diff --git a/changelog.d/6-federation/wpb-5208-add-users-when-others-unreachable b/changelog.d/6-federation/wpb-5208-add-users-when-others-unreachable new file mode 100644 index 00000000000..5d1ea6c1203 --- /dev/null +++ b/changelog.d/6-federation/wpb-5208-add-users-when-others-unreachable @@ -0,0 +1 @@ +Make sure that remote users can be added to both a Proteus and an MLS conversation when other users are unreachable diff --git a/integration/test/Test/Conversation.hs b/integration/test/Test/Conversation.hs index e1855965d55..4973b171599 100644 --- a/integration/test/Test/Conversation.hs +++ b/integration/test/Test/Conversation.hs @@ -280,29 +280,37 @@ testConvWithUnreachableRemoteUsers = do regConvs <- filterM (\c -> (==) <$> (c %. "type" & asInt) <*> pure 0) convs regConvs `shouldMatch` ([] :: [Value]) -testAddReachableWithUnreachableRemoteUsers :: HasCallStack => App () -testAddReachableWithUnreachableRemoteUsers = do - ([alex, bob], conv, domains) <- - startDynamicBackends [def, def] $ \domains -> do - own <- make OwnDomain & asString - other <- make OtherDomain & asString - [alice, alex, bob, charlie, dylan] <- createUsers $ [own, own, other] <> domains - forM_ [alex, bob, charlie, dylan] $ connectTwoUsers alice +testAddUserWithUnreachableRemoteUsers :: HasCallStack => App () +testAddUserWithUnreachableRemoteUsers = do + resourcePool <- asks resourcePool + own <- make OwnDomain & asString + other <- make OtherDomain & asString + runCodensity (acquireResources 1 resourcePool) $ \[cDom] -> do + ([alex, bobId, bradId, chrisId], conv) <- runCodensity (startDynamicBackend cDom mempty) $ \_ -> do + [alice, alex, bob, brad, charlie, chris] <- + createAndConnectUsers [own, own, other, other, cDom.berDomain, cDom.berDomain] - let newConv = defProteus {qualifiedUsers = [alex, charlie, dylan]} + let newConv = defProteus {qualifiedUsers = [alex, charlie]} conv <- postConversation alice newConv >>= getJSON 201 - connectTwoUsers alex bob - pure ([alex, bob], conv, domains) + [bobId, bradId, chrisId] <- forM [bob, brad, chris] (%. "qualified_id") + pure ([alex, bobId, bradId, chrisId], conv) - bobId <- bob %. "qualified_id" - bindResponse (addMembers alex conv def {users = [bobId]}) $ \resp -> do - -- This test is updated to reflect the changes in `performConversationJoin` - -- `performConversationJoin` now does a full check between all federation members - -- that will be in the conversation when adding users to a conversation. This is - -- to ensure that users from domains that aren't federating are not directly - -- connected to each other. - resp.status `shouldMatchInt` 533 - resp.jsonBody %. "unreachable_backends" `shouldMatchSet` domains + bindResponse (addMembers alex conv def {users = [bobId]}) $ \resp -> do + resp.status `shouldMatchInt` 533 + resp.jsonBody %. "unreachable_backends" `shouldMatchSet` [cDom.berDomain] + + runCodensity (startDynamicBackend cDom mempty) $ \_ -> + void $ addMembers alex conv def {users = [bobId]} >>= getBody 200 + + -- even though backend C is unreachable, we know B/OtherDomain and C + -- federate because Bob joined when C was reachable, hence it is OK to add + -- brad from B to the conversation. + void $ addMembers alex conv def {users = [bradId]} >>= getBody 200 + + -- assert an unreachable user cannot be added + bindResponse (addMembers alex conv def {users = [chrisId]}) $ \resp -> do + resp.status `shouldMatchInt` 533 + resp.jsonBody %. "unreachable_backends" `shouldMatchSet` [cDom.berDomain] testAddUnreachableUserFromFederatingBackend :: HasCallStack => App () testAddUnreachableUserFromFederatingBackend = do diff --git a/integration/test/Test/MLS/Unreachable.hs b/integration/test/Test/MLS/Unreachable.hs index 16f8c6acc55..2989cddc750 100644 --- a/integration/test/Test/MLS/Unreachable.hs +++ b/integration/test/Test/MLS/Unreachable.hs @@ -48,31 +48,45 @@ testAddUsersSomeReachable = do (resp.json %. "unreachable_backends" & asList) `shouldMatch` [d] -- There is analogous counterpart for Proteus in the 'Test.Conversation' module. -testAddReachableWithUnreachableRemoteUsers :: HasCallStack => App () -testAddReachableWithUnreachableRemoteUsers = do +testAddUserWithUnreachableRemoteUsers :: HasCallStack => App () +testAddUserWithUnreachableRemoteUsers = do resourcePool <- asks resourcePool runCodensity (acquireResources 1 resourcePool) $ \[cDom] -> do - (alice1, bob) <- runCodensity (startDynamicBackend cDom mempty) $ \_ -> do - ownDomain <- make OwnDomain & asString - [alice, charlie] <- createAndConnectUsers [ownDomain, cDom.berDomain] - - [alice1, charlie1] <- traverse (createMLSClient def) [alice, charlie] - void $ uploadNewKeyPackage charlie1 + (alice1, bob, brad, chris) <- runCodensity (startDynamicBackend cDom mempty) $ \_ -> do + [own, other] <- forM [OwnDomain, OtherDomain] $ asString . make + [alice, bob, brad, charlie, chris] <- + createAndConnectUsers [own, other, other, cDom.berDomain, cDom.berDomain] + [alice1, charlie1, chris1] <- + traverse (createMLSClient def) [alice, charlie, chris] + traverse_ uploadNewKeyPackage [charlie1, chris1] void $ createNewGroup alice1 void $ withWebSocket charlie $ \ws -> do void $ createAddCommit alice1 [charlie] >>= sendAndConsumeCommitBundle awaitMatch 10 isMemberJoinNotif ws - otherDomain <- make OtherDomain & asString - bob <- randomUser otherDomain def - forM_ [alice, charlie] $ connectTwoUsers bob - pure (alice1, bob) + pure (alice1, bob, brad, chris) - bob1 <- createMLSClient def bob - void $ uploadNewKeyPackage bob1 - mp <- createAddCommit alice1 [bob] - bindResponse (postMLSCommitBundle mp.sender (mkBundle mp)) $ \resp -> do - resp.status `shouldMatchInt` 533 - resp.jsonBody %. "unreachable_backends" `shouldMatchSet` [cDom.berDomain] + [bob1, brad1] <- traverse (createMLSClient def) [bob, brad] + traverse_ uploadNewKeyPackage [bob1, brad1] + + do + mp <- createAddCommit alice1 [bob] + bindResponse (postMLSCommitBundle mp.sender (mkBundle mp)) $ \resp -> do + resp.status `shouldMatchInt` 533 + resp.jsonBody %. "unreachable_backends" `shouldMatchSet` [cDom.berDomain] + + runCodensity (startDynamicBackend cDom mempty) $ \_ -> + void $ postMLSCommitBundle mp.sender (mkBundle mp) >>= getBody 201 + + do + mp <- createAddCommit alice1 [brad] + void $ postMLSCommitBundle mp.sender (mkBundle mp) >>= getBody 201 + + do + mp <- runCodensity (startDynamicBackend cDom mempty) $ \_ -> + createAddCommit alice1 [chris] + bindResponse (postMLSCommitBundle mp.sender (mkBundle mp)) $ \resp -> do + resp.status `shouldMatchInt` 533 + resp.jsonBody %. "unreachable_backends" `shouldMatchSet` [cDom.berDomain] testAddUnreachableUserFromFederatingBackend :: HasCallStack => App () testAddUnreachableUserFromFederatingBackend = do diff --git a/libs/wire-api/src/Wire/API/FederationStatus.hs b/libs/wire-api/src/Wire/API/FederationStatus.hs index b0e7a3c9859..3293084d641 100644 --- a/libs/wire-api/src/Wire/API/FederationStatus.hs +++ b/libs/wire-api/src/Wire/API/FederationStatus.hs @@ -11,12 +11,14 @@ import Data.Aeson qualified as A import Data.Aeson.Types qualified as A import Data.Domain import Data.OpenApi qualified as S +import Data.Qualified import Data.Schema +import Data.Set qualified as Set import Imports import Wire.Arbitrary newtype RemoteDomains = RemoteDomains - { rdDomains :: Set Domain + { rdDomains :: Set (Remote ()) } deriving stock (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform RemoteDomains) @@ -26,7 +28,8 @@ instance ToSchema RemoteDomains where schema = objectWithDocModifier "RemoteDomains" (description ?~ "A set of remote domains") $ RemoteDomains - <$> rdDomains .= field "domains" (set schema) + <$> (Set.map tDomain . rdDomains) + .= field "domains" (Set.map (flip toRemoteUnsafe ()) <$> set schema) -- | This value expresses if the requested remote domains are fully connected or not. -- If not the response will contain the first pair of domains found diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/FederationStatus.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/FederationStatus.hs index 06092f01b98..d5118663f59 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/FederationStatus.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/FederationStatus.hs @@ -18,8 +18,9 @@ module Test.Wire.API.Golden.Manual.FederationStatus where import Data.Domain (Domain (..)) +import Data.Qualified import Data.Set qualified as Set -import Imports (Monoid (mempty), ($)) +import Imports import Wire.API.FederationStatus testObject_FederationStatus_1 :: FederationStatus @@ -29,7 +30,9 @@ testObject_FederationStatus_2 :: FederationStatus testObject_FederationStatus_2 = NotConnectedDomains (Domain "d.example.com") (Domain "e.example.com") testObject_RemoteDomains_1 :: RemoteDomains -testObject_RemoteDomains_1 = RemoteDomains $ Set.fromList [Domain "a.example.com", Domain "b.example.com"] +testObject_RemoteDomains_1 = + RemoteDomains . Set.fromList $ + flip toRemoteUnsafe () <$> [Domain "a.example.com", Domain "b.example.com"] testObject_RemoteDomains_2 :: RemoteDomains testObject_RemoteDomains_2 = RemoteDomains mempty diff --git a/services/galley/src/Galley/API/Action.hs b/services/galley/src/Galley/API/Action.hs index a2194ea8e1e..4eaebb02b79 100644 --- a/services/galley/src/Galley/API/Action.hs +++ b/services/galley/src/Galley/API/Action.hs @@ -115,7 +115,7 @@ import Wire.API.Federation.API.Brig import Wire.API.Federation.API.Galley import Wire.API.Federation.API.Galley qualified as F import Wire.API.Federation.Error -import Wire.API.FederationStatus (FederationStatus (FullyConnected, NotConnectedDomains), RemoteDomains (..)) +import Wire.API.FederationStatus import Wire.API.MLS.CipherSuite import Wire.API.Routes.Internal.Brig.Connection import Wire.API.Team.Feature @@ -346,8 +346,11 @@ getFederationStatus req = do fmap firstConflictOrFullyConnected . (ensureNoUnreachableBackends =<<) $ E.runFederatedConcurrentlyEither - (flip toRemoteUnsafe () <$> Set.toList req.rdDomains) - (\qds -> fedClient @'Brig @"get-not-fully-connected-backends" (DomainSet (tDomain qds `Set.delete` req.rdDomains))) + (Set.toList req.rdDomains) + ( \qds -> + fedClient @'Brig @"get-not-fully-connected-backends" + (DomainSet . Set.map tDomain $ void qds `Set.delete` req.rdDomains) + ) -- | "conflict" here means two remote domains that we are connected to -- but are not connected to each other. @@ -519,13 +522,11 @@ performConversationJoin qusr lconv (ConversationJoin invited role) = do addMembersToLocalConversation (fmap (.convId) lconv) newMembers role where - checkRemoteBackendsConnected :: - Local UserId -> - Sem r () - checkRemoteBackendsConnected lusr = do - let invitedRemoteUsers = filter ((/= tDomain lconv) . tDomain) $ snd (partitionQualified lusr $ NE.toList invited) - invitedRemoteDomains = Set.fromList $ tDomain <$> invitedRemoteUsers - existingRemoteDomains = Set.fromList $ tDomain . rmId <$> convRemoteMembers (tUnqualified lconv) + checkRemoteBackendsConnected :: Local x -> Sem r () + checkRemoteBackendsConnected loc = do + let invitedRemoteUsers = snd . partitionQualified loc . NE.toList $ invited + invitedRemoteDomains = Set.fromList $ void <$> invitedRemoteUsers + existingRemoteDomains = Set.fromList $ void . rmId <$> convRemoteMembers (tUnqualified lconv) allInvitedAlreadyInConversation = null $ invitedRemoteDomains \\ existingRemoteDomains if not allInvitedAlreadyInConversation diff --git a/services/galley/src/Galley/API/Create.hs b/services/galley/src/Galley/API/Create.hs index 31ff4dece0e..f785269e6bb 100644 --- a/services/galley/src/Galley/API/Create.hs +++ b/services/galley/src/Galley/API/Create.hs @@ -155,7 +155,7 @@ createGroupConversation :: NewConv -> Sem r CreateGroupConversationResponse createGroupConversation lusr conn newConv = do - let remoteDomains = tDomain <$> snd (partitionQualified lusr $ newConv.newConvQualifiedUsers) + let remoteDomains = void <$> snd (partitionQualified lusr $ newConv.newConvQualifiedUsers) checkFederationStatus (RemoteDomains $ Set.fromList remoteDomains) cnv <- createGroupConversationGeneric