gistfile1.hs

import System.IO
import System.Posix
import Network
import Network.Socket hiding (accept)
import Data.List
import Control.Monad
import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception hiding (catch)

type Connection = (Handle, HostName, PortNumber)
type ServerState = (TChan String, TVar [Connection])

main = withSocketsDo $ do
    installHandler sigPIPE Ignore Nothing
    sock <- listenOn (PortNumber 9901)
    msgQueue <- newTChanIO
    clients <- newTVarIO []
    let state = (msgQueue, clients)
    forkIO . forever $ broadcast state
    forever $ acceptConnection sock state

acceptConnection :: Socket -> ServerState -> IO ()
acceptConnection sock state@(msgQueue, clients) = do
    putStrLn "Accepting connection..."
    conn@(handle, host, port) <- accept sock
    print conn
    atomically $ do 
        cs <- readTVar clients
        writeTVar clients $ conn : cs
    forkIO $ catch (forever (receiveMsg conn state) `finally` closeConn conn state) (const $ return ())
    return ()

closeConn :: Connection -> ServerState -> IO ()
closeConn conn@(handle, host, port) state@(msgQueue, clients) = do
    putStrLn $ "Closing connection: " ++ show conn
    atomically $ do
        cs <- readTVar clients
        writeTVar clients $ delete conn cs

receiveMsg :: Connection -> ServerState -> IO ()
receiveMsg conn@(handle, host, port) state@(msgQueue, clients) = do
    msg <- hGetLine handle
    let msg' | last msg == '\r' = init msg
             | otherwise = msg
    atomically $ writeTChan msgQueue msg'

broadcast :: ServerState -> IO ()
broadcast state@(msgQueue, clients) = do
    (msg, cs) <- atomically $ liftM2 (,) (readTChan msgQueue) (readTVar clients)
    forM_ cs $ \(handle, host, port) -> do
        hPutStrLn handle $ host ++ ":" ++ show port ++ " said: \"" ++ msg ++ "\""
        hFlush handle