diff --git a/changelog.d/6-federation/access-update-remove-remotes b/changelog.d/6-federation/access-update-remove-remotes new file mode 100644 index 00000000000..448f53770ac --- /dev/null +++ b/changelog.d/6-federation/access-update-remove-remotes @@ -0,0 +1 @@ +Remove remote guests as well as local ones when "Guests and services" is disabled in a group conversation, and propagate removal to remote members. diff --git a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/ConversationUpdate.hs b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/ConversationUpdate.hs index 1535c7c458e..e73413673e8 100644 --- a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/ConversationUpdate.hs +++ b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/ConversationUpdate.hs @@ -70,5 +70,5 @@ testObject_ConversationUpdate2 = cuConvId = Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000006")), cuAlreadyPresentUsers = [chad, dee], - cuAction = ConversationActionRemoveMember (qAlice) + cuAction = ConversationActionRemoveMembers (pure qAlice) } diff --git a/libs/wire-api-federation/test/golden/testObject_ConversationUpdate2.json b/libs/wire-api-federation/test/golden/testObject_ConversationUpdate2.json index 3a0490a2535..e398d32ebce 100644 --- a/libs/wire-api-federation/test/golden/testObject_ConversationUpdate2.json +++ b/libs/wire-api-federation/test/golden/testObject_ConversationUpdate2.json @@ -9,11 +9,13 @@ ], "time": "1864-04-12T12:22:43.673Z", "action": { - "tag": "ConversationActionRemoveMember", - "contents": { - "domain": "golden.example.com", - "id": "00000000-0000-0000-0000-000100004007" - } + "tag": "ConversationActionRemoveMembers", + "contents": [ + { + "domain": "golden.example.com", + "id": "00000000-0000-0000-0000-000100004007" + } + ] }, "conv_id": "00000000-0000-0000-0000-000100000006" } \ No newline at end of file diff --git a/libs/wire-api/src/Wire/API/Conversation/Action.hs b/libs/wire-api/src/Wire/API/Conversation/Action.hs index c96a77bc3ea..855376d8528 100644 --- a/libs/wire-api/src/Wire/API/Conversation/Action.hs +++ b/libs/wire-api/src/Wire/API/Conversation/Action.hs @@ -38,7 +38,7 @@ import Wire.API.Util.Aeson (CustomEncoded (..)) -- Used to send notifications to users and to remote backends. data ConversationAction = ConversationActionAddMembers (NonEmpty (Qualified UserId)) RoleName - | ConversationActionRemoveMember (Qualified UserId) + | ConversationActionRemoveMembers (NonEmpty (Qualified UserId)) | ConversationActionRename ConversationRename | ConversationActionMessageTimerUpdate ConversationMessageTimerUpdate | ConversationActionReceiptModeUpdate ConversationReceiptModeUpdate @@ -57,9 +57,9 @@ conversationActionToEvent :: conversationActionToEvent now quid qcnv (ConversationActionAddMembers newMembers role) = Event MemberJoin qcnv quid now $ EdMembersJoin $ SimpleMembers (map (`SimpleMember` role) (toList newMembers)) -conversationActionToEvent now quid qcnv (ConversationActionRemoveMember removedMember) = +conversationActionToEvent now quid qcnv (ConversationActionRemoveMembers removedMembers) = Event MemberLeave qcnv quid now $ - EdMembersLeave (QualifiedUserIdList [removedMember]) + EdMembersLeave (QualifiedUserIdList (toList removedMembers)) conversationActionToEvent now quid qcnv (ConversationActionRename rename) = Event ConvRename qcnv quid now (EdConvRename rename) conversationActionToEvent now quid qcnv (ConversationActionMessageTimerUpdate update) = @@ -74,8 +74,8 @@ conversationActionToEvent now quid qcnv (ConversationActionAccessUpdate update) conversationActionTag :: Qualified UserId -> ConversationAction -> Action conversationActionTag _ (ConversationActionAddMembers _ _) = AddConversationMember -conversationActionTag qusr (ConversationActionRemoveMember victim) - | qusr == victim = LeaveConversation +conversationActionTag qusr (ConversationActionRemoveMembers victims) + | pure qusr == victims = LeaveConversation | otherwise = RemoveConversationMember conversationActionTag _ (ConversationActionRename _) = ModifyConversationName conversationActionTag _ (ConversationActionMessageTimerUpdate _) = ModifyConversationMessageTimer diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index c7476ccfd75..8e63653b402 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -133,8 +133,8 @@ onConversationUpdated requestingDomain cu = do let localUsers = getLocalUsers localDomain toAdd Data.addLocalMembersToRemoteConv qconvId localUsers pure localUsers - ConversationActionRemoveMember toRemove -> do - let localUsers = getLocalUsers localDomain (pure toRemove) + ConversationActionRemoveMembers toRemove -> do + let localUsers = getLocalUsers localDomain toRemove Data.removeLocalMembersFromRemoteConv qconvId localUsers pure [] ConversationActionRename _ -> pure [] @@ -175,7 +175,8 @@ leaveConversation requestingDomain lc = do . runMaybeT . void . API.updateLocalConversation lcnv leaver Nothing - . ConversationActionRemoveMember + . ConversationActionRemoveMembers + . pure $ leaver -- FUTUREWORK: report errors to the originating backend diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index 7b1976d83db..ad643767047 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -230,7 +230,6 @@ performAccessUpdateAction :: performAccessUpdateAction qusr conv target = do lcnv <- qualifyLocal (Data.convId conv) guard $ Data.convAccessData conv /= target - let (bots, users) = localBotsAndUsers (Data.convLocalMembers conv) -- Remove conversation codes if CodeAccess is revoked when ( CodeAccess `elem` Data.convAccess conv @@ -239,54 +238,52 @@ performAccessUpdateAction qusr conv target = do $ lift $ do key <- mkKey (tUnqualified lcnv) Data.deleteCode key ReusableCode - -- Depending on a variety of things, some bots and users have to be - -- removed from the conversation. We keep track of them using 'State'. - (newUsers, newBots) <- lift . flip execStateT (users, bots) $ do - -- We might have to remove non-activated members - -- TODO(akshay): Remove Ord instance for AccessRole. It is dangerous - -- to make assumption about the order of roles and implement policy - -- based on those assumptions. - when - ( Data.convAccessRole conv > ActivatedAccessRole - && cupAccessRole target <= ActivatedAccessRole - ) - $ do - mIds <- map lmId <$> use usersL - activated <- fmap User.userId <$> lift (lookupActivatedUsers mIds) - let isActivated user = lmId user `elem` activated - usersL %= filter isActivated - -- In a team-only conversation we also want to remove bots and guests - case (cupAccessRole target, Data.convTeam conv) of - (TeamAccessRole, Just tid) -> do - currentUsers <- use usersL - onlyTeamUsers <- flip filterM currentUsers $ \user -> - lift $ isJust <$> Data.teamMember tid (lmId user) - assign usersL onlyTeamUsers - botsL .= [] - _ -> return () + + -- Determine bots and members to be removed + let filterBotsAndMembers = filterActivated >=> filterTeammates + let current = convBotsAndMembers conv -- initial bots and members + desired <- lift $ filterBotsAndMembers current -- desired bots and members + let toRemove = bmDiff current desired -- bots and members to be removed + -- Update Cassandra lift $ Data.updateConversationAccess (tUnqualified lcnv) target - -- Remove users and bots lift . void . forkIO $ do - let removedUsers = map lmId users \\ map lmId newUsers - removedBots = map botMemId bots \\ map botMemId newBots - mapM_ (deleteBot (tUnqualified lcnv)) removedBots - for_ (nonEmpty removedUsers) $ \victims -> do - -- FUTUREWORK: deal with remote members, too, see updateLocalConversation (Jira SQCORE-903) - Data.removeLocalMembersFromLocalConv (tUnqualified lcnv) victims - now <- liftIO getCurrentTime - let qvictims = QualifiedUserIdList . map (qUntagged . qualifyAs lcnv) . toList $ victims - let e = Event MemberLeave (qUntagged lcnv) qusr now (EdMembersLeave qvictims) - -- push event to all clients, including zconn - -- since updateConversationAccess generates a second (member removal) event here - traverse_ push1 $ - newPushLocal ListComplete (qUnqualified qusr) (ConvEvent e) (recipient <$> users) - void . forkIO $ void $ External.deliver (newBots `zip` repeat e) + -- Remove bots + traverse_ (deleteBot (tUnqualified lcnv)) (map botMemId (toList (bmBots toRemove))) + + -- Update current bots and members + let current' = current {bmBots = bmBots desired} + + -- Remove users and notify everyone + void . for_ (nonEmpty (bmQualifiedMembers lcnv toRemove)) $ \usersToRemove -> do + let action = ConversationActionRemoveMembers usersToRemove + void . runMaybeT $ performAction qusr conv action + notifyConversationMetadataUpdate qusr Nothing lcnv current' action where - usersL :: Lens' ([LocalMember], [BotMember]) [LocalMember] - usersL = _1 - botsL :: Lens' ([LocalMember], [BotMember]) [BotMember] - botsL = _2 + filterActivated :: BotsAndMembers -> Galley BotsAndMembers + filterActivated bm + | ( Data.convAccessRole conv > ActivatedAccessRole + && cupAccessRole target <= ActivatedAccessRole + ) = do + activated <- map User.userId <$> lookupActivatedUsers (toList (bmLocals bm)) + -- FUTUREWORK: should we also remove non-activated remote users? + pure $ bm {bmLocals = Set.fromList activated} + | otherwise = pure bm + + filterTeammates :: BotsAndMembers -> Galley BotsAndMembers + filterTeammates bm = do + -- In a team-only conversation we also want to remove bots and guests + case (cupAccessRole target, Data.convTeam conv) of + (TeamAccessRole, Just tid) -> do + onlyTeamUsers <- flip filterM (toList (bmLocals bm)) $ \user -> + isJust <$> Data.teamMember tid user + pure $ + BotsAndMembers + { bmLocals = Set.fromList onlyTeamUsers, + bmBots = mempty, + bmRemotes = mempty + } + _ -> pure bm updateConversationReceiptMode :: UserId -> @@ -398,7 +395,7 @@ updateLocalConversation lcnv qusr con action = do qusr con lcnv - (convTargets conv <> extraTargets) + (convBotsAndMembers conv <> extraTargets) action' getUpdateResult :: Functor m => MaybeT m a -> m (UpdateResult a) @@ -410,12 +407,12 @@ performAction :: Qualified UserId -> Data.Conversation -> ConversationAction -> - MaybeT Galley (NotificationTargets, ConversationAction) + MaybeT Galley (BotsAndMembers, ConversationAction) performAction qusr conv action = case action of ConversationActionAddMembers members role -> performAddMemberAction qusr conv members role - ConversationActionRemoveMember member -> do - performRemoveMemberAction conv member + ConversationActionRemoveMembers members -> do + performRemoveMemberAction conv (toList members) pure (mempty, action) ConversationActionRename rename -> lift $ do cn <- rangeChecked (cupName rename) @@ -565,7 +562,7 @@ joinConversation zusr zcon cnv access = do (qUntagged lusr) (Just zcon) lcnv - (convTargets conv <> extraTargets) + (convBotsAndMembers conv <> extraTargets) action -- | Add users to a conversation without performing any checks. Return extra @@ -574,19 +571,19 @@ addMembersToLocalConversation :: Local ConvId -> UserList UserId -> RoleName -> - MaybeT Galley (NotificationTargets, ConversationAction) + MaybeT Galley (BotsAndMembers, ConversationAction) addMembersToLocalConversation lcnv users role = do (lmems, rmems) <- lift $ Data.addMembers lcnv (fmap (,role) users) neUsers <- maybe mzero pure . nonEmpty . ulAll lcnv $ users let action = ConversationActionAddMembers neUsers role - pure (ntFromMembers lmems rmems, action) + pure (bmFromMembers lmems rmems, action) performAddMemberAction :: Qualified UserId -> Data.Conversation -> NonEmpty (Qualified UserId) -> RoleName -> - MaybeT Galley (NotificationTargets, ConversationAction) + MaybeT Galley (BotsAndMembers, ConversationAction) performAddMemberAction qusr conv invited role = do lcnv <- lift $ qualifyLocal (Data.convId conv) let newMembers = ulNewMembers lcnv conv . toUserList lcnv $ invited @@ -644,7 +641,7 @@ performAddMemberAction qusr conv invited role = do qvictim <- qUntagged <$> qualifyLocal (lmId mem) void . runMaybeT $ updateLocalConversation lcnv qvictim Nothing $ - ConversationActionRemoveMember qvictim + ConversationActionRemoveMembers (pure qvictim) else throwErrorDescriptionType @MissingLegalholdConsent checkLHPolicyConflictsRemote :: FutureWork 'LegalholdPlusFederationNotImplemented [Remote UserId] -> Galley () @@ -784,14 +781,16 @@ removeMemberFromRemoteConv (qUntagged -> qcnv) lusr _ victim performRemoveMemberAction :: Data.Conversation -> - Qualified UserId -> + [Qualified UserId] -> MaybeT Galley () -performRemoveMemberAction conv victim = do +performRemoveMemberAction conv victims = do loc <- qualifyLocal () - guard $ isConvMember loc conv victim - let removeLocal u c = Data.removeLocalMembersFromLocalConv c (pure (tUnqualified u)) - removeRemote u c = Data.removeRemoteMembersFromLocalConv c (pure u) - lift $ foldQualified loc removeLocal removeRemote victim (Data.convId conv) + let presentVictims = filter (isConvMember loc conv) victims + guard . not . null $ presentVictims + + let (lvictims, rvictims) = partitionQualified loc presentVictims + traverse_ (lift . Data.removeLocalMembersFromLocalConv (Data.convId conv)) (nonEmpty lvictims) + traverse_ (lift . Data.removeRemoteMembersFromLocalConv (Data.convId conv)) (nonEmpty rvictims) -- | Remove a member from a local conversation. removeMemberFromLocalConv :: @@ -805,7 +804,8 @@ removeMemberFromLocalConv lcnv lusr con victim = fmap (maybe (Left RemoveFromConversationErrorUnchanged) Right) . runMaybeT . updateLocalConversation lcnv (qUntagged lusr) con - . ConversationActionRemoveMember + . ConversationActionRemoveMembers + . pure $ victim -- OTR @@ -1008,7 +1008,7 @@ notifyConversationMetadataUpdate :: Qualified UserId -> Maybe ConnId -> Local ConvId -> - NotificationTargets -> + BotsAndMembers -> ConversationAction -> Galley Event notifyConversationMetadataUpdate quid con (qUntagged -> qcnv) targets action = do @@ -1017,7 +1017,7 @@ notifyConversationMetadataUpdate quid con (qUntagged -> qcnv) targets action = d let e = conversationActionToEvent now quid qcnv action -- notify remote participants - let rusersByDomain = indexRemote (toList (ntRemotes targets)) + let rusersByDomain = indexRemote (toList (bmRemotes targets)) void . pooledForConcurrentlyN 8 rusersByDomain $ \(qUntagged -> Qualified uids domain) -> do let req = FederatedGalley.ConversationUpdate now quid (qUnqualified qcnv) uids action rpc = @@ -1028,7 +1028,7 @@ notifyConversationMetadataUpdate quid con (qUntagged -> qcnv) targets action = d runFederatedGalley domain rpc -- notify local participants and bots - pushConversationEvent con e (ntLocals targets) (ntBots targets) $> e + pushConversationEvent con e (bmLocals targets) (bmBots targets) $> e isTypingH :: UserId ::: ConnId ::: ConvId ::: JsonRequest Public.TypingData -> Galley Response isTypingH (zusr ::: zcon ::: cnv ::: req) = do diff --git a/services/galley/src/Galley/API/Util.hs b/services/galley/src/Galley/API/Util.hs index f12365ae722..c6a940d3552 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/services/galley/src/Galley/API/Util.hs @@ -346,47 +346,60 @@ ulNewMembers loc conv (UserList locals remotes) = -- of the user id. Local user IDs get added to the local targets, remote user IDs -- to remote targets, and qualified user IDs get added to the appropriate list -- according to whether they are local or remote, by making a runtime check. -class IsNotificationTarget uid where - ntAdd :: Local x -> uid -> NotificationTargets -> NotificationTargets +class IsBotOrMember uid where + bmAdd :: Local x -> uid -> BotsAndMembers -> BotsAndMembers -data NotificationTargets = NotificationTargets - { ntLocals :: Set UserId, - ntRemotes :: Set (Remote UserId), - ntBots :: Set BotMember +data BotsAndMembers = BotsAndMembers + { bmLocals :: Set UserId, + bmRemotes :: Set (Remote UserId), + bmBots :: Set BotMember } -instance Semigroup NotificationTargets where - NotificationTargets locals1 remotes1 bots1 - <> NotificationTargets locals2 remotes2 bots2 = - NotificationTargets +bmQualifiedMembers :: Local x -> BotsAndMembers -> [Qualified UserId] +bmQualifiedMembers loc bm = + map (qUntagged . qualifyAs loc) (toList (bmLocals bm)) + <> map qUntagged (toList (bmRemotes bm)) + +instance Semigroup BotsAndMembers where + BotsAndMembers locals1 remotes1 bots1 + <> BotsAndMembers locals2 remotes2 bots2 = + BotsAndMembers (locals1 <> locals2) (remotes1 <> remotes2) (bots1 <> bots2) -instance Monoid NotificationTargets where - mempty = NotificationTargets mempty mempty mempty +instance Monoid BotsAndMembers where + mempty = BotsAndMembers mempty mempty mempty + +instance IsBotOrMember (Local UserId) where + bmAdd _ luid bm = + bm {bmLocals = Set.insert (tUnqualified luid) (bmLocals bm)} -instance IsNotificationTarget (Local UserId) where - ntAdd _ luid nt = - nt {ntLocals = Set.insert (tUnqualified luid) (ntLocals nt)} +instance IsBotOrMember (Remote UserId) where + bmAdd _ ruid bm = bm {bmRemotes = Set.insert ruid (bmRemotes bm)} -instance IsNotificationTarget (Remote UserId) where - ntAdd _ ruid nt = nt {ntRemotes = Set.insert ruid (ntRemotes nt)} +instance IsBotOrMember (Qualified UserId) where + bmAdd loc = foldQualified loc (bmAdd loc) (bmAdd loc) -instance IsNotificationTarget (Qualified UserId) where - ntAdd loc = foldQualified loc (ntAdd loc) (ntAdd loc) +bmDiff :: BotsAndMembers -> BotsAndMembers -> BotsAndMembers +bmDiff bm1 bm2 = + BotsAndMembers + { bmLocals = Set.difference (bmLocals bm1) (bmLocals bm2), + bmRemotes = Set.difference (bmRemotes bm1) (bmRemotes bm2), + bmBots = Set.difference (bmBots bm1) (bmBots bm2) + } -ntFromMembers :: [LocalMember] -> [RemoteMember] -> NotificationTargets -ntFromMembers lmems rusers = case localBotsAndUsers lmems of +bmFromMembers :: [LocalMember] -> [RemoteMember] -> BotsAndMembers +bmFromMembers lmems rusers = case localBotsAndUsers lmems of (bots, lusers) -> - NotificationTargets - { ntLocals = Set.fromList (map lmId lusers), - ntRemotes = Set.fromList (map rmId rusers), - ntBots = Set.fromList bots + BotsAndMembers + { bmLocals = Set.fromList (map lmId lusers), + bmRemotes = Set.fromList (map rmId rusers), + bmBots = Set.fromList bots } -convTargets :: Data.Conversation -> NotificationTargets -convTargets conv = ntFromMembers (Data.convLocalMembers conv) (Data.convRemoteMembers conv) +convBotsAndMembers :: Data.Conversation -> BotsAndMembers +convBotsAndMembers conv = bmFromMembers (Data.convLocalMembers conv) (Data.convRemoteMembers conv) localBotsAndUsers :: Foldable f => f LocalMember -> ([BotMember], [LocalMember]) localBotsAndUsers = foldMap botOrUser diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 5a3b6e8cb3d..c0a63c5ebd9 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -218,6 +218,7 @@ tests s = test s "join code-access conversation" postJoinCodeConvOk, test s "convert invite to code-access conversation" postConvertCodeConv, test s "convert code to team-access conversation" postConvertTeamConv, + test s "local and remote guests are removed when access changes" testAccessUpdateGuestRemoved, test s "cannot join private conversation" postJoinConvFail, test s "remove user" removeUser, test s "iUpsertOne2OneConversation" testAllOne2OneConversationRequests @@ -539,7 +540,12 @@ postMessageQualifiedLocalOwningBackendSuccess = do connectLocalQualifiedUsers aliceUnqualified (list1 bobOwningDomain [chadOwningDomain]) -- FUTUREWORK: Do this test with more than one remote domains - resp <- postConvWithRemoteUser remoteDomain (mkProfile deeRemote (Name "Dee")) aliceUnqualified [bobOwningDomain, chadOwningDomain, deeRemote] + resp <- + postConvWithRemoteUsers + remoteDomain + [mkProfile deeRemote (Name "Dee")] + aliceUnqualified + defNewConv {newConvQualifiedUsers = [bobOwningDomain, chadOwningDomain, deeRemote]} let convId = (`Qualified` owningDomain) . decodeConvId $ resp WS.bracketR2 cannon bobUnqualified chadUnqualified $ \(wsBob, wsChad) -> do @@ -607,7 +613,12 @@ postMessageQualifiedLocalOwningBackendMissingClients = do connectLocalQualifiedUsers aliceUnqualified (list1 bobOwningDomain [chadOwningDomain]) -- FUTUREWORK: Do this test with more than one remote domains - resp <- postConvWithRemoteUser remoteDomain (mkProfile deeRemote (Name "Dee")) aliceUnqualified [bobOwningDomain, chadOwningDomain, deeRemote] + resp <- + postConvWithRemoteUsers + remoteDomain + [mkProfile deeRemote (Name "Dee")] + aliceUnqualified + defNewConv {newConvQualifiedUsers = [bobOwningDomain, chadOwningDomain, deeRemote]} let convId = (`Qualified` owningDomain) . decodeConvId $ resp -- Missing Bob, chadClient2 and Dee @@ -673,7 +684,12 @@ postMessageQualifiedLocalOwningBackendRedundantAndDeletedClients = do connectLocalQualifiedUsers aliceUnqualified (list1 bobOwningDomain [chadOwningDomain]) -- FUTUREWORK: Do this test with more than one remote domains - resp <- postConvWithRemoteUser remoteDomain (mkProfile deeRemote (Name "Dee")) aliceUnqualified [bobOwningDomain, chadOwningDomain, deeRemote] + resp <- + postConvWithRemoteUsers + remoteDomain + [mkProfile deeRemote (Name "Dee")] + aliceUnqualified + defNewConv {newConvQualifiedUsers = [bobOwningDomain, chadOwningDomain, deeRemote]} let convId = (`Qualified` owningDomain) . decodeConvId $ resp WS.bracketR3 cannon bobUnqualified chadUnqualified nonMemberUnqualified $ \(wsBob, wsChad, wsNonMember) -> do @@ -760,7 +776,12 @@ postMessageQualifiedLocalOwningBackendIgnoreMissingClients = do connectLocalQualifiedUsers aliceUnqualified (list1 bobOwningDomain [chadOwningDomain]) -- FUTUREWORK: Do this test with more than one remote domains - resp <- postConvWithRemoteUser remoteDomain (mkProfile deeRemote (Name "Dee")) aliceUnqualified [bobOwningDomain, chadOwningDomain, deeRemote] + resp <- + postConvWithRemoteUsers + remoteDomain + [mkProfile deeRemote (Name "Dee")] + aliceUnqualified + defNewConv {newConvQualifiedUsers = [bobOwningDomain, chadOwningDomain, deeRemote]} let convId = (`Qualified` owningDomain) . decodeConvId $ resp let brigApi = @@ -881,7 +902,12 @@ postMessageQualifiedLocalOwningBackendFailedToSendClients = do connectLocalQualifiedUsers aliceUnqualified (list1 bobOwningDomain [chadOwningDomain]) -- FUTUREWORK: Do this test with more than one remote domains - resp <- postConvWithRemoteUser remoteDomain (mkProfile deeRemote (Name "Dee")) aliceUnqualified [bobOwningDomain, chadOwningDomain, deeRemote] + resp <- + postConvWithRemoteUsers + remoteDomain + [mkProfile deeRemote (Name "Dee")] + aliceUnqualified + defNewConv {newConvQualifiedUsers = [bobOwningDomain, chadOwningDomain, deeRemote]} let convId = (`Qualified` owningDomain) . decodeConvId $ resp WS.bracketR2 cannon bobUnqualified chadUnqualified $ \(wsBob, wsChad) -> do @@ -1148,6 +1174,68 @@ postConvertTeamConv = do -- team members (dave) can still join postJoinCodeConv dave j !!! const 200 === statusCode +testAccessUpdateGuestRemoved :: TestM () +testAccessUpdateGuestRemoved = do + -- alice, bob are in a team + (tid, alice, [bob]) <- createBindingTeamWithQualifiedMembers 2 + + -- charlie is a local guest + charlie <- randomQualifiedUser + connectUsers (qUnqualified alice) (pure (qUnqualified charlie)) + + -- dee is a remote guest + let remoteDomain = Domain "far-away.example.com" + dee <- Qualified <$> randomId <*> pure remoteDomain + let deeProfile = mkProfile dee (Name "dee") + + -- they are all in a local conversation + conv <- + responseJsonError + =<< postConvWithRemoteUsers + remoteDomain + [deeProfile] + (qUnqualified alice) + defNewConv + { newConvQualifiedUsers = [bob, charlie, dee], + newConvTeam = Just (ConvTeamInfo tid False) + } + do + -- conversation access role changes to team only + opts <- view tsGConf + (_, reqs) <- withTempMockFederator opts remoteDomain (const ()) $ do + putQualifiedAccessUpdate + (qUnqualified alice) + (cnvQualifiedId conv) + (ConversationAccessData mempty TeamAccessRole) + !!! const 200 === statusCode + + -- charlie and dee are kicked out + -- + -- note that removing users happens asynchronously, so this check should + -- happen while the mock federator is still available + WS.assertMatchN_ (5 # Second) [wsA, wsB, wsC] $ + wsAssertMembersLeave (cnvQualifiedId conv) alice [charlie, dee] + + -- dee's remote receives a notification + liftIO . assertBool "remote users are not notified" . isJust . flip find reqs $ \freq -> + let req = F.request freq + in and + [ fmap F.component req == Just F.Galley, + fmap F.path req == Just "/federation/on-conversation-updated", + fmap (fmap FederatedGalley.cuAction . eitherDecode . LBS.fromStrict . F.body) req + == Just (Right (ConversationActionRemoveMembers (charlie :| [dee]))) + ] + + -- only alice and bob remain + conv2 <- + responseJsonError + =<< getConvQualified (qUnqualified alice) (cnvQualifiedId conv) + randomId - postConvQualified alice [bob] Nothing [] Nothing Nothing !!! do - const 422 === statusCode + postConvQualified + alice + defNewConv {newConvQualifiedUsers = [bob]} + !!! do + const 422 === statusCode postConvQualifiedNonExistentUser :: TestM () postConvQualifiedNonExistentUser = do @@ -1500,17 +1591,11 @@ postConvQualifiedNonExistentUser = do bob = Qualified bobId remoteDomain charlie = Qualified charlieId remoteDomain opts <- view tsGConf - _g <- view tsGalley - (resp, _) <- - withTempMockFederator - opts - remoteDomain - (const [mkProfile charlie (Name "charlie")]) - (postConvQualified alice [bob, charlie] (Just "remote gossip") [] Nothing Nothing) - liftIO $ do - statusCode resp @?= 400 - let err = responseJsonUnsafe resp :: Object - (err ^. at "label") @?= Just "unknown-remote-user" + void . withTempMockFederator opts remoteDomain (const [mkProfile charlie (Name "charlie")]) $ + postConvQualified alice defNewConv {newConvQualifiedUsers = [bob, charlie]} + !!! do + const 400 === statusCode + const (Right "unknown-remote-user") === fmap label . responseJsonEither postConvQualifiedFederationNotEnabled :: TestM () postConvQualifiedFederationNotEnabled = do @@ -1725,7 +1810,14 @@ getConvQualifiedOk = do bob <- randomQualifiedUser chuck <- randomQualifiedUser connectLocalQualifiedUsers alice (list1 bob [chuck]) - conv <- decodeConvId <$> postConvQualified alice [bob, chuck] (Just "gossip") [] Nothing Nothing + conv <- + decodeConvId + <$> postConvQualified + alice + defNewConv + { newConvQualifiedUsers = [bob, chuck], + newConvName = Just "gossip" + } getConv alice conv !!! const 200 === statusCode getConv (qUnqualified bob) conv !!! const 200 === statusCode getConv (qUnqualified chuck) conv !!! const 200 === statusCode @@ -1773,13 +1865,12 @@ testAddRemoteMember = do convId <- decodeConvId <$> postConv alice [] (Just "remote gossip") [] Nothing Nothing let qconvId = Qualified convId localDomain opts <- view tsGConf - g <- view tsGalley (resp, reqs) <- withTempMockFederator opts remoteDomain (respond remoteBob) - (postQualifiedMembers' g alice (remoteBob :| []) convId) + (postQualifiedMembers alice (remoteBob :| []) convId) liftIO $ do map F.domain reqs @?= replicate 2 (domainText remoteDomain) map (fmap F.path . F.request) reqs @@ -2014,13 +2105,12 @@ testAddRemoteMemberFailure = do remoteCharlie = Qualified charlieId remoteDomain convId <- decodeConvId <$> postConv alice [] (Just "remote gossip") [] Nothing Nothing opts <- view tsGConf - g <- view tsGalley (resp, _) <- withTempMockFederator opts remoteDomain (const [mkProfile remoteCharlie (Name "charlie")]) - (postQualifiedMembers' g alice (remoteBob :| [remoteCharlie]) convId) + (postQualifiedMembers alice (remoteBob :| [remoteCharlie]) convId) liftIO $ statusCode resp @?= 400 let err = responseJsonUnsafe resp :: Object liftIO $ (err ^. at "label") @?= Just "unknown-remote-user" @@ -2033,13 +2123,12 @@ testAddDeletedRemoteUser = do remoteBob = Qualified bobId remoteDomain convId <- decodeConvId <$> postConv alice [] (Just "remote gossip") [] Nothing Nothing opts <- view tsGConf - g <- view tsGalley (resp, _) <- withTempMockFederator opts remoteDomain (const [(mkProfile remoteBob (Name "bob")) {profileDeleted = True}]) - (postQualifiedMembers' g alice (remoteBob :| []) convId) + (postQualifiedMembers alice (remoteBob :| []) convId) liftIO $ statusCode resp @?= 400 let err = responseJsonUnsafe resp :: Object liftIO $ (err ^. at "label") @?= Just "unknown-remote-user" @@ -2062,7 +2151,6 @@ testAddRemoteMemberInvalidDomain = do -- on environments where federation isn't configured (such as our production as of May 2021) testAddRemoteMemberFederationDisabled :: TestM () testAddRemoteMemberFederationDisabled = do - g <- view tsGalley alice <- randomUser remoteBob <- flip Qualified (Domain "some-remote-backend.example.com") <$> randomId convId <- decodeConvId <$> postConv alice [] (Just "remote gossip") [] Nothing Nothing @@ -2071,7 +2159,7 @@ testAddRemoteMemberFederationDisabled = do -- This is the case on staging/production in May 2021. let federatorNotConfigured :: Opts = opts & optFederator .~ Nothing withSettingsOverrides federatorNotConfigured $ - postQualifiedMembers' g alice (remoteBob :| []) convId !!! do + postQualifiedMembers alice (remoteBob :| []) convId !!! do const 400 === statusCode const (Just "federation-not-enabled") === fmap label . responseJsonUnsafe -- federator endpoint being configured in brig and/or galley, but not being @@ -2080,7 +2168,7 @@ testAddRemoteMemberFederationDisabled = do -- Port 1 should always be wrong hopefully. let federatorUnavailable :: Opts = opts & optFederator ?~ Endpoint "127.0.0.1" 1 withSettingsOverrides federatorUnavailable $ - postQualifiedMembers' g alice (remoteBob :| []) convId !!! do + postQualifiedMembers alice (remoteBob :| []) convId !!! do const 500 === statusCode const (Just "federation-not-available") === fmap label . responseJsonUnsafe @@ -2198,7 +2286,14 @@ deleteMembersConvLocalQualifiedOk = do [alice, bob, eve] <- randomUsers 3 let [qAlice, qBob, qEve] = (`Qualified` localDomain) <$> [alice, bob, eve] connectUsers alice (list1 bob [eve]) - conv <- decodeConvId <$> postConvQualified alice [qBob, qEve] (Just "federated gossip") [] Nothing Nothing + conv <- + decodeConvId + <$> postConvQualified + alice + defNewConv + { newConvQualifiedUsers = [qBob, qEve], + newConvName = Just "federated gossip" + } let qconv = Qualified conv localDomain deleteMemberQualified bob qBob qconv !!! const 200 === statusCode deleteMemberQualified bob qBob qconv !!! const 404 === statusCode @@ -2224,7 +2319,13 @@ deleteLocalMemberConvLocalQualifiedOk = do qEve = Qualified eve remoteDomain connectUsers alice (singleton bob) - convId <- decodeConvId <$> postConvWithRemoteUser remoteDomain (mkProfile qEve (Name "Eve")) alice [qBob, qEve] + convId <- + decodeConvId + <$> postConvWithRemoteUsers + remoteDomain + [mkProfile qEve (Name "Eve")] + alice + defNewConv {newConvQualifiedUsers = [qBob, qEve]} let qconvId = Qualified convId localDomain opts <- view tsGConf @@ -2280,7 +2381,10 @@ deleteRemoteMemberConvLocalQualifiedOk = do (convId, _) <- withTempMockFederator' opts remoteDomain1 mockedResponse $ - decodeConvId <$> postConvQualified alice [qBob, qChad, qDee, qEve] Nothing [] Nothing Nothing + decodeConvId + <$> postConvQualified + alice + defNewConv {newConvQualifiedUsers = [qBob, qChad, qDee, qEve]} let qconvId = Qualified convId localDomain (respDel, federatedRequests) <- @@ -2425,7 +2529,12 @@ putQualifiedConvRenameWithRemotesOk = do qbob <- randomQualifiedUser let bob = qUnqualified qbob - resp <- postConvWithRemoteUser remoteDomain (mkProfile qalice (Name "Alice")) bob [qalice] + resp <- + postConvWithRemoteUsers + remoteDomain + [mkProfile qalice (Name "Alice")] + bob + defNewConv {newConvQualifiedUsers = [qalice]} let qconv = decodeQualifiedConvId resp opts <- view tsGConf @@ -2819,7 +2928,12 @@ putReceiptModeWithRemotesOk = do qbob <- randomQualifiedUser let bob = qUnqualified qbob - resp <- postConvWithRemoteUser remoteDomain (mkProfile qalice (Name "Alice")) bob [qalice] + resp <- + postConvWithRemoteUsers + remoteDomain + [mkProfile qalice (Name "Alice")] + bob + defNewConv {newConvQualifiedUsers = [qalice]} let qconv = decodeQualifiedConvId resp opts <- view tsGConf diff --git a/services/galley/test/integration/API/Federation.hs b/services/galley/test/integration/API/Federation.hs index eace125c2a7..0a16eeb34c6 100644 --- a/services/galley/test/integration/API/Federation.hs +++ b/services/galley/test/integration/API/Federation.hs @@ -89,7 +89,11 @@ getConversationsAllFound = do cnv2 <- responseJsonError - =<< postConvWithRemoteUser (qDomain aliceQ) (mkProfile aliceQ (Name "alice")) bob [aliceQ, carlQ] + =<< postConvWithRemoteUsers + (qDomain aliceQ) + [mkProfile aliceQ (Name "alice")] + bob + defNewConv {newConvQualifiedUsers = [aliceQ, carlQ]} getConvs bob (Just $ Left [qUnqualified (cnvQualifiedId cnv2)]) Nothing !!! do const 200 === statusCode @@ -216,7 +220,7 @@ removeLocalUser = do FedGalley.cuConvId = conv, FedGalley.cuAlreadyPresentUsers = [alice], FedGalley.cuAction = - ConversationActionRemoveMember qAlice + ConversationActionRemoveMembers (pure qAlice) } WS.bracketR c alice $ \ws -> do @@ -278,7 +282,7 @@ removeRemoteUser = do FedGalley.cuConvId = conv, FedGalley.cuAlreadyPresentUsers = [alice, charlie, dee], FedGalley.cuAction = - ConversationActionRemoveMember user + ConversationActionRemoveMembers (pure user) } WS.bracketRN c [alice, charlie, dee, flo] $ \[wsA, wsC, wsD, wsF] -> do @@ -476,7 +480,12 @@ leaveConversationSuccess = do (convId, _) <- withTempMockFederator' opts remoteDomain1 mockedResponse $ - decodeConvId <$> postConvQualified alice [qBob, qChad, qDee, qEve] Nothing [] Nothing Nothing + decodeConvId + <$> postConvQualified + alice + defNewConv + { newConvQualifiedUsers = [qBob, qChad, qDee, qEve] + } let qconvId = Qualified convId localDomain (_, federatedRequests) <- @@ -616,7 +625,11 @@ sendMessage = do (convId, requests1) <- withTempMockFederator opts remoteDomain responses1 $ fmap decodeConvId $ - postConvQualified aliceId [bob, chad] Nothing [] Nothing Nothing + postConvQualified + aliceId + defNewConv + { newConvQualifiedUsers = [bob, chad] + } Int -> TestM (TeamId, Qualified UserId, [Qualified UserId]) +createBindingTeamWithQualifiedMembers num = do + localDomain <- viewFederationDomain + (tid, owner, users) <- createBindingTeamWithMembers num + pure (tid, Qualified owner localDomain, map (`Qualified` localDomain) users) + getTeams :: UserId -> TestM TeamList getTeams u = do g <- view tsGalley @@ -538,30 +544,48 @@ createOne2OneTeamConv u1 u2 n tid = do postConv :: UserId -> [UserId] -> Maybe Text -> [Access] -> Maybe AccessRole -> Maybe Milliseconds -> TestM ResponseLBS postConv u us name a r mtimer = postConvWithRole u us name a r mtimer roleNameWireAdmin -postConvQualified :: (HasGalley m, MonadIO m, MonadMask m, MonadHttp m) => UserId -> [Qualified UserId] -> Maybe Text -> [Access] -> Maybe AccessRole -> Maybe Milliseconds -> m ResponseLBS -postConvQualified u us name a r mtimer = postConvWithRoleQualified us u [] name a r mtimer roleNameWireAdmin +defNewConv :: NewConv +defNewConv = NewConv [] [] Nothing mempty Nothing Nothing Nothing Nothing roleNameWireAdmin -postConvWithRemoteUser :: Domain -> UserProfile -> UserId -> [Qualified UserId] -> TestM (Response (Maybe LByteString)) -postConvWithRemoteUser remoteDomain user creatorUnqualified members = - postConvWithRemoteUsers remoteDomain [user] creatorUnqualified members +postConvQualified :: + (HasGalley m, MonadIO m, MonadMask m, MonadHttp m) => + UserId -> + NewConv -> + m ResponseLBS +postConvQualified u n = do + g <- viewGalley + post $ + g + . path "/conversations" + . zUser u + . zConn "conn" + . zType "access" + . json (NewConvUnmanaged n) -postConvWithRemoteUsers :: Domain -> [UserProfile] -> UserId -> [Qualified UserId] -> TestM (Response (Maybe LByteString)) -postConvWithRemoteUsers remoteDomain users creatorUnqualified members = do +postConvWithRemoteUsers :: + HasCallStack => + Domain -> + [UserProfile] -> + UserId -> + NewConv -> + TestM (Response (Maybe LByteString)) +postConvWithRemoteUsers remoteDomain profiles u n = do opts <- view tsGConf fmap fst $ - withTempMockFederator - opts - remoteDomain - respond - $ postConvQualified creatorUnqualified members (Just "federated gossip") [] Nothing Nothing + withTempMockFederator opts remoteDomain respond $ + postConvQualified u n {newConvName = setName (newConvName n)} Value respond req | fmap F.component (F.request req) == Just F.Brig = - toJSON users + toJSON profiles | otherwise = toJSON () + setName :: Maybe Text -> Maybe Text + setName Nothing = Just "federated gossip" + setName x = x + postTeamConv :: TeamId -> UserId -> [UserId] -> Maybe Text -> [Access] -> Maybe AccessRole -> Maybe Milliseconds -> TestM ResponseLBS postTeamConv tid u us name a r mtimer = do g <- view tsGalley @@ -569,13 +593,17 @@ postTeamConv tid u us name a r mtimer = do post $ g . path "/conversations" . zUser u . zConn "conn" . zType "access" . json conv postConvWithRole :: UserId -> [UserId] -> Maybe Text -> [Access] -> Maybe AccessRole -> Maybe Milliseconds -> RoleName -> TestM ResponseLBS -postConvWithRole = postConvWithRoleQualified [] - -postConvWithRoleQualified :: (HasGalley m, MonadIO m, MonadMask m, MonadHttp m) => [Qualified UserId] -> UserId -> [UserId] -> Maybe Text -> [Access] -> Maybe AccessRole -> Maybe Milliseconds -> RoleName -> m ResponseLBS -postConvWithRoleQualified qualifiedUsers u unqualifiedUsers name a r mtimer role = do - g <- viewGalley - let conv = NewConvUnmanaged $ NewConv unqualifiedUsers qualifiedUsers name (Set.fromList a) r Nothing mtimer Nothing role - post $ g . path "/conversations" . zUser u . zConn "conn" . zType "access" . json conv +postConvWithRole u members name access arole timer role = + postConvQualified + u + defNewConv + { newConvUsers = members, + newConvName = name, + newConvAccess = Set.fromList access, + newConvAccessRole = arole, + newConvMessageTimer = timer, + newConvUsersRole = role + } postConvWithReceipt :: UserId -> [UserId] -> Maybe Text -> [Access] -> Maybe AccessRole -> Maybe Milliseconds -> ReceiptMode -> TestM ResponseLBS postConvWithReceipt u us name a r mtimer rcpt = do @@ -826,13 +854,14 @@ listRemoteConvs remoteDomain uid = do allConvs <- fmap mtpResults . responseJsonError @_ @ConvIdsPage =<< listConvIds uid paginationOpts qDomain qcnv == remoteDomain) allConvs -postQualifiedMembers :: UserId -> NonEmpty (Qualified UserId) -> ConvId -> TestM ResponseLBS +postQualifiedMembers :: + (HasGalley m, MonadIO m, MonadHttp m) => + UserId -> + NonEmpty (Qualified UserId) -> + ConvId -> + m ResponseLBS postQualifiedMembers zusr invitees conv = do - g <- view tsGalley - postQualifiedMembers' g zusr invitees conv - -postQualifiedMembers' :: (MonadIO m, MonadHttp m) => (Request -> Request) -> UserId -> NonEmpty (Qualified UserId) -> ConvId -> m ResponseLBS -postQualifiedMembers' g zusr invitees conv = do + g <- viewGalley let invite = Public.InviteQualified invitees roleNameWireAdmin post $ g @@ -1423,7 +1452,7 @@ assertRemoveUpdate req qconvId remover alreadyPresentUsers victim = liftIO $ do FederatedGalley.cuOrigUserId cu @?= remover FederatedGalley.cuConvId cu @?= qUnqualified qconvId sort (FederatedGalley.cuAlreadyPresentUsers cu) @?= sort alreadyPresentUsers - FederatedGalley.cuAction cu @?= ConversationActionRemoveMember victim + FederatedGalley.cuAction cu @?= ConversationActionRemoveMembers (pure victim) ------------------------------------------------------------------------------- -- Helpers