Handle unreachable backends when adding users (#3496)

* Add unreachable error test on adding

* Remove unnecessary ping and rethrow logic

* Add CHANGELOG entry

changelog.d/6-federation/unreachable-add

@@ -0,0 +1 @@
+Return `unreachable_backends` error when some backends of newly added users to a conversation are not reachable

integration/test/Test/Conversation.hs

@@ -328,7 +328,7 @@ testAddMembersNonFullyConnectedProteus = do
       resp.status `shouldMatchInt` 409
       resp.json %. "non_federating_backends" `shouldMatchSet` [domainB, domainC]
 
-testConvWithUnreachableRemoteUsers :: App ()
+testConvWithUnreachableRemoteUsers :: HasCallStack => App ()
 testConvWithUnreachableRemoteUsers = do
   let overrides =
         def {dbBrig = setField "optSettings.setFederationStrategy" "allowAll"}
@@ -348,3 +348,43 @@ testConvWithUnreachableRemoteUsers = do
   convs <- getAllConvs alice >>= asList
   regConvs <- filterM (\c -> (==) <$> (c %. "type" & asInt) <*> pure 0) convs
   regConvs `shouldMatch` ([] :: [Value])
+
+testAddReachableWithUnreachableRemoteUsers :: HasCallStack => App ()
+testAddReachableWithUnreachableRemoteUsers = do
+  let overrides =
+        def {dbBrig = setField "optSettings.setFederationStrategy" "allowAll"}
+          <> fullSearchWithAll
+  ([alex, bob], conv) <-
+    startDynamicBackends [overrides, overrides] $ \domains -> do
+      own <- make OwnDomain & asString
+      other <- make OtherDomain & asString
+      [alice, alex, bob, charlie, dylan] <-
+        createAndConnectUsers $ [own, own, other] <> domains
+
+      let newConv = defProteus {qualifiedUsers = [alex, charlie, dylan]}
+      conv <- postConversation alice newConv >>= getJSON 201
+      pure ([alex, bob], conv)
+
+  bobId <- bob %. "qualified_id"
+  bindResponse (addMembers alex conv [bobId]) $ \resp -> do
+    resp.status `shouldMatchInt` 200
+
+testAddUnreachable :: HasCallStack => App ()
+testAddUnreachable = do
+  let overrides =
+        def {dbBrig = setField "optSettings.setFederationStrategy" "allowAll"}
+          <> fullSearchWithAll
+  ([alex, charlie], [charlieDomain, _dylanDomain], conv) <-
+    startDynamicBackends [overrides, overrides] $ \domains -> do
+      own <- make OwnDomain & asString
+      [alice, alex, charlie, dylan] <-
+        createAndConnectUsers $ [own, own] <> domains
+
+      let newConv = defProteus {qualifiedUsers = [alex, dylan]}
+      conv <- postConversation alice newConv >>= getJSON 201
+      pure ([alex, charlie], domains, conv)
+
+  charlieId <- charlie %. "qualified_id"
+  bindResponse (addMembers alex conv [charlieId]) $ \resp -> do
+    resp.status `shouldMatchInt` 503
+    resp.json %. "unreachable_backends" `shouldMatchSet` [charlieDomain]

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

@@ -87,8 +87,6 @@ import Galley.Types.Conversations.Members
 import Galley.Types.UserList
 import Galley.Validation
 import Imports
-import Network.HTTP.Types.Status qualified as Wai
-import Network.Wai.Utilities.Error qualified as Wai
 import Polysemy
 import Polysemy.Error
 import Polysemy.Input
@@ -445,6 +443,13 @@ performConversationJoin qusr lconv (ConversationJoin invited role) = do
       Sem r ()
     checkRemoteBackendsConnected lusr = do
       let remoteDomains = tDomain <$> snd (partitionQualified lusr $ NE.toList invited)
+      -- 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)
 
     conv :: Data.Conversation
@@ -754,8 +759,7 @@ addMembersToLocalConversation lcnv users role = do
 
 notifyConversationAction ::
   forall tag r.
