diff options
| -rw-r--r-- | README.md | 7 | ||||
| -rw-r--r-- | main/Main.hs | 10 | ||||
| -rw-r--r-- | main/Test.hs | 8 | ||||
| -rw-r--r-- | src/Erebos/Chatroom.hs | 63 | ||||
| -rw-r--r-- | src/Erebos/Conversation.hs | 5 | ||||
| -rw-r--r-- | test/chatroom.test | 171 |
6 files changed, 237 insertions, 27 deletions
@@ -137,6 +137,13 @@ are signed, so message author can not be forged. : Leave the chatroom. User will no longer be listed as a member and erebos tool will no longer collect message of this chatroom. +`/delete` +: Delete the chatroom; this action is only synchronized with devices belonging +to the current user and does not affect the chatroom state for others. Due to +the storage design, the chatroom data will not be purged from the local state +history, but the chatroom will no longer be listed as available and no futher +updates for this chatroom will be collected or shared with other peers. + ### 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 c9c9156..8a4729f 100644 --- a/main/Main.hs +++ b/main/Main.hs @@ -501,6 +501,7 @@ commands = , ("peer-add-public", cmdPeerAddPublic) , ("peer-drop", cmdPeerDrop) , ("send", cmdSend) + , ("delete", cmdDelete) , ("update-identity", cmdUpdateIdentity) , ("attach", cmdAttach) , ("attach-accept", cmdAttachAccept) @@ -632,6 +633,11 @@ cmdSend = void $ do liftIO $ putStrLn $ formatMessage tzone msg Nothing -> return () +cmdDelete :: Command +cmdDelete = void $ do + deleteConversation =<< getSelectedConversation + modify $ \s -> s { csContext = NoContext } + cmdHistory :: Command cmdHistory = void $ do conv <- getSelectedConversation @@ -678,7 +684,7 @@ watchChatroomsForCli eprint h chatroomSetVar contextVar autoSubscribe = do watchChatrooms h $ \set -> \case Nothing -> do - let chatroomList = fromSetBy (comparing roomStateData) set + let chatroomList = filter (not . roomStateDeleted) $ fromSetBy (comparing roomStateData) set (subscribed, notSubscribed) = partition roomStateSubscribe chatroomList subscribedNum = length subscribed @@ -738,7 +744,7 @@ cmdChatrooms :: Command cmdChatrooms = do ensureWatchedChatrooms chatroomSetVar <- asks ciChatroomSetVar - chatroomList <- fromSetBy (comparing roomStateData) <$> liftIO (readMVar chatroomSetVar) + chatroomList <- filter (not . roomStateDeleted) . fromSetBy (comparing roomStateData) <$> liftIO (readMVar chatroomSetVar) set <- asks ciSetContextOptions set $ map SelectedChatroom chatroomList forM_ (zip [1..] chatroomList) $ \(i :: Int, rstate) -> do diff --git a/main/Test.hs b/main/Test.hs index 183ed51..0181575 100644 --- a/main/Test.hs +++ b/main/Test.hs @@ -287,6 +287,7 @@ commands = map (T.pack *** id) , ("dm-list-peer", cmdDmListPeer) , ("dm-list-contact", cmdDmListContact) , ("chatroom-create", cmdChatroomCreate) + , ("chatroom-delete", cmdChatroomDelete) , ("chatroom-list-local", cmdChatroomListLocal) , ("chatroom-watch-local", cmdChatroomWatchLocal) , ("chatroom-set-name", cmdChatroomSetName) @@ -764,6 +765,13 @@ cmdChatroomCreate = do room <- createChatroom (Just name) Nothing cmdOut $ unwords $ "chatroom-create-done" : chatroomInfo room +cmdChatroomDelete :: Command +cmdChatroomDelete = do + [ cid ] <- asks tiParams + sdata <- getChatroomStateData cid + deleteChatroomByStateData sdata + cmdOut $ unwords [ "chatroom-delete-done", T.unpack cid ] + getChatroomStateData :: Text -> CommandM (Stored ChatroomStateData) getChatroomStateData tref = do st <- asks tiStorage diff --git a/src/Erebos/Chatroom.hs b/src/Erebos/Chatroom.hs index 8833450..a616f07 100644 --- a/src/Erebos/Chatroom.hs +++ b/src/Erebos/Chatroom.hs @@ -6,6 +6,7 @@ module Erebos.Chatroom ( ChatroomState(..), ChatroomStateData(..), createChatroom, + deleteChatroomByStateData, updateChatroomByStateData, listChatrooms, findChatroomByRoomData, @@ -206,9 +207,8 @@ sendRawChatroomMessageByStateData lookupData mbIdentity mdReplyTo mdText mdLeave else [] mdata <- mstore =<< sign secret =<< mstore ChatMessageData {..} - mergeSorted . (:[]) <$> mstore ChatroomStateData + mergeSorted . (:[]) <$> mstore emptyChatroomStateData { rsdPrev = roomStateData cstate - , rsdRoom = [] , rsdSubscribe = Just (not mdLeave) , rsdIdentity = mbIdentity , rsdMessages = [ mdata ] @@ -218,15 +218,27 @@ sendRawChatroomMessageByStateData lookupData mbIdentity mdReplyTo mdText mdLeave data ChatroomStateData = ChatroomStateData { rsdPrev :: [Stored ChatroomStateData] , rsdRoom :: [Stored (Signed ChatroomData)] + , rsdDelete :: Bool , rsdSubscribe :: Maybe Bool , rsdIdentity :: Maybe UnifiedIdentity , rsdMessages :: [Stored (Signed ChatMessageData)] } +emptyChatroomStateData :: ChatroomStateData +emptyChatroomStateData = ChatroomStateData + { rsdPrev = [] + , rsdRoom = [] + , rsdDelete = False + , rsdSubscribe = Nothing + , rsdIdentity = Nothing + , rsdMessages = [] + } + data ChatroomState = ChatroomState { roomStateData :: [Stored ChatroomStateData] , roomStateRoom :: Maybe Chatroom , roomStateMessageData :: [Stored (Signed ChatMessageData)] + , roomStateDeleted :: Bool , roomStateSubscribe :: Bool , roomStateIdentity :: Maybe UnifiedIdentity , roomStateMessages :: [ChatMessage] @@ -236,6 +248,7 @@ instance Storable ChatroomStateData where store' ChatroomStateData {..} = storeRec $ do forM_ rsdPrev $ storeRef "PREV" forM_ rsdRoom $ storeRef "room" + when rsdDelete $ storeEmpty "delete" forM_ rsdSubscribe $ storeInt "subscribe" . bool @Int 0 1 forM_ rsdIdentity $ storeRef "id" . idExtData forM_ rsdMessages $ storeRef "msg" @@ -243,6 +256,7 @@ instance Storable ChatroomStateData where load' = loadRec $ do rsdPrev <- loadRefs "PREV" rsdRoom <- loadRefs "room" + rsdDelete <- isJust <$> loadMbEmpty "delete" rsdSubscribe <- fmap ((/=) @Int 0) <$> loadMbInt "subscribe" rsdIdentity <- loadMbUnifiedIdentity "id" rsdMessages <- loadRefs "msg" @@ -257,7 +271,8 @@ instance Mergeable ChatroomState where roomStateMessageData = filterAncestors $ concat $ flip findProperty roomStateData $ \case ChatroomStateData {..} | null rsdMessages -> Nothing | otherwise -> Just rsdMessages - roomStateSubscribe = fromMaybe False $ findPropertyFirst rsdSubscribe roomStateData + roomStateDeleted = any (rsdDelete . fromStored) roomStateData + roomStateSubscribe = not roomStateDeleted && (fromMaybe False $ findPropertyFirst rsdSubscribe roomStateData) roomStateIdentity = findPropertyFirst rsdIdentity roomStateData roomStateMessages = threadToListSince [] $ concatMap (rsdMessages . fromStored) roomStateData in ChatroomState {..} @@ -272,12 +287,9 @@ createChatroom rdName rdDescription = do (secret, rdKey) <- liftIO . generateKeys =<< getStorage let rdPrev = [] rdata <- mstore =<< sign secret =<< mstore ChatroomData {..} - cstate <- mergeSorted . (:[]) <$> mstore ChatroomStateData - { rsdPrev = [] - , rsdRoom = [ rdata ] + cstate <- mergeSorted . (:[]) <$> mstore emptyChatroomStateData + { rsdRoom = [ rdata ] , rsdSubscribe = Just True - , rsdIdentity = Nothing - , rsdMessages = [] } updateLocalHead $ updateSharedState $ \rooms -> do @@ -303,6 +315,17 @@ findAndUpdateChatroomState f = do return (roomSet, Just upd) [] -> return (roomSet, Nothing) +deleteChatroomByStateData + :: (MonadStorage m, MonadHead LocalState m, MonadError String m) + => Stored ChatroomStateData -> m () +deleteChatroomByStateData lookupData = void $ findAndUpdateChatroomState $ \cstate -> do + guard $ any (lookupData `precedesOrEquals`) $ roomStateData cstate + Just $ do + mergeSorted . (:[]) <$> mstore emptyChatroomStateData + { rsdPrev = roomStateData cstate + , rsdDelete = True + } + updateChatroomByStateData :: (MonadStorage m, MonadHead LocalState m, MonadError String m) => Stored ChatroomStateData @@ -320,17 +343,16 @@ updateChatroomByStateData lookupData newName newDesc = findAndUpdateChatroomStat , rdDescription = newDesc , rdKey = roomKey room } - mergeSorted . (:[]) <$> mstore ChatroomStateData + mergeSorted . (:[]) <$> mstore emptyChatroomStateData { rsdPrev = roomStateData cstate , rsdRoom = [ rdata ] , rsdSubscribe = Just True - , rsdIdentity = Nothing - , rsdMessages = [] } listChatrooms :: MonadHead LocalState m => m [ChatroomState] -listChatrooms = fromSetBy (comparing $ roomName <=< roomStateRoom) . +listChatrooms = filter (not . roomStateDeleted) . + fromSetBy (comparing $ roomName <=< roomStateRoom) . lookupSharedValue . lsShared . fromStored <$> getLocalHead findChatroom :: MonadHead LocalState m => (ChatroomState -> Bool) -> m (Maybe ChatroomState) @@ -351,12 +373,9 @@ chatroomSetSubscribe chatroomSetSubscribe lookupData subscribe = void $ findAndUpdateChatroomState $ \cstate -> do guard $ any (lookupData `precedesOrEquals`) $ roomStateData cstate Just $ do - mergeSorted . (:[]) <$> mstore ChatroomStateData + mergeSorted . (:[]) <$> mstore emptyChatroomStateData { rsdPrev = roomStateData cstate - , rsdRoom = [] , rsdSubscribe = Just subscribe - , rsdIdentity = Nothing - , rsdMessages = [] } chatroomMembers :: ChatroomState -> [ ComposedIdentity ] @@ -419,7 +438,7 @@ watchChatrooms h f = liftIO $ do return $ makeChatroomDiff lastList curList chatroomSetToList :: Set ChatroomState -> [(Stored ChatroomStateData, ChatroomState)] -chatroomSetToList = map (cmp &&& id) . fromSetBy (comparing cmp) +chatroomSetToList = map (cmp &&& id) . filter (not . roomStateDeleted) . fromSetBy (comparing cmp) where cmp :: ChatroomState -> Stored ChatroomStateData cmp = head . filterAncestors . concatMap storedRoots . toComponents @@ -517,12 +536,9 @@ 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 + sdata <- mstore emptyChatroomStateData { rsdPrev = prev , rsdRoom = room - , rsdSubscribe = Nothing - , rsdIdentity = Nothing - , rsdMessages = [] } storeSetAddComponent sdata set else return set @@ -562,11 +578,8 @@ instance Service ChatroomService where -- update local state only if subscribed and we got some new messages if roomStateSubscribe prev && messages /= prevMessages then do - sdata <- mstore ChatroomStateData + sdata <- mstore emptyChatroomStateData { rsdPrev = prevData - , rsdRoom = [] - , rsdSubscribe = Nothing - , rsdIdentity = Nothing , rsdMessages = messages } storeSetAddComponent sdata set diff --git a/src/Erebos/Conversation.hs b/src/Erebos/Conversation.hs index 63475bd..f0ffa70 100644 --- a/src/Erebos/Conversation.hs +++ b/src/Erebos/Conversation.hs @@ -18,6 +18,7 @@ module Erebos.Conversation ( conversationHistory, sendMessage, + deleteConversation, ) where import Control.Monad.Except @@ -103,3 +104,7 @@ conversationHistory (ChatroomConversation rstate) = map (\msg -> ChatroomMessage sendMessage :: (MonadHead LocalState m, MonadError String m) => Conversation -> Text -> m (Maybe Message) sendMessage (DirectMessageConversation thread) text = fmap Just $ DirectMessageMessage <$> (fromStored <$> sendDirectMessage (msgPeer thread) text) <*> pure False sendMessage (ChatroomConversation rstate) text = sendChatroomMessage rstate text >> return Nothing + +deleteConversation :: (MonadHead LocalState m, MonadError String m) => Conversation -> m () +deleteConversation (DirectMessageConversation _) = throwError "deleting direct message conversation is not supported" +deleteConversation (ChatroomConversation rstate) = deleteChatroomByStateData (head $ roomStateData rstate) diff --git a/test/chatroom.test b/test/chatroom.test index 862087d..54f9b2a 100644 --- a/test/chatroom.test +++ b/test/chatroom.test @@ -1,3 +1,5 @@ +def refpat = /blake2#[0-9a-f]+/ + test ChatroomSetup: let services = "chatroom" @@ -489,3 +491,172 @@ test ChatroomIdentity: guard (name1 == "Custom1") expect /chatroom-message-new [a-z0-9#]+ room first_room from ([^ ]+) text message4/ capture name2 guard (name2 == "Custom2") + + +test ChatroomDelete: + let services = "chatroom" + + node n1 + node n2 + node n3 + + # Create and sync chatrooms on n1 and sync to n2 + local: + spawn as p1 on n1 + with p1: + send "create-identity Device1 Owner1" + expect /create-identity-done .*/ + + send "chatroom-watch-local" + send "start-server services $services" + + send "chatroom-create first" + send "chatroom-create second" + expect /chatroom-create-done $refpat first.*/ + expect /chatroom-create-done $refpat second.*/ + + + spawn as p2 on n2 + with p2: + send "create-identity Device2 Owner2" + expect /create-identity-done .*/ + + send "chatroom-watch-local" + send "start-server services $services" + + expect /chatroom-watched-added ($refpat) first sub false/ capture first + expect /chatroom-watched-added ($refpat) second sub false/ capture second + + send "chatroom-subscribe $first" + send "chatroom-subscribe $second" + expect /chatroom-watched-updated $first first sub true .*/ + expect /chatroom-watched-updated $second second sub true .*/ + + local: + spawn as p3 on n3 + with p3: + send "create-identity Device3 Owner3" + expect /create-identity-done .*/ + + local: + spawn as p1 on n1 + spawn as p2 on n2 + spawn as p3 on n3 + + # Delete first chatroom from n1 + with p1: + send "chatroom-watch-local" + send "start-server services $services" + + send "chatroom-list-local" + expect /chatroom-list-item ($refpat) first sub true/ capture first + expect /chatroom-list-item $refpat second sub true/ + local: + expect /chatroom-list-(.*)/ capture done + guard (done == "done") + + send "chatroom-delete $first" + expect /chatroom-delete-done .*/ + + # Setup n3 + with p3: + send "chatroom-watch-local" + send "start-server services $services" + + expect /chatroom-watched-added $refpat second sub false/ + + # Check that both n1 and n3 see only the second chatroom + for p in [ p1, p3 ]: + with p: + send "chatroom-list-local" + expect /chatroom-list-item $refpat second .*/ + local: + expect /chatroom-list-(.*)/ capture done + guard (done == "done") + + # Reactive server on n2 and create third chatroom + with p2: + send "chatroom-watch-local" + send "start-server services $services" + + send "chatroom-create third" + expect /chatroom-create-done $refpat third.*/ + + # Verify that first chatroom appears only on n3 ... + with p3: + expect /chatroom-watched-added $refpat first sub false/ + expect /chatroom-watched-added $refpat third sub false/ + + send "chatroom-list-local" + expect /chatroom-list-item $refpat first .*/ + expect /chatroom-list-item $refpat second .*/ + expect /chatroom-list-item $refpat third .*/ + local: + expect /chatroom-list-(.*)/ capture done + guard (done == "done") + + # ... and not on n1 + with p1: + expect /chatroom-watched-added ($refpat) third sub false/ capture third + send "chatroom-subscribe $third" + expect /chatroom-watched-updated $third third sub true .*/ + + send "chatroom-list-local" + expect /chatroom-list-item $refpat second .*/ + expect /chatroom-list-item $refpat third .*/ + local: + expect /chatroom-list-(.*)/ capture done + guard (done == "done") + + # Delete second chatroom on n2 + with p2: + send "chatroom-list-local" + expect /chatroom-list-item $refpat first .*/ + expect /chatroom-list-item ($refpat) second .*/ capture second + expect /chatroom-list-item $refpat third .*/ + local: + expect /chatroom-list-(.*)/ capture done + guard (done == "done") + + send "chatroom-delete $second" + expect /chatroom-delete-done .*/ + + # Send messages + with p3: + send "chatroom-list-local" + expect /chatroom-list-item ($refpat) first .*/ capture first + expect /chatroom-list-item ($refpat) second .*/ capture second + expect /chatroom-list-item ($refpat) third .*/ capture third + local: + expect /chatroom-list-(.*)/ capture done + guard (done == "done") + + send "chatroom-message-send $first message_first" + send "chatroom-message-send $second message_second" + send "chatroom-message-send $third message_third" + + # Receive only to non-deleted ones + with p1: + expect /chatroom-message-new $refpat room second from Owner3 text message_second/ + expect /chatroom-message-new $refpat room ([a-z]+) from Owner3 text ([a-z_]+)/ capture room, msg + guard (room == "third") + guard (msg == "message_third") + + send "chatroom-list-local" + expect /chatroom-list-item $refpat second .*/ + expect /chatroom-list-item $refpat third .*/ + local: + expect /chatroom-list-(.*)/ capture done + guard (done == "done") + with p2: + expect /chatroom-message-new $refpat room first from Owner3 text message_first/ + expect /chatroom-message-new $refpat room ([a-z]+) from Owner3 text ([a-z_]+)/ capture room, msg + guard (room == "third") + guard (msg == "message_third") + + send "chatroom-list-local" + expect /chatroom-list-item $refpat first .*/ + expect /chatroom-list-item $refpat third .*/ + local: + expect /chatroom-list-(.*)/ capture done + guard (done == "done") |