From 49db4661634b364ea49758666623a2efc3ac7107 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Sat, 18 May 2024 21:01:59 +0200 Subject: Chatroom messages --- main/Test.hs | 27 ++++++++-- src/Erebos/Chatroom.hs | 131 ++++++++++++++++++++++++++++++++++++++++++++++--- test/chatroom.test | 26 ++++++++++ 3 files changed, 173 insertions(+), 11 deletions(-) diff --git a/main/Test.hs b/main/Test.hs index 5e89c66..d16e141 100644 --- a/main/Test.hs +++ b/main/Test.hs @@ -269,6 +269,7 @@ commands = map (T.pack *** id) , ("chatroom-list-local", cmdChatroomListLocal) , ("chatroom-watch-local", cmdChatroomWatchLocal) , ("chatroom-set-name", cmdChatroomSetName) + , ("chatroom-message-send", cmdChatroomMessageSend) ] cmdStore :: Command @@ -628,14 +629,30 @@ cmdChatroomWatchLocal = do Just diff -> forM_ diff $ \case AddedChatroom room -> outLine out $ unwords $ "chatroom-watched-added" : chatroomInfo room RemovedChatroom room -> outLine out $ unwords $ "chatroom-watched-removed" : chatroomInfo room - UpdatedChatroom oldroom room -> outLine out $ unwords $ concat - [ [ "chatroom-watched-updated" ], chatroomInfo room - , [ "old" ], map (show . refDigest . storedRef) (roomStateData oldroom) - , [ "new" ], map (show . refDigest . storedRef) (roomStateData room) - ] + UpdatedChatroom oldroom room -> do + when (any (not . null . rsdRoom . fromStored) (roomStateData room)) $ do + outLine out $ unwords $ concat + [ [ "chatroom-watched-updated" ], chatroomInfo room + , [ "old" ], map (show . refDigest . storedRef) (roomStateData oldroom) + , [ "new" ], map (show . refDigest . storedRef) (roomStateData room) + ] + when (any (not . null . rsdMessages . fromStored) (roomStateData room)) $ do + forM_ (getMessagesSinceState room oldroom) $ \msg -> do + outLine out $ unwords $ concat + [ [ "chatroom-message-new" ] + , [ show . refDigest . storedRef . head . filterAncestors . concatMap storedRoots . toComponents $ room ] + , [ "from", maybe "" T.unpack $ idName $ cmsgFrom msg ] + , maybe [] (("text":) . (:[]) . T.unpack) $ cmsgText msg + ] chatroomInfo :: ChatroomState -> [String] chatroomInfo room = [ show . refDigest . storedRef . head . filterAncestors . concatMap storedRoots . toComponents $ room , maybe "" T.unpack $ roomName =<< roomStateRoom room ] + +cmdChatroomMessageSend :: Command +cmdChatroomMessageSend = do + [cid, msg] <- asks tiParams + to <- getChatroomStateData cid + void $ chatroomMessageByStateData to msg diff --git a/src/Erebos/Chatroom.hs b/src/Erebos/Chatroom.hs index d9e8837..3a2628d 100644 --- a/src/Erebos/Chatroom.hs +++ b/src/Erebos/Chatroom.hs @@ -10,10 +10,15 @@ module Erebos.Chatroom ( listChatrooms, findChatroomByRoomData, findChatroomByStateData, + getMessagesSinceState, ChatroomSetChange(..), watchChatrooms, + ChatMessage, cmsgFrom, cmsgReplyTo, cmsgTime, cmsgText, cmsgLeave, + ChatMessageData(..), + chatroomMessageByStateData, + ChatroomService(..), ) where @@ -27,8 +32,11 @@ import Data.List import Data.Maybe import Data.Monoid import Data.Ord +import Data.Set qualified as S import Data.Text (Text) +import Data.Time +import Erebos.Identity import Erebos.PubKey import Erebos.Service import Erebos.Set @@ -87,34 +95,129 @@ validateChatroom roomData = do in All $ all (fromStored sdata `isSignedBy`) required +data ChatMessageData = ChatMessageData + { mdPrev :: [Stored (Signed ChatMessageData)] + , mdRoom :: [Stored (Signed ChatroomData)] + , mdFrom :: ComposedIdentity + , mdReplyTo :: Maybe (Stored (Signed ChatMessageData)) + , mdTime :: ZonedTime + , mdText :: Maybe Text + , mdLeave :: Bool + } + +data ChatMessage = ChatMessage + { cmsgData :: Stored (Signed ChatMessageData) + } + +cmsgFrom :: ChatMessage -> ComposedIdentity +cmsgFrom = mdFrom . fromSigned . cmsgData + +cmsgReplyTo :: ChatMessage -> Maybe ChatMessage +cmsgReplyTo = fmap ChatMessage . mdReplyTo . fromSigned . cmsgData + +cmsgTime :: ChatMessage -> ZonedTime +cmsgTime = mdTime . fromSigned . cmsgData + +cmsgText :: ChatMessage -> Maybe Text +cmsgText = mdText . fromSigned . cmsgData + +cmsgLeave :: ChatMessage -> Bool +cmsgLeave = mdLeave . fromSigned . cmsgData + +instance Storable ChatMessageData where + store' ChatMessageData {..} = storeRec $ do + mapM_ (storeRef "SPREV") mdPrev + mapM_ (storeRef "room") mdRoom + mapM_ (storeRef "from") $ idExtDataF mdFrom + storeMbRef "reply-to" mdReplyTo + storeDate "time" mdTime + storeMbText "text" mdText + when mdLeave $ storeEmpty "leave" + + load' = loadRec $ do + mdPrev <- loadRefs "SPREV" + mdRoom <- loadRefs "room" + mdFrom <- loadIdentity "from" + mdReplyTo <- loadMbRef "reply-to" + mdTime <- loadDate "time" + mdText <- loadMbText "text" + mdLeave <- isJust <$> loadMbEmpty "leave" + return ChatMessageData {..} + +threadToList :: [Stored (Signed ChatMessageData)] -> [ChatMessage] +threadToList thread = helper S.empty $ thread + where + 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)) + | 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 () +chatroomMessageByStateData lookupData msg = void $ findAndUpdateChatroomState $ \cstate -> do + guard $ any (lookupData `precedesOrEquals`) $ roomStateData cstate + Just $ do + self <- finalOwner . localIdentity . fromStored <$> getLocalHead + secret <- loadKey $ idKeyMessage self + time <- liftIO getZonedTime + mdata <- mstore =<< sign secret =<< mstore ChatMessageData + { mdPrev = roomStateMessageData cstate + , mdRoom = [] + , mdFrom = self + , mdReplyTo = Nothing + , mdTime = time + , mdText = Just msg + , mdLeave = False + } + mergeSorted . (:[]) <$> mstore ChatroomStateData + { rsdPrev = roomStateData cstate + , rsdRoom = [] + , rsdMessages = [ mdata ] + } + + data ChatroomStateData = ChatroomStateData { rsdPrev :: [Stored ChatroomStateData] , rsdRoom :: [Stored (Signed ChatroomData)] + , rsdMessages :: [Stored (Signed ChatMessageData)] } data ChatroomState = ChatroomState { roomStateData :: [Stored ChatroomStateData] , roomStateRoom :: Maybe Chatroom + , roomStateMessageData :: [Stored (Signed ChatMessageData)] + , roomStateMessages :: [ChatMessage] } instance Storable ChatroomStateData where store' ChatroomStateData {..} = storeRec $ do forM_ rsdPrev $ storeRef "PREV" forM_ rsdRoom $ storeRef "room" + forM_ rsdMessages $ storeRef "msg" load' = loadRec $ do rsdPrev <- loadRefs "PREV" rsdRoom <- loadRefs "room" + rsdMessages <- loadRefs "msg" return ChatroomStateData {..} instance Mergeable ChatroomState where type Component ChatroomState = ChatroomStateData - mergeSorted cdata = ChatroomState - { roomStateData = cdata - , roomStateRoom = either (const Nothing) Just $ runExcept $ - validateChatroom $ concat $ findProperty ((\case [] -> Nothing; xs -> Just xs) . rsdRoom) cdata - } + mergeSorted roomStateData = + let roomStateRoom = either (const Nothing) Just $ runExcept $ + validateChatroom $ concat $ findProperty ((\case [] -> Nothing; xs -> Just xs) . rsdRoom) roomStateData + roomStateMessageData = filterAncestors $ concat $ flip findProperty roomStateData $ \case + ChatroomStateData {..} | null rsdMessages -> Nothing + | otherwise -> Just rsdMessages + roomStateMessages = threadToList $ concatMap (rsdMessages . fromStored) roomStateData + in ChatroomState {..} toComponents = roomStateData @@ -129,6 +232,7 @@ createChatroom rdName rdDescription = do cstate <- mergeSorted . (:[]) <$> mstore ChatroomStateData { rsdPrev = [] , rsdRoom = [ rdata ] + , rsdMessages = [] } updateLocalHead $ updateSharedState $ \rooms -> do @@ -174,6 +278,7 @@ updateChatroomByStateData lookupData newName newDesc = findAndUpdateChatroomStat mergeSorted . (:[]) <$> mstore ChatroomStateData { rsdPrev = roomStateData cstate , rsdRoom = [ rdata ] + , rsdMessages = [] } @@ -193,6 +298,12 @@ findChatroomByRoomData cdata = findChatroom $ findChatroomByStateData :: MonadHead LocalState m => Stored ChatroomStateData -> m (Maybe ChatroomState) findChatroomByStateData cdata = findChatroom $ any (cdata `precedesOrEquals`) . roomStateData +getMessagesSinceState :: ChatroomState -> ChatroomState -> [ChatMessage] +getMessagesSinceState cur old = takeWhile notOld (roomStateMessages cur) + where + notOld msg = cmsgData msg `notElem` roomStateMessageData old + -- TODO: parallel message threads + data ChatroomSetChange = AddedChatroom ChatroomState | RemovedChatroom ChatroomState @@ -231,22 +342,26 @@ makeChatroomDiff [] ys = map (AddedChatroom . snd) ys data ChatroomService = ChatroomService { chatRoomQuery :: Bool , chatRoomInfo :: [Stored (Signed ChatroomData)] + , chatRoomMessage :: [Stored (Signed ChatMessageData)] } emptyPacket :: ChatroomService emptyPacket = ChatroomService { chatRoomQuery = False , chatRoomInfo = [] + , chatRoomMessage = [] } instance Storable ChatroomService where store' ChatroomService {..} = storeRec $ do when chatRoomQuery $ storeEmpty "room-query" forM_ chatRoomInfo $ storeRef "room-info" + forM_ chatRoomMessage $ storeRef "room-message" load' = loadRec $ do chatRoomQuery <- isJust <$> loadMbEmpty "room-query" chatRoomInfo <- loadRefs "room-info" + chatRoomMessage <- loadRefs "room-message" return ChatroomService {..} data PeerState = PeerState @@ -288,7 +403,11 @@ instance Service ChatroomService where -- update local state only if we got roomInfo not present there if roomInfo `notElem` prevRoom && roomInfo `elem` room then do - sdata <- mstore ChatroomStateData { rsdPrev = prev, rsdRoom = room } + sdata <- mstore ChatroomStateData + { rsdPrev = prev + , rsdRoom = room + , rsdMessages = [] + } storeSetAddComponent sdata set else return set foldM upd roomSet chatRoomInfo diff --git a/test/chatroom.test b/test/chatroom.test index ac66f38..ffb7b4d 100644 --- a/test/chatroom.test +++ b/test/chatroom.test @@ -73,3 +73,29 @@ test ChatroomSetup: with p: expect /chatroom-watched-updated [a-z0-9#]+ fourth2.*/ expect /chatroom-watched-updated [a-z0-9#]+ fifth2.*/ + + +test ChatroomMessages: + spawn as p1 + + send "create-identity Device1 Owner1" to p1 + + for p in [ p1 ]: + 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 + + for p in [ p1 ]: + with p: + expect /chatroom-watched-added $room room/ + + send "chatroom-message-send $room message1" to p1 + expect /chatroom-message-new $room from Owner1 text message1/ from p1 + + send "chatroom-message-send $room message2" to p1 + local: + expect /chatroom-message-new $room from Owner1 text (.*)/ from p1 capture msg + guard (msg == "message2") -- cgit v1.2.3