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 ---------------------------------------- default.nix | 33 ------ picarones-hs.cabal | 31 ------ picarones-hs/Main.lhs | 216 ++++++++++++++++++++++++++++++++++++++++ picarones-hs/default.nix | 33 ++++++ picarones-hs/picarones-hs.cabal | 31 ++++++ 6 files changed, 280 insertions(+), 280 deletions(-) delete mode 100644 Main.lhs delete mode 100644 default.nix delete mode 100644 picarones-hs.cabal create mode 100644 picarones-hs/Main.lhs create mode 100644 picarones-hs/default.nix create mode 100644 picarones-hs/picarones-hs.cabal 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 - - - - - - diff --git a/default.nix b/default.nix deleted file mode 100644 index ebcb880..0000000 --- a/default.nix +++ /dev/null @@ -1,33 +0,0 @@ -{ nixpkgs ? import {}, compiler ? "default", doBenchmark ? false }: - -let - - inherit (nixpkgs) pkgs; - - f = { mkDerivation, aeson, base, bytestring, stdenv, text - , unordered-containers, websockets - }: - mkDerivation { - pname = "haskell-ws-test"; - version = "0.1.0.0"; - src = ./.; - isLibrary = false; - isExecutable = true; - executableHaskellDepends = [ - aeson base bytestring text unordered-containers websockets - ]; - license = "unknown"; - hydraPlatforms = stdenv.lib.platforms.none; - }; - - haskellPackages = if compiler == "default" - then pkgs.haskellPackages - else pkgs.haskell.packages.${compiler}; - - variant = if doBenchmark then pkgs.haskell.lib.doBenchmark else pkgs.lib.id; - - drv = variant (haskellPackages.callPackage f {}); - -in - - if pkgs.lib.inNixShell then drv.env else drv diff --git a/picarones-hs.cabal b/picarones-hs.cabal deleted file mode 100644 index 6ed69a7..0000000 --- a/picarones-hs.cabal +++ /dev/null @@ -1,31 +0,0 @@ -cabal-version: >=1.10 --- Initial package description 'picarones-hs' generated by 'cabal --- init'. For further documentation, see --- http://haskell.org/cabal/users-guide/ - -name: picarones-hs -version: 0.1.0.0 --- synopsis: --- description: --- bug-reports: --- license: --- license-file: LICENSE -author: stuebinm -maintainer: stuebinm@disroot.org --- copyright: --- category: -build-type: Simple - -executable picarones-hs - main-is: Main.lhs - -- other-modules: - -- other-extensions: - ghc-options: -threaded - build-depends: base == 4.*, - text, - aeson, - websockets, - bytestring, - unordered-containers - -- hs-source-dirs: - default-language: Haskell2010 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 + + + + + + diff --git a/picarones-hs/default.nix b/picarones-hs/default.nix new file mode 100644 index 0000000..ebcb880 --- /dev/null +++ b/picarones-hs/default.nix @@ -0,0 +1,33 @@ +{ nixpkgs ? import {}, compiler ? "default", doBenchmark ? false }: + +let + + inherit (nixpkgs) pkgs; + + f = { mkDerivation, aeson, base, bytestring, stdenv, text + , unordered-containers, websockets + }: + mkDerivation { + pname = "haskell-ws-test"; + version = "0.1.0.0"; + src = ./.; + isLibrary = false; + isExecutable = true; + executableHaskellDepends = [ + aeson base bytestring text unordered-containers websockets + ]; + license = "unknown"; + hydraPlatforms = stdenv.lib.platforms.none; + }; + + haskellPackages = if compiler == "default" + then pkgs.haskellPackages + else pkgs.haskell.packages.${compiler}; + + variant = if doBenchmark then pkgs.haskell.lib.doBenchmark else pkgs.lib.id; + + drv = variant (haskellPackages.callPackage f {}); + +in + + if pkgs.lib.inNixShell then drv.env else drv diff --git a/picarones-hs/picarones-hs.cabal b/picarones-hs/picarones-hs.cabal new file mode 100644 index 0000000..6ed69a7 --- /dev/null +++ b/picarones-hs/picarones-hs.cabal @@ -0,0 +1,31 @@ +cabal-version: >=1.10 +-- Initial package description 'picarones-hs' generated by 'cabal +-- init'. For further documentation, see +-- http://haskell.org/cabal/users-guide/ + +name: picarones-hs +version: 0.1.0.0 +-- synopsis: +-- description: +-- bug-reports: +-- license: +-- license-file: LICENSE +author: stuebinm +maintainer: stuebinm@disroot.org +-- copyright: +-- category: +build-type: Simple + +executable picarones-hs + main-is: Main.lhs + -- other-modules: + -- other-extensions: + ghc-options: -threaded + build-depends: base == 4.*, + text, + aeson, + websockets, + bytestring, + unordered-containers + -- hs-source-dirs: + default-language: Haskell2010 -- cgit v1.2.3