core: batch apis - remove, block, change role of members (#5674)

* core: core: batch remove members

* order

* foldr

* list

* style

* batch block

* change role

* test

* if
This commit is contained in:
spaced4ndy
2025-02-28 22:43:39 +04:00
committed by GitHub
parent dce8502165
commit dcea008fb9
10 changed files with 320 additions and 162 deletions
+6 -6
View File
@@ -366,9 +366,9 @@ data ChatCommand
| ApiGetConnNtfMessages {connIds :: NonEmpty AgentConnId}
| APIAddMember GroupId ContactId GroupMemberRole
| APIJoinGroup {groupId :: GroupId, enableNtfs :: MsgFilter}
| APIMemberRole GroupId GroupMemberId GroupMemberRole
| APIBlockMemberForAll GroupId GroupMemberId Bool
| APIRemoveMember GroupId GroupMemberId
| APIMembersRole GroupId (NonEmpty GroupMemberId) GroupMemberRole
| APIBlockMembersForAll GroupId (NonEmpty GroupMemberId) Bool
| APIRemoveMembers GroupId (NonEmpty GroupMemberId)
| APILeaveGroup GroupId
| APIListMembers GroupId
| APIUpdateGroupProfile GroupId GroupProfile
@@ -673,7 +673,7 @@ data ChatResponse
| CRUserAcceptedGroupSent {user :: User, groupInfo :: GroupInfo, hostContact :: Maybe Contact}
| CRGroupLinkConnecting {user :: User, groupInfo :: GroupInfo, hostMember :: GroupMember}
| CRBusinessLinkConnecting {user :: User, groupInfo :: GroupInfo, hostMember :: GroupMember, fromContact :: Contact}
| CRUserDeletedMember {user :: User, groupInfo :: GroupInfo, member :: GroupMember}
| CRUserDeletedMembers {user :: User, groupInfo :: GroupInfo, members :: [GroupMember]}
| CRGroupsList {user :: User, groups :: [(GroupInfo, GroupSummary)]}
| CRSentGroupInvitation {user :: User, groupInfo :: GroupInfo, contact :: Contact, member :: GroupMember}
| CRFileTransferStatus User (FileTransfer, [Integer]) -- TODO refactor this type to FileTransferStatus
@@ -758,9 +758,9 @@ data ChatResponse
| CRJoinedGroupMember {user :: User, groupInfo :: GroupInfo, member :: GroupMember}
| CRJoinedGroupMemberConnecting {user :: User, groupInfo :: GroupInfo, hostMember :: GroupMember, member :: GroupMember}
| CRMemberRole {user :: User, groupInfo :: GroupInfo, byMember :: GroupMember, member :: GroupMember, fromRole :: GroupMemberRole, toRole :: GroupMemberRole}
| CRMemberRoleUser {user :: User, groupInfo :: GroupInfo, member :: GroupMember, fromRole :: GroupMemberRole, toRole :: GroupMemberRole}
| CRMembersRoleUser {user :: User, groupInfo :: GroupInfo, members :: [GroupMember], toRole :: GroupMemberRole}
| CRMemberBlockedForAll {user :: User, groupInfo :: GroupInfo, byMember :: GroupMember, member :: GroupMember, blocked :: Bool}
| CRMemberBlockedForAllUser {user :: User, groupInfo :: GroupInfo, member :: GroupMember, blocked :: Bool}
| CRMembersBlockedForAllUser {user :: User, groupInfo :: GroupInfo, members :: [GroupMember], blocked :: Bool}
| CRConnectedToGroupMember {user :: User, groupInfo :: GroupInfo, member :: GroupMember, memberContact :: Maybe Contact}
| CRDeletedMember {user :: User, groupInfo :: GroupInfo, byMember :: GroupMember, deletedMember :: GroupMember}
| CRDeletedMemberUser {user :: User, groupInfo :: GroupInfo, member :: GroupMember}
+169 -78
View File
@@ -2023,75 +2023,170 @@ processChatCommand' vr = \case
updateCIGroupInvitationStatus user g CIGISAccepted `catchChatError` (toView . CRChatError (Just user))
pure $ CRUserAcceptedGroupSent user g {membership = membership {memberStatus = GSMemAccepted}} Nothing
Nothing -> throwChatError $ CEContactNotActive ct
APIMemberRole groupId memberId memRole -> withUser $ \user -> do
Group gInfo@GroupInfo {membership} members <- withFastStore $ \db -> getGroup db vr user groupId
if memberId == groupMemberId' membership
then changeMemberRole user gInfo members membership $ SGEUserRole memRole
else case find ((== memberId) . groupMemberId') members of
Just m -> changeMemberRole user gInfo members m $ SGEMemberRole memberId (fromLocalProfile $ memberProfile m) memRole
_ -> throwChatError CEGroupMemberNotFound
APIMembersRole groupId memberIds newRole -> withUser $ \user ->
withGroupLock "memberRole" groupId . procCmd $ do
g@(Group gInfo members) <- withFastStore $ \db -> getGroup db vr user groupId
when (selfSelected gInfo) $ throwChatError $ CECommandError "can't change role for self"
let (invitedMems, currentMems, unchangedMems, maxRole, anyAdmin) = selectMembers members
when (length invitedMems + length currentMems + length unchangedMems /= length memberIds) $ throwChatError CEGroupMemberNotFound
when (length memberIds > 1 && (anyAdmin || newRole >= GRAdmin)) $
throwChatError $ CECommandError "can't change role of multiple members when admins selected, or new role is admin"
assertUserGroupRole gInfo $ maximum ([GRAdmin, maxRole, newRole] :: [GroupMemberRole])
(errs1, changed1) <- changeRoleInvitedMems user gInfo invitedMems
(errs2, changed2, acis) <- changeRoleCurrentMems user g currentMems
unless (null acis) $ toView $ CRNewChatItems user acis
let errs = errs1 <> errs2
unless (null errs) $ toView $ CRChatErrors (Just user) errs
pure $ CRMembersRoleUser {user, groupInfo = gInfo, members = changed1 <> changed2, toRole = newRole} -- same order is not guaranteed
where
changeMemberRole user gInfo members m gEvent = do
let GroupMember {memberId = mId, memberRole = mRole, memberStatus = mStatus, memberContactId, localDisplayName = cName} = m
assertUserGroupRole gInfo $ maximum ([GRAdmin, mRole, memRole] :: [GroupMemberRole])
withGroupLock "memberRole" groupId . procCmd $ do
unless (mRole == memRole) $ do
withFastStore' $ \db -> updateGroupMemberRole db user m memRole
case mStatus of
GSMemInvited -> do
withFastStore (\db -> (,) <$> mapM (getContact db vr user) memberContactId <*> liftIO (getMemberInvitation db user $ groupMemberId' m)) >>= \case
(Just ct, Just cReq) -> sendGrpInvitation user ct gInfo (m :: GroupMember) {memberRole = memRole} cReq
_ -> throwChatError $ CEGroupCantResendInvitation gInfo cName
_ -> do
msg <- sendGroupMessage user gInfo members $ XGrpMemRole mId memRole
ci <- saveSndChatItem user (CDGroupSnd gInfo) msg (CISndGroupEvent gEvent)
toView $ CRNewChatItems user [AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci]
pure CRMemberRoleUser {user, groupInfo = gInfo, member = m {memberRole = memRole}, fromRole = mRole, toRole = memRole}
APIBlockMemberForAll groupId memberId blocked -> withUser $ \user -> do
Group gInfo@GroupInfo {membership} members <- withFastStore $ \db -> getGroup db vr user groupId
when (memberId == groupMemberId' membership) $ throwChatError $ CECommandError "can't block/unblock self"
case splitMember memberId members of
Nothing -> throwChatError $ CEException "expected to find a single blocked member"
Just (bm, remainingMembers) -> do
let GroupMember {memberId = bmMemberId, memberRole = bmRole, memberProfile = bmp} = bm
-- TODO GRModerator when most users migrate
assertUserGroupRole gInfo $ max GRAdmin bmRole
when (blocked == blockedByAdmin bm) $ throwChatError $ CECommandError $ if blocked then "already blocked" else "already unblocked"
withGroupLock "blockForAll" groupId . procCmd $ do
let mrs = if blocked then MRSBlocked else MRSUnrestricted
event = XGrpMemRestrict bmMemberId MemberRestrictions {restriction = mrs}
msg <- sendGroupMessage' user gInfo remainingMembers event
let ciContent = CISndGroupEvent $ SGEMemberBlocked memberId (fromLocalProfile bmp) blocked
ci <- saveSndChatItem user (CDGroupSnd gInfo) msg ciContent
toView $ CRNewChatItems user [AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci]
bm' <- withFastStore $ \db -> do
liftIO $ updateGroupMemberBlocked db user groupId memberId mrs
getGroupMember db vr user groupId memberId
toggleNtf user bm' (not blocked)
pure CRMemberBlockedForAllUser {user, groupInfo = gInfo, member = bm', blocked}
selfSelected GroupInfo {membership} = elem (groupMemberId' membership) memberIds
selectMembers :: [GroupMember] -> ([GroupMember], [GroupMember], [GroupMember], GroupMemberRole, Bool)
selectMembers = foldr' addMember ([], [], [], GRObserver, False)
where
addMember m@GroupMember {groupMemberId, memberStatus, memberRole} (invited, current, unchanged, maxRole, anyAdmin)
| groupMemberId `elem` memberIds =
let maxRole' = max maxRole memberRole
anyAdmin' = anyAdmin || memberRole >= GRAdmin
in
if
| memberRole == newRole -> (invited, current, m : unchanged, maxRole', anyAdmin')
| memberStatus == GSMemInvited -> (m : invited, current, unchanged, maxRole', anyAdmin')
| otherwise -> (invited, m : current, unchanged, maxRole', anyAdmin')
| otherwise = (invited, current, unchanged, maxRole, anyAdmin)
changeRoleInvitedMems :: User -> GroupInfo -> [GroupMember] -> CM ([ChatError], [GroupMember])
changeRoleInvitedMems user gInfo memsToChange = do
-- not batched, as we need to send different invitations to different connections anyway
mems_ <- forM memsToChange $ \m -> (Right <$> changeRole m) `catchChatError` (pure . Left)
pure $ partitionEithers mems_
where
changeRole :: GroupMember -> CM GroupMember
changeRole m@GroupMember {groupMemberId, memberContactId, localDisplayName = cName} = do
withFastStore (\db -> (,) <$> mapM (getContact db vr user) memberContactId <*> liftIO (getMemberInvitation db user groupMemberId)) >>= \case
(Just ct, Just cReq) -> do
sendGrpInvitation user ct gInfo (m :: GroupMember) {memberRole = newRole} cReq
withFastStore' $ \db -> updateGroupMemberRole db user m newRole
pure (m :: GroupMember) {memberRole = newRole}
_ -> throwChatError $ CEGroupCantResendInvitation gInfo cName
changeRoleCurrentMems :: User -> Group -> [GroupMember] -> CM ([ChatError], [GroupMember], [AChatItem])
changeRoleCurrentMems user (Group gInfo members) memsToChange = case L.nonEmpty memsToChange of
Nothing -> pure ([], [], [])
Just memsToChange' -> do
let events = L.map (\GroupMember {memberId} -> XGrpMemRole memberId newRole) memsToChange'
(msgs_, _gsr) <- sendGroupMessages user gInfo members events
let itemsData = zipWith (fmap . sndItemData) memsToChange (L.toList msgs_)
cis_ <- saveSndChatItems user (CDGroupSnd gInfo) itemsData Nothing False
when (length cis_ /= length memsToChange) $ logError "changeRoleCurrentMems: memsToChange and cis_ length mismatch"
(errs, changed) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (updMember db) memsToChange)
let acis = map (AChatItem SCTGroup SMDSnd (GroupChat gInfo)) $ rights cis_
pure (errs, changed, acis)
where
sndItemData :: GroupMember -> SndMessage -> NewSndChatItemData c
sndItemData GroupMember {groupMemberId, memberProfile} msg =
let content = CISndGroupEvent $ SGEMemberRole groupMemberId (fromLocalProfile memberProfile) newRole
ts = ciContentTexts content
in NewSndChatItemData msg content ts M.empty Nothing Nothing Nothing
updMember db m = do
updateGroupMemberRole db user m newRole
pure (m :: GroupMember) {memberRole = newRole}
APIBlockMembersForAll groupId memberIds blockFlag -> withUser $ \user ->
withGroupLock "blockForAll" groupId . procCmd $ do
Group gInfo members <- withFastStore $ \db -> getGroup db vr user groupId
when (selfSelected gInfo) $ throwChatError $ CECommandError "can't block/unblock self"
let (blockMems, remainingMems, maxRole, anyAdmin) = selectMembers members
when (length blockMems /= length memberIds) $ throwChatError CEGroupMemberNotFound
when (length memberIds > 1 && anyAdmin) $ throwChatError $ CECommandError "can't block/unblock multiple members when admins selected"
assertUserGroupRole gInfo $ max GRModerator maxRole
blockMembers user gInfo blockMems remainingMems
where
splitMember mId ms = case break ((== mId) . groupMemberId') ms of
(_, []) -> Nothing
(ms1, bm : ms2) -> Just (bm, ms1 <> ms2)
APIRemoveMember groupId memberId -> withUser $ \user -> do
Group gInfo members <- withFastStore $ \db -> getGroup db vr user groupId
case find ((== memberId) . groupMemberId') members of
Nothing -> throwChatError CEGroupMemberNotFound
Just m@GroupMember {memberId = mId, memberRole = mRole, memberStatus = mStatus, memberProfile} -> do
assertUserGroupRole gInfo $ max GRAdmin mRole
withGroupLock "removeMember" groupId . procCmd $ do
case mStatus of
GSMemInvited -> do
deleteMemberConnection user m
withFastStore' $ \db -> deleteGroupMember db user m
_ -> do
msg <- sendGroupMessage user gInfo members $ XGrpMemDel mId
ci <- saveSndChatItem user (CDGroupSnd gInfo) msg (CISndGroupEvent $ SGEMemberDeleted memberId (fromLocalProfile memberProfile))
toView $ CRNewChatItems user [AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci]
deleteMemberConnection' user m True
-- undeleted "member connected" chat item will prevent deletion of member record
deleteOrUpdateMemberRecord user m
pure $ CRUserDeletedMember user gInfo m {memberStatus = GSMemRemoved}
selfSelected GroupInfo {membership} = elem (groupMemberId' membership) memberIds
selectMembers :: [GroupMember] -> ([GroupMember], [GroupMember], GroupMemberRole, Bool)
selectMembers = foldr' addMember ([], [], GRObserver, False)
where
addMember m@GroupMember {groupMemberId, memberRole} (block, remaining, maxRole, anyAdmin)
| groupMemberId `elem` memberIds =
let maxRole' = max maxRole memberRole
anyAdmin' = anyAdmin || memberRole >= GRAdmin
in (m : block, remaining, maxRole', anyAdmin')
| otherwise = (block, m : remaining, maxRole, anyAdmin)
blockMembers :: User -> GroupInfo -> [GroupMember] -> [GroupMember] -> CM ChatResponse
blockMembers user gInfo blockMems remainingMems = case L.nonEmpty blockMems of
Nothing -> throwChatError $ CECommandError "no members to block/unblock"
Just blockMems' -> do
let mrs = if blockFlag then MRSBlocked else MRSUnrestricted
events = L.map (\GroupMember {memberId} -> XGrpMemRestrict memberId MemberRestrictions {restriction = mrs}) blockMems'
(msgs_, _gsr) <- sendGroupMessages user gInfo remainingMems events
let itemsData = zipWith (fmap . sndItemData) blockMems (L.toList msgs_)
cis_ <- saveSndChatItems user (CDGroupSnd gInfo) itemsData Nothing False
when (length cis_ /= length blockMems) $ logError "blockMembers: blockMems and cis_ length mismatch"
let acis = map (AChatItem SCTGroup SMDSnd (GroupChat gInfo)) $ rights cis_
unless (null acis) $ toView $ CRNewChatItems user acis
(errs, blocked) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (updateGroupMemberBlocked db user gInfo mrs) blockMems)
unless (null errs) $ toView $ CRChatErrors (Just user) errs
-- TODO not batched - requires agent batch api
forM_ blocked $ \m -> toggleNtf user m (not blockFlag)
pure CRMembersBlockedForAllUser {user, groupInfo = gInfo, members = blocked, blocked = blockFlag}
where
sndItemData :: GroupMember -> SndMessage -> NewSndChatItemData c
sndItemData GroupMember {groupMemberId, memberProfile} msg =
let content = CISndGroupEvent $ SGEMemberBlocked groupMemberId (fromLocalProfile memberProfile) blockFlag
ts = ciContentTexts content
in NewSndChatItemData msg content ts M.empty Nothing Nothing Nothing
APIRemoveMembers groupId memberIds -> withUser $ \user ->
withGroupLock "removeMembers" groupId . procCmd $ do
g@(Group gInfo members) <- withFastStore $ \db -> getGroup db vr user groupId
let (invitedMems, currentMems, maxRole, anyAdmin) = selectMembers members
when (length invitedMems + length currentMems /= length memberIds) $ throwChatError CEGroupMemberNotFound
when (length memberIds > 1 && anyAdmin) $ throwChatError $ CECommandError "can't remove multiple members when admins selected"
assertUserGroupRole gInfo $ max GRAdmin maxRole
(errs1, deleted1) <- deleteInvitedMems user invitedMems
(errs2, deleted2, acis) <- deleteCurrentMems user g currentMems
unless (null acis) $ toView $ CRNewChatItems user acis
let errs = errs1 <> errs2
unless (null errs) $ toView $ CRChatErrors (Just user) errs
pure $ CRUserDeletedMembers user gInfo (deleted1 <> deleted2) -- same order is not guaranteed
where
selectMembers :: [GroupMember] -> ([GroupMember], [GroupMember], GroupMemberRole, Bool)
selectMembers = foldr' addMember ([], [], GRObserver, False)
where
addMember m@GroupMember {groupMemberId, memberStatus, memberRole} (invited, current, maxRole, anyAdmin)
| groupMemberId `elem` memberIds =
let maxRole' = max maxRole memberRole
anyAdmin' = anyAdmin || memberRole >= GRAdmin
in
if memberStatus == GSMemInvited
then (m : invited, current, maxRole', anyAdmin')
else (invited, m : current, maxRole', anyAdmin')
| otherwise = (invited, current, maxRole, anyAdmin)
deleteInvitedMems :: User -> [GroupMember] -> CM ([ChatError], [GroupMember])
deleteInvitedMems user memsToDelete = do
deleteMembersConnections user memsToDelete
lift $ partitionEithers <$> withStoreBatch' (\db -> map (delMember db) memsToDelete)
where
delMember db m = do
deleteGroupMember db user m
pure m {memberStatus = GSMemRemoved}
deleteCurrentMems :: User -> Group -> [GroupMember] -> CM ([ChatError], [GroupMember], [AChatItem])
deleteCurrentMems user (Group gInfo members) memsToDelete = case L.nonEmpty memsToDelete of
Nothing -> pure ([], [], [])
Just memsToDelete' -> do
let events = L.map (\GroupMember {memberId} -> XGrpMemDel memberId) memsToDelete'
(msgs_, _gsr) <- sendGroupMessages user gInfo members events
let itemsData = zipWith (fmap . sndItemData) memsToDelete (L.toList msgs_)
cis_ <- saveSndChatItems user (CDGroupSnd gInfo) itemsData Nothing False
when (length cis_ /= length memsToDelete) $ logError "deleteCurrentMems: memsToDelete and cis_ length mismatch"
deleteMembersConnections' user memsToDelete True
(errs, deleted) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (delMember db) memsToDelete)
let acis = map (AChatItem SCTGroup SMDSnd (GroupChat gInfo)) $ rights cis_
pure (errs, deleted, acis)
where
sndItemData :: GroupMember -> SndMessage -> NewSndChatItemData c
sndItemData GroupMember {groupMemberId, memberProfile} msg =
let content = CISndGroupEvent $ SGEMemberDeleted groupMemberId (fromLocalProfile memberProfile)
ts = ciContentTexts content
in NewSndChatItemData msg content ts M.empty Nothing Nothing Nothing
delMember db m = do
deleteOrUpdateMemberRecordIO db user m
pure m {memberStatus = GSMemRemoved}
APILeaveGroup groupId -> withUser $ \user@User {userId} -> do
Group gInfo@GroupInfo {membership} members <- withFastStore $ \db -> getGroup db vr user groupId
filesInfo <- withFastStore' $ \db -> getGroupFileInfo db user gInfo
@@ -2114,18 +2209,14 @@ processChatCommand' vr = \case
JoinGroup gName enableNtfs -> withUser $ \user -> do
groupId <- withFastStore $ \db -> getGroupIdByName db user gName
processChatCommand $ APIJoinGroup groupId enableNtfs
MemberRole gName gMemberName memRole -> withMemberName gName gMemberName $ \gId gMemberId -> APIMemberRole gId gMemberId memRole
BlockForAll gName gMemberName blocked -> withMemberName gName gMemberName $ \gId gMemberId -> APIBlockMemberForAll gId gMemberId blocked
MemberRole gName gMemberName memRole -> withMemberName gName gMemberName $ \gId gMemberId -> APIMembersRole gId [gMemberId] memRole
BlockForAll gName gMemberName blocked -> withMemberName gName gMemberName $ \gId gMemberId -> APIBlockMembersForAll gId [gMemberId] blocked
RemoveMembers gName gMemberNames -> withUser $ \user -> do
(gId, gMemberIds) <- withStore $ \db -> do
gId <- getGroupIdByName db user gName
gMemberIds <- forM gMemberNames $ getGroupMemberIdByName db user gId
pure (gId, gMemberIds)
rs <- forM (L.zip (L.fromList [1..]) gMemberIds) $ \(i, memId) -> do
r <- processChatCommand (APIRemoveMember gId memId)
when (i < length gMemberIds) $ toView r
pure r
pure $ L.last rs
processChatCommand $ APIRemoveMembers gId gMemberIds
LeaveGroup gName -> withUser $ \user -> do
groupId <- withFastStore $ \db -> getGroupIdByName db user gName
processChatCommand $ APILeaveGroup groupId
@@ -3090,7 +3181,7 @@ processChatCommand' vr = \case
(msgs_, gsr) <- sendGroupMessages user gInfo ms chatMsgEvents
let itemsData = prepareSndItemsData (L.toList cmrs) (L.toList ciFiles_) (L.toList quotedItems_) (L.toList msgs_)
cis_ <- saveSndChatItems user (CDGroupSnd gInfo) itemsData timed_ live
when (length itemsData /= length cmrs) $ logError "sendGroupContentMessages: cmrs and cis_ length mismatch"
when (length cis_ /= length cmrs) $ logError "sendGroupContentMessages: cmrs and cis_ length mismatch"
createMemberSndStatuses cis_ msgs_ gsr
let r@(_, cis) = partitionEithers cis_
processSendErrs user r
@@ -3795,9 +3886,9 @@ chatCommandP =
"/_ntf conn messages " *> (ApiGetConnNtfMessages <$> strP),
"/_add #" *> (APIAddMember <$> A.decimal <* A.space <*> A.decimal <*> memberRole),
"/_join #" *> (APIJoinGroup <$> A.decimal <*> pure MFAll), -- needs to be changed to support in UI
"/_member role #" *> (APIMemberRole <$> A.decimal <* A.space <*> A.decimal <*> memberRole),
"/_block #" *> (APIBlockMemberForAll <$> A.decimal <* A.space <*> A.decimal <* A.space <* "blocked=" <*> onOffP),
"/_remove #" *> (APIRemoveMember <$> A.decimal <* A.space <*> A.decimal),
"/_member role #" *> (APIMembersRole <$> A.decimal <*> _strP <*> memberRole),
"/_block #" *> (APIBlockMembersForAll <$> A.decimal <*> _strP <* A.space <* "blocked=" <*> onOffP),
"/_remove #" *> (APIRemoveMembers <$> A.decimal <*> _strP),
"/_leave #" *> (APILeaveGroup <$> A.decimal),
"/_members #" *> (APIListMembers <$> A.decimal),
"/_server test " *> (APITestProtoServer <$> A.decimal <* A.space <*> strP),
+8 -5
View File
@@ -1251,11 +1251,14 @@ deleteMemberConnection' user GroupMember {activeConn} waitDelivery = do
withStore' $ \db -> updateConnectionStatus db conn ConnDeleted
deleteOrUpdateMemberRecord :: User -> GroupMember -> CM ()
deleteOrUpdateMemberRecord user@User {userId} member =
withStore' $ \db ->
checkGroupMemberHasItems db user member >>= \case
Just _ -> updateGroupMemberStatus db userId member GSMemRemoved
Nothing -> deleteGroupMember db user member
deleteOrUpdateMemberRecord user member =
withStore' $ \db -> deleteOrUpdateMemberRecordIO db user member
deleteOrUpdateMemberRecordIO :: DB.Connection -> User -> GroupMember -> IO ()
deleteOrUpdateMemberRecordIO db user@User {userId} member =
checkGroupMemberHasItems db user member >>= \case
Just _ -> updateGroupMemberStatus db userId member GSMemRemoved
Nothing -> deleteGroupMember db user member
sendDirectContactMessages :: MsgEncodingI e => User -> Contact -> NonEmpty (ChatMsgEvent e) -> CM [Either ChatError SndMessage]
sendDirectContactMessages user ct events = do
+6 -8
View File
@@ -2608,7 +2608,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
xGrpMemRestrict :: GroupInfo -> GroupMember -> MemberId -> MemberRestrictions -> RcvMessage -> UTCTime -> CM ()
xGrpMemRestrict
gInfo@GroupInfo {groupId, membership = GroupMember {memberId = membershipMemId}}
gInfo@GroupInfo {membership = GroupMember {memberId = membershipMemId}}
m@GroupMember {memberRole = senderRole}
memId
MemberRestrictions {restriction}
@@ -2619,10 +2619,11 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
messageError "x.grp.mem.restrict: admin blocks you"
| otherwise =
withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId) >>= \case
Right bm@GroupMember {groupMemberId = bmId, memberRole, memberProfile = bmp}
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"
| otherwise -> do
bm' <- setMemberBlocked bmId
bm' <- setMemberBlocked bm
toggleNtf user bm' (not blocked)
let ciContent = CIRcvGroupEvent $ RGEMemberBlocked bmId (fromLocalProfile bmp) blocked
ci <- saveRcvChatItemNoParse user (CDGroupRcv gInfo m) msg brokerTs ciContent
@@ -2630,14 +2631,11 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
toView CRMemberBlockedForAll {user, groupInfo = gInfo, byMember = m, member = bm, blocked}
Left (SEGroupMemberNotFoundByMemberId _) -> do
bm <- createUnknownMember gInfo memId
bm' <- setMemberBlocked $ groupMemberId' bm
bm' <- setMemberBlocked bm
toView $ CRUnknownMemberBlocked user gInfo m bm'
Left e -> throwError $ ChatErrorStore e
where
setMemberBlocked bmId =
withStore $ \db -> do
liftIO $ updateGroupMemberBlocked db user groupId bmId restriction
getGroupMember db vr user groupId bmId
setMemberBlocked bm = withStore' $ \db -> updateGroupMemberBlocked db user gInfo restriction bm
blocked = mrsBlocked restriction
xGrpMemCon :: GroupInfo -> GroupMember -> MemberId -> CM ()
@@ -33,9 +33,9 @@ data RcvGroupEvent
data SndGroupEvent
= SGEMemberRole {groupMemberId :: GroupMemberId, profile :: Profile, role :: GroupMemberRole}
| SGEMemberBlocked {groupMemberId :: GroupMemberId, profile :: Profile, blocked :: Bool} -- CRMemberBlockedForAllUser
| SGEMemberBlocked {groupMemberId :: GroupMemberId, profile :: Profile, blocked :: Bool} -- CRMembersBlockedForAllUser
| SGEUserRole {role :: GroupMemberRole}
| SGEMemberDeleted {groupMemberId :: GroupMemberId, profile :: Profile} -- CRUserDeletedMember
| SGEMemberDeleted {groupMemberId :: GroupMemberId, profile :: Profile} -- CRUserDeletedMembers
| SGEUserLeft -- CRLeftMemberUser
| SGEGroupUpdated {groupProfile :: GroupProfile} -- CRGroupUpdated
deriving (Show)
+4 -3
View File
@@ -2062,8 +2062,8 @@ updateGroupMemberSettings db User {userId} gId gMemberId GroupMemberSettings {sh
|]
(BI showMessages, currentTs, userId, gId, gMemberId)
updateGroupMemberBlocked :: DB.Connection -> User -> GroupId -> GroupMemberId -> MemberRestrictionStatus -> IO ()
updateGroupMemberBlocked db User {userId} gId gMemberId memberBlocked = do
updateGroupMemberBlocked :: DB.Connection -> User -> GroupInfo -> MemberRestrictionStatus -> GroupMember -> IO GroupMember
updateGroupMemberBlocked db User {userId} GroupInfo {groupId} mrs m@GroupMember {groupMemberId} = do
currentTs <- getCurrentTime
DB.execute
db
@@ -2072,7 +2072,8 @@ updateGroupMemberBlocked db User {userId} gId gMemberId memberBlocked = do
SET member_restriction = ?, updated_at = ?
WHERE user_id = ? AND group_id = ? AND group_member_id = ?
|]
(memberBlocked, currentTs, userId, gId, gMemberId)
(mrs, currentTs, userId, groupId, groupMemberId)
pure m {blockedByAdmin = mrsBlocked mrs}
getXGrpMemIntroContDirect :: DB.Connection -> User -> Contact -> IO (Maybe (Int64, XGrpMemIntroCont))
getXGrpMemIntroContDirect db User {userId} Contact {contactId} = do
+13 -13
View File
@@ -220,7 +220,9 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe
CRUserAcceptedGroupSent u _g _ -> ttyUser u [] -- [ttyGroup' g <> ": joining the group..."]
CRGroupLinkConnecting u g _ -> ttyUser u [ttyGroup' g <> ": joining the group..."]
CRBusinessLinkConnecting u g _ _ -> ttyUser u [ttyGroup' g <> ": joining the group..."]
CRUserDeletedMember u g m -> ttyUser u [ttyGroup' g <> ": you removed " <> ttyMember m <> " from the group"]
CRUserDeletedMembers u g members -> case members of
[m] -> ttyUser u [ttyGroup' g <> ": you removed " <> ttyMember m <> " from the group"]
mems' -> ttyUser u [ttyGroup' g <> ": you removed " <> sShow (length mems') <> " members from the group"]
CRLeftMemberUser u g -> ttyUser u $ [ttyGroup' g <> ": you left the group"] <> groupPreserved g
CRUnknownMemberCreated u g fwdM um -> ttyUser u [ttyGroup' g <> ": " <> ttyMember fwdM <> " forwarded a message from an unknown member, creating unknown member record " <> ttyMember um]
CRUnknownMemberBlocked u g byM um -> ttyUser u [ttyGroup' g <> ": " <> ttyMember byM <> " blocked an unknown member, creating unknown member record " <> ttyMember um]
@@ -301,9 +303,9 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe
CRJoinedGroupMemberConnecting u g host m -> ttyUser u [ttyGroup' g <> ": " <> ttyMember host <> " added " <> ttyFullMember m <> " to the group (connecting...)"]
CRConnectedToGroupMember u g m _ -> ttyUser u [ttyGroup' g <> ": " <> connectedMember m <> " is connected"]
CRMemberRole u g by m r r' -> ttyUser u $ viewMemberRoleChanged g by m r r'
CRMemberRoleUser u g m r r' -> ttyUser u $ viewMemberRoleUserChanged g m r r'
CRMembersRoleUser u g members r' -> ttyUser u $ viewMemberRoleUserChanged g members r'
CRMemberBlockedForAll u g by m blocked -> ttyUser u $ viewMemberBlockedForAll g by m blocked
CRMemberBlockedForAllUser u g m blocked -> ttyUser u $ viewMemberBlockedForAllUser g m blocked
CRMembersBlockedForAllUser u g members blocked -> ttyUser u $ viewMembersBlockedForAllUser g members blocked
CRDeletedMemberUser u g by -> ttyUser u $ [ttyGroup' g <> ": " <> ttyMember by <> " removed you from the group"] <> groupPreserved g
CRDeletedMember u g by m -> ttyUser u [ttyGroup' g <> ": " <> ttyMember by <> " removed " <> ttyMember m <> " from the group"]
CRLeftMember u g m -> ttyUser u [ttyGroup' g <> ": " <> ttyMember m <> " left the group"]
@@ -1109,21 +1111,19 @@ viewMemberRoleChanged g@GroupInfo {membership} by m r r'
memId = groupMemberId' m
view s = [ttyGroup' g <> ": " <> ttyMember by <> " changed " <> s <> " from " <> showRole r <> " to " <> showRole r']
viewMemberRoleUserChanged :: GroupInfo -> GroupMember -> GroupMemberRole -> GroupMemberRole -> [StyledString]
viewMemberRoleUserChanged g@GroupInfo {membership} m r r'
| r == r' = [ttyGroup' g <> ": member role did not change"]
| groupMemberId' membership == groupMemberId' m = view "your role"
| otherwise = view $ "the role of " <> ttyMember m
where
view s = [ttyGroup' g <> ": you changed " <> s <> " from " <> showRole r <> " to " <> showRole r']
viewMemberRoleUserChanged :: GroupInfo -> [GroupMember] -> GroupMemberRole -> [StyledString]
viewMemberRoleUserChanged g members r = case members of
[m] -> [ttyGroup' g <> ": you changed the role of " <> ttyMember m <> " to " <> showRole r]
mems' -> [ttyGroup' g <> ": you changed the role of " <> sShow (length mems') <> " members to " <> showRole r]
viewMemberBlockedForAll :: GroupInfo -> GroupMember -> GroupMember -> Bool -> [StyledString]
viewMemberBlockedForAll g by m blocked =
[ttyGroup' g <> ": " <> ttyMember by <> " " <> (if blocked then "blocked" else "unblocked") <> " " <> ttyMember m]
viewMemberBlockedForAllUser :: GroupInfo -> GroupMember -> Bool -> [StyledString]
viewMemberBlockedForAllUser g m blocked =
[ttyGroup' g <> ": you " <> (if blocked then "blocked" else "unblocked") <> " " <> ttyMember m]
viewMembersBlockedForAllUser :: GroupInfo -> [GroupMember] -> Bool -> [StyledString]
viewMembersBlockedForAllUser g members blocked = case members of
[m] -> [ttyGroup' g <> ": you " <> (if blocked then "blocked" else "unblocked") <> " " <> ttyMember m]
mems' -> [ttyGroup' g <> ": you " <> (if blocked then "blocked" else "unblocked") <> " " <> sShow (length mems') <> " members"]
showRole :: GroupMemberRole -> StyledString
showRole = plain . strEncode