Add endpoint to get User Id by qualified handle (#1281)

akshaymankar · jschaul · web-flow · commit fe647940d20c · 2020-12-16T11:46:22.000+01:00
* Federation is not implemented yet, so remote handles will always return 404.

* Include qualified user id in 'UserProfile' and 'UserHandleInfo'
  Also changes 'FromJSON' instances of these types as they are never required
  to be sent from clients. We use the FromJSON instances only in integration tests. 

* Rename schema for 'Qualified (Id a)' from QualifiedUserId to QualifiedId

Co-authored-by: jschaul &lt;jschaul@users.noreply.github.com&gt;
diff --git a/libs/types-common/src/Data/Handle.hs b/libs/types-common/src/Data/Handle.hs
@@ -28,13 +28,15 @@ where
 
 import Data.Aeson hiding ((<?>))
 import qualified Data.Attoparsec.ByteString.Char8 as Atto
+import Data.Bifunctor (Bifunctor (first))
 import qualified Data.ByteString as BS
 import Data.ByteString.Conversion (FromByteString (parser), ToByteString)
 import Data.Hashable (Hashable)
-import Data.Swagger (ToSchema (..))
+import Data.Swagger (ToParamSchema, ToSchema (..))
 import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text.E
 import Imports
+import Servant (FromHttpApiData (..))
 import Test.QuickCheck (Arbitrary (arbitrary), choose, elements, oneof)
 import Util.Attoparsec (takeUpToWhile)
 
@@ -45,7 +47,11 @@ import Util.Attoparsec (takeUpToWhile)
 newtype Handle = Handle
   {fromHandle :: Text}
   deriving stock (Eq, Show, Generic)
-  deriving newtype (ToJSON, ToByteString, Hashable, ToSchema)
+  deriving newtype (ToJSON, ToByteString, Hashable, ToSchema, ToParamSchema)
+
+instance FromHttpApiData Handle where
+  parseUrlPiece =
+    first Text.pack . parseHandleEither
 
 instance FromByteString Handle where
   parser = handleParser
diff --git a/libs/types-common/src/Data/Qualified.hs b/libs/types-common/src/Data/Qualified.hs
@@ -32,11 +32,12 @@ module Data.Qualified
     renderQualifiedHandle,
     mkQualifiedHandle,
     partitionRemoteOrLocalIds,
+    deprecatedUnqualifiedSchemaRef,
   )
 where
 
 import Control.Applicative (optional)
-import Control.Lens ((.~), (?~))
+import Control.Lens (view, (.~), (?~))
 import Data.Aeson (FromJSON, ToJSON, withObject, withText, (.:), (.=))
 import qualified Data.Aeson as Aeson
 import qualified Data.Attoparsec.ByteString.Char8 as Atto
@@ -48,6 +49,7 @@ import Data.Id (Id (toUUID))
 import Data.Proxy (Proxy (..))
 import Data.String.Conversions (cs)
 import Data.Swagger
+import Data.Swagger.Declare (Declare)
 import qualified Data.Text.Encoding as Text.E
 import qualified Data.UUID as UUID
 import Imports hiding (local)
@@ -133,12 +135,19 @@ renderQualifiedId = renderQualified (cs . UUID.toString . toUUID)
 mkQualifiedId :: Text -> Either String (Qualified (Id a))
 mkQualifiedId = Atto.parseOnly (parser <* Atto.endOfInput) . Text.E.encodeUtf8
 
+deprecatedUnqualifiedSchemaRef :: ToSchema a => Proxy a -> Text -> Declare (Definitions Schema) (Referenced Schema)
+deprecatedUnqualifiedSchemaRef p newField =
+  Inline
+    . (description ?~ ("Deprecated, use " <> newField))
+    . view schema
+    <$> declareNamedSchema p
+
 instance ToSchema (Qualified (Id a)) where
   declareNamedSchema _ = do
     idSchema <- declareSchemaRef (Proxy @(Id a))
     domainSchema <- declareSchemaRef (Proxy @Domain)
     return $
-      NamedSchema (Just "QualifiedUserId") $
+      NamedSchema (Just "QualifiedId") $
         mempty
           & type_ ?~ SwaggerObject
           & properties
diff --git a/libs/wire-api/src/Wire/API/User.hs b/libs/wire-api/src/Wire/API/User.hs
@@ -110,7 +110,7 @@ import qualified Data.Code as Code
 import qualified Data.Currency as Currency
 import Data.Handle (Handle)
 import qualified Data.HashMap.Strict as HashMap
