blob: c38784a5543a99e0e8a17923beac472987fe5ce1 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
|
import Control.Concurrent
import System.IO
import System.Mem.Weak
import System.IO.Error
import Network.StreamServer
import Network.Address (getBindAddress)
import DPut
import DebugTag
sesh sock n h = do
s <- hGetContents h
putStr s
main = do
setVerbose XMisc
bind <- getBindAddress "8889" True
serv <- forkStreamServer (withSession sesh) [bind]
wtid <- getAcceptLoopThreadId serv
mtid <- deRefWeak wtid
case mtid of
Nothing -> hPutStrLn stderr "missing accept loop?"
Just tid -> do
threadDelay 1000000
hPutStrLn stderr "Throwing execption now..."
let -- e = userError "resource exhausted" `ioeSetErrorType` fullErrorType
e = mkIOError fullErrorType "resourceExhausted.hs" Nothing Nothing
throwTo tid e
hPutStrLn stderr "Thrown."
getLine
quitListening serv
return ()
|
