Haskell chat impl

chat-wikipedia.hs

@@ -0,0 +1,54 @@
+-- http://www.haskell.org/haskellwiki/Implement_a_chat_server
+
+import Network.Socket
+import System.IO
+import Control.Exception
+import Control.Concurrent
+import Control.Concurrent.Chan
+import Control.Monad
+import Control.Monad.Fix (fix)
+ 
+type Msg = (Int, String)
+ 
+main :: IO ()
+main = do
+    chan <- newChan
+    sock <- socket AF_INET Stream 0
+    setSocketOption sock ReuseAddr 1
+    bindSocket sock (SockAddrInet 4242 iNADDR_ANY)
+    listen sock 2
+    forkIO $ fix $ \loop -> do
+        (_, msg) <- readChan chan
+        loop
+    mainLoop sock chan 0
+ 
+mainLoop :: Socket -> Chan Msg -> Int -> IO ()
+mainLoop sock chan nr = do
+    conn <- accept sock
+    forkIO (runConn conn chan nr)
+    mainLoop sock chan $! nr+1
+ 
+runConn :: (Socket, SockAddr) -> Chan Msg -> Int -> IO ()
+runConn (sock, _) chan nr = do
+    let broadcast msg = writeChan chan (nr, msg)
+    hdl <- socketToHandle sock ReadWriteMode
+    hSetBuffering hdl NoBuffering
+    hPutStrLn hdl "Hi, what's your name?"
+    name <- liftM init (hGetLine hdl)
+    broadcast ("--> " ++ name ++ " entered.")
+    hPutStrLn hdl ("Welcome, " ++ name ++ "!")
+    chan' <- dupChan chan
+    reader <- forkIO $ fix $ \loop -> do
+        (nr', line) <- readChan chan'
+        when (nr /= nr') $ hPutStrLn hdl line
+        loop
+    handle (\(SomeException _) -> return ()) $ fix $ \loop -> do
+        line <- liftM init (hGetLine hdl)
+        case line of
+         "quit" -> hPutStrLn hdl "Bye!"
+         _      -> do
+            broadcast (name ++ ": " ++ line)
+            loop
+    killThread reader
+    broadcast ("<-- " ++ name ++ " left.")
+    hClose hdl

chat.hs

@@ -0,0 +1,54 @@
+import Network.Socket
+import Data.List
+import System.IO
+import Control.Exception
+import Control.Concurrent
+import Control.Concurrent.STM
+import Control.Monad
+ 
+hGetLineStripped hdl = liftM (filter (not . flip elem "\n\r")) (hGetLine hdl)
+
+main = do
+  index <- newTVarIO []
+  sock <- socket AF_INET Stream 0
+  setSocketOption sock ReuseAddr 1
+  bindSocket sock (SockAddrInet 5999 iNADDR_ANY)
+  listen sock 2
+  mainLoop index sock 0
+
+mainLoop index sock n = do
+  conn <- accept sock
+  forkIO (runConn index conn ("user" ++ show n))
+  mainLoop index sock $! n+1
+ 
+runConn index (sock, _) name = do
+  hdl <- socketToHandle sock ReadWriteMode
+  hSetBuffering hdl NoBuffering
+  handle (\(SomeException _) -> return ()) $ (do arrive index name hdl
+                                                 connLoop index name hdl)
+  depart index name hdl
+  hClose hdl
+
+broadcast str conns = sequence_ $ map sendStr conns
+    where sendStr (_, hdl) = hPutStrLn hdl str
+ 
+arrive index name hdl = do
+  hPutStrLn hdl ("you are " ++ name)
+  old <- atomically $ do old <- readTVar index
+                         writeTVar index ((name, hdl) : old)
+                         return old
+  broadcast (name ++ " arrived") old
+  sequence_ $ map (\ (otherName, _) -> hPutStrLn hdl (otherName ++ " arrived")) old
+
+depart index name hdl = do
+  new <- atomically $ do old <- readTVar index
+                         let new = old \\ [(name, hdl)]
+                         writeTVar index new
+                         return new
+  broadcast (name ++ " departed") new
+
+connLoop index name hdl = do
+  line <- hGetLineStripped hdl
+  curr <- atomically $ readTVar index
+  broadcast (name ++ " says " ++ line) curr
+  connLoop index name hdl