Brig: Servantify POST /register and POST /i/users endpoint (#2121)

Noteworthy things:

- I servantified `POST /i/users` because it had pretty much the same API and was using the same types.
- While registering a user into a team, if the team has legal hold, the user can only be added if the fanoutLimit has not been reached. This check happens in galley, which generates a `Wai.Error`, brig just throws this error and so isn't aware of internals. This kind of error cannot be transformed into and `ErrorDescription`. So, for now (until galley's internal API is servantiified), brig throws this error using `throwM`, this error gets caught and handled by the `Handler` monad when it executes requests. This is of course not ideal. But hopefully we get to servantify Galley's internal endpoints and we can get rid of this hack.
- The parser for `NewUser` is fairly complex some fields depend on other fields. To help with this, I created `NewUserRaw` which just parses individual fields. The schema for `NewUser` type uses `withParser` to do the validation and make composite fields.
-  Remove ToJSON/FromJSON for UserIdentity, use Schema for User. The ToJSON for UserIdentity encoded nulls, but every other object which used it didn't encode nulls. So, it was better to remove it.

Co-authored-by: Matthias Fischmann <[email protected]>

Author: akshaymankar

changelog.d/5-internal/servantify-register

@@ -0,0 +1 @@
+Servantify `POST /register` and `POST /i/users` endpoints

libs/wire-api/package.yaml

@@ -123,6 +123,7 @@ tests:
     - pretty
     - proto-lens
     - QuickCheck
+    - schema-profunctor
     - string-conversions
     - swagger2
     - tasty

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

@@ -387,3 +387,29 @@ type MLSIdentityMismatch =
     403
     "mls-identity-mismatch"
     "Prekey credential does not match qualified client ID"
