[WPB-8881] Move email update and remove operations to effects (wireap…

…p#4316)

* Move user email updating functions to wire-subsystems

* DELETE /self/email: ZLocalUser instead of ZUser

* Wrap a function signature

* Move 'deleteEmail' to UserStore

* Migrate 'removeEmail' to UserSubsystem

* Add a change log

* Rename an activation code action

* Rename UserSubsystem helpers

* Remove redundant error interpretation

* Elaborate a recusive interpretation cycle

* Drop an unused no-password error

* Implement removeEmail via RemoveEmailEither

This also changes the error type in RemoveEmailEither to the general
UserSubsystemError type. Handler-specific reinterpretations are done in
the handler instead.

* "Fix" timing issue in (old) galley integration tests.

* Move reading from the environment to a helper

---------

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

changelog.d/5-internal/WPB-8881

@@ -0,0 +1 @@
+Move email update and remove operations to effects

libs/wire-api/src/Wire/API/Error/Brig.hs

@@ -67,6 +67,7 @@ data BrigError
   | NameManagedByScim
   | HandleManagedByScim
   | LocaleManagedByScim
+  | EmailManagedByScim
   | LastIdentity
   | NoPassword
   | ChangePasswordMustDiffer
@@ -247,6 +248,8 @@ type instance MapError 'HandleManagedByScim = 'StaticError 403 "managed-by-scim"
 
 type instance MapError 'LocaleManagedByScim = 'StaticError 403 "managed-by-scim" "Updating locale is not allowed, because it is managed by SCIM, or E2EId is enabled"
 
+type instance MapError 'EmailManagedByScim = 'StaticError 403 "managed-by-scim" "Updating email is not allowed, because it is managed by SCIM, or E2EId is enabled"
+
 type instance MapError 'LastIdentity = 'StaticError 403 "last-identity" "The last user identity cannot be removed."
 
 type instance MapError 'NoPassword = 'StaticError 403 "no-password" "The user has no password."

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

@@ -363,7 +363,7 @@ type SelfAPI =
           :> Description
                "Your email address can only be removed if you also have a \
                \phone number."
-          :> ZUser
+          :> ZLocalUser
           :> "self"
           :> "email"
           :> MultiVerb 'DELETE '[JSON] RemoveIdentityResponses (Maybe RemoveIdentityError)

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

@@ -1515,7 +1515,6 @@ instance (res ~ ChangePhoneResponses) => AsUnion res (Maybe ChangePhoneError) wh
 
 data RemoveIdentityError
   = LastIdentity
-  | NoPassword
   | NoIdentity
   deriving (Generic)
   deriving (AsUnion RemoveIdentityErrorResponses) via GenericAsUnion RemoveIdentityErrorResponses RemoveIdentityError
@@ -1524,7 +1523,6 @@ instance GSOP.Generic RemoveIdentityError
 
 type RemoveIdentityErrorResponses =
   [ ErrorResponse 'E.LastIdentity,
-    ErrorResponse 'E.NoPassword,
     ErrorResponse 'E.NoIdentity
   ]
 

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

@@ -32,6 +32,9 @@ module Wire.API.User.Activation
 
     -- * SendActivationCode
     SendActivationCode (..),
+
+    -- * Activation
+    Activation (..),
   )
 where
 
@@ -211,3 +214,12 @@ instance ToSchema SendActivationCode where
       objectDesc =
         description
           ?~ "Data for requesting an email code to be sent. 'email' must be present."
+
+--  | The information associated with the pending activation of an 'EmailKey'.
+data Activation = Activation
+  { -- | An opaque key for the original 'EmailKey' pending activation.
+    activationKey :: !ActivationKey,
+    -- | The confidential activation code.
+    activationCode :: !ActivationCode
+  }
+  deriving (Eq, Show)

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

@@ -21,10 +21,19 @@ module Wire.ActivationCodeStore where
 import Data.Id
 import Imports
 import Polysemy
+import Util.Timeout
 import Wire.API.User.Activation
 import Wire.UserKeyStore
 
 data ActivationCodeStore :: Effect where
   LookupActivationCode :: EmailKey -> ActivationCodeStore m (Maybe (Maybe UserId, ActivationCode))
+  -- | Create a code for a new pending activation for a given 'EmailKey'
+  NewActivationCode ::
+    EmailKey ->
+    -- | The timeout for the activation code.
+    Timeout ->
+    -- | The user with whom to associate the activation code.
+    Maybe UserId ->
+    ActivationCodeStore m Activation
 
 makeSem ''ActivationCodeStore

