Chatroom subscriptions

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 "<unnamed>" T.unpack $ roomName =<< cmsgRoom msg ]
                             , [ "from", maybe "<unnamed>" 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")