Cat Dancer wrote: > On 12/2/06, Chris Kuklewicz <[EMAIL PROTECTED]> 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)) _______________________________________________ Haskell mailing list Haskell@haskell.org http://www.haskell.org/mailman/listinfo/haskell