Difference between revisions of "Implement a chat server"

From HaskellWiki
Jump to: navigation, search
m (embed thumbnail instead)
m (fix spelling)
 
(30 intermediate revisions by 10 users not shown)
Line 1: Line 1:
 
[[Category:Tutorials]]
 
[[Category:Tutorials]]
  +
[[Category:Code]]
 
== Introduction ==
 
== 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.
+
This page describes how to implement a simple chat server which can be connected to with telnet for basic chatting functionality. The server should support multiple connected users. Messages sent to the server are broadcast to all currently connected users. For this tutorial we'll use [https://hackage.haskell.org/package/network-2.6.2.1/docs/Network-Socket.html Network.Socket], which provides low-level bindings to the C-socket API.
  +
  +
Ultimately, our cabal file will hinge on an <hask>executable</hask> section which might look like the following:
   
== Trivial server ==
 
We start with a trivial server.
 
 
<haskell>
 
<haskell>
  +
executable chat-server-exe
  +
hs-source-dirs: app
  +
main-is: Main.hs
  +
ghc-options: -threaded -rtsopts -with-rtsopts=-N
  +
build-depends: base, network
  +
default-language: Haskell2010
  +
</haskell>
  +
  +
== Simple socket server ==
  +
We start with a simple server. The structure of this server begins with a <hask>main</hask> method which will create a reusable socket, open up a TCP connection on port 4242 which will allow a maximum of two queued connections.
  +
  +
<haskell>
  +
-- in Main.hs
  +
module Main where
  +
 
import Network.Socket
 
import Network.Socket
   
 
main :: IO ()
 
main :: IO ()
 
main = do
 
main = do
-- create socket
+
sock <- socket AF_INET Stream 0 -- create socket
sock <- socket AF_INET Stream 0
+
setSocketOption sock ReuseAddr 1 -- make socket immediately reusable - eases debugging.
-- make socket immediately reusable - eases debugging.
+
bind sock (SockAddrInet 4242 iNADDR_ANY) -- listen on TCP port 4242.
setSocketOption sock ReuseAddr 1
+
listen sock 2 -- set a max of 2 queued connections
-- listen on TCP port 4242
+
mainLoop sock -- unimplemented
bindSocket sock (SockAddrInet 4242 iNADDR_ANY)
+
-- allow a maximum of 2 outstanding connections
+
</haskell>
listen sock 2
+
mainLoop sock
+
In our main loop we'll build out the socket-server equivalent of a "Hello World!" example. For a given socket we'll: accept a connection, relay a simple "Hello World!", close the connection, and recurse on the original socket.
  +
  +
<haskell>
  +
-- in Main.hs
   
 
mainLoop :: Socket -> IO ()
 
mainLoop :: Socket -> IO ()
 
mainLoop sock = do
 
mainLoop sock = do
-- accept one connection and handle it
+
conn <- accept sock -- accept a connection and handle it
conn <- accept sock
+
runConn conn -- run our server's logic
runConn conn
+
mainLoop sock -- repeat
mainLoop sock
 
   
 
runConn :: (Socket, SockAddr) -> IO ()
 
runConn :: (Socket, SockAddr) -> IO ()
 
runConn (sock, _) = do
 
runConn (sock, _) = do
send sock "Hi!\n"
+
send sock "Hello!\n"
sClose sock
+
close sock
 
</haskell>
 
</haskell>
   
This server creates a socket for listening on port 4242, and sends a single
 
  +
line to everyone who connects.
 
  +
Notice that accepting a socket has a return type of <hask>(Socket, SockAddr)</hask> — this corresponds to a new socket object which can be used to send and receive data for a given connection. This socket object is then closed at the end of our <hask>runConn</hask> method.
  +
  +
The <hask>SockAddr</hask>, as you can see from the <hask>runConn</hask> method, is largely uninteresting for this use-case and will simply be the initial socket address of 4242.
   
 
== Using System.IO for sockets ==
 
