mock: Some work on mock server

2 files changed, 103 insertions, 11 deletions

diff --git a/mock/Server.hs b/mock/Server.hs
index d77ae84..b4dea2c 100644
--- a/mock/Server.hs
+++ b/mock/Server.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE RankNTypes #-}
 module Server where
 
 import Prelude hiding (Word)
@@ -13,8 +14,11 @@ import Data.Map.Strict (Map)
 import System.Random
 
 import Types
+import Util
 
 
+-- | Message from the client gate to the server process. The response of the
+-- server is written to the MVar.
 data ServerIn = ServerIn ServerIn' (TMVar [ServerOut])
 
 data ServerIn'
@@ -27,6 +31,13 @@ data ServerOut
     | OLogin User
     | OLogout
     | ODisconnect
+    | OBroadcast BroadcastAudience Push  -- ^ Will not broadcast to the sender of the ServerIn
+  deriving (Show)
+
+data BroadcastAudience
+    = AudUser User  -- ^ All sessions of the user
+    | AudRoom Room  -- ^ All sessions of all users in the room
+    | AudVisibleUsers User  -- ^ All sessions of all users in all rooms that this user is in
   deriving (Show)
 
 data ClientAction
@@ -42,6 +53,11 @@ data ClientState
     | CSVersionWait
   deriving (Show)
 
+-- TODO: Make this act upon OBroadcast outputs. One way to do that is to create
+-- a new worker, say pushHub, on which clientGate's register, login, logout and
+-- deregister. Additionally, clientGate's can tell pushHub to broadcast a
+-- message to a particular audience (which should then exclude the connection
+-- that the concerned clientGate is responsible for).
 clientGate :: TQueue ServerIn -> TQueue (Maybe Cmd) -> TQueue ClientAction -> IO ()
 clientGate server clientIn clientOut =
     void $ iterateUntilM (\case CSDisconnected -> True ; _ -> False) body CSVersionWait
@@ -76,11 +92,13 @@ clientGate server clientIn clientOut =
 data ServerState
     = ServerState { ssRooms :: Map Room RoomState
                   , ssUsers :: Map User UserData
-                  , ssRNG :: StdGen }
+                  , ssRNG :: StdGen
+                  , ssNextId :: Id }
   deriving (Show)
 
 data RoomState
-    = RoomState { rsHistory :: Map Id HistoryItem
+    = RoomState { -- | Because Id's are strictly increasing, this is also chronological
+                  rsHistory :: Map Id HistoryItem
                 , rsMembers :: [User] }
   deriving (Show)
 
@@ -96,23 +114,42 @@ data HistoryItem
             , hiLine :: Line }
   deriving (Show)
 
+messageToHIMsg :: Message -> HistoryItem
+messageToHIMsg msg =
+    HIMsg { hiId = msgId msg
+          , hiTimestamp = msgTimestamp msg
+          , hiUser = msgUser msg
+          , hiReplyId = msgReplyId msg
+          , hiLine = msgLine msg }
+
+hiMsgToMessage :: Room -> HistoryItem -> Message
+hiMsgToMessage r hi =
+    Message { msgRoom = r
+            , msgId = hiId hi
+            , msgTimestamp = hiTimestamp hi
+            , msgUser = hiUser hi
+            , msgReplyId = hiReplyId hi
+            , msgLine = hiLine hi }
+
 initialServerState :: ServerState
 initialServerState =
     ServerState { ssRooms = mempty
                 , ssUsers = mempty
-                , ssRNG = mkStdGen 1234 }
+                , ssRNG = mkStdGen 1234
+                , ssNextId = Id 1 }
 
 emptyRoomState :: RoomState
 emptyRoomState =
     RoomState { rsHistory = mempty
               , rsMembers = [] }
 
-serverHandleEvent :: ServerState -> ServerIn' -> (ServerState, [ServerOut])
-serverHandleEvent state = \case
+serverHandleEvent :: Int -> ServerState -> ServerIn' -> (ServerState, [ServerOut])
+serverHandleEvent currentTimestamp state = \case
     IAnon (CRegister u p)
       | u `Map.member` ssUsers state -> (state, [OResponse (RError "User already exists")])
