initial commit

So far, it is fairly inefficient — for each message, the global
state of the application is changed (i.e. a read-write action
on a HashMap). Since clients can't change rooms after joining
anyways, this should probably be changed.

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