Implement a chat server
This page describes how to implement a simple chat server. The server should support multiple connected users. Messages sent to the server are broadcast to all currently connected users.
We start with a trivial server.
import Network.Socket main :: IO () main = do -- create socket sock <- socket AF_INET Stream 0 -- make socket immediately reusable - eases debugging. setSocketOption sock ReuseAddr 1 -- listen on TCP port 4242 bindSocket sock (SockAddrInet 4242 iNADDR_ANY) -- allow a maximum of 2 outstanding connections listen sock 2 mainLoop sock mainLoop :: Socket -> IO () mainLoop sock = do -- accept one connection and handle it conn <- accept sock runConn conn mainLoop sock runConn :: (Socket, SockAddr) -> IO () runConn (sock, _) = do send sock "Hi!\n" sClose sock
This server creates a socket for listening on port 4242, and sends a single line to everyone who connects.
Using System.IO for sockets
System.IO functions for input and output are much more convenient than those that
Network.Socket provides. We can turn a
Socket into a
Handle as follows:
import System.IO [...] runConn (sock, _) = do hdl <- socketToHandle sock ReadWriteMode hSetBuffering hdl NoBuffering hPutStrLn hdl "Hi!" hClose hdl
So far the server can only handle one connection at a time. This is ok for just writing a message but won't work for a chat server. We can fix this quite easily though, using
import Control.Concurrent [...] mainLoop sock = do conn <- accept sock forkIO (runConn conn) mainLoop sock
Adding communication between threads
This seems to be a hard problem. Luckily, the
Control.Concurrent.Chan module provides exactly what we need: channels with a single write and multiple read ends. First we decide on a message type. Let's use a string for now:
type Msg = String
main will have to create a channel, and pass it to
import Control.Concurrent.Chan [...] main = do [...] chan <- newChan mainLoop sock chan
mainLoop in turn will pass it to
mainLoop :: Socket -> Chan Msg -> IO () mainLoop sock chan = do conn <- accept sock forkIO (runConn conn chan nr) mainLoop sock chan
runConn will duplicate the channel and read from it.
import Control.Monad import Control.Monad.Fix (fix) [...] runConn :: (Socket, SockAddr) -> Chan Msg -> -> IO () runConn (sock, _) chan = do let broadcast msg = writeChan chan msg hdl <- socketToHandle sock ReadWriteMode hSetBuffering hdl NoBuffering chan' <- dupChan chan -- fork off thread for reading from the duplicated channel forkIO $ fix $ \loop -> do line <- readChan chan' hPutStrLn hdl line loop -- read lines from socket and echo them back to the user fix $ \loop -> do line <- liftM init (hGetLine hdl) broadcast line loop
runConn now actually forks another worker thread for sending messages to the connected user.
Cleanups and final code
There are two major problems left in the code. First, the code has a memory leak, because the original channel is never read by anyone. This can be fixed by adding another thread just for that purpose.
Secondly, closing connections is not handled gracefully at all. This requires exception handling.
The code below fixes the first issue and mostly fixes the second one, and adds a few cosmetic improvements:
- messages are not echoed back to the user they came from.
- every connection is associated with a name.
-- with apologies for the lack of comments :) 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 (\_ -> 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
Have fun chatting!