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 --- Main.lhs | 216 --------------------------------------------------------------- 1 file changed, 216 deletions(-) delete mode 100644 Main.lhs (limited to 'Main.lhs') diff --git a/Main.lhs b/Main.lhs deleted file mode 100644 index 3586795..0000000 --- a/Main.lhs +++ /dev/null @@ -1,216 +0,0 @@ -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