Hi, I have taken a crack at this. The best thing would be not to use the asynchronous exceptions to signal the thread that calls accept. And use STM more, since the exception semantics are much easier to get right. But a few minor changes gets closer to what you want. First, the main problem you claim to run into is
Except that, whoops, the "takeMVar" in the accept thread code which updates the childrenDone" MVar is also interruptible. So now I'm getting an interruption right where I don't want it, when I'm updating my data structure.
Short version: There is no problem because it will not become interruptible. Long version: The takeMVar unblocks exceptions only if it must stop and wait for the MVar. The MVar is only taken by this command/thread and during graceful shutdown after this thread is dead. So this MVar should never be in contention (and in theory does not *need* to be a locked MVar, and an IORef would do). See http://citeseer.ist.psu.edu/415348.html for why I think takeMVar only allow exceptions if the MVar is unavailable. The biggest change is ensuring the accepting thread puts to acceptLoopDone by using finally. Many things might kill that thread; it is best to ensure it lets the main thread know that it is dead. More subtlety, I added "unblock (return ())" before accept. This makes it look for the asynchronous exception even when an incoming connection would be immediately available. Otherwise a busy server would never notice the exception! As a style point: there is an ugly moment between takeMVar and putMVar in which you state is inconsistent (being inside block makes it safe though). So I changed this to modifyMVar_ which is better practice.
import Control.Concurrent import Control.Concurrent.MVar import Control.Exception as Exception import Network.Socket import Data.Typeable import System.IO
-- A ConnectionHandler is a function which handles an incoming -- client connection. The handler is run in its own thread, and is -- passed a handle to the client socket. The handler does whatever -- communication it wants to do with the client, and when it returns, -- the client socket handle is closed and the thread terminates. -- A list of active handlers is kept, and the client connection is -- also marked as finished when the handler returns.
type ConnectionHandler = Handle -> IO ()
example_connection_handler :: ConnectionHandler
example_connection_handler handle = do hPutStrLn handle "Hello." hPutStrLn handle "Goodbye."
type ChildrenDone = MVar [MVar ()]
data ExitGracefully = ExitGracefully deriving Typeable
waitForChildren :: ChildrenDone -> IO ()
waitForChildren childrenDone = do cs <- takeMVar childrenDone mapM_ takeMVar cs
shutdownServer :: MVar () -> ChildrenDone -> ThreadId -> IO ()
shutdownServer acceptLoopDone childrenDone acceptThreadId = do throwDynTo acceptThreadId ExitGracefully takeMVar acceptLoopDone -- There can be no more changes to childrenDone waitForChildren childrenDone return ()
acceptConnections :: MVar () -> ChildrenDone -> ConnectionHandler -> Socket -> IO ()
acceptConnections acceptLoopDone childrenDone connectionHandler sock = finially (acceptConnections' acceptLoopDone childrenDone connectionHandler sock) (putStrLn "accept loop exiting" >> putMVar acceptLoopDone () ) -- run last
-- This only looks for exceptions when "accept sock" is executed acceptConnections' acceptLoopDone childrenDone connectionHandler sock = block loop where loop = do unblock (return ()) -- safe point to be interrupted, so unblock (clientSocket, addr) <- accept sock -- may or may not unblock and wait clientHandle <- socketToHandle clientSocket ReadWriteMode childDone <- newEmptyMVar forkIO $ handleConnection childDone connectionHandler clientHandle modifyMVar_ childrenDone (return . (childDone:)) -- non-blocking atomic change to MVar loop
handleConnection childDone connectionHandler clientHandle = do Exception.catch (finially (connectionHandler clientHandle) (hClose clientHandle >> putMVar childDone () )
-- TODO we'll want to do something better when -- connectionHandler throws an exception, but -- for now we'll at least display the exception. (\e -> do { putStrLn $ show e; return () })