[Haskell] Help needed interrupting accepting a network connection

[Chris Kuklewicz]

Cat Dancer wrote:
>> > 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.
> 
> Oh, OK, you're still using an asynchronous exception to break out of
> the accept (killThread throws a ThreadKilled asynchronous exception to
> the thread), but you're using STM to *signal* the graceful exit
> instead of using the asynchronous exception as the signalling
> mechanism.  Nice.
> 
> Thanks.  My ghc 6.6 (needed for newTVarIO) installation is broken for
> some reason, so I'll need to fix that tomorrow and then I'll be able
> to try your code.

Since newTVarIO is not in unsafePerformIO, you can replace it with
"atomically (newTVar)"

> 
>>  (mv,tid) <- fork (forever (accept socket >>= syncTMVar chan))
> 
> It looks like to me you could get a connection from "accept" but then
> get a ThreadKilled exception before the "syncTMVar chan" executes, and
> then the connection would be left open and hanging until it was
> eventually garbage collected?

Sigh.  I missed that one.  Not bad to fix, just use block and
split syncTMVar, putting the unblocked empty check before the accept.
I also switched to using "cond", a kind of flipped "if".  The new code:

cond true false test = if test then true else false

acceptUntil socket receiver childrenList checker = do
  chan <- newEmptyTMVarIO
  (mv,tid) <- fork . block . forever $ do
    unblock . atomically $
      isEmptyTMVar chan >>= cond (return ()) retry
    client <- accept socket
    atomically (putTMVar chan client)
  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
        readMVar mv
        maybeClient <- atomically (tryTakeTMVar chan)
        maybe (return ()) spawn maybeClient
  finally (handle (\e -> throwTo tid e >> throw e) loop) end

The new code makes sure chan is empty, and so we are sure the putTMVar chan will never
have to wait so it will never unblock (I just wrote and ran short test to confirm this).
I think this is fixed now.