@@ -1,11 +1,17 @@
1+websockets example
2+==================
3+
14This is the Haskell implementation of the example for the WebSockets library. We
2−implement a simple multi-user chat program.
5+implement a simple multi-user chat program. A live demo of the example is
6+available [here](http://jaspervdj.be/websockets-example). In order to understand
7+this example, keep the [reference](http://jaspervdj.be/websockets/reference)
8+nearby to check out the functions we use.
39
4−> {-# LANGUAGE OverloadedStrings #-}
5−> {-# LANGUAGE TemplateHaskell #-}
10+> {-# LANGUAGE OverloadedStrings, TemplateHaskell #-}
611> import Data.Char (isPunctuation, isSpace)
712> import Data.Monoid (mappend)
813> import Data.Text (Text)
14+> import Control.Exception (fromException)
915> import Control.Monad (forM_)
1016> import Control.Concurrent (MVar, newMVar, modifyMVar_, readMVar)
1117> import Control.Monad.IO.Class (liftIO)
@@ -20,9 +26,13 @@ implement a simple multi-user chat program.
2026> import Data.FileEmbed (embedDir)
2127
2228We represent a client by his username and a 'WS.Sender'. We can use this sender
23−to asynchronously send 'Text' to the client later.
29+to asynchronously send 'Text' to the client later. Note that using `WS.Hybi00`
30+here does not imply that our server is only compatible with the `hybi-00`
31+version of the protocol, for more details on this, see the
32+[Network.WebSockets](http://jaspervdj.be/websockets/reference/Network-WebSockets.html)
33+reference.
2434
25−> type Client = (Text, WS.Sender Text)
35+> type Client = (Text, WS.Sink WS.Hybi00)
2636
2737The state kept on the server is simply a list of connected clients. We've added
2838an alias and some utility functions, so it will be easier to extend this state
@@ -61,7 +71,7 @@ Send a message to all clients, and log it on stdout.
6171> broadcast :: Text -> ServerState -> IO ()
6272> broadcast message clients = do
6373> T.putStrLn message
64−> forM_ clients $ \(_, sender) -> sender WS.textData message
74+> forM_ clients $ \(_, sink) -> WS.sendSink sink $ WS.textData message
6575
6676The main function first creates a new state for the server, then spawns the
6777actual server. For this purpose, we use the simple server provided by
@@ -73,7 +83,7 @@ actual server. For this purpose, we use the simple server provided by
7383> state <- newMVar newServerState
7484> Warp.runSettings Warp.defaultSettings
7585> { Warp.settingsPort = 9160
76−> , Warp.settingsIntercept = WaiWS.intercept (webSocketsApp state)
86+> , Warp.settingsIntercept = WaiWS.intercept (application state)
7787> } staticApp
7888
7989> staticApp :: Network.Wai.Application
@@ -81,84 +91,80 @@ actual server. For this purpose, we use the simple server provided by
8191> { Static.ssFolder = Static.embeddedLookup $ Static.toEmbedded $(embedDir "static")
8292> }
8393
84−> webSocketsApp :: MVar ServerState -> WS.WebSockets ()
85−> webSocketsApp state = do
94+When a client connects, we accept the connection, regardless of the path.
8695
87−When a client connects, we first obtain the request. Once we have that, we use
88−the 'WS.handshake' function to generate a response, which we finally send to the
89−client.
96+> application :: MVar ServerState -> WS.Request -> WS.WebSockets WS.Hybi00 ()
97+> application state rq = do
98+> WS.acceptRequest rq
9099
91−We use irrefutable pattern matches here because the server will spawn a thread
92−for each connection -- and a crashing thread does not effect the rest of the
93−program. For a real application, proper logging is appropriate.
100+We log some information here: in particular, we are interested in the protocol
101+version our client is using (for debugging purposes).
94102
95−> Just rq <- WS.receiveRequest
96−> let Right rsp = WS.handshake rq
97−> WS.sendResponse rsp
103+> WS.getVersion >>= liftIO . putStrLn . ("Client version: " ++)
98104
99105If we want to be able to send data to this client later, from another thread, we
100−obtain a sender. We will add this to the server state later.
106+obtain a sink. We will add this to the server state later.
101107
102−> sender <- WS.getSender
108+> sink <- WS.getSink
103109
104110When a client is succesfully connected, we read the first message. This should
105111be in the format of "Hi, I am Jasper", where Jasper is the requested username.
106112
107−> msg <- WS.receiveData
108−> clients <- liftIO $ readMVar state
109−> case msg of
110−> Nothing -> return ()
111−> Just m
113+> msg <- WS.receiveData
114+> clients <- liftIO $ readMVar state
115+> case msg of
112116
113117Check that the first message has the right format
114118
115−> | not (prefix `T.isPrefixOf` m) ->
116−> WS.sendTextData ("Wrong announcement" :: Text)
119+> _ | not (prefix `T.isPrefixOf` msg) ->
120+> WS.sendTextData ("Wrong announcement" :: Text)
117121
118122Check the validity of the username
119123
120−> | any ($ fst client)
121−> [T.null, T.any isPunctuation, T.any isSpace] ->
122−> WS.sendTextData ("Name cannot " `mappend`
123−> "contain punctuation or whitespace, and " `mappend`
124−> "cannot be empty" :: Text)
124+> | any ($ fst client)
125+> [T.null, T.any isPunctuation, T.any isSpace] ->
126+> WS.sendTextData ("Name cannot " `mappend`
127+> "contain punctuation or whitespace, and " `mappend`
128+> "cannot be empty" :: Text)
125129
126130Check that the given username is not already taken
127131
128−> | clientExists client clients ->
129−> WS.sendTextData ("User already exists" :: Text)
132+> | clientExists client clients ->
133+> WS.sendTextData ("User already exists" :: Text)
130134
131135All is right!
132136
133−> | otherwise -> do
137+> | otherwise -> do
134138
135139We send a "Welcome!", according to our own little protocol. We add the client to
136140the list and broadcast the fact that he has joined. Then, we give control to the
137141'talk' function.
138142
139−> liftIO $ modifyMVar_ state $ \s -> do
140−> let s' = addClient client s
141−> sender WS.textData $ "Welcome! Users: " `mappend`
142−> T.intercalate ", " (map fst s)
143−> broadcast (fst client `mappend` " joined") s'
144−> return s'
145−> talk state client
146−> where
147−> prefix = "Hi! I am "
148−> client = (T.drop (T.length prefix) m, sender)
143+> liftIO $ modifyMVar_ state $ \s -> do
144+> let s' = addClient client s
145+> WS.sendSink sink $ WS.textData $
146+> "Welcome! Users: " `mappend`
147+> T.intercalate ", " (map fst s)
148+> broadcast (fst client `mappend` " joined") s'
149+> return s'
150+> talk state client
151+> where
152+> prefix = "Hi! I am "
153+> client = (T.drop (T.length prefix) msg, sink)
149154
150155The talk function continues to read messages from a single client until he
151156disconnects. All messages are broadcasted to the other clients.
152157
153−> talk :: MVar ServerState -> Client -> WS.WebSockets ()
154−> talk state client@(user, _) = do
158+> talk :: WS.Protocol p => MVar ServerState -> Client -> WS.WebSockets p ()
159+> talk state client@(user, _) = flip WS.catchWsError catchDisconnect $ do
155160> msg <- WS.receiveData
156−> case msg of
157−> Nothing -> liftIO $ modifyMVar_ state $ \s -> do
161+> liftIO $ readMVar state >>= broadcast
162+> (user `mappend` ": " `mappend` msg)
163+> talk state client
164+> where
165+> catchDisconnect e = case fromException e of
166+> Just WS.ConnectionClosed -> liftIO $ modifyMVar_ state $ \s -> do
158167> let s' = removeClient client s
159168> broadcast (user `mappend` " disconnected") s'
160169> return s'
161−> Just m -> do
162−> liftIO $ readMVar state >>= broadcast
163−> (user `mappend` ": " `mappend` m)
164−> talk state client
170+> _ -> return ()