+
+type WhitelistError = ErrorDescription 403 "unauthorized" "Unauthorized e-mail address or phone number."
+
+type InvalidInvitationCode = ErrorDescription 400 "invalid-invitation-code" "Invalid invitation code."
+
+type MissingIdentity = ErrorDescription 403 "missing-identity" "Using an invitation code requires registering the given email and/or phone."
+
+type BlacklistedEmail =
+  ErrorDescription
+    403
+    "blacklisted-email"
+    "The given e-mail address has been blacklisted due to a permanent bounce \
+    \or a complaint."
+
+type InvalidEmail = ErrorDescription 400 "invalid-email" "Invalid e-mail address."
+
+type InvalidActivationCode msg = ErrorDescription 404 "invalid-code" msg
+
+type InvalidActivationCodeWrongUser = InvalidActivationCode "User does not exist."
+
+type InvalidActivationCodeWrongCode = InvalidActivationCode "Invalid activation code"
+
+type TooManyTeamMembers = ErrorDescription 403 "too-many-team-members" "Too many members in this team."
+
+-- | docs/reference/user/registration.md {#RefRestrictRegistration}.
+type UserCreationRestricted = ErrorDescription 403 "user-creation-restricted" "This instance does not allow creation of personal users or teams."

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

@@ -17,6 +17,8 @@
 
 module Wire.API.Routes.Internal.Brig
   ( API,
+    EJPD_API,
+    AccountAPI,
     EJPDRequest,
     GetAccountFeatureConfig,
     PutAccountFeatureConfig,
@@ -39,7 +41,10 @@ import Servant.Swagger.UI
 import Wire.API.Connection
 import Wire.API.Routes.Internal.Brig.Connection
 import Wire.API.Routes.Internal.Brig.EJPD
+import Wire.API.Routes.MultiVerb
+import Wire.API.Routes.Named
 import qualified Wire.API.Team.Feature as ApiFt
+import Wire.API.User
 
 type EJPDRequest =
   Summary
@@ -109,15 +114,29 @@ type GetAllConnections =
     :> ReqBody '[Servant.JSON] ConnectionsStatusRequestV2
     :> Post '[Servant.JSON] [ConnectionStatusV2]
 
+type EJPD_API =
+  ( EJPDRequest
+      :<|> GetAccountFeatureConfig
+      :<|> PutAccountFeatureConfig
+      :<|> DeleteAccountFeatureConfig
+      :<|> GetAllConnectionsUnqualified
+      :<|> GetAllConnections
+  )
+
+type AccountAPI =
+  -- This endpoint can lead to the following events being sent:
+  -- - UserActivated event to created user, if it is a team invitation or user has an SSO ID
+  -- - UserIdentityUpdated event to created user, if email or phone get activated
+  Named
+    "createUserNoVerify"
+    ( "users"
+        :> ReqBody '[Servant.JSON] NewUser
+        :> MultiVerb 'POST '[Servant.JSON] RegisterInternalResponses (Either RegisterError SelfProfile)
+    )
+
 type API =
   "i"
-    :> ( EJPDRequest
-           :<|> GetAccountFeatureConfig
-           :<|> PutAccountFeatureConfig
-           :<|> DeleteAccountFeatureConfig
-           :<|> GetAllConnectionsUnqualified
-           :<|> GetAllConnections
-       )
+    :> (EJPD_API :<|> AccountAPI)
 
 type SwaggerDocsAPI = "api" :> "internal" :> SwaggerSchemaUI "swagger-ui" "swagger.json"
 

libs/wire-api/src/Wire/API/Routes/Named.hs

@@ -22,6 +22,7 @@ import Data.Proxy
 import GHC.TypeLits
 import Imports
 import Servant
+import Servant.Client
 import Servant.Swagger
 
 newtype Named named x = Named {unnamed :: x}
@@ -40,6 +41,11 @@ instance HasServer api ctx => HasServer (Named name api) ctx where
 instance RoutesToPaths api => RoutesToPaths (Named name api) where
   getRoutes = getRoutes @api
 
+instance HasClient m api => HasClient m (Named n api) where
+  type Client m (Named n api) = Client m api
+  clientWithRoute pm _ req = clientWithRoute pm (Proxy @api) req
+  hoistClientMonad pm _ f = hoistClientMonad pm (Proxy @api) f
+
 type family FindName n (api :: *) :: (n, *) where
   FindName n (Named name api) = '(name, api)
   FindName n (x :> api) = AddPrefix x (FindName n api)

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

@@ -312,6 +312,24 @@ type SelfAPI =
                :> MultiVerb 'PUT '[JSON] ChangeHandleResponses (Maybe ChangeHandleError)
            )
 
+type AccountAPI =
+  -- docs/reference/user/registration.md {#RefRegistration}
+  --
+  -- This endpoint can lead to the following events being sent:
+  -- - UserActivated event to created user, if it is a team invitation or user has an SSO ID
+  -- - UserIdentityUpdated event to created user, if email code or phone code is provided
+  Named
+    "register"
+    ( Summary "Register a new user."
+        :> Description
+             "If the environment where the registration takes \
+             \place is private and a registered email address or phone \
+             \number is not whitelisted, a 403 error is returned."
+        :> "register"
+        :> ReqBody '[JSON] NewUserPublic
+        :> MultiVerb 'POST '[JSON] RegisterResponses (Either RegisterError RegisterSuccess)
+    )
+
 type PrekeyAPI =
   Named
     "get-users-prekeys-client-unqualified"
@@ -714,6 +732,7 @@ type MLSAPI = LiftNamed (ZLocalUser :> "mls" :> MLSKeyPackageAPI)
 type BrigAPI =
   UserAPI
     :<|> SelfAPI
+    :<|> AccountAPI
     :<|> ClientAPI
     :<|> PrekeyAPI
     :<|> UserClientAPI

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

@@ -113,7 +113,6 @@ models =
     Push.Token.modelPushTokenList,
     Team.modelTeam,
     Team.modelTeamList,
-    Team.modelNewBindingTeam,
     Team.modelNewNonBindingTeam,
     Team.modelUpdateData,
     Team.modelTeamDelete,
@@ -141,7 +140,6 @@ models =
     Team.SearchVisibility.modelTeamSearchVisibility,
     User.modelUserIdList,
     User.modelUser,
-    User.modelNewUser,
     User.modelEmailUpdate,
     User.modelDelete,
     User.modelVerifyDelete,

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

@@ -39,6 +39,7 @@ module Wire.API.Team
 
     -- * NewTeam
     BindingNewTeam (..),
+    bindingNewTeamObjectSchema,
     NonBindingNewTeam (..),
     NewTeam (..),
     newNewTeam,
@@ -62,7 +63,6 @@ module Wire.API.Team
     -- * Swagger
     modelTeam,
     modelTeamList,
-    modelNewBindingTeam,
     modelNewNonBindingTeam,
     modelUpdateData,
     modelTeamDelete,
@@ -181,24 +181,14 @@ newtype BindingNewTeam = BindingNewTeam (NewTeam ())
   deriving stock (Eq, Show, Generic)
   deriving (ToJSON, FromJSON, S.ToSchema) via (Schema BindingNewTeam)
 
-modelNewBindingTeam :: Doc.Model
-modelNewBindingTeam = Doc.defineModel "NewBindingTeam" $ do
-  Doc.description "Required data when creating new teams"
-  Doc.property "name" Doc.string' $
-    Doc.description "team name"
-  Doc.property "icon" Doc.string' $
-    Doc.description "team icon (asset ID)"
-  Doc.property "icon_key" Doc.string' $ do
-    Doc.description "team icon asset key"
-    Doc.optional
-
 instance ToSchema BindingNewTeam where
-  schema = BindingNewTeam <$> unwrap .= newTeamSchema "BindingNewTeam" sch
-    where
-      unwrap (BindingNewTeam nt) = nt
+  schema = object "BindingNewTeam" bindingNewTeamObjectSchema
 
-      sch :: ValueSchema SwaggerDoc ()
-      sch = null_
+bindingNewTeamObjectSchema :: ObjectSchema SwaggerDoc BindingNewTeam
+bindingNewTeamObjectSchema =
+  BindingNewTeam <$> unwrap .= newTeamObjectSchema null_
+  where
+    unwrap (BindingNewTeam nt) = nt
 
 -- FUTUREWORK: since new team members do not get serialized, we zero them here.
 -- it may be worth looking into how this can be solved in the types.
@@ -214,7 +204,10 @@ newtype NonBindingNewTeam = NonBindingNewTeam (NewTeam (Range 1 127 [TeamMember]
   deriving (FromJSON, ToJSON, S.ToSchema) via (Schema NonBindingNewTeam)
 
 instance ToSchema NonBindingNewTeam where
-  schema = NonBindingNewTeam <$> unwrap .= newTeamSchema "NonBindingNewTeam" sch
+  schema =
+    object "NonBindingNewTeam" $
+      NonBindingNewTeam
+        <$> unwrap .= newTeamObjectSchema sch
     where
       unwrap (NonBindingNewTeam nt) = nt
 
@@ -247,14 +240,13 @@ data NewTeam a = NewTeam
 newNewTeam :: Range 1 256 Text -> Range 1 256 Text -> NewTeam a
 newNewTeam nme ico = NewTeam nme ico Nothing Nothing
 
-newTeamSchema :: HasSchemaRef d => Text -> ValueSchema d a -> ValueSchema NamedSwaggerDoc (NewTeam a)
-newTeamSchema name sch =
-  object name $
-    NewTeam
-      <$> _newTeamName .= field "name" schema
-      <*> _newTeamIcon .= field "icon" schema
-      <*> _newTeamIconKey .= maybe_ (optField "icon_key" schema)
-      <*> _newTeamMembers .= maybe_ (optField "members" sch)
+newTeamObjectSchema :: ValueSchema SwaggerDoc a -> ObjectSchema SwaggerDoc (NewTeam a)
+newTeamObjectSchema sch =
+  NewTeam
+    <$> _newTeamName .= field "name" schema
+    <*> _newTeamIcon .= field "icon" schema
+    <*> _newTeamIconKey .= maybe_ (optField "icon_key" schema)
+    <*> _newTeamMembers .= maybe_ (optField "members" sch)
 
 --------------------------------------------------------------------------------
 -- TeamUpdateData