From bbe367637f4804a2d2373aa580304691530e7af1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Mon, 4 Nov 2024 15:37:26 +0100 Subject: [PATCH] [WPB-8881] Move email update and remove operations to effects (#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 --- changelog.d/5-internal/WPB-8881 | 1 + libs/wire-api/src/Wire/API/Error/Brig.hs | 3 + .../src/Wire/API/Routes/Public/Brig.hs | 2 +- libs/wire-api/src/Wire/API/User.hs | 2 - libs/wire-api/src/Wire/API/User/Activation.hs | 12 ++ .../src/Wire/ActivationCodeStore.hs | 9 ++ .../src/Wire/ActivationCodeStore/Cassandra.hs | 52 +++++++- libs/wire-subsystems/src/Wire/UserStore.hs | 2 + .../src/Wire/UserStore/Cassandra.hs | 15 +++ .../wire-subsystems/src/Wire/UserSubsystem.hs | 95 +++++++++++++- .../src/Wire/UserSubsystem/Error.hs | 8 ++ .../src/Wire/UserSubsystem/Interpreter.hs | 35 ++++-- .../Wire/UserSubsystem/UserSubsystemConfig.hs | 16 +++ .../MockInterpreters/ActivationCodeStore.hs | 28 ++++- .../unit/Wire/MockInterpreters/UserStore.hs | 8 ++ .../Wire/UserSubsystem/InterpreterSpec.hs | 32 ++--- libs/wire-subsystems/wire-subsystems.cabal | 1 + services/brig/src/Brig/API/Auth.hs | 21 +++- services/brig/src/Brig/API/Error.hs | 6 - services/brig/src/Brig/API/Internal.hs | 36 ++++-- services/brig/src/Brig/API/Public.hs | 43 +++++-- services/brig/src/Brig/API/Types.hs | 17 +-- services/brig/src/Brig/API/User.hs | 117 ++++-------------- .../brig/src/Brig/CanonicalInterpreter.hs | 6 +- services/brig/src/Brig/Data/Activation.hs | 55 +------- services/brig/src/Brig/Data/User.hs | 14 --- services/galley/test/integration/API/Util.hs | 5 +- 27 files changed, 398 insertions(+), 243 deletions(-) create mode 100644 changelog.d/5-internal/WPB-8881 create mode 100644 libs/wire-subsystems/src/Wire/UserSubsystem/UserSubsystemConfig.hs diff --git a/changelog.d/5-internal/WPB-8881 b/changelog.d/5-internal/WPB-8881 new file mode 100644 index 00000000000..f4bf49f3359 --- /dev/null +++ b/changelog.d/5-internal/WPB-8881 @@ -0,0 +1 @@ +Move email update and remove operations to effects diff --git a/libs/wire-api/src/Wire/API/Error/Brig.hs b/libs/wire-api/src/Wire/API/Error/Brig.hs index 9c397736cc2..6dc470def9a 100644 --- a/libs/wire-api/src/Wire/API/Error/Brig.hs +++ b/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." diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs b/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs index d377fc79835..8af642848d8 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs +++ b/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) diff --git a/libs/wire-api/src/Wire/API/User.hs b/libs/wire-api/src/Wire/API/User.hs index 75387c76429..c6d2a6d4404 100644 --- a/libs/wire-api/src/Wire/API/User.hs +++ b/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 ] diff --git a/libs/wire-api/src/Wire/API/User/Activation.hs b/libs/wire-api/src/Wire/API/User/Activation.hs index 5e347a54afe..84c993870b4 100644 --- a/libs/wire-api/src/Wire/API/User/Activation.hs +++ b/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) diff --git a/libs/wire-subsystems/src/Wire/ActivationCodeStore.hs b/libs/wire-subsystems/src/Wire/ActivationCodeStore.hs index 9473bd16f58..1d5175387fe 100644 --- a/libs/wire-subsystems/src/Wire/ActivationCodeStore.hs +++ b/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 diff --git a/libs/wire-subsystems/src/Wire/ActivationCodeStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/ActivationCodeStore/Cassandra.hs index 7f0ba27ba03..01349e6102b 100644 --- a/libs/wire-subsystems/src/Wire/ActivationCodeStore/Cassandra.hs +++ b/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 diff --git a/libs/wire-subsystems/src/Wire/UserStore.hs b/libs/wire-subsystems/src/Wire/UserStore.hs index a5189d29818..6f24e084717 100644 --- a/libs/wire-subsystems/src/Wire/UserStore.hs +++ b/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 diff --git a/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs index 96e78df99d3..d113e202496 100644 --- a/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs +++ b/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 = ?" diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem.hs b/libs/wire-subsystems/src/Wire/UserSubsystem.hs index f53da756a00..564799f2b6b 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem.hs +++ b/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 ------------------------------------------ diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Error.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Error.hs index 90a2d39a888..f9005275289 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Error.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Error.hs @@ -14,7 +14,9 @@ data UserSubsystemError UserSubsystemDisplayNameManagedByScim | UserSubsystemHandleManagedByScim | UserSubsystemLocaleManagedByScim + | UserSubsystemEmailManagedByScim | UserSubsystemNoIdentity + | UserSubsystemLastIdentity | UserSubsystemHandleExists | UserSubsystemInvalidHandle | UserSubsystemProfileNotFound @@ -28,6 +30,8 @@ data UserSubsystemError | UserSubsystemInvitationNotFound | UserSubsystemUserNotAllowedToJoinTeam Wai.Error | UserSubsystemMLSServicesNotAllowed + | UserSubsystemChangeBlocklistedEmail + | UserSubsystemEmailExists deriving (Eq, Show) userSubsystemErrorToHttpError :: UserSubsystemError -> HttpError @@ -36,7 +40,9 @@ userSubsystemErrorToHttpError = UserSubsystemProfileNotFound -> errorToWai @E.UserNotFound UserSubsystemDisplayNameManagedByScim -> errorToWai @E.NameManagedByScim UserSubsystemLocaleManagedByScim -> errorToWai @E.LocaleManagedByScim + UserSubsystemEmailManagedByScim -> errorToWai @E.EmailManagedByScim UserSubsystemNoIdentity -> errorToWai @E.NoIdentity + UserSubsystemLastIdentity -> errorToWai @E.LastIdentity UserSubsystemHandleExists -> errorToWai @E.HandleExists UserSubsystemInvalidHandle -> errorToWai @E.InvalidHandle UserSubsystemHandleManagedByScim -> errorToWai @E.HandleManagedByScim @@ -50,5 +56,7 @@ userSubsystemErrorToHttpError = UserSubsystemInvitationNotFound -> Wai.mkError status404 "not-found" "Something went wrong, while looking up the invitation" UserSubsystemUserNotAllowedToJoinTeam e -> e UserSubsystemMLSServicesNotAllowed -> errorToWai @E.MLSServicesNotAllowed + UserSubsystemChangeBlocklistedEmail -> errorToWai @E.BlacklistedEmail + UserSubsystemEmailExists -> errorToWai @'E.UserKeyExists instance Exception UserSubsystemError diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index 8f9ba2566e1..5424bbe4f5b 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -48,7 +48,6 @@ import Wire.API.User as User import Wire.API.User.RichInfo import Wire.API.User.Search import Wire.API.UserEvent -import Wire.Arbitrary import Wire.AuthenticationSubsystem import Wire.BlockListStore as BlockList import Wire.DeleteQueue @@ -75,17 +74,9 @@ import Wire.UserStore.IndexUser import Wire.UserSubsystem import Wire.UserSubsystem.Error import Wire.UserSubsystem.HandleBlacklist +import Wire.UserSubsystem.UserSubsystemConfig import Witherable (wither) -data UserSubsystemConfig = UserSubsystemConfig - { emailVisibilityConfig :: EmailVisibilityConfig, - defaultLocale :: Locale, - searchSameTeamOnly :: Bool, - maxTeamSize :: Word32 - } - deriving (Show, Generic) - deriving (Arbitrary) via (GenericUniform UserSubsystemConfig) - runUserSubsystem :: ( Member UserStore r, Member UserKeyStore r, @@ -157,6 +148,7 @@ runUserSubsystem authInterpreter = interpret $ InternalFindTeamInvitation mEmailKey code -> internalFindTeamInvitationImpl mEmailKey code GetUserExportData uid -> getUserExportDataImpl uid + RemoveEmailEither luid -> removeEmailEitherImpl luid scimExtId :: StoredUser -> Maybe Text scimExtId su = do @@ -974,3 +966,26 @@ getUserExportDataImpl uid = fmap hush . runError @() $ do tExportLastActive = lastActive, tExportStatus = su.status } + +removeEmailEitherImpl :: + ( Member UserKeyStore r, + Member UserStore r, + Member Events r, + Member IndexedUserStore r, + Member (Input UserSubsystemConfig) r, + Member GalleyAPIAccess r, + Member Metrics r + ) => + Local UserId -> + Sem r (Either UserSubsystemError ()) +removeEmailEitherImpl lusr = runError $ do + let uid = tUnqualified lusr + ident <- getSelfProfileImpl lusr >>= note UserSubsystemProfileNotFound + case ident.selfUser.userIdentity of + Just (SSOIdentity (UserSSOId _) (Just e)) -> do + deleteKey $ mkEmailKey e + deleteEmail uid + generateUserEvent uid Nothing (emailRemoved uid e) + syncUserIndex uid + Just _ -> throw UserSubsystemLastIdentity + Nothing -> throw UserSubsystemNoIdentity diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/UserSubsystemConfig.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/UserSubsystemConfig.hs new file mode 100644 index 00000000000..094e541a8b1 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/UserSubsystemConfig.hs @@ -0,0 +1,16 @@ +module Wire.UserSubsystem.UserSubsystemConfig where + +import Imports +import Util.Timeout +import Wire.API.User +import Wire.Arbitrary + +data UserSubsystemConfig = UserSubsystemConfig + { emailVisibilityConfig :: EmailVisibilityConfig, + defaultLocale :: Locale, + searchSameTeamOnly :: Bool, + maxTeamSize :: Word32, + activationCodeTimeout :: Timeout + } + deriving (Show, Generic) + deriving (Arbitrary) via (GenericUniform UserSubsystemConfig) diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/ActivationCodeStore.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/ActivationCodeStore.hs index 0265c8d07fe..a31d31cbfc3 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/ActivationCodeStore.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/ActivationCodeStore.hs @@ -2,12 +2,36 @@ module Wire.MockInterpreters.ActivationCodeStore where import Data.Id import Data.Map +import Data.Text (pack) +import Data.Text.Ascii qualified as Ascii +import Data.Text.Encoding qualified as T import Imports import Polysemy import Polysemy.State +import Text.Printf (printf) import Wire.API.User.Activation import Wire.ActivationCodeStore (ActivationCodeStore (..)) import Wire.UserKeyStore -inMemoryActivationCodeStoreInterpreter :: (Member (State (Map EmailKey (Maybe UserId, ActivationCode))) r) => InterpreterFor ActivationCodeStore r -inMemoryActivationCodeStoreInterpreter = interpret \case LookupActivationCode ek -> gets (!? ek) +inMemoryActivationCodeStoreInterpreter :: + ( Member (State (Map EmailKey (Maybe UserId, ActivationCode))) r + ) => + InterpreterFor ActivationCodeStore r +inMemoryActivationCodeStoreInterpreter = interpret \case + LookupActivationCode ek -> gets (!? ek) + NewActivationCode ek _ uid -> do + let key = + ActivationKey + . Ascii.encodeBase64Url + . T.encodeUtf8 + . emailKeyUniq + $ ek + code = + ActivationCode + . Ascii.unsafeFromText + . pack + . printf "%06d" + . length + . show + $ ek + modify (insert ek (uid, code)) $> Activation key code diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs index 133365cf986..d3f00a25016 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs @@ -37,6 +37,13 @@ inMemoryUserStoreInterpreter = interpret $ \case . maybe Imports.id setStoredUserSupportedProtocols update.supportedProtocols $ u else u + UpdateEmailUnvalidated uid email -> modify (map doUpdate) + where + doUpdate :: StoredUser -> StoredUser + doUpdate u = + if u.id == uid + then u {emailUnvalidated = Just email} + else u GetIndexUser uid -> gets $ fmap storedUserToIndexUser . find (\user -> user.id == uid) GetIndexUsersPaginated _pageSize _pagingState -> @@ -74,6 +81,7 @@ inMemoryUserStoreInterpreter = interpret $ \case GetActivityTimestamps _ -> pure [] GetRichInfo _ -> error "rich info not implemented" GetUserAuthenticationInfo _uid -> error "Not implemented" + DeleteEmail _uid -> error "Not implemented" storedUserToIndexUser :: StoredUser -> IndexUser storedUserToIndexUser storedUser = diff --git a/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs index c573d4709c5..3b82816399e 100644 --- a/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs @@ -57,7 +57,7 @@ spec = describe "UserSubsystem.Interpreter" do target1 = mkUserIds remoteDomain1 targetUsers1 target2 = mkUserIds remoteDomain2 targetUsers2 localBackend = def {users = [viewer] <> localTargetUsers} - config = UserSubsystemConfig visibility miniLocale False 100 + config = UserSubsystemConfig visibility miniLocale False 100 undefined retrievedProfiles = runFederationStack localBackend federation Nothing config $ getUserProfiles @@ -85,7 +85,7 @@ spec = describe "UserSubsystem.Interpreter" do mkUserIds domain users = map (flip Qualified domain . (.id)) users onlineUsers = mkUserIds onlineDomain onlineTargetUsers offlineUsers = mkUserIds offlineDomain offlineTargetUsers - config = UserSubsystemConfig visibility miniLocale False 100 + config = UserSubsystemConfig visibility miniLocale False 100 undefined localBackend = def {users = [viewer]} result = run @@ -155,7 +155,7 @@ spec = describe "UserSubsystem.Interpreter" do \viewer targetUsers visibility domain remoteDomain -> do let remoteBackend = def {users = targetUsers} federation = [(remoteDomain, remoteBackend)] - config = UserSubsystemConfig visibility miniLocale False 100 + config = UserSubsystemConfig visibility miniLocale False 100 undefined localBackend = def {users = [viewer]} retrievedProfilesWithErrors :: ([(Qualified UserId, FederationError)], [UserProfile]) = runFederationStack localBackend federation Nothing config $ @@ -176,7 +176,7 @@ spec = describe "UserSubsystem.Interpreter" do prop "Remote users on offline backend always fail to return" $ \viewer (targetUsers :: Set StoredUser) visibility domain remoteDomain -> do let online = mempty - config = UserSubsystemConfig visibility miniLocale False 100 + config = UserSubsystemConfig visibility miniLocale False 100 undefined localBackend = def {users = [viewer]} retrievedProfilesWithErrors :: ([(Qualified UserId, FederationError)], [UserProfile]) = runFederationStack localBackend online Nothing config $ @@ -196,7 +196,7 @@ spec = describe "UserSubsystem.Interpreter" do allDomains = [domain, remoteDomainA, remoteDomainB] remoteAUsers = map (flip Qualified remoteDomainA . (.id)) targetUsers remoteBUsers = map (flip Qualified remoteDomainB . (.id)) targetUsers - config = UserSubsystemConfig visibility miniLocale False 100 + config = UserSubsystemConfig visibility miniLocale False 100 undefined localBackend = def {users = [viewer]} retrievedProfilesWithErrors :: ([(Qualified UserId, FederationError)], [UserProfile]) = runFederationStack localBackend online Nothing config $ @@ -281,7 +281,7 @@ spec = describe "UserSubsystem.Interpreter" do describe "getAccountsBy" do prop "GetBy userId when pending fails if not explicitly allowed" $ \(PendingNotEmptyIdentityStoredUser alice') email teamId invitationInfo localDomain visibility locale -> - let config = UserSubsystemConfig visibility locale False 100 + let config = UserSubsystemConfig visibility locale False 100 undefined alice = alice' { email = Just email, @@ -316,7 +316,7 @@ spec = describe "UserSubsystem.Interpreter" do prop "GetBy userId works for pending if explicitly queried" $ \(PendingNotEmptyIdentityStoredUser alice') email teamId invitationInfo localDomain visibility locale -> - let config = UserSubsystemConfig visibility locale True 100 + let config = UserSubsystemConfig visibility locale True 100 undefined alice = alice' { email = Just email, @@ -350,7 +350,7 @@ spec = describe "UserSubsystem.Interpreter" do in result === [mkUserFromStored localDomain locale alice] prop "GetBy handle when pending fails if not explicitly allowed" $ \(PendingNotEmptyIdentityStoredUser alice') handl email teamId invitationInfo localDomain visibility locale -> - let config = UserSubsystemConfig visibility locale True 100 + let config = UserSubsystemConfig visibility locale True 100 undefined alice = alice' { email = Just email, @@ -386,7 +386,7 @@ spec = describe "UserSubsystem.Interpreter" do prop "GetBy handle works for pending if explicitly queried" $ \(PendingNotEmptyIdentityStoredUser alice') handl email teamId invitationInfo localDomain visibility locale -> - let config = UserSubsystemConfig visibility locale True 100 + let config = UserSubsystemConfig visibility locale True 100 undefined alice = alice' { email = Just email, @@ -422,7 +422,7 @@ spec = describe "UserSubsystem.Interpreter" do prop "GetBy email does not filter by pending, missing identity or expired invitations" $ \(alice' :: StoredUser) email localDomain visibility locale -> - let config = UserSubsystemConfig visibility locale True 100 + let config = UserSubsystemConfig visibility locale True 100 undefined alice = alice' {email = Just email} localBackend = def @@ -436,7 +436,7 @@ spec = describe "UserSubsystem.Interpreter" do prop "GetBy userId does not return missing identity users, pending invitation off" $ \(NotPendingEmptyIdentityStoredUser alice) localDomain visibility locale -> - let config = UserSubsystemConfig visibility locale True 100 + let config = UserSubsystemConfig visibility locale True 100 undefined getBy = toLocalUnsafe localDomain $ def @@ -451,7 +451,7 @@ spec = describe "UserSubsystem.Interpreter" do prop "GetBy userId does not return missing identity users, pending invtation on" $ \(NotPendingEmptyIdentityStoredUser alice) localDomain visibility locale -> - let config = UserSubsystemConfig visibility locale True 100 + let config = UserSubsystemConfig visibility locale True 100 undefined getBy = toLocalUnsafe localDomain $ def @@ -466,7 +466,7 @@ spec = describe "UserSubsystem.Interpreter" do prop "GetBy pending user by id works if there is a valid invitation" $ \(PendingNotEmptyIdentityStoredUser alice') (email :: EmailAddress) teamId (invitationInfo :: StoredInvitation) localDomain visibility locale -> - let config = UserSubsystemConfig visibility locale True 100 + let config = UserSubsystemConfig visibility locale True 100 undefined emailKey = mkEmailKey email getBy = toLocalUnsafe localDomain $ @@ -495,7 +495,7 @@ spec = describe "UserSubsystem.Interpreter" do prop "GetBy pending user by id fails if there is no valid invitation" $ \(PendingNotEmptyIdentityStoredUser alice') (email :: EmailAddress) teamId localDomain visibility locale -> - let config = UserSubsystemConfig visibility locale True 100 + let config = UserSubsystemConfig visibility locale True 100 undefined emailKey = mkEmailKey email getBy = toLocalUnsafe localDomain $ @@ -516,7 +516,7 @@ spec = describe "UserSubsystem.Interpreter" do prop "GetBy pending user handle id works if there is a valid invitation" $ \(PendingNotEmptyIdentityStoredUser alice') (email :: EmailAddress) handl teamId (invitationInfo :: StoredInvitation) localDomain visibility locale -> - let config = UserSubsystemConfig visibility locale True 100 + let config = UserSubsystemConfig visibility locale True 100 undefined emailKey = mkEmailKey email getBy = toLocalUnsafe localDomain $ @@ -550,7 +550,7 @@ spec = describe "UserSubsystem.Interpreter" do prop "GetBy pending user by handle fails if there is no valid invitation" $ \(PendingNotEmptyIdentityStoredUser alice') (email :: EmailAddress) handl teamId localDomain visibility locale -> - let config = UserSubsystemConfig visibility locale True 100 + let config = UserSubsystemConfig visibility locale True 100 undefined emailKey = mkEmailKey email getBy = toLocalUnsafe localDomain $ diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index d9000793018..2e591f788db 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -135,6 +135,7 @@ library Wire.UserSubsystem.Error Wire.UserSubsystem.HandleBlacklist Wire.UserSubsystem.Interpreter + Wire.UserSubsystem.UserSubsystemConfig Wire.VerificationCode Wire.VerificationCodeGen Wire.VerificationCodeStore diff --git a/services/brig/src/Brig/API/Auth.hs b/services/brig/src/Brig/API/Auth.hs index 021ca38aabc..3821d6b4534 100644 --- a/services/brig/src/Brig/API/Auth.hs +++ b/services/brig/src/Brig/API/Auth.hs @@ -20,7 +20,6 @@ module Brig.API.Auth where import Brig.API.Error import Brig.API.Handler import Brig.API.Types -import Brig.API.User import Brig.App import Brig.Options import Brig.User.Auth qualified as Auth @@ -39,6 +38,7 @@ import Network.HTTP.Types import Network.Wai.Utilities ((!>>)) import Network.Wai.Utilities.Error qualified as Wai import Polysemy +import Polysemy.Error (Error) import Polysemy.Input import Polysemy.TinyLog (TinyLog) import Wire.API.Error @@ -57,7 +57,10 @@ import Wire.Events (Events) import Wire.GalleyAPIAccess import Wire.UserKeyStore import Wire.UserStore -import Wire.UserSubsystem +import Wire.UserSubsystem (UpdateOriginType (..), UserSubsystem) +import Wire.UserSubsystem qualified as User +import Wire.UserSubsystem.Error +import Wire.UserSubsystem.UserSubsystemConfig import Wire.VerificationCodeSubsystem (VerificationCodeSubsystem) accessH :: @@ -128,23 +131,29 @@ logout :: (TokenPair u a) => NonEmpty (Token u) -> Maybe (Token a) -> Handler r logout _ Nothing = throwStd authMissingToken logout uts (Just at) = Auth.logout (List1 uts) at !>> zauthError -changeSelfEmailH :: +changeSelfEmail :: ( Member BlockListStore r, Member UserKeyStore r, Member EmailSubsystem r, - Member UserSubsystem r + Member UserSubsystem r, + Member UserStore r, + Member ActivationCodeStore r, + Member (Error UserSubsystemError) r, + Member (Input UserSubsystemConfig) r ) => [Either Text SomeUserToken] -> Maybe (Either Text SomeAccessToken) -> EmailUpdate -> Handler r ChangeEmailResponse -changeSelfEmailH uts' mat' up = do +changeSelfEmail uts' mat' up = do uts <- handleTokenErrors uts' mat <- traverse handleTokenError mat' toks <- partitionTokens uts mat usr <- either (uncurry validateCredentials) (uncurry validateCredentials) toks + lusr <- qualifyLocal usr let email = euEmail up - changeSelfEmail usr email UpdateOriginWireClient + lift . liftSem $ + User.requestEmailChange lusr email UpdateOriginWireClient validateCredentials :: (TokenPair u a) => diff --git a/services/brig/src/Brig/API/Error.hs b/services/brig/src/Brig/API/Error.hs index 019e3786c1b..289639b0c40 100644 --- a/services/brig/src/Brig/API/Error.hs +++ b/services/brig/src/Brig/API/Error.hs @@ -76,12 +76,6 @@ sendActCodeError (InvalidRecipient _) = StdError $ errorToWai @'E.InvalidEmail sendActCodeError (UserKeyInUse _) = StdError (errorToWai @'E.UserKeyExists) sendActCodeError (ActivationBlacklistedUserKey _) = StdError blacklistedEmail -changeEmailError :: ChangeEmailError -> HttpError -changeEmailError (InvalidNewEmail _ _) = StdError (errorToWai @'E.InvalidEmail) -changeEmailError (EmailExists _) = StdError (errorToWai @'E.UserKeyExists) -changeEmailError (ChangeBlacklistedEmail _) = StdError blacklistedEmail -changeEmailError EmailManagedByScim = StdError $ propertyManagedByScim "email" - legalHoldLoginError :: LegalHoldLoginError -> HttpError legalHoldLoginError LegalHoldLoginNoBindingTeam = StdError noBindingTeam legalHoldLoginError LegalHoldLoginLegalHoldNotEnabled = StdError legalHoldNotEnabled diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index ea9c2f26f20..75a80dde93e 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -117,6 +117,7 @@ import Wire.UserStore as UserStore import Wire.UserSubsystem import Wire.UserSubsystem qualified as UserSubsystem import Wire.UserSubsystem.Error +import Wire.UserSubsystem.UserSubsystemConfig import Wire.VerificationCode import Wire.VerificationCodeGen import Wire.VerificationCodeSubsystem @@ -149,7 +150,8 @@ servantSitemap :: Member (Polysemy.Error UserSubsystemError) r, Member HashPassword r, Member (Embed IO) r, - Member ActivationCodeStore r + Member ActivationCodeStore r, + Member (Input UserSubsystemConfig) r ) => ServerT BrigIRoutes.API (Handler r) servantSitemap = @@ -203,7 +205,9 @@ accountAPI :: Member HashPassword r, Member InvitationStore r, Member (Embed IO) r, - Member ActivationCodeStore r + Member ActivationCodeStore r, + Member (Polysemy.Error UserSubsystemError) r, + Member (Input UserSubsystemConfig) r ) => ServerT BrigIRoutes.AccountAPI (Handler r) accountAPI = @@ -477,7 +481,8 @@ createUserNoVerify :: Member UserSubsystem r, Member (Input (Local ())) r, Member HashPassword r, - Member PasswordResetCodeStore r + Member PasswordResetCodeStore r, + Member ActivationCodeStore r ) => NewUser -> (Handler r) (Either RegisterError SelfProfile) @@ -538,7 +543,11 @@ changeSelfEmailMaybeSendH :: ( Member BlockListStore r, Member UserKeyStore r, Member EmailSubsystem r, - Member UserSubsystem r + Member UserSubsystem r, + Member UserStore r, + Member ActivationCodeStore r, + Member (Polysemy.Error UserSubsystemError) r, + Member (Input UserSubsystemConfig) r ) => UserId -> EmailUpdate -> @@ -554,7 +563,11 @@ changeSelfEmailMaybeSend :: ( Member BlockListStore r, Member UserKeyStore r, Member EmailSubsystem r, - Member UserSubsystem r + Member UserSubsystem r, + Member UserStore r, + Member ActivationCodeStore r, + Member (Polysemy.Error UserSubsystemError) r, + Member (Input UserSubsystemConfig) r ) => UserId -> MaybeSendEmail -> @@ -562,11 +575,16 @@ changeSelfEmailMaybeSend :: UpdateOriginType -> (Handler r) ChangeEmailResponse changeSelfEmailMaybeSend u ActuallySendEmail email allowScim = do - API.changeSelfEmail u email allowScim + lusr <- qualifyLocal u + lift . liftSem $ + UserSubsystem.requestEmailChange lusr email allowScim changeSelfEmailMaybeSend u DoNotSendEmail email allowScim = do - API.changeEmail u email allowScim !>> changeEmailError >>= \case - ChangeEmailIdempotent -> pure ChangeEmailResponseIdempotent - ChangeEmailNeedsActivation _ -> pure ChangeEmailResponseNeedsActivation + lusr <- qualifyLocal u + (lift . liftSem) + (UserSubsystem.createEmailChangeToken lusr email allowScim) + >>= \case + ChangeEmailIdempotent -> pure ChangeEmailResponseIdempotent + ChangeEmailNeedsActivation _ -> pure ChangeEmailResponseNeedsActivation -- Historically, this end-point was two end-points with distinct matching routes -- (distinguished by query params), and it was only allowed to pass one param per call. This diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index 6580a413959..8b3b484e236 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -173,9 +173,10 @@ import Wire.UserKeyStore import Wire.UserSearch.Types import Wire.UserStore (UserStore) import Wire.UserStore qualified as UserStore -import Wire.UserSubsystem hiding (checkHandle, checkHandles) +import Wire.UserSubsystem hiding (checkHandle, checkHandles, removeEmail, requestEmailChange) import Wire.UserSubsystem qualified as User import Wire.UserSubsystem.Error +import Wire.UserSubsystem.UserSubsystemConfig import Wire.VerificationCode import Wire.VerificationCodeGen import Wire.VerificationCodeSubsystem @@ -363,7 +364,8 @@ servantSitemap :: Member BlockListStore r, Member (ConnectionStore InternalPaging) r, Member IndexedUserStore r, - Member HashPassword r + Member HashPassword r, + Member (Input UserSubsystemConfig) r ) => ServerT BrigAPI (Handler r) servantSitemap = @@ -511,7 +513,7 @@ servantSitemap = :<|> Named @"send-login-code" sendLoginCode :<|> Named @"login" login :<|> Named @"logout" logoutH - :<|> Named @"change-self-email" changeSelfEmailH + :<|> Named @"change-self-email" changeSelfEmail :<|> Named @"list-cookies" listCookies :<|> Named @"remove-cookies" removeCookies @@ -811,7 +813,8 @@ createUser :: Member UserSubsystem r, Member PasswordResetCodeStore r, Member HashPassword r, - Member EmailSending r + Member EmailSending r, + Member ActivationCodeStore r ) => Public.NewUserPublic -> Handler r (Either Public.RegisterError Public.RegisterSuccess) @@ -1024,13 +1027,18 @@ removePhone :: UserId -> Handler r (Maybe Public.RemoveIdentityError) removePhone _ = (lift . pure) Nothing removeEmail :: - ( Member UserKeyStore r, - Member UserSubsystem r, - Member Events r + ( Member UserSubsystem r, + Member (Error UserSubsystemError) r ) => - UserId -> + Local UserId -> Handler r (Maybe Public.RemoveIdentityError) -removeEmail self = lift . exceptTToMaybe $ API.removeEmail self +removeEmail = lift . liftSem . User.removeEmailEither >=> reint + where + reint = \case + Left UserSubsystemNoIdentity -> pure . Just $ Public.NoIdentity + Left UserSubsystemLastIdentity -> pure . Just $ Public.LastIdentity + Left e -> lift . liftSem . throw $ e + Right () -> pure Nothing checkPasswordExists :: (Member PasswordStore r) => UserId -> (Handler r) Bool checkPasswordExists = fmap isJust . lift . liftSem . lookupHashedPassword @@ -1101,7 +1109,12 @@ getHandleInfoUnqualifiedH self handle = do Public.UserHandleInfo . Public.profileQualifiedId <$$> Handle.getHandleInfo self (Qualified handle domain) -changeHandle :: (Member UserSubsystem r) => Local UserId -> ConnId -> Public.HandleUpdate -> Handler r () +changeHandle :: + (Member UserSubsystem r) => + Local UserId -> + ConnId -> + Public.HandleUpdate -> + Handler r () changeHandle u conn (Public.HandleUpdate h) = lift $ liftSem do User.updateHandle u (Just conn) UpdateOriginWireClient h @@ -1336,7 +1349,11 @@ updateUserEmail :: Member UserKeyStore r, Member GalleyAPIAccess r, Member EmailSubsystem r, - Member UserSubsystem r + Member UserSubsystem r, + Member UserStore r, + Member ActivationCodeStore r, + Member (Error UserSubsystemError) r, + Member (Input UserSubsystemConfig) r ) => UserId -> UserId -> @@ -1347,7 +1364,9 @@ updateUserEmail zuserId emailOwnerId (Public.EmailUpdate email) = do whenM (not <$> assertHasPerm maybeZuserTeamId) $ throwStd insufficientTeamPermissions maybeEmailOwnerTeamId <- lift $ wrapClient $ Data.lookupUserTeam emailOwnerId checkSameTeam maybeZuserTeamId maybeEmailOwnerTeamId - void $ API.changeSelfEmail emailOwnerId email UpdateOriginWireClient + lEmailOwnerId <- qualifyLocal emailOwnerId + void . lift . liftSem $ + User.requestEmailChange lEmailOwnerId email UpdateOriginWireClient where checkSameTeam :: Maybe TeamId -> Maybe TeamId -> (Handler r) () checkSameTeam (Just zuserTeamId) maybeEmailOwnerTeamId = diff --git a/services/brig/src/Brig/API/Types.hs b/services/brig/src/Brig/API/Types.hs index 5da615a530f..1936a91c644 100644 --- a/services/brig/src/Brig/API/Types.hs +++ b/services/brig/src/Brig/API/Types.hs @@ -30,7 +30,7 @@ module Brig.API.Types ) where -import Brig.Data.Activation (Activation (..), ActivationError (..)) +import Brig.Data.Activation (ActivationError (..)) import Brig.Data.Client (ClientDataError (..)) import Brig.Types.Intra import Data.Code @@ -42,6 +42,7 @@ import Imports import Network.Wai.Utilities.Error qualified as Wai import Wire.API.Federation.Error import Wire.API.User +import Wire.API.User.Activation import Wire.AuthenticationSubsystem.Error import Wire.UserKeyStore @@ -65,14 +66,6 @@ data ActivationResult ActivationPass deriving (Show) --- | Outcome of the invariants check in 'Brig.API.User.changeEmail'. -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) - ------------------------------------------------------------------------------- -- Failures @@ -153,12 +146,6 @@ data VerificationCodeError | VerificationCodeNoPendingCode | VerificationCodeNoEmail -data ChangeEmailError - = InvalidNewEmail !EmailAddress !String - | EmailExists !EmailAddress - | ChangeBlacklistedEmail !EmailAddress - | EmailManagedByScim - data SendActivationCodeError = InvalidRecipient EmailKey | UserKeyInUse EmailKey diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index 7ff8e0f22b1..8c6a2e6fb67 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -25,8 +25,6 @@ module Brig.API.User createUserSpar, createUserInviteViaScim, checkRestrictedUserCreation, - changeSelfEmail, - changeEmail, CheckHandleResp (..), checkHandle, lookupHandle, @@ -67,7 +65,6 @@ module Brig.API.User ) where -import Brig.API.Error qualified as Error import Brig.API.Types import Brig.API.Util import Brig.App as App @@ -128,7 +125,7 @@ import Wire.API.User.Activation import Wire.API.User.Client import Wire.API.User.RichInfo import Wire.API.UserEvent -import Wire.ActivationCodeStore (ActivationCodeStore) +import Wire.ActivationCodeStore import Wire.ActivationCodeStore qualified as ActivationCode import Wire.AuthenticationSubsystem (AuthenticationSubsystem, internalLookupPasswordResetCode) import Wire.BlockListStore as BlockListStore @@ -319,7 +316,8 @@ createUser :: Member (Input (Local ())) r, Member PasswordResetCodeStore r, Member HashPassword r, - Member InvitationStore r + Member InvitationStore r, + Member ActivationCodeStore r ) => NewUser -> ExceptT RegisterError (AppT r) CreateUserResult @@ -479,17 +477,22 @@ createUser new = do pure $ CreateUserTeam tid nm -- Handle e-mail activation (deprecated, see #RefRegistrationNoPreverification in /docs/reference/user/registration.md) - handleEmailActivation :: Maybe EmailAddress -> UserId -> Maybe BindingNewTeamUser -> ExceptT RegisterError (AppT r) (Maybe Activation) + handleEmailActivation :: + Maybe EmailAddress -> + UserId -> + Maybe BindingNewTeamUser -> + ExceptT RegisterError (AppT r) (Maybe Activation) handleEmailActivation email uid newTeam = do fmap join . for (mkEmailKey <$> email) $ \ek -> case newUserEmailCode new of Nothing -> do timeout <- asks (.settings.activationTimeout) - edata <- lift . wrapClient $ Data.newActivation ek timeout (Just uid) - lift . liftSem . Log.info $ - field "user" (toByteString uid) - . field "activation.key" (toByteString $ activationKey edata) - . msg (val "Created email activation key/code pair") - pure $ Just edata + lift . liftSem $ do + edata <- newActivationCode ek timeout (Just uid) + Log.info $ + field "user" (toByteString uid) + . field "activation.key" (toByteString $ activationKey edata) + . msg (val "Created email activation key/code pair") + pure $ Just edata Just c -> do ak <- liftIO $ Data.mkActivationKey ek void $ @@ -546,82 +549,6 @@ checkRestrictedUserCreation new = do ) $ throwE RegisterErrorUserCreationRestricted -------------------------------------------------------------------------------- --- Change Email - --- | Call 'changeEmail' and process result: if email changes to itself, succeed, if not, send --- validation email. -changeSelfEmail :: - ( Member BlockListStore r, - Member UserKeyStore r, - Member EmailSubsystem r, - Member UserSubsystem r - ) => - UserId -> - EmailAddress -> - UpdateOriginType -> - ExceptT HttpError (AppT r) ChangeEmailResponse -changeSelfEmail u email allowScim = do - changeEmail u email allowScim !>> Error.changeEmailError >>= \case - ChangeEmailIdempotent -> - pure ChangeEmailResponseIdempotent - ChangeEmailNeedsActivation (usr, adata, en) -> lift $ do - liftSem $ sendOutEmail usr adata en - wrapClient $ Data.updateEmailUnvalidated u email - liftSem $ User.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). -changeEmail :: (Member BlockListStore r, Member UserKeyStore r) => UserId -> EmailAddress -> UpdateOriginType -> ExceptT ChangeEmailError (AppT r) ChangeEmailResult -changeEmail u email updateOrigin = do - let ek = mkEmailKey email - blacklisted <- lift . liftSem $ 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 == email -> pure ChangeEmailIdempotent - _ -> do - unless (userManagedBy usr /= ManagedByScim || updateOrigin == UpdateOriginScim) $ - throwE EmailManagedByScim - timeout <- asks (.settings.activationTimeout) - act <- lift . wrapClient $ Data.newActivation ek timeout (Just u) - pure $ ChangeEmailNeedsActivation (usr, act, email) - -------------------------------------------------------------------------------- --- Remove Email - -removeEmail :: - ( Member UserKeyStore r, - Member UserSubsystem r, - Member Events r - ) => - UserId -> - ExceptT RemoveIdentityError (AppT r) () -removeEmail uid = do - ident <- lift $ fetchUserIdentity uid - case ident of - Just (SSOIdentity (UserSSOId _) (Just e)) -> lift $ do - liftSem $ deleteKey $ mkEmailKey e - wrapClient $ Data.deleteEmail uid - liftSem $ Events.generateUserEvent uid Nothing (emailRemoved uid e) - liftSem $ User.internalUpdateSearchIndex uid - Just _ -> throwE LastIdentity - Nothing -> throwE NoIdentity - ------------------------------------------------------------------------------- -- Forcefully revoke a verified identity @@ -775,6 +702,7 @@ onActivated (EmailActivated uid email) = do -- docs/reference/user/activation.md {#RefActivationRequest} sendActivationCode :: + forall r. ( Member BlockListStore r, Member EmailSubsystem r, Member GalleyAPIAccess r, @@ -800,22 +728,27 @@ sendActivationCode email loc = do Just (Just uid, c) -> sendActivationEmail ek c uid -- User re-requesting activation where notFound = throwM . UserDisplayNameNotFound + mkPair :: + EmailKey -> + Maybe ActivationCode -> + Maybe UserId -> + ExceptT SendActivationCodeError (AppT r) (ActivationKey, ActivationCode) mkPair k c u = do timeout <- asks (.settings.activationTimeout) case c of Just c' -> liftIO $ (,c') <$> Data.mkActivationKey k - Nothing -> lift $ do - dat <- Data.newActivation k timeout u + Nothing -> lift . liftSem $ do + dat <- newActivationCode k timeout u pure (activationKey dat, activationCode dat) sendVerificationEmail ek uc = do - (key, code) <- wrapClientE $ mkPair ek uc Nothing + (key, code) <- mkPair ek uc Nothing let em = emailKeyOrig ek lift $ liftSem $ sendVerificationMail em key code loc sendActivationEmail ek uc uid = do -- FUTUREWORK(fisx): we allow for 'PendingInvitations' here, but I'm not sure this -- top-level function isn't another piece of a deprecated onboarding flow? u <- maybe (notFound uid) pure =<< lift (wrapClient $ Data.lookupUser WithPendingInvitations uid) - (aKey, aCode) <- wrapClientE $ mkPair ek (Just uc) (Just uid) + (aKey, aCode) <- mkPair ek (Just uc) (Just uid) let ident = userIdentity u name = userDisplayName u loc' = loc <|> Just (userLocale u) diff --git a/services/brig/src/Brig/CanonicalInterpreter.hs b/services/brig/src/Brig/CanonicalInterpreter.hs index 5248effd92b..18e53608df1 100644 --- a/services/brig/src/Brig/CanonicalInterpreter.hs +++ b/services/brig/src/Brig/CanonicalInterpreter.hs @@ -176,7 +176,8 @@ runBrigToIO e (AppT ma) = do { emailVisibilityConfig = e.settings.emailVisibility, defaultLocale = Opt.defaultUserLocale e.settings, searchSameTeamOnly = fromMaybe False e.settings.searchSameTeamOnly, - maxTeamSize = e.settings.maxTeamSize + maxTeamSize = e.settings.maxTeamSize, + activationCodeTimeout = e.settings.activationTimeout } teamInvitationSubsystemConfig = TeamInvitationSubsystemConfig @@ -213,6 +214,9 @@ runBrigToIO e (AppT ma) = do } -- These interpreters depend on each other, we use let recursion to solve that. + -- + -- This terminates if and only if we do not create an action sequence at + -- runtime such that interpretation of actions results in a call cycle. userSubsystemInterpreter :: (Members BrigLowerLevelEffects r) => InterpreterFor UserSubsystem r userSubsystemInterpreter = runUserSubsystem authSubsystemInterpreter diff --git a/services/brig/src/Brig/Data/Activation.hs b/services/brig/src/Brig/Data/Activation.hs index ae9ce48899f..981038f9d42 100644 --- a/services/brig/src/Brig/Data/Activation.hs +++ b/services/brig/src/Brig/Data/Activation.hs @@ -17,11 +17,9 @@ -- | Activation of 'Email' addresses and 'Phone' numbers. module Brig.Data.Activation - ( Activation (..), - ActivationEvent (..), + ( ActivationEvent (..), ActivationError (..), activationErrorToRegisterError, - newActivation, mkActivationKey, activateKey, verifyCode, @@ -34,16 +32,12 @@ import Brig.Types.Intra import Cassandra import Control.Error import Data.Id -import Data.Text (pack) import Data.Text.Ascii qualified as Ascii import Data.Text.Encoding qualified as T import Data.Text.Lazy qualified as LT import Imports -import OpenSSL.BN (randIntegerZeroToNMinusOne) import OpenSSL.EVP.Digest (digestBS, getDigestByName) import Polysemy -import Text.Printf (printf) -import Util.Timeout import Wire.API.User import Wire.API.User.Activation import Wire.API.User.Password @@ -53,15 +47,6 @@ import Wire.UserKeyStore import Wire.UserSubsystem (UserSubsystem) import Wire.UserSubsystem qualified as User --- | 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) - data ActivationError = UserKeyExists !LT.Text | InvalidActivationCodeWrongUser @@ -82,10 +67,6 @@ data ActivationEvent | EmailActivated !UserId !EmailAddress deriving (Show) --- | Max. number of activation attempts per 'ActivationKey'. -maxAttempts :: Int32 -maxAttempts = 3 - -- docs/reference/user/activation.md {#RefActivationSubmit} activateKey :: forall r. @@ -151,29 +132,6 @@ activateKey k c u = wrapClientE (verifyCode k c) >>= pickUser >>= activate throwE . UserKeyExists . LT.fromStrict $ fromEmail (emailKeyOrig key) --- | Create a new pending activation for a given 'EmailKey'. -newActivation :: - (MonadClient m) => - EmailKey -> - -- | The timeout for the activation code. - Timeout -> - -- | The user with whom to associate the activation code. - Maybe UserId -> - m Activation -newActivation 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 - -- | Verify an activation code. verifyCode :: (MonadClient m) => @@ -196,6 +154,11 @@ verifyCode key code = do mkScope _ _ _ = throwE invalidCode countdown = lift . retry x5 . write keyInsert . params LocalQuorum revoke = lift $ deleteActivationPair key + 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 ?" mkActivationKey :: EmailKey -> IO ActivationKey mkActivationKey k = do @@ -213,12 +176,6 @@ invalidUser = InvalidActivationCodeWrongUser -- "User does not exist." invalidCode :: ActivationError invalidCode = InvalidActivationCodeWrongCode -- "Invalid activation code" -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 ?" - keySelect :: PrepQuery R (Identity ActivationKey) (Int32, Ascii, Text, ActivationCode, Maybe UserId, Int32) keySelect = "SELECT ttl(code) as ttl, key_type, key_text, code, user, retries FROM activation_keys WHERE key = ?" diff --git a/services/brig/src/Brig/Data/User.hs b/services/brig/src/Brig/Data/User.hs index 7e1f8e57656..326ef1cb780 100644 --- a/services/brig/src/Brig/Data/User.hs +++ b/services/brig/src/Brig/Data/User.hs @@ -36,7 +36,6 @@ module Brig.Data.User -- * Updates updateEmail, - updateEmailUnvalidated, updateSSOId, updateManagedBy, activateUser, @@ -46,7 +45,6 @@ module Brig.Data.User updateFeatureConferenceCalling, -- * Deletions - deleteEmail, deleteEmailUnvalidated, deleteServiceUser, ) @@ -209,9 +207,6 @@ insertAccount u mbConv password activated = retry x5 . batch $ do updateEmail :: (MonadClient m) => UserId -> EmailAddress -> m () updateEmail u e = retry x5 $ write userEmailUpdate (params LocalQuorum (e, u)) -updateEmailUnvalidated :: (MonadClient m) => UserId -> EmailAddress -> m () -updateEmailUnvalidated u e = retry x5 $ write userEmailUnvalidatedUpdate (params LocalQuorum (e, u)) - updateSSOId :: (MonadClient m) => UserId -> Maybe UserSSOId -> m Bool updateSSOId u ssoid = do mteamid <- lookupUserTeam u @@ -234,9 +229,6 @@ updateFeatureConferenceCalling uid mStatus = update :: PrepQuery W (Maybe FeatureStatus, UserId) () update = fromString "update user set feature_conference_calling = ? where id = ?" -deleteEmail :: (MonadClient m) => UserId -> m () -deleteEmail u = retry x5 $ write userEmailDelete (params LocalQuorum (Identity u)) - deleteEmailUnvalidated :: (MonadClient m) => UserId -> m () deleteEmailUnvalidated u = retry x5 $ write userEmailUnvalidatedDelete (params LocalQuorum (Identity u)) @@ -435,9 +427,6 @@ userInsert = userEmailUpdate :: PrepQuery W (EmailAddress, UserId) () userEmailUpdate = {- `IF EXISTS`, but that requires benchmarking -} "UPDATE user SET email = ? WHERE id = ?" -userEmailUnvalidatedUpdate :: PrepQuery W (EmailAddress, UserId) () -userEmailUnvalidatedUpdate = {- `IF EXISTS`, but that requires benchmarking -} "UPDATE user SET email_unvalidated = ? WHERE id = ?" - userEmailUnvalidatedDelete :: PrepQuery W (Identity UserId) () userEmailUnvalidatedDelete = {- `IF EXISTS`, but that requires benchmarking -} "UPDATE user SET email_unvalidated = null WHERE id = ?" @@ -456,9 +445,6 @@ userDeactivatedUpdate = {- `IF EXISTS`, but that requires benchmarking -} "UPDAT userActivatedUpdate :: PrepQuery W (Maybe EmailAddress, UserId) () userActivatedUpdate = {- `IF EXISTS`, but that requires benchmarking -} "UPDATE user SET activated = true, email = ? 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 = ?" - userRichInfoUpdate :: PrepQuery W (RichInfoAssocList, UserId) () userRichInfoUpdate = {- `IF EXISTS`, but that requires benchmarking -} "UPDATE rich_info SET json = ? WHERE user = ?" diff --git a/services/galley/test/integration/API/Util.hs b/services/galley/test/integration/API/Util.hs index 07909cbbbcd..243a8a723cf 100644 --- a/services/galley/test/integration/API/Util.hs +++ b/services/galley/test/integration/API/Util.hs @@ -29,7 +29,7 @@ import Control.Concurrent.Async import Control.Lens hiding (from, to, uncons, (#), (.=)) import Control.Monad.Catch (MonadCatch, MonadMask) import Control.Monad.Codensity (lowerCodensity) -import Control.Retry (constantDelay, exponentialBackoff, limitRetries, retrying) +import Control.Retry (constantDelay, exponentialBackoff, limitRetries, recoverAll, retrying) import Data.Aeson hiding (json) import Data.Aeson qualified as A import Data.Aeson.Lens (key, _String) @@ -429,7 +429,8 @@ addUserToTeamWithRole' role inviter tid = do let invite = InvitationRequest Nothing role Nothing inviteeEmail invResponse <- postInvitation tid inviter invite inv <- responseJsonError invResponse - inviteeCode <- getInvitationCode tid inv.invitationId + inviteeCode <- recoverAll (exponentialBackoff 1000 <> limitRetries 11) $ + \_ -> getInvitationCode tid inv.invitationId r <- post ( brig