User subsystems: update identity

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

@@ -1,4 +1,5 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
 
 -- This file is part of the Wire Server implementation.
 --
@@ -34,7 +35,6 @@ import Data.Qualified (Qualified (..))
 import Data.Range
 import Data.SOP
 import Data.Schema as Schema
-import Generics.SOP qualified as GSOP
 import Imports hiding (head)
 import Network.Wai.Utilities
 import Servant (JSON)
@@ -519,6 +519,7 @@ type AccountAPI =
     :<|> Named
            "get-activate"
            ( Summary "Activate (i.e. confirm) an email address."
+               :> Description "Used in deprecated registration flow.  DO NOT USE"
                :> MakesFederatedCall 'Brig "send-connection-action"
                :> Description "See also 'POST /activate' which has a larger feature set."
                :> CanThrow 'UserKeyExists
@@ -533,7 +534,7 @@ type AccountAPI =
                     'GET
                     '[JSON]
                     GetActivateResponse
-                    ActivationRespWithStatus
+                    ActivationFullResponse
            )
     -- docs/reference/user/activation.md {#RefActivationSubmit}
     --
@@ -546,6 +547,7 @@ type AccountAPI =
                :> Description
                     "Activation only succeeds once and the number of \
                     \failed attempts for a valid key is limited."
+               :> Description "Used in deprecated registration flow.  DO NOT USE"
                :> MakesFederatedCall 'Brig "send-connection-action"
                :> CanThrow 'UserKeyExists
                :> CanThrow 'InvalidActivationCodeWrongUser
@@ -558,12 +560,13 @@ type AccountAPI =
                     'POST
                     '[JSON]
                     GetActivateResponse
-                    ActivationRespWithStatus
+                    ActivationFullResponse
            )
     -- docs/reference/user/activation.md {#RefActivationRequest}
     :<|> Named
            "post-activate-send"
            ( Summary "Send (or resend) an email activation code."
+               :> Description "Used in standard activation flow as a first step to trigger sending the validation email."
                :> CanThrow 'UserKeyExists
                :> CanThrow 'InvalidEmail
                :> CanThrow 'BlacklistedEmail
@@ -637,15 +640,7 @@ instance ToSchema DeprecatedMatchingResult where
         <* const []
           .= field "auto-connects" (array (null_ @SwaggerDoc))
 
-data ActivationRespWithStatus
-  = ActivationResp ActivationResponse
-  | ActivationRespDryRun
-  | ActivationRespPass
-  | ActivationRespSuccessNoIdent
-  deriving (Generic)
-  deriving (AsUnion GetActivateResponse) via GenericAsUnion GetActivateResponse ActivationRespWithStatus
-
-instance GSOP.Generic ActivationRespWithStatus
+deriving via GenericAsUnion GetActivateResponse ActivationFullResponse instance AsUnion GetActivateResponse ActivationFullResponse
 
 type GetActivateResponse =
   '[ Respond 200 "Activation successful." ActivationResponse,
@@ -1488,6 +1483,11 @@ type AuthAPI =
                :> "self"
                :> "email"
                :> Summary "Change your email address"
+               :> Description
+                    "Called when user changes email address in settings out of an active session.\n\n\
+                    \ We have to do zauth validation here in cases where we may not have a session token\
+                    \ (because no communication for 15 minutes). In these cases, nginz can't authenticate,\
+                    \ so brig has to do it based on the cookie(s)."
                :> Cookies '["zuid" ::: SomeUserToken]
                :> Bearer SomeAccessToken
                :> ReqBody '[JSON] EmailUpdate

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

@@ -29,6 +29,8 @@ module Wire.API.User.Activation
     -- * Activate
     Activate (..),
     ActivationResponse (..),
+    ActivationResult (..),
+    ActivationFullResponse (..),
 
     -- * SendActivationCode
     SendActivationCode (..),
@@ -45,6 +47,7 @@ import Data.OpenApi (ToParamSchema)
 import Data.OpenApi qualified as S
 import Data.Schema
 import Data.Text.Ascii
+import Generics.SOP qualified as GSOP
 import Imports
 import Servant (FromHttpApiData (..))
 import Wire.API.Locale
@@ -163,6 +166,7 @@ instance ToSchema Activate where
         ActivateEmail email -> (Nothing, Just email)
 
 -- | Information returned as part of a successful activation.
+-- TODO: this should not be visible outside of the UserSubsystem.
 data ActivationResponse = ActivationResponse
   { -- | The activated / verified user identity.
     activatedIdentity :: UserIdentity,
@@ -180,6 +184,28 @@ instance ToSchema ActivationResponse where
         <$> activatedIdentity .= userIdentityObjectSchema
         <*> activatedFirst .= (fromMaybe False <$> optFieldWithDocModifier "first" (description ?~ "Whether this is the first successful activation (i.e. account activation).") schema)
 
+-- | Something copied over from "Brig.API.Types".
+--
+-- TODO: this should not be visible outside of the UserSubsystem.
+data ActivationResult
+  = -- | The key/code was valid and successfully activated.
+    ActivationSuccess !(Maybe UserIdentity) !Bool
+  | -- | The key/code was valid but already recently activated.
+    ActivationPass
+
+-- | Outcome of an email address the procedure.
+--
+-- TODO: make `ActivationResult` and `ActivationResponse` local and only use this data type in
+-- the wire-subsystems interface.
+data ActivationFullResponse
+  = ActivationResp ActivationResponse
+  | ActivationRespDryRun
+  | ActivationRespPass
+  | ActivationRespSuccessNoIdentity
+  deriving (Generic)
+
+instance GSOP.Generic ActivationFullResponse
+
 --------------------------------------------------------------------------------
 -- SendActivationCode
 

libs/wire-subsystems/src/Wire/EmailSubsystem.hs

@@ -13,13 +13,18 @@ import Wire.API.User.Client (Client (..))
 
 data EmailSubsystem m a where
   SendPasswordResetMail :: EmailAddress -> PasswordResetPair -> Maybe Locale -> EmailSubsystem m ()
+  -- | Context: request to create new account with this email address
   SendVerificationMail :: EmailAddress -> ActivationKey -> ActivationCode -> Maybe Locale -> EmailSubsystem m ()
   SendCreateScimTokenVerificationMail :: EmailAddress -> Code.Value -> Maybe Locale -> EmailSubsystem m ()
   SendLoginVerificationMail :: EmailAddress -> Code.Value -> Maybe Locale -> EmailSubsystem m ()
+  -- | Context: request to create new account with this email address (also)
+  -- TODO(fisx): i think this is rendundant with SendVerificationMail, see docs/src/developer/reference/user/registration.md.  remove one of them?
   SendActivationMail :: EmailAddress -> Name -> ActivationKey -> ActivationCode -> Maybe Locale -> EmailSubsystem m ()
+  -- | Context: existing account owner changes their email
   SendEmailAddressUpdateMail :: EmailAddress -> Name -> ActivationKey -> ActivationCode -> Maybe Locale -> EmailSubsystem m ()
   SendNewClientEmail :: EmailAddress -> Name -> Client -> Locale -> EmailSubsystem m ()
   SendAccountDeletionEmail :: EmailAddress -> Name -> Code.Key -> Code.Value -> Locale -> EmailSubsystem m ()
+  -- | Context: create a team with owner
   SendTeamActivationMail :: EmailAddress -> Name -> ActivationKey -> ActivationCode -> Maybe Locale -> Text -> EmailSubsystem m ()
   SendTeamDeletionVerificationMail :: EmailAddress -> Code.Value -> Maybe Locale -> EmailSubsystem m ()
   SendUpgradePersonalToTeamConfirmationEmail :: EmailAddress -> Name -> Text -> Locale -> EmailSubsystem m ()

libs/wire-subsystems/src/Wire/UserSubsystem.hs

@@ -18,17 +18,19 @@ import Data.Range
 import Imports
 import Polysemy
 import Polysemy.Error
+import SAML2.WebSSO.Types (UserRef)
 import Wire.API.Federation.Error
 import Wire.API.Routes.Internal.Galley.TeamFeatureNoConfigMulti (TeamStatus)
 import Wire.API.Team.Feature
 import Wire.API.Team.Member (IsPerm (..), TeamMember)
 import Wire.API.User
+import Wire.API.User.Activation
 import Wire.API.User.Search
 import Wire.Arbitrary
 import Wire.GalleyAPIAccess (GalleyAPIAccess)
 import Wire.GalleyAPIAccess qualified as GalleyAPIAccess
 import Wire.InvitationStore
-import Wire.UserKeyStore (EmailKey, emailKeyOrig)
+import Wire.UserKeyStore
 import Wire.UserSearch.Types
 import Wire.UserSubsystem.Error (UserSubsystemError (..))
 
@@ -110,7 +112,15 @@ data UserSubsystem m a where
   GetSelfProfile :: Local UserId -> UserSubsystem m (Maybe SelfProfile)
   -- | Simple updates (as opposed to, eg., handle, where we need to manage locks).  Empty fields are ignored (not deleted).
   UpdateUserProfile :: Local UserId -> Maybe ConnId -> UpdateOriginType -> UserProfileUpdate -> UserSubsystem m ()
-  -- | Parse and lookup a handle.
+  -- | Initiate change of email address
+  UpdateUserEmailInit :: UserId -> EmailAddress -> UserSubsystem m ChangeEmailResponse
+  -- | Complete the email address update flow
+  UpdateUserEmailComplete :: Activate -> UserSubsystem m ActivationFullResponse
+  -- | Update SAML IdP EntityId (Issuer) and User NameId
+  UpdateUserSamlUserRef :: UserRef -> UserSubsystem m ()
+  -- | Update SCIM externalId
+  UpdateUserScimExternalId :: Text -> UserSubsystem m ()
+  -- | parse and lookup a handle, return what the operation has found
   CheckHandle :: Text {- use Handle here? -} -> UserSubsystem m CheckHandleResp
   -- | Check a number of 'Handle's for availability and returns at most 'Word' amount of them
   CheckHandles :: [Handle] -> Word -> UserSubsystem m [Handle]

libs/wire-subsystems/src/Wire/UserSubsystem/Error.hs

@@ -1,10 +1,12 @@
+{-# OPTIONS -Wwarn #-}
 module Wire.UserSubsystem.Error where
 
 import Imports
 import Network.HTTP.Types (status404)
 import Network.Wai.Utilities qualified as Wai
 import Wire.API.Error
 import Wire.API.Error.Brig qualified as E
+import Wire.API.User.Identity
 import Wire.Error
 
 -- | All errors that are thrown by the user subsystem are subsumed under this sum type.
@@ -28,6 +30,14 @@ data UserSubsystemError
   | UserSubsystemInvitationNotFound
   | UserSubsystemUserNotAllowedToJoinTeam Wai.Error
   | UserSubsystemMLSServicesNotAllowed
+  | UserSubsystemChangeEmailError ChangeEmailError
+  deriving (Eq, Show)
+
+data ChangeEmailError
+  = InvalidNewEmail !EmailAddress !String
+  | EmailExists !EmailAddress
+  | ChangeBlacklistedEmail !EmailAddress
+  | EmailManagedByScim
   deriving (Eq, Show)
 
 userSubsystemErrorToHttpError :: UserSubsystemError -> HttpError
@@ -50,5 +60,6 @@ userSubsystemErrorToHttpError =
     UserSubsystemInvitationNotFound -> Wai.mkError status404 "not-found" "Something went wrong, while looking up the invitation"
     UserSubsystemUserNotAllowedToJoinTeam e -> e
     UserSubsystemMLSServicesNotAllowed -> errorToWai @E.MLSServicesNotAllowed
+    UserSubsystemChangeEmailError _ -> todo -- check how this is handled in brig! is it also an api error? if not: is it ok to throw it here anyway?
 
 instance Exception UserSubsystemError

libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs

@@ -36,17 +36,22 @@ import Wire.API.Routes.FederationDomainConfig
 import Wire.API.Routes.Internal.Galley.TeamFeatureNoConfigMulti (TeamStatus (..))
 import Wire.API.Team.Feature
 import Wire.API.Team.Member
+import Wire.API.Team.Member hiding (userId)
 import Wire.API.Team.Permission qualified as Permission
 import Wire.API.Team.Role (defaultRole)
 import Wire.API.Team.SearchVisibility
 import Wire.API.Team.Size (TeamSize (TeamSize))
+import Wire.API.User
 import Wire.API.User as User
+import Wire.API.User.Activation
 import Wire.API.User.Search
 import Wire.API.UserEvent
 import Wire.Arbitrary
 import Wire.AuthenticationSubsystem
 import Wire.BlockListStore as BlockList
+import Wire.BlockListStore as BlockListStore
 import Wire.DeleteQueue
+import Wire.EmailSubsystem
 import Wire.Events
 import Wire.FederationAPIAccess
 import Wire.FederationConfigStore
@@ -132,6 +137,18 @@ runUserSubsystem cfg authInterpreter =
       UpdateUserProfile self mconn mb update ->
         runInputConst cfg $
           updateUserProfileImpl self mconn mb update
+      UpdateUserEmailInit uid email ->
+        runInputConst cfg $
+          updateUserEmailInitImpl uid email
+      UpdateUserEmailComplete activate ->
+        runInputConst cfg $
+          updateUserEmailCompleteImpl activate
+      UpdateUserSamlUserRef uref ->
+        runInputConst cfg $
+          undefined uref
+      UpdateUserScimExternalId scimEId ->
+        runInputConst cfg $
+          undefined scimEId
       CheckHandle uhandle ->
         runInputConst cfg $
           checkHandleImpl uhandle
@@ -203,6 +220,102 @@ internalFindTeamInvitationImpl (Just e) c =
 isBlockedImpl :: (Member BlockListStore r) => EmailAddress -> Sem r Bool
 isBlockedImpl = BlockList.exists . mkEmailKey
 
+-- :> CanThrow 'InvalidEmail
+-- :> CanThrow 'UserKeyExists
+-- :> CanThrow 'BlacklistedEmail
+-- :> CanThrow 'BadCredentials
+--
+-- https://staging-nginz-https.zinfra.io/v5/api/swagger-ui/#/default/put_access_self_email  "change-self-email" -- this is the one we're interested in for this PR.
+-- https://staging-nginz-https.zinfra.io/v5/api/swagger-ui/#/default/post_activate_send  "post-activate-send"
+
+-- | Call 'changeEmail' and process result: if email changes to itself, succeed, if not, send
+-- validation email.
+updateUserEmailInitImpl ::
+  forall r.
+  (Member BlockListStore r, Member UserKeyStore r, Member EmailSubsystem r) =>
+  UserId ->
+  EmailAddress ->
+  UpdateOriginType ->
+  Sem r ChangeEmailResponse
+updateUserEmailInitImpl uid email updateOriginType = do
+  result <- prepareUpdateUserEmail u email updateOriginType
+  case result of
+    ChangeEmailIdempotent ->
+      pure ChangeEmailResponseIdempotent
+    ChangeEmailNeedsActivation (usr, adata, en) -> lift $ do
+      liftSem $ sendOutEmail usr adata en
+      wrapClient $ Data.updateEmailUnvalidated u email
+      wrapClient $ reindex u
+      pure ChangeEmailResponseNeedsActivation
+  where
+    sendOutEmail usr adata en = do
+      (maybe sendActivationMail (const sendEmailAddressUpdateMail) usr.userIdentity)
+        en
+        (userDisplayName usr)
+        (activationKey adata)
+        (activationCode adata)
+        (Just (userLocale usr))
+
+-- | Prepare changing the email (checking a number of invariants).
+prepareUpdateUserEmail ::
+  (Member BlockListStore r, Member UserKeyStore r, Member (Error ChangeEmailError) r) =>
+  UserId ->
+  EmailAddress ->
+  UpdateOriginType ->
+  Sem r ChangeEmailResult
+prepareUpdateUserEmail u email updateOriginType = do
+  em <-
+    either
+      (throwE . InvalidNewEmail email)
+      pure
+      (validateEmail email)
+  let ek = mkEmailKey em
+  blacklisted <- BlockListStore.exists ek
+  when blacklisted $
+    throwE (ChangeBlacklistedEmail email)
+  available <- lift $ liftSem $ keyAvailable ek (Just u)
+  unless available $
+    throwE $
+      EmailExists email
+  usr <- maybe (throwM $ UserProfileNotFound u) pure =<< lift (wrapClient $ Data.lookupUser WithPendingInvitations u)
+  case emailIdentity =<< userIdentity usr of
+    -- The user already has an email address and the new one is exactly the same
+    Just current | current == em -> pure ChangeEmailIdempotent
+    _ -> do
+      unless (userManagedBy usr /= ManagedByScim || updateOriginType == UpdateOriginScim) $
+        throwE EmailManagedByScim
+      timeout <- setActivationTimeout <$> view settings
+      act <- lift . wrapClient $ Data.newActivation ek timeout (Just u)
+      pure $ ChangeEmailNeedsActivation (usr, act, em)
+
+-- | Outcome of the invariants check in 'Brig.API.User.changeEmail'.
+-- TODO: does this belong here?  or in wire-api?
+data ChangeEmailResult
+  = -- | The request was successful, user needs to verify the new email address
+    ChangeEmailNeedsActivation !(User, Activation, EmailAddress)
+  | -- | The user asked to change the email address to the one already owned
+    ChangeEmailIdempotent
+
+-- | The information associated with the pending activation of a 'UserKey'.
+data Activation = Activation
+  { -- | An opaque key for the original 'UserKey' pending activation.
+    activationKey :: !ActivationKey,
+    -- | The confidential activation code.
+    activationCode :: !ActivationCode
+  }
+  deriving (Eq, Show)
+
+-- :> CanThrow 'UserKeyExists
+-- :> CanThrow 'InvalidActivationCodeWrongUser
+-- :> CanThrow 'InvalidActivationCodeWrongCode
+-- :> CanThrow 'InvalidEmail
+-- :> CanThrow 'InvalidPhone
+--
+-- https://staging-nginz-https.zinfra.io/v5/api/swagger-ui/#/default/get_activate  "get-activate" (is this still used?)
+-- https://staging-nginz-https.zinfra.io/v5/api/swagger-ui/#/default/post_activate  "post-activate" (is this still used?)
+updateUserEmailCompleteImpl :: a
+updateUserEmailCompleteImpl = undefined
+
 blockListDeleteImpl :: (Member BlockListStore r) => EmailAddress -> Sem r ()
 blockListDeleteImpl = BlockList.delete . mkEmailKey