Personal tools

Implement a chat server

From HaskellWiki

(Difference between revisions)
Jump to: navigation, search
m (fixed a minor bug)
(Changed 'putStrLn' to 'hPutStrLn' in first System IO Example)
Line 46: Line 46:
 
hdl <- socketToHandle sock ReadWriteMode
 
hdl <- socketToHandle sock ReadWriteMode
 
hSetBuffering hdl NoBuffering
 
hSetBuffering hdl NoBuffering
putStrLn hdl "Hi!"
+
hPutStrLn hdl "Hi!"
 
hClose hdl
 
hClose hdl
 
</haskell>
 
</haskell>

Revision as of 07:53, 21 October 2008

Contents

1 Introduction

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.

2 Trivial server

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.

3 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

4 Concurrency

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
forkIO
:
import Control.Concurrent
[...]
mainLoop sock = do
    conn <- accept sock
    forkIO (runConn conn)
    mainLoop sock

5 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
mainLoop
.
import Control.Concurrent.Chan
[...]
main = do
    [...]
    chan <- newChan
    mainLoop sock chan
mainLoop
in turn will pass it to
runConn
.
mainLoop :: Socket -> Chan Msg -> IO ()
mainLoop sock chan = do
    conn <- accept sock
    forkIO (runConn conn chan nr)
    mainLoop sock chan
And finally,
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
Note that
runConn
now actually forks another worker thread for sending messages to the connected user.

6 Cleanups and final code

(thumbnail)
Screenshot :)

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!