@@ -0,0 +1,158 @@
1+This is the Haskell implementation of the example for the WebSockets library. We
2+implement a simple multi-user chat program.
3+
4+> {-# LANGUAGE OverloadedStrings #-}
5+> import Data.Char (isPunctuation, isSpace)
6+> import Data.Monoid (mappend)
7+> import Data.Text (Text)
8+> import Control.Monad (forM_)
9+> import Control.Concurrent (MVar, newMVar, modifyMVar_, readMVar)
10+> import Control.Monad.IO.Class (liftIO)
11+> import qualified Data.Text as T
12+> import qualified Data.Text.IO as T
13+
14+> import qualified Network.WebSockets as WS
15+> import qualified Network.Wai.Handler.Warp as Warp
16+> import qualified Network.Wai.Handler.WebSockets as WaiWS
17+> import qualified Network.Wai.Application.Static as Static
18+
19+We represent a client by his username and a 'WS.Sender'. We can use this sender
20+to asynchronously send 'Text' to the client later.
21+
22+> type Client = (Text, WS.Sender Text)
23+
24+The state kept on the server is simply a list of connected clients. We've added
25+an alias and some utility functions, so it will be easier to extend this state
26+later on.
27+
28+> type ServerState = [Client]
29+
30+Create a new, initial state
31+
32+> newServerState :: ServerState
33+> newServerState = []
34+
35+Get the number of active clients
36+
37+> numClients :: ServerState -> Int
38+> numClients = length
39+
40+Check if a user already exists (based on username)
41+
42+> clientExists :: Client -> ServerState -> Bool
43+> clientExists client = any ((== fst client) . fst)
44+
45+Add a client (first, you should verify the client is not already connected using
46+'clientExists')
47+
48+> addClient :: Client -> ServerState -> ServerState
49+> addClient client clients = client : clients
50+
51+Remove a client
52+
53+> removeClient :: Client -> ServerState -> ServerState
54+> removeClient client = filter ((/= fst client) . fst)
55+
56+Send a message to all clients, and log it on stdout.
57+
58+> broadcast :: Text -> ServerState -> IO ()
59+> broadcast message clients = do
60+> T.putStrLn message
61+> forM_ clients $ \(_, sender) -> sender WS.textData message
62+
63+The main function first creates a new state for the server, then spawns the
64+actual server. For this purpose, we use the simple server provided by
65+'WS.runServer'.
66+
67+> main :: IO ()
68+> main = do
69+> state <- newMVar newServerState
70+> Warp.runSettings Warp.defaultSettings
71+> { Warp.settingsPort = 9160
72+> , Warp.settingsIntercept = WaiWS.intercept (webSocketsApp state)
73+> } staticApp
74+
75+> staticApp = Static.staticApp Static.defaultFileServerSettings
76+> { Static.ssFolder = Static.fileSystemLookup $ Static.toFilePath "."
77+> }
78+
79+> webSocketsApp state = do
80+
81+When a client connects, we first obtain the request. Once we have that, we use
82+the 'WS.handshake' function to generate a response, which we finally send to the
83+client.
84+
85+We use irrefutable pattern matches here because the server will spawn a thread
86+for each connection -- and a crashing thread does not effect the rest of the
87+program. For a real application, proper logging is appropriate.
88+
89+> Just rq <- WS.receiveRequest
90+> let Right rsp = WS.handshake rq
91+> WS.sendResponse rsp
92+
93+If we want to be able to send data to this client later, from another thread, we
94+obtain a sender. We will add this to the server state later.
95+
96+> sender <- WS.getSender
97+
98+When a client is succesfully connected, we read the first message. This should
99+be in the format of "Hi, I am Jasper", where Jasper is the requested username.
100+
101+> msg <- WS.receiveData
102+> clients <- liftIO $ readMVar state
103+> case msg of
104+> Nothing -> return ()
105+> Just m
106+
107+Check that the first message has the right format
108+
109+> | not (prefix `T.isPrefixOf` m) ->
110+> WS.sendTextData ("Wrong announcement" :: Text)
111+
112+Check the validity of the username
113+
114+> | any ($ fst client)
115+> [T.null, T.any isPunctuation, T.any isSpace] ->
116+> WS.sendTextData ("Name cannot " `mappend`
117+> "contain punctuation or whitespace, and " `mappend`
118+> "cannot be empty" :: Text)
119+
120+Check that the given username is not already taken
121+
122+> | clientExists client clients ->
123+> WS.sendTextData ("User already exists" :: Text)
124+
125+All is right!
126+
127+> | otherwise -> do
128+
129+We send a "Welcome!", according to our own little protocol. We add the client to
130+the list and broadcast the fact that he has joined. Then, we give control to the
131+'talk' function.
132+
133+> liftIO $ modifyMVar_ state $ \s -> do
134+> let s' = addClient client s
135+> sender WS.textData $ "Welcome! Users: " `mappend`
136+> T.intercalate ", " (map fst s)
137+> broadcast (fst client `mappend` " joined") s'
138+> return s'
139+> talk state client
140+> where
141+> prefix = "Hi! I am "
142+> client = (T.drop (T.length prefix) m, sender)
143+
144+The talk function continues to read messages from a single client until he
145+disconnects. All messages are broadcasted to the other clients.
146+
147+> talk :: MVar ServerState -> Client -> WS.WebSockets ()
148+> talk state client@(user, _) = do
149+> msg <- WS.receiveData
150+> case msg of
151+> Nothing -> liftIO $ modifyMVar_ state $ \s -> do
152+> let s' = removeClient client s
153+> broadcast (user `mappend` " disconnected") s'
154+> return s'
155+> Just m -> do
156+> liftIO $ readMVar state >>= broadcast
157+> (user `mappend` ": " `mappend` m)
158+> talk state client