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
|
Picarones
=========
This is a test implementation using literate haskell, loosely based on jaspervdj's
example of the haskell websockets library.
> {-# LANGUAGE OverloadedStrings #-}
> {-# LANGUAGE DeriveGeneric #-}
> 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)
> import Control.Concurrent (MVar, newMVar, modifyMVar_, readMVar)
> 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
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:
> type ServerState = HashMap Text Room
Since rooms are created dynamically, the initial server state is just
an empty map:
> initialState :: ServerState
> initialState = M.empty
Since all clients should be notified of all state changes, we define
a function to broadcast messages to all clients in one room:
> broadcast :: Text -> [Client] -> IO ()
> broadcast message cs = do
> --T.putStrLn message
> forM_ cs $ \(_,conn) -> WS.sendTextData conn message
Then there are some bookkeeping functions:
> addClient :: Client -> Maybe Room -> Room
> addClient c room = case room of
> Nothing -> ([c],0)
> Just (cs,n) -> (c:cs,n)
> removeClient :: Int -> Room -> Room
> removeClient i (cs,n) = (filter ((/= i) . fst) cs, n)
Protocol
========
Clients communicate by sending strings containing json over websockets,
though there are currently only two possible messages, both of which
are pretty boring:
> data Join = Join { room :: !Text } deriving (Show, Generic)
> data State = State { state :: Int } deriving (Show, Generic)
> instance FromJSON Join
> instance FromJSON State
Join is sent after a connection is established to indicate which room
should be joined, State to indicate a state change
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, retrieve the current slide
number and a new, free index, perform some housekeeping, and send the
new client the current state.
Additionally, we can fork a pinging thread to the background:
> s <- readMVar state
> let (i,n) = getNewIndex s
> WS.withPingThread conn 30 (return ()) $ flip finally (disconnect i) $ do
> putStrLn $ show i <> " joined room " <> (show $ room join)
> WS.sendTextData conn (T.pack $ "state " <> show n)
> modifyMVar_ state $ \map -> return (M.insert (room join) (addClient (i,conn) $ M.lookup (room join) map) map)
> talk (i,conn) (room join) state
> where
> getNewIndex :: ServerState -> (Int, Int)
> getNewIndex s = case M.lookup (room join) s of
> Nothing -> (0,0)
> Just (cs,n) -> case cs of
> [] -> (0,0)
> (i,c):_ -> (i+1,n)
> disconnect i = do
> modifyMVar_ state $ \map -> return (M.adjust (removeClient i) (room join) map)
> putStrLn $ show i <> " disconnected"
Message Loop
============
Still todo: how to dynamically handle different incoming data types via Aeson?
> talk :: Client -> Text -> MVar ServerState -> IO ()
> talk (i,conn) room s = forever $ do
> msg <- WS.receiveData conn
> let d = (eitherDecode msg) :: (Either String State)
> case d of
> Left err -> putStrLn $ "json malformed" <> err
> Right new -> do
> modifyMVar_ s $ \map -> return $ M.adjust (\(cs,_) -> (cs, state new)) room map
> state <- readMVar s
> case M.lookup room state of
> Nothing -> putStrLn $ "whoops, room " <> show room <> " somehow got lost"
> Just (cs,n) -> broadcast ("state " <> (T.pack $ show n)) cs
|
