Skip to content
This repository
tree: edfa0acc84
Fetching contributors…

Cannot retrieve contributors at this time

file 168 lines (126 sloc) 6.134 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168
websockets example
==================

This is the Haskell implementation of the example for the WebSockets library. We
implement a simple multi-user chat program. A live demo of the example is
available [here](http://jaspervdj.be/websockets-example). In order to understand
this example, keep the [reference](http://jaspervdj.be/websockets/reference)
nearby to check out the functions we use.

> {-# LANGUAGE OverloadedStrings, TemplateHaskell #-}
> import Data.Char (isPunctuation, isSpace)
> import Data.Monoid (mappend)
> import Data.Text (Text)
> import Control.Exception (fromException)
> import Control.Monad (forM_)
> import Control.Concurrent (MVar, newMVar, modifyMVar_, readMVar)
> import Control.Monad.IO.Class (liftIO)
> import qualified Data.Text as T
> import qualified Data.Text.IO as T

> import qualified Network.WebSockets as WS
> import qualified Network.Wai
> import qualified Network.Wai.Handler.Warp as Warp
> import qualified Network.Wai.Handler.WebSockets as WaiWS
> import qualified Network.Wai.Application.Static as Static
> import Data.FileEmbed (embedDir)

We represent a client by his username and a 'WS.Sender'. We can use this sender
to asynchronously send 'Text' to the client later. Note that using `WS.Hybi00`
here does not imply that our server is only compatible with the `hybi-00`
version of the protocol, for more details on this, see the
[Network.WebSockets](http://jaspervdj.be/websockets/reference/Network-WebSockets.html)
reference.

> type Client = (Text, WS.Sink WS.Hybi00)

The state kept on the server is simply a list of connected clients. We've added
an alias and some utility functions, so it will be easier to extend this state
later on.

> type ServerState = [Client]

Create a new, initial state

> newServerState :: ServerState
> newServerState = []

Get the number of active clients

> numClients :: ServerState -> Int
> numClients = length

Check if a user already exists (based on username)

> clientExists :: Client -> ServerState -> Bool
> clientExists client = any ((== fst client) . fst)

Add a client (first, you should verify the client is not already connected using
'clientExists')

> addClient :: Client -> ServerState -> ServerState
> addClient client clients = client : clients

Remove a client

> removeClient :: Client -> ServerState -> ServerState
> removeClient client = filter ((/= fst client) . fst)

Send a message to all clients, and log it on stdout.

> broadcast :: Text -> ServerState -> IO ()
> broadcast message clients = do
> T.putStrLn message
> forM_ clients $ \(_, sink) -> WS.sendSink sink $ WS.textData message

The main function first creates a new state for the server, then spawns the
actual server. For this purpose, we use the simple server provided by
'WS.runServer'.

> main :: IO ()
> main = do
> putStrLn "http://localhost:9160/client.html"
> state <- newMVar newServerState
> Warp.runSettings Warp.defaultSettings
> { Warp.settingsPort = 9160
> , Warp.settingsIntercept = WaiWS.intercept (application state)
> } staticApp

> staticApp :: Network.Wai.Application
> staticApp = Static.staticApp $ Static.embeddedSettings $(embedDir "static")

When a client connects, we accept the connection, regardless of the path.

> application :: MVar ServerState -> WS.Request -> WS.WebSockets WS.Hybi00 ()
> application state rq = do
> WS.acceptRequest rq

We log some information here: in particular, we are interested in the protocol
version our client is using (for debugging purposes).

> WS.getVersion >>= liftIO . putStrLn . ("Client version: " ++)

If we want to be able to send data to this client later, from another thread, we
obtain a sink. We will add this to the server state later.

> sink <- WS.getSink

When a client is succesfully connected, we read the first message. This should
be in the format of "Hi, I am Jasper", where Jasper is the requested username.

> msg <- WS.receiveData
> clients <- liftIO $ readMVar state
> case msg of

Check that the first message has the right format

> _ | not (prefix `T.isPrefixOf` msg) ->
> WS.sendTextData ("Wrong announcement" :: Text)

Check the validity of the username

> | any ($ fst client)
> [T.null, T.any isPunctuation, T.any isSpace] ->
> WS.sendTextData ("Name cannot " `mappend`
> "contain punctuation or whitespace, and " `mappend`
> "cannot be empty" :: Text)

Check that the given username is not already taken

> | clientExists client clients ->
> WS.sendTextData ("User already exists" :: Text)

All is right!

> | otherwise -> do

We send a "Welcome!", according to our own little protocol. We add the client to
the list and broadcast the fact that he has joined. Then, we give control to the
'talk' function.

> liftIO $ modifyMVar_ state $ \s -> do
> let s' = addClient client s
> WS.sendSink sink $ WS.textData $
> "Welcome! Users: " `mappend`
> T.intercalate ", " (map fst s)
> broadcast (fst client `mappend` " joined") s'
> return s'
> talk state client
> where
> prefix = "Hi! I am "
> client = (T.drop (T.length prefix) msg, sink)

The talk function continues to read messages from a single client until he
disconnects. All messages are broadcasted to the other clients.

> talk :: WS.Protocol p => MVar ServerState -> Client -> WS.WebSockets p ()
> talk state client@(user, _) = flip WS.catchWsError catchDisconnect $ do
> msg <- WS.receiveData
> liftIO $ readMVar state >>= broadcast
> (user `mappend` ": " `mappend` msg)
> talk state client
> where
> catchDisconnect e = case fromException e of
> Just WS.ConnectionClosed -> liftIO $ modifyMVar_ state $ \s -> do
> let s' = removeClient client s
> broadcast (user `mappend` " disconnected") s'
> return s'
> _ -> return ()
Something went wrong with that request. Please try again.