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)
_______________________________________________
Haskell mailing list
Haskell@haskell.org
http://www.haskell.org/mailman/listinfo/haskell
