From c63919784f98c095200f4dab76bb9b0897ae2bf7 Mon Sep 17 00:00:00 2001 From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> Date: Fri, 15 Aug 2025 15:04:17 +0400 Subject: [PATCH] core: fix forwarding for connection deleting events (x.grp.mem.del, x.grp.del) --- src/Simplex/Chat/Library/Commands.hs | 2 +- src/Simplex/Chat/Library/Subscriber.hs | 227 +++++++++++++++---------- src/Simplex/Chat/Protocol.hs | 4 +- src/Simplex/Chat/Store/Groups.hs | 20 +-- src/Simplex/Chat/Types.hs | 6 + src/Simplex/Chat/View.hs | 4 +- tests/ChatTests/Groups.hs | 28 +++ 7 files changed, 191 insertions(+), 100 deletions(-) diff --git a/src/Simplex/Chat/Library/Commands.hs b/src/Simplex/Chat/Library/Commands.hs index 4fa2e4ac9b..da55b2543c 100644 --- a/src/Simplex/Chat/Library/Commands.hs +++ b/src/Simplex/Chat/Library/Commands.hs @@ -3143,7 +3143,7 @@ processChatCommand vr nm = \case contactMember :: Contact -> [GroupMember] -> Maybe GroupMember contactMember Contact {contactId} = find $ \GroupMember {memberContactId = cId, memberStatus = s} -> - cId == Just contactId && s /= GSMemRejected && s /= GSMemRemoved && s /= GSMemLeft + cId == Just contactId && s /= GSMemRejected && s /= GSMemRemoved && s /= GSMemMarkedRemoved && s /= GSMemLeft checkSndFile :: CryptoFile -> CM Integer checkSndFile (CryptoFile f cfArgs) = do fsFilePath <- lift $ toFSFilePath f diff --git a/src/Simplex/Chat/Library/Subscriber.hs b/src/Simplex/Chat/Library/Subscriber.hs index 3312e928de..e3373ef5e8 100644 --- a/src/Simplex/Chat/Library/Subscriber.hs +++ b/src/Simplex/Chat/Library/Subscriber.hs @@ -895,11 +895,13 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = -- possible improvement is to choose scope based on event (some events specify scope) (gInfo', m', scopeInfo) <- mkGroupChatScope gInfo m checkIntegrityCreateItem (CDGroupRcv gInfo' scopeInfo m') msgMeta `catchChatError` \_ -> pure () - fwdScopesMsgs <- foldM (processAChatMsg gInfo' m' tags eInfo) M.empty aChatMsgs - let GroupMember {memberRole = membershipMemRole} = membership - when (membershipMemRole >= GRAdmin && not (blockedByAdmin m)) $ - forM_ (M.assocs fwdScopesMsgs) $ \(groupForwardScope, fwdMsgs) -> - forwardMsgs groupForwardScope (L.reverse fwdMsgs) `catchChatError` eToView + (fwdScopesMsgs, connDeletingMsgs) <- foldM (processAChatMsg gInfo' m' tags eInfo) (M.empty, []) aChatMsgs + when (isUserGrpFwdRelay gInfo') $ do + unless (blockedByAdmin m) $ do + let hasConnDeletingMsgs = not (null connDeletingMsgs) + forM_ (M.assocs fwdScopesMsgs) $ \(groupForwardScope, fwdMsgs) -> + forwardMsgs groupForwardScope (L.reverse fwdMsgs) hasConnDeletingMsgs `catchChatError` eToView + forM_ (reverse connDeletingMsgs) $ \chatMsg -> processConnectionDeletingMsg gInfo' chatMsg checkSendRcpt $ rights aChatMsgs where aChatMsgs = parseChatMessages msgBody @@ -909,25 +911,30 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = -> GroupMember -> TVar [Text] -> Text - -> Map GroupForwardScope (NonEmpty (ChatMessage 'Json)) + -> (Map GroupForwardScope (NonEmpty (ChatMessage 'Json)), [ChatMessage 'Json]) -> Either String AChatMessage - -> CM (Map GroupForwardScope (NonEmpty (ChatMessage 'Json))) - processAChatMsg gInfo' m' tags eInfo fwdScopeMap = \case + -> CM (Map GroupForwardScope (NonEmpty (ChatMessage 'Json)), [ChatMessage 'Json]) + processAChatMsg gInfo' m' tags eInfo (fwdScopeMap, connDeletingMsgs) = \case Right (ACMsg SJson chatMsg) -> do - cmFwdScope_ <- processEvent gInfo' m' tags eInfo chatMsg `catchChatError` \e -> eToView e $> Nothing - case cmFwdScope_ of - Nothing -> pure fwdScopeMap - Just cmFwdScope -> - pure $ M.alter (Just . maybe [chatMsg] (chatMsg <|)) cmFwdScope fwdScopeMap + (cmFwdScope_, isConnDeletingMsg) <- + processEvent gInfo' m' tags eInfo chatMsg `catchChatError` \e -> eToView e $> (Nothing, False) + let fwdScopeMap' = + case cmFwdScope_ of + Nothing -> fwdScopeMap + Just cmFwdScope -> M.alter (Just . maybe [chatMsg] (chatMsg <|)) cmFwdScope fwdScopeMap + connDeletingMsgs' + | isConnDeletingMsg = chatMsg : connDeletingMsgs + | otherwise = connDeletingMsgs + pure (fwdScopeMap', connDeletingMsgs') Right (ACMsg SBinary chatMsg) -> do void (processEvent gInfo' m' tags eInfo chatMsg) `catchChatError` \e -> eToView e - pure fwdScopeMap + pure (fwdScopeMap, connDeletingMsgs) Left e -> do atomically $ modifyTVar' tags ("error" :) logInfo $ "group msg=error " <> eInfo <> " " <> tshow e eToView (ChatError . CEException $ "error parsing chat message: " <> e) - pure fwdScopeMap - processEvent :: GroupInfo -> GroupMember -> TVar [Text] -> Text -> MsgEncodingI e => ChatMessage e -> CM (Maybe GroupForwardScope) + pure (fwdScopeMap, connDeletingMsgs) + processEvent :: GroupInfo -> GroupMember -> TVar [Text] -> Text -> MsgEncodingI e => ChatMessage e -> CM (Maybe GroupForwardScope, Bool) processEvent gInfo' m' tags eInfo chatMsg@ChatMessage {chatMsgEvent} = do let tag = toCMEventTag chatMsgEvent atomically $ modifyTVar' tags (tshow tag :) @@ -936,42 +943,40 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = (m'', conn', msg@RcvMessage {chatMsgEvent = ACME _ event}) <- saveGroupRcvMsg user groupId m' conn msgMeta body chatMsg -- ! see isForwardedGroupMsg: processing functions should return GroupForwardScope for same events case event of - XMsgNew mc -> memberCanSend m'' scope $ newGroupContentMessage gInfo' m'' mc msg brokerTs False + XMsgNew mc -> memberCanSend m'' scope $ (,False) <$> newGroupContentMessage gInfo' m'' mc msg brokerTs False where ExtMsgContent {scope} = mcExtMsgContent mc -- file description is always allowed, to allow sending files to support scope - XMsgFileDescr sharedMsgId fileDescr -> groupMessageFileDescription gInfo' m'' sharedMsgId fileDescr - XMsgUpdate sharedMsgId mContent mentions ttl live msgScope -> memberCanSend m'' msgScope $ groupMessageUpdate gInfo' m'' sharedMsgId mContent mentions msgScope msg brokerTs ttl live - XMsgDel sharedMsgId memberId scope_ -> groupMessageDelete gInfo' m'' sharedMsgId memberId scope_ msg brokerTs - XMsgReact sharedMsgId (Just memberId) scope_ reaction add -> groupMsgReaction gInfo' m'' sharedMsgId memberId scope_ reaction add msg brokerTs + XMsgFileDescr sharedMsgId fileDescr -> (,False) <$> groupMessageFileDescription gInfo' m'' sharedMsgId fileDescr + XMsgUpdate sharedMsgId mContent mentions ttl live msgScope -> memberCanSend m'' msgScope $ (,False) <$> groupMessageUpdate gInfo' m'' sharedMsgId mContent mentions msgScope msg brokerTs ttl live + XMsgDel sharedMsgId memberId scope_ -> (,False) <$> groupMessageDelete gInfo' m'' sharedMsgId memberId scope_ msg brokerTs + XMsgReact sharedMsgId (Just memberId) scope_ reaction add -> (,False) <$> groupMsgReaction gInfo' m'' sharedMsgId memberId scope_ reaction add msg brokerTs -- TODO discontinue XFile - XFile fInv -> Nothing <$ processGroupFileInvitation' gInfo' m'' fInv msg brokerTs - XFileCancel sharedMsgId -> xFileCancelGroup gInfo' m'' sharedMsgId - XFileAcptInv sharedMsgId fileConnReq_ fName -> Nothing <$ xFileAcptInvGroup gInfo' m'' sharedMsgId fileConnReq_ fName - XInfo p -> xInfoMember gInfo' m'' p brokerTs - XGrpLinkMem p -> Nothing <$ xGrpLinkMem gInfo' m'' conn' p - XGrpLinkAcpt acceptance role memberId -> Nothing <$ xGrpLinkAcpt gInfo' m'' acceptance role memberId msg brokerTs - XGrpMemNew memInfo msgScope -> xGrpMemNew gInfo' m'' memInfo msgScope msg brokerTs - XGrpMemIntro memInfo memRestrictions_ -> Nothing <$ xGrpMemIntro gInfo' m'' memInfo memRestrictions_ - XGrpMemInv memId introInv -> Nothing <$ xGrpMemInv gInfo' m'' memId introInv - XGrpMemFwd memInfo introInv -> Nothing <$ xGrpMemFwd gInfo' m'' memInfo introInv - XGrpMemRole memId memRole -> xGrpMemRole gInfo' m'' memId memRole msg brokerTs - XGrpMemRestrict memId memRestrictions -> xGrpMemRestrict gInfo' m'' memId memRestrictions msg brokerTs - XGrpMemCon memId -> Nothing <$ xGrpMemCon gInfo' m'' memId - -- TODO there should be a special logic when deleting host member (e.g., host forwards it before deleting connections) + XFile fInv -> (Nothing, False) <$ processGroupFileInvitation' gInfo' m'' fInv msg brokerTs + XFileCancel sharedMsgId -> (,False) <$> xFileCancelGroup gInfo' m'' sharedMsgId + XFileAcptInv sharedMsgId fileConnReq_ fName -> (Nothing, False) <$ xFileAcptInvGroup gInfo' m'' sharedMsgId fileConnReq_ fName + XInfo p -> (,False) <$> xInfoMember gInfo' m'' p brokerTs + XGrpLinkMem p -> (Nothing, False) <$ xGrpLinkMem gInfo' m'' conn' p + XGrpLinkAcpt acceptance role memberId -> (Nothing, False) <$ xGrpLinkAcpt gInfo' m'' acceptance role memberId msg brokerTs + XGrpMemNew memInfo msgScope -> (,False) <$> xGrpMemNew gInfo' m'' memInfo msgScope msg brokerTs + XGrpMemIntro memInfo memRestrictions_ -> (Nothing, False) <$ xGrpMemIntro gInfo' m'' memInfo memRestrictions_ + XGrpMemInv memId introInv -> (Nothing, False) <$ xGrpMemInv gInfo' m'' memId introInv + XGrpMemFwd memInfo introInv -> (Nothing, False) <$ xGrpMemFwd gInfo' m'' memInfo introInv + XGrpMemRole memId memRole -> (,False) <$> xGrpMemRole gInfo' m'' memId memRole msg brokerTs + XGrpMemRestrict memId memRestrictions -> (,False) <$> xGrpMemRestrict gInfo' m'' memId memRestrictions msg brokerTs + XGrpMemCon memId -> (Nothing, False) <$ xGrpMemCon gInfo' m'' memId XGrpMemDel memId withMessages -> xGrpMemDel gInfo' m'' memId withMessages msg brokerTs - XGrpLeave -> xGrpLeave gInfo' m'' msg brokerTs - -- TODO there should be a special logic - host should forward before deleting connections - XGrpDel -> Just <$> xGrpDel gInfo' m'' msg brokerTs - XGrpInfo p' -> xGrpInfo gInfo' m'' p' msg brokerTs - XGrpPrefs ps' -> xGrpPrefs gInfo' m'' ps' + XGrpLeave -> (,False) <$> xGrpLeave gInfo' m'' msg brokerTs + XGrpDel -> (Just GFSAll, True) <$ xGrpDel gInfo' m'' msg brokerTs + XGrpInfo p' -> (,False) <$> xGrpInfo gInfo' m'' p' msg brokerTs + XGrpPrefs ps' -> (,False) <$> xGrpPrefs gInfo' m'' ps' -- TODO [knocking] why don't we forward these messages? - XGrpDirectInv connReq mContent_ msgScope -> memberCanSend m'' msgScope $ Nothing <$ xGrpDirectInv gInfo' m'' conn' connReq mContent_ msg brokerTs - XGrpMsgForward memberId msg' msgTs -> Nothing <$ xGrpMsgForward gInfo' m'' memberId msg' msgTs - XInfoProbe probe -> Nothing <$ xInfoProbe (COMGroupMember m'') probe - XInfoProbeCheck probeHash -> Nothing <$ xInfoProbeCheck (COMGroupMember m'') probeHash - XInfoProbeOk probe -> Nothing <$ xInfoProbeOk (COMGroupMember m'') probe - BFileChunk sharedMsgId chunk -> Nothing <$ bFileChunkGroup gInfo' sharedMsgId chunk msgMeta - _ -> Nothing <$ messageError ("unsupported message: " <> tshow event) + XGrpDirectInv connReq mContent_ msgScope -> memberCanSend m'' msgScope $ (Nothing, False) <$ xGrpDirectInv gInfo' m'' conn' connReq mContent_ msg brokerTs + XGrpMsgForward memberId msg' msgTs -> (Nothing, False) <$ xGrpMsgForward gInfo' m'' memberId msg' msgTs + XInfoProbe probe -> (Nothing, False) <$ xInfoProbe (COMGroupMember m'') probe + XInfoProbeCheck probeHash -> (Nothing, False) <$ xInfoProbeCheck (COMGroupMember m'') probeHash + XInfoProbeOk probe -> (Nothing, False) <$ xInfoProbeOk (COMGroupMember m'') probe + BFileChunk sharedMsgId chunk -> (Nothing, False) <$ bFileChunkGroup gInfo' sharedMsgId chunk msgMeta + _ -> (Nothing, False) <$ messageError ("unsupported message: " <> tshow event) checkSendRcpt :: [AChatMessage] -> CM Bool checkSendRcpt aMsgs = do currentMemCount <- withStore' $ \db -> getGroupCurrentMembersCount db user gInfo @@ -989,8 +994,8 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = -- as an additional step, instead initially retrieve only moderators -- (reuse getForwardIntroducedModerators, getForwardInvitedModerators + filters) -- - new GroupForwardScope for excluding members on XGrpMemRestrict - forwardMsgs :: GroupForwardScope -> NonEmpty (ChatMessage 'Json) -> CM () - forwardMsgs groupForwardScope fwdMsgs = do + forwardMsgs :: GroupForwardScope -> NonEmpty (ChatMessage 'Json) -> Bool -> CM () + forwardMsgs groupForwardScope fwdMsgs hasConnDeletingMsgs = do ms <- buildMemberList let GroupMember {memberId} = m events = L.map (\cm -> XGrpMsgForward memberId cm brokerTs) fwdMsgs @@ -999,10 +1004,16 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = buildMemberList = case groupForwardScope of GFSAll -> do ms <- getAllIntroducedAndInvited - pure $ filter (\mem -> memberCurrentOrPending mem && msgsForwardedToMember fwdMsgs mem) ms + let memberFilter mem = + (memberCurrentOrPending mem || (hasConnDeletingMsgs && memberStatus mem == GSMemMarkedRemoved)) + && msgsForwardedToMember fwdMsgs mem + pure $ filter memberFilter ms GFSMain -> do ms <- getAllIntroducedAndInvited - pure $ filter (\mem -> memberCurrent mem && msgsForwardedToMember fwdMsgs mem) ms + let memberFilter mem = + (memberCurrent mem || (hasConnDeletingMsgs && memberStatus mem == GSMemMarkedRemoved)) + && msgsForwardedToMember fwdMsgs mem + pure $ filter memberFilter ms GFSMemberSupport scopeGMId -> do -- moderators introduced to this invited member introducedModMs <- @@ -1013,7 +1024,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = invitedModMs <- withStore' $ \db -> getForwardInvitedModerators db vr user m let modMs = introducedModMs <> invitedModMs moderatorFilter mem = - memberCurrent mem + (memberCurrent mem || (hasConnDeletingMsgs && memberStatus mem == GSMemMarkedRemoved)) && maxVersion (memberChatVRange mem) >= groupKnockingVersion && msgsForwardedToMember fwdMsgs mem modMs' = filter moderatorFilter modMs @@ -1034,6 +1045,12 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = -- invited members to which this member was introduced invitedMembers <- withStore' $ \db -> getForwardInvitedMembers db vr user m highlyAvailable pure $ introducedMembers <> invitedMembers + processConnectionDeletingMsg :: GroupInfo -> ChatMessage 'Json -> CM () + processConnectionDeletingMsg gInfo' ChatMessage {chatMsgEvent} = + case chatMsgEvent of + XGrpMemDel memId _withMessages -> xGrpMemDelAfterFwd gInfo' memId + XGrpDel -> deleteAllMemberConnections gInfo' + _ -> messageWarning ("unexpected connection deleting message: " <> tshow chatMsgEvent) RCVD msgMeta msgRcpt -> withAckMessage' "group rcvd" agentConnId msgMeta $ groupMsgReceived gInfo m conn msgMeta msgRcpt @@ -1472,12 +1489,12 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = mem <- acceptGroupJoinSendRejectAsync user uclId gInfo invId chatVRange p xContactId_ rjctReason toViewTE $ TERejectingGroupJoinRequestMember user gInfo mem rjctReason - memberCanSend :: GroupMember -> Maybe MsgScope -> CM (Maybe GroupForwardScope) -> CM (Maybe GroupForwardScope) + memberCanSend :: GroupMember -> Maybe MsgScope -> CM (Maybe GroupForwardScope, Bool) -> CM (Maybe GroupForwardScope, Bool) memberCanSend m@GroupMember {memberRole} msgScope a = case msgScope of Just MSMember {} -> a Nothing | memberRole > GRObserver || memberPending m -> a - | otherwise -> messageError "member is not allowed to send messages" $> Nothing + | otherwise -> messageError "member is not allowed to send messages" $> (Nothing, False) processConnMERR :: ConnectionEntity -> Connection -> AgentErrorType -> CM () processConnMERR connEntity conn err = do @@ -2962,46 +2979,89 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = _ -> updateStatus introId GMIntroReConnected updateStatus introId status = withStore' $ \db -> updateIntroStatus db introId status - xGrpMemDel :: GroupInfo -> GroupMember -> MemberId -> Bool -> RcvMessage -> UTCTime -> CM (Maybe GroupForwardScope) + xGrpMemDel :: GroupInfo -> GroupMember -> MemberId -> Bool -> RcvMessage -> UTCTime -> CM (Maybe GroupForwardScope, Bool) 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 deleteGroupLinkIfExists user gInfo - -- member records are not deleted to keep history - members <- withStore' $ \db -> getGroupMembers db vr user gInfo - deleteMembersConnections user members + unless (isUserGrpFwdRelay gInfo) $ deleteAllMemberConnections gInfo withStore' $ \db -> updateGroupMemberStatus db userId membership GSMemRemoved - when withMessages $ deleteMessages membership SMDSnd + let membership' = membership {memberStatus = GSMemRemoved} + when withMessages $ deleteMessages gInfo membership' SMDSnd deleteMemberItem RGEUserDeleted - toView $ CEvtDeletedMemberUser user gInfo {membership = membership {memberStatus = GSMemRemoved}} m withMessages - pure Nothing -- TODO there should be a special logic when deleting host member (e.g., host forwards it before deleting connections) + toView $ CEvtDeletedMemberUser user gInfo {membership = membership'} m withMessages + pure (Just GFSAll, True) else withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId) >>= \case - Left _ -> messageError "x.grp.mem.del with unknown member ID" $> Just GFSAll + Left _ -> messageError "x.grp.mem.del with unknown member ID" $> (Just GFSAll, False) Right member@GroupMember {groupMemberId, memberProfile} -> - checkRole member $ do - -- ? prohibit deleting member if it's the sender - sender should use x.grp.leave - deleteMemberConnection member - -- undeleted "member connected" chat item will prevent deletion of member record - gInfo' <- deleteOrUpdateMemberRecord user gInfo member - when withMessages $ deleteMessages member SMDRcv - deleteMemberItem $ RGEMemberDeleted groupMemberId (fromLocalProfile memberProfile) - toView $ CEvtDeletedMember user gInfo' m member {memberStatus = GSMemRemoved} withMessages - pure $ memberEventForwardScope member + checkRole member $ + if isUserGrpFwdRelay gInfo + then do + gInfo' <- + withStore' $ \db -> do + gInfo' <- if gmRequiresAttention member + then decreaseGroupMembersRequireAttention db user gInfo + else pure gInfo + updateGroupMemberStatus db userId member GSMemMarkedRemoved + pure gInfo' + let member' = member {memberStatus = GSMemMarkedRemoved} + when withMessages $ deleteMessages gInfo' member' SMDRcv + deleteMemberItem $ RGEMemberDeleted groupMemberId (fromLocalProfile memberProfile) + toView $ CEvtDeletedMember user gInfo' m member' withMessages + pure (memberEventForwardScope member, True) + else do + -- ? prohibit deleting member if it's the sender - sender should use x.grp.leave + deleteMemberConnection member + -- undeleted "member connected" chat item will prevent deletion of member record + gInfo' <- deleteOrUpdateMemberRecord user gInfo member + let member' = member {memberStatus = GSMemRemoved} + when withMessages $ deleteMessages gInfo' member' SMDRcv + deleteMemberItem $ RGEMemberDeleted groupMemberId (fromLocalProfile memberProfile) + toView $ CEvtDeletedMember user gInfo' m member' withMessages + pure (Nothing, False) where checkRole GroupMember {memberRole} a | senderRole < GRAdmin || senderRole < memberRole = - messageError "x.grp.mem.del with insufficient member permissions" $> Nothing + messageError "x.grp.mem.del with insufficient member permissions" $> (Nothing, False) | otherwise = a deleteMemberItem gEvent = do (gInfo', m', scopeInfo) <- mkGroupChatScope gInfo m (ci, cInfo) <- saveRcvChatItemNoParse user (CDGroupRcv gInfo' scopeInfo m') msg brokerTs (CIRcvGroupEvent gEvent) groupMsgToView cInfo 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 + deleteMessages :: MsgDirectionI d => GroupInfo -> GroupMember -> SMsgDirection d -> CM () + deleteMessages gInfo' delMem msgDir + | groupFeatureMemberAllowed SGFFullDelete m gInfo' = deleteGroupMemberCIs user gInfo' delMem m msgDir + | otherwise = markGroupMemberCIsDeleted user gInfo' delMem m + + isUserGrpFwdRelay :: GroupInfo -> Bool + isUserGrpFwdRelay GroupInfo {membership = GroupMember {memberRole}} = + memberRole >= GRAdmin + + deleteAllMemberConnections :: GroupInfo -> CM () + deleteAllMemberConnections gInfo = do + -- member records are not deleted to keep history + members <- withStore' $ \db -> getGroupMembers db vr user gInfo + deleteMembersConnections user members + + xGrpMemDelAfterFwd :: GroupInfo -> MemberId -> CM () + xGrpMemDelAfterFwd gInfo@GroupInfo {membership} memId = do + let GroupMember {memberId = membershipMemId} = membership + if membershipMemId == memId + then + -- This scenario is fwd relay deleting member connections with all members + -- after forwarding to them that relay itself was removed. + deleteAllMemberConnections gInfo + else + -- This scenario is fwd relay deleting member connection with the removed member + -- after forwarding to that member that they were removed. + withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId) >>= \case + Left _ -> messageError "x.grp.mem.del with unknown member ID" + Right member -> do + deleteMemberConnection member + -- undeleted "member connected" chat item will prevent deletion of member record + void $ deleteOrUpdateMemberRecord user gInfo member xGrpLeave :: GroupInfo -> GroupMember -> RcvMessage -> UTCTime -> CM (Maybe GroupForwardScope) xGrpLeave gInfo m msg brokerTs = do @@ -3018,20 +3078,15 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = toView $ CEvtLeftMember user gInfo'' m' {memberStatus = GSMemLeft} pure $ memberEventForwardScope m - xGrpDel :: GroupInfo -> GroupMember -> RcvMessage -> UTCTime -> CM GroupForwardScope + xGrpDel :: GroupInfo -> GroupMember -> RcvMessage -> UTCTime -> CM () xGrpDel gInfo@GroupInfo {membership} m@GroupMember {memberRole} msg brokerTs = do when (memberRole /= GROwner) $ throwChatError $ CEGroupUserRole gInfo GROwner - ms <- withStore' $ \db -> do - members <- getGroupMembers db vr user gInfo - updateGroupMemberStatus db userId membership GSMemGroupDeleted - pure members - -- member records are not deleted to keep history - deleteMembersConnections user ms + withStore' $ \db -> updateGroupMemberStatus db userId membership GSMemGroupDeleted + unless (isUserGrpFwdRelay gInfo) $ deleteAllMemberConnections gInfo (gInfo'', m', scopeInfo) <- mkGroupChatScope gInfo m (ci, cInfo) <- saveRcvChatItemNoParse user (CDGroupRcv gInfo'' scopeInfo m') msg brokerTs (CIRcvGroupEvent RGEGroupDeleted) groupMsgToView cInfo ci toView $ CEvtGroupDeleted user gInfo'' {membership = membership {memberStatus = GSMemGroupDeleted}} m' - pure GFSAll xGrpInfo :: GroupInfo -> GroupMember -> GroupProfile -> RcvMessage -> UTCTime -> CM (Maybe GroupForwardScope) xGrpInfo g@GroupInfo {groupProfile = p, businessChat} m@GroupMember {memberRole} p' msg brokerTs @@ -3170,11 +3225,11 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = let body = chatMsgToBody chatMsg rcvMsg@RcvMessage {chatMsgEvent = ACME _ event} <- saveGroupFwdRcvMsg user groupId m author body chatMsg case event of - XMsgNew mc -> void $ memberCanSend author scope $ newGroupContentMessage gInfo author mc rcvMsg msgTs True + XMsgNew mc -> void $ memberCanSend author scope $ (,False) <$> newGroupContentMessage gInfo author mc rcvMsg msgTs True where ExtMsgContent {scope} = mcExtMsgContent mc -- file description is always allowed, to allow sending files to support scope XMsgFileDescr sharedMsgId fileDescr -> void $ groupMessageFileDescription gInfo author sharedMsgId fileDescr - XMsgUpdate sharedMsgId mContent mentions ttl live msgScope -> void $ memberCanSend author msgScope $ groupMessageUpdate gInfo author sharedMsgId mContent mentions msgScope rcvMsg msgTs ttl live + XMsgUpdate sharedMsgId mContent mentions ttl live msgScope -> void $ memberCanSend author msgScope $ (,False) <$> groupMessageUpdate gInfo author sharedMsgId mContent mentions msgScope rcvMsg msgTs ttl live XMsgDel sharedMsgId memId scope_ -> void $ groupMessageDelete gInfo author sharedMsgId memId scope_ rcvMsg msgTs XMsgReact sharedMsgId (Just memId) scope_ reaction add -> void $ groupMsgReaction gInfo author sharedMsgId memId scope_ reaction add rcvMsg msgTs XFileCancel sharedMsgId -> void $ xFileCancelGroup gInfo author sharedMsgId diff --git a/src/Simplex/Chat/Protocol.hs b/src/Simplex/Chat/Protocol.hs index 830a4e27b0..165d376814 100644 --- a/src/Simplex/Chat/Protocol.hs +++ b/src/Simplex/Chat/Protocol.hs @@ -385,9 +385,9 @@ 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 XGrpLeave -> True - XGrpDel -> True -- TODO there should be a special logic - host should forward before deleting connections + XGrpDel -> True XGrpInfo _ -> True XGrpPrefs _ -> True _ -> False diff --git a/src/Simplex/Chat/Store/Groups.hs b/src/Simplex/Chat/Store/Groups.hs index d9ea7e20e7..809b2fc3a1 100644 --- a/src/Simplex/Chat/Store/Groups.hs +++ b/src/Simplex/Chat/Store/Groups.hs @@ -818,9 +818,9 @@ getGroupToSubscribe db User {userId, userContactId} groupId = do FROM groups g JOIN group_members mu ON mu.group_id = g.group_id WHERE g.group_id = ? AND g.user_id = ? AND mu.contact_id = ? - AND mu.member_status NOT IN (?,?,?) + AND mu.member_status NOT IN (?,?,?,?) |] - (groupId, userId, userContactId, GSMemRemoved, GSMemLeft, GSMemGroupDeleted) + (groupId, userId, userContactId, GSMemMarkedRemoved, GSMemRemoved, GSMemLeft, GSMemGroupDeleted) where toInfo :: (GroupName, GroupMemberStatus) -> ShortGroupInfo toInfo (groupName, membershipStatus) = @@ -839,9 +839,9 @@ getGroupToSubscribe db User {userId, userContactId} groupId = do WHERE cc.user_id = ? AND cc.group_member_id = m.group_member_id ) WHERE m.user_id = ? AND m.group_id = ? AND (m.contact_id IS NULL OR m.contact_id != ?) - AND m.member_status NOT IN (?,?,?) + AND m.member_status NOT IN (?,?,?,?) |] - (userId, userId, groupId, userContactId, GSMemRemoved, GSMemLeft, GSMemGroupDeleted) + (userId, userId, groupId, userContactId, GSMemMarkedRemoved, GSMemRemoved, GSMemLeft, GSMemGroupDeleted) where toShortMember :: (GroupMemberId, ContactName, AgentConnId) -> ShortGroupMember toShortMember (groupMemberId, localDisplayName, agentConnId) = @@ -995,9 +995,9 @@ getGroupSummary db User {userId} groupId = do JOIN group_members m USING (group_id) WHERE g.user_id = ? AND g.group_id = ? - AND m.member_status NOT IN (?,?,?,?,?) + AND m.member_status NOT IN (?,?,?,?,?,?) |] - (userId, groupId, GSMemRejected, GSMemRemoved, GSMemLeft, GSMemUnknown, GSMemInvited) + (userId, groupId, GSMemRejected, GSMemMarkedRemoved, GSMemRemoved, GSMemLeft, GSMemUnknown, GSMemInvited) pure GroupSummary {currentMembers = fromMaybe 0 currentMembers_} getContactGroupPreferences :: DB.Connection -> User -> Contact -> IO [(GroupMemberRole, FullGroupPreferences)] @@ -1143,13 +1143,13 @@ getGroupMembersForExpiration db vr user@User {userId, userContactId} GroupInfo { ( groupMemberQuery <> [sql| WHERE m.group_id = ? AND m.user_id = ? AND (m.contact_id IS NULL OR m.contact_id != ?) - AND m.member_status IN (?, ?, ?, ?) + AND m.member_status IN (?, ?, ?, ?, ?) AND m.group_member_id NOT IN ( SELECT DISTINCT group_member_id FROM chat_items ) |] ) - (userId, groupId, userId, userContactId, GSMemRemoved, GSMemLeft, GSMemGroupDeleted, GSMemUnknown) + (userId, groupId, userId, userContactId, GSMemMarkedRemoved, GSMemRemoved, GSMemLeft, GSMemGroupDeleted, GSMemUnknown) toContactMember :: VersionRangeChat -> User -> (GroupMemberRow :. MaybeConnectionRow) -> GroupMember toContactMember vr User {userContactId} (memberRow :. connRow) = @@ -2104,10 +2104,10 @@ getGroupInfoByGroupLinkHash db vr user@User {userId, userContactId} (groupLinkHa FROM groups g JOIN group_members mu ON mu.group_id = g.group_id WHERE g.user_id = ? AND g.via_group_link_uri_hash IN (?,?) - AND mu.contact_id = ? AND mu.member_status NOT IN (?,?,?,?) + AND mu.contact_id = ? AND mu.member_status NOT IN (?,?,?,?,?) LIMIT 1 |] - (userId, groupLinkHash1, groupLinkHash2, userContactId, GSMemRemoved, GSMemLeft, GSMemGroupDeleted, GSMemUnknown) + (userId, groupLinkHash1, groupLinkHash2, userContactId, GSMemMarkedRemoved, GSMemRemoved, GSMemLeft, GSMemGroupDeleted, GSMemUnknown) maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getGroupInfo db vr user) groupId_ getGroupIdByName :: DB.Connection -> User -> GroupName -> ExceptT StoreError IO GroupId diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index 5d25ae64e3..26cc2b4e78 100644 --- a/src/Simplex/Chat/Types.hs +++ b/src/Simplex/Chat/Types.hs @@ -1165,6 +1165,7 @@ instance TextEncoding GroupMemberCategory where data GroupMemberStatus = GSMemRejected -- joining member who was rejected by the host, or host that rejected the join + | GSMemMarkedRemoved -- member was removed from the group, but forwarding relay keeps their connection temporarily | GSMemRemoved -- member who was removed from the group | GSMemLeft -- member who left the group | GSMemGroupDeleted -- user member of the deleted group @@ -1202,6 +1203,7 @@ acceptanceToStatus memberAdmission groupAcceptance memberActive :: GroupMember -> Bool memberActive m = case memberStatus m of GSMemRejected -> False + GSMemMarkedRemoved -> False GSMemRemoved -> False GSMemLeft -> False GSMemGroupDeleted -> False @@ -1233,6 +1235,7 @@ memberCurrentOrPending m = memberCurrent m || memberPending m memberCurrent' :: GroupMemberStatus -> Bool memberCurrent' = \case GSMemRejected -> False + GSMemMarkedRemoved -> False GSMemRemoved -> False GSMemLeft -> False GSMemGroupDeleted -> False @@ -1251,6 +1254,7 @@ memberCurrent' = \case memberRemoved :: GroupMember -> Bool memberRemoved m = case memberStatus m of GSMemRejected -> True + GSMemMarkedRemoved -> True GSMemRemoved -> True GSMemLeft -> True GSMemGroupDeleted -> True @@ -1269,6 +1273,7 @@ memberRemoved m = case memberStatus m of instance TextEncoding GroupMemberStatus where textDecode = \case "rejected" -> Just GSMemRejected + "marked_removed" -> Just GSMemMarkedRemoved "removed" -> Just GSMemRemoved "left" -> Just GSMemLeft "deleted" -> Just GSMemGroupDeleted @@ -1286,6 +1291,7 @@ instance TextEncoding GroupMemberStatus where _ -> Nothing textEncode = \case GSMemRejected -> "rejected" + GSMemMarkedRemoved -> "marked_removed" GSMemRemoved -> "removed" GSMemLeft -> "left" GSMemGroupDeleted -> "deleted" diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 6fef6cc204..961d3f8894 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -1299,7 +1299,7 @@ showRole = plain . strEncode viewGroupMembers :: Group -> [StyledString] viewGroupMembers (Group GroupInfo {membership} members) = map groupMember . filter (not . removedOrLeft) $ membership : members where - removedOrLeft m = let s = memberStatus m in s == GSMemRejected || s == GSMemRemoved || s == GSMemLeft + removedOrLeft m = let s = memberStatus m in s == GSMemRejected || s == GSMemMarkedRemoved || s == GSMemRemoved || s == GSMemLeft groupMember m = memIncognito m <> ttyFullMember m <> ": " <> plain (intercalate ", " $ [role m] <> category m <> status m <> muted m) role :: GroupMember -> String role GroupMember {memberRole} = B.unpack $ strEncode memberRole @@ -1310,6 +1310,7 @@ viewGroupMembers (Group GroupInfo {membership} members) = map groupMember . filt _ -> [] status m = case memberStatus m of GSMemRejected -> ["rejected"] + GSMemMarkedRemoved -> ["removed"] GSMemRemoved -> ["removed"] GSMemLeft -> ["left"] GSMemUnknown -> ["status unknown"] @@ -1363,6 +1364,7 @@ viewGroupsList gs = map groupSS $ sortOn ldn_ gs where viewMemberStatus = \case GSMemRejected -> delete "you are rejected" + GSMemMarkedRemoved -> delete "you are removed" -- shouldn't happen - status is only assigned to other members GSMemRemoved -> delete "you are removed" GSMemLeft -> delete "you left" GSMemGroupDeleted -> delete "group deleted" diff --git a/tests/ChatTests/Groups.hs b/tests/ChatTests/Groups.hs index ab438b2e58..199ac5bd43 100644 --- a/tests/ChatTests/Groups.hs +++ b/tests/ChatTests/Groups.hs @@ -160,6 +160,7 @@ chatGroupTests = do it "forward role change (x.grp.mem.role)" testGroupMsgForwardChangeRole it "forward new member announcement (x.grp.mem.new)" testGroupMsgForwardNewMember it "forward member leaving (x.grp.leave)" testGroupMsgForwardLeave + it "forward member deletion (x.grp.mem.del)" testGroupMsgForwardMemberDelete describe "group history" $ do it "text messages" testGroupHistory it "history is sent when joining via group link" testGroupHistoryGroupLink @@ -5055,6 +5056,33 @@ testGroupMsgForwardLeave = alice <## "#team: bob left the group" cath <## "#team: bob left the group" +testGroupMsgForwardMemberDelete :: HasCallStack => TestParams -> IO () +testGroupMsgForwardMemberDelete = + testChat3 aliceProfile bobProfile cathProfile $ + \alice bob cath -> do + createGroup3' "team" alice (bob, GRAdmin) (cath, GRMember) + setupGroupForwarding alice bob cath + + -- remove member + bob ##> "/rm team cath" + concurrentlyN_ + [ bob <## "#team: you removed cath from the group", + alice <## "#team: bob removed cath from the group", + do + cath <## "#team: bob removed you from the group" + cath <## "use /d #team to delete the group" + ] + bob #> "#team hi" + concurrently_ + (alice <# "#team bob> hi") + (cath "#team hello" + concurrently_ + (bob <# "#team alice> hello") + (cath "#team hello" + cath <## "bad chat command: not current member" + testGroupHistory :: HasCallStack => TestParams -> IO () testGroupHistory = testChat3 aliceProfile bobProfile cathProfile $