operations with handles hang

[Artem Chuprina]

Hello.

Searching for example of TCP server in Haskell, I found an example close to my
problem.  While most of examples of TCP servers do very simple handling of TCP
requests, in one thread, this one does in a simplified manner what I need -
routes messages between connected clients.

But trying it, I encountered a very strange (for me) behavior.  The example
can be found at http://sequence.complete.org/node/258, and a slightly cleaned
code is below.

An author writes that the code was tested on ghc 6.6 under Linux/x86.  I have
ghc 6.12.1 on Debian GNU/Linux.  My compiler asked me to add type signatures
in second arguments of catch (original code does not have them).

The code works well while no one of the clients is disconnected.  But as one
of the clients disconnects, the server hangs trying to write to its handle,
consuming processor (and it seems that it slowly consumes memory too).

My investigation showed that disconnect is detected by hGetLine, which throws
an exception, and clientLoop in finally closes the handle.  After that
hPutStrLn to its handle in mainLoop hangs.  To me this is a very strange
behavior.  I expected that hPutStrLn to closed handle should throw an
exception.  The original author, it seems, too.

I tried to comment the final hClose in clientLoop.  After that hPutStrLn
stopped to hang, but, strangely, the fact that the client has disconnected is
detected only on the second write (hFlush) after disconnect, not on the
first.  And more, when I insert, say, hIsClosed h before hPutStrLn h in
mainLoop, the server hangs on it, now even not waiting for disconnect, just on
first call to hIsClosed.

Could anyone tell me what is wrong with the code:

module Main where 
import Prelude hiding (catch)
import Network (listenOn, accept, sClose, Socket, 
                withSocketsDo, PortID(..)) 
import System.IO 
import System.Environment (getArgs) 
import Control.Exception (finally, catch) 
import Control.Concurrent 
import Control.Concurrent.STM 
import Control.Monad (forM, filterM, liftM, when)

main = withSocketsDo $ do 
    [portStr] <- getArgs
    let port = fromIntegral (read portStr :: Int) 
    servSock <- listenOn $ PortNumber port 
    putStrLn $ "listening on: " ++ show port 
    start servSock `finally` sClose servSock

start servSock = do 
    acceptChan <- atomically newTChan 
    forkIO $ acceptLoop servSock acceptChan 
    mainLoop servSock acceptChan []

type Client = (TChan String, Handle) 

acceptLoop :: Socket -> TChan Client -> IO () 
acceptLoop servSock chan = do 
    (cHandle, host, port) <- accept servSock 
    cChan <- atomically newTChan 
    cTID <- forkIO $ clientLoop cHandle cChan 
    atomically $ writeTChan chan (cChan, cHandle) 
    acceptLoop servSock chan

clientLoop :: Handle -> TChan String -> IO () 
clientLoop handle chan = 
    listenLoop (hGetLine handle) chan 
                   `catch` (const $ return () :: IOError -> IO ()) 
                   `finally` hClose handle 

listenLoop :: IO a -> TChan a -> IO () 
listenLoop act chan = 
    sequence_ (repeat (act >>= atomically . writeTChan chan))

mainLoop :: Socket -> TChan Client -> [Client] -> IO () 
mainLoop servSock acceptChan clients = do 
    r <- atomically $ (Left `fmap` readTChan acceptChan) 
                      `orElse` 
                      (Right `fmap` tselect clients) 
    case r of 
          Left (ch,h) -> do 
               putStrLn "new client" 
               mainLoop servSock acceptChan $ (ch,h):clients 
          Right (line,_) -> do 
               putStrLn $ "data: " ++ line
               clients' <- forM clients $ 
                            \(ch,h) -> do 
                                hPutStrLn h line 
                                hFlush h 
                                return [(ch,h)] 
                            `catch` (const (hClose h >> return []) :: IOError -> IO [a])
               let dropped = length $ filter null clients' 
               when (dropped > 0) $ 
                   putStrLn ("clients lost: " ++ show dropped) 
               mainLoop servSock acceptChan $ concat clients'

tselect :: [(TChan a, t)] -> STM (a, t) 
tselect = foldl orElse retry 
          . map (\(ch, ty) -> (flip (,) ty) `fmap` readTChan ch)