-  ( Member (Error FederationError) r,
-    Member FederatorAccess r,
+  ( Member FederatorAccess r,
     Member ExternalAccess r,
     Member GundeckAccess r,
     Member (Input UTCTime) r,
@@ -772,7 +776,6 @@ notifyConversationAction ::
 notifyConversationAction tag quid notifyOrigDomain con lconv targets action = do
   now <- input
   let lcnv = fmap convId lconv
-      conv = tUnqualified lconv
       e = conversationActionToEvent tag now quid (tUntagged lcnv) Nothing action
 
   let mkUpdate uids =
@@ -783,48 +786,7 @@ notifyConversationAction tag quid notifyOrigDomain con lconv targets action = do
           uids
           (SomeConversationAction tag action)
 
-  -- call `api-version` on backends that are seeing this
-  -- conversation for the first time
-  let newDomains =
-        Set.difference
-          (Set.map void (bmRemotes targets))
-          (Set.fromList (map (void . rmId) (convRemoteMembers conv)))
-      newRemotes =
-        Set.filter (\r -> Set.member (void r) newDomains)
-          . bmRemotes
-          $ targets
   update <- do
-    do
-      -- ping new remote backends
-      notifyEithers <-
-        E.runFederatedConcurrentlyEither (toList newRemotes) $ \_ -> do
-          void $ fedClient @'Brig @"api-version" ()
-      -- For now these users will not be able to join the conversation until
-      -- queueing and retrying is implemented.
-      let failedNotifies = lefts notifyEithers
-      for_ failedNotifies $
-        logError
-          "api-version"
-          "An error occurred while communicating with federated server: "
-      for_ failedNotifies $ \case
-        -- rethrow invalid-domain errors and mis-configured federation errors
-        (_, ex@(FederationCallFailure (FederatorClientError (Wai.Error (Wai.Status 422 _) _ _ _)))) -> throw ex
-        -- FUTUREWORK: This error occurs when federation strategy is set to `allowDynamic`
-        -- and the remote domain is not in the allow list
-        -- Is it ok to throw all 400 errors?
-        (_, ex@(FederationCallFailure (FederatorClientError (Wai.Error (Wai.Status 400 _) _ _ _)))) -> throw ex
-        (_, ex@(FederationCallFailure (FederatorClientHTTP2Error (FederatorClientConnectionError _)))) -> throw ex
-        -- FUTUREWORK: Default case (`_ -> pure ()`) is now explicit. Do we really want to ignore all these errors?
-        (_, FederationCallFailure (FederatorClientHTTP2Error _)) -> pure ()
-        (_, FederationCallFailure (FederatorClientError _)) -> pure ()
-        (_, FederationCallFailure FederatorClientStreamingNotSupported) -> pure ()
-        (_, FederationCallFailure (FederatorClientServantError _)) -> pure ()
-        (_, FederationCallFailure (FederatorClientVersionNegotiationError _)) -> pure ()
-        (_, FederationCallFailure FederatorClientVersionMismatch) -> pure ()
-        (_, FederationNotImplemented) -> pure ()
-        (_, FederationNotConfigured) -> pure ()
-        (_, FederationUnexpectedBody _) -> pure ()
-        (_, FederationUnexpectedError _) -> pure ()
     updates <-
       E.runFederatedConcurrentlyEither (toList (bmRemotes targets)) $
         \ruids -> do

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

@@ -675,7 +675,6 @@ joinConversationByReusableCode ::
   ( Member BrigAccess r,
     Member CodeStore r,
     Member ConversationStore r,
-    Member (Error FederationError) r,
     Member (ErrorS 'CodeNotFound) r,
     Member (ErrorS 'InvalidConversationPassword) r,
     Member (ErrorS 'ConvAccessDenied) r,
@@ -709,7 +708,6 @@ joinConversationById ::
   ( Member BrigAccess r,
     Member FederatorAccess r,
     Member ConversationStore r,
-    Member (Error FederationError) r,
     Member (ErrorS 'ConvAccessDenied) r,
     Member (ErrorS 'ConvNotFound) r,
     Member (ErrorS 'InvalidOperation) r,
@@ -735,7 +733,6 @@ joinConversation ::
   forall r.
   ( Member BrigAccess r,
     Member FederatorAccess r,
-    Member (Error FederationError) r,
     Member (ErrorS 'ConvAccessDenied) r,
     Member (ErrorS 'InvalidOperation) r,
     Member (ErrorS 'NotATeamMember) r,