[Haskell] Help needed interrupting accepting a network connection

[Chris Kuklewicz]

I realized there is another problem, since my code holds onto the ThreadId's the thread
data structures may or may not be getting garbage collected and for a long running
server the list of children grows without bound.

So I changed it to periodically clean out the finished child threads from the list
of children.  A simple counter IORef is used to avoid doing the cleanup on each
new child.

There are also a couple of other small style changes.

> {-
> 
> 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.
> 
> The list of child threads is cleaned periodically (currently every
> 10th child), which allows the garbage collected to remove the dead
> threads' structures.
> 
> -}
> 
> -- Example using STM and orElse to compose a solution
> import Control.Monad
> import Control.Concurrent
> import Control.Exception
> import Control.Concurrent.STM
> import Data.IORef
> import Network
> import System.IO
> 
> forever x = x >> forever x
> 
> 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)
> 
> shutdownServer tv ((acceptLoopDone,_),childrenList) = do
>   atomically (writeTVar tv True)
>   readMVar acceptLoopDone
>   withMVar childrenList (mapM_ (readMVar . fst))
> 
> -- 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)
> 
> cond true false test = if test then true else false
> 
> -- This is an asychronous exception safe way to use accept to get one
> -- client at a time and pass them to the parent thread via a TMVar.
> acceptInto socket chan =  block . forever $ do
>   unblock . atomically $
>     isEmptyTMVar chan >>= cond (return ()) retry
>   client <- accept socket
>   atomically (putTMVar chan client)
> 
> -- This demonstrates how to use acceptInto to spawn client thread
> -- running "receiver".  It ends when checker commits instead of using
> -- retry.
> acceptUntil socket receiver childrenList checker = do
>   counter <- newIORef (0::Int) -- who cares if it rolls over?
>   chan <- atomically (newEmptyTMVar)
>   (mv,tid) <- fork (acceptInto socket chan)
>   let loop = atomically (fmap Left checker `orElse` fmap Right (takeTMVar chan))
>              >>= either (const (return ()))    (\client -> spawn client >> loop)
>       spawn client@(handle,_,_) = do
>         cInfo <- fork (finally (receiver client) (hClose handle))
>         count <- readIORef counter
>         writeIORef counter $! (succ count)
>         modifyMVar_ childrenList $ \kids -> fmap (cInfo:) $
>           if count `mod` 10 == 0  -- 10 is arbitrary frequency for cleaning list
>             then return kids
>             else filterM (isEmptyMVar . fst) kids
>       end = do
>         killThread tid
>         readMVar mv
>         atomically (tryTakeTMVar chan) >>= maybe (return ()) spawn
>   finally (handle (\e -> throwTo tid e >> throw e) loop) end
> 
> exampleReceiver (handle,_,_) = do
>   hPutStrLn handle "Hello."
>   hPutStrLn handle "Goodbye."
> 
> retry'until'true tv = (readTVar tv >>= cond (return ()) retry)