@@ -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)
@@ -19,9 +25,13 @@ implement a simple multi-user chat program.
1925> import Data.FileEmbed (embedDir)
2026
2127We represent a client by his username and a 'WS.Sender'. We can use this sender
22−to asynchronously send 'Text' to the client later.
28+to asynchronously send 'Text' to the client later. Note that using `WS.Hybi00`
29+here does not imply that our server is only compatible with the `hybi-00`
30+version of the protocol, for more details on this, see the
31+[Network.WebSockets](http://jaspervdj.be/websockets/reference/Network-WebSockets.html)
32+reference.
2333
24−> type Client = (Text, WS.Sender Text)
34+> type Client = (Text, WS.Sink WS.Hybi00)
2535
2636The state kept on the server is simply a list of connected clients. We've added
2737an alias and some utility functions, so it will be easier to extend this state
@@ -60,7 +70,7 @@ Send a message to all clients, and log it on stdout.
6070> broadcast :: Text -> ServerState -> IO ()
6171> broadcast message clients = do
6272> T.putStrLn message
63−> forM_ clients $ \(_, sender) -> sender WS.textData message
73+> forM_ clients $ \(_, sink) -> WS.sendSink sink $ WS.textData message
6474
6575The main function first creates a new state for the server, then spawns the
6676actual server. For this purpose, we use the simple server provided by
@@ -72,90 +82,87 @@ actual server. For this purpose, we use the simple server provided by
7282> state <- newMVar newServerState
7383> Warp.runSettings Warp.defaultSettings
7484> { Warp.settingsPort = 9160
75−> , Warp.settingsIntercept = WaiWS.intercept (webSocketsApp state)
85+> , Warp.settingsIntercept = WaiWS.intercept (application state)
7686> } staticApp
7787
7888> staticApp = Static.staticApp Static.defaultFileServerSettings
7989> { Static.ssFolder = Static.embeddedLookup $ Static.toEmbedded $(embedDir "static")
8090> }
8191
82−> webSocketsApp state = do
92+When a client connects, we accept the connection, regardless of the path.
8393
84−When a client connects, we first obtain the request. Once we have that, we use
85−the 'WS.handshake' function to generate a response, which we finally send to the
86−client.
94+> application :: MVar ServerState -> WS.Request -> WS.WebSockets WS.Hybi00 ()
95+> application state rq = do
96+> WS.acceptRequest rq
8797
88−We use irrefutable pattern matches here because the server will spawn a thread
89−for each connection -- and a crashing thread does not effect the rest of the
90−program. For a real application, proper logging is appropriate.
98+We log some information here: in particular, we are interested in the protocol
99+version our client is using (for debugging purposes).
91100
92−> Just rq <- WS.receiveRequest
93−> let Right rsp = WS.handshake rq
94−> WS.sendResponse rsp
101+> WS.getVersion >>= liftIO . putStrLn . ("Client version: " ++)
95102
96103If we want to be able to send data to this client later, from another thread, we
97−obtain a sender. We will add this to the server state later.
104+obtain a sink. We will add this to the server state later.
98105
99−> sender <- WS.getSender
106+> sink <- WS.getSink
100107
101108When a client is succesfully connected, we read the first message. This should
102109be in the format of "Hi, I am Jasper", where Jasper is the requested username.
103110
104−> msg <- WS.receiveData
105−> clients <- liftIO $ readMVar state
106−> case msg of
107−> Nothing -> return ()
108−> Just m
111+> msg <- WS.receiveData
112+> clients <- liftIO $ readMVar state
113+> case msg of
109114
110115Check that the first message has the right format
111116
112−> | not (prefix `T.isPrefixOf` m) ->
113−> WS.sendTextData ("Wrong announcement" :: Text)
117+> _ | not (prefix `T.isPrefixOf` msg) ->
118+> WS.sendTextData ("Wrong announcement" :: Text)
114119
115120Check the validity of the username
116121
117−> | any ($ fst client)
118−> [T.null, T.any isPunctuation, T.any isSpace] ->
119−> WS.sendTextData ("Name cannot " `mappend`
120−> "contain punctuation or whitespace, and " `mappend`
121−> "cannot be empty" :: Text)
122+> | any ($ fst client)
123+> [T.null, T.any isPunctuation, T.any isSpace] ->
124+> WS.sendTextData ("Name cannot " `mappend`
125+> "contain punctuation or whitespace, and " `mappend`
126+> "cannot be empty" :: Text)
122127
123128Check that the given username is not already taken
124129
125−> | clientExists client clients ->
126−> WS.sendTextData ("User already exists" :: Text)
130+> | clientExists client clients ->
131+> WS.sendTextData ("User already exists" :: Text)
127132
128133All is right!
129134
130−> | otherwise -> do
135+> | otherwise -> do
131136
132137We send a "Welcome!", according to our own little protocol. We add the client to
133138the list and broadcast the fact that he has joined. Then, we give control to the
134139'talk' function.
135140
136−> liftIO $ modifyMVar_ state $ \s -> do
137−> let s' = addClient client s
138−> sender WS.textData $ "Welcome! Users: " `mappend`
139−> T.intercalate ", " (map fst s)
140−> broadcast (fst client `mappend` " joined") s'
141−> return s'
142−> talk state client
143−> where
144−> prefix = "Hi! I am "
145−> client = (T.drop (T.length prefix) m, sender)
141+> liftIO $ modifyMVar_ state $ \s -> do
142+> let s' = addClient client s
143+> WS.sendSink sink $ WS.textData $
144+> "Welcome! Users: " `mappend`
145+> T.intercalate ", " (map fst s)
146+> broadcast (fst client `mappend` " joined") s'
147+> return s'
148+> talk state client
149+> where
150+> prefix = "Hi! I am "
151+> client = (T.drop (T.length prefix) msg, sink)
146152
147153The talk function continues to read messages from a single client until he
148154disconnects. All messages are broadcasted to the other clients.
149155
150−> talk :: MVar ServerState -> Client -> WS.WebSockets ()
151−> talk state client@(user, _) = do
156+> talk :: WS.Protocol p => MVar ServerState -> Client -> WS.WebSockets p ()
157+> talk state client@(user, _) = flip WS.catchWsError catchDisconnect $ do
152158> msg <- WS.receiveData
153−> case msg of
154−> Nothing -> liftIO $ modifyMVar_ state $ \s -> do
159+> liftIO $ readMVar state >>= broadcast
160+> (user `mappend` ": " `mappend` msg)
161+> talk state client
162+> where
163+> catchDisconnect e = case fromException e of
164+> Just WS.ConnectionClosed -> liftIO $ modifyMVar_ state $ \s -> do
155165> let s' = removeClient client s
156166> broadcast (user `mappend` " disconnected") s'
157167> return s'
158−> Just m -> do
159−> liftIO $ readMVar state >>= broadcast
160−> (user `mappend` ": " `mappend` m)
161−> talk state client
168+> _ -> return ()