Add server to general repository

Idea: have all components of this program in one repository

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