libs/wire-subsystems/src/Wire/ActivationCodeStore/Cassandra.hs

@@ -1,31 +1,63 @@
-module Wire.ActivationCodeStore.Cassandra where
+module Wire.ActivationCodeStore.Cassandra (interpretActivationCodeStoreToCassandra) where
 
 import Cassandra
 import Data.Id
+import Data.Text (pack)
 import Data.Text.Ascii qualified as Ascii
 import Data.Text.Encoding qualified as T
 import Imports
+import OpenSSL.BN (randIntegerZeroToNMinusOne)
 import OpenSSL.EVP.Digest
 import Polysemy
 import Polysemy.Embed
+import Text.Printf (printf)
+import Util.Timeout
 import Wire.API.User.Activation
+import Wire.API.User.EmailAddress
 import Wire.ActivationCodeStore
-import Wire.UserKeyStore (EmailKey, emailKeyUniq)
+import Wire.UserKeyStore
 
 interpretActivationCodeStoreToCassandra :: (Member (Embed IO) r) => ClientState -> InterpreterFor ActivationCodeStore r
 interpretActivationCodeStoreToCassandra casClient =
   interpret $
-    runEmbedded (runClient casClient) . \case
-      LookupActivationCode ek -> embed do
+    runEmbedded (runClient casClient) . embed . \case
+      LookupActivationCode ek -> do
         liftIO (mkActivationKey ek)
           >>= retry x1 . query1 cql . params LocalQuorum . Identity
+      NewActivationCode ek timeout uid -> newActivationCodeImpl ek timeout uid
   where
     cql :: PrepQuery R (Identity ActivationKey) (Maybe UserId, ActivationCode)
     cql =
