[Haskell] Help needed interrupting accepting a network connection

[Chris Kuklewicz]

Cat Dancer wrote:
> On 12/2/06, Chris Kuklewicz <haskell at list.mightyreason.com> wrote:
>> 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.
> 
> I'd certainly be most happy not to use asynchronous exceptions as the
> signalling mechanism, but how would you break out of the accept,
> except by receiving an asynchronous exception?
> 

Short Version: You trigger a graceful exit using a TVar...
...and then you use killThread to break out of accept.

Long Version:

{-

The main accepting thread spawns this a slave thread to run accept and
stuffs the result into a TMVar.  The main loop then atomically checks
the TVar used for graceful shutdown and the TMVar.  These two checks
are combined by `orElse` which gives the semantics one wants: on each
loop either the TVar has been set to True or the the slave thread has
accepted a client into the TMVar.

There is still the possibility that a busy server could accept a
connection from the last client and put it in the TMVar where the main
loop will miss it when it exits.  This is handled by the finally
action which waits for the slave thread to be well and truly dead and
then looks for that last client in the TMVar.

No uses of block or unblock are required.

-}

-- Example using STM and orElse to compose a solution
import Control.Concurrent
import Control.Exception
import Control.Concurrent.STM
import Network
import System.IO

runExampleFor socket seconds = do
  tv <- newTVarIO False           -- Set to True to indicate graceful exit requested
  sInfo <- startServer socket tv
  threadDelay (1000*1000*seconds)
  shutdownServer tv sInfo

startServer socket tv = do
  childrenList <- newMVar []
  tInfo <- fork (acceptUntil socket exampleReceiver childrenList (retry'until'true tv))
  return (tInfo,childrenList)

-- Capture idiom of notifying a new MVar when a thread is finished
fork todo = do
  doneMVar <- newEmptyMVar
  tid <- forkIO $ finally todo (putMVar doneMVar ())
  return (doneMVar,tid)

acceptUntil socket receiver childrenList checker = do
  chan <- newEmptyTMVarIO
  (mv,tid) <- fork (forever (accept socket >>= syncTMVar chan))
  let loop = do
        result <- atomically (fmap Left checker `orElse` fmap Right (takeTMVar chan))
        case result of
          Left _ -> return ()
          Right client -> spawn client >> loop
      spawn client@(handle,_,_) = do
        cInfo <- fork (finally (receiver client) (hClose handle))
        modifyMVar_ childrenList (return . (cInfo:))
      end = do
        killThread tid
        takeMVar mv
        maybeClient <- atomically (tryTakeTMVar chan)
        maybe (return ()) spawn maybeClient
  finally (handle (\e -> throwTo tid e >> throw e) loop) end

forever x = x >> forever x

-- Pass item to another thread and wait for pickup
syncTMVar tmv item = do
  atomically (putTMVar tmv item)
  atomically (do empty <- isEmptyTMVar tmv
                 if empty then return () else retry)

retry'until'true tv = do
  val <- readTVar tv
  if val then return ()
         else retry

exampleReceiver (handle,_,_) = do
  hPutStrLn handle "Hello."
  hPutStrLn handle "Goodbye."

shutdownServer tv ((acceptLoopDone,_),childrenList) = do
  atomically (writeTVar tv True)
  readMVar acceptLoopDone
  withMVar childrenList (mapM_ (readMVar . fst))