From 1e193f42fb51ff2e32b80a1f8ca64df421c30dce Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Thu, 17 Oct 2019 22:48:46 -0400 Subject: Fixed resource-exhausted logic. --- test/resourceExhausted.hs | 35 +++++++++++++++++++++++++++++++++++ 1 file changed, 35 insertions(+) create mode 100644 test/resourceExhausted.hs (limited to 'test') 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 () -- cgit v1.2.3