WPB-4835 call-between-web-and-android-cant-be-established-when-one-backend-is-not-available

changelog.d/3-bug-fixes/WPB-4835

@@ -0,0 +1 @@
+list-clients returns with partial success even if one of the remote backends is unreachable

integration/test/API/Brig.hs

@@ -153,6 +153,12 @@ getClientsQualified user domain otherUser = do
         <> "/clients"
   submit "GET" req
 
+listUsersClients :: (HasCallStack, MakesValue user, MakesValue qualifiedUserIds) => user -> [qualifiedUserIds] -> App Response
+listUsersClients usr qualifiedUserIds = do
+  qUsers <- mapM objQidObject qualifiedUserIds
+  req <- baseRequest usr Brig Versioned $ joinHttpPath ["users", "list-clients"]
+  submit "POST" (req & addJSONObject ["qualified_users" .= qUsers])
+
 searchContacts ::
   ( MakesValue user,
     MakesValue searchTerm,

integration/test/Test/Client.hs

@@ -1,13 +1,21 @@
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
+
 module Test.Client where
 
 import API.Brig
+import API.Brig qualified as API
 import API.Gundeck
-import Data.Aeson
+import Control.Lens hiding ((.=))
+import Control.Monad.Codensity
+import Control.Monad.Reader
+import Data.Aeson hiding ((.=))
+import Data.ProtoLens.Labels ()
 import Data.Time.Clock.POSIX
 import Data.Time.Clock.System
 import Data.Time.Format
 import SetupHelpers
 import Testlib.Prelude
+import Testlib.ResourcePool
 
 testClientLastActive :: HasCallStack => App ()
 testClientLastActive = do
@@ -32,3 +40,33 @@ testClientLastActive = do
       . utcTimeToPOSIXSeconds
       <$> parseTimeM False defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" tm1
   assertBool "last_active is earlier than expected" $ ts1 >= now
+
+testListClientsIfBackendIsOffline :: HasCallStack => App ()
+testListClientsIfBackendIsOffline = do
+  resourcePool <- asks (.resourcePool)
+  ownDomain <- asString OwnDomain
+  otherDomain <- asString OtherDomain
+  [ownUser1, ownUser2] <- createAndConnectUsers [OwnDomain, OtherDomain]
+  ownClient1 <- objId $ bindResponse (API.addClient ownUser1 def) $ getJSON 201
+  ownClient2 <- objId $ bindResponse (API.addClient ownUser2 def) $ getJSON 201
+  ownUser1Id <- objId ownUser1
+  ownUser2Id <- objId ownUser2
+
+  let expectedResponse =
+        object
+          [ ownDomain .= object [ownUser1Id .= [object ["id" .= ownClient1]]],
+            otherDomain .= object [ownUser2Id .= [object ["id" .= ownClient2]]]
+          ]
+
+  bindResponse (listUsersClients ownUser1 [ownUser1, ownUser2]) $ \resp -> do
+    resp.status `shouldMatchInt` 200
+    resp.json %. "qualified_user_map" `shouldMatch` expectedResponse
+
+  -- we don't even have to start the backend, but we have to take the resource so that it doesn't get started by another test
+  runCodensity (acquireResources 1 resourcePool) $ \[downBackend] -> do
+    rndUsrId <- randomId
+    let downUser = (object ["domain" .= downBackend.berDomain, "id" .= rndUsrId])
+
+    bindResponse (listUsersClients ownUser1 [ownUser1, ownUser2, downUser]) $ \resp -> do
+      resp.status `shouldMatchInt` 200
+      resp.json %. "qualified_user_map" `shouldMatch` expectedResponse

libs/wire-api/src/Wire/API/Routes/Public/Brig.hs

@@ -920,6 +920,7 @@ type ClientAPI =
     :<|> Named
            "list-clients-bulk@v2"
            ( Summary "List all clients for a set of user ids"
+               :> Description "If a backend is unreachable, the clients from that backend will be omitted from the response"
                :> From 'V2
                :> MakesFederatedCall 'Brig "get-user-clients"
                :> ZUser

services/brig/src/Brig/API/Client.hs

@@ -78,10 +78,10 @@ import Control.Lens (view)
 import Data.ByteString.Conversion
 import Data.Code as Code
 import Data.Domain
+import Data.Either.Extra (mapLeft)
 import Data.IP (IP)
 import Data.Id (ClientId, ConnId, UserId)
 import Data.List.Split (chunksOf)
-import Data.Map.Strict (traverseWithKey)
 import Data.Map.Strict qualified as Map
 import Data.Misc (PlainTextPassword6)
 import Data.Qualified
@@ -133,13 +133,21 @@ lookupPubClientsBulk :: [Qualified UserId] -> ExceptT ClientError (AppT r) (Qual
 lookupPubClientsBulk qualifiedUids = do
   loc <- qualifyLocal ()
   let (localUsers, remoteUsers) = partitionQualified loc qualifiedUids
-  remoteUserClientMap <-
-    traverseWithKey
-      (\domain' uids -> getUserClients domain' (GetUserClients uids))
-      (indexQualified (fmap tUntagged remoteUsers))
-      !>> ClientFederationError
+  remoteUserClientMap <- lift $ getRemoteClients $ indexQualified (fmap tUntagged remoteUsers)
   localUserClientMap <- Map.singleton (tDomain loc) <$> lookupLocalPubClientsBulk localUsers
   pure $ QualifiedUserMap (Map.union localUserClientMap remoteUserClientMap)
+  where
+    getRemoteClients :: Map Domain [UserId] -> AppT r (Map Domain (UserMap (Set PubClient)))
+    getRemoteClients uids = do
+      results <-
+        traverse
+          (\(d, ids) -> mapLeft (const d) . fmap (d,) <$> runExceptT (getUserClients d (GetUserClients ids)))
+          (Map.toList uids)
+      forM_ (lefts results) $ \d ->
+        Log.warn $
+          field "remote_domain" (domainText d)
+            ~~ msg (val "Failed to fetch clients for domain")
+      pure $ Map.fromList (rights results)
 
 lookupLocalPubClientsBulk :: [UserId] -> ExceptT ClientError (AppT r) (UserMap (Set PubClient))
 lookupLocalPubClientsBulk = lift . wrapClient . Data.lookupPubClientsBulk