From b065da85359da8ca6f82e98d78e7d02a2a72acab Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Tue, 4 Aug 2026 20:01:36 +0200 Subject: [PATCH 1/2] WPB-22970: migrate activation-keys to PostGreSQL MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Add Postgres, DualWrite, and Migration interpreters for the ActivationCodeStore effect (brig service). The migration follows the canonical dual-write + background-worker pattern: - Layer A: PostgresMarshall instances for ActivationKey/ActivationCode - Layer B: Postgres interpreter with TTL→expires_at conversion - Layer C: DualWrite interpreter (reads→Cassandra, writes→both) - Layer D: Migration loop copying ttl(code)→expires_at - Layer E: activationKeys StorageLocation config field - Layer F: Brig interpreter selection + second-writer refactor - Layer G-H: Background-worker migration wrapper + flag - Layer I-R: SQL migration, helm values, config docs, integration test The key design decision: the second writer (Brig.Data.Activation.verifyCode) that bypassed the effect is now routed through a new VerifyActivationCode effect constructor. This preserves the brute-force protection (3 max retries, TTL-preserving countdown, delete on exhaustion) while allowing each interpreter to implement it natively. ActivationCodeStore was moved before the Error block in BrigLowerLevelEffects to ensure Error Hasql.UsageError is available when the Postgres interpreter runs. Bead: ws-migrate-postgresql-ec0 --- changelog.d/5-internal/WPB-22970 | 1 + .../background-worker/configmap.yaml | 1 + charts/wire-server/values.yaml | 2 + .../src/developer/reference/config-options.md | 24 ++- hack/helm_vars/common.yaml.gotmpl | 1 + hack/helm_vars/wire-server/values.yaml.gotmpl | 1 + integration/integration.cabal | 1 + .../test/Test/Migration/ActivationKeys.hs | 61 ++++++++ libs/wire-api/src/Wire/API/User/Activation.hs | 12 ++ .../Wire/API/Roundtrip/PostgresMarshall.hs | 3 + .../20260804165620-activation-keys.sql | 18 +++ .../src/Wire/ActivationCodeStore.hs | 62 +++++++- .../src/Wire/ActivationCodeStore/Cassandra.hs | 64 ++++---- .../src/Wire/ActivationCodeStore/DualWrite.hs | 66 ++++++++ .../src/Wire/ActivationCodeStore/Migration.hs | 124 +++++++++++++++ .../src/Wire/ActivationCodeStore/Postgres.hs | 146 ++++++++++++++++++ .../src/Wire/PostgresMigrationOpts.hs | 4 +- .../MockInterpreters/ActivationCodeStore.hs | 1 + libs/wire-subsystems/wire-subsystems.cabal | 3 + postgres-schema.sql | 28 ++++ .../background-worker.integration.yaml | 2 + .../src/Wire/BackgroundWorker.hs | 10 +- .../src/Wire/BackgroundWorker/Options.hs | 1 + .../src/Wire/PostgresMigrations.hs | 17 ++ .../Wire/BackendNotificationPusherSpec.hs | 6 +- .../background-worker/test/Test/Wire/Util.hs | 3 +- services/brig/brig.integration.yaml | 1 + services/brig/src/Brig/API/Internal.hs | 3 +- services/brig/src/Brig/API/Public.hs | 8 +- services/brig/src/Brig/API/User.hs | 23 +-- .../brig/src/Brig/CanonicalInterpreter.hs | 10 +- services/brig/src/Brig/Data/Activation.hs | 58 ++----- 32 files changed, 654 insertions(+), 111 deletions(-) create mode 100644 changelog.d/5-internal/WPB-22970 create mode 100644 integration/test/Test/Migration/ActivationKeys.hs create mode 100644 libs/wire-subsystems/postgres-migrations/20260804165620-activation-keys.sql create mode 100644 libs/wire-subsystems/src/Wire/ActivationCodeStore/DualWrite.hs create mode 100644 libs/wire-subsystems/src/Wire/ActivationCodeStore/Migration.hs create mode 100644 libs/wire-subsystems/src/Wire/ActivationCodeStore/Postgres.hs diff --git a/changelog.d/5-internal/WPB-22970 b/changelog.d/5-internal/WPB-22970 new file mode 100644 index 00000000000..71d7a6b42c3 --- /dev/null +++ b/changelog.d/5-internal/WPB-22970 @@ -0,0 +1 @@ +Migration of activation keys from cassandra to postgres diff --git a/charts/wire-server/templates/background-worker/configmap.yaml b/charts/wire-server/templates/background-worker/configmap.yaml index d4fe2a63202..b340c05139e 100644 --- a/charts/wire-server/templates/background-worker/configmap.yaml +++ b/charts/wire-server/templates/background-worker/configmap.yaml @@ -84,6 +84,7 @@ data: migrateConversationCodes: {{ .migrateConversationCodes }} migrateTeamFeatures: {{ .migrateTeamFeatures }} migrateDomainRegistration: {{ .migrateDomainRegistration }} + migrateActivationKeys: {{ .migrateActivationKeys }} migrationOptions: {{ toYaml .migrationOptions | indent 6 }} diff --git a/charts/wire-server/values.yaml b/charts/wire-server/values.yaml index 5bb0b276eb6..af9208dd5dd 100644 --- a/charts/wire-server/values.yaml +++ b/charts/wire-server/values.yaml @@ -89,6 +89,7 @@ galley: conversationCodes: cassandra teamFeatures: cassandra domainRegistration: cassandra + activationKeys: cassandra user: cassandra settings: httpPoolSize: 128 @@ -1026,6 +1027,7 @@ background-worker: # It's important to set `settings.postgresMigration.domainRegistration` to `migration-to-postgresql` # before starting the migration. migrateDomainRegistration: false + migrateActivationKeys: false backendNotificationPusher: pushBackoffMinWait: 10000 # in microseconds, so 10ms diff --git a/docs/src/developer/reference/config-options.md b/docs/src/developer/reference/config-options.md index cf86ee7681c..2a2e71cce2e 100644 --- a/docs/src/developer/reference/config-options.md +++ b/docs/src/developer/reference/config-options.md @@ -2150,6 +2150,7 @@ galley: conversationCodes: postgresql teamFeatures: postgresql domainRegistration: postgresql + activationKeys: postgresql user: postgresql background-worker: config: @@ -2157,6 +2158,7 @@ background-worker: migrateConversationCodes: false migrateTeamFeatures: false migrateDomainRegistration: false + migrateActivationKeys: false ``` #### Migration for existing installations @@ -2187,6 +2189,7 @@ The current settings and their background-worker flags are: - `conversationCodes` -> `migrateConversationCodes` - `teamFeatures` -> `migrateTeamFeatures` - `domainRegistration` -> `migrateDomainRegistration` +- `activationKeys` -> `migrateActivationKeys` **Migration pattern per migration setting** @@ -2205,13 +2208,15 @@ The current settings and their background-worker flags are: conversation: migration-to-postgresql conversationCodes: migration-to-postgresql teamFeatures: migration-to-postgresql - domainRegistration: cassandra - background-worker: - config: - migrateConversations: false - migrateConversationCodes: false - migrateTeamFeatures: false - migrateDomainRegistration: false + domainRegistration: cassandra + activationKeys: migration-to-postgresql + background-worker: + config: + migrateConversations: false + migrateConversationCodes: false + migrateTeamFeatures: false + migrateDomainRegistration: false + migrateActivationKeys: false ``` This change should restart the affected pods, and new writes will follow the @@ -2225,7 +2230,8 @@ The current settings and their background-worker flags are: migrateConversations: true migrateConversationCodes: true migrateTeamFeatures: true - migrateDomainRegistration: true + migrateDomainRegistration: true + migrateActivationKeys: true ``` During migration, Cassandra rows are not deleted. Writes and migration share @@ -2241,6 +2247,7 @@ The current settings and their background-worker flags are: - `conversationCodes`: `wire_conv_codes_migration_finished` - `teamFeatures`: `wire_team_features_migration_finished` - `domainRegistration`: `wire_domain_registration_migration_finished` + - `activationKeys`: `wire_activation_keys_migration_finished` 3. Cut over reads and writes to PostgreSQL for the selected migration setting(s). This configuration must be used from now on for every new @@ -2273,6 +2280,7 @@ The current settings and their background-worker flags are: - Some settings cover multiple Cassandra tables. For example, `postgresMigration.domainRegistration` covers `domain_registration`, `domain_registration_by_team`, and `domain_registration_challenge`. + `postgresMigration.activationKeys` covers the `activation_keys` table. ## Configure Cells diff --git a/hack/helm_vars/common.yaml.gotmpl b/hack/helm_vars/common.yaml.gotmpl index 2276355e2a9..000d0702bac 100644 --- a/hack/helm_vars/common.yaml.gotmpl +++ b/hack/helm_vars/common.yaml.gotmpl @@ -18,6 +18,7 @@ conversationStore: {{ $preferredStore }} conversationCodesStore: {{ $preferredStore }} teamFeaturesStore: {{ $preferredStore }} domainRegistration: {{ $preferredStore }} +activationKeysStore: {{ $preferredStore }} userStore: {{ $preferredStore }} {{- if (eq (env "UPLOAD_XML_S3_BASE_URL") "") }} diff --git a/hack/helm_vars/wire-server/values.yaml.gotmpl b/hack/helm_vars/wire-server/values.yaml.gotmpl index b0309380b56..c29755397a2 100644 --- a/hack/helm_vars/wire-server/values.yaml.gotmpl +++ b/hack/helm_vars/wire-server/values.yaml.gotmpl @@ -305,6 +305,7 @@ galley: conversationCodes: {{ .Values.conversationCodesStore }} teamFeatures: {{ .Values.teamFeaturesStore }} domainRegistration: {{ .Values.domainRegistration }} + activationKeys: {{ .Values.activationKeysStore }} user: {{ .Values.userStore }} settings: maxConvAndTeamSize: 16 diff --git a/integration/integration.cabal b/integration/integration.cabal index d124256a118..d58d18c92d8 100644 --- a/integration/integration.cabal +++ b/integration/integration.cabal @@ -177,6 +177,7 @@ library Test.Login Test.Meetings Test.MessageTimer + Test.Migration.ActivationKeys Test.Migration.Conversation Test.Migration.ConversationCodes Test.Migration.DomainRegistration diff --git a/integration/test/Test/Migration/ActivationKeys.hs b/integration/test/Test/Migration/ActivationKeys.hs new file mode 100644 index 00000000000..9b5cd5f5a3b --- /dev/null +++ b/integration/test/Test/Migration/ActivationKeys.hs @@ -0,0 +1,61 @@ +module Test.Migration.ActivationKeys where + +import Control.Concurrent.Timeout +import Control.Monad.Reader +import SetupHelpers +import Test.Migration.Util (waitForMigration) +import Testlib.Prelude + +testActivationKeysMigration :: (HasCallStack) => App () +testActivationKeysMigration = do + -- Start in migration-to-postgresql mode with the worker enabled. + withDynamicBackend + ( \domain -> + conf + domain + Backend + { def = \c -> c & #br #~ brigConf domain "migration-to-postgresql", + optSettings = \c -> c & #br #~ brigConf domain "migration-to-postgresql" + } + ) + $ do + -- The background worker copies existing activation_keys rows. + -- Poll until the migration counter reaches 1.0. + waitForMigration "brig" "^wire_activation_keys_migration_finished" + + -- After migration, verify activation still works by registering + -- a new user and activating with the code. + user <- + randomUser + . def + $ \u -> + u + & #email .~ Just "activation-migration@example.com" + & #name .~ "Activation Migration" + + -- Verify the user can be activated (the VerifyActivationCode path + -- now reads from Postgres). + -- (Full activation flow is exercised by the existing integration + -- tests; here we only verify the migration completed.) + pure () + +conf :: String -> DomainTag -> ServiceOverrides +conf domain tag = + ServiceOverrides + { brig = + stdFieldUpdate + "config.postgresMigration.activationKeys" + "postgresql" + domain + tag, + backgroundWorker = bwConf + } + where + bwConf domain' tag' = + mconcat + [ stdFieldUpdate "config.migrateActivationKeys" "true" domain' tag', + stdFieldUpdate "config.postgresMigration.activationKeys" "postgresql" domain' tag' + ] + +counterName :: String +counterName = "^wire_activation_keys_migration_finished" diff --git a/libs/wire-api/src/Wire/API/User/Activation.hs b/libs/wire-api/src/Wire/API/User/Activation.hs index 798011c53e6..5f309446d37 100644 --- a/libs/wire-api/src/Wire/API/User/Activation.hs +++ b/libs/wire-api/src/Wire/API/User/Activation.hs @@ -40,6 +40,8 @@ import Data.OpenApi (ToParamSchema) import Data.OpenApi qualified as S import Data.Schema import Data.Text.Ascii +import Data.Text (pack) +import Wire.API.PostgresMarshall import Imports import Servant (FromHttpApiData (..)) import Wire.API.Locale @@ -75,6 +77,11 @@ instance FromHttpApiData ActivationKey where parseUrlPiece = fmap ActivationKey . parseUrlPiece deriving instance C.Cql ActivationKey +instance PostgresMarshall Text ActivationKey where + postgresMarshall = toText . fromActivationKey + +instance PostgresUnmarshall Text ActivationKey where + postgresUnmarshall = bimap pack ActivationKey . validateBase64Url -------------------------------------------------------------------------------- -- ActivationCode @@ -100,6 +107,11 @@ deriving instance C.Cql ActivationCode -- | A pair of 'ActivationKey' and 'ActivationCode' as required for activation. type ActivationPair = (ActivationKey, ActivationCode) +instance PostgresMarshall Text ActivationCode where + postgresMarshall = toText . fromActivationCode + +instance PostgresUnmarshall Text ActivationCode where + postgresUnmarshall = bimap pack ActivationCode . validateBase64Url -------------------------------------------------------------------------------- -- Activate diff --git a/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/PostgresMarshall.hs b/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/PostgresMarshall.hs index 532ff0510ed..9c9091bd759 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/PostgresMarshall.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/PostgresMarshall.hs @@ -50,6 +50,7 @@ import Wire.API.Password as Password import Wire.API.Password.Argon2id (Argon2HashedPassword (..), encodeArgon2HashedPassword) import Wire.API.Password.Scrypt (encodeScryptPassword) import Wire.API.PostgresMarshall +import Wire.API.User.Activation import Wire.API.Team.Feature import Wire.Arbitrary qualified as Arbitrary () @@ -58,6 +59,8 @@ tests = T.localOption (T.Timeout (60 * 1000000) "60s") . T.testGroup "PostgresMarshall roundtrip tests" $ [ testRoundTrip @Text @Code.Key, testRoundTrip @Text @Code.Value, + testRoundTrip @Text @ActivationKey, + testRoundTrip @Text @ActivationCode, testRoundTrip @ByteString @Password.Password, testRoundTrip @Int32 @FeatureStatus, testRoundTrip @Int32 @LockStatus, diff --git a/libs/wire-subsystems/postgres-migrations/20260804165620-activation-keys.sql b/libs/wire-subsystems/postgres-migrations/20260804165620-activation-keys.sql new file mode 100644 index 00000000000..543e6eaeaeb --- /dev/null +++ b/libs/wire-subsystems/postgres-migrations/20260804165620-activation-keys.sql @@ -0,0 +1,18 @@ +CREATE TABLE activation_keys ( + key text NOT NULL, + key_type text NOT NULL, + key_text text NOT NULL, + code text NOT NULL, + "user" uuid, + retries int4 NOT NULL, + expires_at timestamptz NOT NULL, + PRIMARY KEY (key) +); + +-- index for lookups like `WHERE key = ? AND expires_at > now()` +CREATE INDEX activation_keys_key_expires_at_idx + ON activation_keys (key, expires_at); + +-- index for cleanup like `DELETE ... WHERE expires_at <= now()` +CREATE INDEX activation_keys_expires_at_idx + ON activation_keys (expires_at); diff --git a/libs/wire-subsystems/src/Wire/ActivationCodeStore.hs b/libs/wire-subsystems/src/Wire/ActivationCodeStore.hs index 0b6f656e363..d3cb61db0a8 100644 --- a/libs/wire-subsystems/src/Wire/ActivationCodeStore.hs +++ b/libs/wire-subsystems/src/Wire/ActivationCodeStore.hs @@ -33,13 +33,31 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Wire.ActivationCodeStore where +module Wire.ActivationCodeStore + ( ActivationCodeStore (..), + lookupActivationCode, + newActivationCode, + deleteActivationCode, + verifyActivationCode, + mkActivationKey, + genActivationCode, + maxAttempts, + mkActivationScope, + ) +where 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 Text.Printf (printf) import Util.Timeout import Wire.API.User.Activation +import Wire.API.User.EmailAddress import Wire.UserKeyStore data ActivationCodeStore :: Effect where @@ -60,5 +78,47 @@ data ActivationCodeStore :: Effect where DeleteActivationCode :: EmailKey -> ActivationCodeStore m () + -- | Verify an activation code against the stored value for the given key. + -- On a match, returns the associated 'EmailKey' and 'UserId'. On a + -- mismatch with remaining retries, decrements the retry counter (preserving + -- the remaining TTL). On exhaustion, deletes the row. Returns 'Nothing' + -- for any non-matching outcome (the caller treats this as an invalid code). + VerifyActivationCode :: + ActivationKey -> + ActivationCode -> + ActivationCodeStore m (Maybe (EmailKey, Maybe UserId)) makeSem ''ActivationCodeStore + +-------------------------------------------------------------------------------- +-- Shared utilities (used by Cassandra, Postgres, DualWrite interpreters) + +-- | Compute the opaque 'ActivationKey' (SHA-256 hash, base64url-encoded) for +-- a given 'EmailKey'. Moved here from the Cassandra interpreter so that all +-- interpreters share a single definition. +mkActivationKey :: EmailKey -> IO ActivationKey +mkActivationKey k = do + d <- getDigestByName "SHA256" + d' <- maybe (fail "SHA256 not found") pure d + let bs = digestBS d' (T.encodeUtf8 $ emailKeyUniq k) + pure . ActivationKey $ Ascii.encodeBase64Url bs + +-- | Generate a fresh random 6-digit 'ActivationCode'. +genActivationCode :: IO ActivationCode +genActivationCode = + ActivationCode . Ascii.unsafeFromText . pack . printf "%06d" + <$> randIntegerZeroToNMinusOne 1000000 + +-- | Maximum number of activation attempts per 'ActivationKey'. +maxAttempts :: Int32 +maxAttempts = 3 + +-- | Reconstruct an activation scope from the stored key type/text. +-- Returns 'Just' if the key type is @"email"@ and the text parses as an +-- email address; 'Nothing' otherwise. +mkActivationScope :: Text -> Text -> Maybe UserId -> Maybe (EmailKey, Maybe UserId) +mkActivationScope "email" keyText mUser = + case emailAddressText keyText of + Just e -> Just (mkEmailKey e, mUser) + Nothing -> Nothing +mkActivationScope _ _ _ = Nothing diff --git a/libs/wire-subsystems/src/Wire/ActivationCodeStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/ActivationCodeStore/Cassandra.hs index 24d2f3c2737..30ed7d43dfa 100644 --- a/libs/wire-subsystems/src/Wire/ActivationCodeStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/ActivationCodeStore/Cassandra.hs @@ -19,15 +19,9 @@ module Wire.ActivationCodeStore.Cassandra (interpretActivationCodeStoreToCassand 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 @@ -40,12 +34,13 @@ interpretActivationCodeStoreToCassandra casClient = runEmbedded (runClient casClient) . embed . \case LookupActivationCode ek -> do liftIO (mkActivationKey ek) - >>= retry x1 . query1 cql . params LocalQuorum . Identity + >>= retry x1 . query1 lookupCode . params LocalQuorum . Identity NewActivationCode ek timeout uid -> newActivationCodeImpl ek timeout uid DeleteActivationCode ek -> deleteActivationCodeImpl ek + VerifyActivationCode key code -> verifyActivationCodeImpl key code where - cql :: PrepQuery R (Identity ActivationKey) (Maybe UserId, ActivationCode) - cql = + lookupCode :: PrepQuery R (Identity ActivationKey) (Maybe UserId, ActivationCode) + lookupCode = [sql| SELECT user, code FROM activation_keys WHERE key = ? |] @@ -62,16 +57,10 @@ newActivationCodeImpl :: 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 + code <- liftIO genActivationCode + key' <- liftIO $ mkActivationKey uk + retry x5 . write keyInsert $ params LocalQuorum (key', typ, key, code, u, maxAttempts, round timeout) + pure $ Activation key' code -- | Delete a pending activation code for a given 'EmailKey', if any. deleteActivationCodeImpl :: @@ -82,18 +71,31 @@ deleteActivationCodeImpl uk = do key <- liftIO $ mkActivationKey uk retry x5 . write keyDelete $ params LocalQuorum (Identity key) +-- | Verify an activation code, decrementing retries or revoking on mismatch. +-- Returns 'Just' the 'EmailKey' and 'UserId' on a match, 'Nothing' otherwise. +verifyActivationCodeImpl :: + (MonadClient m) => + ActivationKey -> + ActivationCode -> + m (Maybe (EmailKey, Maybe UserId)) +verifyActivationCodeImpl key code = do + s <- retry x1 . query1 keySelect $ params LocalQuorum (Identity key) + case s of + Just (ttl, Ascii t, k, c, u, r) -> + if + | c == code -> pure (mkActivationScope t k u) + | r >= 1 -> do + retry x5 . write keyInsert $ params LocalQuorum (key, t, k, c, u, r - 1, ttl) + pure Nothing + | otherwise -> do + write keyDelete $ params LocalQuorum (Identity key) + pure Nothing + Nothing -> pure Nothing -------------------------------------------------------------------------------- --- Utilities +-- CQL queries -mkActivationKey :: EmailKey -> IO ActivationKey -mkActivationKey k = do - Just d <- getDigestByName "SHA256" - pure do - ActivationKey - . Ascii.encodeBase64Url - . digestBS d - . T.encodeUtf8 - $ emailKeyUniq k +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 = ?" keyInsert :: PrepQuery W (ActivationKey, Text, Text, ActivationCode, Maybe UserId, Int32, Int32) () keyInsert = @@ -103,7 +105,3 @@ keyInsert = keyDelete :: PrepQuery W (Identity ActivationKey) () keyDelete = "DELETE FROM activation_keys WHERE key = ?" - --- | Max. number of activation attempts per 'ActivationKey'. -maxAttempts :: Int32 -maxAttempts = 3 diff --git a/libs/wire-subsystems/src/Wire/ActivationCodeStore/DualWrite.hs b/libs/wire-subsystems/src/Wire/ActivationCodeStore/DualWrite.hs new file mode 100644 index 00000000000..9a0a2d90af8 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/ActivationCodeStore/DualWrite.hs @@ -0,0 +1,66 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2026 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Wire.ActivationCodeStore.DualWrite + ( interpretActivationCodeStoreToCassandraAndPostgres, + ) +where + +import Cassandra (ClientState) +import Imports +import Polysemy +import Wire.ActivationCodeStore +import Wire.ActivationCodeStore qualified as ActivationCodeStore +import Wire.ActivationCodeStore.Cassandra qualified as Cassandra +import Wire.ActivationCodeStore.Postgres qualified as Postgres +import Wire.API.User.Activation +import Wire.API.User.EmailAddress +import Wire.Postgres +import Wire.UserKeyStore + +interpretActivationCodeStoreToCassandraAndPostgres :: + (PGConstraints r) => + ClientState -> + InterpreterFor ActivationCodeStore r +interpretActivationCodeStoreToCassandraAndPostgres cs = interpret $ \case + LookupActivationCode ek -> + Cassandra.interpretActivationCodeStoreToCassandra cs $ ActivationCodeStore.lookupActivationCode ek + NewActivationCode ek timeout uid -> do + activation <- + Cassandra.interpretActivationCodeStoreToCassandra cs $ + ActivationCodeStore.newActivationCode ek timeout uid + Postgres.interpretActivationCodeStoreToPostgres $ + Postgres.insertActivationKeyRow + ( activationKey activation, + "email", + fromEmail (emailKeyOrig ek), + activationCode activation, + uid, + maxAttempts, + round timeout + ) + pure activation + DeleteActivationCode ek -> do + Cassandra.interpretActivationCodeStoreToCassandra cs $ ActivationCodeStore.deleteActivationCode ek + Postgres.interpretActivationCodeStoreToPostgres $ ActivationCodeStore.deleteActivationCode ek + VerifyActivationCode key code -> do + -- Cassandra is the source of truth for reads; the Postgres result is + -- discarded for state convergence. A Postgres error fails the operation + -- (consistent with sibling stores). + result <- Cassandra.interpretActivationCodeStoreToCassandra cs $ ActivationCodeStore.verifyActivationCode key code + _ <- Postgres.interpretActivationCodeStoreToPostgres $ ActivationCodeStore.verifyActivationCode key code + pure result diff --git a/libs/wire-subsystems/src/Wire/ActivationCodeStore/Migration.hs b/libs/wire-subsystems/src/Wire/ActivationCodeStore/Migration.hs new file mode 100644 index 00000000000..5598cd8d652 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/ActivationCodeStore/Migration.hs @@ -0,0 +1,124 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2026 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Wire.ActivationCodeStore.Migration (migrateActivationKeysLoop) where + +import Cassandra hiding (Value) +import Data.ByteString.Conversion +import Data.Conduit +import Data.Conduit.List qualified as C +import Data.Id (UserId) +import Data.Time +import Hasql.Pool.Extended qualified as Hasql +import Imports +import Polysemy +import Polysemy.Async +import Polysemy.Conc (interpretRace) +import Polysemy.Conc.Effect.Race hiding (Timeout) +import Polysemy.Input +import Polysemy.Resource (Resource, resourceToIOFinal) +import Wire.API.User.Activation +import Polysemy.State +import Polysemy.TinyLog +import Prometheus qualified +import System.Logger qualified as Log +import Wire.ActivationCodeStore.Postgres qualified as Postgres +import Wire.Migration +import Wire.Postgres +import Wire.Sem.Logger (mapLogger) +import Wire.Sem.Logger.TinyLog (loggerToTinyLog) + +type EffectStack = + [ State Int, + Input ClientState, + Input Hasql.Pool, + Resource, + Async, + Race, + TinyLog, + Embed IO, + Final IO + ] + +migrateActivationKeysLoop :: + MigrationOptions -> + ClientState -> + Hasql.Pool -> + Log.Logger -> + Prometheus.Counter -> + Prometheus.Counter -> + Prometheus.Counter -> + Prometheus.Vector Text Prometheus.Histogram -> + IO () +migrateActivationKeysLoop migOpts cassClient pgPool logger migCounter migFinished migFailed migDuration = + migrationLoop + logger + "activation keys" + migFinished + migFailed + (interpreter cassClient pgPool logger "activation keys") + (migrateAllActivationKeys migOpts migCounter migDuration) + +interpreter :: ClientState -> Hasql.Pool -> Log.Logger -> ByteString -> Sem EffectStack a -> IO (Int, a) +interpreter cassClient pgPool logger name = + runFinal + . embedToFinal + . loggerToTinyLog logger + . mapLogger (Log.field "migration" (Log.val name) .) + . raiseUnder + . interpretRace + . asyncToIOFinal + . resourceToIOFinal + . runInputConst pgPool + . runInputConst cassClient + . runState 0 + +migrateAllActivationKeys :: + ( Member (Input Hasql.Pool) r, + Member (Embed IO) r, + Member (Input ClientState) r, + Member TinyLog r, + Member (State Int) r + ) => + MigrationOptions -> + Prometheus.Counter -> + Prometheus.Vector Text Prometheus.Histogram -> + ConduitM () Void (Sem r) () +migrateAllActivationKeys migOpts migCounter migDuration = do + lift $ info $ Log.msg (Log.val "migrateAllActivationKeys") + withCount (paginateSem selectAllActivationKeys (paramsP LocalQuorum () migOpts.pageSize) x5) + .| logRetrievedPage migOpts.pageSize id + .| C.mapM_ (traverse_ (\row@(key, _, _, _, _, _) -> handleErrors (toByteString' key) (migrateActivationKeyRow migCounter migDuration row))) + +migrateActivationKeyRow :: + (PGConstraints r) => + Prometheus.Counter -> + Prometheus.Vector Text Prometheus.Histogram -> + (ActivationKey, Text, ActivationCode, Maybe UserId, Int32, Int32) -> + Sem r () +migrateActivationKeyRow migCounter migDuration (key, keyText, code, mUser, retries, ttl) = + when (ttl > 0) $ do + start <- liftIO getCurrentTime + Postgres.interpretActivationCodeStoreToPostgres $ + Postgres.insertActivationKeyRow (key, "email", keyText, code, mUser, retries, ttl) + end <- liftIO getCurrentTime + liftIO $ Prometheus.withLabel migDuration "success" (`Prometheus.observe` realToFrac (diffUTCTime end start)) + liftIO $ Prometheus.incCounter migCounter + +selectAllActivationKeys :: PrepQuery R () (ActivationKey, Text, ActivationCode, Maybe UserId, Int32, Int32) +selectAllActivationKeys = + "SELECT key, key_text, code, user, retries, ttl(code) FROM activation_keys" diff --git a/libs/wire-subsystems/src/Wire/ActivationCodeStore/Postgres.hs b/libs/wire-subsystems/src/Wire/ActivationCodeStore/Postgres.hs new file mode 100644 index 00000000000..729df3cabe3 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/ActivationCodeStore/Postgres.hs @@ -0,0 +1,146 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2026 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Wire.ActivationCodeStore.Postgres + ( interpretActivationCodeStoreToPostgres, + insertActivationKeyRow, + ) +where + +import Data.Id (UserId) +import Hasql.TH +import Hasql.Statement qualified as Hasql +import Imports +import Polysemy +import Util.Timeout +import Wire.API.PostgresMarshall +import Wire.API.User.Activation +import Wire.API.User.EmailAddress +import Wire.ActivationCodeStore +import Wire.Postgres +import Wire.UserKeyStore + +interpretActivationCodeStoreToPostgres :: + (PGConstraints r) => + InterpreterFor ActivationCodeStore r +interpretActivationCodeStoreToPostgres = interpret $ \case + LookupActivationCode ek -> do + key <- embed (mkActivationKey ek) + runStatement key lookupCode + NewActivationCode ek timeout uid -> newActivationCodeImpl ek timeout uid + DeleteActivationCode ek -> do + key <- embed (mkActivationKey ek) + runStatement key deleteCode + VerifyActivationCode key code -> verifyActivationCodeImpl key code + +lookupCode :: Hasql.Statement ActivationKey (Maybe (Maybe UserId, ActivationCode)) +lookupCode = + dimapPG + [maybeStatement| + SELECT "user" :: uuid?, code :: text + FROM activation_keys + WHERE key = ($1 :: text) AND expires_at > now() + |] + +newActivationCodeImpl :: + (PGConstraints r) => + EmailKey -> + Timeout -> + Maybe UserId -> + Sem r Activation +newActivationCodeImpl ek timeout u = do + key <- embed (mkActivationKey ek) + code <- embed genActivationCode + let keyText = fromEmail (emailKeyOrig ek) + runStatement (key, "email", keyText, code, u, maxAttempts, round timeout) insertWithTtl + pure $ Activation key code + +-- | Used by the migration loop to copy an existing row verbatim (with a +-- computed @expires_at@ derived from the Cassandra TTL). +insertActivationKeyRow :: + (PGConstraints r) => + (ActivationKey, Text, Text, ActivationCode, Maybe UserId, Int32, Int32) -> + Sem r () +insertActivationKeyRow (key, keyType, keyText, code, mUser, retries, ttlSecs) = + runStatement (key, keyType, keyText, code, mUser, retries, ttlSecs) insertWithTtl + +verifyActivationCodeImpl :: + (PGConstraints r) => + ActivationKey -> + ActivationCode -> + Sem r (Maybe (EmailKey, Maybe UserId)) +verifyActivationCodeImpl key code = do + mRow <- runStatement key selectForVerify + case mRow of + Just (keyType, keyText, storedCode, mUser, retries) -> + if + | storedCode == code -> pure (mkActivationScope keyType keyText mUser) + | retries >= 1 -> do + runStatement key decrementRetries + pure Nothing + | otherwise -> do + runStatement key deleteCode + pure Nothing + Nothing -> pure Nothing + +-------------------------------------------------------------------------------- +-- Statements + + +insertWithTtl :: + Hasql.Statement (ActivationKey, Text, Text, ActivationCode, Maybe UserId, Int32, Int32) () +insertWithTtl = + lmapPG + [resultlessStatement| + INSERT INTO activation_keys (key, key_type, key_text, code, "user", retries, expires_at) + VALUES ($1 :: text, $2 :: text, $3 :: text, $4 :: text, $5 :: uuid?, $6 :: int4, now() + make_interval(secs => $7 :: int4)) + ON CONFLICT (key) DO UPDATE + SET key_type = ($2 :: text), + key_text = ($3 :: text), + code = ($4 :: text), + "user" = ($5 :: uuid?), + retries = ($6 :: int4), + expires_at = now() + make_interval(secs => $7 :: int4) + |] + +selectForVerify :: + Hasql.Statement ActivationKey (Maybe (Text, Text, ActivationCode, Maybe UserId, Int32)) +selectForVerify = + dimapPG + [maybeStatement| + SELECT key_type :: text, + key_text :: text, + code :: text, + "user" :: uuid?, + retries :: int4 + FROM activation_keys + WHERE key = ($1 :: text) AND expires_at > now() + |] + +decrementRetries :: Hasql.Statement ActivationKey () +decrementRetries = + lmapPG + [resultlessStatement| + UPDATE activation_keys SET retries = retries - 1 WHERE key = ($1 :: text) AND retries > 0 + |] + +deleteCode :: Hasql.Statement ActivationKey () +deleteCode = + lmapPG + [resultlessStatement| + DELETE FROM activation_keys WHERE key = ($1 :: text) + |] diff --git a/libs/wire-subsystems/src/Wire/PostgresMigrationOpts.hs b/libs/wire-subsystems/src/Wire/PostgresMigrationOpts.hs index 327862f7cd5..d2f5463d0f1 100644 --- a/libs/wire-subsystems/src/Wire/PostgresMigrationOpts.hs +++ b/libs/wire-subsystems/src/Wire/PostgresMigrationOpts.hs @@ -56,7 +56,8 @@ data PostgresMigrationOpts = PostgresMigrationOpts conversationCodes :: StorageLocation, teamFeatures :: StorageLocation, domainRegistration :: StorageLocation, - user :: StorageLocation + user :: StorageLocation, + activationKeys :: StorageLocation } deriving (Show) @@ -68,3 +69,4 @@ instance FromJSON PostgresMigrationOpts where <*> o .: "teamFeatures" <*> o .: "domainRegistration" <*> o .: "user" + <*> o .: "activationKeys" diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/ActivationCodeStore.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/ActivationCodeStore.hs index 7250d3047fa..ead9bfe9334 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/ActivationCodeStore.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/ActivationCodeStore.hs @@ -55,3 +55,4 @@ inMemoryActivationCodeStoreInterpreter = c = emailKeyToCode ek modify (insert ek (uid, c)) $> Activation key c DeleteActivationCode ek -> modify (delete ek) + VerifyActivationCode _ _ -> pure Nothing diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index f7627036f1c..793dc975cf8 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -221,6 +221,9 @@ library exposed-modules: Wire.ActivationCodeStore Wire.ActivationCodeStore.Cassandra + Wire.ActivationCodeStore.DualWrite + Wire.ActivationCodeStore.Migration + Wire.ActivationCodeStore.Postgres Wire.AppStore Wire.AppStore.Postgres Wire.AppSubsystem diff --git a/postgres-schema.sql b/postgres-schema.sql index b2d1587ab49..fde41962148 100644 --- a/postgres-schema.sql +++ b/postgres-schema.sql @@ -685,6 +685,34 @@ SET default_tablespace = ''; SET default_table_access_method = heap; + +-- +-- Name: activation_keys; Type: TABLE; Schema: public; Owner: wire-server +-- + +CREATE TABLE public.activation_keys ( + key text NOT NULL, + key_type text NOT NULL, + key_text text NOT NULL, + code text NOT NULL, + "user" uuid, + retries integer NOT NULL, + expires_at timestamp with time zone NOT NULL +); + + +-- +-- Name: activation_keys activation_keys_key_expires_at_idx; Type: INDEX; Schema: public; Owner: wire-server +-- + +CREATE INDEX activation_keys_key_expires_at_idx ON public.activation_keys USING btree (key, expires_at); + + +-- +-- Name: activation_keys activation_keys_expires_at_idx; Type: INDEX; Schema: public; Owner: wire-server +-- + +CREATE INDEX activation_keys_expires_at_idx ON public.activation_keys USING btree (expires_at); -- -- Name: arbiter_concurrency; Type: TABLE; Schema: arbiter; Owner: wire-server -- diff --git a/services/background-worker/background-worker.integration.yaml b/services/background-worker/background-worker.integration.yaml index e264ce14016..d1fe690bcb0 100644 --- a/services/background-worker/background-worker.integration.yaml +++ b/services/background-worker/background-worker.integration.yaml @@ -58,6 +58,7 @@ migrationOptions: migrateConversationCodes: false migrateTeamFeatures: false migrateDomainRegistration: false +migrateActivationKeys: false # Background jobs consumer configuration for integration backgroundJobs: @@ -91,4 +92,5 @@ postgresMigration: conversationCodes: postgresql teamFeatures: postgresql domainRegistration: postgresql + activationKeys: postgresql user: postgresql diff --git a/services/background-worker/src/Wire/BackgroundWorker.hs b/services/background-worker/src/Wire/BackgroundWorker.hs index b57ba12df40..126f4a663bc 100644 --- a/services/background-worker/src/Wire/BackgroundWorker.hs +++ b/services/background-worker/src/Wire/BackgroundWorker.hs @@ -78,6 +78,13 @@ run opts galleyOpts = do withNamedLogger "migrate-domain-registration" $ Migrations.domainRegistration opts.migrationOptions else pure $ pure () + cleanupActivationKeysMigration <- + if opts.migrateActivationKeys + then + runAppT env $ + withNamedLogger "migrate-activation-keys" $ + Migrations.activationKeys opts.migrationOptions + else pure $ pure () cleanupJobs <- runAppT env $ withNamedLogger "background-job-consumer" $ @@ -89,13 +96,14 @@ run opts galleyOpts = do let cleanup = void $ runConcurrently $ - (,,,,,,,) + (,,,,,,,,) <$> Concurrently cleanupDeadUserNotifWatcher <*> Concurrently cleanupBackendNotifPusher <*> Concurrently cleanupConvMigration <*> Concurrently cleanUpConvCodesMigration <*> Concurrently cleanupTeamFeaturesMigration <*> Concurrently cleanupDomainRegistrationMigration + <*> Concurrently cleanupActivationKeysMigration <*> Concurrently cleanupJobRunner <*> Concurrently cleanupJobs diff --git a/services/background-worker/src/Wire/BackgroundWorker/Options.hs b/services/background-worker/src/Wire/BackgroundWorker/Options.hs index 61df5d5d14f..cf7355ac944 100644 --- a/services/background-worker/src/Wire/BackgroundWorker/Options.hs +++ b/services/background-worker/src/Wire/BackgroundWorker/Options.hs @@ -55,6 +55,7 @@ data Opts = Opts migrateConversationCodes :: !Bool, migrateTeamFeatures :: !Bool, migrateDomainRegistration :: !Bool, + migrateActivationKeys :: !Bool, jobs :: JobConfig, meetingsCleanup :: MeetingsCleanupConfig, backgroundJobs :: BackgroundJobsConfig diff --git a/services/background-worker/src/Wire/PostgresMigrations.hs b/services/background-worker/src/Wire/PostgresMigrations.hs index 604cab0140c..9b068adfa7a 100644 --- a/services/background-worker/src/Wire/PostgresMigrations.hs +++ b/services/background-worker/src/Wire/PostgresMigrations.hs @@ -26,6 +26,7 @@ import Wire.BackgroundWorker.Util import Wire.CodeStore.Migration import Wire.ConversationStore.Migration import Wire.DomainRegistrationStore.Migration +import Wire.ActivationCodeStore.Migration import Wire.Migration (MigrationOptions) import Wire.TeamFeatureStore.Migration @@ -107,3 +108,19 @@ domainRegistration migOpts = do pure $ do Log.info logger $ Log.msg (Log.val "cancelling domain registration migration") cancel migrationLoop + +activationKeys :: MigrationOptions -> AppT IO CleanupAction +activationKeys migOpts = do + cassClient <- asks (.cassandraBrig) + pgPool <- asks (.hasqlPool) + logger <- asks (.logger) + Log.info logger $ Log.msg (Log.val "starting activation keys migration") + count <- register $ counter $ Prometheus.Info "wire_activation_keys_migrated_to_pg" "Number of activation keys migrated to Postgresql" + finished <- register $ counter $ Prometheus.Info "wire_activation_keys_migration_finished" "Whether the activation keys migration to Postgresql is finished successfully" + failed <- register $ counter $ Prometheus.Info "wire_activation_keys_migration_failed" "Whether the activation keys migration to Postgresql has failed" + duration <- register $ vector "outcome" $ histogram (Prometheus.Info "wire_activation_keys_migration_duration_seconds" "Duration of activation key migration attempts") defaultBuckets + migrationLoop <- async . lift $ migrateActivationKeysLoop migOpts cassClient pgPool logger count finished failed duration + Log.info logger $ Log.msg (Log.val "started activation keys migration") + pure $ do + Log.info logger $ Log.msg (Log.val "cancelling activation keys migration") + cancel migrationLoop diff --git a/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs b/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs index 7222120d93a..ea6304ce05d 100644 --- a/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs +++ b/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs @@ -371,7 +371,8 @@ spec = do conversationCodes = CassandraStorage, teamFeatures = CassandraStorage, domainRegistration = CassandraStorage, - user = CassandraStorage + user = CassandraStorage, + activationKeys = CassandraStorage } gundeckEndpoint = undefined brigEndpoint = undefined @@ -435,7 +436,8 @@ spec = do conversationCodes = CassandraStorage, teamFeatures = CassandraStorage, domainRegistration = CassandraStorage, - user = CassandraStorage + user = CassandraStorage, + activationKeys = CassandraStorage } gundeckEndpoint = undefined brigEndpoint = undefined diff --git a/services/background-worker/test/Test/Wire/Util.hs b/services/background-worker/test/Test/Wire/Util.hs index 5d89532bfec..cbea972702b 100644 --- a/services/background-worker/test/Test/Wire/Util.hs +++ b/services/background-worker/test/Test/Wire/Util.hs @@ -50,7 +50,8 @@ testEnv = do conversationCodes = CassandraStorage, teamFeatures = CassandraStorage, domainRegistration = CassandraStorage, - user = CassandraStorage + user = CassandraStorage, + activationKeys = CassandraStorage } statuses <- newIORef mempty backendNotificationMetrics <- mkBackendNotificationMetrics diff --git a/services/brig/brig.integration.yaml b/services/brig/brig.integration.yaml index 8be11f028bd..4935a4bafcd 100644 --- a/services/brig/brig.integration.yaml +++ b/services/brig/brig.integration.yaml @@ -175,6 +175,7 @@ postgresMigration: conversationCodes: postgresql teamFeatures: postgresql domainRegistration: postgresql + activationKeys: postgresql user: postgresql optSettings: diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index 86f9f2e9b2d..c463f9d8589 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -610,7 +610,8 @@ createUserNoVerifySpar :: Member Events r, Member PasswordResetCodeStore r, Member UserStore r, - Member UserKeyStore r + Member UserKeyStore r, + Member ActivationCodeStore r ) => NewUserSpar -> (Handler r) (Either CreateUserSparError SelfProfile) diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index dd5471760b1..ac194b35a99 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -1578,7 +1578,8 @@ activate :: Member Events r, Member PasswordResetCodeStore r, Member UserStore r, - Member UserKeyStore r + Member UserKeyStore r, + Member ActivationCodeStore r ) => Public.ActivationKey -> Public.ActivationCode -> @@ -1595,13 +1596,14 @@ activateKey :: Member UserSubsystem r, Member PasswordResetCodeStore r, Member UserStore r, - Member UserKeyStore r + Member UserKeyStore r, + Member ActivationCodeStore r ) => Public.Activate -> (Handler r) ActivationRespWithStatus activateKey (Public.Activate tgt code dryrun) | dryrun = do - (emailKey, _) <- wrapClientE (API.preverify tgt code) !>> actError + (emailKey, _) <- API.preverify tgt code !>> actError lift $ liftSem $ guardRegisterActivateUserEmailDomain (emailKeyOrig emailKey) pure ActivationRespDryRun | otherwise = do diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index 10c4a949c2b..3b9ba6f1ba8 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -75,7 +75,6 @@ import Brig.Effects.ConnectionStore import Brig.IO.Intra qualified as Intra import Brig.Options hiding (internalEvents) import Brig.User.Auth.Cookie qualified as Auth -import Cassandra hiding (Set) import Control.Error import Control.Lens (preview, to, (^.), _Just) import Control.Monad.Catch @@ -117,7 +116,7 @@ import Wire.API.User.Activation import Wire.API.User.Client import Wire.API.User.RichInfo import Wire.API.UserEvent -import Wire.ActivationCodeStore +import Wire.ActivationCodeStore hiding (mkActivationKey) import Wire.ActivationCodeStore qualified as ActivationCode import Wire.AuthenticationSubsystem (AuthenticationSubsystem, internalLookupPasswordResetCode) import Wire.BackendNotificationQueueAccess @@ -769,7 +768,8 @@ activate :: Member PasswordResetCodeStore r, Member UserSubsystem r, Member UserStore r, - Member UserKeyStore r + Member UserKeyStore r, + Member ActivationCodeStore r ) => ActivationTarget -> ActivationCode -> @@ -785,7 +785,8 @@ activateNoVerifyEmailDomain :: Member PasswordResetCodeStore r, Member UserSubsystem r, Member UserStore r, - Member UserKeyStore r + Member UserKeyStore r, + Member ActivationCodeStore r ) => ActivationTarget -> ActivationCode -> @@ -801,7 +802,8 @@ activateWithCurrency :: Member PasswordResetCodeStore r, Member UserSubsystem r, Member UserStore r, - Member UserKeyStore r + Member UserKeyStore r, + Member ActivationCodeStore r ) => Bool -> ActivationTarget -> @@ -812,13 +814,13 @@ activateWithCurrency :: Maybe Currency.Alpha -> ExceptT ActivationError (AppT r) ActivationResult activateWithCurrency verifyEmailDomain tgt code usr cur = do - key <- wrapClientE $ mkActivationKey tgt + key <- mkActivationKey tgt lift . liftSem . Log.info $ field "activation.key" (toByteString key) . field "activation.code" (toByteString code) . msg (val "Activating") when verifyEmailDomain $ do - (emailKey, _) <- wrapClientE (Data.verifyCode key code) + (emailKey, _) <- Data.verifyCode key code lift $ liftSem $ guardRegisterActivateUserEmailDomain (emailKeyOrig emailKey) event <- Data.activateKey key code usr case event of @@ -835,12 +837,11 @@ activateWithCurrency verifyEmailDomain tgt code usr cur = do for_ tid $ \t -> liftSem $ GalleyAPIAccess.changeTeamStatus t Team.Active cur preverify :: - ( MonadClient m, - MonadReader Env m + ( Member ActivationCodeStore r ) => ActivationTarget -> ActivationCode -> - ExceptT ActivationError m (EmailKey, Maybe UserId) + ExceptT ActivationError (AppT r) (EmailKey, Maybe UserId) preverify tgt code = do key <- mkActivationKey tgt Data.verifyCode key code @@ -958,7 +959,7 @@ sendActivationCode email loc = do when (domain `elem` blocked) $ Polysemy.Error.throw UserSubsystemBlockedDomain -mkActivationKey :: (MonadClient m, MonadReader Env m) => ActivationTarget -> ExceptT ActivationError m ActivationKey +mkActivationKey :: (MonadIO m) => ActivationTarget -> ExceptT ActivationError m ActivationKey mkActivationKey (ActivateKey k) = pure k mkActivationKey (ActivateEmail e) = liftIO $ Data.mkActivationKey (mkEmailKey e) diff --git a/services/brig/src/Brig/CanonicalInterpreter.hs b/services/brig/src/Brig/CanonicalInterpreter.hs index f866fc5a9ca..243d3ce68e2 100644 --- a/services/brig/src/Brig/CanonicalInterpreter.hs +++ b/services/brig/src/Brig/CanonicalInterpreter.hs @@ -54,6 +54,8 @@ import Wire.API.Federation.Error import Wire.API.Team.Collaborator import Wire.ActivationCodeStore (ActivationCodeStore) import Wire.ActivationCodeStore.Cassandra (interpretActivationCodeStoreToCassandra) +import Wire.ActivationCodeStore.DualWrite (interpretActivationCodeStoreToCassandraAndPostgres) +import Wire.ActivationCodeStore.Postgres (interpretActivationCodeStoreToPostgres) import Wire.AppStore import Wire.AppStore.Postgres import Wire.AppSubsystem @@ -219,6 +221,7 @@ type BrigLowerLevelEffects = UserGroupStore, DomainRegistrationStore, DomainVerificationChallengeStore, + ActivationCodeStore, Error AppSubsystemError, Error TeamCollaboratorsError, Error UsageError, @@ -243,7 +246,6 @@ type BrigLowerLevelEffects = SessionStore, PasswordStore, VerificationCodeStore, - ActivationCodeStore, InvitationStore, PropertyStore, SFT, @@ -409,6 +411,10 @@ runBrigToIO e (AppT ma) = do CassandraStorage -> interpretDomainRegistrationStoreToCassandra e.casClient PostgresqlStorage -> interpretDomainRegistrationStoreToPostgres MigrationToPostgresql -> interpretDomainRegistrationStoreToCassandraAndPostgres e.casClient + activationCodeStoreInterpreter = case e.postgresMigration.activationKeys of + CassandraStorage -> interpretActivationCodeStoreToCassandra e.casClient + PostgresqlStorage -> interpretActivationCodeStoreToPostgres + MigrationToPostgresql -> interpretActivationCodeStoreToCassandraAndPostgres e.casClient domainVerificationChallengeStore = case e.postgresMigration.domainRegistration of CassandraStorage -> interpretDomainVerificationChallengeStoreToCassandra e.settings.challengeTTL @@ -465,7 +471,6 @@ runBrigToIO e (AppT ma) = do . interpretSFT e.httpManager . interpretPropertyStoreCassandra e.casClient . interpretInvitationStoreToCassandra e.casClient - . interpretActivationCodeStoreToCassandra e.casClient . interpretVerificationCodeStoreCassandra e.casClient . interpretPasswordStore e.casClient . interpretSessionStoreCassandra e.casClient @@ -490,6 +495,7 @@ runBrigToIO e (AppT ma) = do . mapError postgresUsageErrorToHttpError . mapError teamCollaboratorsSubsystemErrorToHttpError . mapError appSubsystemErrorToHttpError + . activationCodeStoreInterpreter . domainVerificationChallengeStore . domainRegistrationStore . interpretUserGroupStoreToPostgres diff --git a/services/brig/src/Brig/Data/Activation.hs b/services/brig/src/Brig/Data/Activation.hs index 9c9eb1446e1..77095f9e9cd 100644 --- a/services/brig/src/Brig/Data/Activation.hs +++ b/services/brig/src/Brig/Data/Activation.hs @@ -26,19 +26,16 @@ module Brig.Data.Activation ) where -import Brig.App (AppT, liftSem, qualifyLocal, wrapClientE) -import Cassandra +import Brig.App (AppT, liftSem, qualifyLocal) import Control.Error import Data.Id -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.EVP.Digest (digestBS, getDigestByName) import Polysemy import Wire.API.User -import Wire.API.User.Activation import Wire.API.User.Password +import Wire.API.User.Activation +import Wire.ActivationCodeStore import Wire.PasswordResetCodeStore (PasswordResetCodeStore) import Wire.PasswordResetCodeStore qualified as Password import Wire.UserKeyStore @@ -73,14 +70,15 @@ activateKey :: ( Member UserSubsystem r, Member PasswordResetCodeStore r, Member UserStore r, - Member UserKeyStore r + Member UserKeyStore r, + Member ActivationCodeStore r ) => ActivationKey -> ActivationCode -> Maybe UserId -> ExceptT ActivationError (AppT r) (Maybe ActivationEvent) activateKey k c u = do - (emailKey, mUser) <- wrapClientE (verifyCode k c) + (emailKey, mUser) <- verifyCode k c pickUser (emailKey, mUser) >>= activate where pickUser :: (t, Maybe UserId) -> ExceptT ActivationError (AppT r) (t, UserId) @@ -136,52 +134,18 @@ activateKey k c u = do throwE . UserKeyExists . LT.fromStrict $ fromEmail (emailKeyOrig key) --- | Verify an activation code. +-- | Verify an activation code via the 'ActivationCodeStore' effect. verifyCode :: - (MonadClient m) => + (Member ActivationCodeStore r) => ActivationKey -> ActivationCode -> - ExceptT ActivationError m (EmailKey, Maybe UserId) + ExceptT ActivationError (AppT r) (EmailKey, Maybe UserId) verifyCode key code = do - s <- lift . retry x1 . query1 keySelect $ params LocalQuorum (Identity key) - case s of - Just (ttl, Ascii t, k, c, u, r) -> - if - | c == code -> mkScope t k u - | r >= 1 -> countdown (key, t, k, c, u, r - 1, ttl) >> throwE invalidCode - | otherwise -> revoke >> throwE invalidCode - Nothing -> throwE invalidCode - where - mkScope "email" k u = case emailAddressText k of - Just e -> pure (mkEmailKey e, u) - Nothing -> throwE invalidCode - 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 - d <- liftIO $ getDigestByName "SHA256" - d' <- maybe (fail "SHA256 not found") pure d - let bs = digestBS d' (T.encodeUtf8 $ emailKeyUniq k) - pure . ActivationKey $ Ascii.encodeBase64Url bs - -deleteActivationPair :: (MonadClient m) => ActivationKey -> m () -deleteActivationPair = write keyDelete . params LocalQuorum . Identity + mResult <- lift . liftSem $ verifyActivationCode key code + maybe (throwE invalidCode) pure mResult invalidUser :: ActivationError invalidUser = InvalidActivationCodeWrongUser -- "User does not exist." invalidCode :: ActivationError invalidCode = InvalidActivationCodeWrongCode -- "Invalid activation code" - -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 = ?" - -keyDelete :: PrepQuery W (Identity ActivationKey) () -keyDelete = "DELETE FROM activation_keys WHERE key = ?" From 9169072082e7e14c8da4414bf5163b3908f0010a Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Thu, 27 Aug 2026 18:16:04 +0200 Subject: [PATCH 2/2] WPB-22970: address review feedback - rename activation_keys column "user" -> user_id and drop the redundant (key, expires_at) index (PK on key serves the lookup); regenerate postgres-schema.sql - move verification logic out of the ActivationCodeStore effect into a new Wire.ActivationCodeVerificationStore effect over the store; the store keeps persistence only (LookupActivationKey / DecrementActivationRetries / DeleteActivationKey) - add a nightly Arbiter cron job (activation-keys queue) that deletes expired activation key rows from Postgres in bounded batches; new required config background-worker.config.activationKeysCleanup.schedule (default 0 3 * * *) - rewrite the integration test to drive the full lifecycle cassandra -> dual-write -> dual-write+worker -> postgresql, including retry convergence and brute-force exhaustion --- changelog.d/0-release-notes/WPB-22970 | 1 + .../background-worker/configmap.yaml | 4 + charts/wire-server/values.yaml | 4 + .../src/developer/reference/config-options.md | 3 + hack/helm_vars/wire-server/values.yaml.gotmpl | 2 + .../test/Test/Migration/ActivationKeys.hs | 149 +++++++++++------- libs/wire-api/src/Wire/API/Jobs.hs | 61 ++++++- libs/wire-api/src/Wire/API/User/Activation.hs | 6 +- .../Wire/API/Roundtrip/PostgresMarshall.hs | 2 +- .../20260804165620-activation-keys.sql | 5 +- .../src/Wire/ActivationCodeStore.hs | 49 +++--- .../src/Wire/ActivationCodeStore/Cassandra.hs | 51 ++++-- .../src/Wire/ActivationCodeStore/DualWrite.hs | 20 +-- .../src/Wire/ActivationCodeStore/Migration.hs | 2 +- .../src/Wire/ActivationCodeStore/Postgres.hs | 60 ++++--- .../Wire/ActivationCodeVerificationStore.hs | 68 ++++++++ .../ActivationCodeStore/InterpreterSpec.hs | 27 ++++ .../MockInterpreters/ActivationCodeStore.hs | 33 +++- libs/wire-subsystems/wire-subsystems.cabal | 1 + postgres-schema.sql | 60 +++---- .../background-worker/background-worker.cabal | 1 + .../background-worker.integration.yaml | 4 + .../src/Wire/ActivationKeysCleanupWorker.hs | 54 +++++++ .../src/Wire/BackgroundWorker.hs | 2 +- .../src/Wire/BackgroundWorker/Options.hs | 19 ++- .../src/Wire/BackgroundWorker/Workers.hs | 70 ++++++-- .../src/Wire/PostgresMigrations.hs | 2 +- services/brig/src/Brig/API/Internal.hs | 10 +- services/brig/src/Brig/API/Public.hs | 10 +- services/brig/src/Brig/API/User.hs | 19 ++- .../brig/src/Brig/CanonicalInterpreter.hs | 6 + services/brig/src/Brig/Data/Activation.hs | 12 +- 32 files changed, 616 insertions(+), 201 deletions(-) create mode 100644 changelog.d/0-release-notes/WPB-22970 create mode 100644 libs/wire-subsystems/src/Wire/ActivationCodeVerificationStore.hs create mode 100644 services/background-worker/src/Wire/ActivationKeysCleanupWorker.hs diff --git a/changelog.d/0-release-notes/WPB-22970 b/changelog.d/0-release-notes/WPB-22970 new file mode 100644 index 00000000000..eb96c07f686 --- /dev/null +++ b/changelog.d/0-release-notes/WPB-22970 @@ -0,0 +1 @@ +The background worker now cleans up expired activation keys from Postgres via a nightly cron job; new required config flag 'background-worker.config.activationKeysCleanup.schedule' (default '0 3 * * *'). diff --git a/charts/wire-server/templates/background-worker/configmap.yaml b/charts/wire-server/templates/background-worker/configmap.yaml index b340c05139e..c535450c4f4 100644 --- a/charts/wire-server/templates/background-worker/configmap.yaml +++ b/charts/wire-server/templates/background-worker/configmap.yaml @@ -112,6 +112,10 @@ data: workerStaleThreshold: {{ .jobs.workerStaleThreshold }} {{- with .meetingsCleanup }} meetingsCleanup: +{{ toYaml . | indent 6 }} + {{- end }} + {{- with .activationKeysCleanup }} + activationKeysCleanup: {{ toYaml . | indent 6 }} {{- end }} {{- if $.Values.galley.config.postgresMigration }} diff --git a/charts/wire-server/values.yaml b/charts/wire-server/values.yaml index af9208dd5dd..0a64a0655bb 100644 --- a/charts/wire-server/values.yaml +++ b/charts/wire-server/values.yaml @@ -1077,6 +1077,10 @@ background-worker: # Cron schedule for the cleanup job (0 * * * * = every hour) schedule: "0 * * * *" + # Cleanup of expired activation keys in Postgres (nightly) + activationKeysCleanup: + schedule: "0 3 * * *" + secrets: {} podSecurityContext: diff --git a/docs/src/developer/reference/config-options.md b/docs/src/developer/reference/config-options.md index 2a2e71cce2e..87eb137214a 100644 --- a/docs/src/developer/reference/config-options.md +++ b/docs/src/developer/reference/config-options.md @@ -2159,6 +2159,9 @@ background-worker: migrateTeamFeatures: false migrateDomainRegistration: false migrateActivationKeys: false + # Cleanup of expired activation keys in Postgres (nightly) + activationKeysCleanup: + schedule: "0 3 * * *" ``` #### Migration for existing installations diff --git a/hack/helm_vars/wire-server/values.yaml.gotmpl b/hack/helm_vars/wire-server/values.yaml.gotmpl index c29755397a2..3f8a3fa14a0 100644 --- a/hack/helm_vars/wire-server/values.yaml.gotmpl +++ b/hack/helm_vars/wire-server/values.yaml.gotmpl @@ -686,6 +686,8 @@ background-worker: cleanOlderThanHours: 0.0014 batchSize: 100 schedule: "* * * * *" + activationKeysCleanup: + schedule: "* * * * *" # Cassandra clusters used by background-worker cassandra: host: {{ .Values.cassandraHost }} diff --git a/integration/test/Test/Migration/ActivationKeys.hs b/integration/test/Test/Migration/ActivationKeys.hs index 9b5cd5f5a3b..9feaf1b1ffc 100644 --- a/integration/test/Test/Migration/ActivationKeys.hs +++ b/integration/test/Test/Migration/ActivationKeys.hs @@ -1,61 +1,104 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2026 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + module Test.Migration.ActivationKeys where -import Control.Concurrent.Timeout -import Control.Monad.Reader -import SetupHelpers +import qualified API.Brig as Brig +import qualified API.BrigInternal as BrigI +import API.Common (randomEmail) +import Control.Monad.Codensity +import Control.Monad.Reader (asks) import Test.Migration.Util (waitForMigration) import Testlib.Prelude +import Testlib.ResourcePool +import Text.Printf (printf) testActivationKeysMigration :: (HasCallStack) => App () testActivationKeysMigration = do - -- Start in migration-to-postgresql mode with the worker enabled. - withDynamicBackend - ( \domain -> - conf - domain - Backend - { def = \c -> c & #br #~ brigConf domain "migration-to-postgresql", - optSettings = \c -> c & #br #~ brigConf domain "migration-to-postgresql" - } - ) - $ do - -- The background worker copies existing activation_keys rows. - -- Poll until the migration counter reaches 1.0. - waitForMigration "brig" "^wire_activation_keys_migration_finished" - - -- After migration, verify activation still works by registering - -- a new user and activating with the code. - user <- - randomUser - . def - $ \u -> - u - & #email .~ Just "activation-migration@example.com" - & #name .~ "Activation Migration" - - -- Verify the user can be activated (the VerifyActivationCode path - -- now reads from Postgres). - -- (Full activation flow is exercised by the existing integration - -- tests; here we only verify the migration completed.) - pure () - -conf :: String -> DomainTag -> ServiceOverrides -conf domain tag = - ServiceOverrides - { brig = - stdFieldUpdate - "config.postgresMigration.activationKeys" - "postgresql" - domain - tag, - backgroundWorker = bwConf - } + resourcePool <- asks (.resourcePool) + runCodensity (acquireResources 1 resourcePool) $ \[backend] -> do + let domain = backend.berDomain + + -- cassandra: two pending registrations + (k1, c1) <- + runCodensity (startDynamicBackend backend (conf "cassandra" False)) + . const + $ newPendingActivation domain + (k2, c2) <- + runCodensity (startDynamicBackend backend (conf "cassandra" False)) + . const + $ newPendingActivation domain + + -- dual-write, worker off: one wrong attempt on the second registration + -- (retries 3 -> 2, mirrored to Postgres) + runCodensity (startDynamicBackend backend (conf "migration-to-postgresql" False)) . const $ do + wrongActivationCodeFails domain (k2, c2) + + -- dual-write, worker on: copy Cassandra rows; create a fresh pending + -- registration + (k4, c4) <- + runCodensity (startDynamicBackend backend (conf "migration-to-postgresql" True)) . const $ do + waitForMigration domain counterName + newPendingActivation domain + + -- postgresql: pre-migration codes activate from Postgres; retry state + -- converged; exhaustion deletes the row + runCodensity (startDynamicBackend backend (conf "postgresql" False)) . const $ do + -- code created in cassandra mode activates (copied by the worker) + activateCode domain (k1, c1) + -- code that was wrong-attempted once in dual-write activates + -- (mirrored writes kept Postgres in sync) + activateCode domain (k2, c2) + -- brute-force exhaustion: 3 wrong attempts decrement to 0, correct code + -- still works, the 4th wrong attempt deletes the row, correct then fails + forM_ [1 :: Int .. 3] $ \_ -> wrongActivationCodeFails domain (k4, c4) + activateCode domain (k4, c4) + wrongActivationCodeFails domain (k4, c4) + bindResponse (Brig.activate domain k4 c4) $ \resp -> do + resp.status `shouldMatchInt` 404 + resp.json %. "label" `shouldMatch` "invalid-code" where - bwConf domain' tag' = - mconcat - [ stdFieldUpdate "config.migrateActivationKeys" "true" domain' tag', - stdFieldUpdate "config.postgresMigration.activationKeys" "postgresql" domain' tag' - ] - -counterName :: String -counterName = "^wire_activation_keys_migration_finished" + -- create a pending registration for a random email, then fetch its + -- (key, code) via the internal API + newPendingActivation domain = do + email <- randomEmail + Brig.activateSend domain email Nothing >>= assertSuccess + bindResponse (BrigI.getActivationCode domain email) $ \resp -> do + resp.status `shouldMatchInt` 200 + (,) + <$> (resp.json %. "key" >>= asString) + <*> (resp.json %. "code" >>= asString) + + activateCode domain (k, c) = Brig.activate domain k c >>= assertSuccess + + -- wrong code must 404 with 'invalid-code' + wrongActivationCodeFails domain (k, c) = do + let wrong = printf "%06d" $ (read @Int c + 1) `mod` 1000000 + bindResponse (Brig.activate domain k wrong) $ \resp -> do + resp.status `shouldMatchInt` 404 + resp.json %. "label" `shouldMatch` "invalid-code" + conf :: String -> Bool -> ServiceOverrides + conf db runMigration = + def + { brigCfg = setField "postgresMigration.activationKeys" db, + backgroundWorkerCfg = + setField "postgresMigration.activationKeys" db + >=> setField "migrateActivationKeys" runMigration + } + + counterName :: String + counterName = "^wire_activation_keys_migration_finished" diff --git a/libs/wire-api/src/Wire/API/Jobs.hs b/libs/wire-api/src/Wire/API/Jobs.hs index f60d60ca74f..613bb7124df 100644 --- a/libs/wire-api/src/Wire/API/Jobs.hs +++ b/libs/wire-api/src/Wire/API/Jobs.hs @@ -50,6 +50,12 @@ type ConversationsQueueName = "conversations" conversationsQueueName :: Text conversationsQueueName = Text.pack $ symbolVal (Proxy @ConversationsQueueName) +-- | The queue/table for jobs that operate on activation keys. +type ActivationKeysQueueName = "activation-keys" + +activationKeysQueueName :: Text +activationKeysQueueName = Text.pack $ symbolVal (Proxy @ActivationKeysQueueName) + -- | Empty payload because the schedule itself carries all execution context. data MeetingsCleanupJob = MeetingsCleanupJob deriving stock (Eq, Generic, Show) @@ -61,6 +67,17 @@ instance ToSchema MeetingsCleanupJob where instance Arbitrary MeetingsCleanupJob where arbitrary = pure MeetingsCleanupJob +-- | Empty payload because the schedule itself carries all execution context. +data ActivationKeysCleanupJob = ActivationKeysCleanupJob + deriving stock (Eq, Generic, Show) + deriving (ToJSON, FromJSON, S.ToSchema) via (Schema ActivationKeysCleanupJob) + +instance ToSchema ActivationKeysCleanupJob where + schema = object $ pure ActivationKeysCleanupJob + +instance Arbitrary ActivationKeysCleanupJob where + arbitrary = pure ActivationKeysCleanupJob + -- | Payload for adminless deletions. -- Arbiter persists these payloads and workers decode them later, so changes to -- field names or shapes require a coordinated rollout. The origin user is @@ -193,6 +210,47 @@ deriving via (Schema MeetingsJobPayload) instance S.ToSchema MeetingsJobPayload instance Arbitrary MeetingsJobPayload where arbitrary = MeetingsCleanup <$> arbitrary +-- | Payload for the activation-keys queue. +data ActivationKeysJobPayload + = ActivationKeysCleanup ActivationKeysCleanupJob + deriving stock (Eq, Generic, Show) + +data ActivationKeysJobPayloadTag + = ActivationKeysCleanupTag + deriving stock (Eq, Ord, Bounded, Enum, Show, Generic) + deriving (Arbitrary) via GenericUniform ActivationKeysJobPayloadTag + +instance ToSchema ActivationKeysJobPayloadTag where + schema = + enum @Text $ + element "activation_keys_cleanup" ActivationKeysCleanupTag + +makePrisms ''ActivationKeysJobPayload + +activationKeysJobPayloadObjectSchema :: ObjectSchema SwaggerDoc ActivationKeysJobPayload +activationKeysJobPayloadObjectSchema = taggedJobPayloadObjectSchema toTag toSchema + where + toTag :: ActivationKeysJobPayload -> ActivationKeysJobPayloadTag + toTag = + \case + ActivationKeysCleanup {} -> ActivationKeysCleanupTag + + toSchema :: ActivationKeysJobPayloadTag -> ObjectSchema SwaggerDoc ActivationKeysJobPayload + toSchema = \case + ActivationKeysCleanupTag -> tag _ActivationKeysCleanup (field "data" schema) + +instance ToSchema ActivationKeysJobPayload where + schema = object activationKeysJobPayloadObjectSchema + +deriving via (Schema ActivationKeysJobPayload) instance FromJSON ActivationKeysJobPayload + +deriving via (Schema ActivationKeysJobPayload) instance ToJSON ActivationKeysJobPayload + +deriving via (Schema ActivationKeysJobPayload) instance S.ToSchema ActivationKeysJobPayload + +instance Arbitrary ActivationKeysJobPayload where + arbitrary = ActivationKeysCleanup <$> arbitrary + -- | Payload persisted in the conversations queue. Keep the type tags and -- nested data shapes stable when changing job payloads. data ConversationsJobPayload @@ -250,5 +308,6 @@ instance Arbitrary ConversationsJobPayload where -- | Registry for the jobs we expose via Arbiter. type JobRegistry = '[ Queue MeetingsQueueName MeetingsJobPayload, - Queue ConversationsQueueName ConversationsJobPayload + Queue ConversationsQueueName ConversationsJobPayload, + Queue ActivationKeysQueueName ActivationKeysJobPayload ] diff --git a/libs/wire-api/src/Wire/API/User/Activation.hs b/libs/wire-api/src/Wire/API/User/Activation.hs index 5f309446d37..33284d1a6a5 100644 --- a/libs/wire-api/src/Wire/API/User/Activation.hs +++ b/libs/wire-api/src/Wire/API/User/Activation.hs @@ -39,12 +39,12 @@ import Data.Data (Proxy (Proxy)) import Data.OpenApi (ToParamSchema) import Data.OpenApi qualified as S import Data.Schema -import Data.Text.Ascii import Data.Text (pack) -import Wire.API.PostgresMarshall +import Data.Text.Ascii import Imports import Servant (FromHttpApiData (..)) import Wire.API.Locale +import Wire.API.PostgresMarshall import Wire.API.User.Identity import Wire.Arbitrary (Arbitrary, GenericUniform (..)) @@ -77,6 +77,7 @@ instance FromHttpApiData ActivationKey where parseUrlPiece = fmap ActivationKey . parseUrlPiece deriving instance C.Cql ActivationKey + instance PostgresMarshall Text ActivationKey where postgresMarshall = toText . fromActivationKey @@ -107,6 +108,7 @@ deriving instance C.Cql ActivationCode -- | A pair of 'ActivationKey' and 'ActivationCode' as required for activation. type ActivationPair = (ActivationKey, ActivationCode) + instance PostgresMarshall Text ActivationCode where postgresMarshall = toText . fromActivationCode diff --git a/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/PostgresMarshall.hs b/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/PostgresMarshall.hs index 9c9091bd759..5476c15380e 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/PostgresMarshall.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/PostgresMarshall.hs @@ -50,8 +50,8 @@ import Wire.API.Password as Password import Wire.API.Password.Argon2id (Argon2HashedPassword (..), encodeArgon2HashedPassword) import Wire.API.Password.Scrypt (encodeScryptPassword) import Wire.API.PostgresMarshall -import Wire.API.User.Activation import Wire.API.Team.Feature +import Wire.API.User.Activation import Wire.Arbitrary qualified as Arbitrary () tests :: T.TestTree diff --git a/libs/wire-subsystems/postgres-migrations/20260804165620-activation-keys.sql b/libs/wire-subsystems/postgres-migrations/20260804165620-activation-keys.sql index 543e6eaeaeb..7079214cf85 100644 --- a/libs/wire-subsystems/postgres-migrations/20260804165620-activation-keys.sql +++ b/libs/wire-subsystems/postgres-migrations/20260804165620-activation-keys.sql @@ -3,15 +3,12 @@ CREATE TABLE activation_keys ( key_type text NOT NULL, key_text text NOT NULL, code text NOT NULL, - "user" uuid, + user_id uuid, retries int4 NOT NULL, expires_at timestamptz NOT NULL, PRIMARY KEY (key) ); --- index for lookups like `WHERE key = ? AND expires_at > now()` -CREATE INDEX activation_keys_key_expires_at_idx - ON activation_keys (key, expires_at); -- index for cleanup like `DELETE ... WHERE expires_at <= now()` CREATE INDEX activation_keys_expires_at_idx diff --git a/libs/wire-subsystems/src/Wire/ActivationCodeStore.hs b/libs/wire-subsystems/src/Wire/ActivationCodeStore.hs index d3cb61db0a8..47944a09538 100644 --- a/libs/wire-subsystems/src/Wire/ActivationCodeStore.hs +++ b/libs/wire-subsystems/src/Wire/ActivationCodeStore.hs @@ -18,7 +18,7 @@ -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2025 Wire Swiss GmbH +-- Copyright (C) 2026 Wire Swiss GmbH -- -- This program is free software: you can redistribute it and/or modify it under -- the terms of the GNU Affero General Public License as published by the Free @@ -38,11 +38,13 @@ module Wire.ActivationCodeStore lookupActivationCode, newActivationCode, deleteActivationCode, - verifyActivationCode, + lookupActivationKey, + decrementActivationRetries, + deleteActivationKey, + ActivationKeyRow (..), mkActivationKey, genActivationCode, maxAttempts, - mkActivationScope, ) where @@ -57,9 +59,18 @@ import Polysemy import Text.Printf (printf) import Util.Timeout import Wire.API.User.Activation -import Wire.API.User.EmailAddress import Wire.UserKeyStore +-- | Persisted state of one activation key row (no TTL/expiry exposure; +-- expiry handling is a storage-internal concern). +data ActivationKeyRow = ActivationKeyRow + { keyType :: Text, + keyText :: Text, + code :: ActivationCode, + user :: Maybe UserId, + retries :: Int32 + } + data ActivationCodeStore :: Effect where LookupActivationCode :: EmailKey -> @@ -78,15 +89,19 @@ data ActivationCodeStore :: Effect where DeleteActivationCode :: EmailKey -> ActivationCodeStore m () - -- | Verify an activation code against the stored value for the given key. - -- On a match, returns the associated 'EmailKey' and 'UserId'. On a - -- mismatch with remaining retries, decrements the retry counter (preserving - -- the remaining TTL). On exhaustion, deletes the row. Returns 'Nothing' - -- for any non-matching outcome (the caller treats this as an invalid code). - VerifyActivationCode :: + -- | Read the full row for an opaque 'ActivationKey' (unexpired only). + LookupActivationKey :: + ActivationKey -> + ActivationCodeStore m (Maybe ActivationKeyRow) + -- | Decrement the retry counter by one, preserving expiry. + -- No-op when the row is absent or already at 0. + DecrementActivationRetries :: + ActivationKey -> + ActivationCodeStore m () + -- | Delete the row for an opaque 'ActivationKey' (brute-force exhaustion). + DeleteActivationKey :: ActivationKey -> - ActivationCode -> - ActivationCodeStore m (Maybe (EmailKey, Maybe UserId)) + ActivationCodeStore m () makeSem ''ActivationCodeStore @@ -112,13 +127,3 @@ genActivationCode = -- | Maximum number of activation attempts per 'ActivationKey'. maxAttempts :: Int32 maxAttempts = 3 - --- | Reconstruct an activation scope from the stored key type/text. --- Returns 'Just' if the key type is @"email"@ and the text parses as an --- email address; 'Nothing' otherwise. -mkActivationScope :: Text -> Text -> Maybe UserId -> Maybe (EmailKey, Maybe UserId) -mkActivationScope "email" keyText mUser = - case emailAddressText keyText of - Just e -> Just (mkEmailKey e, mUser) - Nothing -> Nothing -mkActivationScope _ _ _ = Nothing diff --git a/libs/wire-subsystems/src/Wire/ActivationCodeStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/ActivationCodeStore/Cassandra.hs index 30ed7d43dfa..4f1390b2610 100644 --- a/libs/wire-subsystems/src/Wire/ActivationCodeStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/ActivationCodeStore/Cassandra.hs @@ -37,7 +37,9 @@ interpretActivationCodeStoreToCassandra casClient = >>= retry x1 . query1 lookupCode . params LocalQuorum . Identity NewActivationCode ek timeout uid -> newActivationCodeImpl ek timeout uid DeleteActivationCode ek -> deleteActivationCodeImpl ek - VerifyActivationCode key code -> verifyActivationCodeImpl key code + LookupActivationKey key -> lookupActivationKeyImpl key + DecrementActivationRetries key -> decrementActivationRetriesImpl key + DeleteActivationKey key -> deleteActivationKeyImpl key where lookupCode :: PrepQuery R (Identity ActivationKey) (Maybe UserId, ActivationCode) lookupCode = @@ -71,26 +73,41 @@ deleteActivationCodeImpl uk = do key <- liftIO $ mkActivationKey uk retry x5 . write keyDelete $ params LocalQuorum (Identity key) --- | Verify an activation code, decrementing retries or revoking on mismatch. --- Returns 'Just' the 'EmailKey' and 'UserId' on a match, 'Nothing' otherwise. -verifyActivationCodeImpl :: +-- | Read the full row for an opaque 'ActivationKey' (unexpired rows only: +-- Cassandra drops expired rows via the TTL, so no expiry filter is needed). +lookupActivationKeyImpl :: (MonadClient m) => ActivationKey -> - ActivationCode -> - m (Maybe (EmailKey, Maybe UserId)) -verifyActivationCodeImpl key code = do + m (Maybe ActivationKeyRow) +lookupActivationKeyImpl key = do + s <- retry x1 . query1 keySelect $ params LocalQuorum (Identity key) + pure $ case s of + Just (_, Ascii t, k, c, u, r) -> Just (ActivationKeyRow t k c u r) + Nothing -> Nothing + +-- | Decrement the retry counter by one, preserving the remaining TTL. +-- (TTL-preserving decrement is a Cassandra persistence detail, which is why +-- it lives in the store.) No-op when the row is absent or already at 0. +decrementActivationRetriesImpl :: + (MonadClient m) => + ActivationKey -> + m () +decrementActivationRetriesImpl key = do s <- retry x1 . query1 keySelect $ params LocalQuorum (Identity key) case s of - Just (ttl, Ascii t, k, c, u, r) -> - if - | c == code -> pure (mkActivationScope t k u) - | r >= 1 -> do - retry x5 . write keyInsert $ params LocalQuorum (key, t, k, c, u, r - 1, ttl) - pure Nothing - | otherwise -> do - write keyDelete $ params LocalQuorum (Identity key) - pure Nothing - Nothing -> pure Nothing + Just (ttl, Ascii t, k, c, u, r) + | r >= 1 -> + retry x5 . write keyInsert $ params LocalQuorum (key, t, k, c, u, r - 1, ttl) + _ -> pure () + +-- | Delete the row for an opaque 'ActivationKey' (brute-force exhaustion). +deleteActivationKeyImpl :: + (MonadClient m) => + ActivationKey -> + m () +deleteActivationKeyImpl key = + retry x5 . write keyDelete $ params LocalQuorum (Identity key) + -------------------------------------------------------------------------------- -- CQL queries diff --git a/libs/wire-subsystems/src/Wire/ActivationCodeStore/DualWrite.hs b/libs/wire-subsystems/src/Wire/ActivationCodeStore/DualWrite.hs index 9a0a2d90af8..1adc47db788 100644 --- a/libs/wire-subsystems/src/Wire/ActivationCodeStore/DualWrite.hs +++ b/libs/wire-subsystems/src/Wire/ActivationCodeStore/DualWrite.hs @@ -23,12 +23,12 @@ where import Cassandra (ClientState) import Imports import Polysemy +import Wire.API.User.Activation +import Wire.API.User.EmailAddress import Wire.ActivationCodeStore import Wire.ActivationCodeStore qualified as ActivationCodeStore import Wire.ActivationCodeStore.Cassandra qualified as Cassandra import Wire.ActivationCodeStore.Postgres qualified as Postgres -import Wire.API.User.Activation -import Wire.API.User.EmailAddress import Wire.Postgres import Wire.UserKeyStore @@ -57,10 +57,12 @@ interpretActivationCodeStoreToCassandraAndPostgres cs = interpret $ \case DeleteActivationCode ek -> do Cassandra.interpretActivationCodeStoreToCassandra cs $ ActivationCodeStore.deleteActivationCode ek Postgres.interpretActivationCodeStoreToPostgres $ ActivationCodeStore.deleteActivationCode ek - VerifyActivationCode key code -> do - -- Cassandra is the source of truth for reads; the Postgres result is - -- discarded for state convergence. A Postgres error fails the operation - -- (consistent with sibling stores). - result <- Cassandra.interpretActivationCodeStoreToCassandra cs $ ActivationCodeStore.verifyActivationCode key code - _ <- Postgres.interpretActivationCodeStoreToPostgres $ ActivationCodeStore.verifyActivationCode key code - pure result + LookupActivationKey key -> + -- Cassandra is the source of truth for reads. + Cassandra.interpretActivationCodeStoreToCassandra cs $ ActivationCodeStore.lookupActivationKey key + DecrementActivationRetries key -> do + Cassandra.interpretActivationCodeStoreToCassandra cs $ ActivationCodeStore.decrementActivationRetries key + Postgres.interpretActivationCodeStoreToPostgres $ ActivationCodeStore.decrementActivationRetries key + DeleteActivationKey key -> do + Cassandra.interpretActivationCodeStoreToCassandra cs $ ActivationCodeStore.deleteActivationKey key + Postgres.interpretActivationCodeStoreToPostgres $ ActivationCodeStore.deleteActivationKey key diff --git a/libs/wire-subsystems/src/Wire/ActivationCodeStore/Migration.hs b/libs/wire-subsystems/src/Wire/ActivationCodeStore/Migration.hs index 5598cd8d652..31efd02ba01 100644 --- a/libs/wire-subsystems/src/Wire/ActivationCodeStore/Migration.hs +++ b/libs/wire-subsystems/src/Wire/ActivationCodeStore/Migration.hs @@ -31,11 +31,11 @@ import Polysemy.Conc (interpretRace) import Polysemy.Conc.Effect.Race hiding (Timeout) import Polysemy.Input import Polysemy.Resource (Resource, resourceToIOFinal) -import Wire.API.User.Activation import Polysemy.State import Polysemy.TinyLog import Prometheus qualified import System.Logger qualified as Log +import Wire.API.User.Activation import Wire.ActivationCodeStore.Postgres qualified as Postgres import Wire.Migration import Wire.Postgres diff --git a/libs/wire-subsystems/src/Wire/ActivationCodeStore/Postgres.hs b/libs/wire-subsystems/src/Wire/ActivationCodeStore/Postgres.hs index 729df3cabe3..ef8a5dfa408 100644 --- a/libs/wire-subsystems/src/Wire/ActivationCodeStore/Postgres.hs +++ b/libs/wire-subsystems/src/Wire/ActivationCodeStore/Postgres.hs @@ -18,12 +18,13 @@ module Wire.ActivationCodeStore.Postgres ( interpretActivationCodeStoreToPostgres, insertActivationKeyRow, + deleteExpiredActivationKeys, ) where import Data.Id (UserId) -import Hasql.TH import Hasql.Statement qualified as Hasql +import Hasql.TH import Imports import Polysemy import Util.Timeout @@ -45,13 +46,40 @@ interpretActivationCodeStoreToPostgres = interpret $ \case DeleteActivationCode ek -> do key <- embed (mkActivationKey ek) runStatement key deleteCode - VerifyActivationCode key code -> verifyActivationCodeImpl key code + LookupActivationKey key -> do + mRow <- runStatement key selectForVerify + pure $ case mRow of + Just (keyType, keyText, code, user, retries) -> Just (ActivationKeyRow keyType keyText code user retries) + Nothing -> Nothing + DecrementActivationRetries key -> runStatement key decrementRetries + DeleteActivationKey key -> runStatement key deleteCode + +-- | Delete all expired activation key rows in bounded batches; returns the +-- total number deleted. +deleteExpiredActivationKeys :: (PGConstraints r) => Sem r Int +deleteExpiredActivationKeys = go 0 + where + batchSize :: Int32 + batchSize = 10000 + go !acc = do + deleted <- length <$> runStatement batchSize deleteExpiredBatch + if deleted >= fromIntegral batchSize then go (acc + deleted) else pure (acc + deleted) + +-- | Delete one batch of expired rows; returns one element per deleted row. +deleteExpiredBatch :: Hasql.Statement Int32 [Int32] +deleteExpiredBatch = + rmapPG + [vectorStatement| + DELETE FROM activation_keys + WHERE key IN (SELECT key FROM activation_keys WHERE expires_at <= now() LIMIT $1 :: int4) + RETURNING 1 :: int4 + |] lookupCode :: Hasql.Statement ActivationKey (Maybe (Maybe UserId, ActivationCode)) lookupCode = dimapPG [maybeStatement| - SELECT "user" :: uuid?, code :: text + SELECT user_id :: uuid?, code :: text FROM activation_keys WHERE key = ($1 :: text) AND expires_at > now() |] @@ -78,41 +106,21 @@ insertActivationKeyRow :: insertActivationKeyRow (key, keyType, keyText, code, mUser, retries, ttlSecs) = runStatement (key, keyType, keyText, code, mUser, retries, ttlSecs) insertWithTtl -verifyActivationCodeImpl :: - (PGConstraints r) => - ActivationKey -> - ActivationCode -> - Sem r (Maybe (EmailKey, Maybe UserId)) -verifyActivationCodeImpl key code = do - mRow <- runStatement key selectForVerify - case mRow of - Just (keyType, keyText, storedCode, mUser, retries) -> - if - | storedCode == code -> pure (mkActivationScope keyType keyText mUser) - | retries >= 1 -> do - runStatement key decrementRetries - pure Nothing - | otherwise -> do - runStatement key deleteCode - pure Nothing - Nothing -> pure Nothing - -------------------------------------------------------------------------------- -- Statements - insertWithTtl :: Hasql.Statement (ActivationKey, Text, Text, ActivationCode, Maybe UserId, Int32, Int32) () insertWithTtl = lmapPG [resultlessStatement| - INSERT INTO activation_keys (key, key_type, key_text, code, "user", retries, expires_at) + INSERT INTO activation_keys (key, key_type, key_text, code, user_id, retries, expires_at) VALUES ($1 :: text, $2 :: text, $3 :: text, $4 :: text, $5 :: uuid?, $6 :: int4, now() + make_interval(secs => $7 :: int4)) ON CONFLICT (key) DO UPDATE SET key_type = ($2 :: text), key_text = ($3 :: text), code = ($4 :: text), - "user" = ($5 :: uuid?), + user_id = ($5 :: uuid?), retries = ($6 :: int4), expires_at = now() + make_interval(secs => $7 :: int4) |] @@ -125,7 +133,7 @@ selectForVerify = SELECT key_type :: text, key_text :: text, code :: text, - "user" :: uuid?, + user_id :: uuid?, retries :: int4 FROM activation_keys WHERE key = ($1 :: text) AND expires_at > now() diff --git a/libs/wire-subsystems/src/Wire/ActivationCodeVerificationStore.hs b/libs/wire-subsystems/src/Wire/ActivationCodeVerificationStore.hs new file mode 100644 index 00000000000..9163926f3b8 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/ActivationCodeVerificationStore.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2026 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Wire.ActivationCodeVerificationStore + ( ActivationCodeVerificationStore (..), + verifyActivationCode, + interpretActivationCodeVerificationStore, + ) +where + +import Data.Id +import Imports +import Polysemy +import Wire.API.User.Activation +import Wire.API.User.EmailAddress +import Wire.ActivationCodeStore +import Wire.UserKeyStore + +data ActivationCodeVerificationStore :: Effect where + VerifyActivationCode :: + ActivationKey -> + ActivationCode -> + ActivationCodeVerificationStore m (Maybe (EmailKey, Maybe UserId)) + +makeSem ''ActivationCodeVerificationStore + +-- | Verify an activation code against the stored value. On a match, +-- return the reconstructed scope. On a mismatch with remaining retries, +-- decrement the counter. On exhaustion, delete the row. 'Nothing' for +-- any non-matching outcome. +interpretActivationCodeVerificationStore :: + (Member ActivationCodeStore r) => + InterpreterFor ActivationCodeVerificationStore r +interpretActivationCodeVerificationStore = interpret $ \case + VerifyActivationCode key code -> do + mRow <- lookupActivationKey key + case mRow of + Nothing -> pure Nothing + Just row + | row.code == code -> pure (mkActivationScope row.keyType row.keyText row.user) + | row.retries >= 1 -> decrementActivationRetries key $> Nothing + | otherwise -> deleteActivationKey key $> Nothing + +-- | Reconstruct an activation scope from the stored key type/text. +-- Returns 'Just' if the key type is @"email"@ and the text parses as an +-- email address; 'Nothing' otherwise. +mkActivationScope :: Text -> Text -> Maybe UserId -> Maybe (EmailKey, Maybe UserId) +mkActivationScope "email" keyText mUser = + case emailAddressText keyText of + Just e -> Just (mkEmailKey e, mUser) + Nothing -> Nothing +mkActivationScope _ _ _ = Nothing diff --git a/libs/wire-subsystems/test/unit/Wire/ActivationCodeStore/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/ActivationCodeStore/InterpreterSpec.hs index 2e166acb9af..8c332166b3d 100644 --- a/libs/wire-subsystems/test/unit/Wire/ActivationCodeStore/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/ActivationCodeStore/InterpreterSpec.hs @@ -19,14 +19,19 @@ module Wire.ActivationCodeStore.InterpreterSpec (spec) where import Data.Default import Data.Map qualified as Map +import Data.Text qualified as Text +import Data.Text.Ascii qualified as Ascii import Imports import Test.Hspec import Test.Hspec.QuickCheck import Test.QuickCheck +import Text.Printf (printf) import Wire.API.User.Activation import Wire.ActivationCodeStore +import Wire.ActivationCodeVerificationStore import Wire.MiniBackend import Wire.MockInterpreters.ActivationCodeStore +import Wire.UserKeyStore spec :: Spec spec = do @@ -55,3 +60,25 @@ spec = do <$> newActivationCode emailKey undefined mUid (ac,) <$> lookupActivationCode emailKey in actCode === c .&&. lookupRes === Just (mUid, c) + prop "a correct code verifies" $ \email config -> + let key = mkEmailKey email + result = + runNoFederationStack def mempty config $ + interpretActivationCodeVerificationStore $ do + a <- newActivationCode key undefined Nothing + verifyActivationCode (a.activationKey) (a.activationCode) + in result === Just (key, Nothing) + prop "a wrong code fails to verify" $ \email config -> + let key = mkEmailKey email + result = + runNoFederationStack def mempty config $ + interpretActivationCodeVerificationStore $ do + a <- newActivationCode key undefined Nothing + verifyActivationCode (a.activationKey) (bumpCode (a.activationCode)) + in result === Nothing + where + -- a code that is (almost surely) different from the given one + bumpCode :: ActivationCode -> ActivationCode + bumpCode c = + ActivationCode . Ascii.unsafeFromText . Text.pack . printf "%06d" $ + (read @Int (Text.unpack (Ascii.toText (fromActivationCode c))) + 1) `mod` 1000000 diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/ActivationCodeStore.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/ActivationCodeStore.hs index ead9bfe9334..58b75114c1e 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/ActivationCodeStore.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/ActivationCodeStore.hs @@ -27,7 +27,12 @@ import Polysemy import Polysemy.State import Text.Printf (printf) import Wire.API.User.Activation -import Wire.ActivationCodeStore (ActivationCodeStore (..)) +import Wire.API.User.EmailAddress +import Wire.ActivationCodeStore + ( ActivationCodeStore (..), + ActivationKeyRow (..), + maxAttempts, + ) import Wire.UserKeyStore emailKeyToCode :: EmailKey -> ActivationCode @@ -39,6 +44,12 @@ emailKeyToCode = . length . show +-- | Derive the 'ActivationKey' exactly as 'NewActivationCode' does below. +-- (Intentionally NOT the SHA-256 derivation of 'mkActivationKey'; the mock +-- only needs internal consistency.) +mockKey :: EmailKey -> ActivationKey +mockKey = ActivationKey . Ascii.encodeBase64Url . T.encodeUtf8 . emailKeyUniq + inMemoryActivationCodeStoreInterpreter :: (Member (State (Map EmailKey (Maybe UserId, ActivationCode))) r) => InterpreterFor ActivationCodeStore r @@ -46,13 +57,19 @@ inMemoryActivationCodeStoreInterpreter = interpret \case LookupActivationCode ek -> gets (!? ek) NewActivationCode ek _ uid -> do - let key = - ActivationKey - . Ascii.encodeBase64Url - . T.encodeUtf8 - . emailKeyUniq - $ ek + let key = mockKey ek c = emailKeyToCode ek modify (insert ek (uid, c)) $> Activation key c DeleteActivationCode ek -> modify (delete ek) - VerifyActivationCode _ _ -> pure Nothing + LookupActivationKey key -> do + m <- get + pure $ + listToMaybe + [ ActivationKeyRow "email" (fromEmail (emailKeyOrig ek)) c uid maxAttempts + | (ek, (uid, c)) <- Data.Map.toList m, + mockKey ek == key + ] + -- The mock keeps no retry count. + DecrementActivationRetries _ -> pure () + DeleteActivationKey key -> + modify (Data.Map.filterWithKey (\ek _ -> mockKey ek /= key)) diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index 793dc975cf8..8a827fe6fe9 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -224,6 +224,7 @@ library Wire.ActivationCodeStore.DualWrite Wire.ActivationCodeStore.Migration Wire.ActivationCodeStore.Postgres + Wire.ActivationCodeVerificationStore Wire.AppStore Wire.AppStore.Postgres Wire.AppSubsystem diff --git a/postgres-schema.sql b/postgres-schema.sql index fde41962148..eab618eb976 100644 --- a/postgres-schema.sql +++ b/postgres-schema.sql @@ -685,34 +685,6 @@ SET default_tablespace = ''; SET default_table_access_method = heap; - --- --- Name: activation_keys; Type: TABLE; Schema: public; Owner: wire-server --- - -CREATE TABLE public.activation_keys ( - key text NOT NULL, - key_type text NOT NULL, - key_text text NOT NULL, - code text NOT NULL, - "user" uuid, - retries integer NOT NULL, - expires_at timestamp with time zone NOT NULL -); - - --- --- Name: activation_keys activation_keys_key_expires_at_idx; Type: INDEX; Schema: public; Owner: wire-server --- - -CREATE INDEX activation_keys_key_expires_at_idx ON public.activation_keys USING btree (key, expires_at); - - --- --- Name: activation_keys activation_keys_expires_at_idx; Type: INDEX; Schema: public; Owner: wire-server --- - -CREATE INDEX activation_keys_expires_at_idx ON public.activation_keys USING btree (expires_at); -- -- Name: arbiter_concurrency; Type: TABLE; Schema: arbiter; Owner: wire-server -- @@ -1270,6 +1242,23 @@ CREATE TABLE arbiter.schema_migrations ( ALTER TABLE arbiter.schema_migrations OWNER TO "wire-server"; +-- +-- Name: activation_keys; Type: TABLE; Schema: public; Owner: wire-server +-- + +CREATE TABLE public.activation_keys ( + key text NOT NULL, + key_type text NOT NULL, + key_text text NOT NULL, + code text NOT NULL, + user_id uuid, + retries integer NOT NULL, + expires_at timestamp with time zone NOT NULL +); + + +ALTER TABLE public.activation_keys OWNER TO "wire-server"; + -- -- Name: apps; Type: TABLE; Schema: public; Owner: wire-server -- @@ -1864,6 +1853,14 @@ ALTER TABLE ONLY arbiter.meetings_results ADD CONSTRAINT meetings_results_pkey PRIMARY KEY (parent_id, child_id); +-- +-- Name: activation_keys activation_keys_pkey; Type: CONSTRAINT; Schema: public; Owner: wire-server +-- + +ALTER TABLE ONLY public.activation_keys + ADD CONSTRAINT activation_keys_pkey PRIMARY KEY (key); + + -- -- Name: apps apps_pkey; Type: CONSTRAINT; Schema: public; Owner: wire-server -- @@ -2315,6 +2312,13 @@ CREATE INDEX idx_meetings_ungrouped_due ON arbiter.meetings USING btree (not_vis CREATE INDEX idx_meetings_ungrouped_ready_ranking ON arbiter.meetings USING btree (priority, id) WHERE ((group_key IS NULL) AND (not_visible_until IS NULL) AND (NOT suspended)); +-- +-- Name: activation_keys_expires_at_idx; Type: INDEX; Schema: public; Owner: wire-server +-- + +CREATE INDEX activation_keys_expires_at_idx ON public.activation_keys USING btree (expires_at); + + -- -- Name: asset_user_id_idx; Type: INDEX; Schema: public; Owner: wire-server -- diff --git a/services/background-worker/background-worker.cabal b/services/background-worker/background-worker.cabal index a43796a4ca7..cb90c0b6232 100644 --- a/services/background-worker/background-worker.cabal +++ b/services/background-worker/background-worker.cabal @@ -12,6 +12,7 @@ build-type: Simple library -- cabal-fmt: expand src exposed-modules: + Wire.ActivationKeysCleanupWorker Wire.AdminlessJobsWorker Wire.BackendNotificationPusher Wire.BackgroundWorker diff --git a/services/background-worker/background-worker.integration.yaml b/services/background-worker/background-worker.integration.yaml index d1fe690bcb0..728dbb217c6 100644 --- a/services/background-worker/background-worker.integration.yaml +++ b/services/background-worker/background-worker.integration.yaml @@ -87,6 +87,10 @@ meetingsCleanup: batchSize: 100 schedule: "* * * * *" # Run every minute +# Cleanup of expired activation keys (nightly; every minute in CI) +activationKeysCleanup: + schedule: "* * * * *" + postgresMigration: conversation: postgresql conversationCodes: postgresql diff --git a/services/background-worker/src/Wire/ActivationKeysCleanupWorker.hs b/services/background-worker/src/Wire/ActivationKeysCleanupWorker.hs new file mode 100644 index 00000000000..9f8cc384a93 --- /dev/null +++ b/services/background-worker/src/Wire/ActivationKeysCleanupWorker.hs @@ -0,0 +1,54 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2026 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Wire.ActivationKeysCleanupWorker + ( runCleanupExpiredActivationKeys, + ) +where + +import Control.Monad.Catch +import Data.Id (RequestId (RequestId)) +import Imports +import System.Logger qualified as Log +import Wire.ActivationCodeStore.Postgres qualified as ActivationCodeStore.Postgres +import Wire.BackgroundWorker.Env (AppT, Env (..)) +import Wire.Effects (runBackgroundWorkerEffects) +import Wire.ExternalAccess.External (initExtEnv) + +newtype ActivationKeysCleanupError = ActivationKeysCleanupError Text + deriving stock (Show) + +instance Exception ActivationKeysCleanupError + +runCleanupExpiredActivationKeys :: AppT IO () +runCleanupExpiredActivationKeys = do + env <- ask + extEnv <- liftIO $ initExtEnv True + result <- + liftIO . runBackgroundWorkerEffects env extEnv (RequestId "activation-keys-cleanup") Nothing $ + ActivationCodeStore.Postgres.deleteExpiredActivationKeys + case result of + Left err -> do + Log.err env.logger $ + Log.msg (Log.val "activation keys cleanup failed") + . Log.field "error" err + -- Throwing makes Arbiter retry the job (maxAttempts 3). + liftIO . throwM $ ActivationKeysCleanupError err + Right n -> + Log.info env.logger $ + Log.msg (Log.val "cleaned up expired activation keys") + . Log.field "deleted" n diff --git a/services/background-worker/src/Wire/BackgroundWorker.hs b/services/background-worker/src/Wire/BackgroundWorker.hs index 126f4a663bc..573bf079409 100644 --- a/services/background-worker/src/Wire/BackgroundWorker.hs +++ b/services/background-worker/src/Wire/BackgroundWorker.hs @@ -92,7 +92,7 @@ run opts galleyOpts = do cleanupJobRunner <- runAppT env $ withNamedLogger "job-runner" $ - Workers.startWorker opts.jobs opts.meetingsCleanup + Workers.startWorker opts.jobs opts.meetingsCleanup opts.activationKeysCleanup let cleanup = void $ runConcurrently $ diff --git a/services/background-worker/src/Wire/BackgroundWorker/Options.hs b/services/background-worker/src/Wire/BackgroundWorker/Options.hs index cf7355ac944..674fdfd4b26 100644 --- a/services/background-worker/src/Wire/BackgroundWorker/Options.hs +++ b/services/background-worker/src/Wire/BackgroundWorker/Options.hs @@ -55,9 +55,10 @@ data Opts = Opts migrateConversationCodes :: !Bool, migrateTeamFeatures :: !Bool, migrateDomainRegistration :: !Bool, - migrateActivationKeys :: !Bool, + migrateActivationKeys :: !Bool, jobs :: JobConfig, meetingsCleanup :: MeetingsCleanupConfig, + activationKeysCleanup :: ActivationKeysCleanupConfig, backgroundJobs :: BackgroundJobsConfig } deriving (Show, Generic) @@ -205,3 +206,19 @@ instance FromJSON MeetingsCleanupConfig where Left e -> parserThrowError [Key "schedule"] $ "Cannot parse cronjob syntax: " <> e Right x -> pure x pure $ MeetingsCleanupConfig {..} + +data ActivationKeysCleanupConfig = ActivationKeysCleanupConfig + { -- | Cron schedule for the expired-activation-keys cleanup job + schedule :: CronSchedule + } + deriving (Show, Generic) + +instance FromJSON ActivationKeysCleanupConfig where + parseJSON = + withObject "ActivationKeysCleanupConfig" $ \o -> do + scheduleRaw <- o .: "schedule" + schedule <- + case parseCronSchedule scheduleRaw of + Left e -> parserThrowError [Key "schedule"] $ "Cannot parse cronjob syntax: " <> e + Right x -> pure x + pure $ ActivationKeysCleanupConfig {..} diff --git a/services/background-worker/src/Wire/BackgroundWorker/Workers.hs b/services/background-worker/src/Wire/BackgroundWorker/Workers.hs index e28c1e92d14..46f91769eb7 100644 --- a/services/background-worker/src/Wire/BackgroundWorker/Workers.hs +++ b/services/background-worker/src/Wire/BackgroundWorker/Workers.hs @@ -36,14 +36,16 @@ import System.IO.Error (userError) import System.Logger qualified as Log import UnliftIO.Async qualified as Async import Wire.API.Jobs +import Wire.ActivationKeysCleanupWorker (runCleanupExpiredActivationKeys) import Wire.AdminlessJobsWorker (runAdminlessDeletionJob, runAdminlessReminderJob, runAdminlessSetupJob) import Wire.BackgroundWorker.Env (AppT, Env (..), runAppT) -import Wire.BackgroundWorker.Options (JobConfig (..), JobJitter (..), MeetingsCleanupConfig (..)) +import Wire.BackgroundWorker.Options (ActivationKeysCleanupConfig (..), JobConfig (..), JobJitter (..), MeetingsCleanupConfig (..)) import Wire.BackgroundWorker.Util import Wire.ExternalAccess.External import Wire.JobSubsystem.ArbiterAdapter import Wire.JobSubsystem.Migrations (runJobMigrations) import Wire.MeetingsCleanupWorker +import Wire.PostgresMigrationOpts (StorageLocation (..), activationKeys) -- | Runtime settings shared by every job runner in a process. -- @@ -68,12 +70,13 @@ data JobWorkerSettings = JobWorkerSettings data JobRunnerConfig registry = JobRunnerConfig { jobRunnerLogger :: Log.Logger, jobRunnerSchedule :: CronSchedule, + jobRunnerActivationKeysSchedule :: CronSchedule, jobRunnerSchemaName :: Text, jobRunnerSettings :: JobWorkerSettings } -startWorker :: JobConfig -> MeetingsCleanupConfig -> AppT IO CleanupAction -startWorker scheduledConfig meetingsCleanupConfig = do +startWorker :: JobConfig -> MeetingsCleanupConfig -> ActivationKeysCleanupConfig -> AppT IO CleanupAction +startWorker scheduledConfig meetingsCleanupConfig activationKeysCleanupConfig = do env <- ask extEnv <- liftIO $ initExtEnv True let cleanupConfig = @@ -100,6 +103,7 @@ startWorker scheduledConfig meetingsCleanupConfig = do JobRunnerConfig { jobRunnerLogger = env.logger, jobRunnerSchedule = meetingsCleanupConfig.schedule, + jobRunnerActivationKeysSchedule = activationKeysCleanupConfig.schedule, jobRunnerSchemaName = ArbiterCore.defaultSchemaName, jobRunnerSettings = workerSettings } :: @@ -119,10 +123,10 @@ toJobJitter = \case -- | Start the worker pools for the job queues. -- -- Each domain queue has its own Arbiter table and worker pool. The meetings --- pool owns the recurring cleanup cron job, while the conversations pool owns --- the adminless one-off jobs. Both pools are supervised by Arbiter's --- multi-pool runner, so they share the process lifecycle without sharing a --- payload type or queue. +-- pool and the activation-keys pool each own a recurring cleanup cron job, +-- while the conversations pool owns the adminless one-off jobs. All pools are +-- supervised by Arbiter's multi-pool runner, so they share the process +-- lifecycle without sharing a payload type or queue. runJobRunner :: Env -> ExtEnv -> @@ -132,8 +136,9 @@ runJobRunner :: runJobRunner env extEnv runnerConfig cleanupConfig = do Log.info runnerConfig.jobRunnerLogger $ Log.msg (Log.val "Starting job worker") - . Log.field "queue_names" (T.intercalate "," [meetingsQueueName, conversationsQueueName]) + . Log.field "queue_names" (T.intercalate "," [meetingsQueueName, conversationsQueueName, activationKeysQueueName]) . Log.field "schedule" (show runnerConfig.jobRunnerSchedule) + . Log.field "activation_keys_schedule" (show runnerConfig.jobRunnerActivationKeysSchedule) let arbiterEnv = mkNewWireArbiterEnv runnerConfig.jobRunnerSchemaName env.hasqlPool meetingsWorkerHandler _conn job = liftIO $ do @@ -154,6 +159,14 @@ runJobRunner env extEnv runnerConfig cleanupConfig = do AdminlessDeletion payload -> runAppT env $ runAdminlessDeletionJob extEnv (mapJobPayload (const payload) job) AdminlessReminder payload -> runAppT env $ runAdminlessReminderJob extEnv (mapJobPayload (const payload) job) + activationKeysWorkerHandler _conn job = liftIO $ do + Log.info runnerConfig.jobRunnerLogger $ + Log.msg (Log.val "Running job") + . Log.field "queue_name" activationKeysQueueName + . Log.field "payload_type" (activationKeysJobPayloadTypeName job.payload) + case job.payload of + ActivationKeysCleanup _ -> runAppT env $ runCleanupExpiredActivationKeys + cronJob <- case ArbiterWorkerCron.cronJob "meetings-cleanup" (serializeCronSchedule runnerConfig.jobRunnerSchedule) @@ -167,6 +180,19 @@ runJobRunner env extEnv runnerConfig cleanupConfig = do Left err -> throwIO . userError $ "Invalid cron schedule for meetings-cleanup: " <> err Right job -> pure job + activationKeysCronJob <- case ArbiterWorkerCron.cronJob + "activation-keys-cleanup" + (serializeCronSchedule runnerConfig.jobRunnerActivationKeysSchedule) + ArbiterWorkerCron.SkipOverlap + ( \_ scheduledFor -> + (ArbiterCore.defaultGroupedJob "activation-keys-cleanup" (ActivationKeysCleanup ActivationKeysCleanupJob)) + { ArbiterCore.notVisibleUntil = Just scheduledFor, + ArbiterCore.maxAttempts = Just 3 + } + ) of + Left err -> throwIO . userError $ "Invalid cron schedule for activation-keys-cleanup: " <> err + Right job -> pure job + meetingsWorkerConfig <- ( ArbiterWorker.transactionalWorkerConfig runnerConfig.jobRunnerSettings.jobWorkerThreads @@ -189,6 +215,17 @@ runJobRunner env extEnv runnerConfig cleanupConfig = do ) ) + activationKeysWorkerConfig <- + ( ArbiterWorker.transactionalWorkerConfig + runnerConfig.jobRunnerSettings.jobWorkerThreads + activationKeysWorkerHandler :: + IO + ( ArbiterWorker.WorkerConfig + (WireArbiter JobRegistry) + ActivationKeysJobPayload + ) + ) + let meetingsWorkerConfig' = applyExplicitDefaults runnerConfig.jobRunnerSettings @@ -199,9 +236,20 @@ runJobRunner env extEnv runnerConfig cleanupConfig = do applyExplicitDefaults runnerConfig.jobRunnerSettings conversationsWorkerConfig + activationKeysWorkerConfig' = + applyExplicitDefaults + runnerConfig.jobRunnerSettings + activationKeysWorkerConfig + { ArbiterWorkerConfig.cronJobs = case activationKeys env.postgresMigration of + -- In cassandra mode the Cassandra TTL already expires rows, + -- so no cleanup cron is registered. + CassandraStorage -> [] + _ -> [activationKeysCronJob] + } workerPools = [ ArbiterWorker.namedWorkerPool meetingsWorkerConfig', - ArbiterWorker.namedWorkerPool conversationsWorkerConfig' + ArbiterWorker.namedWorkerPool conversationsWorkerConfig', + ArbiterWorker.namedWorkerPool activationKeysWorkerConfig' ] workerAsync <- @@ -223,6 +271,10 @@ conversationsJobPayloadTypeName = \case AdminlessDeletion _ -> "adminless_deletion" AdminlessReminder _ -> "adminless_reminder" +activationKeysJobPayloadTypeName :: ActivationKeysJobPayload -> Text +activationKeysJobPayloadTypeName = \case + ActivationKeysCleanup _ -> "activation_keys_cleanup" + mapJobPayload :: (a -> b) -> ArbiterCore.JobRead a -> ArbiterCore.JobRead b mapJobPayload f job = ArbiterCore.Job diff --git a/services/background-worker/src/Wire/PostgresMigrations.hs b/services/background-worker/src/Wire/PostgresMigrations.hs index 9b068adfa7a..0ec117b81a5 100644 --- a/services/background-worker/src/Wire/PostgresMigrations.hs +++ b/services/background-worker/src/Wire/PostgresMigrations.hs @@ -21,12 +21,12 @@ import Imports import Prometheus import System.Logger qualified as Log import UnliftIO +import Wire.ActivationCodeStore.Migration import Wire.BackgroundWorker.Env import Wire.BackgroundWorker.Util import Wire.CodeStore.Migration import Wire.ConversationStore.Migration import Wire.DomainRegistrationStore.Migration -import Wire.ActivationCodeStore.Migration import Wire.Migration (MigrationOptions) import Wire.TeamFeatureStore.Migration diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index c463f9d8589..f722d6fd782 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -89,6 +89,7 @@ import Wire.API.UserGroup.Pagination import Wire.API.UserMap import Wire.ActivationCodeStore (ActivationCodeStore) import Wire.ActivationCodeStore qualified as ActivationCode +import Wire.ActivationCodeVerificationStore (ActivationCodeVerificationStore) import Wire.AppStore (AppStore) import Wire.AppStore qualified as AppStore import Wire.AppSubsystem (AppSubsystem) @@ -174,6 +175,7 @@ servantSitemap :: Member (Polysemy.Error UserSubsystemError) r, Member HashPassword r, Member (Embed IO) r, + Member ActivationCodeVerificationStore r, Member ActivationCodeStore r, Member (Input UserSubsystemConfig) r, Member (Polysemy.Error EnterpriseLoginSubsystemError) r, @@ -251,6 +253,7 @@ accountAPI :: Member HashPassword r, Member InvitationStore r, Member (Embed IO) r, + Member ActivationCodeVerificationStore r, Member ActivationCodeStore r, Member (Polysemy.Error UserSubsystemError) r, Member (Input UserSubsystemConfig) r, @@ -587,6 +590,7 @@ createUserNoVerify :: Member (Input (Local ())) r, Member HashPassword r, Member PasswordResetCodeStore r, + Member ActivationCodeVerificationStore r, Member ActivationCodeStore r, Member RateLimit r ) => @@ -610,8 +614,8 @@ createUserNoVerifySpar :: Member Events r, Member PasswordResetCodeStore r, Member UserStore r, - Member UserKeyStore r, - Member ActivationCodeStore r + Member UserKeyStore r, + Member ActivationCodeVerificationStore r ) => NewUserSpar -> (Handler r) (Either CreateUserSparError SelfProfile) @@ -656,6 +660,7 @@ changeSelfEmailMaybeSendH :: Member UserKeyStore r, Member EmailSubsystem r, Member UserSubsystem r, + Member ActivationCodeVerificationStore r, Member UserStore r, Member ActivationCodeStore r, Member (Polysemy.Error UserSubsystemError) r, @@ -703,6 +708,7 @@ changeSelfEmailMaybeSend :: Member EmailSubsystem r, Member UserSubsystem r, Member UserStore r, + Member ActivationCodeVerificationStore r, Member ActivationCodeStore r, Member (Polysemy.Error UserSubsystemError) r, Member (Input UserSubsystemConfig) r, diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index ac194b35a99..e57b4f243ec 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -148,6 +148,7 @@ import Wire.API.UserGroup.Pagination import Wire.API.UserMap qualified as Public import Wire.API.Wrapped qualified as Public import Wire.ActivationCodeStore (ActivationCodeStore) +import Wire.ActivationCodeVerificationStore (ActivationCodeVerificationStore) import Wire.AppSubsystem (AppSubsystem) import Wire.AppSubsystem qualified as AppSubsystem import Wire.AuthenticationSubsystem as AuthenticationSubsystem @@ -380,6 +381,7 @@ servantSitemap :: Member SFT r, Member TinyLog r, Member UserKeyStore r, + Member ActivationCodeVerificationStore r, Member ActivationCodeStore r, Member UserStore r, Member (Input InvitationUrlTemplates) r, @@ -912,6 +914,7 @@ createUser :: Member UserSubsystem r, Member PasswordResetCodeStore r, Member HashPassword r, + Member ActivationCodeVerificationStore r, Member ActivationCodeStore r, Member RateLimit r, Member AuthenticationSubsystem r @@ -935,6 +938,7 @@ createUserV16 :: Member UserSubsystem r, Member PasswordResetCodeStore r, Member HashPassword r, + Member ActivationCodeVerificationStore r, Member ActivationCodeStore r, Member RateLimit r, Member AuthenticationSubsystem r @@ -1579,7 +1583,7 @@ activate :: Member PasswordResetCodeStore r, Member UserStore r, Member UserKeyStore r, - Member ActivationCodeStore r + Member ActivationCodeVerificationStore r ) => Public.ActivationKey -> Public.ActivationCode -> @@ -1596,8 +1600,8 @@ activateKey :: Member UserSubsystem r, Member PasswordResetCodeStore r, Member UserStore r, - Member UserKeyStore r, - Member ActivationCodeStore r + Member UserKeyStore r, + Member ActivationCodeVerificationStore r ) => Public.Activate -> (Handler r) ActivationRespWithStatus diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index 3b9ba6f1ba8..0212d5ea624 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -118,6 +118,7 @@ import Wire.API.User.RichInfo import Wire.API.UserEvent import Wire.ActivationCodeStore hiding (mkActivationKey) import Wire.ActivationCodeStore qualified as ActivationCode +import Wire.ActivationCodeVerificationStore (ActivationCodeVerificationStore) import Wire.AuthenticationSubsystem (AuthenticationSubsystem, internalLookupPasswordResetCode) import Wire.BackendNotificationQueueAccess import Wire.BlockListStore as BlockListStore @@ -365,6 +366,7 @@ createUser :: Member PasswordResetCodeStore r, Member HashPassword r, Member InvitationStore r, + Member ActivationCodeVerificationStore r, Member ActivationCodeStore r, Member RateLimit r ) => @@ -390,6 +392,7 @@ createUserV16 :: Member PasswordResetCodeStore r, Member HashPassword r, Member InvitationStore r, + Member ActivationCodeVerificationStore r, Member ActivationCodeStore r, Member RateLimit r ) => @@ -417,6 +420,7 @@ createUserWith :: Member PasswordResetCodeStore r, Member HashPassword r, Member InvitationStore r, + Member ActivationCodeVerificationStore r, Member ActivationCodeStore r, Member RateLimit r ) => @@ -768,8 +772,8 @@ activate :: Member PasswordResetCodeStore r, Member UserSubsystem r, Member UserStore r, - Member UserKeyStore r, - Member ActivationCodeStore r + Member UserKeyStore r, + Member ActivationCodeVerificationStore r ) => ActivationTarget -> ActivationCode -> @@ -785,8 +789,8 @@ activateNoVerifyEmailDomain :: Member PasswordResetCodeStore r, Member UserSubsystem r, Member UserStore r, - Member UserKeyStore r, - Member ActivationCodeStore r + Member UserKeyStore r, + Member ActivationCodeVerificationStore r ) => ActivationTarget -> ActivationCode -> @@ -802,8 +806,8 @@ activateWithCurrency :: Member PasswordResetCodeStore r, Member UserSubsystem r, Member UserStore r, - Member UserKeyStore r, - Member ActivationCodeStore r + Member UserKeyStore r, + Member ActivationCodeVerificationStore r ) => Bool -> ActivationTarget -> @@ -837,8 +841,7 @@ activateWithCurrency verifyEmailDomain tgt code usr cur = do for_ tid $ \t -> liftSem $ GalleyAPIAccess.changeTeamStatus t Team.Active cur preverify :: - ( Member ActivationCodeStore r - ) => + (Member ActivationCodeVerificationStore r) => ActivationTarget -> ActivationCode -> ExceptT ActivationError (AppT r) (EmailKey, Maybe UserId) diff --git a/services/brig/src/Brig/CanonicalInterpreter.hs b/services/brig/src/Brig/CanonicalInterpreter.hs index 243d3ce68e2..62781b2ec69 100644 --- a/services/brig/src/Brig/CanonicalInterpreter.hs +++ b/services/brig/src/Brig/CanonicalInterpreter.hs @@ -56,6 +56,10 @@ import Wire.ActivationCodeStore (ActivationCodeStore) import Wire.ActivationCodeStore.Cassandra (interpretActivationCodeStoreToCassandra) import Wire.ActivationCodeStore.DualWrite (interpretActivationCodeStoreToCassandraAndPostgres) import Wire.ActivationCodeStore.Postgres (interpretActivationCodeStoreToPostgres) +import Wire.ActivationCodeVerificationStore + ( ActivationCodeVerificationStore, + interpretActivationCodeVerificationStore, + ) import Wire.AppStore import Wire.AppStore.Postgres import Wire.AppSubsystem @@ -221,6 +225,7 @@ type BrigLowerLevelEffects = UserGroupStore, DomainRegistrationStore, DomainVerificationChallengeStore, + ActivationCodeVerificationStore, ActivationCodeStore, Error AppSubsystemError, Error TeamCollaboratorsError, @@ -496,6 +501,7 @@ runBrigToIO e (AppT ma) = do . mapError teamCollaboratorsSubsystemErrorToHttpError . mapError appSubsystemErrorToHttpError . activationCodeStoreInterpreter + . interpretActivationCodeVerificationStore . domainVerificationChallengeStore . domainRegistrationStore . interpretUserGroupStoreToPostgres diff --git a/services/brig/src/Brig/Data/Activation.hs b/services/brig/src/Brig/Data/Activation.hs index 77095f9e9cd..e1f92e63718 100644 --- a/services/brig/src/Brig/Data/Activation.hs +++ b/services/brig/src/Brig/Data/Activation.hs @@ -33,9 +33,13 @@ import Data.Text.Lazy qualified as LT import Imports import Polysemy import Wire.API.User -import Wire.API.User.Password import Wire.API.User.Activation +import Wire.API.User.Password import Wire.ActivationCodeStore +import Wire.ActivationCodeVerificationStore + ( ActivationCodeVerificationStore, + verifyActivationCode, + ) import Wire.PasswordResetCodeStore (PasswordResetCodeStore) import Wire.PasswordResetCodeStore qualified as Password import Wire.UserKeyStore @@ -71,7 +75,7 @@ activateKey :: Member PasswordResetCodeStore r, Member UserStore r, Member UserKeyStore r, - Member ActivationCodeStore r + Member ActivationCodeVerificationStore r ) => ActivationKey -> ActivationCode -> @@ -134,9 +138,9 @@ activateKey k c u = do throwE . UserKeyExists . LT.fromStrict $ fromEmail (emailKeyOrig key) --- | Verify an activation code via the 'ActivationCodeStore' effect. +-- | Verify an activation code via the 'ActivationCodeVerificationStore' effect. verifyCode :: - (Member ActivationCodeStore r) => + (Member ActivationCodeVerificationStore r) => ActivationKey -> ActivationCode -> ExceptT ActivationError (AppT r) (EmailKey, Maybe UserId)