diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,6 +4,32 @@ [PVP](https://pvp.haskell.org/) and is versioned independently of the other Shōmei packages. +## 0.3.0.0 — 2026-11-05 + +- **Breaking:** internal dependency bounds follow the 0.3 API series; migration dependencies require `shomei-migrations ^>=0.2.0.1`. + +- **Upgrade:** migration 0043 repairs legacy machine/delegated provenance and makes omitted SQL provenance default to machine. Missing kinds fail closed on read; authorize also refuses a stored actor. Stop old issuers before migration; affected backing-account humans can establish a new interactive session by logging in. See deployment.md. + +- **Breaking:** user and credential interpreters require `Clock`; password change/reset stamp credential `updated_at` with the workflow transaction timestamp. Repeated session revocation preserves its original timestamp. Migration 0042 adds measured user-list and per-user audit indexes. + +- **Breaking:** PostgreSQL assembly uses the managed `Shomei.Persistence.Pool.Postgres.Pool` and its `UsageError`, `use` and `release` operations. Interrupted/failed sessions discard their connection and restore capacity; the external pool dependency is removed. + +- Machine and delegated mints atomically enforce the configurable active principal ceiling (default 1000), preserving existing sessions after lowering the cap. Expiry frees capacity; finite sweeper retention bounds ordinary history by issuance rate and retention. + +- **Breaking:** database transactions use the bounded statement wrapper; session bulk revocation returns winning IDs and the audited unit of work returns a count. Administrative session HTTP listing returns a keyset page (default 50, maximum 200). Server transaction limits default to three attempts/five seconds. + +- Enforce finite new-write identity, display-name, passkey-label and role/scope budgets; preserve legacy identity authentication and snapshots. Login passwords over 256 code points fail before credential proof accounting. PostgreSQL adds migration 0039; see `docs/user/input-limits.md`. + +- **Breaking:** passkey enrollment locks the account, counts, and inserts in one transaction; + callers pass a 1–100 ceiling and handle `PasskeyLimitReached`. + +- **Upgrade required:** TOTP envelopes bind both row identifiers; normal reads reject legacy + ciphertext. Apply migration 0038 and run the offline converter before starting new hosts. +- Add keyless envelope-version inspection and resumable conversion in batches of 100. +- Require `hasql-transaction >=1.2.1` for the explicit no-retry transaction primitive. + +- The session store persists and reads `shomei_sessions.remembered`. + ## 0.2.0.0 — 2026-08-27 - **Breaking:** requires `shomei-core ^>=0.2.0.0` and `shomei-migrations ^>=0.2.0.0`. diff --git a/shomei-postgres.cabal b/shomei-postgres.cabal --- a/shomei-postgres.cabal +++ b/shomei-postgres.cabal @@ -1,6 +1,6 @@ -cabal-version: 3.0 -name: shomei-postgres -version: 0.2.0.0 +cabal-version: 3.0 +name: shomei-postgres +version: 0.3.0.0 synopsis: PostgreSQL adapters for Shōmei's store/publisher/signing-key ports @@ -13,29 +13,34 @@ token hashing (crypton, ram), connection pooling, and a transactional unit-of-work. The schema itself lives in shomei-migrations. -homepage: https://github.com/shinzui/shomei -bug-reports: https://github.com/shinzui/shomei/issues -license: MIT -license-file: LICENSE -author: Nadeem Bitar -maintainer: nadeem@gmail.com -copyright: 2026 Nadeem Bitar -category: Database, Security -build-type: Simple -tested-with: GHC ==9.12.4 +homepage: https://github.com/shinzui/shomei +bug-reports: https://github.com/shinzui/shomei/issues +license: MIT +license-file: LICENSE +author: Nadeem Bitar +maintainer: nadeem@gmail.com +copyright: 2026 Nadeem Bitar +category: Database, Security +build-type: Simple +tested-with: ghc ==9.12.4 extra-doc-files: CHANGELOG.md source-repository head - type: git + type: git location: https://github.com/shinzui/shomei.git common warnings ghc-options: - -Wall -Wcompat -Widentities -Wincomplete-record-updates - -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints + -Wall + -Wcompat + -Widentities + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wpartial-fields + -Wredundant-constraints common shared - default-language: GHC2024 + default-language: GHC2024 default-extensions: BlockArguments DataKinds @@ -53,8 +58,8 @@ TypeFamilies library - import: warnings, shared - hs-source-dirs: src + import: warnings, shared + hs-source-dirs: src exposed-modules: Shomei.Account.Credential.Postgres Shomei.Account.Password.Hash.Postgres @@ -74,6 +79,7 @@ Shomei.Persistence.Database.Postgres Shomei.Persistence.Maintenance.Postgres Shomei.Persistence.Pool.Postgres + Shomei.Persistence.Transaction.Postgres Shomei.ServiceAccount.Postgres Shomei.Session.LoginAttempt.Postgres Shomei.Session.Postgres @@ -83,44 +89,49 @@ Shomei.Time.Postgres build-depends: - , aeson >=2.1 && <2.3 - , base >=4.18 && <5 - , bytestring >=0.11 && <0.13 - , containers >=0.6 && <0.9 - , contravariant-extras >=0.3 && <0.4 - , crypton >=1.1.0 && <1.2 - , effectful >=2.5 && <2.8 - , effectful-core >=2.5 && <2.8 - , hasql >=1.10 && <1.11 - , hasql-pool >=1.2 && <1.5 - , hasql-transaction >=1.0 && <1.3 - , ram >=0.22 && <0.23 - , shomei-core ^>=0.2.0.0 - , stm >=2.5 && <2.6 - , text >=2.0 && <2.2 - , time >=1.12 && <1.15 - , transformers >=0.6 && <0.7 - , uuid >=1.3 && <1.4 + aeson >=2.1 && <2.3, + base >=4.18 && <5, + bytestring >=0.11 && <0.13, + containers >=0.6 && <0.9, + contravariant-extras >=0.3 && <0.4, + crypton >=1.1.0 && <1.2, + effectful >=2.5 && <2.8, + effectful-core >=2.5 && <2.8, + hasql >=1.10 && <1.11, + hasql-transaction >=1.2.1 && <1.3, + ram >=0.22 && <0.23, + shomei-core ^>=0.3.0.0, + stm >=2.5 && <2.6, + text >=2.0 && <2.2, + time >=1.12 && <1.15, + transformers >=0.6 && <0.7, + uuid >=1.3 && <1.4, test-suite shomei-postgres-test - import: warnings, shared - type: exitcode-stdio-1.0 - main-is: Main.hs + import: warnings, shared + type: exitcode-stdio-1.0 + main-is: Main.hs hs-source-dirs: test - ghc-options: -threaded -rtsopts -with-rtsopts=-N + ghc-options: + -threaded + -rtsopts + -with-rtsopts=-N + build-depends: - , base >=4.18 && <5 - , bytestring >=0.11 && <0.13 - , containers >=0.6 && <0.9 - , effectful >=2.5 && <2.8 - , effectful-core >=2.5 && <2.8 - , hasql >=1.10 && <1.11 - , hasql-pool >=1.4 && <1.5 - , shomei-core ^>=0.2.0.0 - , shomei-migrations:test-support ^>=0.2.0.0 - , shomei-postgres ^>=0.2.0.0 - , tasty >=1.4 && <1.6 - , tasty-hunit >=0.10 && <0.11 - , text >=2.0 && <2.2 - , time >=1.12 && <1.15 - , uuid >=1.3 && <1.4 + base >=4.18 && <5, + bytestring >=0.11 && <0.13, + containers >=0.6 && <0.9, + crypton >=1.1.0 && <1.2, + effectful >=2.5 && <2.8, + effectful-core >=2.5 && <2.8, + hasql >=1.10 && <1.11, + hasql-transaction >=1.2.1 && <1.3, + ram >=0.22 && <0.23, + shomei-core ^>=0.3.0.0, + shomei-migrations:test-support ^>=0.2.0.1, + shomei-postgres ^>=0.3.0.0, + tasty >=1.4 && <1.6, + tasty-hunit >=0.10 && <0.11, + text >=2.0 && <2.2, + time >=1.12 && <1.15, + uuid >=1.3 && <1.4, diff --git a/src/Shomei/Account/Credential/Postgres.hs b/src/Shomei/Account/Credential/Postgres.hs --- a/src/Shomei/Account/Credential/Postgres.hs +++ b/src/Shomei/Account/Credential/Postgres.hs @@ -10,7 +10,7 @@ ) where -import Contravariant.Extras (contrazip2, contrazip7) +import Contravariant.Extras (contrazip3, contrazip7) import Data.UUID (UUID) import Effectful (Eff, IOE, (:>)) import Effectful.Dispatch.Dynamic (interpret_) @@ -29,17 +29,18 @@ import Shomei.Persistence.Codec.Postgres (loginIdFromDb, maybeEmailFromDb) import Shomei.Persistence.Database.Postgres (Database, postgresUnavailable, postgresWriteError, runSession) import Shomei.Prelude +import Shomei.Time.Store (Clock, now) type CredRow = (UUID, UUID, Text, Maybe Text, Text, UTCTime, UTCTime) runCredentialStorePostgres :: - (Database :> es, IOE :> es, Error AuthError :> es) => + (Database :> es, IOE :> es, Error AuthError :> es, Clock :> es) => Eff (CredentialStore : es) a -> Eff es a runCredentialStorePostgres = interpret_ \case CreatePasswordCredential uid loginId mEmail pwHash -> do cid <- genCredentialId - ts <- liftIO getCurrentTime + ts <- now let row = (credentialIdToUUID cid, userIdToUUID uid, loginIdText loginId, emailText <$> mEmail, passwordHashText pwHash, ts, ts) res <- runSession (Session.statement row insertCredentialStmt) either (throwError . postgresWriteError identityConflict) (const (pure (mkCredential cid uid loginId mEmail pwHash ts))) res @@ -52,7 +53,8 @@ row <- either dbFail pure res traverse rebuild row UpdatePasswordHash uid pwHash -> do - res <- runSession (Session.statement (userIdToUUID uid, passwordHashText pwHash) updatePasswordHashStmt) + ts <- now + res <- runSession (Session.statement (userIdToUUID uid, passwordHashText pwHash, ts) updatePasswordHashStmt) either dbFail (const (pure ())) res where dbFail = throwError . postgresUnavailable @@ -148,13 +150,13 @@ (E.param (E.nonNullable E.text)) (D.rowMaybe credRowDecoder) -updatePasswordHashStmt :: Statement (UUID, Text) () +updatePasswordHashStmt :: Statement (UUID, Text, UTCTime) () updatePasswordHashStmt = preparable """ UPDATE shomei.shomei_password_credentials - SET password_hash = $2 + SET password_hash = $2, updated_at = $3 WHERE user_id = $1 """ - (contrazip2 (E.param (E.nonNullable E.uuid)) (E.param (E.nonNullable E.text))) + (contrazip3 (E.param (E.nonNullable E.uuid)) (E.param (E.nonNullable E.text)) (E.param (E.nonNullable E.timestamptz))) D.noResult diff --git a/src/Shomei/Account/User/Postgres.hs b/src/Shomei/Account/User/Postgres.hs --- a/src/Shomei/Account/User/Postgres.hs +++ b/src/Shomei/Account/User/Postgres.hs @@ -17,26 +17,28 @@ import Hasql.Statement (Statement, preparable) import Shomei.Account.Email.Domain (emailText) import Shomei.Account.LoginId.Domain (loginIdText) -import Shomei.Account.User.Domain (NewUser (..), User (..), UserStatus (UserActive)) +import Shomei.Account.User.Domain (NewUser (..), User (..), UserStatus (UserActive), validateNewUser) import Shomei.Account.User.Store (UserCursor (..), UserListQuery (..), UserStore (..), clampUserLimit) import Shomei.Error (AuthError (..)) import Shomei.Id (UserId, genUserId, userIdFromUUID, userIdToUUID) import Shomei.Persistence.Codec.Postgres (loginIdFromDb, maybeEmailFromDb, userStatusFromText, userStatusToText) import Shomei.Persistence.Database.Postgres (Database, postgresUnavailable, postgresWriteError, runSession) import Shomei.Prelude +import Shomei.Time.Store (Clock, now) type InsertUserRow = (UUID, Text, Maybe Text, Maybe Text, Text, UTCTime, UTCTime) type UserRow = (UUID, Text, Maybe Text, Maybe Text, Text, Maybe UTCTime, UTCTime, UTCTime) runUserStorePostgres :: - (Database :> es, IOE :> es, Error AuthError :> es) => + (Database :> es, IOE :> es, Error AuthError :> es, Clock :> es) => Eff (UserStore : es) a -> Eff es a runUserStorePostgres = interpret_ \case CreateUser nu -> do + either throwError pure (validateNewUser nu) uid <- genUserId - ts <- liftIO getCurrentTime + ts <- now let row = (userIdToUUID uid, loginIdText nu.loginId, emailText <$> nu.email, nu.displayName, userStatusToText UserActive, ts, ts) res <- runSession (Session.statement row insertUserStmt) either (throwError . postgresWriteError identityConflict) (const (pure (mkUser uid nu ts))) res diff --git a/src/Shomei/Mfa/Totp/Postgres.hs b/src/Shomei/Mfa/Totp/Postgres.hs --- a/src/Shomei/Mfa/Totp/Postgres.hs +++ b/src/Shomei/Mfa/Totp/Postgres.hs @@ -6,19 +6,20 @@ -- The port ('Shomei.Mfa.Totp.Store') speaks in raw 'Shomei.Mfa.Totp.Algorithm.TotpSecret's; -- encryption lives here so the workflows stay pure policy over ports and the in-memory tests -- exercise TOTP logic rather than AES (Decision Log). Each write draws a fresh 96-bit nonce and --- stores @nonce || ciphertext || tag@ in one @bytea@; the key comes from the server 'Env' +-- stores @marker || nonce || ciphertext || tag@ in one @bytea@; the key comes from the server 'Env' -- (@SHOMEI_TOTP_ENCRYPTION_KEY@), never from the database, so a dump alone yields no usable --- secret. This follows the ChaChaPoly1305 AEAD shape in --- @shomei-jwt/src/Shomei/Jwt/KeyProtection.hs@, adapted to AES-256-GCM. +-- secret. The authenticated context binds the format, credential and user identifiers. module Shomei.Mfa.Totp.Postgres ( runTotpCredentialStorePostgres, TotpEncryptionKey, totpEncryptionKeyFromBytes, totpEncryptionKeyFromBase64, + checkTotpEnvelopeVersions, + migrateTotpEnvelopeBatch, ) where -import Contravariant.Extras (contrazip2, contrazip4) +import Contravariant.Extras (contrazip2, contrazip4, contrazip5) import Crypto.Cipher.AES (AES256) import Crypto.Cipher.Types ( AEAD, @@ -35,7 +36,8 @@ import Data.ByteArray.Encoding (Base (Base64), convertFromBase) import Data.ByteString (ByteString) import Data.ByteString qualified as BS -import Data.Int (Int64) +import Data.Int (Int16, Int64) +import Data.Maybe (catMaybes) import Data.Text qualified as Text import Data.Text.Encoding qualified as TE import Data.UUID (UUID) @@ -46,9 +48,12 @@ import Hasql.Encoders qualified as E import Hasql.Session qualified as Session import Hasql.Statement (Statement, preparable) +import Hasql.Transaction qualified as Tx +import Hasql.Transaction.Sessions qualified as TxSession import Shomei.Error (AuthError (..)) import Shomei.Id - ( totpCredentialIdFromUUID, + ( idText, + totpCredentialIdFromUUID, totpCredentialIdToUUID, userIdFromUUID, userIdToUUID, @@ -58,6 +63,7 @@ import Shomei.Mfa.Totp.Store (TotpCredentialStore (..)) import Shomei.Persistence.Codec.Postgres (tshow) import Shomei.Persistence.Database.Postgres (Database, postgresUnavailable, runSession) +import Shomei.Persistence.Pool.Postgres qualified as Pool import Shomei.Prelude -- | The AES-256-GCM key that encrypts stored TOTP secrets. Abstract: no 'Show', no JSON, so a @@ -88,34 +94,52 @@ cipher <- cipherInit key aeadInit AEAD_GCM cipher nonce --- | Encrypt raw secret bytes: draw a 96-bit nonce, and lay out @nonce || ciphertext || tag@. -encryptSecret :: TotpEncryptionKey -> ByteString -> IO ByteString -encryptSecret (TotpEncryptionKey key) plaintext = do +-- | Explicit envelope marker; the schema version is authoritative, never sniffed from a nonce. +envelopeMarker :: ByteString +envelopeMarker = "STOTP\x01" + +-- | Both canonical TypeIDs have fixed width (31 ASCII bytes). The domain/version and +-- ordered credential/user identities make concatenation unambiguous. +associatedData :: UUID -> UUID -> ByteString +associatedData tcid uid = + "shomei:totp:aes256gcm:v1:" + <> TE.encodeUtf8 (idText (totpCredentialIdFromUUID tcid)) + <> TE.encodeUtf8 (idText (userIdFromUUID uid)) + +encryptSecret :: TotpEncryptionKey -> UUID -> UUID -> ByteString -> IO ByteString +encryptSecret (TotpEncryptionKey key) tcid uid plaintext = do nonce <- getRandomBytes 12 :: IO ByteString case aeadState key nonce of CryptoFailed e -> ioError (userError ("shomei: cannot initialize TOTP encryption: " <> show e)) CryptoPassed st -> do - let (tag, ciphertext) = aeadSimpleEncrypt st (BS.empty :: ByteString) plaintext 16 - pure (nonce <> ciphertext <> BA.convert (unAuthTag tag)) + let (tag, ciphertext) = aeadSimpleEncrypt st (associatedData tcid uid) plaintext 16 + pure (envelopeMarker <> nonce <> ciphertext <> BA.convert (unAuthTag tag)) -- | Recover raw secret bytes from a stored @secret_enc@ blob. A wrong key, a tampered -- ciphertext, or a truncated blob all fail the same way (one indistinguishable error). -decryptSecret :: TotpEncryptionKey -> ByteString -> Either Text ByteString -decryptSecret (TotpEncryptionKey key) blob - | BS.length blob < 12 + 16 = Left "TOTP secret ciphertext is shorter than nonce + tag" +decryptSecret :: TotpEncryptionKey -> UUID -> UUID -> Int16 -> ByteString -> Either Text ByteString +decryptSecret key tcid uid version blob + | version /= 1 = Left "TOTP envelope requires offline conversion" + | not (envelopeMarker `BS.isPrefixOf` blob) = Left "TOTP secret failed authentication" + | otherwise = decryptPayload key (associatedData tcid uid) (BS.drop (BS.length envelopeMarker) blob) + +-- Legacy decoding is reachable only from the explicit offline converter below. +decryptPayload :: TotpEncryptionKey -> ByteString -> ByteString -> Either Text ByteString +decryptPayload (TotpEncryptionKey key) aad blob + | BS.length blob < 12 + 16 = Left "TOTP secret failed authentication" | otherwise = let (nonce, rest) = BS.splitAt 12 blob (ciphertext, tagBytes) = BS.splitAt (BS.length rest - 16) rest in case aeadState key nonce of CryptoFailed _ -> Left "TOTP secret: bad AES-GCM initialization" CryptoPassed st -> - case aeadSimpleDecrypt st (BS.empty :: ByteString) ciphertext (AuthTag (BA.convert tagBytes)) of + case aeadSimpleDecrypt st aad ciphertext (AuthTag (BA.convert tagBytes)) of Just pt -> Right pt Nothing -> Left "TOTP secret failed authentication" -- | The stored row, column order matching @shomei_totp_credentials@: -- @(totp_credential_id, user_id, secret_enc, last_used_counter, confirmed_at, created_at)@. -type TotpRow = (UUID, UUID, ByteString, Maybe Int64, Maybe UTCTime, UTCTime) +type TotpRow = (UUID, UUID, ByteString, Maybe Int64, Maybe UTCTime, UTCTime, Int16) runTotpCredentialStorePostgres :: (Database :> es, IOE :> es, Error AuthError :> es) => @@ -124,7 +148,7 @@ Eff es a runTotpCredentialStorePostgres key = interpret_ \case UpsertTotpEnrollment NewTotpCredential {totpCredentialId, userId, secret = TotpSecret raw, createdAt} -> do - enc <- liftIO (encryptSecret key raw) + enc <- liftIO (encryptSecret key (totpCredentialIdToUUID totpCredentialId) (userIdToUUID userId) raw) let params = (totpCredentialIdToUUID totpCredentialId, userIdToUUID userId, enc, createdAt) res <- runSession (Session.statement params upsertStmt) either dbFail (const (pure ())) res @@ -156,8 +180,8 @@ rebuild row = either (throwError . InternalAuthError) pure (rebuildCredential key row) rebuildCredential :: TotpEncryptionKey -> TotpRow -> Either Text TotpCredential -rebuildCredential key (tcid, uid, enc, lastUsed, confirmed, created) = do - raw <- decryptSecret key enc +rebuildCredential key (tcid, uid, enc, lastUsed, confirmed, created, version) = do + raw <- decryptSecret key tcid uid version enc pure TotpCredential { totpCredentialId = totpCredentialIdFromUUID tcid, @@ -170,16 +194,17 @@ totpRowDecoder :: D.Row TotpRow totpRowDecoder = - (,,,,,) + (,,,,,,) <$> D.column (D.nonNullable D.uuid) <*> D.column (D.nonNullable D.uuid) <*> D.column (D.nonNullable D.bytea) <*> D.column (D.nullable D.int8) <*> D.column (D.nullable D.timestamptz) <*> D.column (D.nonNullable D.timestamptz) + <*> D.column (D.nonNullable D.int2) selectCols :: Text -selectCols = "totp_credential_id, user_id, secret_enc, last_used_counter, confirmed_at, created_at" +selectCols = "totp_credential_id, user_id, secret_enc, last_used_counter, confirmed_at, created_at, envelope_version" -- | Insert, or replace an existing (unconfirmed) enrollment for the user: on a @user_id@ -- conflict the id and secret are swapped in and the counter/confirmation are reset to NULL. The @@ -189,11 +214,12 @@ preparable """ INSERT INTO shomei.shomei_totp_credentials - (totp_credential_id, user_id, secret_enc, last_used_counter, confirmed_at, created_at) - VALUES ($1, $2, $3, NULL, NULL, $4) + (totp_credential_id, user_id, secret_enc, last_used_counter, confirmed_at, created_at, envelope_version) + VALUES ($1, $2, $3, NULL, NULL, $4, 1) ON CONFLICT (user_id) DO UPDATE SET totp_credential_id = EXCLUDED.totp_credential_id, secret_enc = EXCLUDED.secret_enc, + envelope_version = 1, last_used_counter = NULL, confirmed_at = NULL, created_at = EXCLUDED.created_at @@ -243,3 +269,62 @@ "DELETE FROM shomei.shomei_totp_credentials WHERE user_id = $1" (E.param (E.nonNullable E.uuid)) D.noResult + +-- | Read-only and keyless. Returns (legacy rows, unknown versions). +checkTotpEnvelopeVersions :: Pool.Pool -> IO (Either AuthError (Int64, Int64)) +checkTotpEnvelopeVersions pool = + fmap (either (Left . postgresUnavailable) Right) $ + Pool.use pool (Session.statement () versionCountsStmt) + +versionCountsStmt :: Statement () (Int64, Int64) +versionCountsStmt = + preparable + "SELECT count(*) FILTER (WHERE envelope_version = 0), count(*) FILTER (WHERE envelope_version NOT IN (0, 1)) FROM shomei.shomei_totp_credentials" + E.noParams + (D.singleRow ((,) <$> D.column (D.nonNullable D.int8) <*> D.column (D.nonNullable D.int8))) + +-- | Convert at most 100 legacy rows. Call only with all authentication writers stopped. +-- Decrypt the whole batch before writing anything. Each encryption draws its own nonce. +-- The transaction lock serializes converter writes; CAS protects against stale snapshots. +-- A caller can safely resume after any completed batch or restart after failure. +migrateTotpEnvelopeBatch :: TotpEncryptionKey -> Pool.Pool -> IO (Either AuthError Int) +migrateTotpEnvelopeBatch key pool = do + rows <- Pool.use pool (Session.statement () legacyRowsStmt) + case rows of + Left err -> pure (Left (postgresUnavailable err)) + Right originals -> case traverse decryptLegacy originals of + Left _ -> pure (Left (InternalAuthError "TOTP envelope conversion failed authentication; no batch writes performed")) + Right plaintexts -> do + replacements <- forM plaintexts \(tcid, uid, original, raw) -> do + enc <- encryptSecret key tcid uid raw + pure (tcid, uid, original, enc, 0 :: Int16) + result <- Pool.use pool $ TxSession.transactionNoRetry TxSession.ReadCommitted TxSession.Write do + Tx.statement () conversionLockStmt + results <- forM replacements (\params -> Tx.statement params convertRowStmt) + pure (length (catMaybes results)) + pure (either (Left . postgresUnavailable) Right result) + where + decryptLegacy (tcid, uid, enc) = do + raw <- decryptPayload key BS.empty enc + pure (tcid, uid, enc, raw) + +legacyRowsStmt :: Statement () [(UUID, UUID, ByteString)] +legacyRowsStmt = + preparable + "SELECT totp_credential_id, user_id, secret_enc FROM shomei.shomei_totp_credentials WHERE envelope_version = 0 ORDER BY totp_credential_id LIMIT 100" + E.noParams + (D.rowList ((,,) <$> D.column (D.nonNullable D.uuid) <*> D.column (D.nonNullable D.uuid) <*> D.column (D.nonNullable D.bytea))) + +conversionLockStmt :: Statement () () +conversionLockStmt = + preparable + "SELECT pg_advisory_xact_lock(1936224116, 1)" + E.noParams + D.noResult + +convertRowStmt :: Statement (UUID, UUID, ByteString, ByteString, Int16) (Maybe UUID) +convertRowStmt = + preparable + "UPDATE shomei.shomei_totp_credentials SET secret_enc = $4, envelope_version = 1 WHERE totp_credential_id = $1 AND user_id = $2 AND secret_enc = $3 AND envelope_version = $5 RETURNING totp_credential_id" + (contrazip5 (E.param (E.nonNullable E.uuid)) (E.param (E.nonNullable E.uuid)) (E.param (E.nonNullable E.bytea)) (E.param (E.nonNullable E.bytea)) (E.param (E.nonNullable E.int2))) + (D.rowMaybe (D.column (D.nonNullable D.uuid))) diff --git a/src/Shomei/OAuth/AuthorizationCode/Postgres.hs b/src/Shomei/OAuth/AuthorizationCode/Postgres.hs --- a/src/Shomei/OAuth/AuthorizationCode/Postgres.hs +++ b/src/Shomei/OAuth/AuthorizationCode/Postgres.hs @@ -51,9 +51,6 @@ res <- runSession (Session.statement (h, t) findConsumedStmt) row <- either dbFail pure res traverse rebuild row - DeleteExpiredAuthorizationCodes t -> do - res <- runSession (Session.statement t deleteExpiredStmt) - either dbFail (const (pure ())) res where dbFail = throwError . postgresUnavailable rebuild r = either (throwError . InternalAuthError) pure (rebuildCode r) @@ -181,10 +178,3 @@ ) (contrazip2 (E.param (E.nonNullable E.text)) (E.param (E.nonNullable E.timestamptz))) (D.rowMaybe codeRowDecoder) - -deleteExpiredStmt :: Statement UTCTime () -deleteExpiredStmt = - preparable - "DELETE FROM shomei.shomei_oauth_authorization_codes WHERE expires_at <= $1" - (E.param (E.nonNullable E.timestamptz)) - D.noResult diff --git a/src/Shomei/Passkey/Postgres.hs b/src/Shomei/Passkey/Postgres.hs --- a/src/Shomei/Passkey/Postgres.hs +++ b/src/Shomei/Passkey/Postgres.hs @@ -34,7 +34,8 @@ WebAuthnCredentialId (..), ) import Shomei.Passkey.Store (PasskeyStore (..)) -import Shomei.Persistence.Database.Postgres (Database, postgresUnavailable, runSession) +import Shomei.Persistence.Database.Postgres (Database, postgresUnavailable, runSession, runTransaction) +import Shomei.Persistence.Transaction.Postgres qualified as Tx import Shomei.Prelude -- | The stored-credential row, column order matching @shomei_webauthn_credentials@: @@ -48,7 +49,7 @@ Eff (PasskeyStore : es) a -> Eff es a runPasskeyStorePostgres = interpret_ \case - CreatePasskey NewPasskeyCredential {userId, credentialId, userHandle, publicKey, signCounter, transports, label, createdAt} -> do + CreatePasskey limit NewPasskeyCredential {userId, credentialId, userHandle, publicKey, signCounter, transports, label, createdAt} -> do pid <- genPasskeyId let pc = PasskeyCredential @@ -63,8 +64,13 @@ createdAt, lastUsedAt = Nothing } - res <- runSession (Session.statement (toRow pc) insertStmt) - either dbFail (const (pure pc)) res + res <- runTransaction do + Tx.statement (userIdToUUID userId) enrollmentLockStmt + count <- Tx.statement (userIdToUUID userId) countByUserStmt + if limit < 1 || limit > 100 || count >= fromIntegral limit + then pure (Left PasskeyLimitReached) + else Tx.statement (toRow pc) insertStmt >> pure (Right pc) + either dbFail pure res FindPasskeysByUser uid -> do res <- runSession (Session.statement (userIdToUUID uid) findByUserStmt) rows <- either dbFail pure res @@ -168,6 +174,14 @@ (E.param (E.nullable E.timestamptz)) -- | The SELECT column list (matches 'PasskeyRow' / 'passkeyRowDecoder' order). +-- Lock the account before counting so concurrent inserts cannot both spend the last slot. +enrollmentLockStmt :: Statement UUID () +enrollmentLockStmt = + preparable + "SELECT user_id FROM shomei.shomei_users WHERE user_id = $1 FOR UPDATE" + (E.param (E.nonNullable E.uuid)) + D.noResult + selectCols :: Text selectCols = "passkey_id, user_id, credential_id, user_handle, public_key, sign_counter, transports, label, created_at, last_used_at" diff --git a/src/Shomei/Persistence/Codec/Postgres.hs b/src/Shomei/Persistence/Codec/Postgres.hs --- a/src/Shomei/Persistence/Codec/Postgres.hs +++ b/src/Shomei/Persistence/Codec/Postgres.hs @@ -26,8 +26,8 @@ where import Data.Text qualified as Text -import Shomei.Account.Email.Domain (Email, mkEmail) -import Shomei.Account.LoginId.Domain (LoginId, mkLoginId) +import Shomei.Account.Email.Domain (Email, parseStoredEmail) +import Shomei.Account.LoginId.Domain (LoginId, parseLoginIdForAuthentication) import Shomei.Account.OneTimeToken.Domain (OneTimeTokenStatus (..)) import Shomei.Account.User.Domain (UserStatus (..)) import Shomei.Prelude @@ -146,7 +146,7 @@ -- already normalized through 'mkEmail' on the way in, so this should never fail; a 'Left' -- here signals a corrupt row. emailFromDb :: Text -> Either Text Email -emailFromDb t = case mkEmail t of +emailFromDb t = case parseStoredEmail t of Right e -> Right e Left _ -> Left ("invalid email in database: " <> t) @@ -159,6 +159,6 @@ -- were already normalized through 'mkLoginId' on the way in, so this should never fail; a -- 'Left' here signals a corrupt row. loginIdFromDb :: Text -> Either Text LoginId -loginIdFromDb t = case mkLoginId t of +loginIdFromDb t = case parseLoginIdForAuthentication t of Right l -> Right l Left _ -> Left ("invalid login id in database: " <> t) diff --git a/src/Shomei/Persistence/Database/Postgres.hs b/src/Shomei/Persistence/Database/Postgres.hs --- a/src/Shomei/Persistence/Database/Postgres.hs +++ b/src/Shomei/Persistence/Database/Postgres.hs @@ -9,20 +9,28 @@ uniqueViolation, postgresWriteError, runDatabasePool, + runDatabasePoolWith, + TransactionRetryPolicy (..), + defaultTransactionRetryPolicy, + validateTransactionRetryPolicy, + retryableTransactionError, ) where +import Control.Concurrent (threadDelay) import Data.Text (Text) import Data.Text qualified as Text import Effectful (Dispatch (..), DispatchOf, Eff, Effect, IOE, liftIO, (:>)) import Effectful.Dispatch.Dynamic (interpret_, send) +import GHC.Clock (getMonotonicTimeNSec) import Hasql.Errors qualified as Hasql -import Hasql.Pool (Pool, UsageError) -import Hasql.Pool qualified as Pool import Hasql.Session (Session) -import Hasql.Transaction (Transaction) -import Hasql.Transaction.Sessions qualified as Tx import Shomei.Error (AuthDependency (PostgreSQL), AuthError (DependencyUnavailable)) +import Shomei.Persistence.Pool.Postgres (Pool, UsageError) +import Shomei.Persistence.Pool.Postgres qualified as Pool +import Shomei.Persistence.Transaction.Postgres (Transaction) +import Shomei.Persistence.Transaction.Postgres qualified as Bounded +import System.Timeout (timeout) data Database :: Effect where RunSession :: Session a -> Database m (Either UsageError a) @@ -75,10 +83,61 @@ where marker = "unique constraint \"" --- | Interpret @Database@ against a concrete @hasql@ 'Pool'. Transactions run --- read-committed, read-write (with @hasql-transaction@'s automatic retry on --- serialization failures). +-- | Validated at startup; an invalid direct policy refuses work without touching the pool. +-- The deadline covers checkout, every attempt, and backoff. No retry follows an ambiguous +-- connection/commit failure. Transaction bodies are Hasql database statements only. +data TransactionRetryPolicy = TransactionRetryPolicy + { maxAttempts :: !Int, + deadlineMs :: !Int + } + deriving stock (Eq, Show) + +defaultTransactionRetryPolicy :: TransactionRetryPolicy +defaultTransactionRetryPolicy = TransactionRetryPolicy 3 5000 + +validateTransactionRetryPolicy :: TransactionRetryPolicy -> Either Text () +validateTransactionRetryPolicy policy + | policy.maxAttempts < 1 = Left "transaction max attempts must be positive" + | policy.deadlineMs < 1 || policy.deadlineMs > min 2147483647 (maxBound `div` 1000) = Left "transaction deadline milliseconds must be positive and representable" + | otherwise = Right () + +retryableTransactionError :: UsageError -> Bool +retryableTransactionError = \case + Pool.SessionUsageError (Hasql.StatementSessionError _ _ _ _ _ (Hasql.ServerStatementError (Hasql.ServerError code _ _ _ _))) -> retryable code + Pool.SessionUsageError (Hasql.ScriptSessionError _ (Hasql.ServerError code _ _ _ _)) -> retryable code + _ -> False + where + retryable code = code == "40001" || code == "40P01" + runDatabasePool :: (IOE :> es) => Pool -> Eff (Database : es) a -> Eff es a -runDatabasePool pool = interpret_ \case +runDatabasePool = runDatabasePoolWith defaultTransactionRetryPolicy + +runDatabasePoolWith :: (IOE :> es) => TransactionRetryPolicy -> Pool -> Eff (Database : es) a -> Eff es a +runDatabasePoolWith policy pool = interpret_ \case RunSession sess -> liftIO (Pool.use pool sess) - RunTransaction t -> liftIO (Pool.use pool (Tx.transaction Tx.ReadCommitted Tx.Write t)) + RunTransaction transaction -> liftIO do + case validateTransactionRetryPolicy policy of + Left _ -> pure (Left Pool.AcquisitionTimeoutUsageError) + Right () -> do + started <- getMonotonicTimeNSec + let deadline = toInteger started + toInteger policy.deadlineMs * 1000000 + attempt remainingAttempts = do + now <- getMonotonicTimeNSec + let remainingMicros = (deadline - toInteger now) `div` 1000 + if remainingMicros <= 0 + then pure (Left Pool.AcquisitionTimeoutUsageError) + else do + -- Hasql cancels and rolls back an interrupted session before returning its + -- connection. Keep the operation unmasked so the deadline can interrupt + -- query I/O. A timeout is never retried. + result <- timeout (fromInteger remainingMicros) (Pool.use pool (Bounded.transactionSession (max 1 (fromInteger (remainingMicros `div` 1000))) transaction)) + case result of + Nothing -> pure (Left Pool.AcquisitionTimeoutUsageError) + Just (Left err) | remainingAttempts > 1 && retryableTransactionError err -> do + after <- getMonotonicTimeNSec + let pause = min 10000 ((deadline - toInteger after) `div` 1000) + if pause <= 0 + then pure (Left err) + else threadDelay (fromInteger pause) >> attempt (remainingAttempts - 1) + Just outcome -> pure outcome + attempt policy.maxAttempts diff --git a/src/Shomei/Persistence/Maintenance/Postgres.hs b/src/Shomei/Persistence/Maintenance/Postgres.hs --- a/src/Shomei/Persistence/Maintenance/Postgres.hs +++ b/src/Shomei/Persistence/Maintenance/Postgres.hs @@ -40,17 +40,18 @@ where import Contravariant.Extras (contrazip2) +import Control.Concurrent (threadDelay) import Control.Monad.Trans.Except (ExceptT (..), runExceptT) import Data.Int (Int64) import Data.Time (addUTCTime) import Hasql.Decoders qualified as D import Hasql.Encoders qualified as E -import Hasql.Pool (Pool, UsageError) -import Hasql.Pool qualified as Pool import Hasql.Session qualified as Session import Hasql.Statement (Statement, preparable) import Shomei.Error (AuthError) import Shomei.Persistence.Database.Postgres (postgresUnavailable) +import Shomei.Persistence.Pool.Postgres (Pool, UsageError) +import Shomei.Persistence.Pool.Postgres qualified as Pool import Shomei.Prelude -- | How much history to keep, and how large each delete batch may be. @@ -216,7 +217,7 @@ Left err -> pure (Left err) Right deleted | deleted <= 0 -> pure (Right (fromIntegral acc)) - | otherwise -> go (acc + deleted) + | otherwise -> threadDelay 10000 >> go (acc + deleted) -- Statements ----------------------------------------------------------------- diff --git a/src/Shomei/Persistence/Pool/Postgres.hs b/src/Shomei/Persistence/Pool/Postgres.hs --- a/src/Shomei/Persistence/Pool/Postgres.hs +++ b/src/Shomei/Persistence/Pool/Postgres.hs @@ -1,41 +1,125 @@ --- | Acquire a @hasql@ connection pool from a libpq connection string. +-- | A finite, cancellation-safe pool over public Hasql connections. +-- Every slot has one owner under masking; query/network work is restored to the caller's +-- masking state, and interruption disposes the connection before returning its capacity. module Shomei.Persistence.Pool.Postgres - ( acquirePool, + ( Pool, + UsageError (..), + acquirePool, + use, + release, ) where +import Control.Concurrent.STM +import Control.Exception (SomeException, finally, mask, throwIO, try) +import Control.Monad (forM_) import Data.Text (Text) import Data.Text qualified as Text import Data.Time (DiffTime) +import Hasql.Connection qualified as Connection import Hasql.Connection.Settings qualified as Settings -import Hasql.Pool (Pool) -import Hasql.Pool qualified as Pool -import Hasql.Pool.Config qualified as Config +import Hasql.Errors (ConnectionError, SessionError) +import Hasql.Session (Session) import Hasql.Session qualified as Session +import System.Timeout (timeout) --- | Acquire a pool of @size@ connections against a libpq connection string. --- --- @acquisitionTimeout@ bounds how long a caller of @Hasql.Pool.use@ waits for a free --- connection before giving up with @AcquisitionTimeoutUsageError@; it is @hasql-pool@'s own --- 10-second default unless the operator narrows it. A short timeout sheds load (a request --- fails fast instead of queueing behind a saturated pool); a long one absorbs bursts. --- --- @statementTimeoutMs@ is installed on every new connection as both PostgreSQL's --- @statement_timeout@ and @idle_in_transaction_session_timeout@. This bounds a hung statement or --- leaked transaction holding a pool slot; zero disables both settings. +-- Keep the failure vocabulary stable while owning connection lifecycle explicitly. +data UsageError + = ConnectionUsageError ConnectionError + | SessionUsageError SessionError + | AcquisitionTimeoutUsageError + deriving stock (Eq, Show) + +data Entry = Entry !Connection.Connection !Integer + +data Pool = Pool + { idle :: !(TQueue Entry), + capacity :: !(TVar Int), + generation :: !(TVar Integer), + acquisitionMicros :: !Int, + connectionSettings :: !Settings.Settings, + initializeSession :: !(Session ()) + } + +data Borrowed = Existing !Entry | Vacant !Integer + +-- | Acquire lazily. The timeout bounds waiting for capacity; transaction deadlines also +-- cover connection establishment. Server settings validate positive sizes/timeouts. acquirePool :: Int -> DiffTime -> Int -> Text -> IO Pool -acquirePool size acquisitionTimeout statementTimeoutMs connStr = - Pool.acquire - ( Config.settings - [ Config.staticConnectionSettings (Settings.connectionString connStr), - Config.size size, - Config.acquisitionTimeout acquisitionTimeout, - Config.initSession (Session.script (sessionSetup (max 0 statementTimeoutMs))) - ] - ) +acquirePool size acquisitionTimeout statementTimeoutMs connStr = do + idle <- newTQueueIO + capacity <- newTVarIO (max 1 size) + generation <- newTVarIO 0 + let milliseconds = max 0 statementTimeoutMs + setting = Text.pack (show milliseconds) + setup = "SET statement_timeout = " <> setting <> "; SET idle_in_transaction_session_timeout = " <> setting + micros = max 1 (min (toInteger (maxBound :: Int)) (floor (toRational acquisitionTimeout * 1000000))) + pure + Pool + { idle, + capacity, + generation, + acquisitionMicros = fromInteger micros, + connectionSettings = Settings.connectionString connStr, + initializeSession = Session.script setup + } + +-- | Failures discard the connection conservatively, including a closed backend reported as +-- a decoder error. Successful sessions alone return a connection for reuse. +use :: Pool -> Session a -> IO (Either UsageError a) +use pool session = mask \restore -> do + let returnSlot = atomically (modifyTVar' pool.capacity (+ 1)) + dispose connection = Connection.release connection `finally` returnSlot + returnEntry entry@(Entry connection epoch) = do + reusable <- atomically do + current <- readTVar pool.generation + if current == epoch then writeTQueue pool.idle entry >> pure True else pure False + if reusable then pure () else dispose connection + execute entry@(Entry connection _) = do + outcome <- try @SomeException (restore (Connection.use connection session)) + case outcome of + Left interrupted -> dispose connection >> throwIO interrupted + Right (Left err) -> dispose connection >> pure (Left (SessionUsageError err)) + Right (Right value) -> returnEntry entry >> pure (Right value) + establish epoch = do + acquired <- try @SomeException (restore (Connection.acquire pool.connectionSettings)) + case acquired of + Left interrupted -> returnSlot >> throwIO interrupted + Right (Left err) -> returnSlot >> pure (Left (ConnectionUsageError err)) + Right (Right connection) -> do + initialized <- try @SomeException (restore (Connection.use connection pool.initializeSession)) + case initialized of + Left interrupted -> dispose connection >> throwIO interrupted + Right (Left err) -> dispose connection >> pure (Left (SessionUsageError err)) + Right (Right ()) -> execute (Entry connection epoch) + -- Remain masked across the STM ownership transfer. Blocking STM is interruptible and + -- rolls back before interruption, so cancellation cannot consume an unowned slot. + borrowed <- + timeout + pool.acquisitionMicros + ( atomically do + available <- tryReadTQueue pool.idle + case available of + Just entry -> pure (Existing entry) + Nothing -> do + free <- readTVar pool.capacity + check (free > 0) + modifyTVar' pool.capacity (subtract 1) + Vacant <$> readTVar pool.generation + ) + case borrowed of + Nothing -> pure (Left AcquisitionTimeoutUsageError) + Just (Existing entry) -> execute entry + Just (Vacant epoch) -> establish epoch + +-- | Flush idle connections and retire in-flight connections on return. The same pool stays +-- usable; old and new generations share capacity, preserving the global connection ceiling. +release :: Pool -> IO () +release pool = mask \_ -> do + entries <- atomically do + modifyTVar' pool.generation (+ 1) + flushTQueue pool.idle + failures <- traverse (try @SomeException . close) entries + forM_ [err | Left err <- failures] throwIO where - sessionSetup ms = - "SET statement_timeout = " - <> Text.pack (show ms) - <> "; SET idle_in_transaction_session_timeout = " - <> Text.pack (show ms) + close (Entry connection _) = Connection.release connection `finally` atomically (modifyTVar' pool.capacity (+ 1)) diff --git a/src/Shomei/Persistence/Transaction/Postgres.hs b/src/Shomei/Persistence/Transaction/Postgres.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Persistence/Transaction/Postgres.hs @@ -0,0 +1,57 @@ +-- | Database-only transactions whose statements inherit a shrinking server-side budget. +-- There is no MonadIO instance or raw transaction constructor. Generate IDs and perform +-- non-database effects before/after the transaction. Audit inserts are ordinary transactional SQL. +module Shomei.Persistence.Transaction.Postgres + ( Transaction, + statement, + transactionSession, + ) +where + +import Data.Int (Int64) +import Hasql.Decoders qualified as D +import Hasql.Encoders qualified as E +import Hasql.Session (Session) +import Hasql.Statement (Statement, preparable) +import Hasql.Transaction qualified as Tx +import Hasql.Transaction.Sessions qualified as Sessions +import Shomei.Prelude + +newtype Transaction a = Transaction (Tx.Transaction a) + deriving newtype (Functor, Applicative, Monad) + +statement :: a -> Statement a b -> Transaction b +statement params query = Transaction do + _ <- Tx.statement () capStatementBudget + Tx.statement params query + +-- | One whole attempt, with dependency automatic retries disabled. The local settings reset +-- on COMMIT/ROLLBACK. Retrying starts a fresh server budget from the remaining client deadline. +transactionSession :: Int -> Transaction a -> Session a +transactionSession milliseconds (Transaction body) = + Sessions.transactionNoRetry Sessions.ReadCommitted Sessions.Write do + _ <- Tx.statement (fromIntegral milliseconds) initializeBudget + body + +initializeBudget :: Statement Int64 (Text, Text) +initializeBudget = + preparable + """ + SELECT set_config('shomei.transaction_deadline', (clock_timestamp() + $1::bigint * interval '1 millisecond')::text, true), + set_config('shomei.statement_limit_ms', (extract(epoch FROM current_setting('statement_timeout')::interval) * 1000)::bigint::text, true) + """ + (E.param (E.nonNullable E.int8)) + (D.singleRow ((,) <$> D.column (D.nonNullable D.text) <*> D.column (D.nonNullable D.text))) + +capStatementBudget :: Statement () Text +capStatementBudget = + preparable + """ + SELECT set_config('statement_timeout', + greatest(1, least( + floor(extract(epoch FROM (current_setting('shomei.transaction_deadline')::timestamptz - clock_timestamp())) * 1000)::bigint, + nullif(current_setting('shomei.statement_limit_ms')::bigint,0) + ))::text, true) + """ + E.noParams + (D.singleRow (D.column (D.nonNullable D.text))) diff --git a/src/Shomei/Session/LoginAttempt/Postgres.hs b/src/Shomei/Session/LoginAttempt/Postgres.hs --- a/src/Shomei/Session/LoginAttempt/Postgres.hs +++ b/src/Shomei/Session/LoginAttempt/Postgres.hs @@ -21,11 +21,11 @@ import Hasql.Encoders qualified as E import Hasql.Session qualified as Session import Hasql.Statement (Statement, preparable) -import Hasql.Transaction qualified as Tx import Shomei.Error (AuthError (..)) import Shomei.Id (genLoginAttemptId, loginAttemptIdToUUID) import Shomei.Persistence.Codec.Postgres (attemptFactorToText, loginOutcomeToText) import Shomei.Persistence.Database.Postgres (Database, postgresUnavailable, runSession, runTransaction) +import Shomei.Persistence.Transaction.Postgres qualified as Tx import Shomei.Prelude import Shomei.Session.LoginAttempt.Domain ( AccountKey (..), diff --git a/src/Shomei/Session/Postgres.hs b/src/Shomei/Session/Postgres.hs --- a/src/Shomei/Session/Postgres.hs +++ b/src/Shomei/Session/Postgres.hs @@ -13,10 +13,12 @@ mkSession, revokeSessionStmt, revokeAllUserSessionsStmt, + revokeAllUserSessionsSql, ) where -import Contravariant.Extras (contrazip11, contrazip2) +import Contravariant.Extras (contrazip12, contrazip2, contrazip3, contrazip4) +import Data.Int (Int64) import Data.Set qualified as Set import Data.UUID (UUID) import Effectful (Eff, IOE, (:>)) @@ -30,12 +32,13 @@ import Shomei.Error (AuthError (..)) import Shomei.Id (SessionId, genSessionId, sessionIdFromUUID, sessionIdToUUID, userIdFromUUID, userIdToUUID) import Shomei.Persistence.Codec.Postgres (sessionKindFromText, sessionKindToText, sessionStatusFromText, sessionStatusToText) -import Shomei.Persistence.Database.Postgres (Database, postgresUnavailable, runSession) +import Shomei.Persistence.Database.Postgres (Database, postgresUnavailable, runSession, runTransaction) +import Shomei.Persistence.Transaction.Postgres qualified as Tx import Shomei.Prelude -import Shomei.Session.Domain (NewSession (..), Session (..), SessionKind (InteractiveSession), SessionStatus (SessionActive)) -import Shomei.Session.Store (SessionStore (..)) +import Shomei.Session.Domain (NewSession (..), Session (..), SessionStatus (SessionActive)) +import Shomei.Session.Store (SessionCursor (..), SessionListQuery (..), SessionStore (..), clampSessionLimit) -type SessionRow = (UUID, UUID, Text, UTCTime, UTCTime, Maybe UTCTime, Maybe UUID, Maybe Text, Maybe Text, [Text], Maybe UTCTime) +type SessionRow = (UUID, UUID, Text, UTCTime, UTCTime, Maybe UTCTime, Maybe UUID, Maybe Text, Maybe Text, [Text], Maybe UTCTime, Bool) runSessionStorePostgres :: (Database :> es, IOE :> es, Error AuthError :> es) => @@ -45,21 +48,24 @@ CreateSession ns -> do sid <- genSessionId let session = mkSession sid ns - row = - ( sessionIdToUUID sid, - userIdToUUID ns.userId, - sessionStatusToText SessionActive, - ns.createdAt, - ns.expiresAt, - Nothing, - userIdToUUID <$> ns.actor, - ns.oauthClientId, - Just (sessionKindToText ns.kind), - [scope | Scope scope <- Set.toList ns.grantedScopes], - Just ns.authenticatedAt - ) + row = sessionToRow session res <- runSession (Session.statement row insertSessionStmt) either dbFail (const (pure session)) res + CreateSessionWithinLimit cap ns -> do + sid <- genSessionId + let session = mkSession sid ns + principals = Set.toAscList (Set.fromList (ns.userId : maybe [] pure ns.actor)) + res <- runTransaction do + -- UUID ordering prevents two overlapping actor/subject pairs from deadlocking. + locked <- Tx.statement (map userIdToUUID principals) lockPrincipalsStmt + if length locked /= length principals + then pure (Left UserNotFound) + else do + counts <- forM principals \principal -> Tx.statement (userIdToUUID principal, ns.createdAt, fromIntegral cap) activePrincipalSessionsStmt + if any (>= fromIntegral cap) counts + then pure (Left SessionLimitReached) + else Right session <$ Tx.statement (sessionToRow session) insertSessionStmt + either dbFail pure res FindSessionById sid -> do res <- runSession (Session.statement (sessionIdToUUID sid) findSessionByIdStmt) row <- either dbFail pure res @@ -69,7 +75,12 @@ either dbFail (const (pure ())) res RevokeAllUserSessions uid t -> do res <- runSession (Session.statement (userIdToUUID uid, t) revokeAllUserSessionsStmt) - either dbFail (const (pure ())) res + either dbFail (pure . map sessionIdFromUUID) res + ListSessionPage uid query -> do + let params = (userIdToUUID uid, (.cursorCreatedAt) <$> query.queryBefore, sessionIdToUUID . (.cursorSessionId) <$> query.queryBefore, fromIntegral (clampSessionLimit query.queryLimit)) + res <- runSession (Session.statement params listSessionPageStmt) + rows <- either dbFail pure res + traverse rebuild rows ListSessionsForUser uid -> do res <- runSession (Session.statement (userIdToUUID uid) listSessionsForUserStmt) rows <- either dbFail pure res @@ -91,13 +102,14 @@ oauthClientId = ns.oauthClientId, kind = ns.kind, grantedScopes = ns.grantedScopes, - authenticatedAt = ns.authenticatedAt + authenticatedAt = ns.authenticatedAt, + remembered = ns.remembered } rebuildSession :: SessionRow -> Either Text Session -rebuildSession (sid, uid, st, c, e, r, act, oauthClientId, mKind, scopeTexts, mAuthenticatedAt) = do +rebuildSession (sid, uid, st, c, e, r, act, oauthClientId, mKind, scopeTexts, mAuthenticatedAt, remembered) = do status <- sessionStatusFromText st - kind <- maybe (Right InteractiveSession) sessionKindFromText mKind + kind <- maybe (Left "session kind is missing") sessionKindFromText mKind pure Session { sessionId = sessionIdFromUUID sid, @@ -110,12 +122,13 @@ oauthClientId, kind, grantedScopes = Set.fromList (map Scope scopeTexts), - authenticatedAt = fromMaybe c mAuthenticatedAt + authenticatedAt = fromMaybe c mAuthenticatedAt, + remembered } sessionRowDecoder :: D.Row SessionRow sessionRowDecoder = - (,,,,,,,,,,) + (,,,,,,,,,,,) <$> D.column (D.nonNullable D.uuid) <*> D.column (D.nonNullable D.uuid) <*> D.column (D.nonNullable D.text) @@ -127,16 +140,17 @@ <*> D.column (D.nullable D.text) <*> D.column (D.nonNullable (D.listArray (D.nonNullable D.text))) <*> D.column (D.nullable D.timestamptz) + <*> D.column (D.nonNullable D.bool) insertSessionStmt :: Statement SessionRow () insertSessionStmt = preparable """ INSERT INTO shomei.shomei_sessions - (session_id, user_id, status, created_at, expires_at, revoked_at, actor_user_id, oauth_client_id, kind, granted_scopes, authenticated_at) - VALUES ($1, $2, $3, $4, $5, $6, $7, $8, $9, $10, $11) + (session_id, user_id, status, created_at, expires_at, revoked_at, actor_user_id, oauth_client_id, kind, granted_scopes, authenticated_at, remembered) + VALUES ($1, $2, $3, $4, $5, $6, $7, $8, $9, $10, $11, $12) """ - ( contrazip11 + ( contrazip12 (E.param (E.nonNullable E.uuid)) (E.param (E.nonNullable E.uuid)) (E.param (E.nonNullable E.text)) @@ -148,6 +162,7 @@ (E.param (E.nullable E.text)) (E.param (E.nonNullable (E.foldableArray (E.nonNullable E.text)))) (E.param (E.nullable E.timestamptz)) + (E.param (E.nonNullable E.bool)) ) D.noResult @@ -157,7 +172,7 @@ listSessionsForUserStmt = preparable """ - SELECT session_id, user_id, status, created_at, expires_at, revoked_at, actor_user_id, oauth_client_id, kind, granted_scopes, authenticated_at + SELECT session_id, user_id, status, created_at, expires_at, revoked_at, actor_user_id, oauth_client_id, kind, granted_scopes, authenticated_at, remembered FROM shomei.shomei_sessions WHERE user_id = $1 ORDER BY created_at DESC, session_id DESC @@ -169,7 +184,7 @@ findSessionByIdStmt = preparable """ - SELECT session_id, user_id, status, created_at, expires_at, revoked_at, actor_user_id, oauth_client_id, kind, granted_scopes, authenticated_at + SELECT session_id, user_id, status, created_at, expires_at, revoked_at, actor_user_id, oauth_client_id, kind, granted_scopes, authenticated_at, remembered FROM shomei.shomei_sessions WHERE session_id = $1 """ @@ -189,13 +204,73 @@ (contrazip2 (E.param (E.nonNullable E.uuid)) (E.param (E.nonNullable E.timestamptz))) (D.rowMaybe (D.column (D.nonNullable D.uuid))) -revokeAllUserSessionsStmt :: Statement (UUID, UTCTime) () +revokeAllUserSessionsStmt :: Statement (UUID, UTCTime) [UUID] revokeAllUserSessionsStmt = preparable + revokeAllUserSessionsSql + (contrazip2 (E.param (E.nonNullable E.uuid)) (E.param (E.nonNullable E.timestamptz))) + (D.rowList (D.column (D.nonNullable D.uuid))) + +-- | Shared winner-producing update, also embedded in the bulk audited CTE. No application +-- materialization of winners is needed by that operation. +revokeAllUserSessionsSql :: Text +revokeAllUserSessionsSql = + """ + UPDATE shomei.shomei_sessions SET status = 'revoked', revoked_at = $2 + WHERE user_id = $1 AND status = 'active' + RETURNING session_id + """ + +listSessionPageStmt :: Statement (UUID, Maybe UTCTime, Maybe UUID, Int64) [SessionRow] +listSessionPageStmt = + preparable """ - UPDATE shomei.shomei_sessions - SET status = 'revoked', revoked_at = $2 - WHERE user_id = $1 AND status = 'active' + SELECT session_id, user_id, status, created_at, expires_at, revoked_at, actor_user_id, oauth_client_id, kind, granted_scopes, authenticated_at, remembered + FROM shomei.shomei_sessions + WHERE user_id = $1 AND ($2::timestamptz IS NULL OR (created_at, session_id) < ($2,$3)) + ORDER BY created_at DESC, session_id DESC LIMIT $4 """ - (contrazip2 (E.param (E.nonNullable E.uuid)) (E.param (E.nonNullable E.timestamptz))) - D.noResult + ( contrazip4 + (E.param (E.nonNullable E.uuid)) + (E.param (E.nullable E.timestamptz)) + (E.param (E.nullable E.uuid)) + (E.param (E.nonNullable E.int8)) + ) + (D.rowList sessionRowDecoder) + +sessionToRow :: Session -> SessionRow +sessionToRow session = + ( sessionIdToUUID session.sessionId, + userIdToUUID session.userId, + sessionStatusToText session.status, + session.createdAt, + session.expiresAt, + session.revokedAt, + userIdToUUID <$> session.actor, + session.oauthClientId, + Just (sessionKindToText session.kind), + [scope | Scope scope <- Set.toList session.grantedScopes], + Just session.authenticatedAt, + session.remembered + ) + +lockPrincipalsStmt :: Statement [UUID] [UUID] +lockPrincipalsStmt = + preparable + "SELECT user_id FROM shomei.shomei_users WHERE user_id = ANY($1) ORDER BY user_id FOR UPDATE" + (E.param (E.nonNullable (E.foldableArray (E.nonNullable E.uuid)))) + (D.rowList (D.column (D.nonNullable D.uuid))) + +activePrincipalSessionsStmt :: Statement (UUID, UTCTime, Int64) Int64 +activePrincipalSessionsStmt = + preparable + """ + SELECT count(*) FROM ( + SELECT 1 FROM shomei.shomei_sessions + WHERE (user_id=$1 OR actor_user_id=$1) AND status='active' + AND kind IN ('machine','delegated') AND expires_at > $2 + LIMIT $3 + ) AS active + """ + (contrazip3 (E.param (E.nonNullable E.uuid)) (E.param (E.nonNullable E.timestamptz)) (E.param (E.nonNullable E.int8))) + (D.singleRow (D.column (D.nonNullable D.int8))) diff --git a/src/Shomei/Session/UnitOfWork/Postgres.hs b/src/Shomei/Session/UnitOfWork/Postgres.hs --- a/src/Shomei/Session/UnitOfWork/Postgres.hs +++ b/src/Shomei/Session/UnitOfWork/Postgres.hs @@ -17,13 +17,20 @@ ) where +import Contravariant.Extras (contrazip3) +import Data.Aeson (Value, object) +import Data.Aeson qualified as Aeson import Data.Foldable (traverse_) +import Data.Int (Int64) import Data.Set qualified as Set +import Data.UUID (UUID) import Data.UUID.V4 qualified as UUIDv4 import Effectful (Eff, IOE, (:>)) import Effectful.Dispatch.Dynamic (interpret_) import Effectful.Error.Static (Error, throwError) -import Hasql.Transaction qualified as Tx +import Hasql.Decoders qualified as D +import Hasql.Encoders qualified as E +import Hasql.Statement (Statement, preparable) import Shomei.Account.Credential.Postgres (updatePasswordHashStmt) import Shomei.Account.Password.Domain (PasswordHash (..)) import Shomei.Account.PasswordReset.Postgres qualified as PR @@ -43,12 +50,14 @@ ) import Shomei.Persistence.Codec.Postgres (refreshTokenStatusToText, sessionKindToText, sessionStatusToText) import Shomei.Persistence.Database.Postgres (Database, postgresUnavailable, runTransaction) +import Shomei.Persistence.Transaction.Postgres qualified as Tx import Shomei.Prelude import Shomei.Session.Domain (Session (..), SessionStatus (SessionActive)) import Shomei.Session.Postgres ( SessionRow, insertSessionStmt, mkSession, + revokeAllUserSessionsSql, revokeAllUserSessionsStmt, revokeSessionStmt, ) @@ -114,8 +123,8 @@ case won of Nothing -> pure False Just _ -> do - Tx.statement (userIdToUUID uid, passwordHashText newHash) updatePasswordHashStmt - Tx.statement (userIdToUUID uid, ts) revokeAllUserSessionsStmt + Tx.statement (userIdToUUID uid, passwordHashText newHash, ts) updatePasswordHashStmt + _ <- Tx.statement (userIdToUUID uid, ts) revokeAllUserSessionsStmt Tx.statement (userIdToUUID uid, ts) RTP.revokeUserTokensStmt -- The consumed token is no longer active, so this revokes only its live siblings. Tx.statement (userIdToUUID uid, ts) PR.revokeUserTokensStmt @@ -124,11 +133,15 @@ CompletePasswordChange uid newHash ts events -> do eventRows <- traverse toEventRow events res <- runTransaction do - Tx.statement (userIdToUUID uid, passwordHashText newHash) updatePasswordHashStmt - Tx.statement (userIdToUUID uid, ts) revokeAllUserSessionsStmt + Tx.statement (userIdToUUID uid, passwordHashText newHash, ts) updatePasswordHashStmt + _ <- Tx.statement (userIdToUUID uid, ts) revokeAllUserSessionsStmt Tx.statement (userIdToUUID uid, ts) RTP.revokeUserTokensStmt traverse_ (\row -> Tx.statement row insertAuthEventStmt) eventRows either dbFail pure res + RevokeUserSessionsWithAudit actor uid ts -> do + let payload = object ["revokedBy" Aeson..= actor, "occurredAt" Aeson..= ts] + res <- runTransaction (Tx.statement (userIdToUUID uid, ts, payload) revokeUserSessionsWithAuditStmt) + either dbFail (pure . fromIntegral) res RevokeSessionWithTokens sid ts events -> do eventRows <- traverse toEventRow events res <- runTransaction do @@ -167,7 +180,8 @@ session.oauthClientId, Just (sessionKindToText session.kind), [scope | Scope scope <- Set.toList session.grantedScopes], - Just session.authenticatedAt + Just session.authenticatedAt, + session.remembered ) -- | The column tuple 'insertRefreshTokenStmt' encodes. A freshly inserted token is always @@ -184,3 +198,26 @@ Nothing, Nothing ) + +-- Winners and audit payloads remain inside PostgreSQL: the application receives one count. +-- A bulk revocation's event UUID is the unique session UUID; each session has at most one +-- active→revoked winner. All other event writers allocate UUIDv4 keys independently. +revokeUserSessionsWithAuditStmt :: Statement (UUID, UTCTime, Value) Int64 +revokeUserSessionsWithAuditStmt = + preparable + ( "WITH winners AS (" + <> revokeAllUserSessionsSql + <> """ + ), tokens AS ( + UPDATE shomei.shomei_refresh_tokens SET status = 'revoked', revoked_at = $2 + WHERE session_id IN (SELECT session_id FROM winners) AND status <> 'revoked' + ), events AS ( + INSERT INTO shomei.shomei_auth_events(event_id, user_id, session_id, event_type, payload, created_at) + SELECT session_id, NULL, session_id, 'session_revoked', + $3::jsonb || jsonb_build_object('sessionId', session_id::text), $2 FROM winners + RETURNING event_id + ) SELECT count(*) FROM events + """ + ) + (contrazip3 (E.param (E.nonNullable E.uuid)) (E.param (E.nonNullable E.timestamptz)) (E.param (E.nonNullable E.jsonb))) + (D.singleRow (D.column (D.nonNullable D.int8))) diff --git a/src/Shomei/SigningKey/Postgres.hs b/src/Shomei/SigningKey/Postgres.hs --- a/src/Shomei/SigningKey/Postgres.hs +++ b/src/Shomei/SigningKey/Postgres.hs @@ -13,10 +13,10 @@ import Hasql.Encoders qualified as E import Hasql.Session qualified as Session import Hasql.Statement (Statement, preparable) -import Hasql.Transaction qualified as Tx import Shomei.Error (AuthError (..)) import Shomei.Persistence.Codec.Postgres (signingKeyStatusFromText, signingKeyStatusToText) import Shomei.Persistence.Database.Postgres (Database, postgresUnavailable, runSession, runTransaction) +import Shomei.Persistence.Transaction.Postgres qualified as Tx import Shomei.Prelude import Shomei.SigningKey.Domain (SigningKeyStatus (KeyActive), StoredSigningKey (..)) import Shomei.SigningKey.Store (SigningKeyStore (..)) diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -5,9 +5,13 @@ -- PostgreSQL interpreters with database-state assertions. module Main (main) where -import Control.Concurrent (forkIO, newEmptyMVar, putMVar, readMVar, takeMVar, threadDelay) -import Control.Exception (evaluate) -import Control.Monad (forM_, replicateM, void, when) +import Control.Concurrent (MVar, forkIO, killThread, newEmptyMVar, putMVar, readMVar, takeMVar, threadDelay) +import Control.Exception (SomeException, bracket, bracket_, evaluate, try) +import Control.Monad (forM, forM_, replicateM, void, when, (<=<)) +import Crypto.Cipher.AES (AES256) +import Crypto.Cipher.Types (AEAD, AEADMode (AEAD_GCM), AuthTag (..), aeadInit, aeadSimpleEncrypt, cipherInit) +import Crypto.Error (CryptoFailable (..)) +import Data.ByteArray qualified as BA import Data.ByteString (ByteString) import Data.ByteString qualified as BS import Data.Either (isLeft) @@ -18,22 +22,21 @@ import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as Text +import Data.Text.Encoding qualified as TE import Data.Time (UTCTime (..), addUTCTime, fromGregorian, getCurrentTime) import Effectful (Eff, IOE, liftIO, runEff, (:>)) -import Effectful.Dispatch.Dynamic (interpose, interpret_, send) +import Effectful.Dispatch.Dynamic (interpose, interpret_, passthrough, send) import Effectful.Error.Static (Error, runErrorNoCallStack) import GHC.Clock (getMonotonicTimeNSec) import GHC.Conc (getNumCapabilities) import Hasql.Decoders qualified as D import Hasql.Encoders qualified as E import Hasql.Errors qualified as Hasql -import Hasql.Pool (Pool) -import Hasql.Pool qualified as Pool import Hasql.Session qualified as Session import Hasql.Statement (preparable) import Shomei.Account.Credential.Domain (Credential (..)) import Shomei.Account.Credential.Postgres (runCredentialStorePostgres) -import Shomei.Account.Credential.Store (CredentialStore, createPasswordCredential, findPasswordCredentialByEmail, findPasswordCredentialByLoginId) +import Shomei.Account.Credential.Store (CredentialStore, createPasswordCredential, findPasswordCredentialByEmail, findPasswordCredentialByLoginId, updatePasswordHash) import Shomei.Account.Email.Domain (Email, emailText, mkEmail) import Shomei.Account.Lifecycle.Workflow ( ConfirmEmailVerification (..), @@ -79,7 +82,7 @@ import Shomei.Account.User.Store ( UserCursor (..), UserListQuery (..), - UserStore, + UserStore (..), createUser, emptyUserListQuery, findUserByEmail, @@ -131,7 +134,7 @@ import Shomei.Config (RateLimitConfig (..), ShomeiConfig (..), defaultRateLimitConfig, defaultShomeiConfig) import Shomei.Error (AuthDependency (PostgreSQL), AuthError (DependencyUnavailable, EmailAlreadyRegistered, InvalidCredentials, LoginIdAlreadyRegistered, PasswordResetTokenInvalid, RefreshTokenReuseDetected, RoleNotDefined, UserNotFound)) import Shomei.Error qualified as Err -import Shomei.Id (OAuthClientId, PasskeyId, ServiceAccountDbId, genCeremonyId, genOAuthClientId, genRecoveryCodeId, genServiceAccountDbId, genSessionId, genTotpCredentialId, genUserId, idText, userIdToUUID) +import Shomei.Id (OAuthClientId, PasskeyId, ServiceAccountDbId, genCeremonyId, genOAuthClientId, genRecoveryCodeId, genServiceAccountDbId, genSessionId, genTotpCredentialId, genUserId, idText, totpCredentialIdToUUID, userIdToUUID) import Shomei.Mfa.RecoveryCode.Postgres (runRecoveryCodeStorePostgres) import Shomei.Mfa.RecoveryCode.Store ( RecoveryCodeStore, @@ -139,10 +142,12 @@ countUnusedRecoveryCodes, replaceRecoveryCodes, ) -import Shomei.Mfa.Totp.Algorithm (TotpSecret (..)) +import Shomei.Mfa.Totp.Algorithm (TotpSecret (..), totpCode, totpCounter) import Shomei.Mfa.Totp.Domain (NewRecoveryCode (..), NewTotpCredential (..), TotpCredential (..)) import Shomei.Mfa.Totp.Postgres ( TotpEncryptionKey, + checkTotpEnvelopeVersions, + migrateTotpEnvelopeBatch, runTotpCredentialStorePostgres, totpEncryptionKeyFromBytes, ) @@ -154,6 +159,7 @@ setTotpLastUsedCounter, upsertTotpEnrollment, ) +import Shomei.Mfa.Workflow (MfaCompletion (..), completeMfa, prepareMfaChallenge) import Shomei.Migrations.TestSupport (withShomeiMigratedDatabase) import Shomei.OAuth.AuthorizationCode.Domain (AuthorizationCode (..), NewAuthorizationCode (..)) import Shomei.OAuth.AuthorizationCode.Postgres (runOAuthCodeStorePostgres) @@ -161,7 +167,6 @@ ( OAuthCodeStore, bindAuthorizationCodeSession, consumeAuthorizationCode, - deleteExpiredAuthorizationCodes, findConsumedAuthorizationCode, putAuthorizationCode, ) @@ -204,7 +209,7 @@ findPasskeysByUserHandle, updatePasskeySignCounter, ) -import Shomei.Persistence.Database.Postgres (Database (..), runDatabasePool) +import Shomei.Persistence.Database.Postgres (Database (..), TransactionRetryPolicy (..), retryableTransactionError, runDatabasePool, runDatabasePoolWith, runTransaction) import Shomei.Persistence.Maintenance.Postgres ( SweepConfig (..), SweepReport (..), @@ -212,7 +217,9 @@ emptySweepReport, sweepOnce, ) -import Shomei.Persistence.Pool.Postgres (acquirePool) +import Shomei.Persistence.Pool.Postgres (Pool, acquirePool) +import Shomei.Persistence.Pool.Postgres qualified as Pool +import Shomei.Persistence.Transaction.Postgres qualified as Tx import Shomei.ServiceAccount.Domain (NewServiceAccount (..), ServiceAccount (..), ServiceAccountStatus (..)) import Shomei.ServiceAccount.Postgres (runServiceAccountStorePostgres) import Shomei.ServiceAccount.Store @@ -224,7 +231,7 @@ rotateServiceAccountSecret, ) import Shomei.Session.Authentication.Workflow (login, logout, refresh, signup) -import Shomei.Session.Command (ClientContext (..), LoginCommand (..), LogoutCommand (..), RefreshCommand (..), SignupCommand (..)) +import Shomei.Session.Command (ClientContext (..), LoginCommand (..), LogoutCommand (..), ProofContext (..), RefreshCommand (..), SignupCommand (..)) import Shomei.Session.Domain (NewSession (..), Session (..), SessionKind (..), SessionStatus (..)) import Shomei.Session.LoginAttempt.Domain (AccountKey (..), AccountLockout (..), AttemptFactor (..), ClientIp (..), FailureOutcome (..), LockPolicy (..), LoginOutcome (..), NewLoginAttempt (..)) import Shomei.Session.LoginAttempt.Postgres (runLoginAttemptStorePostgres) @@ -240,12 +247,12 @@ import Shomei.Session.Postgres (runSessionStorePostgres) import Shomei.Session.RefreshToken.Domain (NewRefreshToken (..), PersistedRefreshToken (..), RefreshToken (..), RefreshTokenStatus (..)) import Shomei.Session.RefreshToken.Postgres (runRefreshTokenStorePostgres) -import Shomei.Session.RefreshToken.Store (RefreshTokenStore, createRefreshToken, findRefreshTokenByHash, markRefreshTokenUsed) -import Shomei.Session.Store (SessionStore, createSession, findSessionById, listSessionsForUser, revokeSession) +import Shomei.Session.RefreshToken.Store (RefreshTokenStore (..), createRefreshToken, findRefreshTokenByHash, markRefreshTokenUsed) +import Shomei.Session.Store (SessionCursor (..), SessionListQuery (..), SessionStore, createSession, createSessionWithinLimit, emptySessionListQuery, findSessionById, listSessionPage, listSessionsForUser, revokeSession) import Shomei.Session.Token.Domain (AccessToken (..), TokenPair (..)) import Shomei.Session.Token.Generator (TokenGen, hashRefreshToken) import Shomei.Session.UnitOfWork.Postgres (runAuthUnitOfWorkPostgres) -import Shomei.Session.UnitOfWork.Store (AuthUnitOfWork, revokeSessionWithTokens) +import Shomei.Session.UnitOfWork.Store (AuthUnitOfWork, completePasswordChange, completePasswordReset, revokeSessionWithTokens, revokeUserSessionsWithAudit) import Shomei.Session.Workflow (buildEnrichedClaims) import Shomei.SigningKey.Domain (SigningKeyStatus (..), StoredSigningKey (..)) import Shomei.SigningKey.Postgres (runSigningKeyStorePostgres) @@ -254,6 +261,7 @@ import Shomei.Test.InMemory (emptyWorld, runPasswordBreachCheckerFake, runWebAuthnCeremonyFake) import Shomei.Time.Postgres (runClockIO) import Shomei.Time.Store (Clock (..), now) +import System.Timeout (timeout) import Test.Tasty (TestTree, defaultMain, testGroup) import Test.Tasty.HUnit (Assertion, assertBool, assertEqual, assertFailure, testCase, (@?=)) @@ -513,8 +521,25 @@ tests :: [TestTree] tests = - [ testUserRoundTrip, + [ testManagedPoolOwnership, + testPersistenceClock, + testAdminQueryPlans, + testRefreshRotationRace, + testResetAndVerificationRaces, + testRecoveryAndCeremonyRaces, + testSweepVersusLiveRotation, + testRetryBudgets, + testTransactionDeadline, + testShrinkingStatementBudget, + testSessionQuotaQueryPlan, + testActiveSessionQuota, + testBulkRevocation, + testSessionPages, + testSessionQueryPlan, + testDatabaseTimeouts, + testUserRoundTrip, testUserNoEmailAndUniqueLoginId, + testFieldBudgets, testSchemaRejectsInvalidUserStatusAndCaseVariantIdentities, testListUsersOrderFilterAndPaging, testUserStatusIsCompareAndSwap, @@ -527,7 +552,8 @@ testSessionActorRoundTrip, testSessionKindRoundTrip, testSessionGrantedScopesRoundTrip, - testSessionKindNullReadsInteractive, + testSessionRememberedRoundTrip, + testSessionKindNullFailsClosed, testRefreshTokenMarkUsed, testVerificationTokenRoundTrip, testPasswordResetTokenRoundTrip, @@ -553,6 +579,7 @@ testLockoutRecordAndCountIsAtomicUnderRace, testWorkflowLockout, testPasskeyCreateAndFind, + testPasskeyQuotaRace, testPasskeyUpdateCountDelete, testPasskeyCounterIsCompareAndSwap, testPasskeyCounterCasUnderRace, @@ -564,6 +591,11 @@ testTotpCounterIsCompareAndSwap, testTotpCounterCasUnderRace, testTotpEncryptionAtRest, + testTotpEnvelopeBinding, + testTotpEnvelopeConversion, + testTotpConversionBatches, + testTotpConvertedFactor, + testTotpConversionConflict, testRecoveryCodeCasAndReplace, testPendingCeremonyConsumeOnce, testPendingCeremonyExpired, @@ -862,8 +894,206 @@ stored <- scalarBytea pool "SELECT secret_enc FROM shomei.shomei_totp_credentials LIMIT 1" assertBool "stored ciphertext must differ from the plaintext secret" (stored /= totpRawSecret) -- 12-byte nonce + 20-byte ciphertext + 16-byte GCM tag - BS.length stored @?= 48 + BS.length stored @?= 54 +testTotpEnvelopeBinding :: TestTree +testTotpEnvelopeBinding = + testCase "totp envelopes bind pending/confirmed rows and reject transplant, version and payload tampering" $ withDb \pool -> do + (alice, bob) <- + expectApp =<< runApp pool do + a <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing}) + b <- createUser (NewUser {loginId = bobLogin, email = Just bobEmail, displayName = Nothing}) + forM_ [a, b] \u -> do + tcid <- genTotpCredentialId + t <- now + _ <- upsertTotpEnrollment NewTotpCredential {totpCredentialId = tcid, userId = u.userId, secret = TotpSecret totpRawSecret, createdAt = t} + pure () + pure (a, b) + let aliceId = "'" <> Text.pack (show (userIdToUUID alice.userId)) <> "'" + bobId = "'" <> Text.pack (show (userIdToUUID bob.userId)) <> "'" + restore = execSql pool ("UPDATE shomei.shomei_totp_credentials SET secret_enc = saved.secret_enc, envelope_version = 1 FROM saved WHERE shomei_totp_credentials.user_id = saved.user_id") + -- Persist snapshots in an ordinary fixture table because pool checkouts may differ. + execSql pool "CREATE TABLE saved AS SELECT * FROM shomei.shomei_totp_credentials" + forM_ [False, True] \confirmed -> do + when confirmed $ execSql pool "UPDATE shomei.shomei_totp_credentials SET confirmed_at = created_at" + execSql pool ("UPDATE shomei.shomei_totp_credentials SET secret_enc = (SELECT secret_enc FROM saved WHERE user_id = " <> aliceId <> ") WHERE user_id = " <> bobId) + transplanted <- runApp pool (findTotpByUser bob.userId) + assertBool "transplanted secret rejected" (isLeft transplanted) + restore + forM_ [0, 6, 18, 53] \offset -> do + execSql pool ("UPDATE shomei.shomei_totp_credentials SET secret_enc = set_byte(secret_enc, " <> Text.pack (show (offset :: Int)) <> ", get_byte(secret_enc, " <> Text.pack (show offset) <> ") # 1)") + tampered <- runApp pool (findTotpByUser alice.userId) + assertBool "marker/nonce/ciphertext/tag tampering rejected" (isLeft tampered) + restore + execSql pool "UPDATE shomei.shomei_totp_credentials SET envelope_version = 0" + legacy <- runApp pool (findTotpByUser alice.userId) + assertBool "strict runtime never sniffs a legacy version" (isLeft legacy) + restore + changedId <- genTotpCredentialId + let newId = "'" <> Text.pack (show (totpCredentialIdToUUID changedId)) <> "'" + execSql pool ("UPDATE shomei.shomei_totp_credentials SET totp_credential_id = " <> newId <> " WHERE user_id = " <> aliceId) + relabeled <- runApp pool (findTotpByUser alice.userId) + assertBool "credential-id mutation rejected" (isLeft relabeled) + execSql pool "UPDATE shomei.shomei_totp_credentials SET totp_credential_id = saved.totp_credential_id FROM saved WHERE shomei_totp_credentials.user_id = saved.user_id" + replacement <- + expectApp =<< runApp pool do + tcid <- genTotpCredentialId + t <- now + c <- upsertTotpEnrollment NewTotpCredential {totpCredentialId = tcid, userId = alice.userId, secret = TotpSecret totpRawSecret, createdAt = t} + found <- findTotpByUser alice.userId + pure (c, found) + fmap (\TotpCredential {totpCredentialId} -> totpCredentialId) (snd replacement) + @?= Just (case fst replacement of TotpCredential {totpCredentialId} -> totpCredentialId) + +-- Legacy format is deliberately constructed only in tests, never through a runtime writer. +legacyTotpBlob :: ByteString +legacyTotpBlob = case cipherInit (BS.replicate 32 7) >>= (\cipher -> aeadInit AEAD_GCM cipher (BS.replicate 12 3)) :: CryptoFailable (AEAD AES256) of + CryptoFailed _ -> error "test-only AES initialization failed" + CryptoPassed st -> + let (tag, ciphertext) = aeadSimpleEncrypt st (BS.empty :: ByteString) totpRawSecret 16 + in BS.replicate 12 3 <> ciphertext <> BA.convert (unAuthTag tag) + +testTotpEnvelopeConversion :: TestTree +testTotpEnvelopeConversion = + testCase "totp conversion is keyless-checkable, resumable, strict and nonce-fresh" $ withDb \pool -> do + uid <- + expectApp =<< runApp pool do + a <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing}) + tcid <- genTotpCredentialId + t <- now + _ <- upsertTotpEnrollment NewTotpCredential {totpCredentialId = tcid, userId = a.userId, secret = TotpSecret totpRawSecret, createdAt = t} + pure a.userId + let seed = + preparable + "UPDATE shomei.shomei_totp_credentials SET secret_enc = $1, envelope_version = 0" + (E.param (E.nonNullable E.bytea)) + D.noResult + _ <- expectRight =<< Pool.use pool (Session.statement legacyTotpBlob seed) + checkTotpEnvelopeVersions pool >>= (@?= Right (1, 0)) + wrongKey <- expectRight (totpEncryptionKeyFromBytes (BS.replicate 32 8)) + failed <- migrateTotpEnvelopeBatch wrongKey pool + assertBool "wrong key fails without changing rows" (isLeft failed) + checkTotpEnvelopeVersions pool >>= (@?= Right (1, 0)) + execSql pool "UPDATE shomei.shomei_totp_credentials SET secret_enc = set_byte(secret_enc, 47, get_byte(secret_enc, 47) # 1)" + corrupt <- migrateTotpEnvelopeBatch testTotpKey pool + assertBool "invalid legacy tag leaves the row unchanged" (isLeft corrupt) + checkTotpEnvelopeVersions pool >>= (@?= Right (1, 0)) + _ <- expectRight =<< Pool.use pool (Session.statement legacyTotpBlob seed) + migrateTotpEnvelopeBatch testTotpKey pool >>= (@?= Right 1) + checkTotpEnvelopeVersions pool >>= (@?= Right (0, 0)) + migrateTotpEnvelopeBatch testTotpKey pool >>= (@?= Right 0) + actual <- expectApp =<< runApp pool (findTotpByUser uid) + fmap tcSecret actual @?= Just (TotpSecret totpRawSecret) + stored <- scalarBytea pool "SELECT secret_enc FROM shomei.shomei_totp_credentials LIMIT 1" + assertBool "conversion uses a fresh nonce" (BS.take 12 (BS.drop 6 stored) /= BS.take 12 legacyTotpBlob) + +testTotpConversionBatches :: TestTree +testTotpConversionBatches = + testCase "totp conversion resumes after 100 rows and preserves pending/confirmed state" $ withDb \pool -> do + _ <- + expectApp =<< runApp pool do + forM_ [1 .. 101 :: Int] \i -> do + lid <- either (error . show) pure (mkLoginId ("totp-batch-" <> Text.pack (show i))) + u <- createUser (NewUser {loginId = lid, email = Nothing, displayName = Nothing}) + tcid <- genTotpCredentialId + t <- now + _ <- upsertTotpEnrollment NewTotpCredential {totpCredentialId = tcid, userId = u.userId, secret = TotpSecret totpRawSecret, createdAt = t} + when (even i) (confirmTotp tcid t) + let seed = + preparable + "UPDATE shomei.shomei_totp_credentials SET secret_enc = $1, envelope_version = 0" + (E.param (E.nonNullable E.bytea)) + D.noResult + _ <- expectRight =<< Pool.use pool (Session.statement legacyTotpBlob seed) + migrateTotpEnvelopeBatch testTotpKey pool >>= (@?= Right 100) + checkTotpEnvelopeVersions pool >>= (@?= Right (1, 0)) + -- An interruption here requires no retained process state or cursor. + migrateTotpEnvelopeBatch testTotpKey pool >>= (@?= Right 1) + checkTotpEnvelopeVersions pool >>= (@?= Right (0, 0)) + scalarInt pool "SELECT count(*) FROM shomei.shomei_totp_credentials WHERE confirmed_at IS NOT NULL" >>= (@?= 50) + scalarInt pool "SELECT count(DISTINCT substring(secret_enc FROM 7 FOR 12)) FROM shomei.shomei_totp_credentials" >>= (@?= 101) + +testTotpConvertedFactor :: TestTree +testTotpConvertedFactor = + testCase "totp factor completion succeeds with the same secret before and after offline conversion" $ withDb \pool -> do + u <- + expectApp =<< runAppAtTime t0 pool do + a <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing}) + tcid <- genTotpCredentialId + _ <- upsertTotpEnrollment NewTotpCredential {totpCredentialId = tcid, userId = a.userId, secret = TotpSecret totpRawSecret, createdAt = t0} + confirmTotp tcid t0 + pure a + let completeAt ts = do + result <- runAppAtTime ts pool do + (cid, _, methods) <- prepareMfaChallenge cfg u ts + liftIO (assertBool "TOTP offered" ("totp" `elem` methods)) + completeMfa + cfg + (ProofContext (ClientIp "test-ip") AccountKey) + cid + (MfaTotp (totpCode 6 (TotpSecret totpRawSecret) (totpCounter ts))) + _ <- expectApp result >>= expectRight + pure () + completeAt t0 + let seed = + preparable + "UPDATE shomei.shomei_totp_credentials SET secret_enc = $1, envelope_version = 0" + (E.param (E.nonNullable E.bytea)) + D.noResult + _ <- expectRight =<< Pool.use pool (Session.statement legacyTotpBlob seed) + migrateTotpEnvelopeBatch testTotpKey pool >>= (@?= Right 1) + completeAt (addUTCTime 30 t0) + +testTotpConversionConflict :: TestTree +testTotpConversionConflict = + testCase "totp converter CAS preserves enrollment changed after its snapshot" $ + withShomeiMigratedDatabase \connStr -> do + pool <- acquirePool 4 10 30000 connStr + gatePool <- acquirePool 1 10 30000 connStr + u <- + expectApp =<< runApp pool do + a <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing}) + tcid <- genTotpCredentialId + t <- now + _ <- upsertTotpEnrollment NewTotpCredential {totpCredentialId = tcid, userId = a.userId, secret = TotpSecret totpRawSecret, createdAt = t} + pure a + let seed = + preparable + "UPDATE shomei.shomei_totp_credentials SET secret_enc = $1, envelope_version = 0" + (E.param (E.nonNullable E.bytea)) + D.noResult + awaitLock sql = + let loop n = do + count <- scalarInt pool sql + if count > 0 + then pure () + else + if n == (0 :: Int) then assertFailure "advisory-lock barrier not reached" else threadDelay 10000 >> loop (n - 1) + in loop 500 + _ <- expectRight =<< Pool.use pool (Session.statement legacyTotpBlob seed) + -- A separate one-connection pool holds a session lock that gates the converter lock. + execSql gatePool "SELECT pg_advisory_lock(1936224116, 2)" + blocker <- newEmptyMVar + _ <- forkIO $ do + result <- Pool.use pool (Session.script "BEGIN; SELECT pg_advisory_xact_lock(1936224116, 1); SELECT pg_advisory_xact_lock(1936224116, 2); COMMIT") + putMVar blocker result + awaitLock "SELECT count(*) FROM pg_locks WHERE locktype = 'advisory' AND classid = 1936224116 AND objid = 1 AND granted" + converted <- newEmptyMVar + _ <- forkIO (putMVar converted =<< migrateTotpEnvelopeBatch testTotpKey pool) + awaitLock "SELECT count(*) FROM pg_locks WHERE locktype = 'advisory' AND classid = 1936224116 AND objid = 1 AND NOT granted" + fresh <- + expectApp =<< runApp pool do + tcid <- genTotpCredentialId + t <- now + upsertTotpEnrollment NewTotpCredential {totpCredentialId = tcid, userId = u.userId, secret = TotpSecret "new enrollment secret", createdAt = t} + execSql gatePool "SELECT pg_advisory_unlock(1936224116, 2)" + _ <- expectRight =<< takeMVar blocker + takeMVar converted >>= (@?= Right 0) + stored <- expectApp =<< runApp pool (findTotpByUser u.userId) + fmap tcSecret stored @?= Just (tcSecret fresh) + Pool.release gatePool + Pool.release pool + -- | The recovery-code store's contract: a replaced set is the live set, consumption is a -- consume-once compare-and-set, the unused count tracks it, and regeneration drops the old set. testRecoveryCodeCasAndReplace :: TestTree @@ -1058,9 +1288,9 @@ alice <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing}) bob <- createUser (NewUser {loginId = bobLogin, email = Just bobEmail, displayName = Nothing}) t <- now - s1 <- createSession (NewSession {userId = alice.userId, createdAt = t, expiresAt = addUTCTime 3600 t, actor = Nothing, oauthClientId = Nothing, kind = InteractiveSession, grantedScopes = Set.empty, authenticatedAt = t}) - s2 <- createSession (NewSession {userId = alice.userId, createdAt = addUTCTime 1 t, expiresAt = addUTCTime 3600 t, actor = Nothing, oauthClientId = Nothing, kind = InteractiveSession, grantedScopes = Set.empty, authenticatedAt = addUTCTime 1 t}) - _ <- createSession (NewSession {userId = bob.userId, createdAt = t, expiresAt = addUTCTime 3600 t, actor = Nothing, oauthClientId = Nothing, kind = InteractiveSession, grantedScopes = Set.empty, authenticatedAt = t}) + s1 <- createSession (NewSession {userId = alice.userId, createdAt = t, expiresAt = addUTCTime 3600 t, actor = Nothing, oauthClientId = Nothing, kind = InteractiveSession, grantedScopes = Set.empty, authenticatedAt = t, remembered = False}) + s2 <- createSession (NewSession {userId = alice.userId, createdAt = addUTCTime 1 t, expiresAt = addUTCTime 3600 t, actor = Nothing, oauthClientId = Nothing, kind = InteractiveSession, grantedScopes = Set.empty, authenticatedAt = addUTCTime 1 t, remembered = False}) + _ <- createSession (NewSession {userId = bob.userId, createdAt = t, expiresAt = addUTCTime 3600 t, actor = Nothing, oauthClientId = Nothing, kind = InteractiveSession, grantedScopes = Set.empty, authenticatedAt = t, remembered = False}) revokeSession s1.sessionId t aliceSessions <- listSessionsForUser alice.userId pure (s1, s2, aliceSessions) @@ -1154,11 +1384,13 @@ result <- runApp pool do u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing}) t <- now - s <- createSession (NewSession {userId = u.userId, createdAt = t, expiresAt = addUTCTime 3600 t, actor = Nothing, oauthClientId = Nothing, kind = InteractiveSession, grantedScopes = Set.empty, authenticatedAt = t}) + s <- createSession (NewSession {userId = u.userId, createdAt = t, expiresAt = addUTCTime 3600 t, actor = Nothing, oauthClientId = Nothing, kind = InteractiveSession, grantedScopes = Set.empty, authenticatedAt = t, remembered = False}) revokeSession s.sessionId t + revokeSession s.sessionId (addUTCTime 60 t) findSessionById s.sessionId found <- expectApp result fmap (.status) found @?= Just SessionRevoked + fmap (.revokedAt) found @?= fmap (Just . (.createdAt)) found testSessionActorRoundTrip :: TestTree testSessionActorRoundTrip = testCase "create delegated session persists actor" $ withDb \pool -> do @@ -1176,10 +1408,11 @@ oauthClientId = Nothing, kind = DelegatedSession, grantedScopes = Set.empty, - authenticatedAt = t + authenticatedAt = t, + remembered = False } ) - normal <- createSession (NewSession {userId = subject.userId, createdAt = t, expiresAt = addUTCTime 3600 t, actor = Nothing, oauthClientId = Nothing, kind = InteractiveSession, grantedScopes = Set.empty, authenticatedAt = t}) + normal <- createSession (NewSession {userId = subject.userId, createdAt = t, expiresAt = addUTCTime 3600 t, actor = Nothing, oauthClientId = Nothing, kind = InteractiveSession, grantedScopes = Set.empty, authenticatedAt = t, remembered = False}) foundDelegated <- findSessionById delegated.sessionId foundNormal <- findSessionById normal.sessionId pure (operator.userId, foundDelegated, foundNormal) @@ -1192,9 +1425,9 @@ result <- runApp pool do subject <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing}) t <- now - interactive <- createSession (NewSession {userId = subject.userId, createdAt = t, expiresAt = addUTCTime 3600 t, actor = Nothing, oauthClientId = Nothing, kind = InteractiveSession, grantedScopes = Set.empty, authenticatedAt = t}) - machine <- createSession (NewSession {userId = subject.userId, createdAt = t, expiresAt = addUTCTime 3600 t, actor = Nothing, oauthClientId = Nothing, kind = MachineSession, grantedScopes = Set.empty, authenticatedAt = t}) - delegated <- createSession (NewSession {userId = subject.userId, createdAt = t, expiresAt = addUTCTime 3600 t, actor = Just subject.userId, oauthClientId = Nothing, kind = DelegatedSession, grantedScopes = Set.empty, authenticatedAt = t}) + interactive <- createSession (NewSession {userId = subject.userId, createdAt = t, expiresAt = addUTCTime 3600 t, actor = Nothing, oauthClientId = Nothing, kind = InteractiveSession, grantedScopes = Set.empty, authenticatedAt = t, remembered = False}) + machine <- createSession (NewSession {userId = subject.userId, createdAt = t, expiresAt = addUTCTime 3600 t, actor = Nothing, oauthClientId = Nothing, kind = MachineSession, grantedScopes = Set.empty, authenticatedAt = t, remembered = False}) + delegated <- createSession (NewSession {userId = subject.userId, createdAt = t, expiresAt = addUTCTime 3600 t, actor = Just subject.userId, oauthClientId = Nothing, kind = DelegatedSession, grantedScopes = Set.empty, authenticatedAt = t, remembered = False}) foundInteractive <- findSessionById interactive.sessionId foundMachine <- findSessionById machine.sessionId foundDelegated <- findSessionById delegated.sessionId @@ -1221,7 +1454,8 @@ oauthClientId = Just "oauthclient_roundtrip", kind = InteractiveSession, grantedScopes = granted, - authenticatedAt = authenticated + authenticatedAt = authenticated, + remembered = False } found <- findSessionById session.sessionId pure (session.sessionId, authenticated, found) @@ -1251,16 +1485,61 @@ defaulted <- scalarInt pool "SELECT count(*) FROM shomei.shomei_sessions WHERE granted_scopes = '{}'::text[]" defaulted @?= 1 -testSessionKindNullReadsInteractive :: TestTree -testSessionKindNullReadsInteractive = testCase "a session row whose kind is NULL reads as interactive" $ withDb \pool -> do +testSessionRememberedRoundTrip :: TestTree +testSessionRememberedRoundTrip = testCase "a session's remembered flag round-trips; rows from before the column read remembered" $ withDb \pool -> do created <- runApp pool do user <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing}) t <- now - createSession (NewSession {userId = user.userId, createdAt = t, expiresAt = addUTCTime 3600 t, actor = Nothing, oauthClientId = Nothing, kind = InteractiveSession, grantedScopes = Set.empty, authenticatedAt = t}) + let new remembered = + NewSession + { userId = user.userId, + createdAt = t, + expiresAt = addUTCTime 3600 t, + actor = Nothing, + oauthClientId = Nothing, + kind = InteractiveSession, + grantedScopes = Set.empty, + authenticatedAt = t, + remembered + } + rememberedSession <- createSession (new True) + forgottenSession <- createSession (new False) + (,) <$> findSessionById rememberedSession.sessionId <*> findSessionById forgottenSession.sessionId + (foundRemembered, foundForgotten) <- expectApp created + fmap (.remembered) foundRemembered @?= Just True + fmap (.remembered) foundForgotten @?= Just False + + execSql + pool + """ + INSERT INTO shomei.shomei_sessions + (session_id, user_id, status, created_at, expires_at, kind) + SELECT + '00000000-0000-4000-8000-000000000053'::uuid, + user_id, + 'active', + now(), + now() + interval '1 hour', + 'interactive' + FROM shomei.shomei_users + LIMIT 1 + """ + defaulted <- scalarInt pool "SELECT count(*) FROM shomei.shomei_sessions WHERE remembered" + defaulted @?= 2 + +testSessionKindNullFailsClosed :: TestTree +testSessionKindNullFailsClosed = testCase "NULL session provenance is rejected by the schema and fails closed after constraint bypass" $ withDb \pool -> do + created <- runApp pool do + user <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing}) + t <- now + createSession (NewSession {userId = user.userId, createdAt = t, expiresAt = addUTCTime 3600 t, actor = Nothing, oauthClientId = Nothing, kind = InteractiveSession, grantedScopes = Set.empty, authenticatedAt = t, remembered = False}) session <- expectApp created - execSql pool "UPDATE shomei.shomei_sessions SET kind = NULL" - found <- expectApp =<< runApp pool (findSessionById session.sessionId) - fmap (.kind) found @?= Just InteractiveSession + execSqlExpectState pool "23502" "UPDATE shomei.shomei_sessions SET kind = NULL" + execSql pool "ALTER TABLE shomei.shomei_sessions ALTER COLUMN kind DROP NOT NULL; UPDATE shomei.shomei_sessions SET kind = NULL" + found <- runApp pool (findSessionById session.sessionId) + case found of + Left (Err.InternalAuthError _) -> pure () + _ -> assertFailure "missing provenance must never decode as interactive" -- | Pins the compare-and-swap semantics of the @UPDATE … AND status = 'active' RETURNING@ -- statement: the first mark wins and stamps @used_at@, a second mark of the same token loses @@ -1271,7 +1550,7 @@ result <- runApp pool do u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing}) t <- now - s <- createSession (NewSession {userId = u.userId, createdAt = t, expiresAt = addUTCTime 3600 t, actor = Nothing, oauthClientId = Nothing, kind = InteractiveSession, grantedScopes = Set.empty, authenticatedAt = t}) + s <- createSession (NewSession {userId = u.userId, createdAt = t, expiresAt = addUTCTime 3600 t, actor = Nothing, oauthClientId = Nothing, kind = InteractiveSession, grantedScopes = Set.empty, authenticatedAt = t, remembered = False}) h <- hashRefreshToken (RefreshToken "token-1") persisted <- createRefreshToken @@ -1554,7 +1833,9 @@ -- not back into this one, so the workflow still talks to PostgreSQL and there is no recursion. -- Both constructors are counted: a @RunSession@ is one pool checkout for one -- statement, and a @RunTransaction@ is one pool checkout for the whole transaction. That is --- exactly the quantity these tests pin — network round-trips, not statements. +-- exactly the quantity these tests pin — logical Database port operations. A transaction +-- is one operation even when it contains several SQL statements and budget-setting queries; +-- these counters are not a wire-level network round-trip measurement. countingDatabase :: (Database :> es, IOE :> es) => IORef Int -> Eff es a -> Eff es a countingDatabase counter = interpose \_env op -> do liftIO (atomicModifyIORef' counter \n -> (n + 1, ())) @@ -1562,7 +1843,7 @@ RunSession sess -> send (RunSession sess) RunTransaction t -> send (RunTransaction t) --- | A successful password login costs exactly ten database round-trips: +-- | A successful password login costs exactly ten database operations: -- -- 1. @countRecentFailuresByIp@ (per-IP throttle) -- 2. @recordLoginFailure@ (ONE transaction: advisory lock + provisional insert + count) @@ -1577,7 +1858,7 @@ -- -- There is deliberately no @clearAccountLockout@: the record transaction found no standing row -- and did not reach the account threshold. --- Password verification and access-token signing are CPU-only and cost no round-trip. +-- Password verification and access-token signing are CPU-only and cost no database operation. -- -- Step 7 was added by EP-7's generalized MFA gate: login now challenges for /any/ enrolled -- second factor, so it reads the TOTP credential alongside the passkey count. It is one @@ -1592,32 +1873,32 @@ -- role set to its permission union with a single @role = ANY(...)@ query. It runs once per mint, -- on the same principle as step 9 (resolve at mint, never at verification). -- --- If this number drifts, something added a round-trip to the login path. Find it before +-- If this number drifts, something added a database operation to the login path. Find it before -- changing the constant. testLoginRoundTripBudget :: TestTree -testLoginRoundTripBudget = testCase "a successful login costs exactly 10 database round-trips" $ withDb \pool -> do +testLoginRoundTripBudget = testCase "a successful login costs exactly 10 database operations" $ withDb \pool -> do signupRes <- runApp pool (signup cfg (SignupCommand aliceLogin (Just aliceEmail) strongPw Nothing)) _ <- expectApp signupRes >>= expectRight counter <- newIORef 0 let ctx = ClientContext (ClientIp "10.0.0.1") (AccountKey (loginIdText aliceLogin)) - loginRes <- runApp pool (countingDatabase counter (login cfg ctx (LoginCommand aliceLogin strongPw))) + loginRes <- runApp pool (countingDatabase counter (login cfg ctx (LoginCommand aliceLogin strongPw False))) _ <- expectApp loginRes >>= expectRight readIORef counter >>= (@?= 10) --- | A wrong password costs four checkouts: per-IP count, atomic record-and-count transaction, +-- | A wrong password costs four database operations: per-IP count, atomic record-and-count transaction, -- credential lookup, and the @LoginFailed@ audit insert. The user row is only needed after the -- password succeeds, and hashing itself is CPU-only. testFailedLoginRoundTripBudget :: TestTree -testFailedLoginRoundTripBudget = testCase "a wrong password costs exactly 4 database round-trips" $ withDb \pool -> do +testFailedLoginRoundTripBudget = testCase "a wrong password costs exactly 4 database operations" $ withDb \pool -> do signupRes <- runApp pool (signup cfg (SignupCommand aliceLogin (Just aliceEmail) strongPw Nothing)) _ <- expectApp signupRes >>= expectRight counter <- newIORef 0 let ctx = ClientContext (ClientIp "10.0.0.1") (AccountKey (loginIdText aliceLogin)) - loginRes <- runApp pool (countingDatabase counter (login cfg ctx (LoginCommand aliceLogin (PlainPassword "wrong")))) + loginRes <- runApp pool (countingDatabase counter (login cfg ctx (LoginCommand aliceLogin (PlainPassword "wrong") False))) expectApp loginRes >>= (@?= Left InvalidCredentials) readIORef counter >>= (@?= 4) --- | A token refresh costs exactly five database round-trips: +-- | A token refresh costs exactly five database operations: -- -- 1. @findRefreshTokenByHash@ -- 2. @findSessionById@ @@ -1626,12 +1907,12 @@ -- 5. @permissionsForRoles@ (the permissions claim, via @buildEnrichedClaims@ — EP-9) -- -- The user row is not read because @emailVerificationRequired@ is off in 'cfg'; turning it on --- adds a further round-trip by design. +-- adds a further database operation by design. -- -- Step 4 is what makes a role change take effect on refresh rather than only at the next login; -- step 5 (EP-9) does the same for a permission re-wiring or a grant expiry. testRefreshRoundTripBudget :: TestTree -testRefreshRoundTripBudget = testCase "a token refresh costs exactly 5 database round-trips" $ withDb \pool -> do +testRefreshRoundTripBudget = testCase "a token refresh costs exactly 5 database operations" $ withDb \pool -> do signupRes <- runApp pool (signup cfg (SignupCommand aliceLogin (Just aliceEmail) strongPw Nothing)) (_, pair) <- expectApp signupRes >>= expectRight counter <- newIORef 0 @@ -1639,12 +1920,12 @@ _ <- expectApp refreshRes >>= expectRight readIORef counter >>= (@?= 5) --- | Logout costs two database round-trips: one session lookup and one transaction that CASes +-- | Logout costs two database operations: one session lookup and one transaction that CASes -- the session, revokes its refresh tokens, and inserts the audit event. testLogoutRoundTripBudget :: TestTree -testLogoutRoundTripBudget = testCase "logout costs exactly 2 database round-trips" $ withDb \pool -> do +testLogoutRoundTripBudget = testCase "logout costs exactly 2 database operations" $ withDb \pool -> do signupRes <- runApp pool (signup cfg (SignupCommand aliceLogin (Just aliceEmail) strongPw Nothing)) - (user, _) <- expectApp signupRes >>= expectRight + (user, pair) <- expectApp signupRes >>= expectRight sessionsRes <- runApp pool (listSessionsForUser user.userId) sessions <- expectApp sessionsRes sid <- case sessions of @@ -1654,11 +1935,15 @@ logoutRes <- runApp pool (countingDatabase counter (logout cfg (LogoutCommand sid))) _ <- expectApp logoutRes >>= expectRight readIORef counter >>= (@?= 2) + replay <- expectApp =<< runApp pool (refresh cfg (RefreshCommand pair.refreshToken)) + replay @?= Left Err.SessionRevoked + scalarInt pool "SELECT count(*) FROM shomei.shomei_auth_events WHERE event_type='session_revoked'" >>= (@?= 1) + scalarInt pool "SELECT count(*) FROM shomei.shomei_auth_events WHERE event_type='refresh_token_reuse_detected'" >>= (@?= 0) --- | Password-reset confirmation costs three database round-trips: token lookup, user lookup, +-- | Password-reset confirmation costs three database operations: token lookup, user lookup, -- and one transaction for the consume/hash/revocation/event tail. testPasswordResetRoundTripBudget :: TestTree -testPasswordResetRoundTripBudget = testCase "password reset confirmation costs exactly 3 database round-trips" $ withDb \pool -> do +testPasswordResetRoundTripBudget = testCase "password reset confirmation costs exactly 3 database operations" $ withDb \pool -> do notifications <- newIORef [] signupRes <- runAppWithNotifications notifications pool (signup cfg (SignupCommand aliceLogin (Just aliceEmail) strongPw Nothing)) _ <- expectApp signupRes >>= expectRight @@ -1736,7 +2021,7 @@ siblingRes <- runAppWithNotifications notifications pool (confirmPasswordReset cfg (ConfirmPasswordReset second (PlainPassword "correct horse battery staple three"))) sibling <- expectApp siblingRes sibling @?= Left PasswordResetTokenInvalid - loginRes <- runAppWithNotifications notifications pool (login cfg (ClientContext (ClientIp "test-ip") (AccountKey (loginIdText aliceLogin))) (LoginCommand aliceLogin (PlainPassword "correct horse battery staple two"))) + loginRes <- runAppWithNotifications notifications pool (login cfg (ClientContext (ClientIp "test-ip") (AccountKey (loginIdText aliceLogin))) (LoginCommand aliceLogin (PlainPassword "correct horse battery staple two") False)) _ <- expectApp loginRes >>= expectRight oldRefreshRes <- runAppWithNotifications notifications pool (refresh cfg (RefreshCommand pair.refreshToken)) oldRefresh <- expectApp oldRefreshRes @@ -1839,7 +2124,7 @@ seeded <- runAppAtTime t0 pool (signup lockCfg (SignupCommand aliceLogin (Just aliceEmail) strongPw Nothing)) _ <- expectApp seeded >>= expectRight let ctx = ClientContext (ClientIp "10.0.0.9") (AccountKey (loginIdText aliceLogin)) - badLogin = login lockCfg ctx (LoginCommand aliceLogin (PlainPassword "wrong")) + badLogin = login lockCfg ctx (LoginCommand aliceLogin (PlainPassword "wrong") False) _ <- runAppAtTime t0 pool badLogin >>= expectApp _ <- runAppAtTime t0 pool badLogin >>= expectApp r3 <- runAppAtTime t0 pool badLogin >>= expectApp @@ -1847,10 +2132,10 @@ locked <- scalarInt pool "SELECT count(*) FROM shomei.shomei_account_lockouts WHERE locked_until IS NOT NULL" locked @?= 1 -- The correct password while still locked returns the SAME generic error (no leak). - denied <- runAppAtTime t0 pool (login lockCfg ctx (LoginCommand aliceLogin strongPw)) >>= expectApp + denied <- runAppAtTime t0 pool (login lockCfg ctx (LoginCommand aliceLogin strongPw False)) >>= expectApp denied @?= Left InvalidCredentials -- After the cooldown (15 min default) the correct password succeeds and clears the lockout. - ok <- runAppAtTime (addUTCTime (16 * 60) t0) pool (login lockCfg ctx (LoginCommand aliceLogin strongPw)) >>= expectApp + ok <- runAppAtTime (addUTCTime (16 * 60) t0) pool (login lockCfg ctx (LoginCommand aliceLogin strongPw False)) >>= expectApp _ <- expectRight ok remaining <- scalarInt pool "SELECT count(*) FROM shomei.shomei_account_lockouts" remaining @?= 0 @@ -2077,9 +2362,8 @@ unknown <- consumeAuthorizationCode "hash-nope" t -- One second past its expiry: the row is there, but it must not consume. expired <- consumeAuthorizationCode "hash-expired" (addUTCTime 61 t) - deleteExpiredAuthorizationCodes (addUTCTime 61 t) - pure (first', sid, bound, replay, unknown, expired, scopes) - (first', sid, bound, replay, unknown, expired, scopes) <- expectApp result + pure (first', sid, bound, replay, unknown, expired, scopes, t) + (first', sid, bound, replay, unknown, expired, scopes, writtenAt) <- expectApp result -- The consume returns every binding the exchange will re-check, and stamps consumed_at. case first' of Nothing -> assertFailure "the first consume must return the code" @@ -2095,8 +2379,9 @@ assertBool "a replay must miss" (isNothing replay) assertBool "an unknown hash must miss" (isNothing unknown) assertBool "an expired code must miss" (isNothing expired) - -- The consumed row survives the consume (only the sweeper deletes), and the sweep above - -- removed both rows because both were past their expiry by then. + -- Only the bounded maintenance path deletes expired codes, including consumed rows. + report <- expectSweep =<< sweepOnce pool defaultSweepConfig {batchSize = 1, ceremonyGraceMinutes = 0} (addUTCTime 61 writtenAt) + report.authorizationCodesDeleted @?= 2 remaining <- scalarInt pool "SELECT count(*) FROM shomei.shomei_oauth_authorization_codes" remaining @?= 0 @@ -2145,12 +2430,31 @@ consumedRows <- scalarInt pool "SELECT count(*) FROM shomei.shomei_oauth_authorization_codes WHERE consumed_at IS NOT NULL" consumedRows @?= 1 +testPasskeyQuotaRace :: TestTree +testPasskeyQuotaRace = testCase "passkey quota: eight database racers spend one final slot" $ withDb \pool -> do + u <- expectApp =<< runApp pool (createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})) + gate <- newEmptyMVar + workers <- forM [1 .. 8 :: Int] \i -> do + done <- newEmptyMVar + _ <- forkIO do + readMVar gate + result <- runApp pool do + t <- now + createPasskey 1 ((newPasskey u t) {credentialId = WebAuthnCredentialId (BS.pack [fromIntegral i])}) + putMVar done result + pure done + putMVar gate () + results <- mapM (expectApp <=< takeMVar) workers + length [() | Right _ <- results] @?= 1 + length [() | Left Err.PasskeyLimitReached <- results] @?= 7 + scalarInt pool "SELECT count(*) FROM shomei.shomei_webauthn_credentials" >>= (@?= 1) + testPasskeyCreateAndFind :: TestTree testPasskeyCreateAndFind = testCase "passkey store: create + find by user/credential-id/user-handle" $ withDb \pool -> do result <- runApp pool do u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing}) t <- now - created <- createPasskey (newPasskey u t) + created <- either (error . show) pure =<< createPasskey 20 (newPasskey u t) byUser <- findPasskeysByUser u.userId byCred <- findPasskeyByCredentialId (WebAuthnCredentialId "cred-1") byHandle <- findPasskeysByUserHandle (UserHandle "uh-1") @@ -2172,7 +2476,7 @@ result <- runApp pool do u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing}) t <- now - created <- createPasskey (newPasskey u t) + created <- either (error . show) pure =<< createPasskey 20 (newPasskey u t) let pid = pkPasskeyId created counterAdvanced <- updatePasskeySignCounter pid (SignatureCounter 42) t afterUpdate <- findPasskeyByCredentialId (WebAuthnCredentialId "cred-1") @@ -2197,7 +2501,7 @@ result <- runApp pool do u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing}) t <- now - created <- createPasskey (newPasskey u t) + created <- either (error . show) pure =<< createPasskey 20 (newPasskey u t) let pid = pkPasskeyId created zeroToZero <- updatePasskeySignCounter pid (SignatureCounter 0) t first <- updatePasskeySignCounter pid (SignatureCounter 42) t @@ -2218,7 +2522,7 @@ seeded <- runApp pool do u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing}) t <- now - created <- createPasskey (newPasskey u t) + created <- either (error . show) pure =<< createPasskey 20 (newPasskey u t) pure (pkPasskeyId created, t) (pid, t) <- expectApp seeded gate <- newEmptyMVar @@ -2683,3 +2987,511 @@ latestResetToken = \case PasswordResetRequested {token = raw} : _ -> pure raw _ -> assertFailure "expected password-reset notification" + +testFieldBudgets :: TestTree +testFieldBudgets = testCase "new-write field budgets preserve legacy rows and security updates" $ withDb \pool -> do + -- Model an installed pre-budget row; trigger bypass exists only in this throwaway fixture. + execSql + pool + """ + BEGIN; + ALTER TABLE shomei.shomei_users DISABLE TRIGGER enforce_field_budgets; + INSERT INTO shomei.shomei_users(user_id, login_id, email, display_name, status, created_at, updated_at) + VALUES ('11111111-1111-1111-1111-111111111111', repeat('界',257), repeat('界',100)||'@a.b', repeat('界',257), 'active', now(), now()); + ALTER TABLE shomei.shomei_users ENABLE TRIGGER enforce_field_budgets; + COMMIT; + """ + rows <- expectApp =<< runApp pool (listUsers emptyUserListQuery) + length rows @?= 1 + let user = head rows + Text.length (loginIdText user.loginId) @?= 257 + changed <- expectApp =<< runApp pool (updateUserStatus user.userId [UserActive] UserSuspended t0) + changed @?= True + execSqlExpectState pool "22001" "UPDATE shomei.shomei_users SET login_id = repeat('a',258)" + execSqlExpectState pool "22001" "UPDATE shomei.shomei_users SET email = repeat('é',126)||'@a.b'" + execSqlExpectState pool "22001" "UPDATE shomei.shomei_users SET display_name = repeat('界',258)" + execSql pool "UPDATE shomei.shomei_users SET login_id = repeat('🔑',256), email = repeat('é',125)||'@a.b', display_name = repeat('🔑',256)" + execSqlExpectState pool "22001" "INSERT INTO shomei.shomei_roles(role, created_at) VALUES (repeat('a',129),now())" + execSql pool "INSERT INTO shomei.shomei_roles(role, created_at) VALUES (repeat('界',128),now())" + +testRetryBudgets :: TestTree +testRetryBudgets = testCase "transaction retries classify only rollback-safe states and stop at three attempts" $ withDb \pool -> do + execSql pool "CREATE SEQUENCE retry_attempts; CREATE TABLE retry_writes(value integer)" + let run policy body = runEff . runDatabasePoolWith policy pool $ runTransaction body + failure code = Tx.statement () (preparable ("DO $$ BEGIN INSERT INTO retry_writes VALUES(1); PERFORM nextval('retry_attempts'); RAISE EXCEPTION 'injected' USING ERRCODE = '" <> TE.decodeUtf8 code <> "'; END $$") E.noParams D.noResult) + forM_ ["40001", "40P01", "23505", "08006"] $ \code -> do + execSql pool "ALTER SEQUENCE retry_attempts RESTART WITH 1" + result <- run (TransactionRetryPolicy 3 1000) (failure code) + assertBool "injected transaction fails" (isLeft result) + count <- scalarInt pool "SELECT last_value FROM retry_attempts" + count @?= if code == "40001" || code == "40P01" then 3 else 1 + scalarInt pool "SELECT count(*) FROM retry_writes" >>= (@?= 0) + scalarInt pool "SELECT 1::bigint" >>= (@?= 1) + retryableTransactionError Pool.AcquisitionTimeoutUsageError @?= False + retryableTransactionError (Pool.ConnectionUsageError (Hasql.OtherConnectionError "ambiguous commit")) @?= False + invalid <- run (TransactionRetryPolicy 0 1000) (Tx.statement () (preparable "INSERT INTO retry_writes VALUES(1)" E.noParams D.noResult)) + assertBool "invalid policy does no work" (isLeft invalid) + scalarInt pool "SELECT count(*) FROM retry_writes" >>= (@?= 0) + +testTransactionDeadline :: TestTree +testTransactionDeadline = testCase "transaction deadline cancels a real lock wait, rolls back and returns a usable sole connection" $ + withShomeiMigratedDatabase \conn -> + bracket (acquirePool 1 1 30000 conn) Pool.release \pool -> + bracket (acquirePool 1 1 30000 conn) Pool.release \holder -> do + execSql pool "CREATE TABLE deadline_writes(value integer)" + bracket_ + (execSql holder "SELECT pg_advisory_lock(1936224116, 17)") + (execSql holder "SELECT pg_advisory_unlock(1936224116, 17)") + do + started <- getMonotonicTimeNSec + result <- + timeout + 2000000 + ( runEff . runDatabasePoolWith (TransactionRetryPolicy 3 100) pool $ + runTransaction (Tx.statement () (preparable "DO $$ BEGIN INSERT INTO deadline_writes VALUES(1); PERFORM pg_advisory_xact_lock(1936224116, 17); END $$" E.noParams D.noResult)) + ) + ended <- getMonotonicTimeNSec + assertBool "deadline returns unavailable" (case result of Just (Left _) -> True; _ -> False) + assertBool "total deadline is finite" (ended - started < 2000000000) + usable <- timeout 1000000 (scalarInt pool "SELECT count(*) FROM deadline_writes") + usable @?= Just 0 + completed <- newEmptyMVar + worker <- forkIO do + outcome <- + try @SomeException + ( runEff . runDatabasePoolWith (TransactionRetryPolicy 3 500) pool $ + runTransaction (Tx.statement () (preparable "DO $$ BEGIN INSERT INTO deadline_writes VALUES(2); PERFORM pg_advisory_xact_lock(1936224116, 17); END $$" E.noParams D.noResult)) + ) + putMVar completed outcome + let awaitWaiter = do + waiting <- scalarInt holder "SELECT count(*) FROM pg_locks WHERE locktype='advisory' AND classid=1936224116 AND objid=17 AND NOT granted" + if waiting > 0 then pure () else threadDelay 1000 >> awaitWaiter + barrier <- timeout 1000000 awaitWaiter + barrier @?= Just () + killThread worker + cancelled <- timeout 2000000 (takeMVar completed) + assertBool "caller cancellation returns after cleanup" (case cancelled of Just (Left _) -> True; Just (Right (Left _)) -> True; _ -> False) + reused <- timeout 1000000 (scalarInt pool "SELECT count(*) FROM deadline_writes") + reused @?= Just 0 + +testDatabaseTimeouts :: TestTree +testDatabaseTimeouts = testCase "every connection installs statement and idle transaction timeouts; hung statement is cancelled" $ + withShomeiMigratedDatabase \conn -> + bracket (acquirePool 2 1 75 conn) Pool.release \pool -> do + settings <- scalarInt pool "SELECT CASE WHEN current_setting('statement_timeout')='75ms' AND current_setting('idle_in_transaction_session_timeout')='75ms' THEN 1 ELSE 0 END::bigint" + settings @?= 1 + execSqlExpectState pool "57014" "SELECT pg_sleep(1)" + scalarInt pool "SELECT 1::bigint" >>= (@?= 1) + +testBulkRevocation :: TestTree +testBulkRevocation = testCase "bulk revoke: 10000 winners and audits stay atomic under failure and eight racers" $ withDb \pool -> do + user <- expectApp =<< runApp pool (createUser (NewUser aliceLogin Nothing Nothing)) + actor <- genUserId + let uid = "'" <> Text.pack (show (userIdToUUID user.userId)) <> "'" + execSql pool ("INSERT INTO shomei.shomei_sessions(session_id,user_id,status,created_at,expires_at) SELECT gen_random_uuid(), " <> uid <> ", 'active', now(), now()+interval '1 day' FROM generate_series(1,10000)") + execSql pool "INSERT INTO shomei.shomei_refresh_tokens(refresh_token_id,session_id,token_hash,status,created_at,expires_at) SELECT gen_random_uuid(),session_id,md5(session_id::text),'active',created_at,expires_at FROM shomei.shomei_sessions" + execSql pool "ALTER TABLE shomei.shomei_auth_events ADD CONSTRAINT fail_bulk_audit CHECK(event_type <> 'session_revoked')" + failed <- runApp pool (revokeUserSessionsWithAudit actor user.userId t0) + assertBool "audit failure rejects entire operation" (isLeft failed) + scalarInt pool "SELECT count(*) FROM shomei.shomei_sessions WHERE status='active'" >>= (@?= 10000) + scalarInt pool "SELECT count(*) FROM shomei.shomei_refresh_tokens WHERE status='active'" >>= (@?= 10000) + execSql pool "ALTER TABLE shomei.shomei_auth_events DROP CONSTRAINT fail_bulk_audit" + start <- newEmptyMVar + completed <- replicateM 8 do + done <- newEmptyMVar + _ <- forkIO do + readMVar start + result <- runApp pool (revokeUserSessionsWithAudit actor user.userId t0) + putMVar done result + pure done + putMVar start () + results <- traverse (expectApp <=< takeMVar) completed + sum results @?= 10000 + length (filter (> 0) results) @?= 1 + scalarInt pool "SELECT count(*) FROM shomei.shomei_auth_events WHERE event_type='session_revoked'" >>= (@?= 10000) + scalarInt pool "SELECT count(*) FROM shomei.shomei_refresh_tokens WHERE status<>'revoked'" >>= (@?= 0) + repeated <- expectApp =<< runApp pool (revokeUserSessionsWithAudit actor user.userId (addUTCTime 60 t0)) + repeated @?= 0 + scalarInt pool "SELECT count(*) FROM shomei.shomei_sessions WHERE revoked_at <> '2026-01-01T00:00:00Z'" >>= (@?= 0) + events <- expectApp =<< runApp pool (queryAuthEvents emptyAuditQuery {queryEventTypes = ["session_revoked"], queryLimit = 1}) + case events of + [event] -> case reconstructAuthEvent event.storedEventType event.storedPayload of + Right (Event.SessionRevoked details) -> do + details.revokedBy @?= Just actor + details.occurredAt @?= t0 + other -> assertFailure ("bulk payload failed reconstruction: " <> show other) + _ -> assertFailure "expected one event page" + +testSessionPages :: TestTree +testSessionPages = testCase "session pages default to 50, cap at 200 and keyset-walk timestamp ties without gaps" $ withDb \pool -> do + user <- expectApp =<< runApp pool (createUser (NewUser aliceLogin Nothing Nothing)) + let uid = "'" <> Text.pack (show (userIdToUUID user.userId)) <> "'" + execSql pool ("INSERT INTO shomei.shomei_sessions(session_id,user_id,status,created_at,expires_at) SELECT gen_random_uuid(), " <> uid <> ", 'active', '2026-01-01', '2027-01-01' FROM generate_series(1,505)") + first <- expectApp =<< runApp pool (listSessionPage user.userId emptySessionListQuery) + length first @?= 50 + capped <- expectApp =<< runApp pool (listSessionPage user.userId (SessionListQuery 10000 Nothing)) + length capped @?= 200 + let walk cursor accumulated = do + page <- expectApp =<< runApp pool (listSessionPage user.userId (SessionListQuery 73 cursor)) + case reverse page of + [] -> pure accumulated + lastRow : _ -> walk (Just (SessionCursor lastRow.createdAt lastRow.sessionId)) (accumulated <> map (.sessionId) page) + identifiers <- walk Nothing [] + length identifiers @?= 505 + Set.size (Set.fromList identifiers) @?= 505 + +testShrinkingStatementBudget :: TestTree +testShrinkingStatementBudget = testCase "transaction statement budgets shrink across successive slow statements and reset afterward" $ withDb \pool -> do + let pause = Tx.statement () (preparable "DO $$ BEGIN PERFORM pg_sleep(0.065); END $$" E.noParams D.noResult) + started <- getMonotonicTimeNSec + result <- runEff . runDatabasePoolWith (TransactionRetryPolicy 3 100) pool $ runTransaction (pause >> pause) + ended <- getMonotonicTimeNSec + assertBool "second statement cannot spend a fresh 100ms" (isLeft result) + assertBool "whole attempt remains bounded" (ended - started < 1000000000) + setting <- scalarInt pool "SELECT CASE WHEN current_setting('statement_timeout')='30s' THEN 1 ELSE 0 END::bigint" + setting @?= 1 + +testSessionQueryPlan :: TestTree +testSessionQueryPlan = testCase "session keyset index removes the 10000-row sort for a 50-row page" $ withDb \pool -> do + user <- expectApp =<< runApp pool (createUser (NewUser aliceLogin Nothing Nothing)) + let uid = "'" <> Text.pack (show (userIdToUUID user.userId)) <> "'" + explain = do + result <- + Pool.use + pool + ( Session.statement + () + ( preparable + ("EXPLAIN (ANALYZE, BUFFERS) SELECT * FROM shomei.shomei_sessions WHERE user_id=" <> uid <> " ORDER BY created_at DESC,session_id DESC LIMIT 50") + E.noParams + (D.rowList (D.column (D.nonNullable D.text))) + ) + ) + expectApp result + execSql pool ("INSERT INTO shomei.shomei_sessions(session_id,user_id,status,created_at,expires_at) SELECT gen_random_uuid(), " <> uid <> ", 'active', now(), now()+interval '1 day' FROM generate_series(1,10000)") + execSql pool "DROP INDEX IF EXISTS shomei.shomei_sessions_user_created_id_idx; ANALYZE shomei.shomei_sessions" + before <- explain + assertBool "baseline sorts the matching sessions" (any (Text.isInfixOf "Sort") before) + execSql pool "CREATE INDEX shomei_sessions_user_created_id_idx ON shomei.shomei_sessions(user_id,created_at DESC,session_id DESC)" + after <- explain + assertBool "bounded page uses ordered index" (any (Text.isInfixOf "shomei_sessions_user_created_id_idx") after) + assertBool "ordered index removes sort" (not (any (Text.isInfixOf "Sort") after)) + writeFile "/tmp/shomei-session-query-plan.txt" (Text.unpack (Text.unlines (["Before compound index:"] <> before <> ["After compound index:"] <> after))) + +testActiveSessionQuota :: TestTree +testActiveSessionQuota = testCase "active session quota serializes actor and subject budgets across replicas; expiry frees capacity" $ withDb \pool -> do + (actor, subject, otherSubject) <- + expectApp =<< runApp pool do + actor <- createUser (NewUser aliceLogin Nothing Nothing) + subject <- createUser (NewUser bobLogin Nothing Nothing) + other <- createUser (NewUser (either (error . show) id (mkLoginId "quota-other")) Nothing Nothing) + pure (actor, subject, other) + let new at uid acting expiry = NewSession uid at expiry acting Nothing DelegatedSession Set.empty at False + delegated = new t0 subject.userId (Just actor.userId) (addUTCTime 60 t0) + mint ns = runApp pool (createSessionWithinLimit 1 ns) + -- Eight independent interpreter invocations contend for the same final slot. + start <- newEmptyMVar + completions <- replicateM 8 do + done <- newEmptyMVar + _ <- forkIO (readMVar start >> mint delegated >>= putMVar done) + pure done + putMVar start () + results <- traverse (expectApp <=< takeMVar) completions + length [() | Right _ <- results] @?= 1 + length [() | Left Err.SessionLimitReached <- results] @?= 7 + acrossSubjects <- expectApp =<< mint (new t0 otherSubject.userId (Just actor.userId) (addUTCTime 60 t0)) + acrossSubjects @?= Left Err.SessionLimitReached + acrossActors <- expectApp =<< mint (new t0 subject.userId (Just otherSubject.userId) (addUTCTime 60 t0)) + acrossActors @?= Left Err.SessionLimitReached + -- Existing rows survive lowering; expired rows do not spend the active budget. + expiredMint <- expectApp =<< runApp pool (createSessionWithinLimit 1 (new (addUTCTime 61 t0) subject.userId (Just actor.userId) (addUTCTime 120 t0))) + assertBool "expiry frees a slot without a sweep" (case expiredMint of Right _ -> True; _ -> False) + scalarInt pool "SELECT count(*) FROM shomei.shomei_sessions" >>= (@?= 2) + let future = addUTCTime (31 * 86400) t0 + live <- expectApp =<< mint (new future subject.userId (Just actor.userId) (addUTCTime 60 future)) + liveSession <- expectRight live + sweepStarted <- getMonotonicTimeNSec + report <- expectSweep =<< sweepOnce pool defaultSweepConfig {batchSize = 1} future + sweepEnded <- getMonotonicTimeNSec + assertBool "two successful delete batches yield at least 10ms each" (sweepEnded - sweepStarted >= 20000000) + report.sessionsDeleted @?= 2 + surviving <- expectApp =<< runApp pool (findSessionById liveSession.sessionId) + fmap (.status) surviving @?= Just SessionActive + +testSessionQuotaQueryPlan :: TestTree +testSessionQuotaQueryPlan = testCase "session quota indexes exclude expired history from the bounded live count" $ withDb \pool -> do + user <- expectApp =<< runApp pool (createUser (NewUser aliceLogin Nothing Nothing)) + other <- expectApp =<< runApp pool (createUser (NewUser bobLogin Nothing Nothing)) + let otherUid = "'" <> Text.pack (show (userIdToUUID other.userId)) <> "'" + uid = "'" <> Text.pack (show (userIdToUUID user.userId)) <> "'" + query = "EXPLAIN (ANALYZE,BUFFERS) SELECT count(*) FROM (SELECT 1 FROM shomei.shomei_sessions WHERE user_id=" <> uid <> " AND status='active' AND kind IN ('machine','delegated') AND expires_at > '2026-01-01' UNION ALL SELECT 1 FROM shomei.shomei_sessions WHERE actor_user_id=" <> uid <> " AND user_id<>" <> uid <> " AND status='active' AND kind IN ('machine','delegated') AND expires_at>'2026-01-01' LIMIT 1000) active" + explain = expectApp =<< Pool.use pool (Session.statement () (preparable query E.noParams (D.rowList (D.column (D.nonNullable D.text))))) + execSql pool ("INSERT INTO shomei.shomei_sessions(session_id,user_id,actor_user_id,status,kind,created_at,expires_at) SELECT gen_random_uuid()," <> uid <> "," <> uid <> ",'active','delegated','2025-01-01','2025-01-02' FROM generate_series(1,10000)") + execSql pool ("INSERT INTO shomei.shomei_sessions(session_id,user_id,actor_user_id,status,kind,created_at,expires_at) VALUES(gen_random_uuid()," <> uid <> "," <> uid <> ",'active','delegated','2026-01-01','2027-01-01')") + execSql pool ("INSERT INTO shomei.shomei_sessions(session_id,user_id,status,kind,created_at,expires_at) SELECT gen_random_uuid()," <> otherUid <> ",'active','machine','2026-01-01','2027-01-01' FROM generate_series(1,10000)") + execSql pool "DROP INDEX IF EXISTS shomei.shomei_sessions_active_subject_idx; DROP INDEX IF EXISTS shomei.shomei_sessions_active_actor_idx; ANALYZE shomei.shomei_sessions" + before <- explain + execSql pool "CREATE INDEX shomei_sessions_active_subject_idx ON shomei.shomei_sessions(user_id,expires_at) WHERE status='active' AND kind IN ('machine','delegated'); CREATE INDEX shomei_sessions_active_actor_idx ON shomei.shomei_sessions(actor_user_id,expires_at) WHERE status='active' AND kind IN ('machine','delegated')" + after <- explain + writeFile "/tmp/shomei-session-quota-plan.txt" (Text.unpack (Text.unlines (["Before active range indexes:"] <> before <> ["After active range indexes:"] <> after))) + assertBool "quota range indexes used" (any (Text.isInfixOf "shomei_sessions_active_") after) + +testManagedPoolOwnership :: TestTree +testManagedPoolOwnership = testCase "managed pool restores interrupted/failed slots and preserves its ceiling across release" $ + withShomeiMigratedDatabase \conn -> bracket (acquirePool 1 0.05 30000 conn) Pool.release \pool -> do + execSql pool "CREATE TABLE pool_cancel_writes(value integer)" + -- A gate inside a raw session makes caller interruption deterministic. This session is + -- not a retried database transaction, whose abstract type deliberately has no MonadIO. + forM_ [1 .. 12 :: Int] $ \_ -> do + entered <- newEmptyMVar + neverCommit <- newEmptyMVar + completed <- newEmptyMVar + worker <- forkIO do + result <- + try @SomeException + ( Pool.use pool do + Session.script "BEGIN; INSERT INTO pool_cancel_writes VALUES(1)" + liftIO (putMVar entered () >> takeMVar neverCommit) + Session.script "COMMIT" + ) + putMVar completed result + timeout 1000000 (takeMVar entered) >>= (@?= Just ()) + killThread worker + outcome <- timeout 1000000 (takeMVar completed) + assertBool "interrupted session did not commit" (case outcome of Just (Left _) -> True; Just (Right (Left _)) -> True; _ -> False) + timeout 1000000 (scalarInt pool "SELECT count(*) FROM pool_cancel_writes") >>= (@?= Just 0) + -- Failed initialization must also return the reserved capacity, every time. + bracket (acquirePool 1 0.05 maxBound conn) Pool.release $ \invalid -> + forM_ [1 .. 3 :: Int] $ \_ -> do + outcome <- Pool.use invalid (pure ()) + assertBool + "initialization failure retains its typed result, never a leaked-slot timeout" + (case outcome of Left (Pool.SessionUsageError _) -> True; _ -> False) + entered <- newEmptyMVar + finish <- newEmptyMVar + completed <- newEmptyMVar + _ <- forkIO do + result <- Pool.use pool (liftIO (putMVar entered () >> takeMVar finish)) + putMVar completed result + timeout 1000000 (takeMVar entered) >>= (@?= Just ()) + Pool.release pool + exhausted <- Pool.use pool (pure ()) + exhausted @?= Left Pool.AcquisitionTimeoutUsageError + putMVar finish () + timeout 1000000 (takeMVar completed) >>= (@?= Just (Right ())) + timeout 1000000 (scalarInt pool "SELECT 1::bigint") >>= (@?= Just 1) + +testPersistenceClock :: TestTree +testPersistenceClock = testCase "user and credential timestamps follow Clock; password tails share their transaction timestamp" $ withDb \pool -> do + (user, credential) <- + expectApp =<< runAppAtTime t0 pool do + user <- createUser (NewUser aliceLogin Nothing Nothing) + credential <- createPasswordCredential user.userId aliceLogin Nothing (PasswordHash "initial-hash") + pure (user, credential) + user.createdAt @?= t0 + user.updatedAt @?= t0 + credential.createdAt @?= t0 + credential.updatedAt @?= t0 + let changedAt = addUTCTime 60 t0 + (updatedUser, updatedCredential) <- + expectApp =<< runAppAtTime changedAt pool do + _ <- updateUserStatus user.userId [UserActive] UserSuspended changedAt + updatePasswordHash user.userId (PasswordHash "second-hash") + (,) <$> findUserById user.userId <*> findPasswordCredentialByLoginId aliceLogin + fmap (.updatedAt) updatedUser @?= Just changedAt + fmap (.updatedAt) updatedCredential @?= Just changedAt + let tailTime = addUTCTime 120 t0 + -- A different ambient Clock proves the tail uses the one timestamp already chosen by its workflow. + expectApp =<< runAppAtTime t0 pool (completePasswordChange user.userId (PasswordHash "third-hash") tailTime []) + afterTail <- expectApp =<< runAppAtTime t0 pool (findPasswordCredentialByLoginId aliceLogin) + fmap (.updatedAt) afterTail @?= Just tailTime + fmap (.createdAt) afterTail @?= Just t0 + reset <- expectApp =<< runAppAtTime t0 pool (createPasswordResetToken (NewPasswordResetToken user.userId (OneTimeTokenHash "clock-reset") t0 (addUTCTime 3600 t0))) + let resetTime = addUTCTime 180 t0 + won <- expectApp =<< runAppAtTime t0 pool (completePasswordReset reset.passwordResetTokenId user.userId (PasswordHash "fourth-hash") resetTime []) + won @?= True + afterReset <- expectApp =<< runAppAtTime t0 pool (findPasswordCredentialByLoginId aliceLogin) + fmap (.updatedAt) afterReset @?= Just resetTime + fmap (.createdAt) afterReset @?= Just t0 + +-- Start every independent interpreter invocation together and never leave a failed worker +-- silently blocking the acceptance suite. +raceDatabase :: Int -> IO a -> IO [a] +raceDatabase count action = do + start <- newEmptyMVar + completed <- replicateM count do + done <- newEmptyMVar + _ <- forkIO do + readMVar start + outcome <- try @SomeException action + putMVar done outcome + pure done + putMVar start () + forM completed \done -> do + outcome <- timeout 10000000 (takeMVar done) + case outcome of + Just (Right value) -> pure value + Just (Left _) -> assertFailure "database racer raised an exception" + Nothing -> assertFailure "database race did not reach its completion barrier" + +readBarrier :: Int -> IORef Int -> MVar () -> IO () +readBarrier racers count allRead = do + lastReader <- atomicModifyIORef' count (\n -> let next = n + 1 in (next, next == racers)) + when lastReader (putMVar allRead ()) + readMVar allRead + +synchronizeUserRead :: (UserStore :> es, IOE :> es) => Int -> IORef Int -> MVar () -> Eff es a -> Eff es a +synchronizeUserRead racers count allRead = interpose \env -> \case + op@(FindUserById _) -> do + value <- passthrough env op + liftIO (readBarrier racers count allRead) + pure value + op -> passthrough env op + +synchronizeRefreshRead :: (RefreshTokenStore :> es, IOE :> es) => Int -> IORef Int -> MVar () -> Eff es a -> Eff es a +synchronizeRefreshRead racers count allRead = interpose \env -> \case + op@(FindRefreshTokenByHash _) -> do + value <- passthrough env op + liftIO (readBarrier racers count allRead) + pure value + op -> passthrough env op + +testRefreshRotationRace :: TestTree +testRefreshRotationRace = testCase "real refresh workflow race rotates once and treats the losing proof as theft" $ withDb \pool -> do + (_, pair) <- runApp pool (signup cfg (SignupCommand aliceLogin (Just aliceEmail) strongPw Nothing)) >>= expectApp >>= expectRight + readCount <- newIORef 0 + allRead <- newEmptyMVar + results <- raceDatabase 2 (runApp pool (synchronizeRefreshRead 2 readCount allRead (refresh cfg (RefreshCommand pair.refreshToken)))) >>= traverse expectApp + length [() | Right _ <- results] @?= 1 + length [() | Left RefreshTokenReuseDetected <- results] @?= 1 + scalarInt pool "SELECT count(*) FROM shomei.shomei_refresh_tokens" >>= (@?= 2) + scalarInt pool "SELECT count(*) FROM shomei.shomei_refresh_tokens WHERE status<>'revoked'" >>= (@?= 0) + scalarInt pool "SELECT count(*) FROM shomei.shomei_sessions WHERE status='active'" >>= (@?= 0) + scalarInt pool "SELECT count(*) FROM shomei.shomei_auth_events WHERE event_type='refresh_token_rotated'" >>= (@?= 1) + scalarInt pool "SELECT count(*) FROM shomei.shomei_auth_events WHERE event_type='refresh_token_reuse_detected'" >>= (@?= 1) + scalarInt pool "SELECT count(*) FROM shomei.shomei_auth_events WHERE event_type='session_revoked'" >>= (@?= 0) + +testResetAndVerificationRaces :: TestTree +testResetAndVerificationRaces = testCase "real reset and verification workflows each consume once and audit one winner" $ withDb \pool -> do + _ <- runApp pool (signup cfg (SignupCommand aliceLogin (Just aliceEmail) strongPw Nothing)) >>= expectApp >>= expectRight + notifications <- newIORef [] + _ <- runAppWithNotifications notifications pool (requestPasswordReset cfg (RequestPasswordReset aliceEmail)) >>= expectApp >>= expectRight + sent <- readIORef notifications + resetToken <- case [raw | PasswordResetRequested {token = raw} <- sent] of + raw : _ -> pure raw + _ -> assertFailure "missing reset token fixture" + readCount <- newIORef 0 + allRead <- newEmptyMVar + resets <- + raceDatabase + 8 + ( runApp + pool + ( synchronizeUserRead + 8 + readCount + allRead + (confirmPasswordReset cfg (ConfirmPasswordReset resetToken (PlainPassword "correct horse battery staple two"))) + ) + ) + >>= traverse expectApp + length [() | Right () <- resets] @?= 1 + length [() | Left PasswordResetTokenInvalid <- resets] @?= 7 + scalarInt pool "SELECT count(*) FROM shomei.shomei_auth_events WHERE event_type='password_reset_completed'" >>= (@?= 1) + _ <- runAppWithNotifications notifications pool (requestEmailVerification cfg (RequestEmailVerification aliceEmail)) >>= expectApp >>= expectRight + sentVerification <- readIORef notifications + verificationToken <- case [raw | EmailVerificationRequested {token = raw} <- sentVerification] of + raw : _ -> pure raw + _ -> assertFailure "missing verification token fixture" + verificationReads <- newIORef 0 + allVerificationRead <- newEmptyMVar + verifications <- + raceDatabase + 8 + ( runApp + pool + ( synchronizeUserRead + 8 + verificationReads + allVerificationRead + (confirmEmailVerification cfg (ConfirmEmailVerification verificationToken)) + ) + ) + >>= traverse expectApp + length [() | Right () <- verifications] @?= 1 + length [() | Left Err.VerificationTokenInvalid <- verifications] @?= 7 + scalarInt pool "SELECT count(*) FROM shomei.shomei_auth_events WHERE event_type='email_verified'" >>= (@?= 1) + +testRecoveryAndCeremonyRaces :: TestTree +testRecoveryAndCeremonyRaces = testCase "real recovery-code and pending-ceremony consume races have one persisted winner" $ withDb \pool -> do + (uid, cid, ts) <- + expectApp =<< runApp pool do + user <- createUser (NewUser aliceLogin Nothing Nothing) + ts <- now + rid <- genRecoveryCodeId + replaceRecoveryCodes user.userId [NewRecoveryCode rid "recovery-race" ts] + cid <- genCeremonyId + putPendingCeremony (PendingCeremony cid (Just user.userId) AuthenticationCeremony "signed-options-fixture" ts (addUTCTime 60 ts)) + pure (user.userId, cid, ts) + recovery <- raceDatabase 8 (runApp pool (consumeRecoveryCode uid "recovery-race" ts)) >>= traverse expectApp + length (filter id recovery) @?= 1 + scalarInt pool "SELECT count(*) FROM shomei.shomei_recovery_codes WHERE used_at IS NOT NULL" >>= (@?= 1) + ceremonies <- raceDatabase 8 (runApp pool (takePendingCeremony cid ts)) >>= traverse expectApp + length (filter isJust ceremonies) @?= 1 + scalarInt pool "SELECT count(*) FROM shomei.shomei_webauthn_pending_ceremonies" >>= (@?= 0) + +testSweepVersusLiveRotation :: TestTree +testSweepVersusLiveRotation = testCase "paced sweeper races a live refresh without deleting the rotation family" $ withDb \pool -> do + (user, pair) <- runApp pool (signup cfg (SignupCommand aliceLogin (Just aliceEmail) strongPw Nothing)) >>= expectApp >>= expectRight + let uid = "'" <> Text.pack (show (userIdToUUID user.userId)) <> "'" + execSql pool ("INSERT INTO shomei.shomei_sessions(session_id,user_id,status,created_at,expires_at) SELECT gen_random_uuid()," <> uid <> ",'active',now()-interval '32 days',now()-interval '31 days' FROM generate_series(1,10)") + cutoff <- getCurrentTime + -- Hold the sweep's first delete at a real SQL barrier while the live rotation commits. + execSql pool "CREATE FUNCTION shomei.test_sweep_barrier() RETURNS trigger LANGUAGE plpgsql AS $$ BEGIN PERFORM pg_advisory_xact_lock(1936224116,18); RETURN OLD; END $$; CREATE TRIGGER test_sweep_barrier BEFORE DELETE ON shomei.shomei_sessions FOR EACH ROW EXECUTE FUNCTION shomei.test_sweep_barrier()" + locked <- newEmptyMVar + unlock <- newEmptyMVar + holderDone <- newEmptyMVar + _ <- forkIO do + outcome <- Pool.use pool do + Session.script "SELECT pg_advisory_lock(1936224116,18)" + liftIO (putMVar locked () >> takeMVar unlock) + Session.script "SELECT pg_advisory_unlock(1936224116,18)" + putMVar holderDone outcome + takeMVar locked + swept <- newEmptyMVar + bracket_ + (pure ()) + (putMVar unlock () >> takeMVar holderDone >>= expectApp) + do + _ <- forkIO (sweepOnce pool defaultSweepConfig {batchSize = 1, deadSessionGraceDays = 0} cutoff >>= putMVar swept) + let awaitSweep = do + waiting <- scalarInt pool "SELECT count(*) FROM pg_locks WHERE locktype='advisory' AND classid=1936224116 AND objid=18 AND NOT granted" + if waiting > 0 then pure () else threadDelay 1000 >> awaitSweep + timeout 2000000 awaitSweep >>= (@?= Just ()) + rotated <- expectApp =<< runApp pool (refresh cfg (RefreshCommand pair.refreshToken)) + _ <- expectRight rotated + pure () + report <- expectSweep =<< takeMVar swept + report.sessionsDeleted @?= 10 + scalarInt pool "SELECT count(*) FROM shomei.shomei_sessions WHERE status='active'" >>= (@?= 1) + scalarInt pool "SELECT count(*) FROM shomei.shomei_refresh_tokens" >>= (@?= 2) + scalarInt pool "SELECT count(*) FROM shomei.shomei_refresh_tokens WHERE status='active'" >>= (@?= 1) + +testAdminQueryPlans :: TestTree +testAdminQueryPlans = testCase "admin user and per-user audit pages use measured ordered indexes; small client catalog stays unindexed" $ withDb \pool -> do + let explain query = expectApp =<< Pool.use pool (Session.statement () (preparable ("EXPLAIN (ANALYZE, BUFFERS) " <> query) E.noParams (D.rowList (D.column (D.nonNullable D.text))))) + users = "SELECT * FROM shomei.shomei_users ORDER BY created_at DESC,user_id DESC LIMIT 50" + suspended = "SELECT * FROM shomei.shomei_users WHERE status='suspended' ORDER BY created_at DESC,user_id DESC LIMIT 50" + audit = "SELECT * FROM shomei.shomei_auth_events WHERE user_id='10000000-0000-0000-0000-000000000001' ORDER BY created_at DESC,event_id DESC LIMIT 50" + clients = "SELECT * FROM shomei.shomei_oauth_clients ORDER BY created_at DESC,oauth_client_id DESC" + execSql pool "INSERT INTO shomei.shomei_users(user_id,login_id,status,created_at,updated_at) SELECT gen_random_uuid(),'plan-user-'||i,CASE WHEN i%2=0 THEN 'active' ELSE 'suspended' END,now()-i*interval '1 second',now() FROM generate_series(1,10000) i" + execSql pool "INSERT INTO shomei.shomei_auth_events(event_id,user_id,event_type,payload,created_at) SELECT gen_random_uuid(),CASE WHEN i<=1000 THEN '10000000-0000-0000-0000-000000000001'::uuid ELSE '10000000-0000-0000-0000-000000000002'::uuid END,'login_succeeded','{}',now()+i*interval '1 second' FROM generate_series(1,11000) i" + execSql pool "INSERT INTO shomei.shomei_oauth_clients(oauth_client_id,client_id,client_type,display_name,redirect_uris,allowed_scopes,status,created_at) SELECT gen_random_uuid(),'plan-client-'||i,'public','Fixture','[]','[]','active',now() FROM generate_series(1,40) i" + execSql pool "DROP INDEX IF EXISTS shomei.shomei_users_created_id_idx; DROP INDEX IF EXISTS shomei.shomei_users_status_created_id_idx; DROP INDEX IF EXISTS shomei.shomei_auth_events_user_created_id_idx; ANALYZE shomei.shomei_users; ANALYZE shomei.shomei_auth_events; ANALYZE shomei.shomei_oauth_clients" + before <- traverse explain [users, suspended, audit, clients] + execSql pool "CREATE INDEX shomei_users_created_id_idx ON shomei.shomei_users(created_at DESC,user_id DESC); CREATE INDEX shomei_users_status_created_id_idx ON shomei.shomei_users(status,created_at DESC,user_id DESC); CREATE INDEX shomei_auth_events_user_created_id_idx ON shomei.shomei_auth_events(user_id,created_at DESC,event_id DESC)" + after <- traverse explain [users, suspended, audit, clients] + forM_ (zip (take 3 after) ["shomei_users_created_id_idx", "shomei_users_status_created_id_idx", "shomei_auth_events_user_created_id_idx"]) \(plan, indexName) -> do + assertBool "bounded page uses the ordered index" (any (Text.isInfixOf indexName) plan) + assertBool "bounded page needs no sort" (not (any (Text.isInfixOf "Sort") plan)) + writeFile "/tmp/shomei-admin-query-plans.txt" (Text.unpack (Text.unlines (concat (zipWith3 (\name b a -> [name <> " before:"] <> b <> [name <> " after:"] <> a) ["Users", "Suspended users", "Per-user audit", "40-client catalog (no new index)"] before after))))