aboutsummaryrefslogtreecommitdiff
path: root/mock
diff options
context:
space:
mode:
Diffstat (limited to 'mock')
-rw-r--r--mock/Server.hs112
-rw-r--r--mock/tomsg-mock.cabal2
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,