Fixed resource-exhausted logic.

1 files changed, 8 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