core: delete members with messages (#5711)

* core: delete members with messages (WIP)

* remove messages

* fix, test

* update query plans
This commit is contained in:
Evgeny 2025-03-07 07:47:32 +00:00 committed by GitHub
parent 5bef7349d8
commit a6631ce629
No known key found for this signature in database
GPG key ID: B5690EEEBB952194
11 changed files with 302 additions and 92 deletions

View file

@ -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

View file

@ -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}

View file

@ -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),

View file

@ -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

View file

@ -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

View file

@ -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]

View file

@ -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

View file

@ -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

View file

@ -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 (<> " <muted>") s
| otherwise = []
withMessages wm = if wm then " with all messages" else ""
userNtf :: User -> Bool
userNtf User {showNtfs, activeUser} = showNtfs || activeUser

View file

@ -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 $

View file

@ -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