-      [sql| 
+      [sql|
       SELECT user, code FROM activation_keys WHERE key = ?
       |]
 
+-- | Create a new pending activation for a given 'EmailKey'.
+newActivationCodeImpl ::
+  (MonadClient m) =>
+  EmailKey ->
+  -- | The timeout for the activation code.
+  Timeout ->
+  -- | The user with whom to associate the activation code.
+  Maybe UserId ->
+  m Activation
+newActivationCodeImpl uk timeout u = do
+  let typ = "email"
+      key = fromEmail (emailKeyOrig uk)
+  code <- liftIO $ genCode
+  insert typ key code
+  where
+    insert t k c = do
+      key <- liftIO $ mkActivationKey uk
+      retry x5 . write keyInsert $ params LocalQuorum (key, t, k, c, u, maxAttempts, round timeout)
+      pure $ Activation key c
+    genCode =
+      ActivationCode . Ascii.unsafeFromText . pack . printf "%06d"
+        <$> randIntegerZeroToNMinusOne 1000000
+
+--------------------------------------------------------------------------------
+-- Utilities
+
 mkActivationKey :: EmailKey -> IO ActivationKey
 mkActivationKey k = do
   Just d <- getDigestByName "SHA256"
@@ -35,3 +67,13 @@ mkActivationKey k = do
       . digestBS d
       . T.encodeUtf8
       $ emailKeyUniq k
+
+keyInsert :: PrepQuery W (ActivationKey, Text, Text, ActivationCode, Maybe UserId, Int32, Int32) ()
+keyInsert =
+  "INSERT INTO activation_keys \
+  \(key, key_type, key_text, code, user, retries) VALUES \
+  \(?  , ?       , ?       , ?   , ?   , ?      ) USING TTL ?"
+
+-- | Max. number of activation attempts per 'ActivationKey'.
+maxAttempts :: Int32
+maxAttempts = 3

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

@@ -54,6 +54,7 @@ data UserStore m a where
   GetIndexUsersPaginated :: Int32 -> Maybe PagingState -> UserStore m (PageWithState IndexUser)
   GetUsers :: [UserId] -> UserStore m [StoredUser]
   UpdateUser :: UserId -> StoredUserUpdate -> UserStore m ()
+  UpdateEmailUnvalidated :: UserId -> EmailAddress -> UserStore m ()
   UpdateUserHandleEither :: UserId -> StoredUserHandleUpdate -> UserStore m (Either StoredUserUpdateError ())
   DeleteUser :: User -> UserStore m ()
   -- | This operation looks up a handle but is guaranteed to not give you stale locks.
@@ -73,6 +74,7 @@ data UserStore m a where
   GetActivityTimestamps :: UserId -> UserStore m [Maybe UTCTime]
   GetRichInfo :: UserId -> UserStore m (Maybe RichInfoAssocList)
   GetUserAuthenticationInfo :: UserId -> UserStore m (Maybe (Maybe Password, AccountStatus))
+  DeleteEmail :: UserId -> UserStore m ()
 
 makeSem ''UserStore
 

libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs

@@ -26,6 +26,7 @@ interpretUserStoreCassandra casClient =
       GetIndexUser uid -> getIndexUserImpl uid
       GetIndexUsersPaginated pageSize mPagingState -> getIndexUserPaginatedImpl pageSize mPagingState
       UpdateUser uid update -> updateUserImpl uid update
+      UpdateEmailUnvalidated uid email -> updateEmailUnvalidatedImpl uid email
       UpdateUserHandleEither uid update -> updateUserHandleEitherImpl uid update
       DeleteUser user -> deleteUserImpl user
       LookupHandle hdl -> lookupHandleImpl LocalQuorum hdl
@@ -37,6 +38,7 @@ interpretUserStoreCassandra casClient =
       GetActivityTimestamps uid -> getActivityTimestampsImpl uid
       GetRichInfo uid -> getRichInfoImpl uid
       GetUserAuthenticationInfo uid -> getUserAuthenticationInfoImpl uid
+      DeleteEmail uid -> deleteEmailImpl uid
 
 getUserAuthenticationInfoImpl :: UserId -> Client (Maybe (Maybe Password, AccountStatus))
 getUserAuthenticationInfoImpl uid = fmap f <$> retry x1 (query1 authSelect (params LocalQuorum (Identity uid)))
@@ -105,6 +107,13 @@ updateUserImpl uid update =
     for_ update.accentId \c -> addPrepQuery userAccentIdUpdate (c, uid)
     for_ update.supportedProtocols \a -> addPrepQuery userSupportedProtocolsUpdate (a, uid)
 
+updateEmailUnvalidatedImpl :: UserId -> EmailAddress -> Client ()
+updateEmailUnvalidatedImpl u e =
+  retry x5 $ write userEmailUnvalidatedUpdate (params LocalQuorum (e, u))
+  where
+    userEmailUnvalidatedUpdate :: PrepQuery W (EmailAddress, UserId) ()
+    userEmailUnvalidatedUpdate = "UPDATE user SET email_unvalidated = ? WHERE id = ?"
+
 updateUserHandleEitherImpl :: UserId -> StoredUserHandleUpdate -> Client (Either StoredUserUpdateError ())
 updateUserHandleEitherImpl uid update =
   runM $ runError do
@@ -200,6 +209,9 @@ getRichInfoImpl uid =
     q :: PrepQuery R (Identity UserId) (Identity RichInfoAssocList)
     q = "SELECT json FROM rich_info WHERE user = ?"
 
+deleteEmailImpl :: UserId -> Client ()
+deleteEmailImpl u = retry x5 $ write userEmailDelete (params LocalQuorum (Identity u))
+
 --------------------------------------------------------------------------------
 -- Queries
 
@@ -259,3 +271,6 @@ activatedSelect = "SELECT activated FROM user WHERE id = ?"
 
 localeSelect :: PrepQuery R (Identity UserId) (Maybe Language, Maybe Country)
 localeSelect = "SELECT language, country FROM user WHERE id = ?"
+
+userEmailDelete :: PrepQuery W (Identity UserId) ()
+userEmailDelete = {- `IF EXISTS`, but that requires benchmarking -} "UPDATE user SET email = null, write_time_bumper = 0 WHERE id = ?"

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

@@ -18,20 +18,28 @@ import Data.Range
 import Imports
 import Polysemy
 import Polysemy.Error
+import Polysemy.Input
 import Wire.API.Federation.Error
 import Wire.API.Routes.Internal.Galley.TeamFeatureNoConfigMulti (TeamStatus)
 import Wire.API.Team.Export (TeamExportUser)
 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.ActivationCodeStore
 import Wire.Arbitrary
+import Wire.BlockListStore
+import Wire.BlockListStore qualified as BlockListStore
+import Wire.EmailSubsystem
 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.UserStore
 import Wire.UserSubsystem.Error (UserSubsystemError (..))
+import Wire.UserSubsystem.UserSubsystemConfig
 
 -- | Who is performing this update operation / who is allowed to?  (Single source of truth:
 -- users managed by SCIM can't be updated by clients and vice versa.)
@@ -88,6 +96,14 @@ data GetBy = MkGetBy
 instance Default GetBy where
   def = MkGetBy NoPendingInvitations [] []
 
+-- | Outcome of email change invariant checks.
+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
+  deriving (Show)
+
 data UserSubsystem m a where
   -- | First arg is for authorization only.
   GetUserProfiles :: Local UserId -> [Qualified UserId] -> UserSubsystem m [UserProfile]
@@ -145,6 +161,7 @@ data UserSubsystem m a where
   InternalUpdateSearchIndex :: UserId -> UserSubsystem m ()
   InternalFindTeamInvitation :: Maybe EmailKey -> InvitationCode -> UserSubsystem m StoredInvitation
   GetUserExportData :: UserId -> UserSubsystem m (Maybe TeamExportUser)
+  RemoveEmailEither :: Local UserId -> UserSubsystem m (Either UserSubsystemError ())
 
 -- | the return type of 'CheckHandle'
 data CheckHandleResp
@@ -154,6 +171,14 @@ data CheckHandleResp
 
 makeSem ''UserSubsystem
 
+removeEmail ::
+  ( Member UserSubsystem r,
+    Member (Error UserSubsystemError) r
+  ) =>
+  Local UserId ->
+  Sem r ()
+removeEmail = removeEmailEither >=> fromEither
+
 getUserProfile :: (Member UserSubsystem r) => Local UserId -> Qualified UserId -> Sem r (Maybe UserProfile)
 getUserProfile luid targetUser =
   listToMaybe <$> getUserProfiles luid [targetUser]
@@ -181,6 +206,74 @@ getLocalUserAccountByUserKey :: (Member UserSubsystem r) => Local EmailKey -> Se
 getLocalUserAccountByUserKey q@(tUnqualified -> ek) =
   listToMaybe <$> getAccountsByEmailNoFilter (qualifyAs q [emailKeyOrig ek])
 
+-- | Call 'createEmailChangeToken' and process result: if email changes to
+-- itself, succeed, if not, send validation email.
+requestEmailChange ::
+  ( Member BlockListStore r,
+    Member UserKeyStore r,
+    Member EmailSubsystem r,
+    Member UserSubsystem r,
+    Member UserStore r,
+    Member (Error UserSubsystemError) r,
+    Member ActivationCodeStore r,
+    Member (Input UserSubsystemConfig) r
+  ) =>
+  Local UserId ->
+  EmailAddress ->
+  UpdateOriginType ->
+  Sem r ChangeEmailResponse
+requestEmailChange lusr email allowScim = do
+  let u = tUnqualified lusr
+  createEmailChangeToken lusr email allowScim >>= \case
+    ChangeEmailIdempotent ->
+      pure ChangeEmailResponseIdempotent
+    ChangeEmailNeedsActivation (usr, adata, en) -> do
+      sendOutEmail usr adata en
+      updateEmailUnvalidated u email
+      internalUpdateSearchIndex 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).
+createEmailChangeToken ::
+  ( Member BlockListStore r,
+    Member UserKeyStore r,
+    Member (Error UserSubsystemError) r,
+    Member UserSubsystem r,
+    Member ActivationCodeStore r,
+    Member (Input UserSubsystemConfig) r
+  ) =>
+  Local UserId ->
+  EmailAddress ->
+  UpdateOriginType ->
+  Sem r ChangeEmailResult
+createEmailChangeToken lusr email updateOrigin = do
+  let ek = mkEmailKey email
+      u = tUnqualified lusr
+  blocklisted <- BlockListStore.exists ek
+  when blocklisted $ throw UserSubsystemChangeBlocklistedEmail
+  available <- keyAvailable ek (Just u)
+  unless available $ throw UserSubsystemEmailExists
+  usr <-
+    getLocalAccountBy WithPendingInvitations lusr
+      >>= note UserSubsystemProfileNotFound
+  case emailIdentity =<< userIdentity usr of
+    -- The user already has an email address and the new one is exactly the same
+    Just current | current == email -> pure ChangeEmailIdempotent
+    _ -> do
+      unless (userManagedBy usr /= ManagedByScim || updateOrigin == UpdateOriginScim) $
+        throw UserSubsystemEmailManagedByScim
+      actTimeout <- inputs (.activationCodeTimeout)
+      act <- newActivationCode ek actTimeout (Just u)
+      pure $ ChangeEmailNeedsActivation (usr, act, email)
+
 ------------------------------------------
 -- FUTUREWORK: Pending functions for a team subsystem
 ------------------------------------------