diff options
| -rw-r--r-- | Main.lhs | 67 |
1 files changed, 47 insertions, 20 deletions
@@ -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) |