Subscribe flag in chatroom state

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 "<unnamed>" 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