Just trying to work out some simple graceful connection handling code in Haskell to get my head around some of the IO/Networking/Threading stuff, some tips where I'm doing things poorly would be appreciated! I'm sure I could just use a module like network pipes that would handle all the graceful stuff for me out of the box, but this was just an exercise to try and understand basic network/multithreaded IO handling in haskell.
import Network import Control.Concurrent import Control.Concurrent.STM import Control.Exception import System.IO type Connection = (Handle, HostName, PortNumber) type ConnectionHandler = Connection -> IO () type Pool = [(ThreadId, Connection)] main = runConn fst' (a,b,c) = a connFromPool (a,(b,c,d)) = b runConn = withSocketsDo $ do s <- (listenOn (PortNumber 1234)) p <- atomically (newTVar (::Pool)) t <- forkIO (repeatAccept s p) repeatUntilExit stdin stdout putChar "" p' <- atomically $ readTVar p mapM_ killThread (t:map fst p') sClose s putStrLn "Enter to exit." >> getLine repeatAccept s p = do c <- accept s t <- forkFinally (echoHandler c) (exitPool p) atomically $ do p' <- readTVar p writeTVar p ((t,c):p') repeatAccept s p exitPool :: TVar Pool -> a -> IO () exitPool pool = \_ -> do tid <- myThreadId print $ "Exiting: " ++ (show tid) p <- (atomically $ readTVar pool) h <- hdl p tid open <- hIsOpen h if open then do hPutStrLn h "bye\n" >> hFlush h >> hClose h else return () atomically $ do pool' <- readTVar pool writeTVar pool $ filter ((/=tid).fst) pool' return () where hdl p tid = return.connFromPool $ head $ filter ((==tid).fst) p echoHandler :: ConnectionHandler echoHandler a@(hdl,_,_) = repeatUntilExit hdl hdl echoToHandleAndStdout "" where echoToHandleAndStdout x = hPutChar hdl x >> putChar x repeatUntilExit :: Handle -> Handle -> (Char -> IO ()) -> [Char] -> IO () repeatUntilExit hIn hOut f "exit\n" = return () repeatUntilExit hIn hOut f x = do c <- hGetChar hIn f c repeatUntilExit hIn hOut f (appendToLastFive c) where appendToLastFive a = (reverse . (:)a . take 4 . reverse) x -- this is just here because I'm using an older version of base which doesn't have it yet forkFinally :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId forkFinally action and_then = mask $ \restore -> forkIO $ try (restore action) >>= and_then