From 15f7d82c37cb1b0e12a1eade91e0db2e132d4c60 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Wed, 26 Jun 2024 22:40:20 +0200 Subject: Subscribe flag in chatroom state --- main/Test.hs | 18 +++++++++++++++++- src/Erebos/Chatroom.hs | 26 +++++++++++++++++++++++++- test/chatroom.test | 41 +++++++++++++++++++++++++++++++---------- 3 files changed, 73 insertions(+), 12 deletions(-) diff --git a/main/Test.hs b/main/Test.hs index cdc337e..a957f4b 100644 --- a/main/Test.hs +++ b/main/Test.hs @@ -12,6 +12,7 @@ import Control.Monad.State import Crypto.Random +import Data.Bool import Data.ByteString qualified as B import Data.ByteString.Char8 qualified as BC import Data.ByteString.Lazy qualified as BL @@ -271,6 +272,8 @@ commands = map (T.pack *** id) , ("chatroom-list-local", cmdChatroomListLocal) , ("chatroom-watch-local", cmdChatroomWatchLocal) , ("chatroom-set-name", cmdChatroomSetName) + , ("chatroom-subscribe", cmdChatroomSubscribe) + , ("chatroom-unsubscribe", cmdChatroomUnsubscribe) , ("chatroom-message-send", cmdChatroomMessageSend) ] @@ -655,7 +658,7 @@ cmdChatroomWatchLocal = do AddedChatroom room -> outLine out $ unwords $ "chatroom-watched-added" : chatroomInfo room RemovedChatroom room -> outLine out $ unwords $ "chatroom-watched-removed" : chatroomInfo room UpdatedChatroom oldroom room -> do - when (any (not . null . rsdRoom . fromStored) (roomStateData room)) $ do + when (any ((\rsd -> not (null (rsdRoom rsd)) || not (null (rsdSubscribe rsd))) . fromStored) (roomStateData room)) $ do outLine out $ unwords $ concat [ [ "chatroom-watched-updated" ], chatroomInfo room , [ "old" ], map (show . refDigest . storedRef) (roomStateData oldroom) @@ -674,8 +677,21 @@ chatroomInfo :: ChatroomState -> [String] chatroomInfo room = [ show . refDigest . storedRef . head . filterAncestors . concatMap storedRoots . toComponents $ room , maybe "" T.unpack $ roomName =<< roomStateRoom room + , "sub " <> bool "false" "true" (roomStateSubscribe room) ] +cmdChatroomSubscribe :: Command +cmdChatroomSubscribe = do + [ cid ] <- asks tiParams + to <- getChatroomStateData cid + void $ chatroomSetSubscribe to True + +cmdChatroomUnsubscribe :: Command +cmdChatroomUnsubscribe = do + [ cid ] <- asks tiParams + to <- getChatroomStateData cid + void $ chatroomSetSubscribe to False + cmdChatroomMessageSend :: Command cmdChatroomMessageSend = do [cid, msg] <- asks tiParams diff --git a/src/Erebos/Chatroom.hs b/src/Erebos/Chatroom.hs index 3a2628d..673c59f 100644 --- a/src/Erebos/Chatroom.hs +++ b/src/Erebos/Chatroom.hs @@ -10,6 +10,7 @@ module Erebos.Chatroom ( listChatrooms, findChatroomByRoomData, findChatroomByStateData, + chatroomSetSubscribe, getMessagesSinceState, ChatroomSetChange(..), @@ -27,6 +28,7 @@ import Control.Monad import Control.Monad.Except import Control.Monad.IO.Class +import Data.Bool import Data.IORef import Data.List import Data.Maybe @@ -178,6 +180,7 @@ chatroomMessageByStateData lookupData msg = void $ findAndUpdateChatroomState $ mergeSorted . (:[]) <$> mstore ChatroomStateData { rsdPrev = roomStateData cstate , rsdRoom = [] + , rsdSubscribe = Just True , rsdMessages = [ mdata ] } @@ -185,6 +188,7 @@ chatroomMessageByStateData lookupData msg = void $ findAndUpdateChatroomState $ data ChatroomStateData = ChatroomStateData { rsdPrev :: [Stored ChatroomStateData] , rsdRoom :: [Stored (Signed ChatroomData)] + , rsdSubscribe :: Maybe Bool , rsdMessages :: [Stored (Signed ChatMessageData)] } @@ -192,6 +196,7 @@ data ChatroomState = ChatroomState { roomStateData :: [Stored ChatroomStateData] , roomStateRoom :: Maybe Chatroom , roomStateMessageData :: [Stored (Signed ChatMessageData)] + , roomStateSubscribe :: Bool , roomStateMessages :: [ChatMessage] } @@ -199,11 +204,13 @@ instance Storable ChatroomStateData where store' ChatroomStateData {..} = storeRec $ do forM_ rsdPrev $ storeRef "PREV" forM_ rsdRoom $ storeRef "room" + forM_ rsdSubscribe $ storeInt "subscribe" . bool @Int 0 1 forM_ rsdMessages $ storeRef "msg" load' = loadRec $ do rsdPrev <- loadRefs "PREV" rsdRoom <- loadRefs "room" + rsdSubscribe <- fmap ((/=) @Int 0) <$> loadMbInt "subscribe" rsdMessages <- loadRefs "msg" return ChatroomStateData {..} @@ -216,6 +223,7 @@ instance Mergeable ChatroomState where roomStateMessageData = filterAncestors $ concat $ flip findProperty roomStateData $ \case ChatroomStateData {..} | null rsdMessages -> Nothing | otherwise -> Just rsdMessages + roomStateSubscribe = fromMaybe False $ findPropertyFirst rsdSubscribe roomStateData roomStateMessages = threadToList $ concatMap (rsdMessages . fromStored) roomStateData in ChatroomState {..} @@ -232,6 +240,7 @@ createChatroom rdName rdDescription = do cstate <- mergeSorted . (:[]) <$> mstore ChatroomStateData { rsdPrev = [] , rsdRoom = [ rdata ] + , rsdSubscribe = Just True , rsdMessages = [] } @@ -278,6 +287,7 @@ updateChatroomByStateData lookupData newName newDesc = findAndUpdateChatroomStat mergeSorted . (:[]) <$> mstore ChatroomStateData { rsdPrev = roomStateData cstate , rsdRoom = [ rdata ] + , rsdSubscribe = Just True , rsdMessages = [] } @@ -298,6 +308,19 @@ findChatroomByRoomData cdata = findChatroom $ findChatroomByStateData :: MonadHead LocalState m => Stored ChatroomStateData -> m (Maybe ChatroomState) findChatroomByStateData cdata = findChatroom $ any (cdata `precedesOrEquals`) . roomStateData +chatroomSetSubscribe + :: (MonadStorage m, MonadHead LocalState m, MonadError String m) + => Stored ChatroomStateData -> Bool -> m () +chatroomSetSubscribe lookupData subscribe = void $ findAndUpdateChatroomState $ \cstate -> do + guard $ any (lookupData `precedesOrEquals`) $ roomStateData cstate + Just $ do + mergeSorted . (:[]) <$> mstore ChatroomStateData + { rsdPrev = roomStateData cstate + , rsdRoom = [] + , rsdSubscribe = Just subscribe + , rsdMessages = [] + } + getMessagesSinceState :: ChatroomState -> ChatroomState -> [ChatMessage] getMessagesSinceState cur old = takeWhile notOld (roomStateMessages cur) where @@ -394,7 +417,7 @@ instance Service ChatroomService where upd set (roomInfo :: Stored (Signed ChatroomData)) = do let currentRoots = storedRoots roomInfo isCurrentRoom = any ((`intersectsSorted` currentRoots) . storedRoots) . - concatMap (rsdRoom . fromStored) . roomStateData + maybe [] roomData . roomStateRoom let prev = concatMap roomStateData $ filter isCurrentRoom rooms prevRoom = concatMap (rsdRoom . fromStored) prev @@ -406,6 +429,7 @@ instance Service ChatroomService where sdata <- mstore ChatroomStateData { rsdPrev = prev , rsdRoom = room + , rsdSubscribe = Nothing , rsdMessages = [] } storeSetAddComponent sdata set diff --git a/test/chatroom.test b/test/chatroom.test index ffb7b4d..9be5665 100644 --- a/test/chatroom.test +++ b/test/chatroom.test @@ -10,8 +10,8 @@ test ChatroomSetup: send "chatroom-list-local" - expect /chatroom-list-item ([a-z0-9#]+) first/ capture first - expect /chatroom-list-item [a-z0-9#]+ second/ + expect /chatroom-list-item ([a-z0-9#]+) first sub true/ capture first + expect /chatroom-list-item [a-z0-9#]+ second sub true/ local: expect /chatroom-list-(.*)/ capture done guard (done == "done") @@ -34,17 +34,38 @@ test ChatroomSetup: for p in [ p2, p3 ]: with p: - expect /chatroom-watched-added [a-z0-9#]+ first/ - expect /chatroom-watched-added [a-z0-9#]+ second/ + expect /chatroom-watched-added [a-z0-9#]+ first sub false/ + expect /chatroom-watched-added [a-z0-9#]+ second sub false/ + + # Subscribe and unsubscribe + + with p1: + send "chatroom-unsubscribe $first" + expect /chatroom-watched-updated [a-z0-9#]+ first sub false .*/ + + send "chatroom-subscribe $first" + expect /chatroom-watched-updated [a-z0-9#]+ first sub true .*/ with p2: send "chatroom-list-local" - expect /chatroom-list-item [a-z0-9#]+ first/ - expect /chatroom-list-item [a-z0-9#]+ second/ + expect /chatroom-list-item ([a-z0-9#]+) first sub false/ capture p2_first + expect /chatroom-list-item ([a-z0-9#]+) second sub false/ capture p2_second local: expect /chatroom-list-(.*)/ capture done guard (done == "done") + send "chatroom-subscribe $p2_first" + send "chatroom-subscribe $p2_second" + + expect /chatroom-watched-updated [a-z0-9#]+ first sub true .*/ + expect /chatroom-watched-updated [a-z0-9#]+ second sub true .*/ + + send "chatroom-unsubscribe $p2_first" + send "chatroom-unsubscribe $p2_second" + + expect /chatroom-watched-updated [a-z0-9#]+ first sub false .*/ + expect /chatroom-watched-updated [a-z0-9#]+ second sub false .*/ + # Create and sync additional chatrooms send "chatroom-create third" to p1 @@ -56,9 +77,9 @@ test ChatroomSetup: for p in [ p1, p2, p3 ]: with p: - expect /chatroom-watched-added [a-z0-9#]+ third/ - expect /chatroom-watched-added [a-z0-9#]+ fourth/ - expect /chatroom-watched-added [a-z0-9#]+ fifth/ + expect /chatroom-watched-added [a-z0-9#]+ third sub [a-z]+/ + expect /chatroom-watched-added [a-z0-9#]+ fourth sub [a-z]+/ + expect /chatroom-watched-added [a-z0-9#]+ fifth sub [a-z]+/ # Update chatroom name @@ -90,7 +111,7 @@ test ChatroomMessages: for p in [ p1 ]: with p: - expect /chatroom-watched-added $room room/ + expect /chatroom-watched-added [a-z0-9#]+ room sub [a-z]+/ send "chatroom-message-send $room message1" to p1 expect /chatroom-message-new $room from Owner1 text message1/ from p1 -- cgit v1.2.3