diff --git a/apps/simplex-directory-service/src/Directory/Service.hs b/apps/simplex-directory-service/src/Directory/Service.hs index 89006c9211..79654b4da6 100644 --- a/apps/simplex-directory-service/src/Directory/Service.hs +++ b/apps/simplex-directory-service/src/Directory/Service.hs @@ -503,8 +503,8 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName rejectPendingMember rjctNotice = do let gmId = groupMemberId' m sendComposedMessages cc (SRGroup groupId $ Just gmId) [MCText rjctNotice] - sendChatCmd cc (APIRemoveMembers groupId [gmId]) >>= \case - CRUserDeletedMembers _ _ (_ : _) -> do + sendChatCmd cc (APIRemoveMembers groupId [gmId] False) >>= \case + CRUserDeletedMembers _ _ (_ : _) _ -> do atomically $ TM.delete gmId $ pendingCaptchas env logInfo $ "Member " <> viewName displayName <> " rejected, group " <> tshow groupId <> ":" <> viewGroupName g r -> logError $ "unexpected remove member response: " <> tshow r diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index e639771f41..49ff263f6f 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -41,6 +41,7 @@ import Data.List.NonEmpty (NonEmpty) import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import Data.Maybe (fromMaybe) +import Data.Set (Set) import Data.String import Data.Text (Text) import Data.Text.Encoding (decodeLatin1) @@ -359,7 +360,7 @@ data ChatCommand | APIAcceptMember GroupId GroupMemberId GroupMemberRole | APIMembersRole GroupId (NonEmpty GroupMemberId) GroupMemberRole | APIBlockMembersForAll GroupId (NonEmpty GroupMemberId) Bool - | APIRemoveMembers GroupId (NonEmpty GroupMemberId) + | APIRemoveMembers {groupId :: GroupId, groupMemberIds :: Set GroupMemberId, withMessages :: Bool} | APILeaveGroup GroupId | APIListMembers GroupId | APIUpdateGroupProfile GroupId GroupProfile @@ -480,7 +481,7 @@ data ChatCommand | JoinGroup {groupName :: GroupName, enableNtfs :: MsgFilter} | MemberRole GroupName ContactName GroupMemberRole | BlockForAll GroupName ContactName Bool - | RemoveMembers GroupName (NonEmpty ContactName) + | RemoveMembers {groupName :: GroupName, members :: Set ContactName, withMessages :: Bool} | LeaveGroup GroupName | DeleteGroup GroupName | ClearGroup GroupName @@ -664,7 +665,7 @@ data ChatResponse | CRUserAcceptedGroupSent {user :: User, groupInfo :: GroupInfo, hostContact :: Maybe Contact} | CRGroupLinkConnecting {user :: User, groupInfo :: GroupInfo, hostMember :: GroupMember} | CRBusinessLinkConnecting {user :: User, groupInfo :: GroupInfo, hostMember :: GroupMember, fromContact :: Contact} - | CRUserDeletedMembers {user :: User, groupInfo :: GroupInfo, members :: [GroupMember]} + | CRUserDeletedMembers {user :: User, groupInfo :: GroupInfo, members :: [GroupMember], withMessages :: Bool} | CRGroupsList {user :: User, groups :: [(GroupInfo, GroupSummary)]} | CRSentGroupInvitation {user :: User, groupInfo :: GroupInfo, contact :: Contact, member :: GroupMember} | CRFileTransferStatus User (FileTransfer, [Integer]) -- TODO refactor this type to FileTransferStatus @@ -753,8 +754,8 @@ data ChatResponse | CRMemberBlockedForAll {user :: User, groupInfo :: GroupInfo, byMember :: GroupMember, member :: GroupMember, blocked :: Bool} | CRMembersBlockedForAllUser {user :: User, groupInfo :: GroupInfo, members :: [GroupMember], blocked :: Bool} | CRConnectedToGroupMember {user :: User, groupInfo :: GroupInfo, member :: GroupMember, memberContact :: Maybe Contact} - | CRDeletedMember {user :: User, groupInfo :: GroupInfo, byMember :: GroupMember, deletedMember :: GroupMember} - | CRDeletedMemberUser {user :: User, groupInfo :: GroupInfo, member :: GroupMember} + | CRDeletedMember {user :: User, groupInfo :: GroupInfo, byMember :: GroupMember, deletedMember :: GroupMember, withMessages :: Bool} + | CRDeletedMemberUser {user :: User, groupInfo :: GroupInfo, member :: GroupMember, withMessages :: Bool} | CRLeftMember {user :: User, groupInfo :: GroupInfo, member :: GroupMember} | CRUnknownMemberCreated {user :: User, groupInfo :: GroupInfo, forwardedByMember :: GroupMember, member :: GroupMember} | CRUnknownMemberBlocked {user :: User, groupInfo :: GroupInfo, blockedByMember :: GroupMember, member :: GroupMember} diff --git a/src/Simplex/Chat/Library/Commands.hs b/src/Simplex/Chat/Library/Commands.hs index 821bc3d6ce..6a5775beb7 100644 --- a/src/Simplex/Chat/Library/Commands.hs +++ b/src/Simplex/Chat/Library/Commands.hs @@ -43,6 +43,7 @@ import qualified Data.List.NonEmpty as L import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, listToMaybe, mapMaybe, maybeToList) +import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (decodeLatin1, encodeUtf8) @@ -1043,8 +1044,7 @@ processChatCommand' vr = \case withContactLock "deleteChat direct" chatId . procCmd $ case cdm of CDMFull notify -> do - cancelFilesInProgress user filesInfo - deleteFilesLocally filesInfo + deleteCIFiles user filesInfo sendDelDeleteConns ct notify -- functions below are called in separate transactions to prevent crashes on android -- (possibly, race condition on integrity check?) @@ -1084,8 +1084,7 @@ processChatCommand' vr = \case unless canDelete $ throwChatError $ CEGroupUserRole gInfo GROwner filesInfo <- withFastStore' $ \db -> getGroupFileInfo db user gInfo withGroupLock "deleteChat group" chatId . procCmd $ do - cancelFilesInProgress user filesInfo - deleteFilesLocally filesInfo + deleteCIFiles user filesInfo let doSendDel = memberActive membership && isOwner -- TODO [knocking] send to pending approval members (move `memberCurrent` filter from sendGroupMessages_ to call sites) when doSendDel . void $ sendGroupMessage' user gInfo members XGrpDel @@ -1103,15 +1102,13 @@ processChatCommand' vr = \case CTDirect -> do ct <- withFastStore $ \db -> getContact db vr user chatId filesInfo <- withFastStore' $ \db -> getContactFileInfo db user ct - cancelFilesInProgress user filesInfo - deleteFilesLocally filesInfo + deleteCIFiles user filesInfo withFastStore' $ \db -> deleteContactCIs db user ct pure $ CRChatCleared user (AChatInfo SCTDirect $ DirectChat ct) CTGroup -> do gInfo <- withFastStore $ \db -> getGroupInfo db vr user chatId filesInfo <- withFastStore' $ \db -> getGroupFileInfo db user gInfo - cancelFilesInProgress user filesInfo - deleteFilesLocally filesInfo + deleteCIFiles user filesInfo withFastStore' $ \db -> deleteGroupChatItemsMessages db user gInfo membersToDelete <- withFastStore' $ \db -> getGroupMembersForExpiration db vr user gInfo forM_ membersToDelete $ \m -> withFastStore' $ \db -> deleteGroupMember db user m @@ -2152,36 +2149,38 @@ processChatCommand' vr = \case let content = CISndGroupEvent $ SGEMemberBlocked groupMemberId (fromLocalProfile memberProfile) blockFlag ts = ciContentTexts content in NewSndChatItemData msg content ts M.empty Nothing Nothing Nothing - APIRemoveMembers groupId memberIds -> withUser $ \user -> + APIRemoveMembers {groupId, groupMemberIds, withMessages} -> withUser $ \user -> withGroupLock "removeMembers" groupId . procCmd $ do Group gInfo members <- withFastStore $ \db -> getGroup db vr user groupId - let (invitedMems, pendingMems, currentMems, maxRole, anyAdmin) = selectMembers members - when (length invitedMems + length pendingMems + length currentMems /= length memberIds) $ throwChatError CEGroupMemberNotFound - when (length memberIds > 1 && anyAdmin) $ throwChatError $ CECommandError "can't remove multiple members when admins selected" + let (count, invitedMems, pendingMems, currentMems, maxRole, anyAdmin) = selectMembers members + memCount = S.size groupMemberIds + when (count /= memCount) $ throwChatError CEGroupMemberNotFound + when (memCount > 1 && anyAdmin) $ throwChatError $ CECommandError "can't remove multiple members when admins selected" assertUserGroupRole gInfo $ max GRAdmin maxRole (errs1, deleted1) <- deleteInvitedMems user invitedMems (errs2, deleted2, acis2) <- deleteMemsSend user gInfo members currentMems - rs <- forM pendingMems $ \m -> deleteMemsSend user gInfo [m] [m] + rs <- forM pendingMems $ \m -> deleteMemsSend user gInfo [m] [m] -- TODO [knocking] let (errs3, deleted3, acis3) = concatTuples rs acis = acis2 <> acis3 errs = errs1 <> errs2 <> errs3 unless (null acis) $ toView $ CRNewChatItems user acis unless (null errs) $ toView $ CRChatErrors (Just user) errs - pure $ CRUserDeletedMembers user gInfo (deleted1 <> deleted2 <> deleted3) -- same order is not guaranteed + when withMessages $ deleteMessages user gInfo $ currentMems <> pendingMems + pure $ CRUserDeletedMembers user gInfo (deleted1 <> deleted2 <> deleted3) withMessages -- same order is not guaranteed where - selectMembers :: [GroupMember] -> ([GroupMember], [GroupMember], [GroupMember], GroupMemberRole, Bool) - selectMembers = foldr' addMember ([], [], [], GRObserver, False) + selectMembers :: [GroupMember] -> (Int, [GroupMember], [GroupMember], [GroupMember], GroupMemberRole, Bool) + selectMembers = foldl' addMember (0, [], [], [], GRObserver, False) where - addMember m@GroupMember {groupMemberId, memberStatus, memberRole} (invited, pending, current, maxRole, anyAdmin) - | groupMemberId `elem` memberIds = + addMember acc@(n, invited, pending, current, maxRole, anyAdmin) m@GroupMember {groupMemberId, memberStatus, memberRole} + | groupMemberId `S.member` groupMemberIds = let maxRole' = max maxRole memberRole anyAdmin' = anyAdmin || memberRole >= GRAdmin - in - case memberStatus of - GSMemInvited -> (m : invited, pending, current, maxRole', anyAdmin') - GSMemPendingApproval -> (invited, m : pending, current, maxRole', anyAdmin') - _ -> (invited, pending, m : current, maxRole', anyAdmin') - | otherwise = (invited, pending, current, maxRole, anyAdmin) + n' = n + 1 + in case memberStatus of + GSMemInvited -> (n', m : invited, pending, current, maxRole', anyAdmin') + GSMemPendingApproval -> (n', invited, m : pending, current, maxRole', anyAdmin') + _ -> (n', invited, pending, m : current, maxRole', anyAdmin') + | otherwise = acc deleteInvitedMems :: User -> [GroupMember] -> CM ([ChatError], [GroupMember]) deleteInvitedMems user memsToDelete = do deleteMembersConnections user memsToDelete @@ -2194,7 +2193,7 @@ processChatCommand' vr = \case deleteMemsSend user gInfo sendToMems memsToDelete = case L.nonEmpty memsToDelete of Nothing -> pure ([], [], []) Just memsToDelete' -> do - let events = L.map (\GroupMember {memberId} -> XGrpMemDel memberId) memsToDelete' + let events = L.map (\GroupMember {memberId} -> XGrpMemDel memberId withMessages) memsToDelete' (msgs_, _gsr) <- sendGroupMessages user gInfo sendToMems events let itemsData = zipWith (fmap . sndItemData) memsToDelete (L.toList msgs_) cis_ <- saveSndChatItems user (CDGroupSnd gInfo) Nothing itemsData Nothing False @@ -2212,6 +2211,9 @@ processChatCommand' vr = \case delMember db m = do deleteOrUpdateMemberRecordIO db user m pure m {memberStatus = GSMemRemoved} + deleteMessages user gInfo@GroupInfo {membership} ms + | groupFeatureMemberAllowed SGFFullDelete membership gInfo = deleteGroupMembersCIs user gInfo ms membership + | otherwise = markGroupMembersCIsDeleted user gInfo ms membership concatTuples :: [([a], [b], [c])] -> ([a], [b], [c]) concatTuples xs = (concat as, concat bs, concat cs) where (as, bs, cs) = unzip3 xs @@ -2240,12 +2242,12 @@ processChatCommand' vr = \case processChatCommand $ APIJoinGroup groupId enableNtfs MemberRole gName gMemberName memRole -> withMemberName gName gMemberName $ \gId gMemberId -> APIMembersRole gId [gMemberId] memRole BlockForAll gName gMemberName blocked -> withMemberName gName gMemberName $ \gId gMemberId -> APIBlockMembersForAll gId [gMemberId] blocked - RemoveMembers gName gMemberNames -> withUser $ \user -> do + RemoveMembers gName gMemberNames withMessages -> withUser $ \user -> do (gId, gMemberIds) <- withStore $ \db -> do gId <- getGroupIdByName db user gName - gMemberIds <- forM gMemberNames $ getGroupMemberIdByName db user gId + gMemberIds <- S.fromList <$> mapM (getGroupMemberIdByName db user gId) (S.toList gMemberNames) pure (gId, gMemberIds) - processChatCommand $ APIRemoveMembers gId gMemberIds + processChatCommand $ APIRemoveMembers gId gMemberIds withMessages LeaveGroup gName -> withUser $ \user -> do groupId <- withFastStore $ \db -> getGroupIdByName db user gName processChatCommand $ APILeaveGroup groupId @@ -3010,8 +3012,7 @@ processChatCommand' vr = \case deleteChatUser :: User -> Bool -> CM ChatResponse deleteChatUser user delSMPQueues = do filesInfo <- withFastStore' (`getUserFileInfo` user) - cancelFilesInProgress user filesInfo - deleteFilesLocally filesInfo + deleteCIFiles user filesInfo withAgent (\a -> deleteUser a (aUserId user) delSMPQueues) `catchChatError` \case e@(ChatErrorAgent NO_USER _) -> toView $ CRChatError (Just user) e @@ -3783,8 +3784,7 @@ expireContactChatItems user vr globalTTL ctId = withExpirationDate globalTTL chatItemTTL $ \expirationDate -> do lift waitChatStartedAndActivated filesInfo <- withStore' $ \db -> getContactExpiredFileInfo db user ct expirationDate - cancelFilesInProgress user filesInfo - deleteFilesLocally filesInfo + deleteCIFiles user filesInfo withStore' $ \db -> deleteContactExpiredCIs db user ct expirationDate expireGroupChatItems :: User -> VersionRangeChat -> Int64 -> UTCTime -> GroupId -> CM () @@ -3795,8 +3795,7 @@ expireGroupChatItems user vr globalTTL createdAtCutoff groupId = withExpirationDate globalTTL chatItemTTL $ \expirationDate -> do lift waitChatStartedAndActivated filesInfo <- withStore' $ \db -> getGroupExpiredFileInfo db user gInfo expirationDate createdAtCutoff - cancelFilesInProgress user filesInfo - deleteFilesLocally filesInfo + deleteCIFiles user filesInfo withStore' $ \db -> deleteGroupExpiredCIs db user gInfo expirationDate createdAtCutoff membersToDelete <- withStore' $ \db -> getGroupMembersForExpiration db vr user gInfo forM_ membersToDelete $ \m -> withStore' $ \db -> deleteGroupMember db user m @@ -3939,8 +3938,8 @@ chatCommandP = "/_join #" *> (APIJoinGroup <$> A.decimal <*> pure MFAll), -- needs to be changed to support in UI "/_accept member #" *> (APIAcceptMember <$> A.decimal <* A.space <*> A.decimal <*> memberRole), "/_member role #" *> (APIMembersRole <$> A.decimal <*> _strP <*> memberRole), - "/_block #" *> (APIBlockMembersForAll <$> A.decimal <*> _strP <* A.space <* "blocked=" <*> onOffP), - "/_remove #" *> (APIRemoveMembers <$> A.decimal <*> _strP), + "/_block #" *> (APIBlockMembersForAll <$> A.decimal <*> _strP <* " blocked=" <*> onOffP), + "/_remove #" *> (APIRemoveMembers <$> A.decimal <*> _strP <*> (" messages=" *> onOffP <|> pure False)), "/_leave #" *> (APILeaveGroup <$> A.decimal), "/_members #" *> (APIListMembers <$> A.decimal), "/_server test " *> (APITestProtoServer <$> A.decimal <* A.space <*> strP), @@ -4026,7 +4025,7 @@ chatCommandP = ("/member role " <|> "/mr ") *> char_ '#' *> (MemberRole <$> displayNameP <* A.space <* char_ '@' <*> displayNameP <*> memberRole), "/block for all #" *> (BlockForAll <$> displayNameP <* A.space <*> (char_ '@' *> displayNameP) <*> pure True), "/unblock for all #" *> (BlockForAll <$> displayNameP <* A.space <*> (char_ '@' *> displayNameP) <*> pure False), - ("/remove " <|> "/rm ") *> char_ '#' *> (RemoveMembers <$> displayNameP <* A.space <*> (L.fromList <$> (char_ '@' *> displayNameP) `A.sepBy1'` A.char ',')), + ("/remove " <|> "/rm ") *> char_ '#' *> (RemoveMembers <$> displayNameP <* A.space <*> (S.fromList <$> (char_ '@' *> displayNameP) `A.sepBy1'` A.char ',') <*> (" messages=" *> onOffP <|> pure False)), ("/leave " <|> "/l ") *> char_ '#' *> (LeaveGroup <$> displayNameP), ("/delete #" <|> "/d #") *> (DeleteGroup <$> displayNameP), ("/delete " <|> "/d ") *> char_ '@' *> (DeleteContact <$> displayNameP <*> chatDeleteMode), diff --git a/src/Simplex/Chat/Library/Internal.hs b/src/Simplex/Chat/Library/Internal.hs index 1b18abda37..0d7de70098 100644 --- a/src/Simplex/Chat/Library/Internal.hs +++ b/src/Simplex/Chat/Library/Internal.hs @@ -468,6 +468,24 @@ deleteGroupCIs user gInfo items byUser timed byGroupMember_ deletedTs = do Nothing -> Nothing <$ deleteGroupChatItem db user gInfo ci pure $ groupDeletion md gInfo ci ci' +deleteGroupMemberCIs :: MsgDirectionI d => User -> GroupInfo -> GroupMember -> GroupMember -> SMsgDirection d -> CM () +deleteGroupMemberCIs user gInfo member byGroupMember msgDir = do + deletedTs <- liftIO getCurrentTime + filesInfo <- withStore' $ \db -> deleteGroupMemberCIs_ db user gInfo member byGroupMember msgDir deletedTs + deleteCIFiles user filesInfo + +deleteGroupMembersCIs :: User -> GroupInfo -> [GroupMember] -> GroupMember -> CM () +deleteGroupMembersCIs user gInfo members byGroupMember = do + deletedTs <- liftIO getCurrentTime + filesInfo <- withStore' $ \db -> fmap concat $ forM members $ \m -> deleteGroupMemberCIs_ db user gInfo m byGroupMember SMDRcv deletedTs + deleteCIFiles user filesInfo + +deleteGroupMemberCIs_ :: MsgDirectionI d => DB.Connection -> User -> GroupInfo -> GroupMember -> GroupMember -> SMsgDirection d -> UTCTime -> IO [CIFileInfo] +deleteGroupMemberCIs_ db user gInfo member byGroupMember msgDir deletedTs = do + fs <- getGroupMemberFileInfo db user gInfo member + updateMemberCIsModerated db user gInfo member byGroupMember msgDir deletedTs + pure fs + deleteLocalCIs :: User -> NoteFolder -> [CChatItem 'CTLocal] -> Bool -> Bool -> CM ChatResponse deleteLocalCIs user nf items byUser timed = do let ciFilesInfo = mapMaybe (\(CChatItem _ ChatItem {file}) -> mkCIFileInfo <$> file) items @@ -511,6 +529,24 @@ markGroupCIsDeleted user gInfo items byUser byGroupMember_ deletedTs = do ci' <- markGroupChatItemDeleted db user gInfo ci byGroupMember_ deletedTs pure $ groupDeletion md gInfo ci (Just ci') +markGroupMemberCIsDeleted :: User -> GroupInfo -> GroupMember -> GroupMember -> CM () +markGroupMemberCIsDeleted user gInfo member byGroupMember = do + deletedTs <- liftIO getCurrentTime + filesInfo <- withStore' $ \db -> markGroupMemberCIsDeleted_ db user gInfo member byGroupMember deletedTs + cancelFilesInProgress user filesInfo + +markGroupMembersCIsDeleted :: User -> GroupInfo -> [GroupMember] -> GroupMember -> CM () +markGroupMembersCIsDeleted user gInfo members byGroupMember = do + deletedTs <- liftIO getCurrentTime + filesInfo <- withStore' $ \db -> fmap concat $ forM members $ \m -> markGroupMemberCIsDeleted_ db user gInfo m byGroupMember deletedTs + cancelFilesInProgress user filesInfo + +markGroupMemberCIsDeleted_ :: DB.Connection -> User -> GroupInfo -> GroupMember -> GroupMember -> UTCTime -> IO [CIFileInfo] +markGroupMemberCIsDeleted_ db user gInfo member byGroupMember deletedTs = do + fs <- getGroupMemberFileInfo db user gInfo member + markMemberCIsDeleted db user gInfo member byGroupMember deletedTs + pure fs + groupDeletion :: MsgDirectionI d => SMsgDirection d -> GroupInfo -> ChatItem 'CTGroup d -> Maybe (ChatItem 'CTGroup d) -> ChatItemDeletion groupDeletion md g ci ci' = ChatItemDeletion (gItem ci) (gItem <$> ci') where diff --git a/src/Simplex/Chat/Library/Subscriber.hs b/src/Simplex/Chat/Library/Subscriber.hs index 739ab25ea9..f9fcecc5a1 100644 --- a/src/Simplex/Chat/Library/Subscriber.hs +++ b/src/Simplex/Chat/Library/Subscriber.hs @@ -867,7 +867,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = XGrpMemRole memId memRole -> xGrpMemRole gInfo m' memId memRole msg brokerTs XGrpMemRestrict memId memRestrictions -> xGrpMemRestrict gInfo m' memId memRestrictions msg brokerTs XGrpMemCon memId -> xGrpMemCon gInfo m' memId - XGrpMemDel memId -> xGrpMemDel gInfo m' memId msg brokerTs + XGrpMemDel memId withMessages -> xGrpMemDel gInfo m' memId withMessages msg brokerTs XGrpLeave -> xGrpLeave gInfo m' msg brokerTs XGrpDel -> xGrpDel gInfo m' msg brokerTs XGrpInfo p' -> xGrpInfo gInfo m' p' msg brokerTs @@ -2570,8 +2570,8 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = _ -> updateStatus introId GMIntroReConnected updateStatus introId status = withStore' $ \db -> updateIntroStatus db introId status - xGrpMemDel :: GroupInfo -> GroupMember -> MemberId -> RcvMessage -> UTCTime -> CM () - xGrpMemDel gInfo@GroupInfo {membership} m@GroupMember {memberRole = senderRole} memId msg brokerTs = do + xGrpMemDel :: GroupInfo -> GroupMember -> MemberId -> Bool -> RcvMessage -> UTCTime -> CM () + xGrpMemDel gInfo@GroupInfo {membership} m@GroupMember {memberRole = senderRole} memId withMessages msg brokerTs = do let GroupMember {memberId = membershipMemId} = membership if membershipMemId == memId then checkRole membership $ do @@ -2580,8 +2580,9 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = members <- withStore' $ \db -> getGroupMembers db vr user gInfo deleteMembersConnections user members withStore' $ \db -> updateGroupMemberStatus db userId membership GSMemRemoved + when withMessages $ deleteMessages membership SMDSnd deleteMemberItem RGEUserDeleted - toView $ CRDeletedMemberUser user gInfo {membership = membership {memberStatus = GSMemRemoved}} m + toView $ CRDeletedMemberUser user gInfo {membership = membership {memberStatus = GSMemRemoved}} m withMessages else withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId) >>= \case Left _ -> messageError "x.grp.mem.del with unknown member ID" @@ -2591,8 +2592,9 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = deleteMemberConnection user member -- undeleted "member connected" chat item will prevent deletion of member record deleteOrUpdateMemberRecord user member + when withMessages $ deleteMessages member SMDRcv deleteMemberItem $ RGEMemberDeleted groupMemberId (fromLocalProfile memberProfile) - toView $ CRDeletedMember user gInfo m member {memberStatus = GSMemRemoved} + toView $ CRDeletedMember user gInfo m member {memberStatus = GSMemRemoved} withMessages where checkRole GroupMember {memberRole} a | senderRole < GRAdmin || senderRole < memberRole = @@ -2601,6 +2603,10 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = deleteMemberItem gEvent = do ci <- saveRcvChatItemNoParse user (CDGroupRcv gInfo m) msg brokerTs (CIRcvGroupEvent gEvent) groupMsgToView gInfo ci + deleteMessages :: MsgDirectionI d => GroupMember -> SMsgDirection d -> CM () + deleteMessages delMem msgDir + | groupFeatureMemberAllowed SGFFullDelete m gInfo = deleteGroupMemberCIs user gInfo delMem m msgDir + | otherwise = markGroupMemberCIsDeleted user gInfo delMem m xGrpLeave :: GroupInfo -> GroupMember -> RcvMessage -> UTCTime -> CM () xGrpLeave gInfo m msg brokerTs = do @@ -2726,7 +2732,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = XInfo p -> xInfoMember gInfo author p msgTs XGrpMemNew memInfo -> xGrpMemNew gInfo author memInfo rcvMsg msgTs XGrpMemRole memId memRole -> xGrpMemRole gInfo author memId memRole rcvMsg msgTs - XGrpMemDel memId -> xGrpMemDel gInfo author memId rcvMsg msgTs + XGrpMemDel memId withMessages -> xGrpMemDel gInfo author memId withMessages rcvMsg msgTs XGrpLeave -> xGrpLeave gInfo author rcvMsg msgTs XGrpDel -> xGrpDel gInfo author rcvMsg msgTs XGrpInfo p' -> xGrpInfo gInfo author p' rcvMsg msgTs diff --git a/src/Simplex/Chat/Protocol.hs b/src/Simplex/Chat/Protocol.hs index a145914ce7..566cd04003 100644 --- a/src/Simplex/Chat/Protocol.hs +++ b/src/Simplex/Chat/Protocol.hs @@ -29,10 +29,12 @@ import qualified Data.Aeson.KeyMap as JM import qualified Data.Aeson.TH as JQ import qualified Data.Aeson.Types as JT import qualified Data.Attoparsec.ByteString.Char8 as A +import Data.Bifunctor (first) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.ByteString.Internal (c2w, w2c) import qualified Data.ByteString.Lazy.Char8 as LB +import Data.Either (fromRight) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as L import Data.Map.Strict (Map) @@ -343,7 +345,7 @@ data ChatMsgEvent (e :: MsgEncoding) where XGrpMemRestrict :: MemberId -> MemberRestrictions -> ChatMsgEvent 'Json XGrpMemCon :: MemberId -> ChatMsgEvent 'Json XGrpMemConAll :: MemberId -> ChatMsgEvent 'Json -- TODO not implemented - XGrpMemDel :: MemberId -> ChatMsgEvent 'Json + XGrpMemDel :: MemberId -> Bool -> ChatMsgEvent 'Json XGrpLeave :: ChatMsgEvent 'Json XGrpDel :: ChatMsgEvent 'Json XGrpInfo :: GroupProfile -> ChatMsgEvent 'Json @@ -384,7 +386,7 @@ isForwardedGroupMsg ev = case ev of XGrpMemNew _ -> True XGrpMemRole {} -> True XGrpMemRestrict {} -> True - XGrpMemDel _ -> True -- TODO there should be a special logic when deleting host member (e.g., host forwards it before deleting connections) + XGrpMemDel {} -> True -- TODO there should be a special logic when deleting host member (e.g., host forwards it before deleting connections) XGrpLeave -> True XGrpDel -> True -- TODO there should be a special logic - host should forward before deleting connections XGrpInfo _ -> True @@ -991,7 +993,7 @@ toCMEventTag msg = case msg of XGrpMemRestrict _ _ -> XGrpMemRestrict_ XGrpMemCon _ -> XGrpMemCon_ XGrpMemConAll _ -> XGrpMemConAll_ - XGrpMemDel _ -> XGrpMemDel_ + XGrpMemDel {} -> XGrpMemDel_ XGrpLeave -> XGrpLeave_ XGrpDel -> XGrpDel_ XGrpInfo _ -> XGrpInfo_ @@ -1094,7 +1096,7 @@ appJsonToCM AppMessageJson {v, msgId, event, params} = do XGrpMemRestrict_ -> XGrpMemRestrict <$> p "memberId" <*> p "memberRestrictions" XGrpMemCon_ -> XGrpMemCon <$> p "memberId" XGrpMemConAll_ -> XGrpMemConAll <$> p "memberId" - XGrpMemDel_ -> XGrpMemDel <$> p "memberId" + XGrpMemDel_ -> XGrpMemDel <$> p "memberId" <*> Right (fromRight False $ p "messages") XGrpLeave_ -> pure XGrpLeave XGrpDel_ -> pure XGrpDel XGrpInfo_ -> XGrpInfo <$> p "groupProfile" @@ -1158,7 +1160,7 @@ chatToAppMessage ChatMessage {chatVRange, msgId, chatMsgEvent} = case encoding @ XGrpMemRestrict memId memRestrictions -> o ["memberId" .= memId, "memberRestrictions" .= memRestrictions] XGrpMemCon memId -> o ["memberId" .= memId] XGrpMemConAll memId -> o ["memberId" .= memId] - XGrpMemDel memId -> o ["memberId" .= memId] + XGrpMemDel memId messages -> o $ ("messages" .=? if messages then Just True else Nothing) ["memberId" .= memId] XGrpLeave -> JM.empty XGrpDel -> JM.empty XGrpInfo p -> o ["groupProfile" .= p] diff --git a/src/Simplex/Chat/Store/Messages.hs b/src/Simplex/Chat/Store/Messages.hs index 00158e0054..ab7d866349 100644 --- a/src/Simplex/Chat/Store/Messages.hs +++ b/src/Simplex/Chat/Store/Messages.hs @@ -21,6 +21,7 @@ module Simplex.Chat.Store.Messages -- * Message and chat item functions deleteContactCIs, getGroupFileInfo, + getGroupMemberFileInfo, deleteGroupChatItemsMessages, createNewSndMessage, createSndMsgDelivery, @@ -57,8 +58,10 @@ module Simplex.Chat.Store.Messages updateGroupCIMentions, deleteGroupChatItem, updateGroupChatItemModerated, + updateMemberCIsModerated, updateGroupCIBlockedByAdmin, markGroupChatItemDeleted, + markMemberCIsDeleted, markGroupChatItemBlocked, markGroupCIBlockedByAdmin, markMessageReportsDeleted, @@ -193,6 +196,11 @@ getGroupFileInfo db User {userId} GroupInfo {groupId} = map toFileInfo <$> DB.query db (fileInfoQuery <> " WHERE i.user_id = ? AND i.group_id = ?") (userId, groupId) +getGroupMemberFileInfo :: DB.Connection -> User -> GroupInfo -> GroupMember -> IO [CIFileInfo] +getGroupMemberFileInfo db User {userId} GroupInfo {groupId} GroupMember {groupMemberId} = + map toFileInfo + <$> DB.query db (fileInfoQuery <> " WHERE i.user_id = ? AND i.group_id = ? AND i.group_member_id = ?") (userId, groupId, groupMemberId) + deleteGroupChatItemsMessages :: DB.Connection -> User -> GroupInfo -> IO () deleteGroupChatItemsMessages db User {userId} GroupInfo {groupId} = do DB.execute db "DELETE FROM messages WHERE group_id = ?" (Only groupId) @@ -2150,18 +2158,18 @@ deleteDirectChatItem db User {userId} Contact {contactId} ci = do (userId, contactId, itemId) deleteChatItemMessages_ :: DB.Connection -> ChatItemId -> IO () -deleteChatItemMessages_ db itemId = - DB.execute - db - [sql| - DELETE FROM messages - WHERE message_id IN ( - SELECT message_id - FROM chat_item_messages - WHERE chat_item_id = ? - ) - |] - (Only itemId) +deleteChatItemMessages_ db itemId = DB.execute db deleteChatItemMessagesQuery (Only itemId) + +deleteChatItemMessagesQuery :: Query +deleteChatItemMessagesQuery = + [sql| + DELETE FROM messages + WHERE message_id IN ( + SELECT message_id + FROM chat_item_messages + WHERE chat_item_id = ? + ) + |] deleteChatItemVersions_ :: DB.Connection -> ChatItemId -> IO () deleteChatItemVersions_ db itemId = @@ -2359,6 +2367,34 @@ updateGroupChatItemModerated db User {userId} GroupInfo {groupId} ci m@GroupMemb (deletedTs, groupMemberId, toContent, toText, currentTs, userId, groupId, itemId) pure ci {content = toContent, meta = (meta ci) {itemText = toText, itemDeleted = Just (CIModerated (Just deletedTs) m), editable = False, deletable = False}, formattedText = Nothing} +updateMemberCIsModerated :: MsgDirectionI d => DB.Connection -> User -> GroupInfo -> GroupMember -> GroupMember -> SMsgDirection d -> UTCTime -> IO () +updateMemberCIsModerated db User {userId} GroupInfo {groupId, membership} member byGroupMember md deletedTs = do + itemIds <- updateCIs =<< getCurrentTime + DB.executeMany db deleteChatItemMessagesQuery itemIds + DB.executeMany db "DELETE FROM chat_item_versions WHERE chat_item_id = ?" itemIds + where + memId = groupMemberId' member + updateQuery = + [sql| + UPDATE chat_items + SET item_deleted = 1, item_deleted_ts = ?, item_deleted_by_group_member_id = ?, item_content = ?, item_text = ?, updated_at = ? + WHERE user_id = ? AND group_id = ? + |] + updateCIs :: UTCTime -> IO [Only Int64] + updateCIs currentTs + | memId == groupMemberId' membership = + DB.query + db + (updateQuery <> " AND group_member_id IS NULL AND item_sent = 1 RETURNING chat_item_id") + (columns :. (userId, groupId)) + | otherwise = + DB.query + db + (updateQuery <> " AND group_member_id = ? RETURNING chat_item_id") + (columns :. (userId, groupId, memId)) + where + columns = (deletedTs, groupMemberId' byGroupMember, msgDirToModeratedContent_ md, ciModeratedText, currentTs) + updateGroupCIBlockedByAdmin :: DB.Connection -> User -> GroupInfo -> ChatItem 'CTGroup d -> UTCTime -> IO (ChatItem 'CTGroup d) updateGroupCIBlockedByAdmin db User {userId} GroupInfo {groupId} ci deletedTs = do currentTs <- getCurrentTime @@ -2405,6 +2441,31 @@ markGroupChatItemDeleted db User {userId} GroupInfo {groupId} ci@ChatItem {meta} (DBCIDeleted, deletedTs, deletedByGroupMemberId, currentTs, userId, groupId, itemId) pure ci {meta = meta {itemDeleted, editable = False, deletable = False}} +markMemberCIsDeleted :: DB.Connection -> User -> GroupInfo -> GroupMember -> GroupMember -> UTCTime -> IO () +markMemberCIsDeleted db User {userId} GroupInfo {groupId, membership} member byGroupMember deletedTs = + updateCIs =<< getCurrentTime + where + memId = groupMemberId' member + updateQuery = + [sql| + UPDATE chat_items + SET item_deleted = ?, item_deleted_ts = ?, item_deleted_by_group_member_id = ?, updated_at = ? + WHERE user_id = ? AND group_id = ? + |] + updateCIs currentTs + | memId == groupMemberId' membership = + DB.execute + db + (updateQuery <> " AND group_member_id IS NULL AND item_sent = 1") + (columns :. (userId, groupId)) + | otherwise = + DB.execute + db + (updateQuery <> " AND group_member_id = ?") + (columns :. (userId, groupId, memId)) + where + columns = (DBCIDeleted, deletedTs, groupMemberId' byGroupMember, currentTs) + markGroupChatItemBlocked :: DB.Connection -> User -> GroupInfo -> ChatItem 'CTGroup 'MDRcv -> IO (ChatItem 'CTGroup 'MDRcv) markGroupChatItemBlocked db User {userId} GroupInfo {groupId} ci@ChatItem {meta} = do deletedTs <- getCurrentTime diff --git a/src/Simplex/Chat/Store/SQLite/Migrations/chat_query_plans.txt b/src/Simplex/Chat/Store/SQLite/Migrations/chat_query_plans.txt index 88836035e5..9cbd5965b7 100644 --- a/src/Simplex/Chat/Store/SQLite/Migrations/chat_query_plans.txt +++ b/src/Simplex/Chat/Store/SQLite/Migrations/chat_query_plans.txt @@ -3314,6 +3314,22 @@ Query: Plan: SEARCH usage_conditions USING INTEGER PRIMARY KEY (rowid=?) +Query: + UPDATE chat_items + SET item_deleted = 1, item_deleted_ts = ?, item_deleted_by_group_member_id = ?, item_content = ?, item_text = ?, updated_at = ? + WHERE user_id = ? AND group_id = ? + AND group_member_id = ? RETURNING chat_item_id +Plan: +SEARCH chat_items USING COVERING INDEX idx_chat_items_group_shared_msg_id (user_id=? AND group_id=? AND group_member_id=?) + +Query: + UPDATE chat_items + SET item_deleted = 1, item_deleted_ts = ?, item_deleted_by_group_member_id = ?, item_content = ?, item_text = ?, updated_at = ? + WHERE user_id = ? AND group_id = ? + AND group_member_id IS NULL AND item_sent = 1 RETURNING chat_item_id +Plan: +SEARCH chat_items USING INDEX idx_chat_items_group_shared_msg_id (user_id=? AND group_id=? AND group_member_id=?) + Query: UPDATE chat_items SET item_deleted = 1, item_deleted_ts = ?, item_deleted_by_group_member_id = ?, item_content = ?, item_text = ?, updated_at = ? @@ -3322,6 +3338,22 @@ Query: Plan: SEARCH chat_items USING INTEGER PRIMARY KEY (rowid=?) +Query: + UPDATE chat_items + SET item_deleted = ?, item_deleted_ts = ?, item_deleted_by_group_member_id = ?, updated_at = ? + WHERE user_id = ? AND group_id = ? + AND group_member_id = ? +Plan: +SEARCH chat_items USING COVERING INDEX idx_chat_items_group_shared_msg_id (user_id=? AND group_id=? AND group_member_id=?) + +Query: + UPDATE chat_items + SET item_deleted = ?, item_deleted_ts = ?, item_deleted_by_group_member_id = ?, updated_at = ? + WHERE user_id = ? AND group_id = ? + AND group_member_id IS NULL AND item_sent = 1 +Plan: +SEARCH chat_items USING INDEX idx_chat_items_group_shared_msg_id (user_id=? AND group_id=? AND group_member_id=?) + Query: UPDATE chat_items SET item_deleted = ?, item_deleted_ts = ?, item_deleted_by_group_member_id = ?, updated_at = ? @@ -3861,25 +3893,6 @@ LIST SUBQUERY 1 SEARCH groups USING INTEGER PRIMARY KEY (rowid=?) SEARCH groups USING COVERING INDEX idx_groups_group_profile_id (group_profile_id=?) -Query: - DELETE FROM messages - WHERE message_id IN ( - SELECT message_id - FROM chat_item_messages - WHERE chat_item_id = ? - ) - -Plan: -SEARCH messages USING INTEGER PRIMARY KEY (rowid=?) -LIST SUBQUERY 1 -SEARCH chat_item_messages USING COVERING INDEX sqlite_autoindex_chat_item_messages_2 (chat_item_id=?) -SEARCH msg_deliveries USING COVERING INDEX idx_msg_deliveries_message_id (message_id=?) -SEARCH chat_item_moderations USING COVERING INDEX idx_chat_item_moderations_created_by_msg_id (created_by_msg_id=?) -SEARCH chat_item_reactions USING COVERING INDEX idx_chat_item_reactions_created_by_msg_id (created_by_msg_id=?) -SEARCH chat_item_messages USING COVERING INDEX sqlite_autoindex_chat_item_messages_1 (message_id=?) -SEARCH chat_items USING COVERING INDEX sqlite_autoindex_chat_items_1 (created_by_msg_id=?) -SEARCH pending_group_messages USING COVERING INDEX idx_pending_group_messages_message_id (message_id=?) - Query: INSERT INTO calls (contact_id, shared_call_id, call_uuid, chat_item_id, call_state, call_ts, user_id, created_at, updated_at) @@ -4414,6 +4427,25 @@ Query: Plan: SEARCH xftp_file_descriptions USING INTEGER PRIMARY KEY (rowid=?) +Query: + DELETE FROM messages + WHERE message_id IN ( + SELECT message_id + FROM chat_item_messages + WHERE chat_item_id = ? + ) + +Plan: +SEARCH messages USING INTEGER PRIMARY KEY (rowid=?) +LIST SUBQUERY 1 +SEARCH chat_item_messages USING COVERING INDEX sqlite_autoindex_chat_item_messages_2 (chat_item_id=?) +SEARCH msg_deliveries USING COVERING INDEX idx_msg_deliveries_message_id (message_id=?) +SEARCH chat_item_moderations USING COVERING INDEX idx_chat_item_moderations_created_by_msg_id (created_by_msg_id=?) +SEARCH chat_item_reactions USING COVERING INDEX idx_chat_item_reactions_created_by_msg_id (created_by_msg_id=?) +SEARCH chat_item_messages USING COVERING INDEX sqlite_autoindex_chat_item_messages_1 (message_id=?) +SEARCH chat_items USING COVERING INDEX sqlite_autoindex_chat_items_1 (created_by_msg_id=?) +SEARCH pending_group_messages USING COVERING INDEX idx_pending_group_messages_message_id (message_id=?) + Query: SELECT -- GroupInfo @@ -4654,6 +4686,15 @@ Plan: SEARCH i USING COVERING INDEX idx_chat_items_groups_user_mention (user_id=? AND group_id=?) SEARCH f USING INDEX idx_files_chat_item_id (chat_item_id=?) +Query: + SELECT f.file_id, f.ci_file_status, f.file_path + FROM chat_items i + JOIN files f ON f.chat_item_id = i.chat_item_id + WHERE i.user_id = ? AND i.group_id = ? AND i.group_member_id = ? +Plan: +SEARCH i USING COVERING INDEX idx_chat_items_group_shared_msg_id (user_id=? AND group_id=? AND group_member_id=?) +SEARCH f USING INDEX idx_files_chat_item_id (chat_item_id=?) + Query: SELECT f.file_id, f.ci_file_status, f.file_path FROM chat_items i diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 1c4f4258d8..5053f24ec6 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -220,9 +220,9 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe CRUserAcceptedGroupSent u _g _ -> ttyUser u [] -- [ttyGroup' g <> ": joining the group..."] CRGroupLinkConnecting u g _ -> ttyUser u [ttyGroup' g <> ": joining the group..."] CRBusinessLinkConnecting u g _ _ -> ttyUser u [ttyGroup' g <> ": joining the group..."] - CRUserDeletedMembers u g members -> case members of - [m] -> ttyUser u [ttyGroup' g <> ": you removed " <> ttyMember m <> " from the group"] - mems' -> ttyUser u [ttyGroup' g <> ": you removed " <> sShow (length mems') <> " members from the group"] + CRUserDeletedMembers u g members wm -> case members of + [m] -> ttyUser u [ttyGroup' g <> ": you removed " <> ttyMember m <> " from the group" <> withMessages wm] + mems' -> ttyUser u [ttyGroup' g <> ": you removed " <> sShow (length mems') <> " members from the group" <> withMessages wm] CRLeftMemberUser u g -> ttyUser u $ [ttyGroup' g <> ": you left the group"] <> groupPreserved g CRUnknownMemberCreated u g fwdM um -> ttyUser u [ttyGroup' g <> ": " <> ttyMember fwdM <> " forwarded a message from an unknown member, creating unknown member record " <> ttyMember um] CRUnknownMemberBlocked u g byM um -> ttyUser u [ttyGroup' g <> ": " <> ttyMember byM <> " blocked an unknown member, creating unknown member record " <> ttyMember um] @@ -306,8 +306,8 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe CRMembersRoleUser u g members r' -> ttyUser u $ viewMemberRoleUserChanged g members r' CRMemberBlockedForAll u g by m blocked -> ttyUser u $ viewMemberBlockedForAll g by m blocked CRMembersBlockedForAllUser u g members blocked -> ttyUser u $ viewMembersBlockedForAllUser g members blocked - CRDeletedMemberUser u g by -> ttyUser u $ [ttyGroup' g <> ": " <> ttyMember by <> " removed you from the group"] <> groupPreserved g - CRDeletedMember u g by m -> ttyUser u [ttyGroup' g <> ": " <> ttyMember by <> " removed " <> ttyMember m <> " from the group"] + CRDeletedMemberUser u g by wm -> ttyUser u $ [ttyGroup' g <> ": " <> ttyMember by <> " removed you from the group" <> withMessages wm] <> groupPreserved g + CRDeletedMember u g by m wm -> ttyUser u [ttyGroup' g <> ": " <> ttyMember by <> " removed " <> ttyMember m <> " from the group" <> withMessages wm] CRLeftMember u g m -> ttyUser u [ttyGroup' g <> ": " <> ttyMember m <> " left the group"] CRGroupEmpty u ShortGroupInfo {groupName = g} -> ttyUser u [ttyGroup g <> ": group is empty"] CRGroupDeleted u g m -> ttyUser u [ttyGroup' g <> ": " <> ttyMember m <> " deleted the group", "use " <> highlight ("/d #" <> viewGroupName g) <> " to delete the local copy of the group"] @@ -511,6 +511,7 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe | chatDirNtf u chat chatDir mention = s | testView = map (<> " ") s | otherwise = [] + withMessages wm = if wm then " with all messages" else "" userNtf :: User -> Bool userNtf User {showNtfs, activeUser} = showNtfs || activeUser diff --git a/tests/ChatTests/Groups.hs b/tests/ChatTests/Groups.hs index 7ec4033046..2e99de4a82 100644 --- a/tests/ChatTests/Groups.hs +++ b/tests/ChatTests/Groups.hs @@ -79,6 +79,8 @@ chatGroupTests = do it "moderate message of another group member (full delete)" testGroupModerateFullDelete it "moderate message that arrives after the event of moderation" testGroupDelayedModeration it "moderate message that arrives after the event of moderation (full delete)" testGroupDelayedModerationFullDelete + it "remove member with messages (full deletion is enabled)" testDeleteMemberWithMessages + it "remove member with messages mark deleted" testDeleteMemberMarkMessagesDeleted describe "batch send messages" $ do it "send multiple messages api" testSendMulti it "send multiple timed messages" testSendMultiTimed @@ -1801,6 +1803,67 @@ testGroupDelayedModerationFullDelete ps = do -- version before forwarding, so cath doesn't expect alice to forward messages (groupForwardVersion = 4) cfg = testCfg {chatVRange = mkVersionRange (VersionChat 1) (VersionChat 3)} +testDeleteMemberWithMessages :: HasCallStack => TestParams -> IO () +testDeleteMemberWithMessages = + testChat3 aliceProfile bobProfile cathProfile $ + \alice bob cath -> do + createGroup3 "team" alice bob cath + threadDelay 750000 + alice ##> "/set delete #team on" + alice <## "updated group preferences:" + alice <## "Full deletion: on" + threadDelay 750000 + concurrentlyN_ + [ do + bob <## "alice updated group #team:" + bob <## "updated group preferences:" + bob <## "Full deletion: on", + do + cath <## "alice updated group #team:" + cath <## "updated group preferences:" + cath <## "Full deletion: on" + ] + threadDelay 750000 + bob #> "#team hello" + concurrently_ + (alice <# "#team bob> hello") + (cath <# "#team bob> hello") + alice #$> ("/_get chat #1 count=1", chat, [(0, "hello")]) + bob #$> ("/_get chat #1 count=1", chat, [(1, "hello")]) + cath #$> ("/_get chat #1 count=1", chat, [(0, "hello")]) + threadDelay 1000000 + alice ##> "/rm #team bob messages=on" + alice <## "#team: you removed bob from the group with all messages" + bob <## "#team: alice removed you from the group with all messages" + bob <## "use /d #team to delete the group" + cath <## "#team: alice removed bob from the group with all messages" + alice #$> ("/_get chat #1 count=2", chat, [(0, "moderated [deleted by you]"), (1, "removed bob (Bob)")]) + bob #$> ("/_get chat #1 count=2", chat, [(1, "moderated [deleted by alice]"), (0, "removed you")]) + cath #$> ("/_get chat #1 count=2", chat, [(0, "moderated [deleted by alice]"), (0, "removed bob (Bob)")]) + +testDeleteMemberMarkMessagesDeleted :: HasCallStack => TestParams -> IO () +testDeleteMemberMarkMessagesDeleted = + testChat3 aliceProfile bobProfile cathProfile $ + \alice bob cath -> do + createGroup3 "team" alice bob cath + threadDelay 1000000 + bob #> "#team hello" + concurrently_ + (alice <# "#team bob> hello") + (cath <# "#team bob> hello") + alice #$> ("/_get chat #1 count=1", chat, [(0, "hello")]) + bob #$> ("/_get chat #1 count=1", chat, [(1, "hello")]) + cath #$> ("/_get chat #1 count=1", chat, [(0, "hello")]) + threadDelay 1000000 + alice ##> "/rm #team bob messages=on" + alice <## "#team: you removed bob from the group with all messages" + bob <## "#team: alice removed you from the group with all messages" + bob <## "use /d #team to delete the group" + cath <## "#team: alice removed bob from the group with all messages" + alice #$> ("/_get chat #1 count=2", chat, [(0, "hello [marked deleted by you]"), (1, "removed bob (Bob)")]) + bob #$> ("/_get chat #1 count=2", chat, [(1, "hello [marked deleted by alice]"), (0, "removed you")]) + cath #$> ("/_get chat #1 count=2", chat, [(0, "hello [marked deleted by alice]"), (0, "removed bob (Bob)")]) + testSendMulti :: HasCallStack => TestParams -> IO () testSendMulti = testChat3 aliceProfile bobProfile cathProfile $ diff --git a/tests/ProtocolTests.hs b/tests/ProtocolTests.hs index 83087a89a8..5c672b2858 100644 --- a/tests/ProtocolTests.hs +++ b/tests/ProtocolTests.hs @@ -283,7 +283,7 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do #==# XGrpMemConAll (MemberId "\1\2\3\4") it "x.grp.mem.del" $ "{\"v\":\"1\",\"event\":\"x.grp.mem.del\",\"params\":{\"memberId\":\"AQIDBA==\"}}" - #==# XGrpMemDel (MemberId "\1\2\3\4") + #==# XGrpMemDel (MemberId "\1\2\3\4") False it "x.grp.leave" $ "{\"v\":\"1\",\"event\":\"x.grp.leave\",\"params\":{}}" ==# XGrpLeave