Wpb 3842 federation completeness check

changelog.d/3-bug-fixes/WPB-3842-federation-completeness-checks

@@ -0,0 +1 @@
+Adding users to a conversation now enforces that all federation domains that will be in the conversation are federated with each other.

integration/test/Test/Conversation.hs

@@ -364,7 +364,7 @@ testAddReachableWithUnreachableRemoteUsers = do
   let overrides =
         def {dbBrig = setField "optSettings.setFederationStrategy" "allowAll"}
           <> fullSearchWithAll
-  ([alex, bob], conv) <-
+  ([alex, bob], conv, domains) <-
     startDynamicBackends [overrides, overrides] $ \domains -> do
       own <- make OwnDomain & asString
       other <- make OtherDomain & asString
@@ -373,18 +373,24 @@ testAddReachableWithUnreachableRemoteUsers = do
 
       let newConv = defProteus {qualifiedUsers = [alex, charlie, dylan]}
       conv <- postConversation alice newConv >>= getJSON 201
-      pure ([alex, bob], conv)
+      pure ([alex, bob], conv, domains)
 
   bobId <- bob %. "qualified_id"
   bindResponse (addMembers alex conv [bobId]) $ \resp -> do
-    resp.status `shouldMatchInt` 200
+    -- 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
 
 testAddUnreachable :: HasCallStack => App ()
 testAddUnreachable = do
   let overrides =
         def {dbBrig = setField "optSettings.setFederationStrategy" "allowAll"}
           <> fullSearchWithAll
-  ([alex, charlie], [charlieDomain, _dylanDomain], conv) <-
+  ([alex, charlie], [charlieDomain, dylanDomain], conv) <-
     startDynamicBackends [overrides, overrides] $ \domains -> do
       own <- make OwnDomain & asString
       [alice, alex, charlie, dylan] <-
@@ -397,4 +403,26 @@ testAddUnreachable = do
   charlieId <- charlie %. "qualified_id"
   bindResponse (addMembers alex conv [charlieId]) $ \resp -> do
     resp.status `shouldMatchInt` 533
-    resp.json %. "unreachable_backends" `shouldMatchSet` [charlieDomain]
+    -- All of the domains that are in the conversation, or will be in the conversation,
+    -- need to be reachable so we can check that the graph for those domains is fully connected.
+    resp.json %. "unreachable_backends" `shouldMatchSet` [charlieDomain, dylanDomain]
+
+testAddingUserNonFullyConnectedFederation :: HasCallStack => App ()
+testAddingUserNonFullyConnectedFederation = do
+  let overrides =
+        def {dbBrig = setField "optSettings.setFederationStrategy" "allowAll"}
+          <> fullSearchWithAll
+  startDynamicBackends [overrides] $ \domains -> do
+    own <- make OwnDomain & asString
+    other <- make OtherDomain & asString
+    [alice, alex, bob, charlie] <-
+      createAndConnectUsers $ [own, own, other] <> domains
+
+    let newConv = defProteus {qualifiedUsers = [alex]}
+    conv <- postConversation alice newConv >>= getJSON 201
+
+    bobId <- bob %. "qualified_id"
+    charlieId <- charlie %. "qualified_id"
+    bindResponse (addMembers alex conv [bobId, charlieId]) $ \resp -> do
+      resp.status `shouldMatchInt` 409
+      resp.json %. "non_federating_backends" `shouldMatchSet` (other : domains)

integration/test/Testlib/Run.hs

@@ -11,6 +11,7 @@ import Data.Function
 import Data.Functor
 import Data.List
 import Data.Time.Clock
+import Data.Traversable (for)
 import RunAllTests
 import System.Directory
 import System.Environment
@@ -134,7 +135,7 @@ runTests tests cfg = do
   genv <- createGlobalEnv cfg
 
   withAsync displayOutput $ \displayThread -> do
-    report <- fmap mconcat $ pooledForConcurrently tests $ \(qname, _, _, action) -> do
+    report <- fmap mconcat $ for tests $ \(qname, _, _, action) -> do
       do
         (mErr, tm) <- withTime (runTest genv action)
         case mErr of

services/galley/src/Galley/API/Action.hs

@@ -442,15 +442,17 @@ performConversationJoin qusr lconv (ConversationJoin invited role) = do
       Local UserId ->
       Sem r ()
     checkRemoteBackendsConnected lusr = do
-      let remoteDomains = tDomain <$> snd (partitionQualified lusr $ NE.toList invited)
+      let invitedDomains = tDomain <$> snd (partitionQualified lusr $ NE.toList invited)
+          existingDomains = tDomain . rmId <$> convRemoteMembers (tUnqualified lconv)
+
       -- Note:
       --
       -- In some cases, this federation status check might be redundant (for
       -- example if there are only local users in the conversation). However,
       -- it is important that we attempt to connect to the backends of the new
       -- users here, because that results in the correct error when those
       -- backends are not reachable.
-      checkFederationStatus (RemoteDomains $ Set.fromList remoteDomains)
+      checkFederationStatus (RemoteDomains . Set.fromList $ invitedDomains <> existingDomains)
 
     conv :: Data.Conversation
     conv = tUnqualified lconv