[WPB-5208] Allow adding users to conversations when other backends are unreachable

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

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

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

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

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

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

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