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