Fixed resource-exhausted logic.

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 @@
+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 <- streamServer (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 ()