dandri/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2026-05-13 21:33:41 +00:00
Code Issues Packages Projects Releases Wiki Activity

core: improve message forwarding to better manage support scopes (#6056)

Browse Source 
* core: test forwarding in support scope

* wip

* test

* add to test

* comment

* rework forwarding

* fixes

* refactor tests

* narrow

* forwardMsgs

* support mem

* unfocus tests

* fix, tests

* plans

* add test

* comment

* add scope to reaction and deletion, refactor

* fix del

* refactor

* query plans

---------

Co-authored-by: Evgeny Poberezkin <evgeny@poberezkin.com>
This commit is contained in:
spaced4ndy
2025-07-12 18:39:41 +00:00
committed by GitHub
parent f3454f1f90
commit 8094078bee
8 changed files with 695 additions and 241 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Simplex/Chat/Library/Commands.hs
+6 -6
View File
@@ -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
src/Simplex/Chat/Library/Subscriber.hs
+310 -183
View File
@@ -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
src/Simplex/Chat/Messages.hs
+18
View File
@@ -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
src/Simplex/Chat/Protocol.hs
+20 -27
View File
@@ -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]
src/Simplex/Chat/Store/Groups.hs
+80 -1
View File
@@ -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
src/Simplex/Chat/Store/SQLite/Migrations/chat_query_plans.txt
+61 -4
View File
@@ -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=?)
tests/ChatTests/Groups.hs
+199 -19
View File
@@ -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 <role> to accept member"
cath <## "#team: new member eve is connected and pending review, use /_accept member #1 5 <role> to accept member",
do
dan <## "#team: alice added eve (Eve) to the group (connecting and pending review...), use /_accept member #1 5 <role> to accept member"
dan <## "#team: new member eve is connected and pending review, use /_accept member #1 5 <role> 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 [<dir>/ | <path>] 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 [<dir>/ | <path>] 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
tests/ProtocolTests.hs
+1 -1
View File
@@ -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