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)