From 7729f1be60bf2c4d38758971bd95d4c6445fde1e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Sun, 30 Jun 2024 23:18:56 +0200 Subject: Chatroom subscriptions --- main/Test.hs | 3 +- src/Erebos/Chatroom.hs | 133 +++++++++++++++++++++++++++++++++++++++++----- test/chatroom.test | 139 +++++++++++++++++++++++++++++++++++++++++++++---- 3 files changed, 252 insertions(+), 23 deletions(-) diff --git a/main/Test.hs b/main/Test.hs index d5737c2..711f9fa 100644 --- a/main/Test.hs +++ b/main/Test.hs @@ -726,10 +726,11 @@ cmdChatroomWatchLocal = do , [ "new" ], map (show . refDigest . storedRef) (roomStateData room) ] when (any (not . null . rsdMessages . fromStored) (roomStateData room)) $ do - forM_ (getMessagesSinceState room oldroom) $ \msg -> do + forM_ (reverse $ getMessagesSinceState room oldroom) $ \msg -> do outLine out $ unwords $ concat [ [ "chatroom-message-new" ] , [ show . refDigest . storedRef . head . filterAncestors . concatMap storedRoots . toComponents $ room ] + , [ "room", maybe "" T.unpack $ roomName =<< cmsgRoom msg ] , [ "from", maybe "" T.unpack $ idName $ cmsgFrom msg ] , maybe [] (("text":) . (:[]) . T.unpack) $ cmsgText msg ] diff --git a/src/Erebos/Chatroom.hs b/src/Erebos/Chatroom.hs index 673c59f..dcd7b42 100644 --- a/src/Erebos/Chatroom.hs +++ b/src/Erebos/Chatroom.hs @@ -16,7 +16,9 @@ module Erebos.Chatroom ( ChatroomSetChange(..), watchChatrooms, - ChatMessage, cmsgFrom, cmsgReplyTo, cmsgTime, cmsgText, cmsgLeave, + ChatMessage, + cmsgFrom, cmsgReplyTo, cmsgTime, cmsgText, cmsgLeave, + cmsgRoom, cmsgRoomData, ChatMessageData(..), chatroomMessageByStateData, @@ -29,6 +31,7 @@ import Control.Monad.Except import Control.Monad.IO.Class import Data.Bool +import Data.Either import Data.IORef import Data.List import Data.Maybe @@ -111,6 +114,11 @@ data ChatMessage = ChatMessage { cmsgData :: Stored (Signed ChatMessageData) } +validateSingleMessage :: Stored (Signed ChatMessageData) -> Maybe ChatMessage +validateSingleMessage sdata = do + guard $ fromStored sdata `isSignedBy` idKeyMessage (mdFrom (fromSigned sdata)) + return $ ChatMessage sdata + cmsgFrom :: ChatMessage -> ComposedIdentity cmsgFrom = mdFrom . fromSigned . cmsgData @@ -126,6 +134,12 @@ cmsgText = mdText . fromSigned . cmsgData cmsgLeave :: ChatMessage -> Bool cmsgLeave = mdLeave . fromSigned . cmsgData +cmsgRoom :: ChatMessage -> Maybe Chatroom +cmsgRoom = either (const Nothing) Just . runExcept . validateChatroom . cmsgRoomData + +cmsgRoomData :: ChatMessage -> [ Stored (Signed ChatroomData) ] +cmsgRoomData = concat . findProperty ((\case [] -> Nothing; xs -> Just xs) . mdRoom . fromStored . signedData) . (: []) . cmsgData + instance Storable ChatMessageData where store' ChatMessageData {..} = storeRec $ do mapM_ (storeRef "SPREV") mdPrev @@ -152,13 +166,11 @@ threadToList thread = helper S.empty $ thread helper :: S.Set (Stored (Signed ChatMessageData)) -> [Stored (Signed ChatMessageData)] -> [ChatMessage] helper seen msgs | msg : msgs' <- filter (`S.notMember` seen) $ reverse $ sortBy (comparing cmpView) msgs = - messageFromData msg : helper (S.insert msg seen) (msgs' ++ mdPrev (fromSigned msg)) + maybe id (:) (validateSingleMessage msg) $ + helper (S.insert msg seen) (msgs' ++ mdPrev (fromSigned msg)) | otherwise = [] cmpView msg = (zonedTimeToUTC $ mdTime $ fromSigned msg, msg) - messageFromData :: Stored (Signed ChatMessageData) -> ChatMessage - messageFromData sdata = ChatMessage { cmsgData = sdata } - chatroomMessageByStateData :: (MonadStorage m, MonadHead LocalState m, MonadError String m) => Stored ChatroomStateData -> Text -> m () @@ -170,7 +182,9 @@ chatroomMessageByStateData lookupData msg = void $ findAndUpdateChatroomState $ time <- liftIO getZonedTime mdata <- mstore =<< sign secret =<< mstore ChatMessageData { mdPrev = roomStateMessageData cstate - , mdRoom = [] + , mdRoom = if null (roomStateMessageData cstate) + then maybe [] roomData (roomStateRoom cstate) + else [] , mdFrom = self , mdReplyTo = Nothing , mdTime = time @@ -365,13 +379,18 @@ makeChatroomDiff [] ys = map (AddedChatroom . snd) ys data ChatroomService = ChatroomService { chatRoomQuery :: Bool , chatRoomInfo :: [Stored (Signed ChatroomData)] + , chatRoomSubscribe :: [Stored (Signed ChatroomData)] + , chatRoomUnsubscribe :: [Stored (Signed ChatroomData)] , chatRoomMessage :: [Stored (Signed ChatMessageData)] } + deriving (Eq) emptyPacket :: ChatroomService emptyPacket = ChatroomService { chatRoomQuery = False , chatRoomInfo = [] + , chatRoomSubscribe = [] + , chatRoomUnsubscribe = [] , chatRoomMessage = [] } @@ -379,17 +398,22 @@ instance Storable ChatroomService where store' ChatroomService {..} = storeRec $ do when chatRoomQuery $ storeEmpty "room-query" forM_ chatRoomInfo $ storeRef "room-info" + forM_ chatRoomSubscribe $ storeRef "room-subscribe" + forM_ chatRoomUnsubscribe $ storeRef "room-unsubscribe" forM_ chatRoomMessage $ storeRef "room-message" load' = loadRec $ do chatRoomQuery <- isJust <$> loadMbEmpty "room-query" chatRoomInfo <- loadRefs "room-info" + chatRoomSubscribe <- loadRefs "room-subscribe" + chatRoomUnsubscribe <- loadRefs "room-unsubscribe" chatRoomMessage <- loadRefs "room-message" return ChatroomService {..} data PeerState = PeerState { psSendRoomUpdates :: Bool , psLastList :: [(Stored ChatroomStateData, ChatroomState)] + , psSubscribedTo :: [ Stored (Signed ChatroomData) ] -- least root for each room } instance Service ChatroomService where @@ -399,6 +423,7 @@ instance Service ChatroomService where emptyServiceState _ = PeerState { psSendRoomUpdates = False , psLastList = [] + , psSubscribedTo = [] } serviceHandler spacket = do @@ -420,7 +445,7 @@ instance Service ChatroomService where maybe [] roomData . roomStateRoom let prev = concatMap roomStateData $ filter isCurrentRoom rooms - prevRoom = concatMap (rsdRoom . fromStored) prev + prevRoom = filterAncestors $ concat $ findProperty ((\case [] -> Nothing; xs -> Just xs) . rsdRoom) prev room = filterAncestors $ (roomInfo : ) prevRoom -- update local state only if we got roomInfo not present there @@ -436,6 +461,51 @@ instance Service ChatroomService where else return set foldM upd roomSet chatRoomInfo + forM_ chatRoomSubscribe $ \subscribeData -> do + mbRoomState <- findChatroomByRoomData subscribeData + forM_ mbRoomState $ \roomState -> + forM (roomStateRoom roomState) $ \room -> do + let leastRoot = head . filterAncestors . concatMap storedRoots . roomData $ room + svcModify $ \ps -> ps { psSubscribedTo = leastRoot : psSubscribedTo ps } + replyPacket emptyPacket + { chatRoomMessage = roomStateMessageData roomState + } + + forM_ chatRoomUnsubscribe $ \unsubscribeData -> do + mbRoomState <- findChatroomByRoomData unsubscribeData + forM_ (mbRoomState >>= roomStateRoom) $ \room -> do + let leastRoot = head . filterAncestors . concatMap storedRoots . roomData $ room + svcModify $ \ps -> ps { psSubscribedTo = filter (/= leastRoot) (psSubscribedTo ps) } + + when (not (null chatRoomMessage)) $ do + updateLocalHead_ $ updateSharedState_ $ \roomSet -> do + let rooms = fromSetBy (comparing $ roomName <=< roomStateRoom) roomSet + upd set (msgData :: Stored (Signed ChatMessageData)) + | Just msg <- validateSingleMessage msgData = do + let roomInfo = cmsgRoomData msg + currentRoots = filterAncestors $ concatMap storedRoots roomInfo + isCurrentRoom = any ((`intersectsSorted` currentRoots) . storedRoots) . + maybe [] roomData . roomStateRoom + + let prevData = concatMap roomStateData $ filter isCurrentRoom rooms + prev = mergeSorted prevData + prevMessages = roomStateMessageData prev + messages = filterAncestors $ msgData : prevMessages + + -- update local state only if subscribed and we got some new messages + if roomStateSubscribe prev && messages /= prevMessages + then do + sdata <- mstore ChatroomStateData + { rsdPrev = prevData + , rsdRoom = [] + , rsdSubscribe = Nothing + , rsdMessages = messages + } + storeSetAddComponent sdata set + else return set + | otherwise = return set + foldM upd roomSet chatRoomMessage + serviceNewPeer = do replyPacket emptyPacket { chatRoomQuery = True } @@ -447,11 +517,50 @@ syncChatroomsToPeer set = do ps@PeerState {..} <- svcGet when psSendRoomUpdates $ do let curList = chatroomSetToList set - updates <- fmap (concat . catMaybes) $ - forM (makeChatroomDiff psLastList curList) $ return . \case + diff = makeChatroomDiff psLastList curList + + roomUpdates <- fmap (concat . catMaybes) $ + forM diff $ return . \case AddedChatroom room -> roomData <$> roomStateRoom room RemovedChatroom {} -> Nothing - UpdatedChatroom _ room -> roomData <$> roomStateRoom room - when (not $ null updates) $ do - replyPacket $ emptyPacket { chatRoomInfo = updates } + UpdatedChatroom oldroom room + | roomStateData oldroom /= roomStateData room -> roomData <$> roomStateRoom room + | otherwise -> Nothing + + (subscribe, unsubscribe) <- fmap (partitionEithers . concat . catMaybes) $ + forM diff $ return . \case + AddedChatroom room + | roomStateSubscribe room + -> map Left . roomData <$> roomStateRoom room + RemovedChatroom oldroom + | roomStateSubscribe oldroom + -> map Right . roomData <$> roomStateRoom oldroom + UpdatedChatroom oldroom room + | roomStateSubscribe oldroom /= roomStateSubscribe room + -> map (if roomStateSubscribe room then Left else Right) . roomData <$> roomStateRoom room + _ -> Nothing + + messages <- fmap concat $ do + let leastRootFor = head . filterAncestors . concatMap storedRoots . roomData + forM diff $ return . \case + AddedChatroom rstate + | Just room <- roomStateRoom rstate + , leastRootFor room `elem` psSubscribedTo + -> roomStateMessageData rstate + UpdatedChatroom oldstate rstate + | Just room <- roomStateRoom rstate + , leastRootFor room `elem` psSubscribedTo + , roomStateMessageData oldstate /= roomStateMessageData rstate + -> roomStateMessageData rstate + _ -> [] + + let packet = emptyPacket + { chatRoomInfo = roomUpdates + , chatRoomSubscribe = subscribe + , chatRoomUnsubscribe = unsubscribe + , chatRoomMessage = messages + } + + when (packet /= emptyPacket) $ do + replyPacket packet svcSet $ ps { psLastList = curList } diff --git a/test/chatroom.test b/test/chatroom.test index 9be5665..c4cdc6d 100644 --- a/test/chatroom.test +++ b/test/chatroom.test @@ -98,25 +98,144 @@ test ChatroomSetup: test ChatroomMessages: spawn as p1 + spawn as p2 send "create-identity Device1 Owner1" to p1 + send "create-identity Device2 Owner2" to p2 - for p in [ p1 ]: + for p in [ p1, p2 ]: with p: send "chatroom-watch-local" send "start-server" - send "chatroom-create room" to p1 - expect /chatroom-create-done ([a-z0-9#]+) room.*/ from p1 capture room + send "chatroom-create first_room" to p1 + expect /chatroom-create-done ([a-z0-9#]+) first_room.*/ from p1 capture room1_p1 - for p in [ p1 ]: - with p: - expect /chatroom-watched-added [a-z0-9#]+ room sub [a-z]+/ + expect /chatroom-watched-added [a-z0-9#]+ first_room sub true/ from p1 + expect /chatroom-watched-added ([a-z0-9#]+) first_room sub false/ from p2 capture room1_p2 - send "chatroom-message-send $room message1" to p1 - expect /chatroom-message-new $room from Owner1 text message1/ from p1 + send "chatroom-message-send $room1_p1 message1" to p1 + expect /chatroom-message-new $room1_p1 room first_room from Owner1 text message1/ from p1 - send "chatroom-message-send $room message2" to p1 + send "chatroom-message-send $room1_p1 message2" to p1 local: - expect /chatroom-message-new $room from Owner1 text (.*)/ from p1 capture msg + expect /chatroom-message-new $room1_p1 room first_room from Owner1 text (.*)/ from p1 capture msg guard (msg == "message2") + + # Subscribe to chatroom + + send "chatroom-subscribe $room1_p2" to p2 + expect /chatroom-watched-updated [a-z0-9#]+ first_room sub true .*/ from p2 + with p2: + expect /chatroom-message-new $room1_p2 room first_room from Owner1 text (.*)/ capture msg + guard (msg == "message1") + with p2: + expect /chatroom-message-new $room1_p2 room first_room from Owner1 text (.*)/ capture msg + guard (msg == "message2") + + send "chatroom-message-send $room1_p2 message3" to p2 + for p in [ p1, p2 ]: + with p: + expect /chatroom-message-new [a-z0-9#]+ room first_room from Owner2 text message3/ + + send "chatroom-message-send $room1_p1 message4" to p1 + for p in [ p1, p2 ]: + with p: + expect /chatroom-message-new [a-z0-9#]+ room first_room from Owner1 text message4/ + + # Multiple rooms + + send "chatroom-create second_room" to p1 + expect /chatroom-create-done ([a-z0-9#]+) second_room.*/ from p1 capture room2_p1 + + send "chatroom-create third_room" to p2 + expect /chatroom-create-done ([a-z0-9#]+) third_room.*/ from p2 capture room3_p2 + + expect /chatroom-watched-added $room2_p1 second_room sub true/ from p1 + expect /chatroom-watched-added $room3_p2 third_room sub true/ from p2 + expect /chatroom-watched-added ([a-z0-9#]+) second_room sub false/ from p2 capture room2_p2 + expect /chatroom-watched-added ([a-z0-9#]+) third_room sub false/ from p1 capture room3_p1 + + spawn as p3 + send "create-identity Device3 Owner3" to p3 + send "chatroom-watch-local" to p3 + send "start-server" to p3 + expect /chatroom-watched-added ([a-z0-9#]+) first_room sub false/ from p3 capture room1_p3 + expect /chatroom-watched-added ([a-z0-9#]+) second_room sub false/ from p3 capture room2_p3 + expect /chatroom-watched-added ([a-z0-9#]+) third_room sub false/ from p3 capture room3_p3 + + with p3: + for room in [ room1_p3, room2_p3, room3_p3 ]: + send "chatroom-subscribe $room" + expect /chatroom-watched-updated $room [a-z_]+ sub true .*/ + for i in [1..4]: + expect /chatroom-message-new $room1_p3 room first_room from Owner. text (.*)/ capture message + guard (message == "message$i") + + with p2: + send "chatroom-message-send $room2_p2 msg_r2_1" + send "chatroom-message-send $room2_p2 msg_r2_2" + send "chatroom-message-send $room2_p2 msg_r2_3" + expect /chatroom-message-new $room2_p2 room second_room from Owner2 text msg_r2_1/ + expect /chatroom-message-new $room2_p2 room second_room from Owner2 text msg_r2_2/ + expect /chatroom-message-new $room2_p2 room second_room from Owner2 text msg_r2_3/ + + send "chatroom-message-send $room3_p2 msg_r3_1" + send "chatroom-message-send $room3_p2 msg_r3_2" + send "chatroom-message-send $room3_p2 msg_r3_3" + expect /chatroom-message-new $room3_p2 room third_room from Owner2 text msg_r3_1/ + expect /chatroom-message-new $room3_p2 room third_room from Owner2 text msg_r3_2/ + expect /chatroom-message-new $room3_p2 room third_room from Owner2 text msg_r3_3/ + + with p1: + local: + expect /chatroom-message-new [a-z0-9#]+ room ([a-z_]+) from Owner2 text ([a-z0-9_]+)/ capture room, message + guard (room == "second_room") + guard (message == "msg_r2_1") + local: + expect /chatroom-message-new [a-z0-9#]+ room ([a-z_]+) from Owner2 text ([a-z0-9_]+)/ capture room, message + guard (room == "second_room") + guard (message == "msg_r2_2") + local: + expect /chatroom-message-new [a-z0-9#]+ room ([a-z_]+) from Owner2 text ([a-z0-9_]+)/ capture room, message + guard (room == "second_room") + guard (message == "msg_r2_3") + + with p3: + expect /chatroom-message-new $room2_p3 room second_room from Owner2 text msg_r2_1/ + expect /chatroom-message-new $room2_p3 room second_room from Owner2 text msg_r2_2/ + expect /chatroom-message-new $room2_p3 room second_room from Owner2 text msg_r2_3/ + expect /chatroom-message-new $room3_p3 room third_room from Owner2 text msg_r3_1/ + expect /chatroom-message-new $room3_p3 room third_room from Owner2 text msg_r3_2/ + expect /chatroom-message-new $room3_p3 room third_room from Owner2 text msg_r3_3/ + + # Unsubscribe + + send "chatroom-unsubscribe $room1_p1" to p1 + expect /chatroom-watched-updated $room1_p1 [a-z_]+ sub false .*/ from p1 + send "chatroom-unsubscribe $room1_p3" to p3 + expect /chatroom-watched-updated $room1_p3 [a-z_]+ sub false .*/ from p3 + send "chatroom-unsubscribe $room2_p3" to p3 + expect /chatroom-watched-updated $room2_p3 [a-z_]+ sub false .*/ from p3 + + with p2: + send "chatroom-message-send $room1_p2 msg_r1_4" + expect /chatroom-message-new $room1_p2 room first_room from Owner2 text msg_r1_4/ + + send "chatroom-message-send $room2_p2 msg_r2_4" + expect /chatroom-message-new $room2_p2 room second_room from Owner2 text msg_r2_4/ + + send "chatroom-message-send $room3_p2 msg_r3_4" + expect /chatroom-message-new $room3_p2 room third_room from Owner2 text msg_r3_4/ + + with p1: + local: + expect /chatroom-message-new [a-z0-9#]+ room ([a-z_]+) from Owner2 text ([a-z0-9_]+)/ capture room, message + guard (room == "second_room") + guard (message == "msg_r2_4") + + with p3: + local: + expect /chatroom-message-new [a-z0-9#]+ room ([a-z_]+) from Owner2 text ([a-z0-9_]+)/ capture room, message + guard (room == "third_room") + guard (message == "msg_r3_4") -- cgit v1.2.3