4
\$\begingroup\$

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
\$\endgroup\$
2
\$\begingroup\$

Just one remark: When handling IO resources, I'd strongly suggest using bracket for resources that are obtained at some point and later released. Not only it makes your code much safer, it clearly demarcates which resource is used in which parts. And that also prevents separating opening and closing of resources, which is often a hard-to-find error.

\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.