aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--.gitignore1
-rw-r--r--Main.lhs161
-rw-r--r--picarones-hs.cabal31
3 files changed, 193 insertions, 0 deletions
diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..b5e3679
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1 @@
+dist-newstyle/*
diff --git a/Main.lhs b/Main.lhs
new file mode 100644
index 0000000..cffb4c7
--- /dev/null
+++ b/Main.lhs
@@ -0,0 +1,161 @@
+Picarones
+=========
+
+This is a test implementation using literate haskell, loosely based on jaspervdj's
+example of the haskell websockets library.
+
+
+> {-# LANGUAGE OverloadedStrings #-}
+> {-# LANGUAGE DeriveGeneric #-}
+> 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)
+> import Control.Concurrent (MVar, newMVar, modifyMVar_, readMVar)
+> 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
+
+
+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:
+
+> type ServerState = HashMap Text Room
+
+Since rooms are created dynamically, the initial server state is just
+an empty map:
+
+> initialState :: ServerState
+> initialState = M.empty
+
+Since all clients should be notified of all state changes, we define
+a function to broadcast messages to all clients in one room:
+
+> broadcast :: Text -> [Client] -> IO ()
+> broadcast message cs = do
+> --T.putStrLn message
+> forM_ cs $ \(_,conn) -> WS.sendTextData conn message
+
+
+
+
+Then there are some bookkeeping functions:
+
+> addClient :: Client -> Maybe Room -> Room
+> addClient c room = case room of
+> Nothing -> ([c],0)
+> Just (cs,n) -> (c:cs,n)
+
+> removeClient :: Int -> Room -> Room
+> removeClient i (cs,n) = (filter ((/= i) . fst) cs, n)
+
+
+
+
+Protocol
+========
+
+Clients communicate by sending strings containing json over websockets,
+though there are currently only two possible messages, both of which
+are pretty boring:
+
+> data Join = Join { room :: !Text } deriving (Show, Generic)
+> data State = State { state :: Int } deriving (Show, Generic)
+> instance FromJSON Join
+> instance FromJSON State
+
+Join is sent after a connection is established to indicate which room
+should be joined, State to indicate a state change
+
+
+
+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, retrieve the current slide
+number and a new, free index, perform some housekeeping, and send the
+new client the current state.
+
+Additionally, we can fork a pinging thread to the background:
+
+> s <- readMVar state
+> let (i,n) = getNewIndex s
+> WS.withPingThread conn 30 (return ()) $ flip finally (disconnect i) $ do
+> putStrLn $ show i <> " joined room " <> (show $ room join)
+> WS.sendTextData conn (T.pack $ "state " <> show n)
+> modifyMVar_ state $ \map -> return (M.insert (room join) (addClient (i,conn) $ M.lookup (room join) map) map)
+> talk (i,conn) (room join) state
+> where
+> getNewIndex :: ServerState -> (Int, Int)
+> getNewIndex s = case M.lookup (room join) s of
+> Nothing -> (0,0)
+> Just (cs,n) -> case cs of
+> [] -> (0,0)
+> (i,c):_ -> (i+1,n)
+> disconnect i = do
+> modifyMVar_ state $ \map -> return (M.adjust (removeClient i) (room join) map)
+> putStrLn $ show i <> " disconnected"
+
+
+
+Message Loop
+============
+
+Still todo: how to dynamically handle different incoming data types via Aeson?
+
+> talk :: Client -> Text -> MVar ServerState -> IO ()
+> talk (i,conn) room s = forever $ do
+> msg <- WS.receiveData conn
+> let d = (eitherDecode msg) :: (Either String State)
+> case d of
+> Left err -> putStrLn $ "json malformed" <> err
+> Right new -> do
+> modifyMVar_ s $ \map -> return $ M.adjust (\(cs,_) -> (cs, state new)) room map
+> state <- readMVar s
+> case M.lookup room state of
+> Nothing -> putStrLn $ "whoops, room " <> show room <> " somehow got lost"
+> Just (cs,n) -> broadcast ("state " <> (T.pack $ show n)) cs
+
+
+
diff --git a/picarones-hs.cabal b/picarones-hs.cabal
new file mode 100644
index 0000000..deb2969
--- /dev/null
+++ b/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