diff options
Diffstat (limited to 'test/resourceExhausted.hs')
-rw-r--r-- | test/resourceExhausted.hs | 35 |
1 files changed, 35 insertions, 0 deletions
diff --git a/test/resourceExhausted.hs b/test/resourceExhausted.hs new file mode 100644 index 00000000..4cdef98e --- /dev/null +++ b/test/resourceExhausted.hs | |||
@@ -0,0 +1,35 @@ | |||
1 | import Control.Concurrent | ||
2 | import System.IO | ||
3 | import System.Mem.Weak | ||
4 | import System.IO.Error | ||
5 | |||
6 | import Network.StreamServer | ||
7 | import Network.Address (getBindAddress) | ||
8 | import DPut | ||
9 | import DebugTag | ||
10 | |||
11 | sesh sock n h = do | ||
12 | s <- hGetContents h | ||
13 | putStr s | ||
14 | |||
15 | main = do | ||
16 | setVerbose XMisc | ||
17 | bind <- getBindAddress "8889" True | ||
18 | serv <- streamServer (withSession sesh) [bind] | ||
19 | |||
20 | wtid <- getAcceptLoopThreadId serv | ||
21 | mtid <- deRefWeak wtid | ||
22 | case mtid of | ||
23 | Nothing -> hPutStrLn stderr "missing accept loop?" | ||
24 | Just tid -> do | ||
25 | threadDelay 1000000 | ||
26 | hPutStrLn stderr "Throwing execption now..." | ||
27 | let -- e = userError "resource exhausted" `ioeSetErrorType` fullErrorType | ||
28 | e = mkIOError fullErrorType "resourceExhausted.hs" Nothing Nothing | ||
29 | throwTo tid e | ||
30 | hPutStrLn stderr "Thrown." | ||
31 | |||
32 | getLine | ||
33 | |||
34 | quitListening serv | ||
35 | return () | ||