[Haskell] Help needed interrupting accepting a network connection

[Chris Kuklewicz]

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 () })