-import qualified Data.HashMap.Strict.InsOrd as InsHashMap
+import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
 import Data.Id
 import Data.Json.Util (UTCTimeMillis, (#))
 import qualified Data.List as List
@@ -166,7 +166,7 @@ instance ToJSON UserIdList where
 -- other users. Each user also has access to their own profile in a richer format --
 -- 'SelfProfile'.
 data UserProfile = UserProfile
-  { profileId :: UserId,
+  { profileQualifiedId :: Qualified UserId,
     profileName :: Name,
     -- | DEPRECATED
     profilePict :: Pict,
@@ -189,6 +189,7 @@ data UserProfile = UserProfile
 -- mark 'deleted' as optional, but it is not a 'Maybe'
 instance ToSchema UserProfile where
   declareNamedSchema _ = do
+    idSchema <- deprecatedUnqualifiedSchemaRef (Proxy @UserId) "qualified_id"
     genericSchema <-
       genericDeclareNamedSchema
         ( swaggerOptions
@@ -206,6 +207,7 @@ instance ToSchema UserProfile where
     pure $
       genericSchema
         & over (schema . required) (List.delete "deleted")
+        & over (schema . properties) (InsOrdHashMap.insert "id" idSchema)
 
 modelUser :: Doc.Model
 modelUser = Doc.defineModel "User" $ do
@@ -237,25 +239,26 @@ modelUser = Doc.defineModel "User" $ do
 
 instance ToJSON UserProfile where
   toJSON u =
-    object $
-      "id" .= profileId u
-        # "name" .= profileName u
-        # "picture" .= profilePict u
-        # "assets" .= profileAssets u
-        # "accent_id" .= profileAccentId u
-        # "deleted" .= (if profileDeleted u then Just True else Nothing)
-        # "service" .= profileService u
-        # "handle" .= profileHandle u
-        # "locale" .= profileLocale u
-        # "expires_at" .= profileExpire u
-        # "team" .= profileTeam u
-        # "email" .= profileEmail u
-        # []
+    object
+      [ "id" .= _qLocalPart (profileQualifiedId u),
+        "qualified_id" .= profileQualifiedId u,
+        "name" .= profileName u,
+        "picture" .= profilePict u,
+        "assets" .= profileAssets u,
+        "accent_id" .= profileAccentId u,
+        "deleted" .= (if profileDeleted u then Just True else Nothing),
+        "service" .= profileService u,
+        "handle" .= profileHandle u,
+        "locale" .= profileLocale u,
+        "expires_at" .= profileExpire u,
+        "team" .= profileTeam u,
+        "email" .= profileEmail u
+      ]
 
 instance FromJSON UserProfile where
   parseJSON = withObject "UserProfile" $ \o ->
     UserProfile
-      <$> o .: "id"
+      <$> o .: "qualified_id"
       <*> o .: "name"
       <*> o .:? "picture" .!= noPict
       <*> o .:? "assets" .!= []
@@ -349,8 +352,8 @@ instance ToSchema User where
       genericSchema
         & over (schema . required) (List.delete "deleted")
         -- The UserIdentity fields need to be flat-included, not be in a sub-object
-        & over (schema . properties) (InsHashMap.delete "identity")
-        & over (schema . properties) (InsHashMap.union identityProperties)
+        & over (schema . properties) (InsOrdHashMap.delete "identity")
+        & over (schema . properties) (InsOrdHashMap.union identityProperties)
 
 -- FUTUREWORK:
 -- disentangle json serializations for 'User', 'NewUser', 'UserIdentity', 'NewUserOrigin'.
@@ -406,7 +409,7 @@ userSSOId = ssoIdentity <=< userIdentity
 connectedProfile :: User -> UserProfile
 connectedProfile u =
   UserProfile
-    { profileId = userId u,
+    { profileQualifiedId = userQualifiedId u,
       profileHandle = userHandle u,
       profileName = userDisplayName u,
       profilePict = userPict u,
@@ -429,7 +432,7 @@ publicProfile u =
   -- RecordWildCards or something similar because we want changes to the public profile
   -- to be EXPLICIT and INTENTIONAL so we don't accidentally leak sensitive data.
   let UserProfile
-        { profileId,
+        { profileQualifiedId,
           profileHandle,
           profileName,
           profilePict,
@@ -443,7 +446,7 @@ publicProfile u =
    in UserProfile
         { profileLocale = Nothing,
           profileEmail = Nothing,
-          profileId,
+          profileQualifiedId,
           profileHandle,
           profileName,
           profilePict,
diff --git a/libs/wire-api/src/Wire/API/User/Handle.hs b/libs/wire-api/src/Wire/API/User/Handle.hs
@@ -1,6 +1,6 @@
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE OverloadedLists #-}
 
 -- This file is part of the Wire Server implementation.
 --
@@ -29,17 +29,21 @@ module Wire.API.User.Handle
   )
 where
 
+import Control.Lens ((.~), (?~))
 import Data.Aeson
 import Data.Id (UserId)
+import Data.Proxy (Proxy (..))
+import Data.Qualified (Qualified (..), deprecatedUnqualifiedSchemaRef)
 import Data.Range
+import Data.Swagger (NamedSchema (..), SwaggerType (..), ToSchema (..), declareSchemaRef, properties, type_)
 import qualified Data.Swagger.Build.Api as Doc
 import Imports
 import Wire.API.Arbitrary (Arbitrary, GenericUniform (..))
 
 --------------------------------------------------------------------------------
 -- UserHandleInfo
 
-newtype UserHandleInfo = UserHandleInfo {userHandleId :: UserId}
+newtype UserHandleInfo = UserHandleInfo {userHandleId :: Qualified UserId}
   deriving stock (Eq, Show, Generic)
   deriving newtype (Arbitrary)
 
@@ -49,14 +53,30 @@ modelUserHandleInfo = Doc.defineModel "UserHandleInfo" $ do
   Doc.property "user" Doc.string' $
     Doc.description "ID of the user owning the handle"
 
+instance ToSchema UserHandleInfo where
+  declareNamedSchema _ = do
+    qualifiedIdSchema <- declareSchemaRef (Proxy @(Qualified UserId))
+    unqualifiedIdSchema <- deprecatedUnqualifiedSchemaRef (Proxy @UserId) "qualified_user"
+    pure $
+      NamedSchema
+        (Just "UserHandleInfo")
+        $ mempty
+          & type_ ?~ SwaggerObject
+          & properties
+            .~ [ ("user", unqualifiedIdSchema),
+                 ("qualified_user", qualifiedIdSchema)
+               ]
+
 instance ToJSON UserHandleInfo where
   toJSON (UserHandleInfo u) =
     object
-      ["user" .= u]
+      [ "user" .= _qLocalPart u, -- For backwards compatibility
+        "qualified_user" .= u
+      ]
 
 instance FromJSON UserHandleInfo where
   parseJSON = withObject "UserHandleInfo" $ \o ->
-    UserHandleInfo <$> o .: "user"
+    UserHandleInfo <$> o .: "qualified_user"
 
 --------------------------------------------------------------------------------
 -- CheckHandles
diff --git a/libs/wire-api/test/unit/Test/Wire/API/Swagger.hs b/libs/wire-api/test/unit/Test/Wire/API/Swagger.hs
@@ -24,13 +24,15 @@ import qualified Test.Tasty as T
 import Test.Tasty.QuickCheck (Arbitrary, counterexample, testProperty)
 import Type.Reflection (typeRep)
 import qualified Wire.API.User as User
+import qualified Wire.API.User.Handle as Handle
 
 tests :: T.TestTree
 tests =
   T.localOption (T.Timeout (60 * 1000000) "60s") . T.testGroup "JSON roundtrip tests" $
     [ testToJSON @User.UserProfile,
       testToJSON @User.User,
-      testToJSON @User.SelfProfile
+      testToJSON @User.SelfProfile,
+      testToJSON @Handle.UserHandleInfo
     ]
 
 testToJSON :: forall a. (Arbitrary a, Typeable a, ToJSON a, ToSchema a, Show a) => T.TestTree
diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs
@@ -224,12 +224,41 @@ type GetSelf =
     :> "self"
     :> Get '[Servant.JSON] Public.SelfProfile
 
+-- See Note [document responses]
+-- The responses looked like this:
+--   Doc.returns (Doc.ref Public.modelUserHandleInfo)
+--   Doc.response 200 "Handle info" Doc.end
+--   Doc.errorResponse handleNotFound
+type GetHandleInfoUnqualified =
+  Summary "Get information on a user handle"
+    :> ZAuthServant
+    :> "users"
+    :> "handles"
+    :> Capture' '[Description "The user handle"] "handle" Handle
+    :> Get '[Servant.JSON] Public.UserHandleInfo
+
+-- See Note [document responses]
+-- The responses looked like this:
+--   Doc.returns (Doc.ref Public.modelUserHandleInfo)
+--   Doc.response 200 "Handle info" Doc.end
+--   Doc.errorResponse handleNotFound
+type GetHandleInfoQualified =
+  Summary "Get information on a user handle"
+    :> ZAuthServant
+    :> "users"
+    :> "handles"
+    :> Capture "domain" Domain
+    :> Capture' '[Description "The user handle"] "handle" Handle
+    :> Get '[Servant.JSON] Public.UserHandleInfo
+
 type OutsideWorldAPI =
   CheckUserExistsUnqualified
     :<|> CheckUserExistsQualified
     :<|> GetUserUnqualified
     :<|> GetUserQualified
     :<|> GetSelf
+    :<|> GetHandleInfoUnqualified
+    :<|> GetHandleInfoQualified
 
 type SwaggerDocsAPI = "api" :> SwaggerSchemaUI "swagger-ui" "swagger.json"
 
@@ -253,6 +282,8 @@ servantSitemap =
     :<|> getUserUnqualifiedH
     :<|> getUserH
     :<|> getSelf
+    :<|> getHandleInfoUnqualifiedH
+    :<|> getHandleInfoH
 
 -- Note [ephemeral user sideeffect]
 -- If the user is ephemeral and expired, it will be removed upon calling
@@ -287,18 +318,7 @@ sitemap o = do
     Doc.errorResponse invalidHandle
     Doc.errorResponse handleNotFound
 
-  get "/users/handles/:handle" (continue getHandleInfoH) $
-    accept "application" "json"
-      .&. zauthUserId
-      .&. capture "handle"
-  document "GET" "getUserHandleInfo" $ do
-    Doc.summary "Get information on a user handle"
-    Doc.parameter Doc.Path "handle" Doc.bytes' $
-      Doc.description "The user handle"
-    Doc.returns (Doc.ref Public.modelUserHandleInfo)
-    Doc.response 200 "Handle info" Doc.end
-    Doc.errorResponse handleNotFound
-
+  -- some APIs moved to servant
   -- end User Handle API
 
   -- If the user is ephemeral and expired, it will be removed, see 'Brig.API.User.userGC'.
@@ -1297,23 +1317,34 @@ checkHandlesH (_ ::: _ ::: req) = do
   free <- lift $ API.checkHandles handles (fromRange num)
   return $ json (free :: [Handle])
 
-getHandleInfoH :: JSON ::: UserId ::: Handle -> Handler Response
-getHandleInfoH (_ ::: self ::: handle) =
-  maybe (setStatus status404 empty) json
-    <$> getHandleInfo self handle
+getHandleInfoUnqualifiedH :: UserId -> Handle -> Handler Public.UserHandleInfo
+getHandleInfoUnqualifiedH self handle = do
+  domain <- viewFederationDomain
+  getHandleInfoH self domain handle
+
+getHandleInfoH :: UserId -> Domain -> Handle -> Handler Public.UserHandleInfo
+getHandleInfoH self domain handle =
+  ifNothing (notFound "handle not found")
+    =<< getHandleInfo self (Qualified handle domain)
 
 -- FUTUREWORK: use 'runMaybeT' to simplify this.
-getHandleInfo :: UserId -> Handle -> Handler (Maybe Public.UserHandleInfo)
+getHandleInfo :: UserId -> Qualified Handle -> Handler (Maybe Public.UserHandleInfo)
 getHandleInfo self handle = do
-  ownerProfile <- do
-    -- FUTUREWORK(federation, #1268): resolve qualified handles, too
-    domain <- viewFederationDomain
-    maybeOwnerId <- fmap (flip Qualified domain) <$> (lift $ API.lookupHandle handle)
-    case maybeOwnerId of
-      Just ownerId -> lift $ API.lookupProfile self ownerId
-      Nothing -> return Nothing
-  owner <- filterHandleResults self (maybeToList ownerProfile)
-  return $ Public.UserHandleInfo . Public.profileId <$> listToMaybe owner
+  domain <- viewFederationDomain
+  if _qDomain handle == domain
+    then getLocalHandleInfo domain
+    else getRemoteHandleInfo
+  where
+    getLocalHandleInfo domain = do
+      maybeOwnerId <- lift $ API.lookupHandle (_qLocalPart handle)
+      case maybeOwnerId of
+        Nothing -> return Nothing
+        Just ownerId -> do
+          ownerProfile <- lift $ API.lookupProfile self (Qualified ownerId domain)
+          owner <- filterHandleResults self (maybeToList ownerProfile)
+          return $ Public.UserHandleInfo . Public.profileQualifiedId <$> listToMaybe owner
+    -- FUTUREWORK: Federate with remote backends
+    getRemoteHandleInfo = return Nothing
 
 changeHandleH :: UserId ::: ConnId ::: JsonRequest Public.HandleUpdate -> Handler Response
 changeHandleH (u ::: conn ::: req) = do
diff --git a/services/brig/test/integration/API/User/Handles.hs b/services/brig/test/integration/API/User/Handles.hs
@@ -221,7 +221,7 @@ assertCanFind brig from target = do
     const (userHandle target) === (>>= (listToMaybe >=> profileHandle)) . responseJsonMaybe
   get (brig . paths ["users", "handles", toByteString' targetHandle] . zUser (userId from)) !!! do
     const 200 === statusCode
-    const (Just (UserHandleInfo $ userId target)) === responseJsonMaybe
+    const (Just (UserHandleInfo $ userQualifiedId target)) === responseJsonMaybe
 
 assertCannotFind :: (Monad m, MonadCatch m, MonadIO m, MonadHttp m, HasCallStack) => Brig -> User -> User -> m ()
 assertCannotFind brig from target = do