== Using System.IO for sockets ==
<hask>System.IO</hask> functions for input and output are much more convenient than those that <hask>Network.Socket</hask> provides. We can turn a <hask>Socket</hask> into a <hask>Handle</hask> as follows:
 
  +
<hask>Network.Socket</hask> incorrectly represents binary data in <hask>send</hask> and <hask>recv</hask> and, as a result, use of these functions is not advised and may lead to bugs. <hask>Network.Socket</hask> actually recommends using these same methods defined in the ByteString module. However, to keep things simple, we'll stick to <hask>System.IO</hask> for input and output.
  +
  +
Importing our new module and turning our <hask>Socket</hask> into a <hask>Handle</hask> now looks like the following:
   
 
<haskell>
 
<haskell>
  +
-- in the imports our Main.hs add:
 
import System.IO
 
import System.IO
[...]
 
  +
  +
-- and we'll change our `runConn` function to look like:
  +
runConn :: (Socket, SockAddr) -> IO ()
 
runConn (sock, _) = do
 
runConn (sock, _) = do
 
hdl <- socketToHandle sock ReadWriteMode
 
hdl <- socketToHandle sock ReadWriteMode
 
hSetBuffering hdl NoBuffering
 
hSetBuffering hdl NoBuffering
putStrLn sock "Hi!"
+
hPutStrLn hdl "Hello!"
hClose sock
+
hClose hdl
 
</haskell>
 
</haskell>
   
 
== Concurrency ==
 
== 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 <hask>forkIO</hask>:
+
So far the server can only handle one connection at a time. This is enough if all we want to do is have a read stream of messages, but it won't be enough if we want to have our server handle chat.
  +
  +
