git.iko.soy/typeable/wai
on warp-3.3.9-conn-closed-by-pear help sign in
typeable/wai/wai-websockets/server.lhs
162 lines 5.9 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 (finally)
15> import Control.Monad (forM_, forever)
16> import Control.Concurrent (MVar, newMVar, modifyMVar_, readMVar, modifyMVar)
17> import Control.Monad.IO.Class (liftIO)
18> import qualified Data.Text as T
19> import qualified Data.Text.IO as T
20> import qualified Network.WebSockets as WS
21> import qualified Network.Wai
22> import qualified Network.Wai.Handler.Warp as Warp
23> import qualified Network.Wai.Handler.WebSockets as WaiWS
24> import qualified Network.Wai.Application.Static as Static
25> import Data.FileEmbed (embedDir)
28We represent a client by their username and a `WS.Connection`. We will see how we
29obtain this `WS.Connection` later on.
31> type Client = (Text, WS.Connection)
33The state kept on the server is simply a list of connected clients. We've added
34an alias and some utility functions, so it will be easier to extend this state
35later on.
37> type ServerState = [Client]
39Create a new, initial state:
41> newServerState :: ServerState
42> newServerState = []
44Get the number of active clients:
46> numClients :: ServerState -> Int
47> numClients = length
49Check if a user already exists (based on username):
51> clientExists :: Client -> ServerState -> Bool
52> clientExists client = any ((== fst client) . fst)
54Add a client (this does not check if the client already exists, you should do
55this yourself using `clientExists`):
57> addClient :: Client -> ServerState -> ServerState
58> addClient client clients = client : clients
60Remove a client:
62> removeClient :: Client -> ServerState -> ServerState
63> removeClient client = filter ((/= fst client) . fst)
65Send a message to all clients, and log it on stdout:
67> broadcast :: Text -> ServerState -> IO ()
68> broadcast message clients = do
69> T.putStrLn message
70> forM_ clients $ \(_, conn) -> WS.sendTextData conn message
72The main function first creates a new state for the server, then spawns the
73actual server.
75> main :: IO ()
76> main = do
77> putStrLn "http://localhost:9160/client.html"
78> state <- newMVar newServerState
79> Warp.runSettings
80> (Warp.setPort 9160 Warp.defaultSettings)
81> $ WaiWS.websocketsOr WS.defaultConnectionOptions (application state) staticApp
83> staticApp :: Network.Wai.Application
84> staticApp = Static.staticApp $ Static.embeddedSettings $(embedDir "static")
86Our main application has the type:
88> application :: MVar ServerState -> WS.ServerApp
90Note that `WS.ServerApp` is nothing but a type synonym for
91`WS.PendingConnection -> IO ()`.
93Our application starts by accepting the connection. In a more realistic
94application, you probably want to check the path and headers provided by the
95pending request.
97We also fork a pinging thread in the background. This will ensure the connection
98stays alive on some browsers.
100> application state pending = do
101> conn <- WS.acceptRequest pending
102> WS.forkPingThread conn 30
104When a client is successfully connected, we read the first message. This should
105be in the format of "Hi! I am Jasper", where Jasper is the requested username.
107> msg <- WS.receiveData conn
108> clients <- liftIO $ readMVar state
109> case msg of
111Check that the first message has the right format:
113> _ | not (prefix `T.isPrefixOf` msg) ->
114> WS.sendTextData conn ("Wrong announcement" :: Text)
116Check the validity of the username:
118> | any ($ fst client)
119> [T.null, T.any isPunctuation, T.any isSpace] ->
120> WS.sendTextData conn ("Name cannot " `mappend`
121> "contain punctuation or whitespace, and " `mappend`
122> "cannot be empty" :: Text)
124Check that the given username is not already taken:
126> | clientExists client clients ->
127> WS.sendTextData conn ("User already exists" :: Text)
129All is right! We're going to allow the client, but for safety reasons we *first*
130setup a `disconnect` function that will be run when the exception is closed.
132> | otherwise -> flip finally disconnect $ do
134We send a "Welcome!", according to our own little protocol. We add the client to
135the list and broadcast the fact that he has joined. Then, we give control to the
136'talk' function.
138> liftIO $ modifyMVar_ state $ \s -> do
139> let s' = addClient client s
140> WS.sendTextData conn $
141> "Welcome! Users: " `mappend`
142> T.intercalate ", " (map fst s)
143> broadcast (fst client `mappend` " joined") s'
144> return s'
145> talk conn state client
146> where
147> prefix = "Hi! I am "
148> client = (T.drop (T.length prefix) msg, conn)
149> disconnect = do
150> -- Remove client and return new state
151> s <- modifyMVar state $ \s ->
152> let s' = removeClient client s in return (s', s')
153> broadcast (fst client `mappend` " disconnected") s
155The talk function continues to read messages from a single client until he
156disconnects. All messages are broadcasted to the other clients.
158> talk :: WS.Connection -> MVar ServerState -> Client -> IO ()
159> talk conn state (user, _) = forever $ do
160> msg <- WS.receiveData conn
161> liftIO $ readMVar state >>= broadcast
162> (user `mappend` ": " `mappend` msg)