diff options
| -rw-r--r-- | .gitignore | 1 | ||||
| -rw-r--r-- | Main.lhs | 161 | ||||
| -rw-r--r-- | picarones-hs.cabal | 31 |
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 |