diff --git a/src/Simplex/Chat/Library/Commands.hs b/src/Simplex/Chat/Library/Commands.hs index 3065b48893..1f1f114a39 100644 --- a/src/Simplex/Chat/Library/Commands.hs +++ b/src/Simplex/Chat/Library/Commands.hs @@ -669,7 +669,7 @@ processChatCommand vr nm = \case assertDeletable items assertDirectAllowed user MDSnd ct XMsgDel_ let msgIds = itemsMsgIds items - events = map (\msgId -> XMsgDel msgId Nothing) msgIds + events = map (\msgId -> XMsgDel msgId Nothing Nothing) msgIds forM_ (L.nonEmpty events) $ \events' -> sendDirectContactMessages user ct events' if featureAllowed SCFFullDelete forUser ct @@ -691,7 +691,7 @@ processChatCommand vr nm = \case assertDeletable items assertUserGroupRole gInfo GRObserver -- can still delete messages sent earlier let msgIds = itemsMsgIds items - events = L.nonEmpty $ map (`XMsgDel` Nothing) msgIds + events = L.nonEmpty $ map (\msgId -> XMsgDel msgId Nothing $ toMsgScope gInfo <$> chatScopeInfo) msgIds mapM_ (sendGroupMessages user gInfo Nothing recipients) events delGroupChatItems user gInfo chatScopeInfo items False pure $ CRChatItemsDeleted user deletions True False @@ -754,7 +754,7 @@ processChatCommand vr nm = \case throwCmdError "reaction not allowed - chat item has no content" rs <- withFastStore' $ \db -> getDirectReactions db ct itemSharedMId True checkReactionAllowed rs - (SndMessage {msgId}, _) <- sendDirectContactMessage user ct $ XMsgReact itemSharedMId Nothing reaction add + (SndMessage {msgId}, _) <- sendDirectContactMessage user ct $ XMsgReact itemSharedMId Nothing Nothing reaction add createdAt <- liftIO getCurrentTime reactions <- withFastStore' $ \db -> do setDirectReaction db ct itemSharedMId True reaction add msgId createdAt @@ -779,7 +779,7 @@ processChatCommand vr nm = \case let GroupMember {memberId = itemMemberId} = chatItemMember g ci rs <- withFastStore' $ \db -> getGroupReactions db g membership itemMemberId itemSharedMId True checkReactionAllowed rs - SndMessage {msgId} <- sendGroupMessage user g scope recipients (XMsgReact itemSharedMId (Just itemMemberId) reaction add) + SndMessage {msgId} <- sendGroupMessage user g scope recipients (XMsgReact itemSharedMId (Just itemMemberId) (toMsgScope g <$> chatScopeInfo) reaction add) createdAt <- liftIO getCurrentTime reactions <- withFastStore' $ \db -> do setGroupReaction db g membership itemMemberId itemSharedMId True reaction add msgId createdAt @@ -2507,7 +2507,7 @@ processChatCommand vr nm = \case APIUpdateGroupProfile groupId p' -> withUser $ \user -> do g <- withFastStore $ \db -> getGroup db vr user groupId runUpdateGroupProfile user g p' - UpdateGroupNames gName p'@GroupProfile {displayName, fullName, shortDescr} -> + UpdateGroupNames gName GroupProfile {displayName, fullName, shortDescr} -> updateGroupProfileByName gName $ \p -> p {displayName, fullName, shortDescr} ShowGroupProfile gName -> withUser $ \user -> CRGroupProfile user <$> withFastStore (\db -> getGroupInfoByName db vr user gName) @@ -3202,7 +3202,7 @@ processChatCommand vr nm = \case assertDeletable gInfo items assertUserGroupRole gInfo GRAdmin -- TODO GRModerator when most users migrate let msgMemIds = itemsMsgMemIds gInfo items - events = L.nonEmpty $ map (\(msgId, memId) -> XMsgDel msgId (Just memId)) msgMemIds + events = L.nonEmpty $ map (\(msgId, memId) -> XMsgDel msgId (Just memId) $ toMsgScope gInfo <$> chatScopeInfo) msgMemIds mapM_ (sendGroupMessages_ user gInfo ms) events delGroupChatItems user gInfo chatScopeInfo items True where diff --git a/src/Simplex/Chat/Library/Subscriber.hs b/src/Simplex/Chat/Library/Subscriber.hs index 5a73430191..4819f254dd 100644 --- a/src/Simplex/Chat/Library/Subscriber.hs +++ b/src/Simplex/Chat/Library/Subscriber.hs @@ -4,6 +4,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} @@ -28,7 +29,7 @@ import Data.Either (lefts, partitionEithers, rights) import Data.Functor (($>)) import Data.Int (Int64) import Data.List (foldl') -import Data.List.NonEmpty (NonEmpty (..)) +import Data.List.NonEmpty (NonEmpty (..), (<|)) import qualified Data.List.NonEmpty as L import Data.Map.Strict (Map) import qualified Data.Map.Strict as M @@ -490,8 +491,8 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = XMsgNew mc -> newContentMessage ct'' mc msg msgMeta XMsgFileDescr sharedMsgId fileDescr -> messageFileDescription ct'' sharedMsgId fileDescr XMsgUpdate sharedMsgId mContent _ ttl live _msgScope -> messageUpdate ct'' sharedMsgId mContent msg msgMeta ttl live - XMsgDel sharedMsgId _ -> messageDelete ct'' sharedMsgId msg msgMeta - XMsgReact sharedMsgId _ reaction add -> directMsgReaction ct'' sharedMsgId reaction add msg msgMeta + XMsgDel sharedMsgId _ _ -> messageDelete ct'' sharedMsgId msg msgMeta + XMsgReact sharedMsgId _ _ reaction add -> directMsgReaction ct'' sharedMsgId reaction add msg msgMeta -- TODO discontinue XFile XFile fInv -> processFileInvitation' ct'' fInv msg msgMeta XFileCancel sharedMsgId -> xFileCancel ct'' sharedMsgId @@ -889,59 +890,82 @@ 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 () - forM_ aChatMsgs $ \case - Right (ACMsg _ chatMsg) -> - processEvent gInfo' m' tags eInfo chatMsg `catchChatError` \e -> eToView e - Left e -> do - atomically $ modifyTVar' tags ("error" :) - logInfo $ "group msg=error " <> eInfo <> " " <> tshow e - eToView (ChatError . CEException $ "error parsing chat message: " <> e) - forwardMsgs (rights aChatMsgs) `catchChatError` eToView + 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 where aChatMsgs = parseChatMessages msgBody brokerTs = metaBrokerTs msgMeta - processEvent :: GroupInfo -> GroupMember -> TVar [Text] -> Text -> MsgEncodingI e => ChatMessage e -> CM () + processAChatMsg :: + GroupInfo + -> GroupMember + -> TVar [Text] + -> Text + -> Map GroupForwardScope (NonEmpty (ChatMessage 'Json)) + -> Either String AChatMessage + -> CM (Map GroupForwardScope (NonEmpty (ChatMessage 'Json))) + processAChatMsg gInfo' m' tags eInfo fwdScopeMap = \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 + Right (ACMsg SBinary chatMsg) -> do + void (processEvent gInfo' m' tags eInfo chatMsg) `catchChatError` \e -> eToView e + pure fwdScopeMap + 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) processEvent gInfo' m' tags eInfo chatMsg@ChatMessage {chatMsgEvent} = do let tag = toCMEventTag chatMsgEvent atomically $ modifyTVar' tags (tshow tag :) logInfo $ "group msg=" <> tshow tag <> " " <> eInfo (m'', conn', msg@RcvMessage {chatMsgEvent = ACME _ event}) <- saveGroupRcvMsg user groupId m' conn msgMeta msgBody 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 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 -> groupMessageDelete gInfo' m'' sharedMsgId memberId msg brokerTs - XMsgReact sharedMsgId (Just memberId) reaction add -> groupMsgReaction gInfo' m'' sharedMsgId memberId reaction add msg brokerTs + 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 -- TODO discontinue XFile - XFile fInv -> processGroupFileInvitation' gInfo' m'' fInv msg brokerTs + XFile fInv -> Nothing <$ processGroupFileInvitation' gInfo' m'' fInv msg brokerTs XFileCancel sharedMsgId -> xFileCancelGroup gInfo' m'' sharedMsgId - XFileAcptInv sharedMsgId fileConnReq_ fName -> xFileAcptInvGroup gInfo' m'' sharedMsgId fileConnReq_ fName + XFileAcptInv sharedMsgId fileConnReq_ fName -> Nothing <$ xFileAcptInvGroup gInfo' m'' sharedMsgId fileConnReq_ fName XInfo p -> xInfoMember gInfo' m'' p brokerTs - XGrpLinkMem p -> xGrpLinkMem gInfo' m'' conn' p - XGrpLinkAcpt acceptance role memberId -> xGrpLinkAcpt gInfo' m'' acceptance role memberId msg 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_ -> xGrpMemIntro gInfo' m'' memInfo memRestrictions_ - XGrpMemInv memId introInv -> xGrpMemInv gInfo' m'' memId introInv - XGrpMemFwd memInfo introInv -> xGrpMemFwd gInfo' m'' memInfo introInv + 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 -> xGrpMemCon gInfo' m'' memId + 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 - XGrpDel -> xGrpDel 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' -- TODO [knocking] why don't we forward these messages? - XGrpDirectInv connReq mContent_ msgScope -> memberCanSend m'' msgScope $ xGrpDirectInv gInfo' m'' conn' connReq mContent_ msg brokerTs - XGrpMsgForward memberId msg' msgTs -> xGrpMsgForward gInfo' m'' memberId msg' msgTs - XInfoProbe probe -> xInfoProbe (COMGroupMember m'') probe - XInfoProbeCheck probeHash -> xInfoProbeCheck (COMGroupMember m'') probeHash - XInfoProbeOk probe -> xInfoProbeOk (COMGroupMember m'') probe - BFileChunk sharedMsgId chunk -> bFileChunkGroup gInfo' sharedMsgId chunk msgMeta - _ -> messageError $ "unsupported message: " <> tshow event + 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) checkSendRcpt :: [AChatMessage] -> CM Bool checkSendRcpt aMsgs = do currentMemCount <- withStore' $ \db -> getGroupCurrentMembersCount db user gInfo @@ -953,25 +977,57 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = where aChatMsgHasReceipt (ACMsg _ ChatMessage {chatMsgEvent}) = hasDeliveryReceipt (toCMEventTag chatMsgEvent) - forwardMsgs :: [AChatMessage] -> CM () - forwardMsgs aMsgs = do - -- TODO [knocking] forward to/from GSMemPendingReview members - let GroupMember {memberRole = membershipMemRole} = membership - when (membershipMemRole >= GRAdmin && not (blockedByAdmin m)) $ do - let forwardedMsgs = mapMaybe (\(ACMsg _ chatMsg) -> forwardedGroupMsg chatMsg) aMsgs - forM_ (L.nonEmpty forwardedMsgs) $ \forwardedMsgs' -> do - ChatConfig {highlyAvailable} <- asks config - -- members introduced to this invited member - introducedMembers <- - if memberCategory m == GCInviteeMember - then withStore' $ \db -> getForwardIntroducedMembers db vr user m highlyAvailable - else pure [] - -- invited members to which this member was introduced - invitedMembers <- withStore' $ \db -> getForwardInvitedMembers db vr user m highlyAvailable - let GroupMember {memberId} = m - ms = forwardedToGroupMembers (introducedMembers <> invitedMembers) forwardedMsgs' - events = L.map (\cm -> XGrpMsgForward memberId cm brokerTs) forwardedMsgs' - unless (null ms) $ void $ sendGroupMessages_ user gInfo ms events + -- TODO forwardMsgs member retrieval can be further optimized: + -- - move remaining filters to SQL (memberCurrentOrPending, memberCurrent) + -- - create new GroupForwardScope for reports to avoid post-filtering moderators in msgsForwardedToMember + -- 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 + ms <- buildMemberList + let GroupMember {memberId} = m + events = L.map (\cm -> XGrpMsgForward memberId cm brokerTs) fwdMsgs + unless (null ms) $ void $ sendGroupMessages_ user gInfo ms events + where + buildMemberList = case groupForwardScope of + GFSAll -> do + ms <- getAllIntroducedAndInvited + pure $ filter (\mem -> memberCurrentOrPending mem && msgsForwardedToMember fwdMsgs mem) ms + GFSMain -> do + ms <- getAllIntroducedAndInvited + pure $ filter (\mem -> memberCurrent mem && msgsForwardedToMember fwdMsgs mem) ms + GFSMemberSupport scopeGMId -> do + -- moderators introduced to this invited member + introducedModMs <- + if memberCategory m == GCInviteeMember + then withStore' $ \db -> getForwardIntroducedModerators db vr user m + else pure [] + -- invited moderators to which this member was introduced + invitedModMs <- withStore' $ \db -> getForwardInvitedModerators db vr user m + let modMs = introducedModMs <> invitedModMs + moderatorFilter mem = + memberCurrent mem + && maxVersion (memberChatVRange mem) >= groupKnockingVersion + && msgsForwardedToMember fwdMsgs mem + modMs' = filter moderatorFilter modMs + if scopeGMId == groupMemberId' m + then pure modMs' + else + withStore' (\db -> getForwardScopeMember db vr user m scopeGMId) >>= \case + Just scopeMem | msgsForwardedToMember fwdMsgs scopeMem -> pure $ scopeMem : modMs' + _ -> pure modMs' + where + getAllIntroducedAndInvited = do + ChatConfig {highlyAvailable} <- asks config + -- members introduced to this invited member + introducedMembers <- + if memberCategory m == GCInviteeMember + then withStore' $ \db -> getForwardIntroducedMembers db vr user m highlyAvailable + else pure [] + -- invited members to which this member was introduced + invitedMembers <- withStore' $ \db -> getForwardInvitedMembers db vr user m highlyAvailable + pure $ introducedMembers <> invitedMembers RCVD msgMeta msgRcpt -> withAckMessage' "group rcvd" agentConnId msgMeta $ groupMsgReceived gInfo m conn msgMeta msgRcpt @@ -1408,12 +1464,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 () -> CM () + memberCanSend :: GroupMember -> Maybe MsgScope -> CM (Maybe GroupForwardScope) -> CM (Maybe GroupForwardScope) 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" + | otherwise -> messageError "member is not allowed to send messages" $> Nothing processConnMERR :: ConnectionEntity -> Connection -> AgentErrorType -> CM () processConnMERR connEntity conn err = do @@ -1641,18 +1697,34 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = when (sz > fileSize) $ receiveFileEvt' user ft False Nothing Nothing >>= toView messageFileDescription :: Contact -> SharedMsgId -> FileDescr -> CM () - messageFileDescription ct@Contact {contactId} sharedMsgId fileDescr = do - fileId <- withStore $ \db -> getFileIdBySharedMsgId db userId contactId sharedMsgId - processFDMessage (CDDirectRcv ct) sharedMsgId fileId fileDescr + messageFileDescription Contact {contactId} sharedMsgId fileDescr = do + (fileId, aci) <- withStore $ \db -> do + fileId <- getFileIdBySharedMsgId db userId contactId sharedMsgId + aci <- getChatItemByFileId db vr user fileId + pure (fileId, aci) + processFDMessage fileId aci fileDescr - groupMessageFileDescription :: GroupInfo -> GroupMember -> SharedMsgId -> FileDescr -> CM () - groupMessageFileDescription g@GroupInfo {groupId} m sharedMsgId fileDescr = do - fileId <- withStore $ \db -> getGroupFileIdBySharedMsgId db userId groupId sharedMsgId - -- here scope we pass only affects how chat item is searched in getAChatItemBySharedMsgId, and it ignores scope - processFDMessage (CDGroupRcv g Nothing m) sharedMsgId fileId fileDescr + groupMessageFileDescription :: GroupInfo -> GroupMember -> SharedMsgId -> FileDescr -> CM (Maybe GroupForwardScope) + groupMessageFileDescription g@GroupInfo {groupId} GroupMember {memberId} sharedMsgId fileDescr = do + (fileId, aci) <- withStore $ \db -> do + fileId <- getGroupFileIdBySharedMsgId db userId groupId sharedMsgId + aci <- getChatItemByFileId db vr user fileId + pure (fileId, aci) + case aci of + AChatItem SCTGroup SMDRcv (GroupChat _g scopeInfo) ChatItem {chatDir = CIGroupRcv m} -> + if sameMemberId memberId m + then do + -- in processFDMessage some paths are programmed as errors, + -- for example failure on not approved relays (CEFileNotApproved). + -- we catch error, so that even if processFDMessage fails, message can still be forwarded. + processFDMessage fileId aci fileDescr `catchChatError` \_ -> pure () + pure $ Just $ toGroupForwardScope g scopeInfo + else + messageError "x.msg.file.descr: file of another member" $> Nothing + _ -> messageError "x.msg.file.descr: invalid file description part" $> Nothing - processFDMessage :: ChatTypeQuotable c => ChatDirection c 'MDRcv -> SharedMsgId -> FileTransferId -> FileDescr -> CM () - processFDMessage cd sharedMsgId fileId fileDescr = do + processFDMessage :: FileTransferId -> AChatItem -> FileDescr -> CM () + processFDMessage fileId aci fileDescr = do ft <- withStore $ \db -> getRcvFileTransfer db user fileId unless (rcvFileCompleteOrCancelled ft) $ do (rfd@RcvFileDescr {fileDescrComplete}, ft'@RcvFileTransfer {fileStatus, xftpRcvFile, cryptoArgs}) <- withStore $ \db -> do @@ -1661,9 +1733,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = -- to prevent race condition with accept ft' <- getRcvFileTransfer db user fileId pure (rfd, ft') - when fileDescrComplete $ do - ci <- withStore $ \db -> getAChatItemBySharedMsgId db user cd sharedMsgId - toView $ CEvtRcvFileDescrReady user ci ft' rfd + when fileDescrComplete $ toView $ CEvtRcvFileDescrReady user aci ft' rfd case (fileStatus, xftpRcvFile) of (RFSAccepted _, Just XFTPRcvFile {userApprovedRelays}) -> receiveViaCompleteFD user fileId rfd userApprovedRelays cryptoArgs _ -> pure () @@ -1769,27 +1839,40 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = else pure Nothing mapM_ toView cEvt_ - groupMsgReaction :: GroupInfo -> GroupMember -> SharedMsgId -> MemberId -> MsgReaction -> Bool -> RcvMessage -> UTCTime -> CM () - groupMsgReaction g m sharedMsgId itemMemberId reaction add RcvMessage {msgId} brokerTs = do - when (groupFeatureAllowed SGFReactions g) $ do - rs <- withStore' $ \db -> getGroupReactions db g m itemMemberId sharedMsgId False - when (reactionAllowed add reaction rs) $ do - updateChatItemReaction `catchCINotFound` \_ -> - withStore' $ \db -> setGroupReaction db g m itemMemberId sharedMsgId False reaction add msgId brokerTs + groupMsgReaction :: GroupInfo -> GroupMember -> SharedMsgId -> MemberId -> Maybe MsgScope -> MsgReaction -> Bool -> RcvMessage -> UTCTime -> CM (Maybe GroupForwardScope) + groupMsgReaction g m@GroupMember {memberRole} sharedMsgId itemMemberId scope_ reaction add RcvMessage {msgId} brokerTs + | groupFeatureAllowed SGFReactions g = do + rs <- withStore' $ \db -> getGroupReactions db g m itemMemberId sharedMsgId False + if reactionAllowed add reaction rs + then + updateChatItemReaction `catchCINotFound` \_ -> case scope_ of + Just (MSMember scopeMemberId) + | memberRole >= GRModerator || scopeMemberId == memberId' m -> + withStore $ \db -> do + liftIO $ setGroupReaction db g m itemMemberId sharedMsgId False reaction add msgId brokerTs + Just . GFSMemberSupport <$> getScopeMemberIdViaMemberId db user g m scopeMemberId + | otherwise -> pure Nothing + Nothing -> do + withStore' $ \db -> setGroupReaction db g m itemMemberId sharedMsgId False reaction add msgId brokerTs + pure $ Just GFSMain + else pure Nothing + | otherwise = pure Nothing where updateChatItemReaction = do - cEvt_ <- withStore $ \db -> do - CChatItem md ci <- getGroupMemberCIBySharedMsgId db user g itemMemberId sharedMsgId - scopeInfo <- getGroupChatScopeInfoForItem db vr user g (chatItemId' ci) - if ciReactionAllowed ci - then liftIO $ do + (CChatItem md ci, scopeInfo) <- withStore $ \db -> do + cci <- getGroupMemberCIBySharedMsgId db user g itemMemberId sharedMsgId + scopeInfo <- getGroupChatScopeInfoForItem db vr user g (cChatItemId cci) + pure (cci, scopeInfo) + if ciReactionAllowed ci + then do + reactions <- withStore' $ \db -> do setGroupReaction db g m itemMemberId sharedMsgId False reaction add msgId brokerTs - reactions <- getGroupCIReactions db g itemMemberId sharedMsgId - let ci' = CChatItem md ci {reactions} - r = ACIReaction SCTGroup SMDRcv (GroupChat g scopeInfo) $ CIReaction (CIGroupRcv m) ci' brokerTs reaction - pure $ Just $ CEvtChatItemReaction user add r - else pure Nothing - mapM_ toView cEvt_ + getGroupCIReactions db g itemMemberId sharedMsgId + let ci' = CChatItem md ci {reactions} + r = ACIReaction SCTGroup SMDRcv (GroupChat g scopeInfo) $ CIReaction (CIGroupRcv m) ci' brokerTs reaction + toView $ CEvtChatItemReaction user add r + pure $ Just $ toGroupForwardScope g scopeInfo + else pure Nothing reactionAllowed :: Bool -> MsgReaction -> [MsgReaction] -> Bool reactionAllowed add reaction rs = (reaction `elem` rs) /= add && not (add && length rs >= maxMsgReactions) @@ -1800,20 +1883,23 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = ChatErrorStore (SEChatItemSharedMsgIdNotFound sharedMsgId) -> handle sharedMsgId e -> throwError e - newGroupContentMessage :: GroupInfo -> GroupMember -> MsgContainer -> RcvMessage -> UTCTime -> Bool -> CM () + newGroupContentMessage :: GroupInfo -> GroupMember -> MsgContainer -> RcvMessage -> UTCTime -> Bool -> CM (Maybe GroupForwardScope) newGroupContentMessage gInfo m@GroupMember {memberId, memberRole} mc msg@RcvMessage {sharedMsgId_} brokerTs forwarded = do (gInfo', m', scopeInfo) <- mkGetMessageChatScope vr user gInfo m msgScope_ if blockedByAdmin m' - then createBlockedByAdmin gInfo' m' scopeInfo + then createBlockedByAdmin gInfo' m' scopeInfo $> Nothing else case prohibitedGroupContent gInfo' m' scopeInfo content ft_ fInv_ False of - Just f -> rejected gInfo' m' scopeInfo f + Just f -> rejected gInfo' m' scopeInfo f $> Nothing Nothing -> withStore' (\db -> getCIModeration db vr user gInfo' memberId sharedMsgId_) >>= \case Just ciModeration -> do applyModeration gInfo' m' scopeInfo ciModeration withStore' $ \db -> deleteCIModeration db gInfo' memberId sharedMsgId_ - Nothing -> createContentItem gInfo' m' scopeInfo + pure Nothing + Nothing -> do + createContentItem gInfo' m' scopeInfo + pure $ Just $ toGroupForwardScope gInfo scopeInfo where rejected gInfo' m' scopeInfo f = newChatItem gInfo' m' scopeInfo (ciContentNoParse $ CIRcvGroupFeatureRejected f) Nothing Nothing False timed' gInfo' = if forwarded then rcvCITimed_ (Just Nothing) itemTTL else rcvGroupCITimed gInfo' itemTTL @@ -1859,10 +1945,10 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = reactions <- maybe (pure []) (\sharedMsgId -> withStore' $ \db -> getGroupCIReactions db gInfo' memberId sharedMsgId) sharedMsgId_ groupMsgToView cInfo ci' {reactions} - groupMessageUpdate :: GroupInfo -> GroupMember -> SharedMsgId -> MsgContent -> Map MemberName MsgMention -> Maybe MsgScope -> RcvMessage -> UTCTime -> Maybe Int -> Maybe Bool -> CM () + groupMessageUpdate :: GroupInfo -> GroupMember -> SharedMsgId -> MsgContent -> Map MemberName MsgMention -> Maybe MsgScope -> RcvMessage -> UTCTime -> Maybe Int -> Maybe Bool -> CM (Maybe GroupForwardScope) groupMessageUpdate gInfo@GroupInfo {groupId} m@GroupMember {groupMemberId, memberId} sharedMsgId mc mentions msgScope_ msg@RcvMessage {msgId} brokerTs ttl_ live_ | prohibitedSimplexLinks gInfo m ft_ = - messageWarning $ "x.msg.update ignored: feature not allowed " <> groupFeatureNameText GFSimplexLinks + messageWarning ("x.msg.update ignored: feature not allowed " <> groupFeatureNameText GFSimplexLinks) $> Nothing | otherwise = do updateRcvChatItem `catchCINotFound` \_ -> do -- This patches initial sharedMsgId into chat item when locally deleted chat item @@ -1877,6 +1963,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = ci' <- updateGroupChatItem db user groupId ci content True live Nothing blockedMember m' ci' $ markGroupChatItemBlocked db user gInfo' ci' toView $ CEvtChatItemUpdated user (AChatItem SCTGroup SMDRcv cInfo ci') + pure $ Just $ toGroupForwardScope gInfo scopeInfo where content = CIRcvMsgContent mc ts@(_, ft_) = msgContentTexts mc @@ -1901,12 +1988,15 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = updateGroupCIMentions db gInfo ci' ciMentions toView $ CEvtChatItemUpdated user (AChatItem SCTGroup SMDRcv (GroupChat gInfo scopeInfo) ci') startUpdatedTimedItemThread user (ChatRef CTGroup groupId $ toChatScope <$> scopeInfo) ci ci' - else toView $ CEvtChatItemNotChanged user (AChatItem SCTGroup SMDRcv (GroupChat gInfo scopeInfo) ci) - else messageError "x.msg.update: group member attempted to update a message of another member" - _ -> messageError "x.msg.update: group member attempted invalid message update" + pure $ Just $ toGroupForwardScope gInfo scopeInfo + else do + toView $ CEvtChatItemNotChanged user (AChatItem SCTGroup SMDRcv (GroupChat gInfo scopeInfo) ci) + pure Nothing + else messageError "x.msg.update: group member attempted to update a message of another member" $> Nothing + _ -> messageError "x.msg.update: group member attempted invalid message update" $> Nothing - groupMessageDelete :: GroupInfo -> GroupMember -> SharedMsgId -> Maybe MemberId -> RcvMessage -> UTCTime -> CM () - groupMessageDelete gInfo@GroupInfo {membership} m@GroupMember {memberId, memberRole = senderRole} sharedMsgId sndMemberId_ RcvMessage {msgId} brokerTs = do + groupMessageDelete :: GroupInfo -> GroupMember -> SharedMsgId -> Maybe MemberId -> Maybe MsgScope -> RcvMessage -> UTCTime -> CM (Maybe GroupForwardScope) + groupMessageDelete gInfo@GroupInfo {membership} m@GroupMember {memberId, memberRole = senderRole} sharedMsgId sndMemberId_ scope_ RcvMessage {msgId} brokerTs = do let msgMemberId = fromMaybe memberId sndMemberId_ withStore' (\db -> runExceptT $ getGroupMemberCIBySharedMsgId db user gInfo msgMemberId sharedMsgId) >>= \case Right cci@(CChatItem _ ci@ChatItem {chatDir}) -> case chatDir of @@ -1914,40 +2004,52 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = -- regular deletion Nothing | sameMemberId memberId mem && msgMemberId == memberId && rcvItemDeletable ci brokerTs -> - delete cci Nothing + Just <$> delete cci Nothing | otherwise -> - messageError "x.msg.del: member attempted invalid message delete" + messageError "x.msg.del: member attempted invalid message delete" $> Nothing -- moderation (not limited by time) Just _ | sameMemberId memberId mem && msgMemberId == memberId -> - delete cci (Just m) + Just <$> delete cci (Just m) | otherwise -> moderate mem cci CIGroupSnd -> moderate membership cci Left e - | msgMemberId == memberId -> messageError $ "x.msg.del: message not found, " <> tshow e - | senderRole < GRModerator -> messageError $ "x.msg.del: message not found, message of another member with insufficient member permissions, " <> tshow e - | otherwise -> withStore' $ \db -> createCIModeration db gInfo m msgMemberId sharedMsgId msgId brokerTs + | msgMemberId == memberId -> + messageError ("x.msg.del: message not found, " <> tshow e) $> Nothing + | senderRole < GRModerator -> do + messageError $ "x.msg.del: message not found, message of another member with insufficient member permissions, " <> tshow e + pure Nothing + | otherwise -> case scope_ of + Just (MSMember scopeMemberId) -> + withStore $ \db -> do + liftIO $ createCIModeration db gInfo m msgMemberId sharedMsgId msgId brokerTs + Just . GFSMemberSupport <$> getScopeMemberIdViaMemberId db user gInfo m scopeMemberId + Nothing -> do + withStore' $ \db -> createCIModeration db gInfo m msgMemberId sharedMsgId msgId brokerTs + pure $ Just GFSMain where - moderate :: GroupMember -> CChatItem 'CTGroup -> CM () + moderate :: GroupMember -> CChatItem 'CTGroup -> CM (Maybe GroupForwardScope) moderate mem cci = case sndMemberId_ of Just sndMemberId | sameMemberId sndMemberId mem -> checkRole mem $ do - delete cci (Just m) + groupForwardScope <- delete cci (Just m) archiveMessageReports cci m - | otherwise -> messageError "x.msg.del: message of another member with incorrect memberId" - _ -> messageError "x.msg.del: message of another member without memberId" + pure $ Just groupForwardScope + | otherwise -> messageError "x.msg.del: message of another member with incorrect memberId" $> Nothing + _ -> messageError "x.msg.del: message of another member without memberId" $> Nothing checkRole GroupMember {memberRole} a | senderRole < GRModerator || senderRole < memberRole = - messageError "x.msg.del: message of another member with insufficient member permissions" + messageError "x.msg.del: message of another member with insufficient member permissions" $> Nothing | otherwise = a - delete :: CChatItem 'CTGroup -> Maybe GroupMember -> CM () + delete :: CChatItem 'CTGroup -> Maybe GroupMember -> CM GroupForwardScope delete cci byGroupMember = do scopeInfo <- withStore $ \db -> getGroupChatScopeInfoForItem db vr user gInfo (cChatItemId cci) deletions <- if groupFeatureMemberAllowed SGFFullDelete m gInfo then deleteGroupCIs user gInfo scopeInfo [cci] byGroupMember brokerTs else markGroupCIsDeleted user gInfo scopeInfo [cci] byGroupMember brokerTs toView $ CEvtChatItemsDeleted user deletions False False + pure $ toGroupForwardScope gInfo scopeInfo archiveMessageReports :: CChatItem 'CTGroup -> GroupMember -> CM () archiveMessageReports (CChatItem _ ci) byMember = do ciIds <- withStore' $ \db -> markMessageReportsDeleted db user gInfo ci byMember brokerTs @@ -2084,21 +2186,25 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = _ -> pure () receiveFileChunk ft Nothing meta chunk - xFileCancelGroup :: GroupInfo -> GroupMember -> SharedMsgId -> CM () - xFileCancelGroup g@GroupInfo {groupId} GroupMember {groupMemberId, memberId} sharedMsgId = do - fileId <- withStore $ \db -> getGroupFileIdBySharedMsgId db userId groupId sharedMsgId - CChatItem msgDir ChatItem {chatDir} <- withStore $ \db -> getGroupChatItemBySharedMsgId db user g groupMemberId sharedMsgId - case (msgDir, chatDir) of - (SMDRcv, CIGroupRcv m) -> do + xFileCancelGroup :: GroupInfo -> GroupMember -> SharedMsgId -> CM (Maybe GroupForwardScope) + xFileCancelGroup g@GroupInfo {groupId} GroupMember {memberId} sharedMsgId = do + (fileId, aci) <- withStore $ \db -> do + fileId <- getGroupFileIdBySharedMsgId db userId groupId sharedMsgId + aci <- getChatItemByFileId db vr user fileId + pure (fileId, aci) + case aci of + AChatItem SCTGroup SMDRcv (GroupChat _g scopeInfo) ChatItem {chatDir = CIGroupRcv m} -> do if sameMemberId memberId m then do - ft <- withStore (\db -> getRcvFileTransfer db user fileId) + ft <- withStore $ \db -> getRcvFileTransfer db user fileId unless (rcvFileCompleteOrCancelled ft) $ do cancelRcvFileTransfer user ft >>= mapM_ deleteAgentConnectionAsync - ci <- withStore $ \db -> getChatItemByFileId db vr user fileId - toView $ CEvtRcvFileSndCancelled user ci ft - else messageError "x.file.cancel: group member attempted to cancel file of another member" -- shouldn't happen now that query includes group member id - (SMDSnd, _) -> messageError "x.file.cancel: group member attempted invalid file cancel" + toView $ CEvtRcvFileSndCancelled user aci ft + pure $ Just $ toGroupForwardScope g scopeInfo + else + -- shouldn't happen now that query includes group member id + messageError "x.file.cancel: group member attempted to cancel file of another member" $> Nothing + _ -> messageError "x.file.cancel: group member attempted invalid file cancel" $> Nothing xFileAcptInvGroup :: GroupInfo -> GroupMember -> SharedMsgId -> Maybe ConnReqInvitation -> String -> CM () xFileAcptInvGroup GroupInfo {groupId} m@GroupMember {activeConn} sharedMsgId fileConnReq_ fName = do @@ -2236,8 +2342,10 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = Profile {displayName = n, fullName = fn, shortDescr = sd, image = i, contactLink = cl} = p Profile {displayName = n', fullName = fn', shortDescr = sd', image = i', contactLink = cl'} = p' - xInfoMember :: GroupInfo -> GroupMember -> Profile -> UTCTime -> CM () - xInfoMember gInfo m p' brokerTs = void $ processMemberProfileUpdate gInfo m p' True (Just brokerTs) + xInfoMember :: GroupInfo -> GroupMember -> Profile -> UTCTime -> CM (Maybe GroupForwardScope) + xInfoMember gInfo m p' brokerTs = do + void $ processMemberProfileUpdate gInfo m p' True (Just brokerTs) + pure $ memberEventForwardScope m xGrpLinkMem :: GroupInfo -> GroupMember -> Connection -> Profile -> CM () xGrpLinkMem gInfo@GroupInfo {membership, businessChat} m@GroupMember {groupMemberId, memberCategory} Connection {viaGroupLink} p' = do @@ -2615,33 +2723,41 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = -- TODO show/log error, other events in SMP confirmation _ -> pure (conn', False) - xGrpMemNew :: GroupInfo -> GroupMember -> MemberInfo -> Maybe MsgScope -> RcvMessage -> UTCTime -> CM () + xGrpMemNew :: GroupInfo -> GroupMember -> MemberInfo -> Maybe MsgScope -> RcvMessage -> UTCTime -> CM (Maybe GroupForwardScope) xGrpMemNew gInfo m memInfo@(MemberInfo memId memRole _ _) msgScope_ msg brokerTs = do checkHostRole m memRole - unless (sameMemberId memId $ membership gInfo) $ - withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId) >>= \case - Right unknownMember@GroupMember {memberStatus = GSMemUnknown} -> do - (updatedMember, gInfo') <- withStore $ \db -> do - updatedMember <- updateUnknownMemberAnnounced db vr user m unknownMember memInfo initialStatus - gInfo' <- if memberPending updatedMember - then liftIO $ increaseGroupMembersRequireAttention db user gInfo - else pure gInfo - pure (updatedMember, gInfo') - toView $ CEvtUnknownMemberAnnounced user gInfo' m unknownMember updatedMember - memberAnnouncedToView updatedMember gInfo' - Right _ -> messageError "x.grp.mem.new error: member already exists" - Left _ -> do - (newMember, gInfo') <- withStore $ \db -> do - newMember <- createNewGroupMember db user gInfo m memInfo GCPostMember initialStatus - gInfo' <- if memberPending newMember - then liftIO $ increaseGroupMembersRequireAttention db user gInfo - else pure gInfo - pure (newMember, gInfo') - memberAnnouncedToView newMember gInfo' + if sameMemberId memId (membership gInfo) + then pure Nothing + else do + withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId) >>= \case + Right unknownMember@GroupMember {memberStatus = GSMemUnknown} -> do + (updatedMember, gInfo') <- withStore $ \db -> do + updatedMember <- updateUnknownMemberAnnounced db vr user m unknownMember memInfo initialStatus + gInfo' <- if memberPending updatedMember + then liftIO $ increaseGroupMembersRequireAttention db user gInfo + else pure gInfo + pure (updatedMember, gInfo') + toView $ CEvtUnknownMemberAnnounced user gInfo' m unknownMember updatedMember + memberAnnouncedToView updatedMember gInfo' + pure $ forwardScope updatedMember + Right _ -> messageError "x.grp.mem.new error: member already exists" $> Nothing + Left _ -> do + (newMember, gInfo') <- withStore $ \db -> do + newMember <- createNewGroupMember db user gInfo m memInfo GCPostMember initialStatus + gInfo' <- if memberPending newMember + then liftIO $ increaseGroupMembersRequireAttention db user gInfo + else pure gInfo + pure (newMember, gInfo') + memberAnnouncedToView newMember gInfo' + pure $ forwardScope newMember where initialStatus = case msgScope_ of Just (MSMember _) -> GSMemPendingReview _ -> GSMemAnnounced + forwardScope GroupMember {groupMemberId, memberStatus} + | memberStatus == GSMemPendingApproval = Nothing + | memberStatus == GSMemPendingReview = Just $ GFSMemberSupport groupMemberId + | otherwise = Just GFSMain memberAnnouncedToView announcedMember@GroupMember {groupMemberId, memberProfile} gInfo' = do (announcedMember', scopeInfo) <- getMemNewChatScope announcedMember let event = RGEMemberAdded groupMemberId (fromLocalProfile memberProfile) @@ -2729,7 +2845,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = chatV = vr `peerConnChatVersion` mcvr withStore' $ \db -> createIntroToMemberContact db user m toMember chatV mcvr groupConnIds directConnIds customUserProfileId subMode - xGrpMemRole :: GroupInfo -> GroupMember -> MemberId -> GroupMemberRole -> RcvMessage -> UTCTime -> CM () + xGrpMemRole :: GroupInfo -> GroupMember -> MemberId -> GroupMemberRole -> RcvMessage -> UTCTime -> CM (Maybe GroupForwardScope) xGrpMemRole gInfo@GroupInfo {membership} m@GroupMember {memberRole = senderRole} memId memRole msg brokerTs | membershipMemId == memId = let gInfo' = gInfo {membership = membership {memberRole = memRole}} @@ -2737,23 +2853,25 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = | otherwise = withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId) >>= \case Right member -> changeMemberRole gInfo member $ RGEMemberRole (groupMemberId' member) (fromLocalProfile $ memberProfile member) memRole - Left _ -> messageError "x.grp.mem.role with unknown member ID" + Left _ -> messageError "x.grp.mem.role with unknown member ID" $> Nothing where GroupMember {memberId = membershipMemId} = membership changeMemberRole gInfo' member@GroupMember {memberRole = fromRole} gEvent - | senderRole < GRAdmin || senderRole < fromRole = messageError "x.grp.mem.role with insufficient member permissions" + | senderRole < GRAdmin || senderRole < fromRole = + messageError "x.grp.mem.role with insufficient member permissions" $> Nothing | otherwise = do withStore' $ \db -> updateGroupMemberRole db user member memRole (gInfo'', m', scopeInfo) <- mkGroupChatScope gInfo' m (ci, cInfo) <- saveRcvChatItemNoParse user (CDGroupRcv gInfo'' scopeInfo m') msg brokerTs (CIRcvGroupEvent gEvent) groupMsgToView cInfo ci toView CEvtMemberRole {user, groupInfo = gInfo'', byMember = m', member = member {memberRole = memRole}, fromRole, toRole = memRole} + pure $ memberEventForwardScope member checkHostRole :: GroupMember -> GroupMemberRole -> CM () checkHostRole GroupMember {memberRole, localDisplayName} memRole = when (memberRole < GRAdmin || memberRole < memRole) $ throwChatError (CEGroupContactRole localDisplayName) - xGrpMemRestrict :: GroupInfo -> GroupMember -> MemberId -> MemberRestrictions -> RcvMessage -> UTCTime -> CM () + xGrpMemRestrict :: GroupInfo -> GroupMember -> MemberId -> MemberRestrictions -> RcvMessage -> UTCTime -> CM (Maybe GroupForwardScope) xGrpMemRestrict gInfo@GroupInfo {membership = GroupMember {memberId = membershipMemId}} m@GroupMember {memberRole = senderRole} @@ -2763,12 +2881,13 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = brokerTs | membershipMemId == memId = -- member shouldn't receive this message about themselves - messageError "x.grp.mem.restrict: admin blocks you" + messageError "x.grp.mem.restrict: admin blocks you" $> Nothing | otherwise = withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId) >>= \case Right bm@GroupMember {groupMemberId = bmId, memberRole, blockedByAdmin, memberProfile = bmp} - | blockedByAdmin == mrsBlocked restriction -> pure () - | senderRole < GRModerator || senderRole < memberRole -> messageError "x.grp.mem.restrict with insufficient member permissions" + | blockedByAdmin == mrsBlocked restriction -> pure Nothing + | senderRole < GRModerator || senderRole < memberRole -> + messageError "x.grp.mem.restrict with insufficient member permissions" $> Nothing | otherwise -> do bm' <- setMemberBlocked bm toggleNtf bm' (not blocked) @@ -2776,11 +2895,13 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = (gInfo', m', scopeInfo) <- mkGroupChatScope gInfo m (ci, cInfo) <- saveRcvChatItemNoParse user (CDGroupRcv gInfo' scopeInfo m') msg brokerTs ciContent groupMsgToView cInfo ci - toView CEvtMemberBlockedForAll {user, groupInfo = gInfo', byMember = m', member = bm, blocked} + toView CEvtMemberBlockedForAll {user, groupInfo = gInfo', byMember = m', member = bm', blocked} + pure $ memberEventForwardScope bm Left (SEGroupMemberNotFoundByMemberId _) -> do bm <- createUnknownMember gInfo memId bm' <- setMemberBlocked bm toView $ CEvtUnknownMemberBlocked user gInfo m bm' + pure $ Just GFSMain Left e -> throwError $ ChatErrorStore e where setMemberBlocked bm = withStore' $ \db -> updateGroupMemberBlocked db user gInfo restriction bm @@ -2827,7 +2948,7 @@ 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 () + xGrpMemDel :: GroupInfo -> GroupMember -> MemberId -> Bool -> RcvMessage -> UTCTime -> CM (Maybe GroupForwardScope) xGrpMemDel gInfo@GroupInfo {membership} m@GroupMember {memberRole = senderRole} memId withMessages msg brokerTs = do let GroupMember {memberId = membershipMemId} = membership if membershipMemId == memId @@ -2840,9 +2961,10 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = when withMessages $ deleteMessages 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) else withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId) >>= \case - Left _ -> messageError "x.grp.mem.del with unknown member ID" + Left _ -> messageError "x.grp.mem.del with unknown member ID" $> Just GFSAll Right member@GroupMember {groupMemberId, memberProfile} -> checkRole member $ do -- ? prohibit deleting member if it's the sender - sender should use x.grp.leave @@ -2852,10 +2974,11 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = when withMessages $ deleteMessages member SMDRcv deleteMemberItem $ RGEMemberDeleted groupMemberId (fromLocalProfile memberProfile) toView $ CEvtDeletedMember user gInfo' m member {memberStatus = GSMemRemoved} withMessages + pure $ memberEventForwardScope member where checkRole GroupMember {memberRole} a | senderRole < GRAdmin || senderRole < memberRole = - messageError "x.grp.mem.del with insufficient member permissions" + messageError "x.grp.mem.del with insufficient member permissions" $> Nothing | otherwise = a deleteMemberItem gEvent = do (gInfo', m', scopeInfo) <- mkGroupChatScope gInfo m @@ -2866,7 +2989,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = | groupFeatureMemberAllowed SGFFullDelete m gInfo = deleteGroupMemberCIs user gInfo delMem m msgDir | otherwise = markGroupMemberCIsDeleted user gInfo delMem m - xGrpLeave :: GroupInfo -> GroupMember -> RcvMessage -> UTCTime -> CM () + xGrpLeave :: GroupInfo -> GroupMember -> RcvMessage -> UTCTime -> CM (Maybe GroupForwardScope) xGrpLeave gInfo m msg brokerTs = do deleteMemberConnection m -- member record is not deleted to allow creation of "member left" chat item @@ -2879,8 +3002,9 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = (ci, cInfo) <- saveRcvChatItemNoParse user (CDGroupRcv gInfo'' scopeInfo m') msg brokerTs (CIRcvGroupEvent RGEMemberLeft) groupMsgToView cInfo ci toView $ CEvtLeftMember user gInfo'' m' {memberStatus = GSMemLeft} + pure $ memberEventForwardScope m - xGrpDel :: GroupInfo -> GroupMember -> RcvMessage -> UTCTime -> CM () + xGrpDel :: GroupInfo -> GroupMember -> RcvMessage -> UTCTime -> CM GroupForwardScope xGrpDel gInfo@GroupInfo {membership} m@GroupMember {memberRole} msg brokerTs = do when (memberRole /= GROwner) $ throwChatError $ CEGroupUserRole gInfo GROwner ms <- withStore' $ \db -> do @@ -2893,26 +3017,29 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = (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 () + xGrpInfo :: GroupInfo -> GroupMember -> GroupProfile -> RcvMessage -> UTCTime -> CM (Maybe GroupForwardScope) xGrpInfo g@GroupInfo {groupProfile = p, businessChat} m@GroupMember {memberRole} p' msg brokerTs - | memberRole < GROwner = messageError "x.grp.info with insufficient member permissions" - | otherwise = case businessChat of - Nothing -> unless (p == p') $ do - g' <- withStore $ \db -> updateGroupProfile db user g p' - (g'', m', scopeInfo) <- mkGroupChatScope g' m - toView $ CEvtGroupUpdated user g g'' (Just m') - let cd = CDGroupRcv g'' scopeInfo m' - unless (sameGroupProfileInfo p p') $ do - (ci, cInfo) <- saveRcvChatItemNoParse user cd msg brokerTs (CIRcvGroupEvent $ RGEGroupUpdated p') - groupMsgToView cInfo ci - createGroupFeatureChangedItems user cd CIRcvGroupFeature g g'' - Just _ -> updateGroupPrefs_ g m $ fromMaybe defaultBusinessGroupPrefs $ groupPreferences p' + | memberRole < GROwner = messageError "x.grp.info with insufficient member permissions" $> Nothing + | otherwise = do + case businessChat of + Nothing -> unless (p == p') $ do + g' <- withStore $ \db -> updateGroupProfile db user g p' + (g'', m', scopeInfo) <- mkGroupChatScope g' m + toView $ CEvtGroupUpdated user g g'' (Just m') + let cd = CDGroupRcv g'' scopeInfo m' + unless (sameGroupProfileInfo p p') $ do + (ci, cInfo) <- saveRcvChatItemNoParse user cd msg brokerTs (CIRcvGroupEvent $ RGEGroupUpdated p') + groupMsgToView cInfo ci + createGroupFeatureChangedItems user cd CIRcvGroupFeature g g'' + Just _ -> updateGroupPrefs_ g m $ fromMaybe defaultBusinessGroupPrefs $ groupPreferences p' + pure $ Just GFSAll - xGrpPrefs :: GroupInfo -> GroupMember -> GroupPreferences -> CM () + xGrpPrefs :: GroupInfo -> GroupMember -> GroupPreferences -> CM (Maybe GroupForwardScope) xGrpPrefs g m@GroupMember {memberRole} ps' - | memberRole < GROwner = messageError "x.grp.prefs with insufficient member permissions" - | otherwise = updateGroupPrefs_ g m ps' + | memberRole < GROwner = messageError "x.grp.prefs with insufficient member permissions" $> Nothing + | otherwise = updateGroupPrefs_ g m ps' $> Just GFSAll updateGroupPrefs_ :: GroupInfo -> GroupMember -> GroupPreferences -> CM () updateGroupPrefs_ g@GroupInfo {groupProfile = p} m ps' = @@ -2984,28 +3111,28 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = processForwardedMsg unknownAuthor msg Left e -> throwError $ ChatErrorStore e where - -- Note: forwarded group events (see forwardedGroupMsg) should include msgId to be deduplicated + -- ! see isForwardedGroupMsg: forwarded group events should include msgId to be deduplicated processForwardedMsg :: GroupMember -> ChatMessage 'Json -> CM () processForwardedMsg author chatMsg = do let body = LB.toStrict $ J.encode msg rcvMsg@RcvMessage {chatMsgEvent = ACME _ event} <- saveGroupFwdRcvMsg user groupId m author body chatMsg case event of - XMsgNew mc -> memberCanSend author scope $ newGroupContentMessage gInfo author mc rcvMsg msgTs True + XMsgNew mc -> void $ memberCanSend author scope $ 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 -> groupMessageFileDescription gInfo author sharedMsgId fileDescr - XMsgUpdate sharedMsgId mContent mentions ttl live msgScope -> memberCanSend author msgScope $ groupMessageUpdate gInfo author sharedMsgId mContent mentions msgScope rcvMsg msgTs ttl live - XMsgDel sharedMsgId memId -> groupMessageDelete gInfo author sharedMsgId memId rcvMsg msgTs - XMsgReact sharedMsgId (Just memId) reaction add -> groupMsgReaction gInfo author sharedMsgId memId reaction add rcvMsg msgTs - XFileCancel sharedMsgId -> xFileCancelGroup gInfo author sharedMsgId - XInfo p -> xInfoMember gInfo author p msgTs - XGrpMemNew memInfo msgScope -> xGrpMemNew gInfo author memInfo msgScope rcvMsg msgTs - XGrpMemRole memId memRole -> xGrpMemRole gInfo author memId memRole 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 - XGrpPrefs ps' -> xGrpPrefs gInfo author ps' + 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 + 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 + XGrpLeave -> void $ xGrpLeave gInfo author rcvMsg msgTs + XGrpDel -> void $ xGrpDel gInfo author rcvMsg msgTs + XGrpInfo p' -> void $ xGrpInfo gInfo author p' rcvMsg msgTs + XGrpPrefs ps' -> void $ xGrpPrefs gInfo author ps' _ -> messageError $ "x.grp.msg.forward: unsupported forwarded event " <> T.pack (show $ toCMEventTag event) createUnknownMember :: GroupInfo -> MemberId -> CM GroupMember diff --git a/src/Simplex/Chat/Messages.hs b/src/Simplex/Chat/Messages.hs index c4442a5e8e..24a2d11dc8 100644 --- a/src/Simplex/Chat/Messages.hs +++ b/src/Simplex/Chat/Messages.hs @@ -128,6 +128,24 @@ toMsgScope :: GroupInfo -> GroupChatScopeInfo -> MsgScope toMsgScope GroupInfo {membership} = \case GCSIMemberSupport {groupMember_} -> MSMember $ memberId' $ fromMaybe membership groupMember_ +data GroupForwardScope + = GFSAll -- message should be forwarded to all group members, even pending (e.g. XGrpDel, XGrpInfo) + | GFSMain -- message should be forwarded to current group members only (e.g. regular messages in group) + | GFSMemberSupport GroupMemberId + deriving (Eq, Ord, Show) + +toGroupForwardScope :: GroupInfo -> Maybe GroupChatScopeInfo -> GroupForwardScope +toGroupForwardScope GroupInfo {membership} = \case + Nothing -> GFSMain + Just GCSIMemberSupport {groupMember_} -> GFSMemberSupport $ groupMemberId' $ fromMaybe membership groupMember_ + +memberEventForwardScope :: GroupMember -> Maybe GroupForwardScope +memberEventForwardScope m@GroupMember {memberRole, memberStatus} + | memberStatus == GSMemPendingApproval = Nothing + | memberStatus == GSMemPendingReview = Just $ GFSMemberSupport $ groupMemberId' m + | memberRole >= GRModerator = Just GFSAll + | otherwise = Just GFSMain + chatInfoToRef :: ChatInfo c -> ChatRef chatInfoToRef = \case DirectChat Contact {contactId} -> ChatRef CTDirect contactId Nothing diff --git a/src/Simplex/Chat/Protocol.hs b/src/Simplex/Chat/Protocol.hs index 1fad623967..84d5cc8c3d 100644 --- a/src/Simplex/Chat/Protocol.hs +++ b/src/Simplex/Chat/Protocol.hs @@ -317,9 +317,9 @@ data ChatMsgEvent (e :: MsgEncoding) where XMsgNew :: MsgContainer -> ChatMsgEvent 'Json XMsgFileDescr :: {msgId :: SharedMsgId, fileDescr :: FileDescr} -> ChatMsgEvent 'Json XMsgUpdate :: {msgId :: SharedMsgId, content :: MsgContent, mentions :: Map MemberName MsgMention, ttl :: Maybe Int, live :: Maybe Bool, scope :: Maybe MsgScope} -> ChatMsgEvent 'Json - XMsgDel :: SharedMsgId -> Maybe MemberId -> ChatMsgEvent 'Json + XMsgDel :: {msgId :: SharedMsgId, memberId :: Maybe MemberId, scope :: Maybe MsgScope} -> ChatMsgEvent 'Json XMsgDeleted :: ChatMsgEvent 'Json - XMsgReact :: {msgId :: SharedMsgId, memberId :: Maybe MemberId, reaction :: MsgReaction, add :: Bool} -> ChatMsgEvent 'Json + XMsgReact :: {msgId :: SharedMsgId, memberId :: Maybe MemberId, scope :: Maybe MsgScope, reaction :: MsgReaction, add :: Bool} -> ChatMsgEvent 'Json XFile :: FileInvitation -> ChatMsgEvent 'Json -- TODO discontinue XFileAcpt :: String -> ChatMsgEvent 'Json -- direct file protocol XFileAcptInv :: SharedMsgId -> Maybe ConnReqInvitation -> String -> ChatMsgEvent 'Json @@ -369,6 +369,8 @@ data AChatMsgEvent = forall e. MsgEncodingI e => ACME (SMsgEncoding e) (ChatMsgE deriving instance Show AChatMsgEvent +-- when sending, used for deciding whether message will be forwarded by host or not (memberSendAction); +-- actual filtering on forwarding is done in processEvent isForwardedGroupMsg :: ChatMsgEvent e -> Bool isForwardedGroupMsg ev = case ev of XMsgNew mc -> case mcExtMsgContent mc of @@ -376,7 +378,7 @@ isForwardedGroupMsg ev = case ev of _ -> True XMsgFileDescr _ _ -> True XMsgUpdate {} -> True - XMsgDel _ _ -> True + XMsgDel {} -> True XMsgReact {} -> True XFileCancel _ -> True XInfo _ -> True @@ -390,12 +392,7 @@ isForwardedGroupMsg ev = case ev of XGrpPrefs _ -> True _ -> False -forwardedGroupMsg :: forall e. MsgEncodingI e => ChatMessage e -> Maybe (ChatMessage 'Json) -forwardedGroupMsg msg@ChatMessage {chatMsgEvent} = case encoding @e of - SJson | isForwardedGroupMsg chatMsgEvent -> Just msg - _ -> Nothing - --- applied after checking forwardedGroupMsg and building list of group members to forward to, see Chat; +-- applied after building list of messages to forward and building list of group members to forward to, see Chat; -- -- this filters out members if any of forwarded events in batch is an XGrpMemRestrict event referring to them, -- but practically XGrpMemRestrict is not batched with other events so it wouldn't prevent forwarding of other events @@ -403,27 +400,23 @@ forwardedGroupMsg msg@ChatMessage {chatMsgEvent} = case encoding @e of -- -- same for reports (MCReport) - they are not batched with other events, so we can safely filter out -- members with role less than moderator when forwarding -forwardedToGroupMembers :: forall e. MsgEncodingI e => [GroupMember] -> NonEmpty (ChatMessage e) -> [GroupMember] -forwardedToGroupMembers ms forwardedMsgs = - filter forwardToMember ms +msgsForwardedToMember :: NonEmpty (ChatMessage 'Json) -> GroupMember -> Bool +msgsForwardedToMember fwdMsgs GroupMember {memberId, memberRole} = + (memberId `notElem` restrictMemberIds) && (not hasReport || memberRole >= GRModerator) where - forwardToMember GroupMember {memberId, memberRole} = - (memberId `notElem` restrictMemberIds) - && (not hasReport || memberRole >= GRModerator) - restrictMemberIds = mapMaybe restrictMemberId $ L.toList forwardedMsgs - restrictMemberId ChatMessage {chatMsgEvent} = case encoding @e of - SJson -> case chatMsgEvent of + restrictMemberIds = mapMaybe restrictMemberId $ L.toList fwdMsgs + restrictMemberId :: ChatMessage 'Json -> Maybe MemberId + restrictMemberId ChatMessage {chatMsgEvent} = + case chatMsgEvent of XGrpMemRestrict mId _ -> Just mId _ -> Nothing - _ -> Nothing - hasReport = any isReportEvent forwardedMsgs - isReportEvent ChatMessage {chatMsgEvent} = case encoding @e of - SJson -> case chatMsgEvent of + hasReport = any isReportEvent fwdMsgs + isReportEvent ChatMessage {chatMsgEvent} = + case chatMsgEvent of XMsgNew mc -> case mcExtMsgContent mc of ExtMsgContent {content = MCReport {}} -> True _ -> False _ -> False - _ -> False data MsgReaction = MREmoji {emoji :: MREmojiChar} | MRUnknown {tag :: Text, json :: J.Object} deriving (Eq, Show) @@ -1105,9 +1098,9 @@ appJsonToCM AppMessageJson {v, msgId, event, params} = do live <- opt "live" scope <- opt "scope" pure XMsgUpdate {msgId = msgId', content, mentions, ttl, live, scope} - XMsgDel_ -> XMsgDel <$> p "msgId" <*> opt "memberId" + XMsgDel_ -> XMsgDel <$> p "msgId" <*> opt "memberId" <*> opt "scope" XMsgDeleted_ -> pure XMsgDeleted - XMsgReact_ -> XMsgReact <$> p "msgId" <*> opt "memberId" <*> p "reaction" <*> p "add" + XMsgReact_ -> XMsgReact <$> p "msgId" <*> opt "memberId" <*> opt "scope" <*> p "reaction" <*> p "add" XFile_ -> XFile <$> p "file" XFileAcpt_ -> XFileAcpt <$> p "fileName" XFileAcptInv_ -> XFileAcptInv <$> p "msgId" <*> opt "fileConnReq" <*> p "fileName" @@ -1176,9 +1169,9 @@ chatToAppMessage ChatMessage {chatVRange, msgId, chatMsgEvent} = case encoding @ XMsgNew container -> msgContainerJSON container XMsgFileDescr msgId' fileDescr -> o ["msgId" .= msgId', "fileDescr" .= fileDescr] XMsgUpdate {msgId = msgId', content, mentions, ttl, live, scope} -> o $ ("ttl" .=? ttl) $ ("live" .=? live) $ ("scope" .=? scope) $ ("mentions" .=? nonEmptyMap mentions) ["msgId" .= msgId', "content" .= content] - XMsgDel msgId' memberId -> o $ ("memberId" .=? memberId) ["msgId" .= msgId'] + XMsgDel msgId' memberId scope -> o $ ("memberId" .=? memberId) $ ("scope" .=? scope) ["msgId" .= msgId'] XMsgDeleted -> JM.empty - XMsgReact msgId' memberId reaction add -> o $ ("memberId" .=? memberId) ["msgId" .= msgId', "reaction" .= reaction, "add" .= add] + XMsgReact msgId' memberId scope reaction add -> o $ ("memberId" .=? memberId) $ ("scope" .=? scope) ["msgId" .= msgId', "reaction" .= reaction, "add" .= add] XFile fileInv -> o ["file" .= fileInv] XFileAcpt fileName -> o ["fileName" .= fileName] XFileAcptInv sharedMsgId fileConnReq fileName -> o $ ("fileConnReq" .=? fileConnReq) ["msgId" .= sharedMsgId, "fileName" .= fileName] diff --git a/src/Simplex/Chat/Store/Groups.hs b/src/Simplex/Chat/Store/Groups.hs index c2c6d9798d..4b1b72ff9d 100644 --- a/src/Simplex/Chat/Store/Groups.hs +++ b/src/Simplex/Chat/Store/Groups.hs @@ -60,6 +60,8 @@ module Simplex.Chat.Store.Groups getMentionedMemberByMemberId, getGroupMemberById, getGroupMemberByMemberId, + getGroupMemberIdViaMemberId, + getScopeMemberIdViaMemberId, getGroupMembers, getGroupModerators, getGroupMembersForExpiration, @@ -103,7 +105,10 @@ module Simplex.Chat.Store.Groups getIntroduction, getIntroducedGroupMemberIds, getForwardIntroducedMembers, + getForwardIntroducedModerators, getForwardInvitedMembers, + getForwardInvitedModerators, + getForwardScopeMember, createIntroReMember, createIntroToMemberContact, saveMemberInvitation, @@ -182,7 +187,7 @@ import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.Ratchet (pattern PQEncOff, pattern PQSupportOff) import Simplex.Messaging.Parsers (defaultJSON) import Simplex.Messaging.Protocol (SubscriptionMode (..)) -import Simplex.Messaging.Util (eitherToMaybe, firstRow', ($>>=), (<$$>)) +import Simplex.Messaging.Util (eitherToMaybe, firstRow', ($>>), ($>>=), (<$$>)) import Simplex.Messaging.Version import UnliftIO.STM #if defined(dbPostgres) @@ -1091,6 +1096,20 @@ getGroupMemberByMemberId db vr user@User {userId} GroupInfo {groupId} memberId = (groupMemberQuery <> " WHERE m.group_id = ? AND m.member_id = ?") (userId, groupId, memberId) +getScopeMemberIdViaMemberId :: DB.Connection -> User -> GroupInfo -> GroupMember -> MemberId -> ExceptT StoreError IO GroupMemberId +getScopeMemberIdViaMemberId db user g@GroupInfo {membership} sender scopeMemberId + | scopeMemberId == memberId' membership = pure $ groupMemberId' membership + | scopeMemberId == memberId' sender = pure $ groupMemberId' sender + | otherwise = getGroupMemberIdViaMemberId db user g scopeMemberId + +getGroupMemberIdViaMemberId :: DB.Connection -> User -> GroupInfo -> MemberId -> ExceptT StoreError IO GroupMemberId +getGroupMemberIdViaMemberId db User {userId} GroupInfo {groupId} memberId = + ExceptT . firstRow fromOnly (SEGroupMemberNotFoundByMemberId memberId) $ + DB.query + db + "SELECT group_member_id FROM group_members WHERE user_id = ? AND group_id = ? AND member_id = ?" + (userId, groupId, memberId) + getGroupMembers :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> IO [GroupMember] getGroupMembers db vr user@User {userId, userContactId} GroupInfo {groupId} = do map (toContactMember vr user) @@ -1727,6 +1746,26 @@ getForwardIntroducedMembers db vr user invitee highlyAvailable = do WHERE to_group_member_id = ? AND intro_status NOT IN (?,?,?) |] +-- for support scope we don't need to filter by intro_chat_protocol_version for non highly available client, +-- as we will filter moderators supporting this feature by a higher version (as opposed to getForwardIntroducedMembers) +getForwardIntroducedModerators :: DB.Connection -> VersionRangeChat -> User -> GroupMember -> IO [GroupMember] +getForwardIntroducedModerators db vr user@User {userContactId} invitee = do + memberIds <- map fromOnly <$> query + rights <$> mapM (runExceptT . getGroupMemberById db vr user) memberIds + where + mId = groupMemberId' invitee + query = + DB.query + db + [sql| + SELECT i.re_group_member_id + FROM group_member_intros i + JOIN group_members m ON m.group_member_id = i.re_group_member_id + WHERE i.to_group_member_id = ? AND i.intro_status NOT IN (?,?,?) + AND (m.contact_id IS NULL OR m.contact_id != ?) AND m.member_role IN (?,?,?) + |] + (mId, GMIntroReConnected, GMIntroToConnected, GMIntroConnected, userContactId, GRModerator, GRAdmin, GROwner) + getForwardInvitedMembers :: DB.Connection -> VersionRangeChat -> User -> GroupMember -> Bool -> IO [GroupMember] getForwardInvitedMembers db vr user forwardMember highlyAvailable = do memberIds <- map fromOnly <$> query @@ -1747,6 +1786,46 @@ getForwardInvitedMembers db vr user forwardMember highlyAvailable = do WHERE re_group_member_id = ? AND intro_status NOT IN (?,?,?) |] +-- for support scope we don't need to filter by intro_chat_protocol_version for non highly available client, +-- as we will filter moderators supporting this feature by a higher version (as opposed to getForwardInvitedMembers) +getForwardInvitedModerators :: DB.Connection -> VersionRangeChat -> User -> GroupMember -> IO [GroupMember] +getForwardInvitedModerators db vr user@User {userContactId} forwardMember = do + memberIds <- map fromOnly <$> query + rights <$> mapM (runExceptT . getGroupMemberById db vr user) memberIds + where + mId = groupMemberId' forwardMember + query = + DB.query + db + [sql| + SELECT i.to_group_member_id + FROM group_member_intros i + JOIN group_members m ON m.group_member_id = i.to_group_member_id + WHERE i.re_group_member_id = ? AND i.intro_status NOT IN (?,?,?) + AND (m.contact_id IS NULL OR m.contact_id != ?) AND m.member_role IN (?,?,?) + |] + (mId, GMIntroReConnected, GMIntroToConnected, GMIntroConnected, userContactId, GRModerator, GRAdmin, GROwner) + +getForwardScopeMember :: DB.Connection -> VersionRangeChat -> User -> GroupMember -> GroupMemberId -> IO (Maybe GroupMember) +getForwardScopeMember db vr user GroupMember {groupMemberId = sendingGMId} scopeGMId = do + (introExists_ :: Maybe Int64) <- + liftIO $ maybeFirstRow fromOnly $ + DB.query + db + [sql| + SELECT 1 + FROM group_member_intros + WHERE + ( + (re_group_member_id = ? AND to_group_member_id = ?) OR + (re_group_member_id = ? AND to_group_member_id = ?) + ) + AND intro_status NOT IN (?,?,?) + LIMIT 1 + |] + (sendingGMId, scopeGMId, scopeGMId, sendingGMId, GMIntroReConnected, GMIntroToConnected, GMIntroConnected) + pure introExists_ $>> (eitherToMaybe <$> runExceptT (getGroupMemberById db vr user scopeGMId)) + createIntroReMember :: DB.Connection -> User -> GroupInfo -> GroupMember -> VersionChat -> MemberInfo -> Maybe MemberRestrictions -> (CommandId, ConnId) -> SubscriptionMode -> ExceptT StoreError IO GroupMember createIntroReMember db diff --git a/src/Simplex/Chat/Store/SQLite/Migrations/chat_query_plans.txt b/src/Simplex/Chat/Store/SQLite/Migrations/chat_query_plans.txt index 7454285725..7ff8ce0ece 100644 --- a/src/Simplex/Chat/Store/SQLite/Migrations/chat_query_plans.txt +++ b/src/Simplex/Chat/Store/SQLite/Migrations/chat_query_plans.txt @@ -1041,6 +1041,24 @@ SEARCH g USING INTEGER PRIMARY KEY (rowid=?) SEARCH gp USING INTEGER PRIMARY KEY (rowid=?) SEARCH pu USING INTEGER PRIMARY KEY (rowid=?) +Query: + SELECT 1 + FROM group_member_intros + WHERE + ( + (re_group_member_id = ? AND to_group_member_id = ?) OR + (re_group_member_id = ? AND to_group_member_id = ?) + ) + AND intro_status NOT IN (?,?,?) + LIMIT 1 + +Plan: +MULTI-INDEX OR +INDEX 1 +SEARCH group_member_intros USING INDEX sqlite_autoindex_group_member_intros_1 (re_group_member_id=? AND to_group_member_id=?) +INDEX 2 +SEARCH group_member_intros USING INDEX sqlite_autoindex_group_member_intros_1 (re_group_member_id=? AND to_group_member_id=?) + Query: SELECT 1 FROM users WHERE (user_id = ? AND local_display_name = ?) @@ -1334,6 +1352,28 @@ Plan: SEARCH g USING INTEGER PRIMARY KEY (rowid=?) SEARCH i USING INTEGER PRIMARY KEY (rowid=?) +Query: + SELECT i.re_group_member_id + FROM group_member_intros i + JOIN group_members m ON m.group_member_id = i.re_group_member_id + WHERE i.to_group_member_id = ? AND i.intro_status NOT IN (?,?,?) + AND (m.contact_id IS NULL OR m.contact_id != ?) AND m.member_role IN (?,?,?) + +Plan: +SEARCH i USING INDEX idx_group_member_intros_to_group_member_id (to_group_member_id=?) +SEARCH m USING INTEGER PRIMARY KEY (rowid=?) + +Query: + SELECT i.to_group_member_id + FROM group_member_intros i + JOIN group_members m ON m.group_member_id = i.to_group_member_id + WHERE i.re_group_member_id = ? AND i.intro_status NOT IN (?,?,?) + AND (m.contact_id IS NULL OR m.contact_id != ?) AND m.member_role IN (?,?,?) + +Plan: +SEARCH i USING INDEX idx_group_member_intros_re_group_member_id (re_group_member_id=?) +SEARCH m USING INTEGER PRIMARY KEY (rowid=?) + Query: SELECT member_status FROM group_members @@ -3565,6 +3605,15 @@ Query: Plan: SEARCH chat_items USING INTEGER PRIMARY KEY (rowid=?) +Query: + UPDATE connections SET conn_status='deleted' + WHERE group_member_id IN (SELECT group_member_id FROM group_members WHERE local_display_name = ?) + +Plan: +SEARCH connections USING INDEX idx_connections_group_member_id (group_member_id=?) +LIST SUBQUERY 1 +SCAN group_members USING COVERING INDEX idx_group_members_user_id_local_display_name + Query: UPDATE group_member_intros SET intro_status = ?, @@ -3576,6 +3625,18 @@ Query: Plan: SEARCH group_member_intros USING INTEGER PRIMARY KEY (rowid=?) +Query: + UPDATE group_member_intros SET intro_status='fwd' + WHERE re_group_member_id IN (SELECT group_member_id FROM group_members WHERE local_display_name = ?) + AND to_group_member_id IN (SELECT group_member_id FROM group_members WHERE local_display_name = ?) + +Plan: +SEARCH group_member_intros USING INDEX sqlite_autoindex_group_member_intros_1 (re_group_member_id=? AND to_group_member_id=?) +LIST SUBQUERY 1 +SCAN group_members USING COVERING INDEX idx_group_members_user_id_local_display_name +LIST SUBQUERY 2 +SCAN group_members USING COVERING INDEX idx_group_members_user_id_local_display_name + Query: UPDATE group_members SET contact_id = ?, local_display_name = ?, contact_profile_id = ?, updated_at = ? @@ -5997,10 +6058,6 @@ Query: UPDATE connections SET conn_status = ?, updated_at = ?, conn_req_inv = NU Plan: SEARCH connections USING INTEGER PRIMARY KEY (rowid=?) -Query: UPDATE connections SET conn_status='deleted' WHERE group_member_id = 3 -Plan: -SEARCH connections USING INDEX idx_connections_group_member_id (group_member_id=?) - Query: UPDATE connections SET conn_type = ?, group_member_id = ?, updated_at = ? WHERE connection_id = ? Plan: SEARCH connections USING INTEGER PRIMARY KEY (rowid=?) diff --git a/tests/ChatTests/Groups.hs b/tests/ChatTests/Groups.hs index 56dd863b2d..23837ad597 100644 --- a/tests/ChatTests/Groups.hs +++ b/tests/ChatTests/Groups.hs @@ -3,6 +3,7 @@ {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PostfixOperators #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} @@ -37,8 +38,10 @@ import Simplex.Messaging.Version import Test.Hspec hiding (it) #if defined(dbPostgres) import Database.PostgreSQL.Simple (Only (..)) +import Database.PostgreSQL.Simple.SqlQQ (sql) #else import Database.SQLite.Simple (Only (..)) +import Database.SQLite.Simple.QQ (sql) import Simplex.Chat.Options.DB import System.Directory (copyFile) import System.FilePath (()) @@ -198,6 +201,13 @@ chatGroupTests = do describe "group scoped messages" $ do it "should send scoped messages to support (single moderator)" testScopedSupportSingleModerator it "should send scoped messages to support (many moderators)" testScopedSupportManyModerators + it "should forward messages inside support scope" testScopedSupportForward + it "should forward messages inside support scope while member is in review" testScopedSupportForwardWhileReview + it "should not forward messages from support to main scope" testScopedSupportDontForward + -- TODO test messages are not forwarded between support scopes (1 in review, 1 not? combinations?) + it "should forward file inside support scope" testScopedSupportForwardFile + -- TODO test files are forwarded inside support scope while member is in review + -- TODO test group events directed to all (e.g. XGrpInfo) are forwarded to support scope member while in review it "should send messages to admins and members" testSupportCLISendCommand it "should correctly maintain unread stats for support chats on reading chat items" testScopedSupportUnreadStatsOnRead it "should correctly maintain unread stats for support chats on deleting chat items" testScopedSupportUnreadStatsOnDelete @@ -4565,7 +4575,8 @@ testGroupMsgForward :: HasCallStack => TestParams -> IO () testGroupMsgForward = testChat3 aliceProfile bobProfile cathProfile $ \alice bob cath -> do - setupGroupForwarding3 "team" alice bob cath + createGroup3 "team" alice bob cath + setupGroupForwarding alice bob cath bob #> "#team hi there" alice <# "#team bob> hi there" @@ -4593,7 +4604,8 @@ testGroupMsgForwardReport :: HasCallStack => TestParams -> IO () testGroupMsgForwardReport = testChat3 aliceProfile bobProfile cathProfile $ \alice bob cath -> do - setupGroupForwarding3 "team" alice bob cath + createGroup3 "team" alice bob cath + setupGroupForwarding alice bob cath bob #> "#team hi there" alice <# "#team bob> hi there" @@ -4647,17 +4659,39 @@ testGroupMsgForwardReport = alice <# "#team cath> hey team" bob <# "#team cath> hey team [>>]" -setupGroupForwarding3 :: String -> TestCC -> TestCC -> TestCC -> IO () -setupGroupForwarding3 gName alice bob cath = do - createGroup3 gName alice bob cath - +setupGroupForwarding :: TestCC -> TestCC -> TestCC -> IO () +setupGroupForwarding host invitee1 invitee2 = do threadDelay 1000000 -- delay so intro_status doesn't get overwritten to connected - void $ withCCTransaction bob $ \db -> - DB.execute_ db "UPDATE connections SET conn_status='deleted' WHERE group_member_id = 3" - void $ withCCTransaction cath $ \db -> - DB.execute_ db "UPDATE connections SET conn_status='deleted' WHERE group_member_id = 3" - void $ withCCTransaction alice $ \db -> - DB.execute_ db "UPDATE group_member_intros SET intro_status='fwd'" + + invitee1Name <- userName invitee1 + invitee2Name <- userName invitee2 + + -- set up test: break connections between invitee1 and invitee2 to enable group forwarding + void $ withCCTransaction invitee1 $ \db -> + DB.execute + db + [sql| + UPDATE connections SET conn_status='deleted' + WHERE group_member_id IN (SELECT group_member_id FROM group_members WHERE local_display_name = ?) + |] + (Only invitee2Name) + void $ withCCTransaction invitee2 $ \db -> + DB.execute + db + [sql| + UPDATE connections SET conn_status='deleted' + WHERE group_member_id IN (SELECT group_member_id FROM group_members WHERE local_display_name = ?) + |] + (Only invitee1Name) + void $ withCCTransaction host $ \db -> + DB.execute + db + [sql| + UPDATE group_member_intros SET intro_status='fwd' + WHERE re_group_member_id IN (SELECT group_member_id FROM group_members WHERE local_display_name = ?) + AND to_group_member_id IN (SELECT group_member_id FROM group_members WHERE local_display_name = ?) + |] + (invitee1Name, invitee2Name) testGroupMsgForwardDeduplicate :: HasCallStack => TestParams -> IO () testGroupMsgForwardDeduplicate = @@ -4700,7 +4734,8 @@ testGroupMsgForwardEdit :: HasCallStack => TestParams -> IO () testGroupMsgForwardEdit = testChat3 aliceProfile bobProfile cathProfile $ \alice bob cath -> do - setupGroupForwarding3 "team" alice bob cath + createGroup3 "team" alice bob cath + setupGroupForwarding alice bob cath bob #> "#team hi there" alice <# "#team bob> hi there" @@ -4723,7 +4758,8 @@ testGroupMsgForwardReaction :: HasCallStack => TestParams -> IO () testGroupMsgForwardReaction = testChat3 aliceProfile bobProfile cathProfile $ \alice bob cath -> do - setupGroupForwarding3 "team" alice bob cath + createGroup3 "team" alice bob cath + setupGroupForwarding alice bob cath bob #> "#team hi there" alice <# "#team bob> hi there" @@ -4740,7 +4776,8 @@ testGroupMsgForwardDeletion :: HasCallStack => TestParams -> IO () testGroupMsgForwardDeletion = testChat3 aliceProfile bobProfile cathProfile $ \alice bob cath -> do - setupGroupForwarding3 "team" alice bob cath + createGroup3 "team" alice bob cath + setupGroupForwarding alice bob cath -- disableFullDeletion3 "team" alice bob cath bob #> "#team hi there" @@ -4756,7 +4793,8 @@ testGroupMsgForwardFile :: HasCallStack => TestParams -> IO () testGroupMsgForwardFile = testChat3 aliceProfile bobProfile cathProfile $ \alice bob cath -> withXFTPServer $ do - setupGroupForwarding3 "team" alice bob cath + createGroup3 "team" alice bob cath + setupGroupForwarding alice bob cath bob #> "/f #team ./tests/fixtures/test.jpg" bob <## "use /fc 1 to cancel sending" @@ -4781,7 +4819,8 @@ testGroupMsgForwardChangeRole :: HasCallStack => TestParams -> IO () testGroupMsgForwardChangeRole = testChat3 aliceProfile bobProfile cathProfile $ \alice bob cath -> do - setupGroupForwarding3 "team" alice bob cath + createGroup3 "team" alice bob cath + setupGroupForwarding alice bob cath cath ##> "/mr #team bob member" cath <## "#team: you changed the role of bob to member" @@ -4792,7 +4831,8 @@ testGroupMsgForwardNewMember :: HasCallStack => TestParams -> IO () testGroupMsgForwardNewMember = testChat4 aliceProfile bobProfile cathProfile danProfile $ \alice bob cath dan -> do - setupGroupForwarding3 "team" alice bob cath + createGroup3 "team" alice bob cath + setupGroupForwarding alice bob cath connectUsers cath dan cath ##> "/a #team dan" @@ -4833,7 +4873,8 @@ testGroupMsgForwardLeave :: HasCallStack => TestParams -> IO () testGroupMsgForwardLeave = testChat3 aliceProfile bobProfile cathProfile $ \alice bob cath -> do - setupGroupForwarding3 "team" alice bob cath + createGroup3 "team" alice bob cath + setupGroupForwarding alice bob cath bob ##> "/leave #team" bob <## "#team: you left the group" @@ -7015,6 +7056,145 @@ testScopedSupportManyModerators = cath ##> "/member support chats #team" cath <## "bob (Bob) (id 3): unread: 0, require attention: 0, mentions: 0" +testScopedSupportForward :: HasCallStack => TestParams -> IO () +testScopedSupportForward = + testChat4 aliceProfile bobProfile cathProfile danProfile $ \alice bob cath dan -> do + createGroup4 "team" alice (bob, GRMember) (cath, GRMember) (dan, GRModerator) + setupGroupForwarding alice bob dan + + -- messages are forwarded in main scope + bob #> "#team 1" + [alice, cath] *<# "#team bob> 1" + dan <# "#team bob> 1 [>>]" + + dan #> "#team 2" + [alice, cath] *<# "#team dan> 2" + bob <# "#team dan> 2 [>>]" + + -- messages are forwarded inside support scope + bob #> "#team (support) 3" + alice <# "#team (support: bob) bob> 3" + dan <# "#team (support: bob) bob> 3 [>>]" + + dan #> "#team (support: bob) 4" + alice <# "#team (support: bob) dan> 4" + bob <# "#team (support) dan> 4 [>>]" + +testScopedSupportForwardWhileReview :: HasCallStack => TestParams -> IO () +testScopedSupportForwardWhileReview = + testChat5 aliceProfile bobProfile cathProfile danProfile eveProfile $ + \alice bob cath dan eve -> do + createGroup4 "team" alice (bob, GRMember) (cath, GRModerator) (dan, GRModerator) + + alice ##> "/set admission review #team all" + alice <## "changed member admission rules" + concurrentlyN_ + [ do + bob <## "alice updated group #team:" + bob <## "changed member admission rules", + do + cath <## "alice updated group #team:" + cath <## "changed member admission rules", + do + dan <## "alice updated group #team:" + dan <## "changed member admission rules" + ] + + alice ##> "/create link #team" + gLink <- getGroupLink alice "team" GRMember True + eve ##> ("/c " <> gLink) + eve <## "connection request sent!" + alice <## "eve (Eve): accepting request to join group #team..." + concurrentlyN_ + [ alice <## "#team: eve connected and pending review", + eve + <### [ "#team: alice accepted you to the group, pending review", + "#team: joining the group...", + "#team: you joined the group, connecting to group moderators for admission to group", + "#team: member cath (Catherine) is connected", + "#team: member dan (Daniel) is connected" + ], + do + cath <## "#team: alice added eve (Eve) to the group (connecting and pending review...), use /_accept member #1 5 to accept member" + cath <## "#team: new member eve is connected and pending review, use /_accept member #1 5 to accept member", + do + dan <## "#team: alice added eve (Eve) to the group (connecting and pending review...), use /_accept member #1 5 to accept member" + dan <## "#team: new member eve is connected and pending review, use /_accept member #1 5 to accept member" + ] + + setupGroupForwarding alice cath eve + + -- message from cath is not forwarded to eve in group scope + bob #> "#team 1" + [alice, cath, dan] *<# "#team bob> 1" + + -- message from cath is not forwarded to eve in group scope + cath #> "#team 2" + [alice, bob, dan] *<# "#team cath> 2" + + -- messages are forwarded in support scope + eve #> "#team (support) 3" + [alice, dan] *<# "#team (support: eve) eve> 3" + cath <# "#team (support: eve) eve> 3 [>>]" + + cath #> "#team (support: eve) 4" + [alice, dan] *<# "#team (support: eve) cath> 4" + eve <# "#team (support) cath> 4 [>>]" + +testScopedSupportDontForward :: HasCallStack => TestParams -> IO () +testScopedSupportDontForward = + testChat4 aliceProfile bobProfile cathProfile danProfile $ \alice bob cath dan -> do + createGroup4 "team" alice (bob, GRMember) (cath, GRMember) (dan, GRModerator) + setupGroupForwarding alice bob cath + + -- messages are forwarded in main scope + bob #> "#team 1" + [alice, dan] *<# "#team bob> 1" + cath <# "#team bob> 1 [>>]" + + cath #> "#team 2" + [alice, dan] *<# "#team cath> 2" + bob <# "#team cath> 2 [>>]" + + -- messages are not forwarded from support to main scope + bob #> "#team (support) 3" + [alice, dan] *<# "#team (support: bob) bob> 3" + + cath #> "#team (support) 4" + [alice, dan] *<# "#team (support: cath) cath> 4" + +testScopedSupportForwardFile :: HasCallStack => TestParams -> IO () +testScopedSupportForwardFile = + testChat4 aliceProfile bobProfile cathProfile danProfile $ \alice bob cath dan -> withXFTPServer $ do + createGroup4 "team" alice (bob, GRMember) (cath, GRMember) (dan, GRModerator) + setupGroupForwarding alice bob dan + + -- files are forwarded inside support scope + bob ##> "/_send #1(_support) json [{\"filePath\": \"./tests/fixtures/test.jpg\", \"msgContent\": {\"type\": \"text\", \"text\": \"hi, sending a file\"}}]" + bob <# "#team (support) hi, sending a file" + bob <# "/f #team (support) ./tests/fixtures/test.jpg" + bob <## "use /fc 1 to cancel sending" + + concurrentlyN_ + [ do + alice <# "#team (support: bob) bob> hi, sending a file" + alice <# "#team (support: bob) bob> sends file test.jpg (136.5 KiB / 139737 bytes)" + alice <## "use /fr 1 [/ | ] to receive it", + do + dan <# "#team (support: bob) bob> hi, sending a file [>>]" + dan <# "#team (support: bob) bob> sends file test.jpg (136.5 KiB / 139737 bytes) [>>]" + dan <## "use /fr 1 [/ | ] to receive it [>>]" + ] + + bob <## "completed uploading file 1 (test.jpg) for #team" + + dan ##> "/fr 1 ./tests/tmp" + dan + <### [ "saving file 1 from bob to ./tests/tmp/test.jpg", + "started receiving file 1 (test.jpg) from bob" + ] + dan <## "completed receiving file 1 (test.jpg) from bob" + testSupportCLISendCommand :: HasCallStack => TestParams -> IO () testSupportCLISendCommand = testChat2 aliceProfile bobProfile $ \alice bob -> do diff --git a/tests/ProtocolTests.hs b/tests/ProtocolTests.hs index 8e0c937358..b42c838c8a 100644 --- a/tests/ProtocolTests.hs +++ b/tests/ProtocolTests.hs @@ -196,7 +196,7 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do #==# XMsgUpdate (SharedMsgId "\1\2\3\4") (MCText "hello") [] Nothing Nothing Nothing it "x.msg.del" $ "{\"v\":\"1\",\"event\":\"x.msg.del\",\"params\":{\"msgId\":\"AQIDBA==\"}}" - #==# XMsgDel (SharedMsgId "\1\2\3\4") Nothing + #==# XMsgDel (SharedMsgId "\1\2\3\4") Nothing Nothing it "x.msg.deleted" $ "{\"v\":\"1\",\"event\":\"x.msg.deleted\",\"params\":{}}" #==# XMsgDeleted