@@ -11,8 +11,8 @@ 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)
15−> import Control.Monad (forM_)
14+> import Control.Exception (fromException, handle)
15+> import Control.Monad (forM_, forever)
1616> import Control.Concurrent (MVar, newMVar, modifyMVar_, readMVar)
1717> import Control.Monad.IO.Class (liftIO)
1818> import qualified Data.Text as T
@@ -25,14 +25,9 @@ nearby to check out the functions we use.
2525> import qualified Network.Wai.Application.Static as Static
2626> import Data.FileEmbed (embedDir)
2727
28−We represent a client by his username and a 'WS.Sender'. We can use this sender
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.
28+We represent a client by his username and a 'WS.Connection'. We will see how we obtain this 'WS.Connection' later on.
3429
35−> type Client = (Text, WS.Sink WS.Hybi00)
30+> type Client = (Text, WS.Connection)
3631
3732The state kept on the server is simply a list of connected clients. We've added
3833an alias and some utility functions, so it will be easier to extend this state
@@ -71,7 +66,7 @@ Send a message to all clients, and log it on stdout.
7166> broadcast :: Text -> ServerState -> IO ()
7267> broadcast message clients = do
7368> T.putStrLn message
74−> forM_ clients $ \(_, sink) -> WS.sendSink sink $ WS.textData message
69+> forM_ clients $ \(_, conn) -> WS.sendTextData conn message
7570
7671The main function first creates a new state for the server, then spawns the
7772actual server. For this purpose, we use the simple server provided by
@@ -91,44 +86,34 @@ actual server. For this purpose, we use the simple server provided by
9186
9287When a client connects, we accept the connection, regardless of the path.
9388
94−> application :: MVar ServerState -> WS.Request -> WS.WebSockets WS.Hybi00 ()
95−> application state rq = do
96−> WS.acceptRequest rq
97−
98−We log some information here: in particular, we are interested in the protocol
99−version our client is using (for debugging purposes).
100−
101−> WS.getVersion >>= liftIO . putStrLn . ("Client version: " ++)
102−
103−If we want to be able to send data to this client later, from another thread, we
104−obtain a sink. We will add this to the server state later.
105−
106−> sink <- WS.getSink
89+> application :: MVar ServerState -> WS.ServerApp
90+> application state pending = do
91+> conn <- WS.acceptRequest pending
10792
10893When a client is succesfully connected, we read the first message. This should
10994be in the format of "Hi, I am Jasper", where Jasper is the requested username.
11095
111−> msg <- WS.receiveData
96+> msg <- WS.receiveData conn
11297> clients <- liftIO $ readMVar state
11398> case msg of
11499
115100Check that the first message has the right format
116101
117102> _ | not (prefix `T.isPrefixOf` msg) ->
118−> WS.sendTextData ("Wrong announcement" :: Text)
103+> WS.sendTextData conn ("Wrong announcement" :: Text)
119104
120105Check the validity of the username
121106
122107> | any ($ fst client)
123108> [T.null, T.any isPunctuation, T.any isSpace] ->
124−> WS.sendTextData ("Name cannot " `mappend`
109+> WS.sendTextData conn ("Name cannot " `mappend`
125110> "contain punctuation or whitespace, and " `mappend`
126111> "cannot be empty" :: Text)
127112
128113Check that the given username is not already taken
129114
130115> | clientExists client clients ->
131−> WS.sendTextData ("User already exists" :: Text)
116+> WS.sendTextData conn ("User already exists" :: Text)
132117
133118All is right!
134119
@@ -140,25 +125,25 @@ the list and broadcast the fact that he has joined. Then, we give control to the
140125
141126> liftIO $ modifyMVar_ state $ \s -> do
142127> let s' = addClient client s
143−> WS.sendSink sink $ WS.textData $
128+> WS.sendTextData conn $
144129> "Welcome! Users: " `mappend`
145130> T.intercalate ", " (map fst s)
146131> broadcast (fst client `mappend` " joined") s'
147132> return s'
148−> talk state client
133+> talk conn state client
149134> where
150135> prefix = "Hi! I am "
151−> client = (T.drop (T.length prefix) msg, sink)
136+> client = (T.drop (T.length prefix) msg, conn)
152137
153138The talk function continues to read messages from a single client until he
154139disconnects. All messages are broadcasted to the other clients.
155140
156−> talk :: WS.Protocol p => MVar ServerState -> Client -> WS.WebSockets p ()
157−> talk state client@(user, _) = flip WS.catchWsError catchDisconnect $ do
158−> msg <- WS.receiveData
159−> liftIO $ readMVar state >>= broadcast
160−> (user `mappend` ": " `mappend` msg)
161−> talk state client
141+> talk :: WS.Connection -> MVar ServerState -> Client -> IO ()
142+> talk conn state client@(user, _) = handle catchDisconnect $
143+> forever $ do
144+> msg <- WS.receiveData conn
145+> liftIO $ readMVar state >>= broadcast
146+> (user `mappend` ": " `mappend` msg)
162147> where
163148> catchDisconnect e = case fromException e of
164149> Just WS.ConnectionClosed -> liftIO $ modifyMVar_ state $ \s -> do