Fs 897 partial success for list users

changelog.d/1-api-changes/FS-897

@@ -0,0 +1 @@
+Adding a new version of /list-users that allows for partial success.

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

@@ -228,10 +228,22 @@ type UserAPI =
           :> Description "The 'qualified_ids' and 'qualified_handles' parameters are mutually exclusive."
           :> MakesFederatedCall 'Brig "get-users-by-ids"
           :> ZUser
+          :> Until 'V3
           :> "list-users"
           :> ReqBody '[JSON] ListUsersQuery
           :> Post '[JSON] [UserProfile]
       )
+    :<|> Named
+           "list-users-by-ids-or-handles@V3"
+           ( Summary "List users"
+               :> Description "The 'qualified_ids' and 'qualified_handles' parameters are mutually exclusive."
+               :> MakesFederatedCall 'Brig "get-users-by-ids"
+               :> ZUser
+               :> From 'V3
+               :> "list-users"
+               :> ReqBody '[JSON] ListUsersQuery
+               :> Post '[JSON] ListUsersById
+           )
     :<|> Named
            "send-verification-code"
            ( Summary "Send a verification code to a given email address."

libs/wire-api/src/Wire/API/User.hs

@@ -20,7 +20,8 @@
 -- with this program. If not, see <https://www.gnu.org/licenses/>.
 
 module Wire.API.User
-  ( UserIdList (..),
+  ( ListUsersById (..),
+    UserIdList (..),
     QualifiedUserIdList (..),
     LimitedQualifiedUserIdList (..),
     ScimUserInfo (..),
@@ -166,6 +167,21 @@ import Wire.API.User.Profile
 import Wire.API.User.RichInfo
 import Wire.Arbitrary (Arbitrary (arbitrary), GenericUniform (..))
 
+------- Paritial Successes
+data ListUsersById = ListUsersById
+  { listUsersByIdFound :: [UserProfile],
+    listUsersByIdFailed :: Maybe [Qualified UserId]
+  }
+  deriving (Eq, Show)
+  deriving (ToJSON, FromJSON, S.ToSchema) via Schema ListUsersById
+
+instance ToSchema ListUsersById where
+  schema =
+    object "ListUsersById" $
+      ListUsersById
+        <$> listUsersByIdFound .= field "found" (array schema)
+        <*> listUsersByIdFailed .= maybe_ (optField "failed" $ array schema)
+
 --------------------------------------------------------------------------------
 -- UserIdList
 

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

@@ -108,6 +108,7 @@ import qualified Wire.API.Connection as Public
 import Wire.API.Error
 import qualified Wire.API.Error.Brig as E
 import Wire.API.Federation.API
+import Wire.API.Federation.Error
 import qualified Wire.API.Properties as Public
 import qualified Wire.API.Routes.Internal.Brig as BrigInternalAPI
 import qualified Wire.API.Routes.Internal.Cannon as CannonInternalAPI
@@ -241,6 +242,7 @@ servantSitemap =
         :<|> Named @"get-user-by-handle-qualified" (callsFed (exposeAnnotations Handle.getHandleInfo))
         :<|> Named @"list-users-by-unqualified-ids-or-handles" (callsFed (exposeAnnotations listUsersByUnqualifiedIdsOrHandles))
         :<|> Named @"list-users-by-ids-or-handles" (callsFed (exposeAnnotations listUsersByIdsOrHandles))
+        :<|> Named @"list-users-by-ids-or-handles@V3" (callsFed (exposeAnnotations listUsersByIdsOrHandlesV3))
         :<|> Named @"send-verification-code" sendVerificationCode
         :<|> Named @"get-rich-info" getRichInfo
 
@@ -738,6 +740,40 @@ listUsersByIdsOrHandles self q = do
     byIds :: Local UserId -> [Qualified UserId] -> (Handler r) [Public.UserProfile]
     byIds lself uids = API.lookupProfiles lself uids !>> fedError
 
+-- Similar to listUsersByIdsOrHandles, except that it allows partial successes
+-- using a new return type
+listUsersByIdsOrHandlesV3 ::
+  forall r.
+  ( Member GalleyProvider r,
+    Member (Concurrency 'Unsafe) r
+  ) =>
+  UserId ->
+  Public.ListUsersQuery ->
+  Handler r ListUsersById
+listUsersByIdsOrHandlesV3 self q = do
+  lself <- qualifyLocal self
+  (errors, foundUsers) <- case q of
+    Public.ListUsersByIds us ->
+      byIds lself us
+    Public.ListUsersByHandles hs -> do
+      let (localHandles, _) = partitionQualified lself (fromRange hs)
+      us <- getIds localHandles
+      (l, r) <- byIds lself us
+      r' <- Handle.filterHandleResults lself r
+      pure (l, r')
+  pure $ ListUsersById foundUsers $ if null errors then Nothing else pure $ fst <$> errors
+  where
+    getIds :: [Handle] -> Handler r [Qualified UserId]
+    getIds localHandles = do
+      localUsers <- catMaybes <$> traverse (lift . wrapClient . API.lookupHandle) localHandles
+      domain <- viewFederationDomain
+      pure $ map (`Qualified` domain) localUsers
+    byIds ::
+      Local UserId ->
+      [Qualified UserId] ->
+      Handler r ([(Qualified UserId, FederationError)], [Public.UserProfile])
+    byIds lself uids = lift (API.lookupProfilesV3 lself uids) !>> fedError
+
 newtype GetActivationCodeResp
   = GetActivationCodeResp (Public.ActivationKey, Public.ActivationCode)
 

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

@@ -27,6 +27,7 @@ module Brig.API.Types
     ReAuthError (..),
     LegalHoldLoginError (..),
     RetryAfter (..),
+    ListUsersById (..),
     foldKey,
   )
 where

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

@@ -40,6 +40,7 @@ module Brig.API.User
     lookupAccountsByIdentity,
     lookupProfile,
     lookupProfiles,
+    lookupProfilesV3,
     lookupLocalProfiles,
     getLegalHoldStatus,
     Data.lookupName,
@@ -1437,6 +1438,30 @@ lookupProfiles self others =
       (lookupProfilesFromDomain self)
       (bucketQualified others)
 
+-- | Similar to lookupProfiles except it returns all results and all errors
+-- allowing for partial success.
+lookupProfilesV3 ::
+  ( Member GalleyProvider r,
+    Member (Concurrency 'Unsafe) r
+  ) =>
+  -- | User 'self' on whose behalf the profiles are requested.
+  Local UserId ->
+  -- | The users ('others') for which to obtain the profiles.
+  [Qualified UserId] ->
+  AppT r ([(Qualified UserId, FederationError)], [UserProfile])
+lookupProfilesV3 self others = do
+  t <-
+    traverseConcurrently
+      (lookupProfilesFromDomain self)
+      (bucketQualified others)
+  let (l, r) = partitionEithers t
+  pure (l >>= flattenUsers, join r)
+  where
+    flattenUsers :: (Qualified [UserId], FederationError) -> [(Qualified UserId, FederationError)]
+    flattenUsers (l, e) =
+      let mkUser u = Qualified u (qDomain l)
+       in (,e) . mkUser <$> qUnqualified l
+
 lookupProfilesFromDomain ::
   (Member GalleyProvider r) =>
   Local UserId ->

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

@@ -22,6 +22,7 @@ module Brig.API.Util
     logInvitationCode,
     validateHandle,
     logEmail,
+    traverseConcurrently,
     traverseConcurrentlyWithErrors,
     traverseConcurrentlyWithErrorsSem,
     traverseConcurrentlyWithErrorsAppT,
@@ -44,6 +45,7 @@ import Brig.Types.Intra (accountUser)
 import Control.Lens (view)
 import Control.Monad.Catch (throwM)
 import Control.Monad.Trans.Except
+import Data.Bifunctor
 import Data.Domain (Domain)
 import Data.Handle (Handle, parseHandle)
 import Data.Id
@@ -96,6 +98,21 @@ logEmail email =
 logInvitationCode :: InvitationCode -> (Msg -> Msg)
 logInvitationCode code = Log.field "invitation_code" (toText $ fromInvitationCode code)
 
+-- | Traverse concurrently and collect errors.
+traverseConcurrently ::
+  (Traversable t, Member (C.Concurrency 'C.Unsafe) r) =>
+  (a -> ExceptT e (AppT r) b) ->
+  t a ->
+  AppT r [Either (a, e) b]
+traverseConcurrently f t = do
+  env <- temporaryGetEnv
+  AppT $
+    lift $
+      C.unsafePooledMapConcurrentlyN
+        8
+        (\a -> first (a,) <$> lowerAppT env (runExceptT $ f a))
+        t
+
 -- | Traverse concurrently and fail on first error.
 traverseConcurrentlyWithErrors ::
   (Traversable t, Exception e, MonadUnliftIO m) =>

services/brig/test/integration/API/User/Account.hs

@@ -49,6 +49,7 @@ import Data.Domain
 import Data.Handle
 import Data.Id hiding (client)
 import Data.Json.Util (fromUTCTimeMillis)
+import Data.LegalHold
 import Data.List1 (singleton)
 import qualified Data.List1 as List1
 import Data.Misc (PlainTextPassword (..))
@@ -131,6 +132,7 @@ tests _ at opts p b c ch g aws userJournalWatcher =
       test p "head /users/:domain/:uid - 200" $ testUserExists b,
       test p "head /users/:domain/:uid - 404" $ testUserDoesNotExist b,
       test p "post /list-users - 200" $ testMultipleUsers b,
+      test p "post /list-users@v3 - 200" $ testMultipleUsersV3 opts b,
       test p "put /self - 200" $ testUserUpdate b c userJournalWatcher,
       test p "put /access/self/email - 2xx" $ testEmailUpdate b userJournalWatcher,
       test p "put /self/phone - 202" $ testPhoneUpdate b,
@@ -773,7 +775,8 @@ testMultipleUsers brig = do
             (Just $ userDisplayName u3, Nothing)
           ]
   post
-    ( brig
+    ( apiVersion "v2"
+        . brig
         . zUser (userId u1)
         . contentJson
         . path "list-users"
@@ -790,6 +793,73 @@ testMultipleUsers brig = do
     field :: FromJSON a => Key -> Value -> Maybe a
     field f u = u ^? key f >>= maybeFromJSON
 
+testMultipleUsersV3 :: Opt.Opts -> Brig -> Http ()
+testMultipleUsersV3 opts brig = do
+  u1 <- randomUser brig
+  u2 <- randomUser brig
+  u3 <- createAnonUser "a" brig
+  -- A remote user that can't be listed
+  u4 <- Qualified <$> randomId <*> pure (Domain "far-away.example.com")
+  -- A remote user that can be listed
+  let evenFurtherAway = Domain "even-further-away.example.com"
+  u5 <- Qualified <$> randomId <*> pure evenFurtherAway
+  let u5Profile =
+        UserProfile
+          { profileQualifiedId = u5,
+            profileName = Name "u5",
+            profilePict = Pict [],
+            profileAssets = [],
+            profileAccentId = ColourId 0,
+            profileDeleted = False,
+            profileService = Nothing,
+            profileHandle = Nothing,
+            profileExpire = Nothing,
+            profileTeam = Nothing,
+            profileEmail = Nothing,
+            profileLegalholdStatus = UserLegalHoldDisabled
+          }
+      users = [u1, u2, u3]
+      q = ListUsersByIds $ u5 : u4 : map userQualifiedId users
+      expected =
+        Set.fromList
+          [ (Just $ userDisplayName u1, Nothing :: Maybe Email),
+            (Just $ userDisplayName u2, Nothing),
+            (Just $ userDisplayName u3, Nothing),
+            (Just $ profileName u5Profile, profileEmail u5Profile)
+          ]
+      expectedFailed = Set.fromList [u4]
+
+  let fedMockResponse req = do
+        -- Check that our allowed remote user is being asked for
+        if frTargetDomain req == evenFurtherAway
+          then -- Return the data for u5
+            pure $ encode [u5Profile]
+          else -- Otherwise mock an unavailable federation server
+            throw $ MockErrorResponse Http.status500 "Down for maintenance"
+      -- Galley isn't needed, but this is what mock federators are available.
+      galleyHandler _ = error "not mocked"
+  (response, _rpcCalls, _galleyCalls) <- liftIO $
+    withMockedFederatorAndGalley opts (Domain "example.com") fedMockResponse galleyHandler $ do
+      post
+        ( brig
+            . zUser (userId u1)
+            . contentJson
+            . path "list-users"
+            . body (RequestBodyLBS (Aeson.encode q))
+        )
+
+  pure response !!! do
+    const 200 === statusCode
+    const (Just expected) === result
+    const (pure $ pure expectedFailed) === resultFailed
+  where
+    result r =
+      Set.fromList
+        . map (\u -> (pure $ profileName u, profileEmail u))
+        . listUsersByIdFound
+        <$> responseJsonMaybe r
+    resultFailed r = fmap Set.fromList . listUsersByIdFailed <$> responseJsonMaybe r
+
 testCreateUserAnonExpiry :: Brig -> Http ()
 testCreateUserAnonExpiry b = do
   u1 <- randomUser b