-      | otherwise -> (state { ssUsers = Map.insert u (UserData p) (ssUsers state) }
-                     ,[OResponse ROk])
+      | otherwise ->
+          (state { ssUsers = Map.insert u (UserData p) (ssUsers state) }
+          ,[OResponse ROk])
 
     IAnon (CLogin u p)
       | Just ud <- Map.lookup u (ssUsers state)
@@ -160,9 +197,64 @@ serverHandleEvent state = \case
                 | otherwise ->
                     (state { ssRooms = Map.adjust (\rs -> rs { rsMembers = u : rsMembers rs })
                                                   r (ssRooms state) }
-                    ,[OResponse ROk, push_to_u_something, broadcast_something])
-         | otherwise
-         -> (state, [OResponse (RError "Not in that room")])
+                    ,[OResponse ROk
+                     ,OBroadcast (AudUser u) (PInvite r user)
+                     ,OBroadcast (AudRoom r) (PJoin r u)])
+          | otherwise
+          -> (state, [OResponse (RError "Not in that room")])
+
+        CSend r mreply line
+          | Just (RoomState { rsMembers = mbs, rsHistory = hist }) <- Map.lookup r (ssRooms state)
+          , user `elem` mbs
+          , let msgid = ssNextId state
+                msg = Message { msgRoom = r
+                              , msgId = msgid
+                              , msgTimestamp = currentTimestamp
+                              , msgUser = user
+                              , msgReplyId = mreply
+                              , msgLine = line }
+                hitem = messageToHIMsg msg
+          -> case mreply of
+               Just reply | reply `Map.notMember` hist ->
+                   (state, [OResponse (RError "Replied-to message doesn't exist")])
+               _ ->
+                   let insertMsg rs = rs { rsHistory = Map.insert msgid hitem (rsHistory rs) }
+                   in (state { ssRooms = Map.adjust insertMsg r (ssRooms state) }
+                      ,[OResponse (RNumber (fromId msgid)), OBroadcast (AudRoom r) (PMessage msg)])
+          | otherwise
+          -> (state, [OResponse (RError "Not in that room")])
+
+        CHistory r num
+          | Just (RoomState { rsMembers = mbs, rsHistory = hist }) <- Map.lookup r (ssRooms state)
+          , user `elem` mbs
+          , let msgs = reverse (map (hiMsgToMessage r . snd) (take num (Map.toDescList hist)))
+          -> (state
+             ,OResponse (RHistory (length msgs))
+                  : [OResponse (RHistoryMessage i msg) | (i, msg) <- zip [0..] msgs])
+          | otherwise
+          -> (state, [OResponse (RError "Not in that room")])
+
+        CHistoryBefore r num beforeId
+          | Just (RoomState { rsMembers = mbs, rsHistory = hist }) <- Map.lookup r (ssRooms state)
+          , user `elem` mbs
+          -> case Map.lookup beforeId hist of
+               Just hitem ->
+                   let beforeStamp = hiTimestamp hitem
+                       msgs = reverse  -- to chronological order again
+                              . map (hiMsgToMessage r)  -- convert to messages
+                              . take num  -- limit to the number of items requested
+                              . dropWhile ((>= beforeStamp) . hiTimestamp)  -- spec-strict filter
+                              . map snd  -- only the history items, not the id keys
+                              . Map.toDescList  -- get a list of the earlier ones, reverse chronological
+                              . Map.takeWhileAntitone (< beforeId)  -- first, drop all certainly later
+                              $ hist
+                   in (state
+                      ,OResponse (RHistory (length msgs))
+                           : [OResponse (RHistoryMessage i msg) | (i, msg) <- zip [0..] msgs])
+               Nothing ->
+                   (state, [OResponse (RError "Message not found")])
+          | otherwise
+          -> (state, [OResponse (RError "Not in that room")])
 
 loopM :: Monad m => [a] -> s -> (s -> a -> m s) -> m s
 loopM [] s _ = return s
diff --git a/mock/tomsg-mock.cabal b/mock/tomsg-mock.cabal
index 8a5efe5..eb1c666 100644
--- a/mock/tomsg-mock.cabal
+++ b/mock/tomsg-mock.cabal
@@ -9,7 +9,7 @@ build-type:          Simple
 
 executable tomsg-mock
   main-is:             Main.hs
-  other-modules:       Types, Server
+  other-modules:       Types, Server, Util
   build-depends:       base >= 4.13 && < 4.15,
                        containers >= 0.6.4 && < 0.7,
                        monad-loops >= 0.4.3 && < 0.5,