Brig: Servantify POST /register and POST /i/users endpoint

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