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)