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
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
|
Picarones
=========
This is a test implementation using literate haskell, loosely based on jaspervdj's
example of the haskell websockets library.
> {-# LANGUAGE OverloadedStrings #-}
> {-# LANGUAGE DeriveGeneric #-}
> {-# LANGUAGE DeriveAnyClass #-}
> module Main where
> import Data.Aeson
> import GHC.Generics
> import Data.Text (Text)
> import Data.HashMap.Strict (HashMap)
> import Control.Exception (finally)
> import Control.Monad (forM_, forever, mplus, mzero)
> import Control.Concurrent (MVar, newMVar, modifyMVar_, modifyMVar, readMVar, takeMVar, putMVar)
> import qualified Data.Text as T
> import qualified Data.Text.Encoding as T
> import qualified Data.Text.IO as T
> import qualified Data.ByteString.Lazy as LB
> import qualified Data.HashMap.Strict as M
> import qualified Network.WebSockets as WS
Application State
=================
We only show slides, so clients can be represented entirely by their
websocket connection and some id, which is only necessarry for bookkeeping
purporses, since WS.Connection apparently doesn't have Eq.
> type Client = (Int, WS.Connection)
Each room is then a list of clients, together with the slide currently
on display there (represented as Int — there is a Data.Nat, but it
doesn't look like it's very efficient, so let's just make sure we don't
end up with invalid values).
> type Room = ([Client], Int)
The entire server state is a map of room names to rooms, which are each
wrapped in a MVar, so we can change room states without touching the
global server state:
> type ServerState = HashMap Text (MVar Room)
Since rooms are created dynamically, the initial server state is just
an empty map:
> initialState :: ServerState
> initialState = M.empty
Protocol
========
Clients communicate by sending strings containing json over websockets.
Upon establishing a connection, clients declare which room they wish
to join:
> data Join = Join { room :: !Text }
> deriving (Show, Generic, FromJSON)
After joining, clients can either change the room state, or point at
some particular position on that room's canvas:
> data ClientMsg = ClientState Int | ClientPointAt Point
> deriving (Show)
> data Point = Point { x :: Int, y :: Int }
> deriving (Show, Generic, FromJSON, ToJSON)
Parsing these incoming messages correctly requires a bit of boilerplate
(or at least I've not yet found out how to get Aeson and Generics or
TemplateHaskell to do this automatically):
> instance FromJSON ClientMsg where
> parseJSON (Object v) = parseState `mplus` parsePointAt
> where
> parseState = ClientState <$> v .: "state"
> parsePointAt = ClientPointAt <$> v .: "pointat"
> parseJSON _ = mzero
The protocol for incoming messages is therefore that '{"state":2}' should
set the room state to 2, and that '{"pointat":{"x":10,"y":20}}' points
at position (10,20).
The server replies (and broadcasts to other clients) in similar json
messages which are constructed ad-hoc and don't have their own types
(for now).
Server Startup & Joining Clients
================================
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 "Starting Server!"
> state <- newMVar initialState
> WS.runServer "127.0.0.1" 9160 $ application state
Whenever we get a new connection, we accept the request, read a first
message (which must be a `join`-message, otherwise the connection is
dropped), and then start processing:
> application :: MVar ServerState -> WS.ServerApp
> application state pending = do
> conn <- WS.acceptRequest pending
> msg <- WS.receiveData conn
> let d = (eitherDecode msg) :: (Either String Join)
> case d of
> Left err -> putStrLn $ "error while join: " <> err
> Right join -> do
Once we now that a new client wants to join, we can start actually
processing the connection. First, we can fork a pinging thread to
the background:
> WS.withPingThread conn 30 (return ()) $ do
Then we can retrieve the global server state. Note that rooms are
ephemeral — they just get created as soon as someone joins them;
so we also have to check if the room already exists, and, if not,
create a new MVar to store that room's state.
> s <- takeMVar state
> (i,n, roomstate) <- case M.lookup (room join) s of
> Nothing -> do
> room' <- newMVar ([(0,conn)],0)
> let s' = M.insert (room join) room' s
> putMVar state s'
> return (0,0, room')
> Just room' -> do
> (i,n) <- modifyMVar room' (\state -> return $ insertClient conn state)
> putMVar state s
> return (i,n, room')
Now the client has joined, and we can print some debug output, send the
new client the current state so it can update its view, and hand over
to the usual message handling loop, which just needs the room's state,
not the server's global state:
> putStrLn $ show i <> " joined room " <> (show $ room join)
> WS.sendTextData conn $ encode (object ["state" .= n])
> talk (i, conn) roomstate
Only one thing is still left to do, which is to define the `insertClient`
function that was used above for brevity. It gets an already-existing
room, adds a client to it, and then returns the new room along with
the new client's index and the room's current slide, to make the call
of `modifyMVar` above look nicer.
> where
> insertClient :: WS.Connection -> Room -> (Room, (Int,Int))
> insertClient client room = case room of
> ([],n) -> (([(0,client)], 0), (0,0))
> ((i,conn'):cs,n) -> (((i+1,conn):(i,conn'):cs, n), (i+1,n))
Message Loop
============
Before we start the message loop, we first set up a disconnect handler
which will remove the client from the room's state once the socket closes.
After that, we just read in new messages, parse them as json messages,
and change the room's state accordingly (note: currently, this server is
"nice" and does not drop clients which send garbage instead of json; this
isn't really much of a concern here, but it would probably be better if
it did drop them).
> talk :: Client -> MVar Room -> IO ()
> talk (i,conn) roomstate = flip finally (disconnect i) $ forever $ do
> msg <- WS.receiveData conn
> let d = (eitherDecode msg) :: (Either String ClientMsg)
> case d of
> Left err -> putStrLn $ "json malformed: " <> err
> Right msg -> case msg of
> ClientState new -> do
> clients <- modifyMVar roomstate $ \(cs,n) -> return ((cs, new), cs)
> broadcast (encode $ object ["state" .= new]) clients
> ClientPointAt point -> do
> (clients,_) <- readMVar roomstate
> let peers = filter (\(i',_) -> i' /= i) clients
> putStrLn $ "client points at " <> show point
> broadcast (encode $ object ["point" .= point, "id" .= i]) peers
> where
> disconnect i = do
> modifyMVar_ roomstate (\room -> return $ removeClient i room)
> putStrLn $ show i <> " disconnected"
> removeClient :: Int -> Room -> Room
> removeClient i (cs,n) = (filter ((/= i) . fst) cs, n)
Broadcasting is equivalent to just going through the list of clients.
Note that this is a linked list (i.e. may be slow and cause some cache
misses while iterating), but it's probably going to be fine unless there's
a couple thousand clients in a room.
> broadcast :: LB.ByteString -> [Client] -> IO ()
> broadcast message cs = do
> LB.putStrLn message -- log messages
> forM_ cs $ \(_,conn) -> WS.sendTextData conn message
|
