2 files changed, 43 insertions, 4 deletions

diff --git a/dht/src/Network/StreamServer.hs b/dht/src/Network/StreamServer.hs
index 9a5b8593..1055eaad 100644
--- a/dht/src/Network/StreamServer.hs
+++ b/dht/src/Network/StreamServer.hs
@@ -7,6 +7,7 @@
 module Network.StreamServer
     ( streamServer
     , ServerHandle
+    , getAcceptLoopThreadId
     , ServerConfig(..)
     , withSession
     , quitListening
@@ -49,6 +50,10 @@ import DebugTag
 
 data ServerHandle = ServerHandle Socket (Weak ThreadId)
 
+-- | Useful for testing.
+getAcceptLoopThreadId :: ServerHandle -> IO (Weak ThreadId)
+getAcceptLoopThreadId (ServerHandle _ t) = return t
+
 listenSocket :: ServerHandle -> RestrictedSocket
 listenSocket (ServerHandle sock _) = restrictSocket sock
 
@@ -149,15 +154,14 @@ acceptLoop cfg sock n = handle (acceptException cfg n sock) $ do
 
 acceptException :: ServerConfig -> Int -> Socket -> IOError -> IO ()
 acceptException cfg n sock ioerror = do
-    Socket.close sock
     case show (ioeGetErrorType ioerror) of
-      "resource exhausted" -> do -- try again
+      "resource exhausted" -> do -- try again (ioeGetErrorType ioerror == fullErrorType)
                                  serverWarn cfg $ ("acceptLoop: resource exhasted")
                                  threadDelay 500000
                                  acceptLoop cfg sock (n + 1)
       "invalid argument"   -> do -- quit on closed socket
-                                 return ()
+                                 Socket.close sock
       message              -> do -- unexpected exception
                                  serverWarn cfg $ ("acceptLoop: "<>bshow message)
-                                 return ()
+                                 Socket.close sock
 
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 ()