diff --git a/bots/api/TYPES.md b/bots/api/TYPES.md index 74e761107f..449d6a9294 100644 --- a/bots/api/TYPES.md +++ b/bots/api/TYPES.md @@ -3111,6 +3111,7 @@ A_QUEUE: - "invitation" - "group" - "channel" +- "relay" --- diff --git a/cabal.project b/cabal.project index 6ef2de59c8..35fc11b3f3 100644 --- a/cabal.project +++ b/cabal.project @@ -12,7 +12,7 @@ constraints: zip +disable-bzip2 +disable-zstd source-repository-package type: git location: https://github.com/simplex-chat/simplexmq.git - tag: 2cedb66667fe4c6b0fed1a7a6f57cbb160695be1 + tag: 46035af9a3f1dac73ec6fd9f304538b39e010955 source-repository-package type: git diff --git a/scripts/nix/sha256map.nix b/scripts/nix/sha256map.nix index 35f3687df1..746c8b255a 100644 --- a/scripts/nix/sha256map.nix +++ b/scripts/nix/sha256map.nix @@ -1,5 +1,5 @@ { - "https://github.com/simplex-chat/simplexmq.git"."2cedb66667fe4c6b0fed1a7a6f57cbb160695be1" = "0w326lpbn6aaibqms545j0yn6sb9myr0yjc3f5hmykpjdfryw0g3"; + "https://github.com/simplex-chat/simplexmq.git"."46035af9a3f1dac73ec6fd9f304538b39e010955" = "031fg3l3vf9bsa2q08jrkx2bx14gcs2dnbdpx6d9bkxql0vkgq3h"; "https://github.com/simplex-chat/hs-socks.git"."a30cc7a79a08d8108316094f8f2f82a0c5e1ac51" = "0yasvnr7g91k76mjkamvzab2kvlb1g5pspjyjn2fr6v83swjhj38"; "https://github.com/simplex-chat/direct-sqlcipher.git"."f814ee68b16a9447fbb467ccc8f29bdd3546bfd9" = "1ql13f4kfwkbaq7nygkxgw84213i0zm7c1a8hwvramayxl38dq5d"; "https://github.com/simplex-chat/sqlcipher-simple.git"."a46bd361a19376c5211f1058908fc0ae6bf42446" = "1z0r78d8f0812kxbgsm735qf6xx8lvaz27k1a0b4a2m0sshpd5gl"; diff --git a/src/Simplex/Chat/Library/Subscriber.hs b/src/Simplex/Chat/Library/Subscriber.hs index 3312e928de..e911dc8d03 100644 --- a/src/Simplex/Chat/Library/Subscriber.hs +++ b/src/Simplex/Chat/Library/Subscriber.hs @@ -351,6 +351,8 @@ processAgentMsgRcvFile _corrId aFileId msg = do agentXFTPDeleteRcvFile aFileId fileId toView $ CEvtRcvFileError user aci_ e ft +type ShouldDeleteGroupConns = Bool + processAgentMessageConn :: VersionRangeChat -> User -> ACorrId -> ConnId -> AEvent 'AEConn -> CM () processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = do -- Missing connection/entity errors here will be sent to the view but not shown as CRITICAL alert, @@ -478,7 +480,8 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = atomically $ modifyTVar' tags ("error" :) logInfo $ "contact msg=error " <> eInfo <> " " <> tshow e eToView (ChatError . CEException $ "error parsing chat message: " <> e) - checkSendRcpt ct' $ rights aChatMsgs -- not crucial to use ct'' from processEvent + withRcpt <- checkSendRcpt ct' $ rights aChatMsgs -- not crucial to use ct'' from processEvent + pure (withRcpt, False) where aChatMsgs = parseChatMessages msgBody processEvent :: Contact -> Connection -> TVar [Text] -> Text -> MsgEncodingI e => ChatMessage e -> CM () @@ -895,12 +898,14 @@ 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 - checkSendRcpt $ rights aChatMsgs + (fwdScopesMsgs, shouldDelConns) <- foldM (processAChatMsg gInfo' m' tags eInfo) (M.empty, False) aChatMsgs + when (isUserGrpFwdRelay gInfo') $ do + unless (blockedByAdmin m) $ + forM_ (M.assocs fwdScopesMsgs) $ \(groupForwardScope, fwdMsgs) -> + forwardMsgs groupForwardScope (L.reverse fwdMsgs) `catchChatError` eToView + when shouldDelConns $ deleteGroupConnections gInfo' True + withRcpt <- checkSendRcpt $ rights aChatMsgs + pure (withRcpt, shouldDelConns) where aChatMsgs = parseChatMessages msgBody brokerTs = metaBrokerTs msgMeta @@ -909,25 +914,28 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = -> GroupMember -> TVar [Text] -> Text - -> Map GroupForwardScope (NonEmpty (ChatMessage 'Json)) + -> (Map GroupForwardScope (NonEmpty (ChatMessage 'Json)), ShouldDeleteGroupConns) -> Either String AChatMessage - -> CM (Map GroupForwardScope (NonEmpty (ChatMessage 'Json))) - processAChatMsg gInfo' m' tags eInfo fwdScopeMap = \case + -> CM (Map GroupForwardScope (NonEmpty (ChatMessage 'Json)), ShouldDeleteGroupConns) + processAChatMsg gInfo' m' tags eInfo (fwdScopeMap, shouldDelConns) = \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_, cmShouldDelConns) <- + 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 + shouldDelConns' = shouldDelConns || cmShouldDelConns + pure (fwdScopeMap', shouldDelConns') Right (ACMsg SBinary chatMsg) -> do void (processEvent gInfo' m' tags eInfo chatMsg) `catchChatError` \e -> eToView e - pure fwdScopeMap + pure (fwdScopeMap, shouldDelConns) 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, shouldDelConns) + processEvent :: forall e. MsgEncodingI e => GroupInfo -> GroupMember -> TVar [Text] -> Text -> ChatMessage e -> CM (Maybe GroupForwardScope, ShouldDeleteGroupConns) processEvent gInfo' m' tags eInfo chatMsg@ChatMessage {chatMsgEvent} = do let tag = toCMEventTag chatMsgEvent atomically $ modifyTVar' tags (tshow tag :) @@ -936,42 +944,42 @@ 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) - 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' + 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 -> case encoding @e of + SJson -> xGrpMemDel gInfo' m'' memId withMessages chatMsg msg brokerTs False + SBinary -> pure (Nothing, False) -- impossible + 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 @@ -1472,12 +1480,16 @@ 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, ShouldDeleteGroupConns) -> + CM (Maybe GroupForwardScope, ShouldDeleteGroupConns) 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 @@ -1534,9 +1546,9 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = withAckMessage' :: Text -> ConnId -> MsgMeta -> CM () -> CM () withAckMessage' label cId msgMeta action = do - withAckMessage label cId msgMeta False Nothing $ \_ -> action $> False + withAckMessage label cId msgMeta False Nothing $ \_ -> action $> (False, False) - withAckMessage :: Text -> ConnId -> MsgMeta -> Bool -> Maybe (TVar [Text]) -> (Text -> CM Bool) -> CM () + withAckMessage :: Text -> ConnId -> MsgMeta -> Bool -> Maybe (TVar [Text]) -> (Text -> CM (Bool, ShouldDeleteGroupConns)) -> CM () withAckMessage label cId msgMeta showCritical tags action = do -- [async agent commands] command should be asynchronous -- TODO catching error and sending ACK after an error, particularly if it is a database error, will result in the message not processed (and no notification to the user). @@ -1547,8 +1559,8 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = eInfo <- eventInfo logInfo $ label <> ": " <> eInfo tryChatError (action eInfo) >>= \case - Right withRcpt -> - withLog (eInfo <> " ok") $ ackMsg msgMeta $ if withRcpt then Just "" else Nothing + Right (withRcpt, shouldDelConns) -> + unless shouldDelConns $ withLog (eInfo <> " ok") $ ackMsg msgMeta $ if withRcpt then Just "" else Nothing -- If showCritical is True, then these errors don't result in ACK and show user visible alert -- This prevents losing the message that failed to be processed. Left (ChatErrorStore SEDBBusyError {message}) | showCritical -> throwError $ ChatErrorAgent (CRITICAL True message) Nothing @@ -2962,46 +2974,67 @@ 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 gInfo@GroupInfo {membership} m@GroupMember {memberRole = senderRole} memId withMessages msg brokerTs = do + xGrpMemDel :: GroupInfo -> GroupMember -> MemberId -> Bool -> ChatMessage 'Json -> RcvMessage -> UTCTime -> Bool -> CM (Maybe GroupForwardScope, ShouldDeleteGroupConns) + xGrpMemDel gInfo@GroupInfo {membership} m@GroupMember {memberRole = senderRole} memId withMessages chatMsg msg brokerTs forwarded = 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) $ deleteGroupConnections gInfo False 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 - Right member@GroupMember {groupMemberId, memberProfile} -> - checkRole member $ do + Left _ -> messageError "x.grp.mem.del with unknown member ID" $> (Just GFSAll, False) + Right deletedMember@GroupMember {groupMemberId, memberProfile} -> + checkRole deletedMember $ do -- ? prohibit deleting member if it's the sender - sender should use x.grp.leave - deleteMemberConnection member + if isUserGrpFwdRelay gInfo && not forwarded + then do + -- Special case: forward before deleting connection. + -- It allows us to avoid adding logic in forwardMsgs to circumvent member filtering. + forwardToMember deletedMember + deleteMemberConnection' deletedMember True + else deleteMemberConnection deletedMember -- undeleted "member connected" chat item will prevent deletion of member record - gInfo' <- deleteOrUpdateMemberRecord user gInfo member - when withMessages $ deleteMessages member SMDRcv + gInfo' <- deleteOrUpdateMemberRecord user gInfo deletedMember + let deletedMember' = deletedMember {memberStatus = GSMemRemoved} + when withMessages $ deleteMessages gInfo' deletedMember' SMDRcv deleteMemberItem $ RGEMemberDeleted groupMemberId (fromLocalProfile memberProfile) - toView $ CEvtDeletedMember user gInfo' m member {memberStatus = GSMemRemoved} withMessages - pure $ memberEventForwardScope member + toView $ CEvtDeletedMember user gInfo' m deletedMember' withMessages + pure (memberEventForwardScope deletedMember, 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 + forwardToMember :: GroupMember -> CM () + forwardToMember member = do + let GroupMember {memberId} = m + event = XGrpMsgForward memberId chatMsg brokerTs + sendGroupMemberMessage gInfo member event Nothing (pure ()) + + isUserGrpFwdRelay :: GroupInfo -> Bool + isUserGrpFwdRelay GroupInfo {membership = GroupMember {memberRole}} = + memberRole >= GRAdmin + + deleteGroupConnections :: GroupInfo -> Bool -> CM () + deleteGroupConnections gInfo waitDelivery = do + -- member records are not deleted to keep history + members <- withStore' $ \db -> getGroupMembers db vr user gInfo + deleteMembersConnections' user members waitDelivery xGrpLeave :: GroupInfo -> GroupMember -> RcvMessage -> UTCTime -> CM (Maybe GroupForwardScope) xGrpLeave gInfo m msg brokerTs = do @@ -3018,20 +3051,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) $ deleteGroupConnections gInfo False (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,18 +3198,18 @@ 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 XInfo p -> void $ xInfoMember gInfo author p msgTs XGrpMemNew memInfo msgScope -> void $ xGrpMemNew gInfo author memInfo msgScope rcvMsg msgTs XGrpMemRole memId memRole -> void $ xGrpMemRole gInfo author memId memRole rcvMsg msgTs - XGrpMemDel memId withMessages -> void $ xGrpMemDel gInfo author memId withMessages rcvMsg msgTs + XGrpMemDel memId withMessages -> void $ xGrpMemDel gInfo author memId withMessages chatMsg rcvMsg msgTs True XGrpLeave -> void $ xGrpLeave gInfo author rcvMsg msgTs XGrpDel -> void $ xGrpDel gInfo author rcvMsg msgTs XGrpInfo p' -> void $ xGrpInfo gInfo author p' rcvMsg msgTs 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/tests/ChatTests/Groups.hs b/tests/ChatTests/Groups.hs index ab438b2e58..58415e3826 100644 --- a/tests/ChatTests/Groups.hs +++ b/tests/ChatTests/Groups.hs @@ -160,6 +160,9 @@ 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 removal (x.grp.mem.del)" testGroupMsgForwardMemberRemoval + it "forward admin removal (x.grp.mem.del, relay forwards it was removed)" testGroupMsgForwardAdminRemoval + it "forward group deletion (x.grp.del)" testGroupMsgForwardGroupDeletion describe "group history" $ do it "text messages" testGroupHistory it "history is sent when joining via group link" testGroupHistoryGroupLink @@ -5055,6 +5058,108 @@ testGroupMsgForwardLeave = alice <## "#team: bob left the group" cath <## "#team: bob left the group" +testGroupMsgForwardMemberRemoval :: HasCallStack => TestParams -> IO () +testGroupMsgForwardMemberRemoval = + 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" + +testGroupMsgForwardAdminRemoval :: HasCallStack => TestParams -> IO () +testGroupMsgForwardAdminRemoval = + testChat3 aliceProfile bobProfile cathProfile $ + \alice bob cath -> do + createGroup3' "team" alice (bob, GROwner) (cath, GRMember) + setupGroupForwarding alice bob cath + + -- alice forwards messages between bob and cath + bob #> "#team hi there" + alice <# "#team bob> hi there" + cath <# "#team bob> hi there [>>]" + + cath #> "#team hey" + alice <# "#team cath> hey" + bob <# "#team cath> hey [>>]" + + -- if alice is removed, she forwards message of her own removal + bob ##> "/rm team alice" + concurrentlyN_ + [ bob <## "#team: you removed alice from the group", + do + alice <## "#team: bob removed you from the group" + alice <## "use /d #team to delete the group", + cath <## "#team: bob removed alice from the group" + ] + + -- there is no forwarding admin anymore between bob and cath, so messages don't get delivered + -- (this is not a desired behavior, just a test demonstration/proof of current implementation) + bob #> "#team hi" + concurrently_ + (cath "#team hello" + concurrently_ + (bob "#team hello" + alice <## "bad chat command: not current member" + +testGroupMsgForwardGroupDeletion :: HasCallStack => TestParams -> IO () +testGroupMsgForwardGroupDeletion = + testChat3 aliceProfile bobProfile cathProfile $ + \alice bob cath -> do + createGroup3' "team" alice (bob, GROwner) (cath, GRMember) + setupGroupForwarding alice bob cath + + -- alice forwards messages between bob and cath + bob #> "#team hi there" + alice <# "#team bob> hi there" + cath <# "#team bob> hi there [>>]" + + cath #> "#team hey" + alice <# "#team cath> hey" + bob <# "#team cath> hey [>>]" + + -- if bob deletes the group, alice forwards it to cath + bob ##> "/d #team" + concurrentlyN_ + [ bob <## "#team: you deleted the group", + do + alice <## "#team: bob deleted the group" + alice <## "use /d #team to delete the local copy of the group", + do + cath <## "#team: bob deleted the group" + cath <## "use /d #team to delete the local copy of the group" + ] + + alice ##> "/groups" + alice <## "#team (group deleted, delete local copy: /d #team)" + bob ##> "/groups" + bob <## "you have no groups!" + bob <## "to create: /g " + cath ##> "/groups" + cath <## "#team (group deleted, delete local copy: /d #team)" + testGroupHistory :: HasCallStack => TestParams -> IO () testGroupHistory = testChat3 aliceProfile bobProfile cathProfile $