git.iko.soy/typeable/wai
on auto-update/0.1.1.3 help sign in
typeable/wai/wai-websockets/server.lhs
152 lines 5.5 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, handle)
15> import Control.Monad (forM_, forever)
16> import Control.Concurrent (MVar, newMVar, modifyMVar_, readMVar, forkIO)
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.Connection'. We will see how we obtain this 'WS.Connection' later on.
30> type Client = (Text, WS.Connection)
32The state kept on the server is simply a list of connected clients. We've added
33an alias and some utility functions, so it will be easier to extend this state
34later on.
36> type ServerState = [Client]
38Create a new, initial state
40> newServerState :: ServerState
41> newServerState = []
43Get the number of active clients
45> numClients :: ServerState -> Int
46> numClients = length
48Check if a user already exists (based on username)
50> clientExists :: Client -> ServerState -> Bool
51> clientExists client = any ((== fst client) . fst)
53Add a client (first, you should verify the client is not already connected using
54'clientExists')
56> addClient :: Client -> ServerState -> ServerState
57> addClient client clients = client : clients
59Remove a client
61> removeClient :: Client -> ServerState -> ServerState
62> removeClient client = filter ((/= fst client) . fst)
64Send a message to all clients, and log it on stdout.
66> broadcast :: Text -> ServerState -> IO ()
67> broadcast message clients = do
68> T.putStrLn message
69> forM_ clients $ \(_, conn) -> forkIO $ WS.sendTextData conn message
71The main function first creates a new state for the server, then spawns the
72actual server. For this purpose, we use the simple server provided by
73'WS.runServer'.
75> main :: IO ()
76> main = do
77> putStrLn "http://localhost:9160/client.html"
78> state <- newMVar newServerState
79> Warp.runSettings Warp.defaultSettings
80> { Warp.settingsPort = 9160
81> } $ WaiWS.websocketsOr WS.defaultConnectionOptions (application state) staticApp
83> staticApp :: Network.Wai.Application
84> staticApp = Static.staticApp $ Static.embeddedSettings $(embedDir "static")
86When a client connects, we accept the connection, regardless of the path.
88> application :: MVar ServerState -> WS.ServerApp
89> application state pending = do
90> conn <- WS.acceptRequest pending
92When a client is succesfully connected, we read the first message. This should
93be in the format of "Hi, I am Jasper", where Jasper is the requested username.
95> msg <- WS.receiveData conn
96> clients <- liftIO $ readMVar state
97> case msg of
99Check that the first message has the right format
101> _ | not (prefix `T.isPrefixOf` msg) ->
102> WS.sendTextData conn ("Wrong announcement" :: Text)
104Check the validity of the username
106> | any ($ fst client)
107> [T.null, T.any isPunctuation, T.any isSpace] ->
108> WS.sendTextData conn ("Name cannot " `mappend`
109> "contain punctuation or whitespace, and " `mappend`
110> "cannot be empty" :: Text)
112Check that the given username is not already taken
114> | clientExists client clients ->
115> WS.sendTextData conn ("User already exists" :: Text)
117All is right!
119> | otherwise -> do
121We send a "Welcome!", according to our own little protocol. We add the client to
122the list and broadcast the fact that he has joined. Then, we give control to the
123'talk' function.
125> liftIO $ modifyMVar_ state $ \s -> do
126> let s' = addClient client s
127> WS.sendTextData conn $
128> "Welcome! Users: " `mappend`
129> T.intercalate ", " (map fst s)
130> broadcast (fst client `mappend` " joined") s'
131> return s'
132> talk conn state client
133> where
134> prefix = "Hi! I am "
135> client = (T.drop (T.length prefix) msg, conn)
137The talk function continues to read messages from a single client until he
138disconnects. All messages are broadcasted to the other clients.
140> talk :: WS.Connection -> MVar ServerState -> Client -> IO ()
141> talk conn state client@(user, _) = handle catchDisconnect $
142> forever $ do
143> msg <- WS.receiveData conn
144> liftIO $ readMVar state >>= broadcast
145> (user `mappend` ": " `mappend` msg)
146> where
147> catchDisconnect e = case fromException e of
148> Just WS.ConnectionClosed -> liftIO $ modifyMVar_ state $ \s -> do
149> let s' = removeClient client s
150> broadcast (user `mappend` " disconnected") s'
151> return s'
152> _ -> return ()