From 936dc3d58c9e7f388a2df92c182abeaeca52ce17 Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Sun, 7 Mar 2021 16:49:26 +0100
Subject: Better handling of json

(mostly to reduce the number of record types needed, and to deal with
multiple possible types of client messages)
---
 Main.lhs | 67 +++++++++++++++++++++++++++++++++++++++++++++-------------------
 1 file 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)
-- 
cgit v1.2.3