@@ -11,13 +11,12 @@ nearby to check out the functions we use.
1111> import Data.Char (isPunctuation, isSpace)
1212> import Data.Monoid (mappend)
1313> import Data.Text (Text)
14−> import Control.Exception (fromException, handle)
14+> import Control.Exception (finally)
1515> import Control.Monad (forM_, forever)
16−> import Control.Concurrent (MVar, newMVar, modifyMVar_, readMVar, forkIO)
16+> import Control.Concurrent (MVar, newMVar, modifyMVar_, readMVar, forkIO, modifyMVar)
1717> import Control.Monad.IO.Class (liftIO)
1818> import qualified Data.Text as T
1919> import qualified Data.Text.IO as T
20−
2120> import qualified Network.WebSockets as WS
2221> import qualified Network.Wai
2322> import qualified Network.Wai.Handler.Warp as Warp
@@ -25,7 +24,9 @@ nearby to check out the functions we use.
2524> import qualified Network.Wai.Application.Static as Static
2625> import Data.FileEmbed (embedDir)
2726
28−We represent a client by his username and a 'WS.Connection'. We will see how we obtain this 'WS.Connection' later on.
27+
28+We represent a client by their username and a `WS.Connection`. We will see how we
29+obtain this `WS.Connection` later on.
2930
3031> type Client = (Text, WS.Connection)
3132
@@ -35,42 +36,41 @@ later on.
3536
3637> type ServerState = [Client]
3738
38−Create a new, initial state
39+Create a new, initial state:
3940
4041> newServerState :: ServerState
4142> newServerState = []
4243
43−Get the number of active clients
44+Get the number of active clients:
4445
4546> numClients :: ServerState -> Int
4647> numClients = length
4748
48−Check if a user already exists (based on username)
49+Check if a user already exists (based on username):
4950
5051> clientExists :: Client -> ServerState -> Bool
5152> clientExists client = any ((== fst client) . fst)
5253
53−Add a client (first, you should verify the client is not already connected using
54−'clientExists')
54+Add a client (this does not check if the client already exists, you should do
55+this yourself using `clientExists`):
5556
5657> addClient :: Client -> ServerState -> ServerState
5758> addClient client clients = client : clients
5859
59−Remove a client
60+Remove a client:
6061
6162> removeClient :: Client -> ServerState -> ServerState
6263> removeClient client = filter ((/= fst client) . fst)
6364
64−Send a message to all clients, and log it on stdout.
65+Send a message to all clients, and log it on stdout:
6566
6667> broadcast :: Text -> ServerState -> IO ()
6768> broadcast message clients = do
6869> T.putStrLn message
69−> forM_ clients $ \(_, conn) -> forkIO $ WS.sendTextData conn message
70+> forM_ clients $ \(_, conn) -> WS.sendTextData conn message
7071
7172The main function first creates a new state for the server, then spawns the
72−actual server. For this purpose, we use the simple server provided by
73−'WS.runServer'.
73+actual server.
7474
7575> main :: IO ()
7676> main = do
@@ -83,25 +83,37 @@ actual server. For this purpose, we use the simple server provided by
8383> staticApp :: Network.Wai.Application
8484> staticApp = Static.staticApp $ Static.embeddedSettings $(embedDir "static")
8585
86−When a client connects, we accept the connection, regardless of the path.
86+Our main application has the type:
8787
8888> application :: MVar ServerState -> WS.ServerApp
89+
90+Note that `WS.ServerApp` is nothing but a type synonym for
91+`WS.PendingConnection -> IO ()`.
92+
93+Our application starts by accepting the connection. In a more realistic
94+application, you probably want to check the path and headers provided by the
95+pending request.
96+
97+We also fork a pinging thread in the background. This will ensure the connection
98+stays alive on some browsers.
99+
89100> application state pending = do
90101> conn <- WS.acceptRequest pending
102+> WS.forkPingThread conn 30
91103
92104When a client is succesfully connected, we read the first message. This should
93−be in the format of "Hi, I am Jasper", where Jasper is the requested username.
105+be in the format of "Hi! I am Jasper", where Jasper is the requested username.
94106
95107> msg <- WS.receiveData conn
96108> clients <- liftIO $ readMVar state
97109> case msg of
98110
99−Check that the first message has the right format
111+Check that the first message has the right format:
100112
101113> _ | not (prefix `T.isPrefixOf` msg) ->
102114> WS.sendTextData conn ("Wrong announcement" :: Text)
103115
104−Check the validity of the username
116+Check the validity of the username:
105117
106118> | any ($ fst client)
107119> [T.null, T.any isPunctuation, T.any isSpace] ->
@@ -109,14 +121,15 @@ Check the validity of the username
109121> "contain punctuation or whitespace, and " `mappend`
110122> "cannot be empty" :: Text)
111123
112−Check that the given username is not already taken
124+Check that the given username is not already taken:
113125
114126> | clientExists client clients ->
115127> WS.sendTextData conn ("User already exists" :: Text)
116128
117−All is right!
129+All is right! We're going to allow the client, but for safety reasons we *first*
130+setup a `disconnect` function that will be run when the exception is closed.
118131
119−> | otherwise -> do
132+> | otherwise -> flip finally disconnect $ do
120133
121134We send a "Welcome!", according to our own little protocol. We add the client to
122135the list and broadcast the fact that he has joined. Then, we give control to the
@@ -131,22 +144,19 @@ the list and broadcast the fact that he has joined. Then, we give control to the
131144> return s'
132145> talk conn state client
133146> where
134−> prefix = "Hi! I am "
135−> client = (T.drop (T.length prefix) msg, conn)
147+> prefix = "Hi! I am "
148+> client = (T.drop (T.length prefix) msg, conn)
149+> disconnect = do
150+> -- Remove client and return new state
151+> s <- modifyMVar state $ \s ->
152+> let s' = removeClient client s in return (s', s')
153+> broadcast (fst client `mappend` " disconnected") s
136154
137155The talk function continues to read messages from a single client until he
138156disconnects. All messages are broadcasted to the other clients.
139157
140158> talk :: WS.Connection -> MVar ServerState -> Client -> IO ()
141−> talk conn state client@(user, _) = handle catchDisconnect $
142−> forever $ do
143−> msg <- WS.receiveData conn
144−> liftIO $ readMVar state >>= broadcast
145−> (user `mappend` ": " `mappend` msg)
146−> where
147−> catchDisconnect e = case fromException e of
148−> Just WS.ConnectionClosed -> liftIO $ modifyMVar_ state $ \s -> do
149−> let s' = removeClient client s
150−> broadcast (user `mappend` " disconnected") s'
151−> return s'
152−> _ -> return ()
159+> talk conn state (user, _) = forever $ do
160+> msg <- WS.receiveData conn
161+> liftIO $ readMVar state >>= broadcast
162+> (user `mappend` ": " `mappend` msg)