network-2.6.3.4 added an MVar wait to Network.Socket.accept, so it

is important to terminate the accept loop before closing the socket.

1 files changed, 9 insertions, 4 deletions

diff --git a/src/Network/StreamServer.hs b/src/Network/StreamServer.hs
index 7fecc7aa..6a36ed00 100644
--- a/src/Network/StreamServer.hs
+++ b/src/Network/StreamServer.hs
@@ -36,10 +36,14 @@ import System.IO
 import Control.Monad
 import Control.Monad.Fix (fix)
 #ifdef THREAD_DEBUG
-import Control.Concurrent.Lifted.Instrument (forkIO, threadDelay, ThreadId, mkWeakThreadId, labelThread, myThreadId)
+import Control.Concurrent.Lifted.Instrument
+           ( forkIO, threadDelay, ThreadId, mkWeakThreadId, labelThread, myThreadId
+           , killThread )
 #else
 import GHC.Conc (labelThread)
-import Control.Concurrent (forkIO, threadDelay, ThreadId, mkWeakThreadId, myThreadId)
+import Control.Concurrent
+           ( forkIO, threadDelay, ThreadId, mkWeakThreadId, myThreadId
+           , killThread )
 #endif
 import Control.Exception (catch,handle,try,finally)
 import System.IO.Error (tryIOError)
@@ -71,9 +75,10 @@ removeSocketFile _                    = return ()
 
 -- | Terminate the server accept-loop.  Call this to shut down the server.
 quitListening :: ServerHandle -> IO ()
-quitListening (ServerHandle socket _) =
+quitListening (ServerHandle socket acceptThread) =
     finally (Socket.getSocketName socket >>= removeSocketFile)
-            (Socket.close socket)
+            (do mapM_ killThread =<< deRefWeak acceptThread
+                Socket.close socket)
 
 
 -- | It's 'bshow' instead of 'show' to enable swapping in a 'ByteString'