aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--.gitignore8
-rw-r--r--picarones-elm/default.nix (renamed from default.nix)0
-rw-r--r--picarones-elm/document.css (renamed from document.css)0
-rw-r--r--picarones-elm/elm-srcs.nix (renamed from elm-srcs.nix)0
-rw-r--r--picarones-elm/elm.json (renamed from elm.json)0
-rw-r--r--picarones-elm/index.html (renamed from index.html)0
-rw-r--r--picarones-elm/registry.dat (renamed from registry.dat)bin106150 -> 106150 bytes
-rw-r--r--picarones-elm/src/Main.elm (renamed from src/Main.elm)0
-rw-r--r--picarones-elm/src/Protocol.elm (renamed from src/Protocol.elm)0
-rw-r--r--picarones-hs/Main.lhs216
-rw-r--r--picarones-hs/default.nix33
-rw-r--r--picarones-hs/picarones-hs.cabal31
12 files changed, 284 insertions, 4 deletions
diff --git a/.gitignore b/.gitignore
index b9e5384..7d57a10 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,4 +1,4 @@
-elm-stuff/*
-app.js
-Main.js
-result
+*/dist-newstyle/*
+*/result
+*/elm-stuff/*
+*js
diff --git a/default.nix b/picarones-elm/default.nix
index d597f70..d597f70 100644
--- a/default.nix
+++ b/picarones-elm/default.nix
diff --git a/document.css b/picarones-elm/document.css
index e4379b6..e4379b6 100644
--- a/document.css
+++ b/picarones-elm/document.css
diff --git a/elm-srcs.nix b/picarones-elm/elm-srcs.nix
index becbc8c..becbc8c 100644
--- a/elm-srcs.nix
+++ b/picarones-elm/elm-srcs.nix
diff --git a/elm.json b/picarones-elm/elm.json
index 2d0d191..2d0d191 100644
--- a/elm.json
+++ b/picarones-elm/elm.json
diff --git a/index.html b/picarones-elm/index.html
index 66fe158..66fe158 100644
--- a/index.html
+++ b/picarones-elm/index.html
diff --git a/registry.dat b/picarones-elm/registry.dat
index 53c3803..53c3803 100644
--- a/registry.dat
+++ b/picarones-elm/registry.dat
Binary files differ
diff --git a/src/Main.elm b/picarones-elm/src/Main.elm
index 5066ad6..5066ad6 100644
--- a/src/Main.elm
+++ b/picarones-elm/src/Main.elm
diff --git a/src/Protocol.elm b/picarones-elm/src/Protocol.elm
index 371a23a..371a23a 100644
--- a/src/Protocol.elm
+++ b/picarones-elm/src/Protocol.elm
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