From d8e2b580d7569e2a3d6d775515582be898ee265f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Sat, 10 Aug 2024 21:52:06 +0200 Subject: Chatroom members and join/leave commands --- README.md | 11 +++++++ main/Main.hs | 25 +++++++++++++-- main/Test.hs | 24 +++++++++++++++ src/Erebos/Chatroom.hs | 65 ++++++++++++++++++++++++++++++--------- test/chatroom.test | 82 ++++++++++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 190 insertions(+), 17 deletions(-) diff --git a/README.md b/README.md index ac262d9..9535aab 100644 --- a/README.md +++ b/README.md @@ -121,6 +121,17 @@ are signed, so message author can not be forged. : Create public unmoderated chatroom. Room name can be passed as command argument or entered interactively. +`/members` +: List members of the chatroom – usesers who sent any message or joined via the +`join` command. + +`/join` +: Join chatroom without sending text message. + +`/leave` +: Leave the chatroom. User will no longer be listed as a member and erebos tool + will no longer collect message of this chatroom. + ### Add contacts To ensure the identity of the contact and prevent man-in-the-middle attack, diff --git a/main/Main.hs b/main/Main.hs index e7615ed..94c0418 100644 --- a/main/Main.hs +++ b/main/Main.hs @@ -452,6 +452,11 @@ getSelectedPeer = gets csContext >>= \case SelectedPeer peer -> return peer _ -> throwError "no peer selected" +getSelectedChatroom :: CommandM ChatroomState +getSelectedChatroom = gets csContext >>= \case + SelectedChatroom rstate -> return rstate + _ -> throwError "no chatroom selected" + getSelectedConversation :: CommandM Conversation getSelectedConversation = gets csContext >>= \case SelectedPeer peer -> peerIdentity peer >>= \case @@ -496,6 +501,9 @@ commands = , ("ice-connect", cmdIceConnect) , ("ice-send", cmdIceSend) #endif + , ("join", cmdJoin) + , ("leave", cmdLeave) + , ("members", cmdMembers) , ("select", cmdSelectContext) , ("quit", cmdQuit) ] @@ -548,6 +556,19 @@ showPeer pidentity paddr = PeerIdentityFull pid -> T.unpack $ displayIdentity pid in name ++ " [" ++ show paddr ++ "]" +cmdJoin :: Command +cmdJoin = joinChatroom =<< getSelectedChatroom + +cmdLeave :: Command +cmdLeave = leaveChatroom =<< getSelectedChatroom + +cmdMembers :: Command +cmdMembers = do + Just room <- findChatroomByStateData . head . roomStateData =<< getSelectedChatroom + forM_ (chatroomMembers room) $ \x -> do + liftIO $ putStrLn $ maybe "" T.unpack $ idName x + + cmdSelectContext :: Command cmdSelectContext = do n <- read <$> asks ciLine @@ -653,8 +674,8 @@ watchChatroomsForCli eprint h chatroomSetVar contextVar autoSubscribe = do [ maybe "" T.unpack $ roomName =<< cmsgRoom msg , formatTime defaultTimeLocale " [%H:%M] " $ utcToLocalTime tzone $ zonedTimeToUTC $ cmsgTime msg , maybe "" T.unpack $ idName $ cmsgFrom msg - , ": " - , maybe "" T.unpack $ cmsgText msg + , if cmsgLeave msg then " left" else "" + , maybe (if cmsgLeave msg then "" else " joined") ((": " ++) . T.unpack) $ cmsgText msg ] modifyMVar_ subscribedNumVar $ return . (if roomStateSubscribe rstate then (+ 1) else id) diff --git a/main/Test.hs b/main/Test.hs index 6e10b54..c6448b8 100644 --- a/main/Test.hs +++ b/main/Test.hs @@ -283,6 +283,9 @@ commands = map (T.pack *** id) , ("chatroom-set-name", cmdChatroomSetName) , ("chatroom-subscribe", cmdChatroomSubscribe) , ("chatroom-unsubscribe", cmdChatroomUnsubscribe) + , ("chatroom-members", cmdChatroomMembers) + , ("chatroom-join", cmdChatroomJoin) + , ("chatroom-leave", cmdChatroomLeave) , ("chatroom-message-send", cmdChatroomMessageSend) ] @@ -732,6 +735,7 @@ cmdChatroomWatchLocal = do , [ show . refDigest . storedRef . head . filterAncestors . concatMap storedRoots . toComponents $ room ] , [ "room", maybe "" T.unpack $ roomName =<< cmsgRoom msg ] , [ "from", maybe "" T.unpack $ idName $ cmsgFrom msg ] + , if cmsgLeave msg then [ "leave" ] else [] , maybe [] (("text":) . (:[]) . T.unpack) $ cmsgText msg ] @@ -754,6 +758,26 @@ cmdChatroomUnsubscribe = do to <- getChatroomStateData cid void $ chatroomSetSubscribe to False +cmdChatroomMembers :: Command +cmdChatroomMembers = do + [ cid ] <- asks tiParams + Just chatroom <- findChatroomByStateData =<< getChatroomStateData cid + forM_ (chatroomMembers chatroom) $ \user -> do + cmdOut $ unwords [ "chatroom-members-item", maybe "" T.unpack $ idName user ] + cmdOut "chatroom-members-done" + +cmdChatroomJoin :: Command +cmdChatroomJoin = do + [ cid ] <- asks tiParams + joinChatroomByStateData =<< getChatroomStateData cid + cmdOut "chatroom-join-done" + +cmdChatroomLeave :: Command +cmdChatroomLeave = do + [ cid ] <- asks tiParams + leaveChatroomByStateData =<< getChatroomStateData cid + cmdOut "chatroom-leave-done" + cmdChatroomMessageSend :: Command cmdChatroomMessageSend = do [cid, msg] <- asks tiParams diff --git a/src/Erebos/Chatroom.hs b/src/Erebos/Chatroom.hs index ae373b6..c8b5805 100644 --- a/src/Erebos/Chatroom.hs +++ b/src/Erebos/Chatroom.hs @@ -11,6 +11,9 @@ module Erebos.Chatroom ( findChatroomByRoomData, findChatroomByStateData, chatroomSetSubscribe, + chatroomMembers, + joinChatroom, joinChatroomByStateData, + leaveChatroom, leaveChatroomByStateData, getMessagesSinceState, ChatroomSetChange(..), @@ -33,6 +36,8 @@ import Control.Monad.IO.Class import Data.Bool import Data.Either +import Data.Foldable +import Data.Function import Data.IORef import Data.List import Data.Maybe @@ -180,23 +185,23 @@ sendChatroomMessage rstate msg = sendChatroomMessageByStateData (head $ roomStat sendChatroomMessageByStateData :: (MonadStorage m, MonadHead LocalState m, MonadError String m) => Stored ChatroomStateData -> Text -> m () -sendChatroomMessageByStateData lookupData msg = void $ findAndUpdateChatroomState $ \cstate -> do +sendChatroomMessageByStateData lookupData msg = sendRawChatroomMessageByStateData lookupData Nothing (Just msg) False + +sendRawChatroomMessageByStateData + :: (MonadStorage m, MonadHead LocalState m, MonadError String m) + => Stored ChatroomStateData -> Maybe (Stored (Signed ChatMessageData)) -> Maybe Text -> Bool -> m () +sendRawChatroomMessageByStateData lookupData mdReplyTo mdText mdLeave = 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 = if null (roomStateMessageData cstate) - then maybe [] roomData (roomStateRoom cstate) - else [] - , mdFrom = self - , mdReplyTo = Nothing - , mdTime = time - , mdText = Just msg - , mdLeave = False - } + mdFrom <- finalOwner . localIdentity . fromStored <$> getLocalHead + secret <- loadKey $ idKeyMessage mdFrom + mdTime <- liftIO getZonedTime + let mdPrev = roomStateMessageData cstate + mdRoom = if null (roomStateMessageData cstate) + then maybe [] roomData (roomStateRoom cstate) + else [] + + mdata <- mstore =<< sign secret =<< mstore ChatMessageData {..} mergeSorted . (:[]) <$> mstore ChatroomStateData { rsdPrev = roomStateData cstate , rsdRoom = [] @@ -341,6 +346,36 @@ chatroomSetSubscribe lookupData subscribe = void $ findAndUpdateChatroomState $ , rsdMessages = [] } +chatroomMembers :: ChatroomState -> [ ComposedIdentity ] +chatroomMembers ChatroomState {..} = + map (mdFrom . fromSigned . head) $ + filter (any $ not . mdLeave . fromSigned) $ -- keep only users that hasn't left + map (filterAncestors . map snd) $ -- gather message data per each identity and filter ancestors + groupBy ((==) `on` fst) $ -- group on identity root + sortBy (comparing fst) $ -- sort by first root of identity data + map (\x -> ( head . filterAncestors . concatMap storedRoots . idDataF . mdFrom . fromSigned $ x, x )) $ + toList $ ancestors $ roomStateMessageData + +joinChatroom + :: (MonadStorage m, MonadHead LocalState m, MonadError String m) + => ChatroomState -> m () +joinChatroom rstate = joinChatroomByStateData (head $ roomStateData rstate) + +joinChatroomByStateData + :: (MonadStorage m, MonadHead LocalState m, MonadError String m) + => Stored ChatroomStateData -> m () +joinChatroomByStateData lookupData = sendRawChatroomMessageByStateData lookupData Nothing Nothing False + +leaveChatroom + :: (MonadStorage m, MonadHead LocalState m, MonadError String m) + => ChatroomState -> m () +leaveChatroom rstate = leaveChatroomByStateData (head $ roomStateData rstate) + +leaveChatroomByStateData + :: (MonadStorage m, MonadHead LocalState m, MonadError String m) + => Stored ChatroomStateData -> m () +leaveChatroomByStateData lookupData = sendRawChatroomMessageByStateData lookupData Nothing Nothing True + getMessagesSinceState :: ChatroomState -> ChatroomState -> [ChatMessage] getMessagesSinceState cur old = threadToListSince (roomStateMessageData old) (roomStateMessageData cur) diff --git a/test/chatroom.test b/test/chatroom.test index 1998290..93de1ff 100644 --- a/test/chatroom.test +++ b/test/chatroom.test @@ -344,3 +344,85 @@ test ParallelThreads: with p2: expect /chatroom-message-new $room1_p2 room first_room from Owner. text message(..)/ capture msg guard (msg == "1B") + + +test ChatroomMembers: + spawn as p1 + spawn as p2 + spawn as p3 + + send "create-identity Device1 Owner1" to p1 + send "create-identity Device2 Owner2" to p2 + send "create-identity Device3 Owner3" to p3 + + for p in [ p1, p2, p3 ]: + with p: + send "chatroom-watch-local" + send "start-server" + + send "chatroom-create first_room" to p1 + expect /chatroom-create-done ([a-z0-9#]+) first_room.*/ from p1 capture room1_p1 + + expect /chatroom-watched-added $room1_p1 first_room sub true/ from p1 + expect /chatroom-watched-added ([a-z0-9#]+) first_room sub false/ from p2 capture room1_p2 + expect /chatroom-watched-added ([a-z0-9#]+) first_room sub false/ from p3 capture room1_p3 + + local: + send "chatroom-members $room1_p1" to p1 + expect /chatroom-members-([a-z]+)/ from p1 capture done + guard (done == "done") + local: + send "chatroom-members $room1_p2" to p2 + expect /chatroom-members-([a-z]+)/ from p2 capture done + guard (done == "done") + + send "chatroom-message-send $room1_p1 message1" to p1 + send "chatroom-message-send $room1_p1 message2" to p1 + send "chatroom-join $room1_p2" to p2 + send "chatroom-message-send $room1_p2 message3" to p2 + send "chatroom-join $room1_p3" to p3 + + with p1: + expect /chatroom-message-new $room1_p1 room first_room from Owner1 text message2/ + expect /chatroom-message-new $room1_p1 room first_room from Owner2 text message3/ + expect /chatroom-message-new $room1_p1 room first_room from Owner3/ + with p2: + expect /chatroom-message-new $room1_p2 room first_room from Owner1 text message2/ + expect /chatroom-message-new $room1_p2 room first_room from Owner2 text message3/ + expect /chatroom-message-new $room1_p2 room first_room from Owner3/ + with p3: + expect /chatroom-message-new $room1_p3 room first_room from Owner1 text message2/ + expect /chatroom-message-new $room1_p3 room first_room from Owner2 text message3/ + expect /chatroom-message-new $room1_p3 room first_room from Owner3/ + + local: + send "chatroom-members $room1_p1" to p1 + expect /chatroom-members-item Owner1/ from p1 + expect /chatroom-members-item Owner2/ from p1 + expect /chatroom-members-item Owner3/ from p1 + expect /chatroom-members-([a-z]+)/ from p1 capture done + guard (done == "done") + local: + send "chatroom-members $room1_p2" to p2 + expect /chatroom-members-item Owner1/ from p2 + expect /chatroom-members-item Owner2/ from p2 + expect /chatroom-members-item Owner3/ from p2 + expect /chatroom-members-([a-z]+)/ from p2 capture done + guard (done == "done") + + send "chatroom-leave $room1_p1" to p1 + send "chatroom-leave $room1_p3" to p3 + + for p in [ p1, p2, p3 ]: + with p: + expect /chatroom-message-new [a-z0-9#]+ room first_room from Owner1 leave/ + expect /chatroom-message-new [a-z0-9#]+ room first_room from Owner3 leave/ + + send "chatroom-members $room1_p1" to p1 + send "chatroom-members $room1_p2" to p2 + send "chatroom-members $room1_p3" to p3 + for p in [ p1, p2, p3 ]: + with p: + expect /chatroom-members-item Owner2/ + expect /chatroom-members-([a-z]+)/ capture done + guard (done == "done") -- cgit v1.2.3