[https://hackage.haskell.org/package/base-4.8.2.0/docs/Control-Concurrent.html Control.Concurrent] is a library in Prelude which does an excellent job of lightweight thread creation and context switching. You are encouraged to check out the hackage page. To handle each user in our chat client, we'll use <hask>forkIO</hask> to create a new thread for each connection. Notice that the signature of <hask>forkIO</hask> is:
   
 
<haskell>
 
<haskell>
  +
forkIO :: IO () -> IO ThreadId
  +
</haskell>
  +
  +
However, as we don't need the thread's id, we'll ignore the result.
  +
  +
<haskell>
  +
-- add to our imports:
 
import Control.Concurrent
 
import Control.Concurrent
[...]
 
  +
  +
-- and in our mainLoop function...
 
mainLoop sock = do
 
mainLoop sock = do
 
conn <- accept sock
 
conn <- accept sock
forkIO (runConn conn)
+
forkIO (runConn conn) -- split off each connection into its own thread
 
mainLoop sock
 
mainLoop sock
 
</haskell>
 
</haskell>
   
 
== Adding communication between threads ==
 
== Adding communication between threads ==
This seems to be a hard problem. Luckily, the <hask>Control.Concurrent.Chan</hask> 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:
 
  +
We'll need some way for two connections, which we've just split into separate threads, to communicate. At first, this might seem a hard problem — requiring us to manage our own event handler / pub-sub implementation as well as start to cover topics such as MVar, TVar, TMVar, and their use-cases. However, we'll let you delve into that at your own pace and will stick to using the <hask>Control.Concurrent.Chan</hask> module which can take care of all of this for us.
  +
  +
[https://hackage.haskell.org/package/base-4.10.0.0/docs/Control-Concurrent-Chan.html Control.Concurrent.Chan] provides exactly what we need: unbounded FIFO channels with a single write and multiple read ends. It's a very simple module where we'll take advantage of the abstract <hask>Chan</hask> datatype: <hask>data Chan a</hask>
  +
  +
Notice that this datatype has a [https://en.wikipedia.org/wiki/Kind_%28type_theory%29 kind] of <hask>* -> *</hask>. To make this datatype concrete, we'll need to decide on a message type. This can be anything serializable, so to keep things simple we'll use <hask>String</hask> and create a type alias of <hask>Msg</hask> to make things a little more semantic.
  +
   
 
<haskell>
 
<haskell>
  +
-- in Main.hs
 
type Msg = String
 
type Msg = String
 
</haskell>
 
</haskell>
   
<hask>main</hask> will have to create a channel, and pass it to <hask>mainLoop</hask>.
 
  +
  +
We do not need to explicitly import the module because it is imported by <hask>Control.Concurrent</hask>. To ensure that all of our socket connections are running in the same channel, we'll have <hask>main</hask> create it and pass it to <hask>mainLoop</hask> which will, in turn, pass the channel to each thread in <hask>runConn</hask>. We'll adjust our code as follows:
  +
   
 
<haskell>
 
<haskell>
import Control.Concurrent.Chan
 
[...]
 
 
main = do
 
main = do
[...]
+
-- [...]
chan <- newChan
+
chan <- newChan -- notice that newChan :: IO (Chan a)
mainLoop sock chan
+
mainLoop sock chan -- pass it into the loop
</haskell>
 
   
<hask>mainLoop</hask> in turn will pass it to <hask>runConn</hask>.
 
  +
-- later, in mainLoop:
   
<haskell>
 
  +
mainLoop :: Socket -> Chan Msg -> IO () -- See how Chan now uses Msg.
mainLoop :: Socket -> Chan Msg -> IO ()
 
 
mainLoop sock chan = do
 
mainLoop sock chan = do
 
conn <- accept sock
 
conn <- accept sock
forkIO (runConn conn chan nr)
+
forkIO (runConn conn chan) -- pass the channel to runConn
 
mainLoop sock chan
 
mainLoop sock chan
 
</haskell>
 
</haskell>
   
And finally, <hask>runConn</hask> will duplicate the channel and read from it.
 
  +
  +
At this point, we want to have <hask>runConn</hask> duplicate the channel in order to communicate with it. First, we'll need a couple of helpers, [https://hackage.haskell.org/package/base-4.10.0.0/docs/Prelude.html#v:fmap fmap] and [https://hackage.haskell.org/package/base-4.8.2.0/docs/Control-Monad-Fix.html fix]. In short, <hask>fmap</hask> allows us to elegantly lift a function over some structure, while <hask>fix</hask> allows us to define a Monadic fixpoint.
  +
   
 
<haskell>
 
<haskell>
import Control.Monad
 
  +
-- at the top of Main.hs
 
import Control.Monad.Fix (fix)
 
import Control.Monad.Fix (fix)
[...]
 
  +
</haskell>
runConn :: (Socket, SockAddr) -> Chan Msg -> -> IO ()
 
  +
  +
From <hask>Control.Concurrent.Chan</hask> we'll use some simple functions which are self-explanatory: <hask>writeChan</hask>, <hask>readChan</hask>, and <hask>dupChan</hask>. Of note, <hask>dupChan</hask> will create a new channel which will start empty and have any data written to either it or the original be available from both locations. This creates a way to broadcast messages.
  +
  +
<haskell>
  +
runConn :: (Socket, SockAddr) -> Chan Msg -> IO ()
 
runConn (sock, _) chan = do
 
runConn (sock, _) chan = do
 
let broadcast msg = writeChan chan msg
 
let broadcast msg = writeChan chan msg
 
hdl <- socketToHandle sock ReadWriteMode
 
hdl <- socketToHandle sock ReadWriteMode
 
hSetBuffering hdl NoBuffering
 
hSetBuffering hdl NoBuffering
chan' <- dupChan chan
+
commLine <- dupChan chan
-- fork off thread for reading from the duplicated channel
+
  +
-- fork off a thread for reading from the duplicated channel
 
forkIO $ fix $ \loop -> do
 
forkIO $ fix $ \loop -> do
line <- readChan chan'
+
line <- readChan commLine
 
hPutStrLn hdl line
 
hPutStrLn hdl line
-- read lines from socket and echo them back to the user
 
  +
loop
  +
  +
-- read lines from the socket and echo them back to the user
 
fix $ \loop -> do
 
fix $ \loop -> do
line <- liftM init (hGetLine hdl)
+
line <- fmap init (hGetLine hdl)
 
broadcast line
 
broadcast line
 
loop
 
loop
 
</haskell>
 
</haskell>
   
Note that <hask>runConn</hask> now actually forks another worker thread for sending messages to the connected user.
+
Notice how <hask>runConn</hask>, running in a separate thread from our main one, now forks <i>another</i> worker thread for sending messages to the connected user.
   
 
== Cleanups and final code ==
 
== Cleanups and final code ==
[[Image:chat_server_screenshot.png|thumb|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.
 
  +
There are two major problems left in the code. The first is the fact that the code has a [[memory leak]] because the original channel is never read by anyone. We can fix this by adding another thread just so that people have access to this channel.
   
The code below fixes the first issue and mostly fixes the second one, and adds a few cosmetic improvements:
+
The second issue is that we do not gracefully close our connections. This will require exception handling. Next we'll fix the first issue, handle the second case to a larger extend, and add the following cosmetic improvements:
  +
  +
* Make messages get echoed back to the user that sent them.
  +
* Associate each connection with a name.
  +
* Change <hask>Msg</hask> to alias <hask>(Int, String)</hask> for convenience.
  +
  +
We'll import <hask>Control.Exception</hask> and handle exceptions in our final code, below:
   
* messages are not echoed back to the user they came from.
 
* every connection is associated with a name.
 
   
 
<haskell>
 
<haskell>
-- with apologies for the lack of comments :)
 
  +
-- Main.hs, final code
  +
module Main where
   
 
import Network.Socket
 
import Network.Socket
Line 130: Line 169:
 
import Control.Exception
 
import Control.Exception
 
import Control.Concurrent
 
import Control.Concurrent
import Control.Concurrent.Chan
+
import Control.Monad (when)
import Control.Monad
 
 
import Control.Monad.Fix (fix)
 
import Control.Monad.Fix (fix)
 
type Msg = (Int, String)
 
   
 
main :: IO ()
 
main :: IO ()
 
main = do
 
main = do
chan <- newChan
 
  +
sock <- socket AF_INET Stream 0
sock <- socket AF_INET Stream 0
 
  +
setSocketOption sock ReuseAddr 1
setSocketOption sock ReuseAddr 1
 
  +
bind sock (SockAddrInet 4242 iNADDR_ANY)
bindSocket sock (SockAddrInet 4242 iNADDR_ANY)
 
  +
listen sock 2
listen sock 2
 
  +
chan <- newChan
forkIO $ fix $ \loop -> do
+
_ <- forkIO $ fix $ \loop -> do
(_, msg) <- readChan chan
+
(_, _) <- readChan chan
loop
+
loop
mainLoop sock chan 0
+
mainLoop sock chan 0
  +
  +
type Msg = (Int, String)
   
 
mainLoop :: Socket -> Chan Msg -> Int -> IO ()
 
mainLoop :: Socket -> Chan Msg -> Int -> IO ()
mainLoop sock chan nr = do
+
mainLoop sock chan msgNum = do
conn <- accept sock
+
conn <- accept sock
forkIO (runConn conn chan nr)
+
forkIO (runConn conn chan msgNum)
mainLoop sock chan $! nr+1
+
mainLoop sock chan $! msgNum + 1
   
 
runConn :: (Socket, SockAddr) -> Chan Msg -> Int -> IO ()
 
runConn :: (Socket, SockAddr) -> Chan Msg -> Int -> IO ()
runConn (sock, _) chan nr = do
+
runConn (sock, _) chan msgNum = do
let broadcast msg = writeChan chan (nr, msg)
+
let broadcast msg = writeChan chan (msgNum, msg)
 
hdl <- socketToHandle sock ReadWriteMode
 
hdl <- socketToHandle sock ReadWriteMode
 
hSetBuffering hdl NoBuffering
 
hSetBuffering hdl NoBuffering
  +
 
hPutStrLn hdl "Hi, what's your name?"
 
hPutStrLn hdl "Hi, what's your name?"
name <- liftM init (hGetLine hdl)
+
name <- fmap init (hGetLine hdl)
broadcast ("--> " ++ name ++ " entered.")
+
broadcast ("--> " ++ name ++ " entered chat.")
 
hPutStrLn hdl ("Welcome, " ++ name ++ "!")
 
hPutStrLn hdl ("Welcome, " ++ name ++ "!")
chan' <- dupChan chan
 
  +
  +
commLine <- dupChan chan
  +
  +
-- fork off a thread for reading from the duplicated channel
 
reader <- forkIO $ fix $ \loop -> do
 
reader <- forkIO $ fix $ \loop -> do
(nr', line) <- readChan chan'
+
(nextNum, line) <- readChan commLine
when (nr /= nr') $ hPutStrLn hdl line
+
when (msgNum /= nextNum) $ hPutStrLn hdl line
 
loop
 
loop
handle (\_ -> return ()) $ fix $ \loop -> do
 
  +
line <- liftM init (hGetLine hdl)
 
  +
handle (\(SomeException _) -> return ()) $ fix $ \loop -> do
  +
line <- fmap init (hGetLine hdl)
 
case line of
 
case line of
"quit" -> hPutStrLn hdl "Bye!"
 
  +
-- If an exception is caught, send a message and break the loop
_ -> do
+
"quit" -> hPutStrLn hdl "Bye!"
broadcast (name ++ ": " ++ line)
+
-- else, continue looping.
loop
+
_ -> broadcast (name ++ ": " ++ line) >> loop
killThread reader
+
broadcast ("<-- " ++ name ++ " left.")
+
killThread reader -- kill after the loop ends
hClose hdl
+
broadcast ("<-- " ++ name ++ " left.") -- make a final broadcast
  +
hClose hdl -- close the handle
  +
 
</haskell>
 
</haskell>
   
Have fun chatting!
 
  +
== Run the server and connect with telnet ==
  +
Now that we have a functional server, after building your executable and firing up the server we can start chatting! After running your server, connect to it with telnet like so:
  +
  +
<haskell>
  +
$ telnet localhost 4242
  +
  +
Trying 127.0.0.1...
  +
Connected to localhost.
  +
Escape character is '^]'.
  +
Hi, what's your name?
  +
</haskell>
  +
  +
  +
Remember that to quit telnet, you need to <hask>^]</hask> and run <hask>quit</hask> after dropping into the telnet prompt.
  +
  +
Fire up two clients and have fun chatting!

Latest revision as of 17:02, 3 December 2019

Introduction

This page describes how to implement a simple chat server which can be connected to with telnet for basic chatting functionality. The server should support multiple connected users. Messages sent to the server are broadcast to all currently connected users. For this tutorial we'll use Network.Socket, which provides low-level bindings to the C-socket API.

Ultimately, our cabal file will hinge on an executable section which might look like the following:

executable chat-server-exe
   hs-source-dirs:      app
   main-is:             Main.hs
   ghc-options:         -threaded -rtsopts -with-rtsopts=-N
   build-depends:       base, network
   default-language:    Haskell2010

Simple socket server

We start with a simple server. The structure of this server begins with a main method which will create a reusable socket, open up a TCP connection on port 4242 which will allow a maximum of two queued connections.

-- in Main.hs
module Main where

import Network.Socket

main :: IO ()
main = do
    sock <- socket AF_INET Stream 0    -- create socket
    setSocketOption sock ReuseAddr 1   -- make socket immediately reusable - eases debugging.
    bind sock (SockAddrInet 4242 iNADDR_ANY)   -- listen on TCP port 4242.
    listen sock 2                              -- set a max of 2 queued connections
    mainLoop sock                              -- unimplemented

In our main loop we'll build out the socket-server equivalent of a "Hello World!" example. For a given socket we'll: accept a connection, relay a simple "Hello World!", close the connection, and recurse on the original socket.

-- in Main.hs

mainLoop :: Socket -> IO ()
mainLoop sock = do
    conn <- accept sock     -- accept a connection and handle it
    runConn conn            -- run our server's logic
    mainLoop sock           -- repeat

runConn :: (Socket, SockAddr) -> IO ()
runConn (sock, _) = do
    send sock "Hello!\n"
    close sock


Notice that accepting a socket has a return type of (Socket, SockAddr) — this corresponds to a new socket object which can be used to send and receive data for a given connection. This socket object is then closed at the end of our runConn method.

The SockAddr, as you can see from the runConn method, is largely uninteresting for this use-case and will simply be the initial socket address of 4242.

Using System.IO for sockets

Network.Socket incorrectly represents binary data in send and recv and, as a result, use of these functions is not advised and may lead to bugs. Network.Socket actually recommends using these same methods defined in the ByteString module. However, to keep things simple, we'll stick to System.IO for input and output.

Importing our new module and turning our Socket into a Handle now looks like the following:

-- in the imports our Main.hs add:
import System.IO

-- and we'll change our `runConn` function to look like:
runConn :: (Socket, SockAddr) -> IO ()
runConn (sock, _) = do
    hdl <- socketToHandle sock ReadWriteMode
    hSetBuffering hdl NoBuffering
    hPutStrLn hdl "Hello!"
    hClose hdl

Concurrency

So far the server can only handle one connection at a time. This is enough if all we want to do is have a read stream of messages, but it won't be enough if we want to have our server handle chat.

Control.Concurrent is a library in Prelude which does an excellent job of lightweight thread creation and context switching. You are encouraged to check out the hackage page. To handle each user in our chat client, we'll use forkIO to create a new thread for each connection. Notice that the signature of forkIO is:

forkIO :: IO () -> IO ThreadId

However, as we don't need the thread's id, we'll ignore the result.

-- add to our imports:
import Control.Concurrent

-- and in our mainLoop function...
mainLoop sock = do
    conn <- accept sock
    forkIO (runConn conn)   -- split off each connection into its own thread
    mainLoop sock

Adding communication between threads

We'll need some way for two connections, which we've just split into separate threads, to communicate. At first, this might seem a hard problem — requiring us to manage our own event handler / pub-sub implementation as well as start to cover topics such as MVar, TVar, TMVar, and their use-cases. However, we'll let you delve into that at your own pace and will stick to using the Control.Concurrent.Chan module which can take care of all of this for us.

Control.Concurrent.Chan provides exactly what we need: unbounded FIFO channels with a single write and multiple read ends. It's a very simple module where we'll take advantage of the abstract Chan datatype: data Chan a

Notice that this datatype has a kind of * -> *. To make this datatype concrete, we'll need to decide on a message type. This can be anything serializable, so to keep things simple we'll use String and create a type alias of Msg to make things a little more semantic.


-- in Main.hs
type Msg = String


We do not need to explicitly import the module because it is imported by Control.Concurrent. To ensure that all of our socket connections are running in the same channel, we'll have main create it and pass it to mainLoop which will, in turn, pass the channel to each thread in runConn. We'll adjust our code as follows:


main = do
    -- [...]
    chan <- newChan        -- notice that newChan :: IO (Chan a)
    mainLoop sock chan     -- pass it into the loop

-- later, in mainLoop:

mainLoop :: Socket -> Chan Msg -> IO ()   -- See how Chan now uses Msg.
mainLoop sock chan = do
    conn <- accept sock
    forkIO (runConn conn chan)  -- pass the channel to runConn
    mainLoop sock chan


At this point, we want to have runConn duplicate the channel in order to communicate with it. First, we'll need a couple of helpers, fmap and fix. In short, fmap allows us to elegantly lift a function over some structure, while fix allows us to define a Monadic fixpoint.


-- at the top of Main.hs
import Control.Monad.Fix (fix)

From Control.Concurrent.Chan we'll use some simple functions which are self-explanatory: writeChan, readChan, and dupChan. Of note, dupChan will create a new channel which will start empty and have any data written to either it or the original be available from both locations. This creates a way to broadcast messages.

runConn :: (Socket, SockAddr) -> Chan Msg -> IO ()
runConn (sock, _) chan = do
    let broadcast msg = writeChan chan msg
    hdl <- socketToHandle sock ReadWriteMode
    hSetBuffering hdl NoBuffering
    commLine <- dupChan chan

    -- fork off a thread for reading from the duplicated channel
    forkIO $ fix $ \loop -> do
        line <- readChan commLine
        hPutStrLn hdl line
        loop

    -- read lines from the socket and echo them back to the user
    fix $ \loop -> do
        line <- fmap init (hGetLine hdl) 
        broadcast line
        loop

Notice how runConn, running in a separate thread from our main one, now forks another worker thread for sending messages to the connected user.

Cleanups and final code

There are two major problems left in the code. The first is the fact that the code has a memory leak because the original channel is never read by anyone. We can fix this by adding another thread just so that people have access to this channel.

The second issue is that we do not gracefully close our connections. This will require exception handling. Next we'll fix the first issue, handle the second case to a larger extend, and add the following cosmetic improvements:

  • Make messages get echoed back to the user that sent them.
  • Associate each connection with a name.
  • Change Msg to alias (Int, String) for convenience.

We'll import Control.Exception and handle exceptions in our final code, below:


-- Main.hs, final code
module Main where

import Network.Socket
import System.IO
import Control.Exception
import Control.Concurrent
import Control.Monad (when)
import Control.Monad.Fix (fix)

main :: IO ()
main = do
  sock <- socket AF_INET Stream 0
  setSocketOption sock ReuseAddr 1
  bind sock (SockAddrInet 4242 iNADDR_ANY)
  listen sock 2
  chan <- newChan
  _ <- forkIO $ fix $ \loop -> do
    (_, _) <- readChan chan
    loop
  mainLoop sock chan 0

type Msg = (Int, String)

mainLoop :: Socket -> Chan Msg -> Int -> IO ()
mainLoop sock chan msgNum = do
  conn <- accept sock
  forkIO (runConn conn chan msgNum)
  mainLoop sock chan $! msgNum + 1

runConn :: (Socket, SockAddr) -> Chan Msg -> Int -> IO ()
runConn (sock, _) chan msgNum = do
    let broadcast msg = writeChan chan (msgNum, msg)
    hdl <- socketToHandle sock ReadWriteMode
    hSetBuffering hdl NoBuffering

    hPutStrLn hdl "Hi, what's your name?"
    name <- fmap init (hGetLine hdl)
    broadcast ("--> " ++ name ++ " entered chat.")
    hPutStrLn hdl ("Welcome, " ++ name ++ "!")

    commLine <- dupChan chan

    -- fork off a thread for reading from the duplicated channel
    reader <- forkIO $ fix $ \loop -> do
        (nextNum, line) <- readChan commLine
        when (msgNum /= nextNum) $ hPutStrLn hdl line
        loop

    handle (\(SomeException _) -> return ()) $ fix $ \loop -> do
        line <- fmap init (hGetLine hdl)
        case line of
             -- If an exception is caught, send a message and break the loop
             "quit" -> hPutStrLn hdl "Bye!"
             -- else, continue looping.
             _      -> broadcast (name ++ ": " ++ line) >> loop

    killThread reader                      -- kill after the loop ends
    broadcast ("<-- " ++ name ++ " left.") -- make a final broadcast
    hClose hdl                             -- close the handle

Run the server and connect with telnet

Now that we have a functional server, after building your executable and firing up the server we can start chatting! After running your server, connect to it with telnet like so:

$ telnet localhost 4242

Trying 127.0.0.1...
Connected to localhost.
Escape character is '^]'.
Hi, what's your name?


Remember that to quit telnet, you need to ^] and run quit after dropping into the telnet prompt.

Fire up two clients and have fun chatting!