git.iko.soy/typeable/wai
on wai-extra/1.3.4.1 help sign in
typeable/wai/wai-websockets/server.lhs
168 lines 6.1 kB history raw
1websockets example
2==================
4This is the Haskell implementation of the example for the WebSockets library. We
5implement a simple multi-user chat program. A live demo of the example is
6available [here](http://jaspervdj.be/websockets-example). In order to understand
7this example, keep the [reference](http://jaspervdj.be/websockets/reference)
8nearby to check out the functions we use.
10> {-# LANGUAGE OverloadedStrings, TemplateHaskell #-}
11> import Data.Char (isPunctuation, isSpace)
12> import Data.Monoid (mappend)
13> import Data.Text (Text)
14> import Control.Exception (fromException)
15> import Control.Monad (forM_)
16> import Control.Concurrent (MVar, newMVar, modifyMVar_, readMVar)
17> import Control.Monad.IO.Class (liftIO)
18> import qualified Data.Text as T
19> import qualified Data.Text.IO as T
21> import qualified Network.WebSockets as WS
22> import qualified Network.Wai
23> import qualified Network.Wai.Handler.Warp as Warp
24> import qualified Network.Wai.Handler.WebSockets as WaiWS
25> import qualified Network.Wai.Application.Static as Static
26> import Data.FileEmbed (embedDir)
28We represent a client by his username and a 'WS.Sender'. We can use this sender
29to asynchronously send 'Text' to the client later. Note that using `WS.Hybi00`
30here does not imply that our server is only compatible with the `hybi-00`
31version of the protocol, for more details on this, see the
32[Network.WebSockets](http://jaspervdj.be/websockets/reference/Network-WebSockets.html)
33reference.
35> type Client = (Text, WS.Sink WS.Hybi00)
37The state kept on the server is simply a list of connected clients. We've added
38an alias and some utility functions, so it will be easier to extend this state
39later on.
41> type ServerState = [Client]
43Create a new, initial state
45> newServerState :: ServerState
46> newServerState = []
48Get the number of active clients
50> numClients :: ServerState -> Int
51> numClients = length
53Check if a user already exists (based on username)
55> clientExists :: Client -> ServerState -> Bool
56> clientExists client = any ((== fst client) . fst)
58Add a client (first, you should verify the client is not already connected using
59'clientExists')
61> addClient :: Client -> ServerState -> ServerState
62> addClient client clients = client : clients
64Remove a client
66> removeClient :: Client -> ServerState -> ServerState
67> removeClient client = filter ((/= fst client) . fst)
69Send a message to all clients, and log it on stdout.
71> broadcast :: Text -> ServerState -> IO ()
72> broadcast message clients = do
73> T.putStrLn message
74> forM_ clients $ \(_, sink) -> WS.sendSink sink $ WS.textData message
76The main function first creates a new state for the server, then spawns the
77actual server. For this purpose, we use the simple server provided by
78'WS.runServer'.
80> main :: IO ()
81> main = do
82> putStrLn "http://localhost:9160/client.html"
83> state <- newMVar newServerState
84> Warp.runSettings Warp.defaultSettings
85> { Warp.settingsPort = 9160
86> , Warp.settingsIntercept = WaiWS.intercept (application state)
87> } staticApp
89> staticApp :: Network.Wai.Application
90> staticApp = Static.staticApp $ Static.embeddedSettings $(embedDir "static")
92When a client connects, we accept the connection, regardless of the path.
94> application :: MVar ServerState -> WS.Request -> WS.WebSockets WS.Hybi00 ()
95> application state rq = do
96> WS.acceptRequest rq
98We log some information here: in particular, we are interested in the protocol
99version our client is using (for debugging purposes).
101> WS.getVersion >>= liftIO . putStrLn . ("Client version: " ++)
103If we want to be able to send data to this client later, from another thread, we
104obtain a sink. We will add this to the server state later.
106> sink <- WS.getSink
108When a client is succesfully connected, we read the first message. This should
109be in the format of "Hi, I am Jasper", where Jasper is the requested username.
111> msg <- WS.receiveData
112> clients <- liftIO $ readMVar state
113> case msg of
115Check that the first message has the right format
117> _ | not (prefix `T.isPrefixOf` msg) ->
118> WS.sendTextData ("Wrong announcement" :: Text)
120Check the validity of the username
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)
128Check that the given username is not already taken
130> | clientExists client clients ->
131> WS.sendTextData ("User already exists" :: Text)
133All is right!
135> | otherwise -> do
137We send a "Welcome!", according to our own little protocol. We add the client to
138the list and broadcast the fact that he has joined. Then, we give control to the
139'talk' function.
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)
153The talk function continues to read messages from a single client until he
154disconnects. All messages are broadcasted to the other clients.
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
162> where
163> catchDisconnect e = case fromException e of
164> Just WS.ConnectionClosed -> liftIO $ modifyMVar_ state $ \s -> do
165> let s' = removeClient client s
166> broadcast (user `mappend` " disconnected") s'
167> return s'
168> _ -> return ()