From 2ad5d413aa958a1c2fe75ce7aa155576e9a80345 Mon Sep 17 00:00:00 2001 From: stuebinm Date: Sun, 7 Mar 2021 16:57:23 +0100 Subject: Add server to general repository Idea: have all components of this program in one repository --- picarones-hs/Main.lhs | 216 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 216 insertions(+) create mode 100644 picarones-hs/Main.lhs (limited to 'picarones-hs/Main.lhs') diff --git a/picarones-hs/Main.lhs b/picarones-hs/Main.lhs new file mode 100644 index 0000000..3586795 --- /dev/null +++ b/picarones-hs/Main.lhs @@ -0,0 +1,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 + + + + + + -- cgit v1.2.3