diff options
| -rw-r--r-- | mock/Server.hs | 112 | ||||
| -rw-r--r-- | mock/tomsg-mock.cabal | 2 |
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, |