diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index e64553af98..71b57c72b2 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -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} diff --git a/src/Simplex/Chat/Library/Commands.hs b/src/Simplex/Chat/Library/Commands.hs index 624f6a6dc1..f44dca9026 100644 --- a/src/Simplex/Chat/Library/Commands.hs +++ b/src/Simplex/Chat/Library/Commands.hs @@ -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), diff --git a/src/Simplex/Chat/Library/Internal.hs b/src/Simplex/Chat/Library/Internal.hs index 4a62c4ccb6..eba1bf169f 100644 --- a/src/Simplex/Chat/Library/Internal.hs +++ b/src/Simplex/Chat/Library/Internal.hs @@ -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 diff --git a/src/Simplex/Chat/Library/Subscriber.hs b/src/Simplex/Chat/Library/Subscriber.hs index 44ad4ccc85..087d49e49a 100644 --- a/src/Simplex/Chat/Library/Subscriber.hs +++ b/src/Simplex/Chat/Library/Subscriber.hs @@ -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 () diff --git a/src/Simplex/Chat/Messages/CIContent/Events.hs b/src/Simplex/Chat/Messages/CIContent/Events.hs index 74f7d94399..054530e06f 100644 --- a/src/Simplex/Chat/Messages/CIContent/Events.hs +++ b/src/Simplex/Chat/Messages/CIContent/Events.hs @@ -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) diff --git a/src/Simplex/Chat/Store/Groups.hs b/src/Simplex/Chat/Store/Groups.hs index 67722ebd0f..a1ce3ab269 100644 --- a/src/Simplex/Chat/Store/Groups.hs +++ b/src/Simplex/Chat/Store/Groups.hs @@ -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 diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index a8c2d215a8..7a20cb2fb0 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -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 diff --git a/tests/Bots/DirectoryTests.hs b/tests/Bots/DirectoryTests.hs index 5bdc379cbf..2a9ad30dd2 100644 --- a/tests/Bots/DirectoryTests.hs +++ b/tests/Bots/DirectoryTests.hs @@ -122,7 +122,7 @@ testDirectoryService ps = bob <# "SimpleX-Directory> You must grant directory service admin role to register the group" bob ##> "/mr PSA SimpleX-Directory admin" -- putStrLn "*** discover service joins group and creates the link for profile" - bob <## "#PSA: you changed the role of SimpleX-Directory from member to admin" + bob <## "#PSA: you changed the role of SimpleX-Directory to admin" bob <# "SimpleX-Directory> Joining the group PSA…" bob <## "#PSA: SimpleX-Directory joined the group" bob <# "SimpleX-Directory> Joined the group PSA, creating the link…" @@ -579,7 +579,7 @@ testDelistedRoleChanges ps = groupFoundN 3 cath "privacy" -- de-listed if service role changed bob ##> "/mr privacy SimpleX-Directory member" - bob <## "#privacy: you changed the role of SimpleX-Directory from admin to member" + bob <## "#privacy: you changed the role of SimpleX-Directory to member" cath <## "#privacy: bob changed the role of SimpleX-Directory from admin to member" bob <# "SimpleX-Directory> SimpleX-Directory role in the group ID 1 (privacy) is changed to member." bob <## "" @@ -588,7 +588,7 @@ testDelistedRoleChanges ps = groupNotFound cath "privacy" -- re-listed if service role changed back without profile changes cath ##> "/mr privacy SimpleX-Directory admin" - cath <## "#privacy: you changed the role of SimpleX-Directory from member to admin" + cath <## "#privacy: you changed the role of SimpleX-Directory to admin" bob <## "#privacy: cath changed the role of SimpleX-Directory from member to admin" bob <# "SimpleX-Directory> SimpleX-Directory role in the group ID 1 (privacy) is changed to admin." bob <## "" @@ -597,7 +597,7 @@ testDelistedRoleChanges ps = groupFoundN 3 cath "privacy" -- de-listed if owner role changed cath ##> "/mr privacy bob admin" - cath <## "#privacy: you changed the role of bob from owner to admin" + cath <## "#privacy: you changed the role of bob to admin" bob <## "#privacy: cath changed your role from owner to admin" bob <# "SimpleX-Directory> Your role in the group ID 1 (privacy) is changed to admin." bob <## "" @@ -606,7 +606,7 @@ testDelistedRoleChanges ps = groupNotFound cath "privacy" -- re-listed if owner role changed back without profile changes cath ##> "/mr privacy bob owner" - cath <## "#privacy: you changed the role of bob from admin to owner" + cath <## "#privacy: you changed the role of bob to owner" bob <## "#privacy: cath changed your role from admin to owner" bob <# "SimpleX-Directory> Your role in the group ID 1 (privacy) is changed to owner." bob <## "" @@ -627,7 +627,7 @@ testNotDelistedMemberRoleChanged ps = cath <## "use @SimpleX-Directory to send messages" groupFoundN 3 cath "privacy" bob ##> "/mr privacy cath member" - bob <## "#privacy: you changed the role of cath from owner to member" + bob <## "#privacy: you changed the role of cath to member" cath <## "#privacy: bob changed your role from owner to member" groupFoundN 3 cath "privacy" @@ -641,11 +641,11 @@ testNotSentApprovalBadRoles ps = submitGroup bob "privacy" "Privacy" welcomeWithLink <- groupAccepted bob "privacy" bob ##> "/mr privacy SimpleX-Directory member" - bob <## "#privacy: you changed the role of SimpleX-Directory from admin to member" + bob <## "#privacy: you changed the role of SimpleX-Directory to member" updateProfileWithLink bob "privacy" welcomeWithLink 1 bob <# "SimpleX-Directory> You must grant directory service admin role to register the group" bob ##> "/mr privacy SimpleX-Directory admin" - bob <## "#privacy: you changed the role of SimpleX-Directory from member to admin" + bob <## "#privacy: you changed the role of SimpleX-Directory to admin" bob <# "SimpleX-Directory> SimpleX-Directory role in the group ID 1 (privacy) is changed to admin." bob <## "" bob <## "The group is submitted for approval." @@ -666,14 +666,14 @@ testNotApprovedBadRoles ps = updateProfileWithLink bob "privacy" welcomeWithLink 1 notifySuperUser superUser bob "privacy" "Privacy" welcomeWithLink 1 bob ##> "/mr privacy SimpleX-Directory member" - bob <## "#privacy: you changed the role of SimpleX-Directory from admin to member" + bob <## "#privacy: you changed the role of SimpleX-Directory to member" let approve = "/approve 1:privacy 1" superUser #> ("@SimpleX-Directory " <> approve) superUser <# ("SimpleX-Directory> > " <> approve) superUser <## " Group is not approved: SimpleX-Directory is not an admin." groupNotFound cath "privacy" bob ##> "/mr privacy SimpleX-Directory admin" - bob <## "#privacy: you changed the role of SimpleX-Directory from member to admin" + bob <## "#privacy: you changed the role of SimpleX-Directory to admin" bob <# "SimpleX-Directory> SimpleX-Directory role in the group ID 1 (privacy) is changed to admin." bob <## "" bob <## "The group is submitted for approval." @@ -940,7 +940,7 @@ testListUserGroups ps = -- with de-listed group groupFound cath "anonymity" cath ##> "/mr anonymity SimpleX-Directory member" - cath <## "#anonymity: you changed the role of SimpleX-Directory from admin to member" + cath <## "#anonymity: you changed the role of SimpleX-Directory to member" cath <# "SimpleX-Directory> SimpleX-Directory role in the group ID 1 (anonymity) is changed to member." cath <## "" cath <## "The group is no longer listed in the directory." diff --git a/tests/ChatTests/Groups.hs b/tests/ChatTests/Groups.hs index 6625fb8094..14539ac219 100644 --- a/tests/ChatTests/Groups.hs +++ b/tests/ChatTests/Groups.hs @@ -173,7 +173,8 @@ chatGroupTests = do it "messages are fully deleted" testBlockForAllFullDelete it "another admin can unblock" testBlockForAllAnotherAdminUnblocks it "member was blocked before joining group" testBlockForAllBeforeJoining - it "can't repeat block, unblock" testBlockForAllCantRepeat + it "repeat block, unblock" testBlockForAllRepeat + it "block multiple members" testBlockForAllMultipleMembers describe "group member inactivity" $ do it "mark member inactive on reaching quota" testGroupMemberInactive describe "group member reports" $ do @@ -265,7 +266,7 @@ testGroupShared alice bob cath checkMessages = do -- test observer role alice ##> "/mr team bob observer" concurrentlyN_ - [ alice <## "#team: you changed the role of bob from admin to observer", + [ alice <## "#team: you changed the role of bob to observer", bob <## "#team: alice changed your role from admin to observer", cath <## "#team: alice changed the role of bob from admin to observer" ] @@ -280,7 +281,7 @@ testGroupShared alice bob cath checkMessages = do ] alice ##> "/mr team bob admin" concurrentlyN_ - [ alice <## "#team: you changed the role of bob from observer to admin", + [ alice <## "#team: you changed the role of bob to admin", bob <## "#team: alice changed your role from observer to admin", cath <## "#team: alice changed the role of bob from observer to admin" ] @@ -1460,7 +1461,7 @@ testUpdateMemberRole = alice <## "to add members use /a team or /create link #team" addMember "team" alice bob GRAdmin alice ##> "/mr team bob member" - alice <## "#team: you changed the role of bob from admin to member" + alice <## "#team: you changed the role of bob to member" bob <## "#team: alice invites you to join the group as member" bob <## "use /j team to accept" bob ##> "/j team" @@ -1472,7 +1473,7 @@ testUpdateMemberRole = bob <## "#team: you have insufficient permissions for this action, the required role is admin" alice ##> "/mr team bob admin" concurrently_ - (alice <## "#team: you changed the role of bob from member to admin") + (alice <## "#team: you changed the role of bob to admin") (bob <## "#team: alice changed your role from member to admin") bob ##> "/a team cath owner" bob <## "#team: you have insufficient permissions for this action, the required role is owner" @@ -1488,13 +1489,7 @@ testUpdateMemberRole = alice <## "#team: new member cath is connected" ] alice ##> "/mr team alice admin" - concurrentlyN_ - [ alice <## "#team: you changed your role from owner to admin", - bob <## "#team: alice changed the role from owner to admin", - cath <## "#team: alice changed the role from owner to admin" - ] - alice ##> "/d #team" - alice <## "#team: you have insufficient permissions for this action, the required role is owner" + alice <## "bad chat command: can't change role for self" testGroupDescription :: HasCallStack => TestParams -> IO () testGroupDescription = testChat4 aliceProfile bobProfile cathProfile danProfile $ \alice bob cath dan -> do @@ -1579,7 +1574,7 @@ testGroupModerate = -- disableFullDeletion3 "team" alice bob cath alice ##> "/mr team cath member" concurrentlyN_ - [ alice <## "#team: you changed the role of cath from admin to member", + [ alice <## "#team: you changed the role of cath to member", bob <## "#team: alice changed the role of cath from admin to member", cath <## "#team: alice changed your role from admin to member" ] @@ -1662,7 +1657,7 @@ testGroupModerateFullDelete = -- disableFullDeletion3 "team" alice bob cath alice ##> "/mr team cath member" concurrentlyN_ - [ alice <## "#team: you changed the role of cath from admin to member", + [ alice <## "#team: you changed the role of cath to member", bob <## "#team: alice changed the role of cath from admin to member", cath <## "#team: alice changed your role from admin to member" ] @@ -2691,7 +2686,7 @@ testGroupLinkMemberRole = bob <## "#team: you don't have permission to send messages" alice ##> "/mr #team bob member" - alice <## "#team: you changed the role of bob from observer to member" + alice <## "#team: you changed the role of bob to member" bob <## "#team: alice changed your role from observer to member" bob #> "#team hey now" @@ -2721,7 +2716,7 @@ testGroupLinkMemberRole = cath <## "#team: you don't have permission to send messages" alice ##> "/mr #team cath admin" - alice <## "#team: you changed the role of cath from observer to admin" + alice <## "#team: you changed the role of cath to admin" cath <## "#team: alice changed your role from observer to admin" bob <## "#team: alice changed the role of cath from observer to admin" @@ -2730,7 +2725,7 @@ testGroupLinkMemberRole = bob <# "#team cath> hey" cath ##> "/mr #team bob admin" - cath <## "#team: you changed the role of bob from member to admin" + cath <## "#team: you changed the role of bob to admin" bob <## "#team: cath changed your role from member to admin" alice <## "#team: cath changed the role of bob from member to admin" @@ -4132,14 +4127,14 @@ testGroupMsgForwardReport = alice ##> "/mr team bob moderator" concurrentlyN_ - [ alice <## "#team: you changed the role of bob from admin to moderator", + [ alice <## "#team: you changed the role of bob to moderator", bob <## "#team: alice changed your role from admin to moderator", cath <## "#team: alice changed the role of bob from admin to moderator" ] alice ##> "/mr team cath member" concurrentlyN_ - [ alice <## "#team: you changed the role of cath from admin to member", + [ alice <## "#team: you changed the role of cath to member", bob <## "#team: alice changed the role of cath from admin to member", cath <## "#team: alice changed your role from admin to member" ] @@ -4157,7 +4152,7 @@ testGroupMsgForwardReport = alice ##> "/mr team bob member" concurrentlyN_ - [ alice <## "#team: you changed the role of bob from moderator to member", + [ alice <## "#team: you changed the role of bob to member", bob <## "#team: alice changed your role from moderator to member", cath <## "#team: alice changed the role of bob from moderator to member" ] @@ -4315,7 +4310,7 @@ testGroupMsgForwardChangeRole = setupGroupForwarding3 "team" alice bob cath cath ##> "/mr #team bob member" - cath <## "#team: you changed the role of bob from admin to member" + cath <## "#team: you changed the role of bob to member" alice <## "#team: cath changed the role of bob from admin to member" bob <## "#team: cath changed your role from admin to member" -- TODO show as forwarded @@ -5942,19 +5937,13 @@ testBlockForAllBeforeJoining = cc <## "#team: alice added dan (Daniel) to the group (connecting...)" cc <## "#team: new member dan is connected" -testBlockForAllCantRepeat :: HasCallStack => TestParams -> IO () -testBlockForAllCantRepeat = +testBlockForAllRepeat :: HasCallStack => TestParams -> IO () +testBlockForAllRepeat = testChat3 aliceProfile bobProfile cathProfile $ \alice bob cath -> do createGroup3 "team" alice bob cath -- disableFullDeletion3 "team" alice bob cath - alice ##> "/unblock for all #team bob" - alice <## "bad chat command: already unblocked" - - cath ##> "/unblock for all #team bob" - cath <## "bad chat command: already unblocked" - bob #> "#team 1" [alice, cath] *<# "#team bob> 1" @@ -5964,10 +5953,10 @@ testBlockForAllCantRepeat = bob "/block for all #team bob" - alice <## "bad chat command: already blocked" + alice <## "#team: you blocked bob" cath ##> "/block for all #team bob" - cath <## "bad chat command: already blocked" + cath <## "#team: you blocked bob" bob #> "#team 2" alice <# "#team bob> 2 [blocked by admin] " @@ -5979,16 +5968,92 @@ testBlockForAllCantRepeat = bob "/unblock for all #team bob" - alice <## "bad chat command: already unblocked" + alice <## "#team: you unblocked bob" cath ##> "/unblock for all #team bob" - cath <## "bad chat command: already unblocked" + cath <## "#team: you unblocked bob" bob #> "#team 3" [alice, cath] *<# "#team bob> 3" bob #$> ("/_get chat #1 count=3", chat, [(1, "1"), (1, "2"), (1, "3")]) +testBlockForAllMultipleMembers :: HasCallStack => TestParams -> IO () +testBlockForAllMultipleMembers = + testChat4 aliceProfile bobProfile cathProfile danProfile $ + \alice bob cath dan -> do + createGroup3 "team" alice bob cath + + connectUsers alice dan + addMember "team" alice dan GRMember + dan ##> "/j team" + concurrentlyN_ + [ alice <## "#team: dan joined the group", + do + dan <## "#team: you joined the group" + dan + <### [ "#team: member bob (Bob) is connected", + "#team: member cath (Catherine) is connected" + ], + do + bob <## "#team: alice added dan (Daniel) to the group (connecting...)" + bob <## "#team: new member dan is connected", + do + cath <## "#team: alice added dan (Daniel) to the group (connecting...)" + cath <## "#team: new member dan is connected" + ] + + -- lower roles to for batch block to be allowed (can't batch block if admins are selected) + alice ##> "/mr team bob member" + concurrentlyN_ + [ alice <## "#team: you changed the role of bob to member", + bob <## "#team: alice changed your role from admin to member", + cath <## "#team: alice changed the role of bob from admin to member", + dan <## "#team: alice changed the role of bob from admin to member" + ] + alice ##> "/mr team cath member" + concurrentlyN_ + [ alice <## "#team: you changed the role of cath to member", + bob <## "#team: alice changed the role of cath from admin to member", + cath <## "#team: alice changed your role from admin to member", + dan <## "#team: alice changed the role of cath from admin to member" + ] + + bob #> "#team 1" + [alice, cath, dan] *<# "#team bob> 1" + + cath #> "#team 2" + [alice, bob, dan] *<# "#team cath> 2" + + alice ##> "/_block #1 2,3 blocked=on" + alice <## "#team: you blocked 2 members" + dan <## "#team: alice blocked bob" + dan <## "#team: alice blocked cath" + bob "#team 3" + [alice, dan] *<# "#team bob> 3 [blocked by admin] " + cath <# "#team bob> 3" + + cath #> "#team 4" + [alice, dan] *<# "#team cath> 4 [blocked by admin] " + bob <# "#team cath> 4" + + alice ##> "/_block #1 2,3 blocked=off" + alice <## "#team: you unblocked 2 members" + dan <## "#team: alice unblocked bob" + dan <## "#team: alice unblocked cath" + bob "#team 5" + [alice, cath, dan] *<# "#team bob> 5" + + cath #> "#team 6" + [alice, bob, dan] *<# "#team cath> 6" + testGroupMemberInactive :: HasCallStack => TestParams -> IO () testGroupMemberInactive ps = do withSmpServer' serverCfg' $ do @@ -6067,13 +6132,13 @@ testGroupMemberReports = -- disableFullDeletion3 "jokes" alice bob cath alice ##> "/mr jokes bob moderator" concurrentlyN_ - [ alice <## "#jokes: you changed the role of bob from admin to moderator", + [ alice <## "#jokes: you changed the role of bob to moderator", bob <## "#jokes: alice changed your role from admin to moderator", cath <## "#jokes: alice changed the role of bob from admin to moderator" ] alice ##> "/mr jokes cath member" concurrentlyN_ - [ alice <## "#jokes: you changed the role of cath from admin to member", + [ alice <## "#jokes: you changed the role of cath to member", bob <## "#jokes: alice changed the role of cath from admin to member", cath <## "#jokes: alice changed your role from admin to member" ] diff --git a/tests/ChatTests/Profiles.hs b/tests/ChatTests/Profiles.hs index 4ab5e8fbd3..5d2b9f5ba8 100644 --- a/tests/ChatTests/Profiles.hs +++ b/tests/ChatTests/Profiles.hs @@ -773,7 +773,7 @@ testBusinessUpdateProfiles = withTestOutput $ testChat4 businessProfile alicePro biz <# "#alisa alisa_1> hello again" -- customer can invite members too, if business allows biz ##> "/mr alisa alisa_1 admin" - biz <## "#alisa: you changed the role of alisa_1 from member to admin" + biz <## "#alisa: you changed the role of alisa_1 to admin" alice <## "#biz: biz_1 changed your role from member to admin" connectUsers alice bob alice ##> "/a #biz bob"