diff options
Diffstat (limited to '')
| -rw-r--r-- | picarones-hs/Main.lhs | 216 | ||||
| -rw-r--r-- | picarones-hs/default.nix | 33 | ||||
| -rw-r--r-- | picarones-hs/picarones-hs.cabal | 31 |
3 files changed, 280 insertions, 0 deletions
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 <nixpkgs> {}, 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 |