[Haskell] Help needed interrupting accepting a network connection
haskell at list.mightyreason.com
Sat Dec 2 20:22:05 EST 2006
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.
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
runExampleFor socket seconds = do
tv <- newTVarIO False -- Set to True to indicate graceful exit requested
sInfo <- startServer socket tv
shutdownServer tv sInfo
startServer socket tv = do
childrenList <- newMVar 
tInfo <- fork (acceptUntil socket exampleReceiver childrenList (retry'until'true tv))
-- Capture idiom of notifying a new MVar when a thread is finished
fork todo = do
doneMVar <- newEmptyMVar
tid <- forkIO $ finally todo (putMVar doneMVar ())
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
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 ()
exampleReceiver (handle,_,_) = do
hPutStrLn handle "Hello."
hPutStrLn handle "Goodbye."
shutdownServer tv ((acceptLoopDone,_),childrenList) = do
atomically (writeTVar tv True)
withMVar childrenList (mapM_ (readMVar . fst))
More information about the Haskell