aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Main.lhs67
1 files changed, 47 insertions, 20 deletions
diff --git a/Main.lhs b/Main.lhs
index c05c2ab..3586795 100644
--- a/Main.lhs
+++ b/Main.lhs
@@ -7,13 +7,14 @@ 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)
+> 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
@@ -51,22 +52,44 @@ an empty map:
> initialState = M.empty
-
Protocol
========
-Clients communicate by sending strings containing json over websockets,
-though there are currently only two possible messages, both of which
-are pretty boring:
+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 Join = Join { room :: !Text } deriving (Show, Generic)
-> data State = State { state :: Int } deriving (Show, Generic)
-> instance FromJSON Join
-> instance FromJSON State
-> instance ToJSON State
+> data Point = Point { x :: Int, y :: Int }
+> deriving (Show, Generic, FromJSON, ToJSON)
-Join is sent after a connection is established to indicate which room
-should be joined, State to indicate a state change
+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).
@@ -125,7 +148,7 @@ 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 State { state = n }
+> 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`
@@ -145,8 +168,6 @@ of `modifyMVar` above look nicer.
Message Loop
============
-Still todo: how to dynamically handle different incoming data types via Aeson?
-
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.
@@ -159,12 +180,18 @@ 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 State)
+> let d = (eitherDecode msg) :: (Either String ClientMsg)
> case d of
-> Left err -> putStrLn $ "json malformed" <> err
-> Right new -> do
-> peers <- modifyMVar roomstate $ \(cs,n) -> return ((cs, state new), cs)
-> broadcast (encode $ State { state = state new }) peers
+> 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)