summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--main/Test.hs3
-rw-r--r--src/Erebos/Chatroom.hs133
-rw-r--r--test/chatroom.test139
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")
generated by cgit v1.2.3 (git 2.25.1) at 2024-09-05 23:38:12 +0000