echo.hs

module Main where

import Network
import Control.Monad (forever)
import Data.Function (fix)
import Control.Exception (try)
import System.IO
import Data.IORef
import Control.Concurrent (forkIO)

main = do
  server <- listenOn (PortNumber 1234)
  nextClientId <- newIORef 0
  forever $ do
    (client, _, _) <- accept server
    clientId <- readIORef nextClientId
    modifyIORef nextClientId (+1)
    forkIO (handleConnection client clientId)

handleConnection :: Handle -> Integer -> IO ()
handleConnection client clientId = do
  let log x y = putStrLn (show x ++ ": " ++ y)
  log clientId "connected"
  fix $ \loop -> do
    message <- try (hGetLine client) :: IO (Either IOError String)
    case message of
      Left _    -> log clientId (" client left")
      Right msg -> do
        log clientId (" received " ++ msg)
        hPutStrLn client msg
        loop