packages feed

shomei-postgres (empty) → 0.2.0.0

raw patch · 29 files changed

+7510/−0 lines, 29 filesdep +aesondep +basedep +bytestring

Dependencies added: aeson, base, bytestring, containers, contravariant-extras, crypton, effectful, effectful-core, hasql, hasql-pool, hasql-transaction, ram, shomei-core, shomei-migrations, shomei-postgres, stm, tasty, tasty-hunit, text, time, transformers, uuid

Files

+ CHANGELOG.md view
@@ -0,0 +1,44 @@+# Changelog for shomei-postgres++All notable changes to `shomei-postgres` are documented here. This package adheres to the+[PVP](https://pvp.haskell.org/) and is versioned independently of the other+Shōmei packages.++## 0.2.0.0 — 2026-08-27++- **Breaking:** requires `shomei-core ^>=0.2.0.0` and `shomei-migrations ^>=0.2.0.0`.+- **Breaking:** `acquirePool` accepts a statement-timeout argument and installs both+  `statement_timeout` and `idle_in_transaction_session_timeout` on every new connection.+- Password hashes are fully evaluated inside the configured concurrency-limiter permit, before+  a credential store acquires a database connection; Argon2 implementation rejections now surface+  as the typed `Argon2Failure` exception. Shared hard-floor validation and a real trial derivation+  let server and CLI boot paths reject unsupported costs before serving work.+- **Breaking:** interpreters implement the new atomic login-attempt, counter, user-status,+  revocation, and credential-tail ports. Per-account failure counting uses a transaction-scoped+  advisory lock; conditional updates and unit-of-work transactions expose exactly one winner.+- Unique identity violations retain their typed login/email conflict at the persistence boundary;+  unknown PostgreSQL write failures remain opaque dependency errors.+- **Breaking:** the signing-key interpreter persists `revoked_at`, stamps activation, retirement,+  and revocation times, and implements atomic active-key replacement in one transaction.+- Session-store and authentication-unit-of-work interpreters now write session provenance and+  read legacy `NULL` provenance as `interactive`.+- Sessions round-trip their OAuth granted scopes, and consumed authorization codes can bind and+  recover the session minted by their first exchange for replay response.++## 0.1.0.0 — 2026-08-24++Initial release. Production `hasql` interpreters for Shōmei's ports.++- A PostgreSQL interpreter for every store: users, credentials, sessions,+  refresh tokens, lifecycle tokens, login attempts, roles and grants,+  service accounts, OAuth clients and authorization codes, TOTP secrets and+  recovery codes, passkeys and pending ceremonies, and signing keys — plus+  the audit-event publisher and the read/query layer behind+  `GET /admin/audit/events`.+- Argon2id password hashing with configurable, self-describing parameters+  and a bound on how many hashes run concurrently, and SHA-256 token+  hashing.+- Connection pooling and a transactional unit of work, so the auth write+  tails commit atomically. One-time token consumption and refresh-token+  rotation are compare-and-swap.+- A batched sweep engine for expired data.
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2026 Nadeem Bitar++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ shomei-postgres.cabal view
@@ -0,0 +1,126 @@+cabal-version:   3.0+name:            shomei-postgres+version:         0.2.0.0+synopsis:+  PostgreSQL adapters for Shōmei's store/publisher/signing-key ports++description:+  Production interpreters for Shōmei's effects, written against hasql: a+  PostgreSQL-backed store for users, credentials, sessions, refresh tokens,+  OAuth clients and authorization codes, MFA secrets, recovery codes,+  passkeys, service accounts, roles, and signing keys, plus the audit-event+  publisher and reader. Also provides Argon2id password hashing and SHA-256+  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+extra-doc-files: CHANGELOG.md++source-repository head+  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++common shared+  default-language:   GHC2024+  default-extensions:+    BlockArguments+    DataKinds+    DeriveAnyClass+    DuplicateRecordFields+    GADTs+    LambdaCase+    MultilineStrings+    OverloadedLabels+    OverloadedRecordDot+    OverloadedStrings+    QualifiedDo+    RecordWildCards+    TemplateHaskell+    TypeFamilies++library+  import:          warnings, shared+  hs-source-dirs:  src+  exposed-modules:+    Shomei.Account.Credential.Postgres+    Shomei.Account.Password.Hash.Postgres+    Shomei.Account.PasswordReset.Postgres+    Shomei.Account.User.Postgres+    Shomei.Account.Verification.Postgres+    Shomei.Audit.Publisher.Postgres+    Shomei.Audit.Reader.Postgres+    Shomei.Authorization.Role.Postgres+    Shomei.Mfa.RecoveryCode.Postgres+    Shomei.Mfa.Totp.Postgres+    Shomei.OAuth.AuthorizationCode.Postgres+    Shomei.OAuth.Client.Postgres+    Shomei.Passkey.Ceremony.Postgres+    Shomei.Passkey.Postgres+    Shomei.Persistence.Codec.Postgres+    Shomei.Persistence.Database.Postgres+    Shomei.Persistence.Maintenance.Postgres+    Shomei.Persistence.Pool.Postgres+    Shomei.ServiceAccount.Postgres+    Shomei.Session.LoginAttempt.Postgres+    Shomei.Session.Postgres+    Shomei.Session.RefreshToken.Postgres+    Shomei.Session.UnitOfWork.Postgres+    Shomei.SigningKey.Postgres+    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++test-suite shomei-postgres-test+  import:         warnings, shared+  type:           exitcode-stdio-1.0+  main-is:        Main.hs+  hs-source-dirs: test+  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
+ src/Shomei/Account/Credential/Postgres.hs view
@@ -0,0 +1,160 @@+-- | PostgreSQL interpreter for the 'CredentialStore' port.+module Shomei.Account.Credential.Postgres+  ( runCredentialStorePostgres,++    -- * Statements shared with the unit-of-work interpreter++    -- | Exported so @Shomei.Session.UnitOfWork.Postgres@ can lift the store-owned statement+    -- into a transaction instead of restating its SQL.+    updatePasswordHashStmt,+  )+where++import Contravariant.Extras (contrazip2, contrazip7)+import Data.UUID (UUID)+import Effectful (Eff, IOE, (:>))+import Effectful.Dispatch.Dynamic (interpret_)+import Effectful.Error.Static (Error, throwError)+import Hasql.Decoders qualified as D+import Hasql.Encoders qualified as E+import Hasql.Session qualified as Session+import Hasql.Statement (Statement, preparable)+import Shomei.Account.Credential.Domain (Credential (..))+import Shomei.Account.Credential.Store (CredentialStore (..))+import Shomei.Account.Email.Domain (Email, emailText)+import Shomei.Account.LoginId.Domain (LoginId, loginIdText)+import Shomei.Account.Password.Domain (PasswordHash (..))+import Shomei.Error (AuthError (..))+import Shomei.Id (CredentialId, UserId, credentialIdFromUUID, credentialIdToUUID, genCredentialId, userIdFromUUID, userIdToUUID)+import Shomei.Persistence.Codec.Postgres (loginIdFromDb, maybeEmailFromDb)+import Shomei.Persistence.Database.Postgres (Database, postgresUnavailable, postgresWriteError, runSession)+import Shomei.Prelude++type CredRow = (UUID, UUID, Text, Maybe Text, Text, UTCTime, UTCTime)++runCredentialStorePostgres ::+  (Database :> es, IOE :> es, Error AuthError :> es) =>+  Eff (CredentialStore : es) a ->+  Eff es a+runCredentialStorePostgres = interpret_ \case+  CreatePasswordCredential uid loginId mEmail pwHash -> do+    cid <- genCredentialId+    ts <- liftIO getCurrentTime+    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+  FindPasswordCredentialByLoginId loginId -> do+    res <- runSession (Session.statement (loginIdText loginId) findCredByLoginIdStmt)+    row <- either dbFail pure res+    traverse rebuild row+  FindPasswordCredentialByEmail email -> do+    res <- runSession (Session.statement (emailText email) findCredByEmailStmt)+    row <- either dbFail pure res+    traverse rebuild row+  UpdatePasswordHash uid pwHash -> do+    res <- runSession (Session.statement (userIdToUUID uid, passwordHashText pwHash) updatePasswordHashStmt)+    either dbFail (const (pure ())) res+  where+    dbFail = throwError . postgresUnavailable+    rebuild r = either (throwError . InternalAuthError) pure (rebuildCredential r)++identityConflict :: Text -> Maybe AuthError+identityConflict = \case+  "shomei_password_credentials_login_id_key" -> Just LoginIdAlreadyRegistered+  "shomei_password_credentials_login_id_lower_key" -> Just LoginIdAlreadyRegistered+  "shomei_password_credentials_email_key" -> Just EmailAlreadyRegistered+  "shomei_password_credentials_email_lower_key" -> Just EmailAlreadyRegistered+  _ -> Nothing++passwordHashText :: PasswordHash -> Text+passwordHashText (PasswordHash t) = t++mkCredential :: CredentialId -> UserId -> LoginId -> Maybe Email -> PasswordHash -> UTCTime -> Credential+mkCredential cid uid loginId mEmail pwHash ts =+  PasswordCredential+    { credentialId = cid,+      userId = uid,+      loginId = loginId,+      email = mEmail,+      passwordHash = pwHash,+      createdAt = ts,+      updatedAt = ts+    }++rebuildCredential :: CredRow -> Either Text Credential+rebuildCredential (cid, uid, lid, e, ph, c, u) = do+  loginId <- loginIdFromDb lid+  email <- maybeEmailFromDb e+  pure+    PasswordCredential+      { credentialId = credentialIdFromUUID cid,+        userId = userIdFromUUID uid,+        loginId = loginId,+        email = email,+        passwordHash = PasswordHash ph,+        createdAt = c,+        updatedAt = u+      }++credRowDecoder :: D.Row CredRow+credRowDecoder =+  (,,,,,,)+    <$> D.column (D.nonNullable D.uuid)+    <*> D.column (D.nonNullable D.uuid)+    <*> D.column (D.nonNullable D.text)+    <*> D.column (D.nullable D.text)+    <*> D.column (D.nonNullable D.text)+    <*> D.column (D.nonNullable D.timestamptz)+    <*> D.column (D.nonNullable D.timestamptz)++insertCredentialStmt :: Statement CredRow ()+insertCredentialStmt =+  preparable+    """+    INSERT INTO shomei.shomei_password_credentials+      (credential_id, user_id, login_id, email, password_hash, created_at, updated_at)+    VALUES ($1, $2, $3, $4, $5, $6, $7)+    """+    ( contrazip7+        (E.param (E.nonNullable E.uuid))+        (E.param (E.nonNullable E.uuid))+        (E.param (E.nonNullable E.text))+        (E.param (E.nullable E.text))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.timestamptz))+        (E.param (E.nonNullable E.timestamptz))+    )+    D.noResult++findCredByLoginIdStmt :: Statement Text (Maybe CredRow)+findCredByLoginIdStmt =+  preparable+    """+    SELECT credential_id, user_id, login_id, email, password_hash, created_at, updated_at+    FROM shomei.shomei_password_credentials+    WHERE login_id = $1+    """+    (E.param (E.nonNullable E.text))+    (D.rowMaybe credRowDecoder)++findCredByEmailStmt :: Statement Text (Maybe CredRow)+findCredByEmailStmt =+  preparable+    """+    SELECT credential_id, user_id, login_id, email, password_hash, created_at, updated_at+    FROM shomei.shomei_password_credentials+    WHERE email = $1+    """+    (E.param (E.nonNullable E.text))+    (D.rowMaybe credRowDecoder)++updatePasswordHashStmt :: Statement (UUID, Text) ()+updatePasswordHashStmt =+  preparable+    """+    UPDATE shomei.shomei_password_credentials+    SET password_hash = $2+    WHERE user_id = $1+    """+    (contrazip2 (E.param (E.nonNullable E.uuid)) (E.param (E.nonNullable E.text)))+    D.noResult
+ src/Shomei/Account/Password/Hash/Postgres.hs view
@@ -0,0 +1,365 @@+-- | Argon2id password hashing, opaque-token generation, and SHA-256 token hashing, plus+-- the @effectful@ interpreters for the 'PasswordHasher' and 'TokenGen' ports. These live+-- here (not in @shomei-core@) because they need @crypton@/@ram@ — infrastructure we keep+-- out of the transport-agnostic core.+module Shomei.Account.Password.Hash.Postgres+  ( Argon2Failure (..),+    Argon2Params (..),+    defaultArgon2Params,+    argon2HardFloor,+    argon2WarningFloor,+    hashPasswordArgon2id,+    trialArgon2Derivation,+    verifyPasswordArgon2id,+    dummyHashFor,+    HashingLimiter,+    newHashingLimiter,+    withHashingPermit,+    hashingLimit,+    peakHashingConcurrency,+    runPasswordHasherCrypto,+    generateOpaqueToken,+    hashRefreshToken,+    runTokenGenCrypto,+    sha256Hex,+  )+where++import Control.Concurrent.STM+  ( STM,+    TVar,+    atomically,+    check,+    modifyTVar',+    newTVarIO,+    readTVar,+    readTVarIO,+    writeTVar,+  )+import Control.Exception (ErrorCall (..), Exception, Handler (..), bracket_, catches, evaluate, throw, throwIO, try)+import Crypto.Error (CryptoError, CryptoFailable (..))+import Crypto.Hash (SHA256 (..), hashWith)+import Crypto.KDF.Argon2 qualified as Argon2+import Crypto.Random (getRandomBytes)+import Data.ByteArray (constEq, convert)+import Data.ByteArray.Encoding (Base (Base16, Base64, Base64URLUnpadded), convertFromBase, convertToBase)+import Data.ByteString (ByteString)+import Data.Text qualified as Text+import Data.Text.Encoding qualified as TE+import Effectful (Eff, IOE, (:>))+import Effectful.Dispatch.Dynamic (interpret_)+import Shomei.Account.Password.Domain (PasswordHash (..), PlainPassword (..))+import Shomei.Account.Password.Hash.Store (PasswordHasher (..))+import Shomei.Prelude+import Shomei.Session.RefreshToken.Domain (RefreshToken (..), RefreshTokenHash (..))+import Shomei.Session.Token.Generator (TokenGen (..))+import Text.Read (readMaybe)++-- | The Argon2id cost parameters used to hash /new/ passwords.+--+-- Verification never consults this record: a stored hash carries the parameters it was made+-- with (see 'hashPasswordArgon2id'), so changing these values cannot invalidate a single+-- existing credential.+data Argon2Params = Argon2Params+  { -- | memory cost in KiB+    memoryKiB :: !Int,+    -- | time cost (passes over memory)+    iterations :: !Int,+    -- | lanes+    parallelism :: !Int+  }+  deriving stock (Show, Eq, Generic)++-- | The Argon2 implementation refused to derive a password hash. Boot validation turns+-- invalid configured parameters into an early, named failure; this exception keeps any+-- unexpected runtime rejection equally explicit.+newtype Argon2Failure = Argon2Failure Text+  deriving stock (Show)++instance Exception Argon2Failure++-- | 64 MiB, 3 iterations, 1 lane: at or above every OWASP-recommended Argon2id configuration,+-- and the values every Shōmei release has shipped.+defaultArgon2Params :: Argon2Params+defaultArgon2Params =+  Argon2Params+    { memoryKiB = 64 * 1024,+      iterations = 3,+      parallelism = 1+    }++-- | @Nothing@ when crypton's Argon2 implementation can represent and accepts the configured+-- costs, otherwise a precise hard-floor failure. These are implementation limits, not the+-- stronger password-storage recommendation reported by 'argon2WarningFloor'.+argon2HardFloor :: Argon2Params -> Maybe Text+argon2HardFloor p+  | any ((> maxWord32) . toInteger) [p.memoryKiB, p.iterations, p.parallelism] =+      Just "every Argon2 parameter must fit in 32 bits"+  | p.iterations < 1 = Just "iterations must be at least 1"+  | p.parallelism < 1 = Just "parallelism must be at least 1"+  | p.memoryKiB < requiredMemory =+      Just+        ( "memoryKiB must be at least 8 × parallelism and at least 8; got m="+            <> tshow p.memoryKiB+            <> " KiB for p="+            <> tshow p.parallelism+            <> " (needs "+            <> tshow requiredMemory+            <> ")"+        )+  | otherwise = Nothing+  where+    maxWord32 = 4294967295+    requiredMemory = max 8 (8 * p.parallelism)+    tshow = Text.pack . show++toOptions :: Argon2Params -> Argon2.Options+toOptions p =+  Argon2.Options+    { Argon2.iterations = fromIntegral p.iterations,+      Argon2.memory = fromIntegral p.memoryKiB,+      Argon2.parallelism = fromIntegral p.parallelism,+      Argon2.variant = Argon2.Argon2id,+      Argon2.version = Argon2.Version13+    }++-- | @Nothing@ when the parameters meet the recommended floor, otherwise the reason they do+-- not. The floor (19 MiB, 2 iterations, 1 lane) is the weakest OWASP-endorsed Argon2id+-- configuration. Callers warn; they do not refuse to start, because test rigs and+-- resource-starved development environments legitimately want cheap hashing.+argon2WarningFloor :: Argon2Params -> Maybe Text+argon2WarningFloor p+  | p.memoryKiB < 19456 || p.iterations < 2 || p.parallelism < 1 =+      Just+        ( "configured Argon2 parameters are below the recommended floor (m="+            <> Text.pack (show p.memoryKiB)+            <> "KiB,t="+            <> Text.pack (show p.iterations)+            <> ",p="+            <> Text.pack (show p.parallelism)+            <> "); passwords hashed with them are weaker"+        )+  | otherwise = Nothing++saltLen, hashLen :: Int+saltLen = 16+hashLen = 32++-- | @Version13@ is 0x13 == 19; the number that appears in the @v=@ field.+phcVersion :: Int+phcVersion = 19++-- | crypton's Argon2 'hash' returns a 'CryptoFailable' (it only fails on invalid params).+deriveArgon2 :: Argon2.Options -> ByteString -> ByteString -> ByteString+deriveArgon2 opts pw salt =+  case Argon2.hash opts pw salt hashLen of+    CryptoPassed digest -> digest+    CryptoFailed e -> throw e++b64enc :: ByteString -> Text+b64enc b = TE.decodeUtf8 (convertToBase Base64 b)++b64dec :: Text -> Either String ByteString+b64dec t = convertFromBase Base64 (TE.encodeUtf8 t)++-- | Encode a hash in the self-describing PHC-style string format:+-- @$argon2id$v=19$m=65536,t=3,p=1$\<b64 salt\>$\<b64 digest\>@.+--+-- (Base64 here is padded, unlike the strict PHC specification's unpadded alphabet. Nothing+-- outside Shōmei reads these strings, and @=@ never collides with the @$@ separator.)+phcEncode :: Argon2Params -> ByteString -> ByteString -> Text+phcEncode p salt digest =+  "$argon2id$v="+    <> Text.pack (show phcVersion)+    <> "$m="+    <> Text.pack (show p.memoryKiB)+    <> ",t="+    <> Text.pack (show p.iterations)+    <> ",p="+    <> Text.pack (show p.parallelism)+    <> "$"+    <> b64enc salt+    <> "$"+    <> b64enc digest++-- | Parse @m=65536,t=3,p=1@. Order is fixed: this reads only strings we produce.+parsePhcParams :: Text -> Maybe Argon2Params+parsePhcParams t = case Text.splitOn "," t of+  [m, i, p] ->+    Argon2Params+      <$> field "m=" m+      <*> field "t=" i+      <*> field "p=" p+  _ -> Nothing+  where+    field prefix raw = do+      rest <- Text.stripPrefix prefix raw+      n <- readMaybe (Text.unpack rest)+      -- crypton would reject these later with a CryptoFailed; refusing here keeps a malformed+      -- stored hash from crashing a login.+      if n > 0 then Just n else Nothing++-- | Hash a password with the given parameters, embedding them in the returned string so that+-- verification never has to guess. A later change to @params@ leaves this hash verifiable.+hashPasswordArgon2id :: Argon2Params -> Text -> IO PasswordHash+hashPasswordArgon2id params pw = do+  salt <- getRandomBytes saltLen :: IO ByteString+  -- A strict 'ByteString' in weak-head normal form is fully allocated. Force the digest here,+  -- inside whatever limiter permit the caller holds, rather than returning a thunk that runs+  -- later while hasql encodes a credential row on a checked-out connection.+  digest <-+    evaluate (deriveArgon2 (toOptions params) (TE.encodeUtf8 pw) salt)+      `catches` [ Handler \(ErrorCall msg) -> throwIO (Argon2Failure (Text.pack msg)),+                  Handler \(e :: CryptoError) -> throwIO (Argon2Failure (Text.pack (show e)))+                ]+  evaluate (PasswordHash (phcEncode params salt digest))++-- | Exercise one real derivation with the configured costs. Startup uses this before acquiring+-- a database pool so implementation or allocation failures become boot errors, not a @500@ on+-- every signup. It also warms the Argon2 arena.+trialArgon2Derivation :: Argon2Params -> IO (Either Argon2Failure ())+trialArgon2Derivation params = try (void (hashPasswordArgon2id params "shomei boot trial"))++-- | Re-derive the hash with the parameters the stored string carries, and compare in constant+-- time.+--+-- Only the PHC-style string produced by 'hashPasswordArgon2id' is accepted. It splits into+-- @["", "argon2id", "v=19", "m=…,t=…,p=…", salt, digest]@ and re-derives with its own+-- parameters. Anything else, including an unparameterized three-part value or a PHC-shaped+-- string with unparseable parameters, is 'False'.+--+-- A malformed hash therefore returns 'False' /without hashing/ (~9 µs versus ~100 ms). That+-- is a timing oracle if a real credential can ever be malformed; it cannot, because only this+-- module writes them.+verifyPasswordArgon2id :: Text -> PasswordHash -> Bool+verifyPasswordArgon2id pw (PasswordHash stored) =+  case Text.splitOn "$" stored of+    ["", "argon2id", version, paramsText, saltB64, hashB64]+      | version == "v=" <> Text.pack (show phcVersion),+        Just params <- parsePhcParams paramsText ->+          check (toOptions params) saltB64 hashB64+    _ -> False+  where+    check opts saltB64 hashB64+      | Right salt <- b64dec saltB64,+        Right want <- b64dec hashB64 =+          constEq (deriveArgon2 opts (TE.encodeUtf8 pw) salt) want+      | otherwise = False++-- | A well-formed hash carrying @params@, whose preimage is nobody's password.+--+-- Verifying against it costs exactly what verifying a real credential hashed with the same+-- parameters costs, which is the whole point: the login paths that never reach a stored hash+-- (unknown account, suspended user) burn this instead, so a miss and a wrong password are+-- indistinguishable by response time. The salt and digest are fixed constants — the digest is+-- not the Argon2 output of anything, and nothing is ever expected to verify against it.+--+-- Both must stay valid base64 of the right lengths: 'verifyPasswordArgon2id' returns 'False'+-- /without hashing/ on a malformed string, which would silently reopen the oracle this closes.+dummyHashFor :: Argon2Params -> PasswordHash+dummyHashFor params = PasswordHash (phcEncode params salt digest)+  where+    salt = TE.encodeUtf8 (Text.replicate saltLen "\x2a") -- 16 bytes of '*'+    digest = TE.encodeUtf8 (Text.replicate hashLen "\x2a") -- 32 bytes of '*'++-- | A lower-case hex SHA-256 of a UTF-8 'Text'. Used by the server to derive the abuse+-- store's account key from a normalized email, so the brute-force tables never hold plaintext+-- addresses (EP-2).+sha256Hex :: Text -> Text+sha256Hex t =+  TE.decodeUtf8 (convertToBase Base16 (hashWith SHA256 (TE.encodeUtf8 t)))++-- Bounding the concurrency ----------------------------------------------------++-- | A bounded-permit gate for Argon2 work.+--+-- Two things make unbounded concurrent hashing dangerous, and neither is obvious from the+-- Haskell side. First, crypton reaches the C implementation through+-- @foreign import ccall unsafe@ (@Crypto.KDF.Argon2@), and an /unsafe/ foreign call cannot be+-- preempted: the calling capability is pinned for the ~100 ms the hash takes, with no+-- garbage-collection safepoint. GHC's default collector is stop-the-world and must synchronize+-- every capability, so one in-flight hash can stall every other thread in the process —+-- including requests that never touch a password. Second, each hash transiently allocates its+-- full memory cost (64 MiB by default); ten concurrent logins spike ~640 MB.+--+-- Bounding the number of simultaneous hashes bounds both. 'peakInUse' records the high-water+-- mark of simultaneous holders, which lets tests assert the bound directly instead of inferring+-- it from timing.+data HashingLimiter = HashingLimiter+  { permits :: !(TVar Int),+    peakInUse :: !(TVar Int),+    limit :: !Int+  }++-- | A limiter admitting at most @n@ concurrent hashes. A non-positive @n@ would block every+-- login forever, so it is clamped to 1.+newHashingLimiter :: Int -> IO HashingLimiter+newHashingLimiter n = do+  let capped = max 1 n+  free <- newTVarIO capped+  peak <- newTVarIO 0+  pure HashingLimiter {permits = free, peakInUse = peak, limit = capped}++-- | How many concurrent hashes this limiter admits.+hashingLimit :: HashingLimiter -> Int+hashingLimit hl = hl.limit++-- | The greatest number of hashes ever running simultaneously under this limiter. Never+-- exceeds 'hashingLimit'; read by tests and available for future metrics.+peakHashingConcurrency :: HashingLimiter -> IO Int+peakHashingConcurrency hl = readTVarIO hl.peakInUse++-- | Run @action@ holding one permit, blocking until one is free. The permit is released even+-- if @action@ throws.+withHashingPermit :: HashingLimiter -> IO a -> IO a+withHashingPermit hl = bracket_ (atomically acquire) (atomically release)+  where+    acquire :: STM ()+    acquire = do+      free <- readTVar hl.permits+      -- 'check' retries the transaction (parking this thread) until a permit appears.+      check (free > 0)+      writeTVar hl.permits (free - 1)+      modifyTVar' hl.peakInUse (max (hl.limit - (free - 1)))++    release :: STM ()+    release = modifyTVar' hl.permits (+ 1)++-- | Interpret the 'PasswordHasher' port with real Argon2id at @params@, admitting at most+-- @limiter@'s worth of concurrent derivations.+--+-- Every operation here is forced with 'evaluate' /inside/ the permit. 'HashPassword' is+-- deliberately forced too: the August 2026 review found that this was the one arm without an+-- 'evaluate', so its derivation ran during row encoding inside 'Pool.use'. A thunk that escapes+-- the bracket is a bound that does nothing.+runPasswordHasherCrypto ::+  (IOE :> es) => HashingLimiter -> Argon2Params -> Eff (PasswordHasher : es) a -> Eff es a+runPasswordHasherCrypto limiter params = interpret_ \case+  HashPassword (PlainPassword pw) ->+    liftIO (withHashingPermit limiter (hashPasswordArgon2id params pw >>= evaluate))+  VerifyPassword (PlainPassword pw) hash ->+    liftIO (withHashingPermit limiter (evaluate (verifyPasswordArgon2id pw hash)))+  -- Derive against a dummy hash carrying the *configured* parameters, so this costs exactly+  -- what the 'VerifyPassword' above costs. Never a constant hash: its baked-in parameters+  -- would drift from the configured ones and reopen the login timing oracle.+  VerifyPasswordDummy (PlainPassword pw) ->+    liftIO (withHashingPermit limiter (void (evaluate (verifyPasswordArgon2id pw (dummyHashFor params)))))++-- | A fresh opaque refresh token: base64url of 32 random bytes (the secret handed to the+-- client; only its hash is stored — see 'hashRefreshToken').+generateOpaqueToken :: IO Text+generateOpaqueToken = do+  raw <- getRandomBytes 32 :: IO ByteString+  pure (TE.decodeUtf8 (convertToBase Base64URLUnpadded raw))++-- | SHA-256 of the opaque token, base64url-encoded: what we persist in @token_hash@.+hashRefreshToken :: Text -> Text+hashRefreshToken tok =+  TE.decodeUtf8+    (convertToBase Base64URLUnpadded (convert (hashWith SHA256 (TE.encodeUtf8 tok)) :: ByteString))++runTokenGenCrypto :: (IOE :> es) => Eff (TokenGen : es) a -> Eff es a+runTokenGenCrypto = interpret_ \case+  GenerateOpaqueToken -> liftIO (RefreshToken <$> generateOpaqueToken)+  HashRefreshToken (RefreshToken t) -> pure (RefreshTokenHash (hashRefreshToken t))+  GenerateRandomBytes n -> liftIO (getRandomBytes n :: IO ByteString)
+ src/Shomei/Account/PasswordReset/Postgres.hs view
@@ -0,0 +1,177 @@+-- | PostgreSQL interpreter for the password-reset token store.+module Shomei.Account.PasswordReset.Postgres+  ( runPasswordResetTokenStorePostgres,++    -- * Statements shared with the unit-of-work interpreter++    -- | Exported so @Shomei.Session.UnitOfWork.Postgres@ can compose the store-owned CAS and+    -- revocation statements inside a transaction without duplicating their SQL.+    markConsumedStmt,+    revokeUserTokensStmt,+  )+where++import Contravariant.Extras (contrazip2, contrazip8)+import Data.UUID (UUID)+import Effectful (Eff, IOE, (:>))+import Effectful.Dispatch.Dynamic (interpret_)+import Effectful.Error.Static (Error, throwError)+import Hasql.Decoders qualified as D+import Hasql.Encoders qualified as E+import Hasql.Session qualified as Session+import Hasql.Statement (Statement, preparable)+import Shomei.Account.OneTimeToken.Domain (OneTimeTokenHash (..), OneTimeTokenStatus (..))+import Shomei.Account.PasswordReset.Domain (NewPasswordResetToken (..), PersistedPasswordResetToken (..))+import Shomei.Account.PasswordReset.Store (PasswordResetTokenStore (..))+import Shomei.Error (AuthError (..))+import Shomei.Id+  ( PasswordResetTokenId,+    genPasswordResetTokenId,+    passwordResetTokenIdFromUUID,+    passwordResetTokenIdToUUID,+    userIdFromUUID,+    userIdToUUID,+  )+import Shomei.Persistence.Codec.Postgres (oneTimeTokenStatusFromText, oneTimeTokenStatusToText)+import Shomei.Persistence.Database.Postgres (Database, postgresUnavailable, runSession)+import Shomei.Prelude++type TokenRow = (UUID, UUID, Text, Text, UTCTime, UTCTime, Maybe UTCTime, Maybe UTCTime)++runPasswordResetTokenStorePostgres ::+  (Database :> es, IOE :> es, Error AuthError :> es) =>+  Eff (PasswordResetTokenStore : es) a ->+  Eff es a+runPasswordResetTokenStorePostgres = interpret_ \case+  CreatePasswordResetToken nrt -> do+    tid <- genPasswordResetTokenId+    let persisted = mkPersisted tid nrt+        row =+          ( passwordResetTokenIdToUUID tid,+            userIdToUUID nrt.userId,+            tokenHashText nrt.tokenHash,+            oneTimeTokenStatusToText OneTimeTokenActive,+            nrt.createdAt,+            nrt.expiresAt,+            Nothing,+            Nothing+          )+    res <- runSession (Session.statement row insertTokenStmt)+    either dbFail (const (pure persisted)) res+  FindPasswordResetTokenByHash h -> do+    res <- runSession (Session.statement (tokenHashText h) findByHashStmt)+    row <- either dbFail pure res+    traverse rebuild row+  MarkPasswordResetTokenConsumed tid t -> do+    res <- runSession (Session.statement (passwordResetTokenIdToUUID tid, t) markConsumedStmt)+    either dbFail (pure . isJust) res+  RevokeUserPasswordResetTokens uid t -> do+    res <- runSession (Session.statement (userIdToUUID uid, t) revokeUserTokensStmt)+    either dbFail (const (pure ())) res+  where+    dbFail = throwError . postgresUnavailable+    rebuild r = either (throwError . InternalAuthError) pure (rebuildToken r)++tokenHashText :: OneTimeTokenHash -> Text+tokenHashText (OneTimeTokenHash t) = t++mkPersisted :: PasswordResetTokenId -> NewPasswordResetToken -> PersistedPasswordResetToken+mkPersisted tid nrt =+  PersistedPasswordResetToken+    { passwordResetTokenId = tid,+      userId = nrt.userId,+      tokenHash = nrt.tokenHash,+      status = OneTimeTokenActive,+      createdAt = nrt.createdAt,+      expiresAt = nrt.expiresAt,+      consumedAt = Nothing,+      revokedAt = Nothing+    }++rebuildToken :: TokenRow -> Either Text PersistedPasswordResetToken+rebuildToken (tid, uid, h, st, c, e, consumed, revoked) = do+  status <- oneTimeTokenStatusFromText st+  pure+    PersistedPasswordResetToken+      { passwordResetTokenId = passwordResetTokenIdFromUUID tid,+        userId = userIdFromUUID uid,+        tokenHash = OneTimeTokenHash h,+        status = status,+        createdAt = c,+        expiresAt = e,+        consumedAt = consumed,+        revokedAt = revoked+      }++tokenRowDecoder :: D.Row TokenRow+tokenRowDecoder =+  (,,,,,,,)+    <$> D.column (D.nonNullable D.uuid)+    <*> D.column (D.nonNullable D.uuid)+    <*> D.column (D.nonNullable D.text)+    <*> D.column (D.nonNullable D.text)+    <*> D.column (D.nonNullable D.timestamptz)+    <*> D.column (D.nonNullable D.timestamptz)+    <*> D.column (D.nullable D.timestamptz)+    <*> D.column (D.nullable D.timestamptz)++insertTokenStmt :: Statement TokenRow ()+insertTokenStmt =+  preparable+    """+    INSERT INTO shomei.shomei_password_reset_tokens+      (password_reset_token_id, user_id, token_hash, status, created_at, expires_at,+       consumed_at, revoked_at)+    VALUES ($1, $2, $3, $4, $5, $6, $7, $8)+    """+    ( contrazip8+        (E.param (E.nonNullable E.uuid))+        (E.param (E.nonNullable E.uuid))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.timestamptz))+        (E.param (E.nonNullable E.timestamptz))+        (E.param (E.nullable E.timestamptz))+        (E.param (E.nullable E.timestamptz))+    )+    D.noResult++findByHashStmt :: Statement Text (Maybe TokenRow)+findByHashStmt =+  preparable+    """+    SELECT password_reset_token_id, user_id, token_hash, status, created_at, expires_at,+           consumed_at, revoked_at+    FROM shomei.shomei_password_reset_tokens+    WHERE token_hash = $1+    """+    (E.param (E.nonNullable E.text))+    (D.rowMaybe tokenRowDecoder)++-- | Compare-and-swap: the @status = 'active'@ guard and the write are one statement, so two+-- concurrent confirmations of the same one-time token cannot both consume it. The loser+-- matches zero rows and returns no @RETURNING@ row.+markConsumedStmt :: Statement (UUID, UTCTime) (Maybe UUID)+markConsumedStmt =+  preparable+    """+    UPDATE shomei.shomei_password_reset_tokens+    SET status = 'consumed', consumed_at = $2+    WHERE password_reset_token_id = $1+      AND status = 'active'+    RETURNING password_reset_token_id+    """+    (contrazip2 (E.param (E.nonNullable E.uuid)) (E.param (E.nonNullable E.timestamptz)))+    (D.rowMaybe (D.column (D.nonNullable D.uuid)))++revokeUserTokensStmt :: Statement (UUID, UTCTime) ()+revokeUserTokensStmt =+  preparable+    """+    UPDATE shomei.shomei_password_reset_tokens+    SET status = 'revoked', revoked_at = $2+    WHERE user_id = $1+      AND status = 'active'+    """+    (contrazip2 (E.param (E.nonNullable E.uuid)) (E.param (E.nonNullable E.timestamptz)))+    D.noResult
+ src/Shomei/Account/User/Postgres.hs view
@@ -0,0 +1,242 @@+-- | PostgreSQL interpreter for the 'UserStore' port.+module Shomei.Account.User.Postgres+  ( runUserStorePostgres,+  )+where++import Contravariant.Extras (contrazip2, contrazip7)+import Data.Functor.Contravariant ((>$<))+import Data.Int (Int64)+import Data.UUID (UUID)+import Effectful (Eff, IOE, (:>))+import Effectful.Dispatch.Dynamic (interpret_)+import Effectful.Error.Static (Error, throwError)+import Hasql.Decoders qualified as D+import Hasql.Encoders qualified as E+import Hasql.Session qualified as Session+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.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++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) =>+  Eff (UserStore : es) a ->+  Eff es a+runUserStorePostgres = interpret_ \case+  CreateUser nu -> do+    uid <- genUserId+    ts <- liftIO getCurrentTime+    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+  FindUserById uid -> do+    res <- runSession (Session.statement (userIdToUUID uid) findUserByIdStmt)+    row <- either dbFail pure res+    traverse rebuild row+  FindUserByLoginId lid -> do+    res <- runSession (Session.statement (loginIdText lid) findUserByLoginIdStmt)+    row <- either dbFail pure res+    traverse rebuild row+  FindUserByEmail email -> do+    res <- runSession (Session.statement (emailText email) findUserByEmailStmt)+    row <- either dbFail pure res+    traverse rebuild row+  UpdateUserStatus uid allowed st ts -> do+    let params = (userIdToUUID uid, userStatusToText st, map userStatusToText allowed, ts)+    res <- runSession (Session.statement params updateUserStatusStmt)+    either dbFail (pure . isJust) res+  MarkUserEmailVerified uid ts -> do+    res <- runSession (Session.statement (userIdToUUID uid, ts) markEmailVerifiedStmt)+    either dbFail (const (pure ())) res+  ListUsers q -> do+    res <- runSession (Session.statement (toListParams q) listUsersStmt)+    rows <- either dbFail pure res+    traverse rebuild rows+  where+    dbFail = throwError . postgresUnavailable+    rebuild r = either (throwError . InternalAuthError) pure (rebuildUser r)++identityConflict :: Text -> Maybe AuthError+identityConflict = \case+  "shomei_users_login_id_key" -> Just LoginIdAlreadyRegistered+  "shomei_users_login_id_lower_key" -> Just LoginIdAlreadyRegistered+  "shomei_users_email_key" -> Just EmailAlreadyRegistered+  "shomei_users_email_lower_key" -> Just EmailAlreadyRegistered+  _ -> Nothing++-- | Flatten a 'UserListQuery' into the statement's parameter tuple: the optional cursor splits+-- into its two columns, and the limit is clamped here so no caller can ask the database for an+-- unbounded scan.+toListParams :: UserListQuery -> ListParams+toListParams q =+  ( userStatusToText <$> q.queryStatus,+    (.cursorCreatedAt) <$> q.queryBefore,+    userIdToUUID . (.cursorUserId) <$> q.queryBefore,+    fromIntegral (clampUserLimit q.queryLimit)+  )++mkUser :: UserId -> NewUser -> UTCTime -> User+mkUser uid nu ts =+  User+    { userId = uid,+      loginId = nu.loginId,+      email = nu.email,+      displayName = nu.displayName,+      status = UserActive,+      emailVerifiedAt = Nothing,+      createdAt = ts,+      updatedAt = ts+    }++rebuildUser :: UserRow -> Either Text User+rebuildUser (uid, lid, e, dn, st, verified, c, u) = do+  loginId <- loginIdFromDb lid+  email <- maybeEmailFromDb e+  status <- userStatusFromText st+  pure+    User+      { userId = userIdFromUUID uid,+        loginId = loginId,+        email = email,+        displayName = dn,+        status = status,+        emailVerifiedAt = verified,+        createdAt = c,+        updatedAt = u+      }++userRowDecoder :: D.Row UserRow+userRowDecoder =+  (,,,,,,,)+    <$> D.column (D.nonNullable D.uuid)+    <*> D.column (D.nonNullable D.text)+    <*> D.column (D.nullable D.text)+    <*> D.column (D.nullable D.text)+    <*> D.column (D.nonNullable D.text)+    <*> D.column (D.nullable D.timestamptz)+    <*> D.column (D.nonNullable D.timestamptz)+    <*> D.column (D.nonNullable D.timestamptz)++insertUserStmt :: Statement InsertUserRow ()+insertUserStmt =+  preparable+    """+    INSERT INTO shomei.shomei_users+      (user_id, login_id, email, display_name, status, created_at, updated_at)+    VALUES ($1, $2, $3, $4, $5, $6, $7)+    """+    ( contrazip7+        (E.param (E.nonNullable E.uuid))+        (E.param (E.nonNullable E.text))+        (E.param (E.nullable E.text))+        (E.param (E.nullable E.text))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.timestamptz))+        (E.param (E.nonNullable E.timestamptz))+    )+    D.noResult++findUserByIdStmt :: Statement UUID (Maybe UserRow)+findUserByIdStmt =+  preparable+    """+    SELECT user_id, login_id, email, display_name, status, email_verified_at, created_at, updated_at+    FROM shomei.shomei_users+    WHERE user_id = $1+    """+    (E.param (E.nonNullable E.uuid))+    (D.rowMaybe userRowDecoder)++findUserByLoginIdStmt :: Statement Text (Maybe UserRow)+findUserByLoginIdStmt =+  preparable+    """+    SELECT user_id, login_id, email, display_name, status, email_verified_at, created_at, updated_at+    FROM shomei.shomei_users+    WHERE login_id = $1+    """+    (E.param (E.nonNullable E.text))+    (D.rowMaybe userRowDecoder)++findUserByEmailStmt :: Statement Text (Maybe UserRow)+findUserByEmailStmt =+  preparable+    """+    SELECT user_id, login_id, email, display_name, status, email_verified_at, created_at, updated_at+    FROM shomei.shomei_users+    WHERE email = $1+    """+    (E.param (E.nonNullable E.text))+    (D.rowMaybe userRowDecoder)++-- | The allowed-status predicate makes the transition a compare-and-swap. The returned row+-- identifies the sole winner under concurrency, and the caller-provided timestamp keeps the+-- status write and its audit tail on the same clock reading.+updateUserStatusStmt :: Statement (UUID, Text, [Text], UTCTime) (Maybe UUID)+updateUserStatusStmt =+  preparable+    """+    UPDATE shomei.shomei_users+    SET status = $2, updated_at = $4+    WHERE user_id = $1 AND status = ANY ($3)+    RETURNING user_id+    """+    ( ((\(a, _, _, _) -> a) >$< E.param (E.nonNullable E.uuid))+        <> ((\(_, b, _, _) -> b) >$< E.param (E.nonNullable E.text))+        <> ((\(_, _, c, _) -> c) >$< E.param (E.nonNullable (E.foldableArray (E.nonNullable E.text))))+        <> ((\(_, _, _, d) -> d) >$< E.param (E.nonNullable E.timestamptz))+    )+    (D.rowMaybe (D.column (D.nonNullable D.uuid)))++markEmailVerifiedStmt :: Statement (UUID, UTCTime) ()+markEmailVerifiedStmt =+  preparable+    """+    UPDATE shomei.shomei_users+    SET email_verified_at = $2, updated_at = $2+    WHERE user_id = $1+    """+    (contrazip2 (E.param (E.nonNullable E.uuid)) (E.param (E.nonNullable E.timestamptz)))+    D.noResult++-- | @(status filter, cursor created_at, cursor user_id, limit)@.+type ListParams = (Maybe Text, Maybe UTCTime, Maybe UUID, Int64)++-- | The optional-filter encoder, built as a 'E.Params' monoid: each field projects out of the+-- tuple and contramaps onto one @E.param@. Same idiom as+-- "Shomei.Audit.Reader.Postgres"'s query encoder.+listUsersEncoder :: E.Params ListParams+listUsersEncoder =+  ((\(a, _, _, _) -> a) >$< E.param (E.nullable E.text))+    <> ((\(_, b, _, _) -> b) >$< E.param (E.nullable E.timestamptz))+    <> ((\(_, _, c, _) -> c) >$< E.param (E.nullable E.uuid))+    <> ((\(_, _, _, d) -> d) >$< E.param (E.nonNullable E.int8))++-- | Newest-first, keyset-paginated. The @$n::type IS NULL OR …@ idiom keeps one prepared+-- statement serving both the filtered and unfiltered cases. The row comparison+-- @(created_at, user_id) < ($2, $3)@ is a genuine tuple comparison, so it is total even when+-- several users share a @created_at@ — which is exactly when an OFFSET would skip or repeat a row.+listUsersStmt :: Statement ListParams [UserRow]+listUsersStmt =+  preparable+    """+    SELECT user_id, login_id, email, display_name, status, email_verified_at, created_at, updated_at+    FROM shomei.shomei_users+    WHERE ($1::text        IS NULL OR status = $1)+      AND ($2::timestamptz IS NULL OR (created_at, user_id) < ($2, $3))+    ORDER BY created_at DESC, user_id DESC+    LIMIT $4+    """+    listUsersEncoder+    (D.rowList userRowDecoder)
+ src/Shomei/Account/Verification/Postgres.hs view
@@ -0,0 +1,170 @@+-- | PostgreSQL interpreter for the email-verification token store.+module Shomei.Account.Verification.Postgres+  ( runVerificationTokenStorePostgres,+  )+where++import Contravariant.Extras (contrazip2, contrazip8)+import Data.UUID (UUID)+import Effectful (Eff, IOE, (:>))+import Effectful.Dispatch.Dynamic (interpret_)+import Effectful.Error.Static (Error, throwError)+import Hasql.Decoders qualified as D+import Hasql.Encoders qualified as E+import Hasql.Session qualified as Session+import Hasql.Statement (Statement, preparable)+import Shomei.Account.OneTimeToken.Domain (OneTimeTokenHash (..), OneTimeTokenStatus (..))+import Shomei.Account.Verification.Domain (NewVerificationToken (..), PersistedVerificationToken (..))+import Shomei.Account.Verification.Store (VerificationTokenStore (..))+import Shomei.Error (AuthError (..))+import Shomei.Id+  ( VerificationTokenId,+    genVerificationTokenId,+    userIdFromUUID,+    userIdToUUID,+    verificationTokenIdFromUUID,+    verificationTokenIdToUUID,+  )+import Shomei.Persistence.Codec.Postgres (oneTimeTokenStatusFromText, oneTimeTokenStatusToText)+import Shomei.Persistence.Database.Postgres (Database, postgresUnavailable, runSession)+import Shomei.Prelude++type TokenRow = (UUID, UUID, Text, Text, UTCTime, UTCTime, Maybe UTCTime, Maybe UTCTime)++runVerificationTokenStorePostgres ::+  (Database :> es, IOE :> es, Error AuthError :> es) =>+  Eff (VerificationTokenStore : es) a ->+  Eff es a+runVerificationTokenStorePostgres = interpret_ \case+  CreateVerificationToken nvt -> do+    tid <- genVerificationTokenId+    let persisted = mkPersisted tid nvt+        row =+          ( verificationTokenIdToUUID tid,+            userIdToUUID nvt.userId,+            tokenHashText nvt.tokenHash,+            oneTimeTokenStatusToText OneTimeTokenActive,+            nvt.createdAt,+            nvt.expiresAt,+            Nothing,+            Nothing+          )+    res <- runSession (Session.statement row insertTokenStmt)+    either dbFail (const (pure persisted)) res+  FindVerificationTokenByHash h -> do+    res <- runSession (Session.statement (tokenHashText h) findByHashStmt)+    row <- either dbFail pure res+    traverse rebuild row+  MarkVerificationTokenConsumed tid t -> do+    res <- runSession (Session.statement (verificationTokenIdToUUID tid, t) markConsumedStmt)+    either dbFail (pure . isJust) res+  RevokeUserVerificationTokens uid t -> do+    res <- runSession (Session.statement (userIdToUUID uid, t) revokeUserTokensStmt)+    either dbFail (const (pure ())) res+  where+    dbFail = throwError . postgresUnavailable+    rebuild r = either (throwError . InternalAuthError) pure (rebuildToken r)++tokenHashText :: OneTimeTokenHash -> Text+tokenHashText (OneTimeTokenHash t) = t++mkPersisted :: VerificationTokenId -> NewVerificationToken -> PersistedVerificationToken+mkPersisted tid nvt =+  PersistedVerificationToken+    { verificationTokenId = tid,+      userId = nvt.userId,+      tokenHash = nvt.tokenHash,+      status = OneTimeTokenActive,+      createdAt = nvt.createdAt,+      expiresAt = nvt.expiresAt,+      consumedAt = Nothing,+      revokedAt = Nothing+    }++rebuildToken :: TokenRow -> Either Text PersistedVerificationToken+rebuildToken (tid, uid, h, st, c, e, consumed, revoked) = do+  status <- oneTimeTokenStatusFromText st+  pure+    PersistedVerificationToken+      { verificationTokenId = verificationTokenIdFromUUID tid,+        userId = userIdFromUUID uid,+        tokenHash = OneTimeTokenHash h,+        status = status,+        createdAt = c,+        expiresAt = e,+        consumedAt = consumed,+        revokedAt = revoked+      }++tokenRowDecoder :: D.Row TokenRow+tokenRowDecoder =+  (,,,,,,,)+    <$> D.column (D.nonNullable D.uuid)+    <*> D.column (D.nonNullable D.uuid)+    <*> D.column (D.nonNullable D.text)+    <*> D.column (D.nonNullable D.text)+    <*> D.column (D.nonNullable D.timestamptz)+    <*> D.column (D.nonNullable D.timestamptz)+    <*> D.column (D.nullable D.timestamptz)+    <*> D.column (D.nullable D.timestamptz)++insertTokenStmt :: Statement TokenRow ()+insertTokenStmt =+  preparable+    """+    INSERT INTO shomei.shomei_email_verification_tokens+      (verification_token_id, user_id, token_hash, status, created_at, expires_at,+       consumed_at, revoked_at)+    VALUES ($1, $2, $3, $4, $5, $6, $7, $8)+    """+    ( contrazip8+        (E.param (E.nonNullable E.uuid))+        (E.param (E.nonNullable E.uuid))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.timestamptz))+        (E.param (E.nonNullable E.timestamptz))+        (E.param (E.nullable E.timestamptz))+        (E.param (E.nullable E.timestamptz))+    )+    D.noResult++findByHashStmt :: Statement Text (Maybe TokenRow)+findByHashStmt =+  preparable+    """+    SELECT verification_token_id, user_id, token_hash, status, created_at, expires_at,+           consumed_at, revoked_at+    FROM shomei.shomei_email_verification_tokens+    WHERE token_hash = $1+    """+    (E.param (E.nonNullable E.text))+    (D.rowMaybe tokenRowDecoder)++-- | Compare-and-swap: the @status = 'active'@ guard and the write are one statement, so two+-- concurrent confirmations of the same one-time token cannot both consume it. The loser+-- matches zero rows and returns no @RETURNING@ row.+markConsumedStmt :: Statement (UUID, UTCTime) (Maybe UUID)+markConsumedStmt =+  preparable+    """+    UPDATE shomei.shomei_email_verification_tokens+    SET status = 'consumed', consumed_at = $2+    WHERE verification_token_id = $1+      AND status = 'active'+    RETURNING verification_token_id+    """+    (contrazip2 (E.param (E.nonNullable E.uuid)) (E.param (E.nonNullable E.timestamptz)))+    (D.rowMaybe (D.column (D.nonNullable D.uuid)))++revokeUserTokensStmt :: Statement (UUID, UTCTime) ()+revokeUserTokensStmt =+  preparable+    """+    UPDATE shomei.shomei_email_verification_tokens+    SET status = 'revoked', revoked_at = $2+    WHERE user_id = $1+      AND status = 'active'+    """+    (contrazip2 (E.param (E.nonNullable E.uuid)) (E.param (E.nonNullable E.timestamptz)))+    D.noResult
+ src/Shomei/Audit/Publisher/Postgres.hs view
@@ -0,0 +1,62 @@+-- | PostgreSQL interpreter for the 'AuthEventPublisher' port. Each 'AuthEvent' arm is+-- projected to (user_id?, session_id?, event_type, JSON payload, occurredAt) and inserted+-- into @shomei_auth_events@.+module Shomei.Audit.Publisher.Postgres+  ( runAuthEventPublisherPostgres,++    -- * Statement shared with the unit-of-work interpreter++    -- | Exported so @Shomei.Session.UnitOfWork.Postgres@ can lift it into a transaction with+    --     @Hasql.Transaction.statement@ instead of restating the SQL.+    AuthEventRow,+    insertAuthEventStmt,+  )+where++import Contravariant.Extras (contrazip6)+import Data.Aeson (Value)+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.Decoders qualified as D+import Hasql.Encoders qualified as E+import Hasql.Session qualified as Session+import Hasql.Statement (Statement, preparable)+import Shomei.Audit.Event.Codec (projectAuthEvent)+import Shomei.Audit.Publisher.Store (AuthEventPublisher (..))+import Shomei.Error (AuthError (..))+import Shomei.Persistence.Database.Postgres (Database, postgresUnavailable, runSession)+import Shomei.Prelude++type AuthEventRow = (UUID, Maybe UUID, Maybe UUID, Text, Value, UTCTime)++runAuthEventPublisherPostgres ::+  (Database :> es, IOE :> es, Error AuthError :> es) =>+  Eff (AuthEventPublisher : es) a ->+  Eff es a+runAuthEventPublisherPostgres = interpret_ \case+  PublishAuthEvent ev -> do+    eid <- liftIO UUIDv4.nextRandom+    let (mUser, mSession, etype, payload, ts) = projectAuthEvent ev+    res <- runSession (Session.statement (eid, mUser, mSession, etype, payload, ts) insertAuthEventStmt)+    either (throwError . postgresUnavailable) (const (pure ())) res++insertAuthEventStmt :: Statement AuthEventRow ()+insertAuthEventStmt =+  preparable+    """+    INSERT INTO shomei.shomei_auth_events+      (event_id, user_id, session_id, event_type, payload, created_at)+    VALUES ($1, $2, $3, $4, $5, $6)+    """+    ( contrazip6+        (E.param (E.nonNullable E.uuid))+        (E.param (E.nullable E.uuid))+        (E.param (E.nullable E.uuid))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.jsonb))+        (E.param (E.nonNullable E.timestamptz))+    )+    D.noResult
+ src/Shomei/Audit/Reader/Postgres.hs view
@@ -0,0 +1,167 @@+-- | PostgreSQL interpreter for the 'AuthEventReader' port: the read counterpart to+-- 'Shomei.Audit.Publisher.Postgres'. It issues only @SELECT@/@COUNT@ against the+-- append-only @shomei_auth_events@ table — there is no path here that mutates the audit+-- trail.+--+-- The query is a single parameterized statement that handles every optional filter with the+-- @($n IS NULL OR col = $n)@ idiom, applies a keyset (seek) predicate on+-- @(created_at, event_id)@, orders newest-first, and limits. The count uses the same filters+-- without ordering/limit/cursor.+module Shomei.Audit.Reader.Postgres+  ( runAuthEventReaderPostgres,+  )+where++import Data.Functor.Contravariant ((>$<))+import Data.Int (Int64)+import Data.UUID (UUID)+import Effectful (Eff, (:>))+import Effectful.Dispatch.Dynamic (interpret_)+import Effectful.Error.Static (Error, throwError)+import Hasql.Decoders qualified as D+import Hasql.Encoders qualified as E+import Hasql.Session qualified as Session+import Hasql.Statement (Statement, preparable)+import Shomei.Audit.Reader.Store+  ( AuditCursor (..),+    AuditEventQuery (..),+    AuthEventReader (..),+    StoredAuthEvent (..),+    clampLimit,+  )+import Shomei.Error (AuthError (..))+import Shomei.Persistence.Database.Postgres (Database, postgresUnavailable, runSession)+import Shomei.Prelude++-- Note: unlike 'runAuthEventPublisherPostgres' this interpreter needs no @IOE :> es@+-- constraint — reads go entirely through the @Database@ effect (no @liftIO@). It still+-- slots into any stack that also provides @IOE@.+runAuthEventReaderPostgres ::+  (Database :> es, Error AuthError :> es) =>+  Eff (AuthEventReader : es) a ->+  Eff es a+runAuthEventReaderPostgres = interpret_ \case+  QueryAuthEvents q -> do+    res <- runSession (Session.statement (toQueryParams q) selectStmt)+    either dbErr pure res+  CountAuthEvents q -> do+    res <- runSession (Session.statement (toCountParams q) countStmt)+    either dbErr pure res+  where+    dbErr = throwError . postgresUnavailable++-- | Parameter bundle for the SELECT (filters, then cursor, then limit).+type QueryParams =+  ( Maybe UUID, -- user_id+    Maybe UUID, -- session_id+    [Text], -- event_type list ([] = all)+    Maybe UTCTime, -- since (>=)+    Maybe UTCTime, -- until (<)+    Maybe UTCTime, -- before cursor created_at+    Maybe UUID, -- before cursor event_id+    Int64 -- limit+  )++-- | Parameter bundle for the COUNT: the same filters, no cursor/limit.+type CountParams =+  (Maybe UUID, Maybe UUID, [Text], Maybe UTCTime, Maybe UTCTime)++toQueryParams :: AuditEventQuery -> QueryParams+toQueryParams q =+  ( queryUserId q,+    querySessionId q,+    queryEventTypes q,+    querySince q,+    queryUntil q,+    beforeTs,+    beforeId,+    fromIntegral (clampLimit (queryLimit q))+  )+  where+    (beforeTs, beforeId) = case queryBefore q of+      Nothing -> (Nothing, Nothing)+      Just (AuditCursor t e) -> (Just t, Just e)++toCountParams :: AuditEventQuery -> CountParams+toCountParams q =+  (queryUserId q, querySessionId q, queryEventTypes q, querySince q, queryUntil q)++-- | Encode a @text[]@ parameter (for the @event_type = ANY($3)@ filter).+textArray :: E.Value [Text]+textArray = E.foldableArray (E.nonNullable E.text)++queryEncoder :: E.Params QueryParams+queryEncoder =+  ((\(a, _, _, _, _, _, _, _) -> a) >$< E.param (E.nullable E.uuid))+    <> ((\(_, b, _, _, _, _, _, _) -> b) >$< E.param (E.nullable E.uuid))+    <> ((\(_, _, c, _, _, _, _, _) -> c) >$< E.param (E.nonNullable textArray))+    <> ((\(_, _, _, d, _, _, _, _) -> d) >$< E.param (E.nullable E.timestamptz))+    <> ((\(_, _, _, _, e, _, _, _) -> e) >$< E.param (E.nullable E.timestamptz))+    <> ((\(_, _, _, _, _, f, _, _) -> f) >$< E.param (E.nullable E.timestamptz))+    <> ((\(_, _, _, _, _, _, g, _) -> g) >$< E.param (E.nullable E.uuid))+    <> ((\(_, _, _, _, _, _, _, h) -> h) >$< E.param (E.nonNullable E.int8))++countEncoder :: E.Params CountParams+countEncoder =+  ((\(a, _, _, _, _) -> a) >$< E.param (E.nullable E.uuid))+    <> ((\(_, b, _, _, _) -> b) >$< E.param (E.nullable E.uuid))+    <> ((\(_, _, c, _, _) -> c) >$< E.param (E.nonNullable textArray))+    <> ((\(_, _, _, d, _) -> d) >$< E.param (E.nullable E.timestamptz))+    <> ((\(_, _, _, _, e) -> e) >$< E.param (E.nullable E.timestamptz))++-- | Decode a row into a 'StoredAuthEvent'. The SELECT column order is+-- @event_id, user_id, session_id, event_type, payload, created_at@ but the record field+-- order differs, so decode positionally (@D.Row@ is 'Applicative', not 'Monad', in this+-- @hasql@ version) and reassemble the record with 'mk'.+storedRowDecoder :: D.Row StoredAuthEvent+storedRowDecoder =+  mk+    <$> D.column (D.nonNullable D.uuid) -- event_id+    <*> D.column (D.nullable D.uuid) -- user_id+    <*> D.column (D.nullable D.uuid) -- session_id+    <*> D.column (D.nonNullable D.text) -- event_type+    <*> D.column (D.nonNullable D.jsonb) -- payload+    <*> D.column (D.nonNullable D.timestamptz) -- created_at+  where+    mk eid uid sid etype pl cat =+      StoredAuthEvent+        { storedEventId = eid,+          storedEventType = etype,+          storedUserId = uid,+          storedSessionId = sid,+          storedCreatedAt = cat,+          storedPayload = pl+        }++selectStmt :: Statement QueryParams [StoredAuthEvent]+selectStmt =+  preparable+    """+    SELECT event_id, user_id, session_id, event_type, payload, created_at+    FROM shomei.shomei_auth_events+    WHERE ($1::uuid        IS NULL OR user_id    = $1)+      AND ($2::uuid        IS NULL OR session_id = $2)+      AND (cardinality($3::text[]) = 0 OR event_type = ANY($3))+      AND ($4::timestamptz IS NULL OR created_at >= $4)+      AND ($5::timestamptz IS NULL OR created_at <  $5)+      AND ($6::timestamptz IS NULL OR (created_at, event_id) < ($6, $7))+    ORDER BY created_at DESC, event_id DESC+    LIMIT $8+    """+    queryEncoder+    (D.rowList storedRowDecoder)++countStmt :: Statement CountParams Int+countStmt =+  preparable+    """+    SELECT count(*)+    FROM shomei.shomei_auth_events+    WHERE ($1::uuid        IS NULL OR user_id    = $1)+      AND ($2::uuid        IS NULL OR session_id = $2)+      AND (cardinality($3::text[]) = 0 OR event_type = ANY($3))+      AND ($4::timestamptz IS NULL OR created_at >= $4)+      AND ($5::timestamptz IS NULL OR created_at <  $5)+    """+    countEncoder+    (D.singleRow (fromIntegral <$> D.column (D.nonNullable D.int8)))
+ src/Shomei/Authorization/Role/Postgres.hs view
@@ -0,0 +1,209 @@+-- | PostgreSQL interpreter for the 'RoleStore' port: the @shomei_roles@ registry, the+-- @shomei_role_grants@ table (with an optional expiry), and the @shomei_role_permissions@+-- role→permission definitions.+--+-- @DefineRole@, @GrantRole@, @RevokeRole@, @AllowPermission@, and @DisallowPermission@ report+-- whether they changed anything by reading @rowsAffected@; the @ON CONFLICT@ clauses make the+-- inserts idempotent, so a caller publishes an audit event only on a real state change. @GrantRole@+-- is an upsert guarded by @expires_at IS DISTINCT FROM@, so re-granting with a different expiry+-- still reports a change while an identical re-grant stays silent.+--+-- Like 'Shomei.Audit.Reader.Postgres' this interpreter needs no @IOE :> es@ constraint: every+-- operation goes through the @Database@ effect with no @liftIO@.+module Shomei.Authorization.Role.Postgres+  ( runRoleStorePostgres,+  )+where++import Contravariant.Extras (contrazip2, contrazip3, contrazip5)+import Data.Int (Int64)+import Data.Set qualified as Set+import Data.UUID (UUID)+import Effectful (Eff, (:>))+import Effectful.Dispatch.Dynamic (interpret_)+import Effectful.Error.Static (Error, throwError)+import Hasql.Decoders qualified as D+import Hasql.Encoders qualified as E+import Hasql.Session qualified as Session+import Hasql.Statement (Statement, preparable)+import Shomei.Authorization.Claims.Domain (Permission (..), Role (..))+import Shomei.Authorization.Role.Store (RoleDefinition (..), RoleStore (..))+import Shomei.Error (AuthError (..))+import Shomei.Id (userIdToUUID)+import Shomei.Persistence.Database.Postgres (Database, postgresUnavailable, runSession)+import Shomei.Prelude++runRoleStorePostgres ::+  (Database :> es, Error AuthError :> es) =>+  Eff (RoleStore : es) a ->+  Eff es a+runRoleStorePostgres = interpret_ \case+  DefineRole (Role r) desc ts -> do+    res <- runSession (Session.statement (r, desc, ts) defineRoleStmt)+    changed <$> either dbFail pure res+  ListDefinedRoles -> do+    res <- runSession (Session.statement () listDefinedRolesStmt)+    either dbFail pure res+  GrantRole uid (Role r) by expiry ts -> do+    let row = (userIdToUUID uid, r, userIdToUUID <$> by, expiry, ts)+    res <- runSession (Session.statement row grantRoleStmt)+    changed <$> either dbFail pure res+  RevokeRole uid (Role r) -> do+    res <- runSession (Session.statement (userIdToUUID uid, r) revokeRoleStmt)+    changed <$> either dbFail pure res+  ListRolesForUser uid asOf -> do+    res <- runSession (Session.statement (userIdToUUID uid, asOf) listRolesForUserStmt)+    Set.fromList . map Role <$> either dbFail pure res+  AllowPermission (Role r) (Permission p) ts -> do+    res <- runSession (Session.statement (r, p, ts) allowPermissionStmt)+    changed <$> either dbFail pure res+  DisallowPermission (Role r) (Permission p) -> do+    res <- runSession (Session.statement (r, p) disallowPermissionStmt)+    changed <$> either dbFail pure res+  ListPermissionsForRole (Role r) -> do+    res <- runSession (Session.statement r permissionsForRoleStmt)+    Set.fromList . map Permission <$> either dbFail pure res+  PermissionsForRoles roles -> do+    let names = map (\(Role r) -> r) (Set.toList roles)+    res <- runSession (Session.statement names permissionsForRolesStmt)+    Set.fromList . map Permission <$> either dbFail pure res+  where+    dbFail = throwError . postgresUnavailable+    changed :: Int64 -> Bool+    changed = (> 0)++roleDefinitionDecoder :: D.Row RoleDefinition+roleDefinitionDecoder =+  RoleDefinition+    <$> (Role <$> D.column (D.nonNullable D.text))+    <*> D.column (D.nullable D.text)+    <*> D.column (D.nonNullable D.timestamptz)++-- | @rowsAffected@ is 0 when the role was already defined. The existing description is left+-- untouched — a re-definition is a no-op, not an update.+defineRoleStmt :: Statement (Text, Maybe Text, UTCTime) Int64+defineRoleStmt =+  preparable+    """+    INSERT INTO shomei.shomei_roles (role, description, created_at)+    VALUES ($1, $2, $3)+    ON CONFLICT (role) DO NOTHING+    """+    ( contrazip3+        (E.param (E.nonNullable E.text))+        (E.param (E.nullable E.text))+        (E.param (E.nonNullable E.timestamptz))+    )+    D.rowsAffected++listDefinedRolesStmt :: Statement () [RoleDefinition]+listDefinedRolesStmt =+  preparable+    """+    SELECT role, description, created_at+    FROM shomei.shomei_roles+    ORDER BY role+    """+    E.noParams+    (D.rowList roleDefinitionDecoder)++-- | Upsert. @rowsAffected@ is 0 only when an identical grant (same expiry) already existed: the+-- @IS DISTINCT FROM@ guard means a re-grant that changes the expiry still updates the row and+-- reports a change, so the workflow re-audits it, while an unchanged re-grant stays silent.+grantRoleStmt :: Statement (UUID, Text, Maybe UUID, Maybe UTCTime, UTCTime) Int64+grantRoleStmt =+  preparable+    """+    INSERT INTO shomei.shomei_role_grants (user_id, role, granted_by, expires_at, granted_at)+    VALUES ($1, $2, $3, $4, $5)+    ON CONFLICT (user_id, role) DO UPDATE+      SET expires_at = EXCLUDED.expires_at,+          granted_by = EXCLUDED.granted_by,+          granted_at = EXCLUDED.granted_at+      WHERE shomei_role_grants.expires_at IS DISTINCT FROM EXCLUDED.expires_at+    """+    ( contrazip5+        (E.param (E.nonNullable E.uuid))+        (E.param (E.nonNullable E.text))+        (E.param (E.nullable E.uuid))+        (E.param (E.nullable E.timestamptz))+        (E.param (E.nonNullable E.timestamptz))+    )+    D.rowsAffected++-- | @rowsAffected@ is 0 when there was no such grant to remove.+revokeRoleStmt :: Statement (UUID, Text) Int64+revokeRoleStmt =+  preparable+    """+    DELETE FROM shomei.shomei_role_grants+    WHERE user_id = $1 AND role = $2+    """+    (contrazip2 (E.param (E.nonNullable E.uuid)) (E.param (E.nonNullable E.text)))+    D.rowsAffected++-- | Expiry-filtered as of $2: a grant whose @expires_at@ is at or before the instant is excluded.+-- A NULL @expires_at@ (forever) always passes.+listRolesForUserStmt :: Statement (UUID, UTCTime) [Text]+listRolesForUserStmt =+  preparable+    """+    SELECT role+    FROM shomei.shomei_role_grants+    WHERE user_id = $1 AND (expires_at IS NULL OR expires_at > $2)+    ORDER BY role+    """+    (contrazip2 (E.param (E.nonNullable E.uuid)) (E.param (E.nonNullable E.timestamptz)))+    (D.rowList (D.column (D.nonNullable D.text)))++-- | @rowsAffected@ is 0 when the permission was already attached to the role.+allowPermissionStmt :: Statement (Text, Text, UTCTime) Int64+allowPermissionStmt =+  preparable+    """+    INSERT INTO shomei.shomei_role_permissions (role, permission, created_at)+    VALUES ($1, $2, $3)+    ON CONFLICT (role, permission) DO NOTHING+    """+    ( contrazip3+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.timestamptz))+    )+    D.rowsAffected++-- | @rowsAffected@ is 0 when there was no such attachment to remove.+disallowPermissionStmt :: Statement (Text, Text) Int64+disallowPermissionStmt =+  preparable+    """+    DELETE FROM shomei.shomei_role_permissions+    WHERE role = $1 AND permission = $2+    """+    (contrazip2 (E.param (E.nonNullable E.text)) (E.param (E.nonNullable E.text)))+    D.rowsAffected++permissionsForRoleStmt :: Statement Text [Text]+permissionsForRoleStmt =+  preparable+    """+    SELECT permission+    FROM shomei.shomei_role_permissions+    WHERE role = $1+    ORDER BY permission+    """+    (E.param (E.nonNullable E.text))+    (D.rowList (D.column (D.nonNullable D.text)))++-- | The deduplicated union of permissions across a role set — one round trip on the mint path.+permissionsForRolesStmt :: Statement [Text] [Text]+permissionsForRolesStmt =+  preparable+    """+    SELECT DISTINCT permission+    FROM shomei.shomei_role_permissions+    WHERE role = ANY ($1)+    ORDER BY permission+    """+    (E.param (E.nonNullable (E.foldableArray (E.nonNullable E.text))))+    (D.rowList (D.column (D.nonNullable D.text)))
+ src/Shomei/Mfa/RecoveryCode/Postgres.hs view
@@ -0,0 +1,105 @@+-- | PostgreSQL interpreter for the EP-7 recovery-code store.+--+-- Codes are stored only as SHA-256 hex hashes. 'ConsumeRecoveryCode' is the compare-and-set+-- @UPDATE … WHERE used_at IS NULL … RETURNING@ that makes a double-spend impossible even under a+-- race; 'ReplaceRecoveryCodes' deletes the user's set and inserts the new one in one 'Session'+-- so they land together.+module Shomei.Mfa.RecoveryCode.Postgres+  ( runRecoveryCodeStorePostgres,+  )+where++import Contravariant.Extras (contrazip3, contrazip4)+import Data.Int (Int64)+import Data.Maybe (isJust)+import Data.UUID (UUID)+import Effectful (Eff, IOE, (:>))+import Effectful.Dispatch.Dynamic (interpret_)+import Effectful.Error.Static (Error, throwError)+import Hasql.Decoders qualified as D+import Hasql.Encoders qualified as E+import Hasql.Session qualified as Session+import Hasql.Statement (Statement, preparable)+import Shomei.Error (AuthError (..))+import Shomei.Id (recoveryCodeIdToUUID, userIdToUUID)+import Shomei.Mfa.RecoveryCode.Store (RecoveryCodeStore (..))+import Shomei.Mfa.Totp.Domain (NewRecoveryCode (..))+import Shomei.Persistence.Database.Postgres (Database, postgresUnavailable, runSession)+import Shomei.Prelude++runRecoveryCodeStorePostgres ::+  (Database :> es, IOE :> es, Error AuthError :> es) =>+  Eff (RecoveryCodeStore : es) a ->+  Eff es a+runRecoveryCodeStorePostgres = interpret_ \case+  ReplaceRecoveryCodes uid newCodes -> do+    let uidU = userIdToUUID uid+        rows =+          [ (recoveryCodeIdToUUID nc.recoveryCodeId, uidU, nc.codeHash, nc.createdAt)+          | nc <- newCodes+          ]+    res <- runSession do+      Session.statement uidU deleteForUserStmt+      mapM_ (`Session.statement` insertStmt) rows+    either dbFail (const (pure ())) res+  ConsumeRecoveryCode uid h t -> do+    res <- runSession (Session.statement (userIdToUUID uid, h, t) consumeStmt)+    either dbFail (pure . isJust) res+  CountUnusedRecoveryCodes uid -> do+    res <- runSession (Session.statement (userIdToUUID uid) countUnusedStmt)+    n <- either dbFail pure res+    pure (fromIntegral n)+  where+    dbFail = throwError . postgresUnavailable++-- | The four columns an INSERT writes; @used_at@ is always NULL on a fresh row.+type InsertRow = (UUID, UUID, Text, UTCTime)++deleteForUserStmt :: Statement UUID ()+deleteForUserStmt =+  preparable+    "DELETE FROM shomei.shomei_recovery_codes WHERE user_id = $1"+    (E.param (E.nonNullable E.uuid))+    D.noResult++insertStmt :: Statement InsertRow ()+insertStmt =+  preparable+    """+    INSERT INTO shomei.shomei_recovery_codes+      (recovery_code_id, user_id, code_hash, created_at, used_at)+    VALUES ($1, $2, $3, $4, NULL)+    """+    ( contrazip4+        (E.param (E.nonNullable E.uuid))+        (E.param (E.nonNullable E.uuid))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.timestamptz))+    )+    D.noResult++-- | Spend one unused code matching @(user_id, code_hash)@. The @RETURNING recovery_code_id@ sits+-- on its own line: a 'MultilineString' drops its trailing newline, so keeping @RETURNING@ apart+-- from the column avoids concatenating into @RETURNINGrecovery_code_id@ (EP-5 discovery).+consumeStmt :: Statement (UUID, Text, UTCTime) (Maybe UUID)+consumeStmt =+  preparable+    """+    UPDATE shomei.shomei_recovery_codes+    SET used_at = $3+    WHERE user_id = $1 AND code_hash = $2 AND used_at IS NULL+    RETURNING recovery_code_id+    """+    ( contrazip3+        (E.param (E.nonNullable E.uuid))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.timestamptz))+    )+    (D.rowMaybe (D.column (D.nonNullable D.uuid)))++countUnusedStmt :: Statement UUID Int64+countUnusedStmt =+  preparable+    "SELECT count(*) FROM shomei.shomei_recovery_codes WHERE user_id = $1 AND used_at IS NULL"+    (E.param (E.nonNullable E.uuid))+    (D.singleRow (D.column (D.nonNullable D.int8)))
+ src/Shomei/Mfa/Totp/Postgres.hs view
@@ -0,0 +1,245 @@+{-# LANGUAGE ScopedTypeVariables #-}++-- | PostgreSQL interpreter for the EP-7 TOTP credential store, with AES-256-GCM encryption of+-- the shared secret at the storage boundary.+--+-- 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'+-- (@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.+module Shomei.Mfa.Totp.Postgres+  ( runTotpCredentialStorePostgres,+    TotpEncryptionKey,+    totpEncryptionKeyFromBytes,+    totpEncryptionKeyFromBase64,+  )+where++import Contravariant.Extras (contrazip2, contrazip4)+import Crypto.Cipher.AES (AES256)+import Crypto.Cipher.Types+  ( AEAD,+    AEADMode (AEAD_GCM),+    AuthTag (..),+    aeadInit,+    aeadSimpleDecrypt,+    aeadSimpleEncrypt,+    cipherInit,+  )+import Crypto.Error (CryptoFailable (..))+import Crypto.Random (getRandomBytes)+import Data.ByteArray qualified as BA+import Data.ByteArray.Encoding (Base (Base64), convertFromBase)+import Data.ByteString (ByteString)+import Data.ByteString qualified as BS+import Data.Int (Int64)+import Data.Text qualified as Text+import Data.Text.Encoding qualified as TE+import Data.UUID (UUID)+import Effectful (Eff, IOE, (:>))+import Effectful.Dispatch.Dynamic (interpret_)+import Effectful.Error.Static (Error, throwError)+import Hasql.Decoders qualified as D+import Hasql.Encoders qualified as E+import Hasql.Session qualified as Session+import Hasql.Statement (Statement, preparable)+import Shomei.Error (AuthError (..))+import Shomei.Id+  ( totpCredentialIdFromUUID,+    totpCredentialIdToUUID,+    userIdFromUUID,+    userIdToUUID,+  )+import Shomei.Mfa.Totp.Algorithm (TotpSecret (..))+import Shomei.Mfa.Totp.Domain (NewTotpCredential (..), TotpCredential (..))+import Shomei.Mfa.Totp.Store (TotpCredentialStore (..))+import Shomei.Persistence.Codec.Postgres (tshow)+import Shomei.Persistence.Database.Postgres (Database, postgresUnavailable, runSession)+import Shomei.Prelude++-- | The AES-256-GCM key that encrypts stored TOTP secrets. Abstract: no 'Show', no JSON, so a+-- leak is a type error rather than a review question. 32 bytes, held as 'BA.ScrubbedBytes'.+newtype TotpEncryptionKey = TotpEncryptionKey BA.ScrubbedBytes++-- | Build a key from exactly 32 raw bytes.+totpEncryptionKeyFromBytes :: ByteString -> Either Text TotpEncryptionKey+totpEncryptionKeyFromBytes bs+  | BS.length bs == 32 = Right (TotpEncryptionKey (BA.convert bs))+  | otherwise = Left ("TOTP encryption key must be exactly 32 bytes, got " <> tshow (BS.length bs))++-- | Parse a key from base64 text (the value of @SHOMEI_TOTP_ENCRYPTION_KEY@); requires exactly+-- 32 decoded bytes. The 'Left' explains how to make a valid one.+totpEncryptionKeyFromBase64 :: Text -> Either Text TotpEncryptionKey+totpEncryptionKeyFromBase64 raw =+  case convertFromBase Base64 (TE.encodeUtf8 (Text.strip raw)) :: Either String ByteString of+    Left err -> Left (bad ("it is not valid base64 (" <> Text.pack err <> ")"))+    Right bs+      | BS.length bs == 32 -> Right (TotpEncryptionKey (BA.convert bs))+      | otherwise -> Left (bad ("it decodes to " <> tshow (BS.length bs) <> " bytes, not 32"))+  where+    bad reason = "is not a valid TOTP encryption key: " <> reason <> ". Generate one with: openssl rand -base64 32"++-- | The AEAD state for @(key, nonce)@ under AES-256-GCM, shared by encrypt and decrypt.+aeadState :: BA.ScrubbedBytes -> ByteString -> CryptoFailable (AEAD AES256)+aeadState key nonce = do+  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+  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))++-- | 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"+  | 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+                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)++runTotpCredentialStorePostgres ::+  (Database :> es, IOE :> es, Error AuthError :> es) =>+  TotpEncryptionKey ->+  Eff (TotpCredentialStore : es) a ->+  Eff es a+runTotpCredentialStorePostgres key = interpret_ \case+  UpsertTotpEnrollment NewTotpCredential {totpCredentialId, userId, secret = TotpSecret raw, createdAt} -> do+    enc <- liftIO (encryptSecret key raw)+    let params = (totpCredentialIdToUUID totpCredentialId, userIdToUUID userId, enc, createdAt)+    res <- runSession (Session.statement params upsertStmt)+    either dbFail (const (pure ())) res+    pure+      TotpCredential+        { totpCredentialId,+          userId,+          secret = TotpSecret raw,+          lastUsedCounter = Nothing,+          confirmedAt = Nothing,+          createdAt+        }+  FindTotpByUser uid -> do+    res <- runSession (Session.statement (userIdToUUID uid) findByUserStmt)+    row <- either dbFail pure res+    traverse rebuild row+  ConfirmTotp tcid t -> do+    res <- runSession (Session.statement (totpCredentialIdToUUID tcid, t) confirmStmt)+    either dbFail (const (pure ())) res+  SetTotpLastUsedCounter tcid c -> do+    res <- runSession (Session.statement (totpCredentialIdToUUID tcid, c) setCounterStmt)+    accepted <- either dbFail pure res+    pure (isJust accepted)+  DeleteTotpByUser uid -> do+    res <- runSession (Session.statement (userIdToUUID uid) deleteByUserStmt)+    either dbFail (const (pure ())) res+  where+    dbFail = throwError . postgresUnavailable+    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+  pure+    TotpCredential+      { totpCredentialId = totpCredentialIdFromUUID tcid,+        userId = userIdFromUUID uid,+        secret = TotpSecret raw,+        lastUsedCounter = lastUsed,+        confirmedAt = confirmed,+        createdAt = created+      }++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)++selectCols :: Text+selectCols = "totp_credential_id, user_id, secret_enc, last_used_counter, confirmed_at, created_at"++-- | 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+-- workflow refuses to reach here when a /confirmed/ credential exists.+upsertStmt :: Statement (UUID, UUID, ByteString, UTCTime) ()+upsertStmt =+  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)+    ON CONFLICT (user_id) DO UPDATE+    SET totp_credential_id = EXCLUDED.totp_credential_id,+        secret_enc = EXCLUDED.secret_enc,+        last_used_counter = NULL,+        confirmed_at = NULL,+        created_at = EXCLUDED.created_at+    """+    ( contrazip4+        (E.param (E.nonNullable E.uuid))+        (E.param (E.nonNullable E.uuid))+        (E.param (E.nonNullable E.bytea))+        (E.param (E.nonNullable E.timestamptz))+    )+    D.noResult++findByUserStmt :: Statement UUID (Maybe TotpRow)+findByUserStmt =+  preparable+    ("SELECT " <> selectCols <> " FROM shomei.shomei_totp_credentials WHERE user_id = $1")+    (E.param (E.nonNullable E.uuid))+    (D.rowMaybe totpRowDecoder)++confirmStmt :: Statement (UUID, UTCTime) ()+confirmStmt =+  preparable+    """+    UPDATE shomei.shomei_totp_credentials+    SET confirmed_at = $2+    WHERE totp_credential_id = $1+    """+    (contrazip2 (E.param (E.nonNullable E.uuid)) (E.param (E.nonNullable E.timestamptz)))+    D.noResult++setCounterStmt :: Statement (UUID, Int64) (Maybe UUID)+setCounterStmt =+  preparable+    """+    UPDATE shomei.shomei_totp_credentials+    SET last_used_counter = $2+    WHERE totp_credential_id = $1+      AND (last_used_counter IS NULL OR last_used_counter < $2)+    RETURNING totp_credential_id+    """+    (contrazip2 (E.param (E.nonNullable E.uuid)) (E.param (E.nonNullable E.int8)))+    (D.rowMaybe (D.column (D.nonNullable D.uuid)))++deleteByUserStmt :: Statement UUID ()+deleteByUserStmt =+  preparable+    "DELETE FROM shomei.shomei_totp_credentials WHERE user_id = $1"+    (E.param (E.nonNullable E.uuid))+    D.noResult
+ src/Shomei/OAuth/AuthorizationCode/Postgres.hs view
@@ -0,0 +1,190 @@+-- | PostgreSQL interpreter for the EP-5 authorization-code store.+module Shomei.OAuth.AuthorizationCode.Postgres+  ( runOAuthCodeStorePostgres,+  )+where++import Contravariant.Extras (contrazip10, contrazip2)+import Data.Aeson (Result (..), Value)+import Data.Set qualified as Set+import Data.Text qualified as Text+import Data.UUID (UUID)+import Effectful (Eff, IOE, (:>))+import Effectful.Dispatch.Dynamic (interpret_)+import Effectful.Error.Static (Error, throwError)+import Hasql.Decoders qualified as D+import Hasql.Encoders qualified as E+import Hasql.Session qualified as Session+import Hasql.Statement (Statement, preparable)+import Shomei.Error (AuthError (..))+import Shomei.Id (sessionIdFromUUID, sessionIdToUUID, userIdFromUUID, userIdToUUID)+import Shomei.OAuth.AuthorizationCode.Domain (AuthorizationCode (..), NewAuthorizationCode (..))+import Shomei.OAuth.AuthorizationCode.Store (OAuthCodeStore (..))+import Shomei.Persistence.Database.Postgres (Database, postgresUnavailable, runSession)+import Shomei.Prelude++-- | The stored row, column order matching @shomei_oauth_authorization_codes@:+-- @(code_hash, client_id, user_id, redirect_uri, scopes, nonce, code_challenge, auth_time,+-- created_at, expires_at, consumed_at, session_id)@.+type CodeRow = (Text, Text, UUID, Text, Value, Maybe Text, Maybe Text, UTCTime, UTCTime, UTCTime, Maybe UTCTime, Maybe UUID)++runOAuthCodeStorePostgres ::+  (Database :> es, IOE :> es, Error AuthError :> es) =>+  Eff (OAuthCodeStore : es) a ->+  Eff es a+runOAuthCodeStorePostgres = interpret_ \case+  PutAuthorizationCode new -> do+    res <- runSession (Session.statement (toInsertRow new) insertStmt)+    either dbFail (const (pure ())) res+  ConsumeAuthorizationCode h t -> do+    -- ONE statement. `UPDATE … WHERE consumed_at IS NULL AND expires_at > $2 RETURNING …` takes a+    -- row lock and returns the row only to the transaction that flipped it, so two racing+    -- exchanges of the same code cannot both receive it. Filtering expiry inside the same WHERE+    -- means an expired code is never consumed and never returned.+    res <- runSession (Session.statement (h, t) consumeStmt)+    row <- either dbFail pure res+    traverse rebuild row+  BindAuthorizationCodeSession h sid -> do+    res <- runSession (Session.statement (h, sessionIdToUUID sid) bindSessionStmt)+    either dbFail (const (pure ())) res+  FindConsumedAuthorizationCode h t -> do+    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)++-- | The ten columns an INSERT writes; @consumed_at@ is always NULL on a fresh row.+type InsertRow = (Text, Text, UUID, Text, Value, Maybe Text, Maybe Text, UTCTime, UTCTime, UTCTime)++toInsertRow :: NewAuthorizationCode -> InsertRow+toInsertRow NewAuthorizationCode {codeHash, clientId, redirectUri, userId, scopes, nonce, codeChallenge, authTime, createdAt, expiresAt} =+  ( codeHash,+    clientId,+    userIdToUUID userId,+    redirectUri,+    toJSON (Set.toList scopes),+    nonce,+    codeChallenge,+    authTime,+    createdAt,+    expiresAt+  )++rebuildCode :: CodeRow -> Either Text AuthorizationCode+rebuildCode (h, cid, uid, uri, scopesJson, nonce, challenge, authTime, createdAt, expiresAt, consumedAt, sessionId) = do+  scopes <- case fromJSON scopesJson of+    Success ss -> Right (Set.fromList ss)+    Error msg -> Left ("invalid scopes json: " <> Text.pack msg)+  pure+    AuthorizationCode+      { codeHash = h,+        clientId = cid,+        redirectUri = uri,+        userId = userIdFromUUID uid,+        scopes,+        nonce,+        codeChallenge = challenge,+        authTime,+        createdAt,+        expiresAt,+        consumedAt,+        sessionId = sessionIdFromUUID <$> sessionId+      }++codeRowDecoder :: D.Row CodeRow+codeRowDecoder =+  (,,,,,,,,,,,)+    <$> D.column (D.nonNullable D.text)+    <*> D.column (D.nonNullable D.text)+    <*> D.column (D.nonNullable D.uuid)+    <*> D.column (D.nonNullable D.text)+    <*> D.column (D.nonNullable D.jsonb)+    <*> D.column (D.nullable D.text)+    <*> D.column (D.nullable D.text)+    <*> D.column (D.nonNullable D.timestamptz)+    <*> D.column (D.nonNullable D.timestamptz)+    <*> D.column (D.nonNullable D.timestamptz)+    <*> D.column (D.nullable D.timestamptz)+    <*> D.column (D.nullable D.uuid)++insertRowEncoder :: E.Params InsertRow+insertRowEncoder =+  contrazip10+    (E.param (E.nonNullable E.text))+    (E.param (E.nonNullable E.text))+    (E.param (E.nonNullable E.uuid))+    (E.param (E.nonNullable E.text))+    (E.param (E.nonNullable E.jsonb))+    (E.param (E.nullable E.text))+    (E.param (E.nullable E.text))+    (E.param (E.nonNullable E.timestamptz))+    (E.param (E.nonNullable E.timestamptz))+    (E.param (E.nonNullable E.timestamptz))++-- | The SELECT/RETURNING column list (matches 'CodeRow' / 'codeRowDecoder' order).+selectCols :: Text+selectCols =+  "code_hash, client_id, user_id, redirect_uri, scopes, nonce, code_challenge, auth_time, created_at, expires_at, consumed_at, session_id"++insertStmt :: Statement InsertRow ()+insertStmt =+  preparable+    """+    INSERT INTO shomei.shomei_oauth_authorization_codes+      (code_hash, client_id, user_id, redirect_uri, scopes, nonce, code_challenge, auth_time,+       created_at, expires_at, consumed_at, session_id)+    VALUES ($1, $2, $3, $4, $5, $6, $7, $8, $9, $10, NULL, NULL)+    """+    insertRowEncoder+    D.noResult++-- | Redeem atomically: at most one caller ever sees a given code unconsumed.+consumeStmt :: Statement (Text, UTCTime) (Maybe CodeRow)+consumeStmt =+  preparable+    ( """+      UPDATE shomei.shomei_oauth_authorization_codes+      SET consumed_at = $2+      WHERE code_hash = $1 AND consumed_at IS NULL AND expires_at > $2+      RETURNING+      """+        -- The multiline string drops its trailing newline, so the column list needs a separator+        -- of its own or the statement reads `RETURNINGcode_hash`.+        <> " "+        <> selectCols+    )+    (contrazip2 (E.param (E.nonNullable E.text)) (E.param (E.nonNullable E.timestamptz)))+    (D.rowMaybe codeRowDecoder)++bindSessionStmt :: Statement (Text, UUID) ()+bindSessionStmt =+  preparable+    """+    UPDATE shomei.shomei_oauth_authorization_codes+    SET session_id = $2+    WHERE code_hash = $1 AND consumed_at IS NOT NULL AND session_id IS NULL+    """+    (contrazip2 (E.param (E.nonNullable E.text)) (E.param (E.nonNullable E.uuid)))+    D.noResult++findConsumedStmt :: Statement (Text, UTCTime) (Maybe CodeRow)+findConsumedStmt =+  preparable+    ( "SELECT "+        <> selectCols+        <> " FROM shomei.shomei_oauth_authorization_codes WHERE code_hash = $1 AND consumed_at IS NOT NULL AND expires_at > $2"+    )+    (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
+ src/Shomei/OAuth/Client/Postgres.hs view
@@ -0,0 +1,204 @@+-- | PostgreSQL interpreter for the EP-5 OAuth-client store.+module Shomei.OAuth.Client.Postgres+  ( runOAuthClientStorePostgres,+  )+where++import Contravariant.Extras (contrazip2, contrazip8)+import Data.Aeson (Result (..), Value)+import Data.Set qualified as Set+import Data.Text qualified as Text+import Data.UUID (UUID)+import Effectful (Eff, IOE, (:>))+import Effectful.Dispatch.Dynamic (interpret_)+import Effectful.Error.Static (Error, throwError)+import Hasql.Decoders qualified as D+import Hasql.Encoders qualified as E+import Hasql.Session qualified as Session+import Hasql.Statement (Statement, preparable)+import Shomei.Error (AuthError (..))+import Shomei.Id (oauthClientIdFromUUID, oauthClientIdToUUID)+import Shomei.OAuth.Client.Domain+  ( ClientType (..),+    NewOAuthClient (..),+    OAuthClient (..),+    OAuthClientStatus (..),+  )+import Shomei.OAuth.Client.Store (OAuthClientStore (..))+import Shomei.Persistence.Database.Postgres (Database, postgresUnavailable, runSession)+import Shomei.Prelude++-- | The stored row, column order matching @shomei_oauth_clients@:+-- @(oauth_client_id, client_id, secret_hash, client_type, display_name, redirect_uris,+-- allowed_scopes, status, created_at, revoked_at)@. @redirect_uris@ and @allowed_scopes@ ride as+-- @jsonb@ arrays of text, as @shomei_service_accounts.allowed_scopes@ does.+type OAuthClientRow = (UUID, Text, Maybe Text, Text, Text, Value, Value, Text, UTCTime, Maybe UTCTime)++-- | The @client_type@ column's two values, in one place so encoder and decoder cannot drift.+renderClientType :: ClientType -> Text+renderClientType = \case+  ConfidentialClient -> "confidential"+  PublicClient -> "public"++parseClientType :: Text -> Either Text ClientType+parseClientType = \case+  "confidential" -> Right ConfidentialClient+  "public" -> Right PublicClient+  other -> Left ("invalid oauth client_type: " <> other)++renderStatus :: OAuthClientStatus -> Text+renderStatus = \case+  OAuthClientActive -> "active"+  OAuthClientRevoked -> "revoked"++parseStatus :: Text -> Either Text OAuthClientStatus+parseStatus = \case+  "active" -> Right OAuthClientActive+  "revoked" -> Right OAuthClientRevoked+  other -> Left ("invalid oauth client status: " <> other)++runOAuthClientStorePostgres ::+  (Database :> es, IOE :> es, Error AuthError :> es) =>+  Eff (OAuthClientStore : es) a ->+  Eff es a+runOAuthClientStorePostgres = interpret_ \case+  CreateOAuthClient NewOAuthClient {oauthClientId, clientId, secretHash, clientType, displayName, redirectUris, allowedScopes, createdAt} -> do+    let oc =+          OAuthClient+            { oauthClientId,+              clientId,+              secretHash,+              clientType,+              displayName,+              redirectUris,+              allowedScopes,+              status = OAuthClientActive,+              createdAt,+              revokedAt = Nothing+            }+    res <- runSession (Session.statement (toInsertRow oc) insertStmt)+    either dbFail (const (pure oc)) res+  FindOAuthClientByClientId cid -> do+    res <- runSession (Session.statement cid findByClientIdStmt)+    row <- either dbFail pure res+    traverse rebuild row+  ListOAuthClients -> do+    res <- runSession (Session.statement () listStmt)+    rows <- either dbFail pure res+    traverse rebuild rows+  RevokeOAuthClient cid t -> do+    res <- runSession (Session.statement (oauthClientIdToUUID cid, t) revokeStmt)+    either dbFail (const (pure ())) res+  where+    dbFail = throwError . postgresUnavailable+    rebuild r = either (throwError . InternalAuthError) pure (rebuildOAuthClient r)++-- | The eight columns an INSERT writes. @revoked_at@ is always NULL on a fresh row, so it is a+-- literal in the statement rather than a parameter.+type InsertRow = (UUID, Text, Maybe Text, Text, Text, Value, Value, UTCTime)++toInsertRow :: OAuthClient -> InsertRow+toInsertRow OAuthClient {oauthClientId, clientId, secretHash, clientType, displayName, redirectUris, allowedScopes, createdAt} =+  ( oauthClientIdToUUID oauthClientId,+    clientId,+    secretHash,+    renderClientType clientType,+    displayName,+    toJSON redirectUris,+    toJSON (Set.toList allowedScopes),+    createdAt+  )++rebuildOAuthClient :: OAuthClientRow -> Either Text OAuthClient+rebuildOAuthClient (ocid, cid, sh, ct, dn, urisJson, scopesJson, st, ca, ra) = do+  redirectUris <- case fromJSON urisJson of+    Success us -> Right us+    Error msg -> Left ("invalid redirect_uris json: " <> Text.pack msg)+  scopes <- case fromJSON scopesJson of+    Success ss -> Right (Set.fromList ss)+    Error msg -> Left ("invalid allowed_scopes json: " <> Text.pack msg)+  clientType <- parseClientType ct+  status <- parseStatus st+  pure+    OAuthClient+      { oauthClientId = oauthClientIdFromUUID ocid,+        clientId = cid,+        secretHash = sh,+        clientType,+        displayName = dn,+        redirectUris,+        allowedScopes = scopes,+        status,+        createdAt = ca,+        revokedAt = ra+      }++oauthClientRowDecoder :: D.Row OAuthClientRow+oauthClientRowDecoder =+  (,,,,,,,,,)+    <$> D.column (D.nonNullable D.uuid)+    <*> D.column (D.nonNullable D.text)+    <*> D.column (D.nullable D.text)+    <*> D.column (D.nonNullable D.text)+    <*> D.column (D.nonNullable D.text)+    <*> D.column (D.nonNullable D.jsonb)+    <*> D.column (D.nonNullable D.jsonb)+    <*> D.column (D.nonNullable D.text)+    <*> D.column (D.nonNullable D.timestamptz)+    <*> D.column (D.nullable D.timestamptz)++insertRowEncoder :: E.Params InsertRow+insertRowEncoder =+  contrazip8+    (E.param (E.nonNullable E.uuid))+    (E.param (E.nonNullable E.text))+    (E.param (E.nullable E.text))+    (E.param (E.nonNullable E.text))+    (E.param (E.nonNullable E.text))+    (E.param (E.nonNullable E.jsonb))+    (E.param (E.nonNullable E.jsonb))+    (E.param (E.nonNullable E.timestamptz))++-- | The SELECT column list (matches 'OAuthClientRow' / 'oauthClientRowDecoder' order).+selectCols :: Text+selectCols =+  "oauth_client_id, client_id, secret_hash, client_type, display_name, redirect_uris, allowed_scopes, status, created_at, revoked_at"++insertStmt :: Statement InsertRow ()+insertStmt =+  preparable+    """+    INSERT INTO shomei.shomei_oauth_clients+      (oauth_client_id, client_id, secret_hash, client_type, display_name, redirect_uris,+       allowed_scopes, status, created_at, revoked_at)+    VALUES ($1, $2, $3, $4, $5, $6, $7, 'active', $8, NULL)+    """+    insertRowEncoder+    D.noResult++findByClientIdStmt :: Statement Text (Maybe OAuthClientRow)+findByClientIdStmt =+  preparable+    ("SELECT " <> selectCols <> " FROM shomei.shomei_oauth_clients WHERE client_id = $1")+    (E.param (E.nonNullable E.text))+    (D.rowMaybe oauthClientRowDecoder)++-- | Newest first, tie-broken by id so the order is total (the in-memory interpreter sorts the+-- same way, and the servant suite walks both).+listStmt :: Statement () [OAuthClientRow]+listStmt =+  preparable+    ("SELECT " <> selectCols <> " FROM shomei.shomei_oauth_clients ORDER BY created_at DESC, oauth_client_id DESC")+    E.noParams+    (D.rowList oauthClientRowDecoder)++revokeStmt :: Statement (UUID, UTCTime) ()+revokeStmt =+  preparable+    """+    UPDATE shomei.shomei_oauth_clients+    SET status = 'revoked', revoked_at = $2+    WHERE oauth_client_id = $1+    """+    (contrazip2 (E.param (E.nonNullable E.uuid)) (E.param (E.nonNullable E.timestamptz)))+    D.noResult
+ src/Shomei/Passkey/Ceremony/Postgres.hs view
@@ -0,0 +1,130 @@+-- | PostgreSQL interpreter for the consume-once pending-ceremony store.+module Shomei.Passkey.Ceremony.Postgres+  ( runPendingCeremonyStorePostgres,+  )+where++import Contravariant.Extras (contrazip6)+import Data.ByteString (ByteString)+import Data.UUID (UUID)+import Effectful (Eff, IOE, (:>))+import Effectful.Dispatch.Dynamic (interpret_)+import Effectful.Error.Static (Error, throwError)+import Hasql.Decoders qualified as D+import Hasql.Encoders qualified as E+import Hasql.Session qualified as Session+import Hasql.Statement (Statement, preparable)+import Shomei.Error (AuthError (..))+import Shomei.Id (ceremonyIdFromUUID, ceremonyIdToUUID, userIdFromUUID, userIdToUUID)+import Shomei.Passkey.Ceremony.Store (PendingCeremonyStore (..))+import Shomei.Passkey.Domain (CeremonyKind (..), PendingCeremony (..))+import Shomei.Persistence.Database.Postgres (Database, postgresUnavailable, runSession)+import Shomei.Prelude++-- | The pending-ceremony row, column order matching+-- @shomei_webauthn_pending_ceremonies@: @(ceremony_id, user_id, kind, options_blob,+-- created_at, expires_at)@. @user_id@ is nullable (a passwordless ceremony has no user yet).+type CeremonyRow = (UUID, Maybe UUID, Text, ByteString, UTCTime, UTCTime)++runPendingCeremonyStorePostgres ::+  (Database :> es, IOE :> es, Error AuthError :> es) =>+  Eff (PendingCeremonyStore : es) a ->+  Eff es a+runPendingCeremonyStorePostgres = interpret_ \case+  PutPendingCeremony pc -> do+    res <- runSession (Session.statement (toRow pc) insertStmt)+    either dbFail (const (pure ())) res+  TakePendingCeremony cid now' -> do+    -- DELETE ... RETURNING is atomic: at most one concurrent transaction removes and+    -- returns the row, so a challenge is usable at most once. We still filter on expiry+    -- AFTER the delete, so an expired ceremony is removed (cannot linger) yet not honored.+    res <- runSession (Session.statement (ceremonyIdToUUID cid) takeStmt)+    row <- either dbFail pure res+    case row of+      Nothing -> pure Nothing+      Just r -> do+        pc <- rebuild r+        pure (if pcExpiresAt pc > now' then Just pc else Nothing)+  where+    dbFail = throwError . postgresUnavailable+    rebuild r = either (throwError . InternalAuthError) pure (rebuildCeremony r)++ceremonyKindToText :: CeremonyKind -> Text+ceremonyKindToText = \case+  RegistrationCeremony -> "registration"+  AuthenticationCeremony -> "authentication"++ceremonyKindFromText :: Text -> Either Text CeremonyKind+ceremonyKindFromText = \case+  "registration" -> Right RegistrationCeremony+  "authentication" -> Right AuthenticationCeremony+  t -> Left ("unknown ceremony kind: " <> t)++pcExpiresAt :: PendingCeremony -> UTCTime+pcExpiresAt PendingCeremony {expiresAt} = expiresAt++toRow :: PendingCeremony -> CeremonyRow+toRow PendingCeremony {ceremonyId, userId, kind, optionsBlob, createdAt, expiresAt} =+  ( ceremonyIdToUUID ceremonyId,+    fmap userIdToUUID userId,+    ceremonyKindToText kind,+    optionsBlob,+    createdAt,+    expiresAt+  )++rebuildCeremony :: CeremonyRow -> Either Text PendingCeremony+rebuildCeremony (cid, uid, k, blob, ca, ea) = do+  kind <- ceremonyKindFromText k+  pure+    PendingCeremony+      { ceremonyId = ceremonyIdFromUUID cid,+        userId = fmap userIdFromUUID uid,+        kind,+        optionsBlob = blob,+        createdAt = ca,+        expiresAt = ea+      }++ceremonyRowDecoder :: D.Row CeremonyRow+ceremonyRowDecoder =+  (,,,,,)+    <$> D.column (D.nonNullable D.uuid)+    <*> D.column (D.nullable D.uuid)+    <*> D.column (D.nonNullable D.text)+    <*> D.column (D.nonNullable D.bytea)+    <*> D.column (D.nonNullable D.timestamptz)+    <*> D.column (D.nonNullable D.timestamptz)++ceremonyRowEncoder :: E.Params CeremonyRow+ceremonyRowEncoder =+  contrazip6+    (E.param (E.nonNullable E.uuid))+    (E.param (E.nullable E.uuid))+    (E.param (E.nonNullable E.text))+    (E.param (E.nonNullable E.bytea))+    (E.param (E.nonNullable E.timestamptz))+    (E.param (E.nonNullable E.timestamptz))++selectCols :: Text+selectCols = "ceremony_id, user_id, kind, options_blob, created_at, expires_at"++insertStmt :: Statement CeremonyRow ()+insertStmt =+  preparable+    """+    INSERT INTO shomei.shomei_webauthn_pending_ceremonies+      (ceremony_id, user_id, kind, options_blob, created_at, expires_at)+    VALUES ($1, $2, $3, $4, $5, $6)+    """+    ceremonyRowEncoder+    D.noResult++takeStmt :: Statement UUID (Maybe CeremonyRow)+takeStmt =+  preparable+    ( "DELETE FROM shomei.shomei_webauthn_pending_ceremonies WHERE ceremony_id = $1 RETURNING "+        <> selectCols+    )+    (E.param (E.nonNullable E.uuid))+    (D.rowMaybe ceremonyRowDecoder)
+ src/Shomei/Passkey/Postgres.hs view
@@ -0,0 +1,242 @@+-- | PostgreSQL interpreter for the registered-passkey store.+module Shomei.Passkey.Postgres+  ( runPasskeyStorePostgres,+  )+where++import Contravariant.Extras (contrazip10, contrazip2, contrazip3)+import Data.Aeson (Result (..), Value)+import Data.ByteString (ByteString)+import Data.Int (Int64)+import Data.Text qualified as Text+import Data.UUID (UUID)+import Effectful (Eff, IOE, (:>))+import Effectful.Dispatch.Dynamic (interpret_)+import Effectful.Error.Static (Error, throwError)+import Hasql.Decoders qualified as D+import Hasql.Encoders qualified as E+import Hasql.Session qualified as Session+import Hasql.Statement (Statement, preparable)+import Shomei.Error (AuthError (..))+import Shomei.Id+  ( genPasskeyId,+    passkeyIdFromUUID,+    passkeyIdToUUID,+    userIdFromUUID,+    userIdToUUID,+  )+import Shomei.Passkey.Domain+  ( NewPasskeyCredential (..),+    PasskeyCredential (..),+    PublicKeyBytes (..),+    SignatureCounter (..),+    UserHandle (..),+    WebAuthnCredentialId (..),+  )+import Shomei.Passkey.Store (PasskeyStore (..))+import Shomei.Persistence.Database.Postgres (Database, postgresUnavailable, runSession)+import Shomei.Prelude++-- | The stored-credential row, column order matching @shomei_webauthn_credentials@:+-- @(passkey_id, user_id, credential_id, user_handle, public_key, sign_counter, transports,+-- label, created_at, last_used_at)@. The 'Word32' signature counter is stored as a signed+-- @bigint@ (it overflows @int4@ but fits @int8@); @transports :: [Text]@ rides as @jsonb@.+type PasskeyRow = (UUID, UUID, ByteString, ByteString, ByteString, Int64, Value, Maybe Text, UTCTime, Maybe UTCTime)++runPasskeyStorePostgres ::+  (Database :> es, IOE :> es, Error AuthError :> es) =>+  Eff (PasskeyStore : es) a ->+  Eff es a+runPasskeyStorePostgres = interpret_ \case+  CreatePasskey NewPasskeyCredential {userId, credentialId, userHandle, publicKey, signCounter, transports, label, createdAt} -> do+    pid <- genPasskeyId+    let pc =+          PasskeyCredential+            { passkeyId = pid,+              userId,+              credentialId,+              userHandle,+              publicKey,+              signCounter,+              transports,+              label,+              createdAt,+              lastUsedAt = Nothing+            }+    res <- runSession (Session.statement (toRow pc) insertStmt)+    either dbFail (const (pure pc)) res+  FindPasskeysByUser uid -> do+    res <- runSession (Session.statement (userIdToUUID uid) findByUserStmt)+    rows <- either dbFail pure res+    traverse rebuild rows+  FindPasskeyByCredentialId (WebAuthnCredentialId cid) -> do+    res <- runSession (Session.statement cid findByCredentialIdStmt)+    row <- either dbFail pure res+    traverse rebuild row+  FindPasskeysByUserHandle (UserHandle uh) -> do+    res <- runSession (Session.statement uh findByUserHandleStmt)+    rows <- either dbFail pure res+    traverse rebuild rows+  UpdatePasskeySignCounter pid (SignatureCounter c) t -> do+    res <- runSession (Session.statement (passkeyIdToUUID pid, fromIntegral c :: Int64, t) updateSignCounterStmt)+    accepted <- either dbFail pure res+    pure (isJust accepted)+  DeletePasskey uid pid -> do+    res <- runSession (Session.statement (userIdToUUID uid, passkeyIdToUUID pid) deletePasskeyStmt)+    either dbFail (const (pure ())) res+  CountPasskeysByUser uid -> do+    res <- runSession (Session.statement (userIdToUUID uid) countByUserStmt)+    n <- either dbFail pure res+    pure (fromIntegral n)+  where+    dbFail = throwError . postgresUnavailable+    rebuild r = either (throwError . InternalAuthError) pure (rebuildPasskey r)++-- | Flatten a 'PasskeyCredential' into its stored row (unwrapping the byte newtypes and+-- widening the 'Word32' counter to 'Int64').+toRow :: PasskeyCredential -> PasskeyRow+toRow+  PasskeyCredential+    { passkeyId,+      userId,+      credentialId = WebAuthnCredentialId cid,+      userHandle = UserHandle uh,+      publicKey = PublicKeyBytes pk,+      signCounter = SignatureCounter sc,+      transports,+      label,+      createdAt,+      lastUsedAt+    } =+    ( passkeyIdToUUID passkeyId,+      userIdToUUID userId,+      cid,+      uh,+      pk,+      fromIntegral sc,+      toJSON transports,+      label,+      createdAt,+      lastUsedAt+    )++rebuildPasskey :: PasskeyRow -> Either Text PasskeyCredential+rebuildPasskey (pid, uid, cid, uh, pk, sc, tj, lbl, ca, lua) = do+  ts <- case fromJSON tj of+    Success ts -> Right ts+    Error msg -> Left ("invalid transports json: " <> Text.pack msg)+  pure+    PasskeyCredential+      { passkeyId = passkeyIdFromUUID pid,+        userId = userIdFromUUID uid,+        credentialId = WebAuthnCredentialId cid,+        userHandle = UserHandle uh,+        publicKey = PublicKeyBytes pk,+        signCounter = SignatureCounter (fromIntegral sc),+        transports = ts,+        label = lbl,+        createdAt = ca,+        lastUsedAt = lua+      }++passkeyRowDecoder :: D.Row PasskeyRow+passkeyRowDecoder =+  (,,,,,,,,,)+    <$> D.column (D.nonNullable D.uuid)+    <*> D.column (D.nonNullable D.uuid)+    <*> D.column (D.nonNullable D.bytea)+    <*> D.column (D.nonNullable D.bytea)+    <*> D.column (D.nonNullable D.bytea)+    <*> D.column (D.nonNullable D.int8)+    <*> D.column (D.nonNullable D.jsonb)+    <*> D.column (D.nullable D.text)+    <*> D.column (D.nonNullable D.timestamptz)+    <*> D.column (D.nullable D.timestamptz)++passkeyRowEncoder :: E.Params PasskeyRow+passkeyRowEncoder =+  contrazip10+    (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.bytea))+    (E.param (E.nonNullable E.int8))+    (E.param (E.nonNullable E.jsonb))+    (E.param (E.nullable E.text))+    (E.param (E.nonNullable E.timestamptz))+    (E.param (E.nullable E.timestamptz))++-- | The SELECT column list (matches 'PasskeyRow' / 'passkeyRowDecoder' order).+selectCols :: Text+selectCols =+  "passkey_id, user_id, credential_id, user_handle, public_key, sign_counter, transports, label, created_at, last_used_at"++insertStmt :: Statement PasskeyRow ()+insertStmt =+  preparable+    """+    INSERT INTO shomei.shomei_webauthn_credentials+      (passkey_id, user_id, credential_id, user_handle, public_key, sign_counter,+       transports, label, created_at, last_used_at)+    VALUES ($1, $2, $3, $4, $5, $6, $7, $8, $9, $10)+    """+    passkeyRowEncoder+    D.noResult++findByUserStmt :: Statement UUID [PasskeyRow]+findByUserStmt =+  preparable+    ("SELECT " <> selectCols <> " FROM shomei.shomei_webauthn_credentials WHERE user_id = $1")+    (E.param (E.nonNullable E.uuid))+    (D.rowList passkeyRowDecoder)++findByCredentialIdStmt :: Statement ByteString (Maybe PasskeyRow)+findByCredentialIdStmt =+  preparable+    ("SELECT " <> selectCols <> " FROM shomei.shomei_webauthn_credentials WHERE credential_id = $1")+    (E.param (E.nonNullable E.bytea))+    (D.rowMaybe passkeyRowDecoder)++findByUserHandleStmt :: Statement ByteString [PasskeyRow]+findByUserHandleStmt =+  preparable+    ("SELECT " <> selectCols <> " FROM shomei.shomei_webauthn_credentials WHERE user_handle = $1")+    (E.param (E.nonNullable E.bytea))+    (D.rowList passkeyRowDecoder)++updateSignCounterStmt :: Statement (UUID, Int64, UTCTime) (Maybe UUID)+updateSignCounterStmt =+  preparable+    """+    UPDATE shomei.shomei_webauthn_credentials+    SET sign_counter = $2, last_used_at = $3+    WHERE passkey_id = $1+      AND (sign_counter < $2 OR ($2 = 0 AND sign_counter = 0))+    RETURNING passkey_id+    """+    ( contrazip3+        (E.param (E.nonNullable E.uuid))+        (E.param (E.nonNullable E.int8))+        (E.param (E.nonNullable E.timestamptz))+    )+    (D.rowMaybe (D.column (D.nonNullable D.uuid)))++deletePasskeyStmt :: Statement (UUID, UUID) ()+deletePasskeyStmt =+  preparable+    """+    DELETE FROM shomei.shomei_webauthn_credentials+    WHERE user_id = $1 AND passkey_id = $2+    """+    (contrazip2 (E.param (E.nonNullable E.uuid)) (E.param (E.nonNullable E.uuid)))+    D.noResult++countByUserStmt :: Statement UUID Int64+countByUserStmt =+  preparable+    """+    SELECT count(*) FROM shomei.shomei_webauthn_credentials WHERE user_id = $1+    """+    (E.param (E.nonNullable E.uuid))+    (D.singleRow (D.column (D.nonNullable D.int8)))
+ src/Shomei/Persistence/Codec/Postgres.hs view
@@ -0,0 +1,164 @@+-- | Pure conversions between Shōmei domain values and their stored text forms, shared by+-- the PostgreSQL port interpreters. Status enums are stored as @text@; the+-- 'Shomei.Account.Email.Domain.Email' smart constructor is reused to rebuild an 'Email' from a+-- (trusted, already-normalized) database value.+module Shomei.Persistence.Codec.Postgres+  ( userStatusToText,+    userStatusFromText,+    sessionStatusToText,+    sessionStatusFromText,+    sessionKindToText,+    sessionKindFromText,+    refreshTokenStatusToText,+    refreshTokenStatusFromText,+    oneTimeTokenStatusToText,+    oneTimeTokenStatusFromText,+    signingKeyStatusToText,+    signingKeyStatusFromText,+    loginOutcomeToText,+    loginOutcomeFromText,+    attemptFactorToText,+    emailFromDb,+    maybeEmailFromDb,+    loginIdFromDb,+    tshow,+  )+where++import Data.Text qualified as Text+import Shomei.Account.Email.Domain (Email, mkEmail)+import Shomei.Account.LoginId.Domain (LoginId, mkLoginId)+import Shomei.Account.OneTimeToken.Domain (OneTimeTokenStatus (..))+import Shomei.Account.User.Domain (UserStatus (..))+import Shomei.Prelude+import Shomei.Session.Domain (SessionKind (..), SessionStatus (..))+import Shomei.Session.LoginAttempt.Domain (AttemptFactor (..), LoginOutcome (..))+import Shomei.Session.RefreshToken.Domain (RefreshTokenStatus (..))+import Shomei.SigningKey.Domain (SigningKeyStatus (..))++tshow :: (Show a) => a -> Text+tshow = Text.pack . show++userStatusToText :: UserStatus -> Text+userStatusToText = \case+  UserActive -> "active"+  UserSuspended -> "suspended"+  UserDeleted -> "deleted"++userStatusFromText :: Text -> Either Text UserStatus+userStatusFromText = \case+  "active" -> Right UserActive+  "suspended" -> Right UserSuspended+  "deleted" -> Right UserDeleted+  t -> Left ("unknown user status: " <> t)++sessionStatusToText :: SessionStatus -> Text+sessionStatusToText = \case+  SessionActive -> "active"+  SessionRevoked -> "revoked"+  SessionExpired -> "expired"++sessionStatusFromText :: Text -> Either Text SessionStatus+sessionStatusFromText = \case+  "active" -> Right SessionActive+  "revoked" -> Right SessionRevoked+  "expired" -> Right SessionExpired+  t -> Left ("unknown session status: " <> t)++sessionKindToText :: SessionKind -> Text+sessionKindToText = \case+  InteractiveSession -> "interactive"+  MachineSession -> "machine"+  DelegatedSession -> "delegated"++sessionKindFromText :: Text -> Either Text SessionKind+sessionKindFromText = \case+  "interactive" -> Right InteractiveSession+  "machine" -> Right MachineSession+  "delegated" -> Right DelegatedSession+  t -> Left ("unknown session kind: " <> t)++refreshTokenStatusToText :: RefreshTokenStatus -> Text+refreshTokenStatusToText = \case+  RefreshTokenActive -> "active"+  RefreshTokenUsed -> "used"+  RefreshTokenRevoked -> "revoked"+  RefreshTokenExpired -> "expired"++refreshTokenStatusFromText :: Text -> Either Text RefreshTokenStatus+refreshTokenStatusFromText = \case+  "active" -> Right RefreshTokenActive+  "used" -> Right RefreshTokenUsed+  "revoked" -> Right RefreshTokenRevoked+  "expired" -> Right RefreshTokenExpired+  t -> Left ("unknown refresh-token status: " <> t)++oneTimeTokenStatusToText :: OneTimeTokenStatus -> Text+oneTimeTokenStatusToText = \case+  OneTimeTokenActive -> "active"+  OneTimeTokenConsumed -> "consumed"+  OneTimeTokenRevoked -> "revoked"+  OneTimeTokenExpired -> "expired"++oneTimeTokenStatusFromText :: Text -> Either Text OneTimeTokenStatus+oneTimeTokenStatusFromText = \case+  "active" -> Right OneTimeTokenActive+  "consumed" -> Right OneTimeTokenConsumed+  "revoked" -> Right OneTimeTokenRevoked+  "expired" -> Right OneTimeTokenExpired+  t -> Left ("unknown one-time-token status: " <> t)++signingKeyStatusToText :: SigningKeyStatus -> Text+signingKeyStatusToText = \case+  KeyPending -> "pending"+  KeyActive -> "active"+  KeyRetired -> "retired"+  KeyRevoked -> "revoked"++signingKeyStatusFromText :: Text -> Either Text SigningKeyStatus+signingKeyStatusFromText = \case+  "pending" -> Right KeyPending+  "active" -> Right KeyActive+  "retired" -> Right KeyRetired+  "revoked" -> Right KeyRevoked+  t -> Left ("unknown signing-key status: " <> t)++loginOutcomeToText :: LoginOutcome -> Text+loginOutcomeToText = \case+  LoginSuccess -> "success"+  LoginFailure -> "failure"++loginOutcomeFromText :: Text -> Either Text LoginOutcome+loginOutcomeFromText = \case+  "success" -> Right LoginSuccess+  "failure" -> Right LoginFailure+  t -> Left ("unknown login outcome: " <> t)++attemptFactorToText :: AttemptFactor -> Text+attemptFactorToText = \case+  FactorPassword -> "password"+  FactorTotp -> "totp"+  FactorRecoveryCode -> "recovery"+  FactorPasskey -> "passkey"+  FactorPasswordChange -> "password_change"++-- | Rebuild an 'Email' from a stored value. The column only ever holds emails that were+-- 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+  Right e -> Right e+  Left _ -> Left ("invalid email in database: " <> t)++-- | Rebuild an optional 'Email' from a nullable stored value: a NULL column decodes to+-- 'Nothing', a present value is rebuilt through 'emailFromDb'.+maybeEmailFromDb :: Maybe Text -> Either Text (Maybe Email)+maybeEmailFromDb = traverse emailFromDb++-- | Rebuild a 'LoginId' from a stored value. The column only ever holds identifiers that+-- 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+  Right l -> Right l+  Left _ -> Left ("invalid login id in database: " <> t)
+ src/Shomei/Persistence/Database/Postgres.hs view
@@ -0,0 +1,84 @@+-- | The @Database@ effect: a thin @effectful@ wrapper over a @hasql@ connection pool.+-- Interpreters run a 'Session' (or a 'Transaction') and surface a @Left UsageError@ for+-- the caller to translate with 'postgresUnavailable'.+module Shomei.Persistence.Database.Postgres+  ( Database (..),+    runSession,+    runTransaction,+    postgresUnavailable,+    uniqueViolation,+    postgresWriteError,+    runDatabasePool,+  )+where++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 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))++data Database :: Effect where+  RunSession :: Session a -> Database m (Either UsageError a)+  RunTransaction :: Transaction a -> Database m (Either UsageError a)++type instance DispatchOf Database = Dynamic++runSession :: (Database :> es) => Session a -> Eff es (Either UsageError a)+runSession = send . RunSession++runTransaction :: (Database :> es) => Transaction a -> Eff es (Either UsageError a)+runTransaction = send . RunTransaction++-- | Collapse all Hasql execution details to the one typed dependency failure.+-- Driver messages and SQL must never cross the persistence boundary.+postgresUnavailable :: UsageError -> AuthError+postgresUnavailable _ = DependencyUnavailable PostgreSQL++-- | The constraint name of a PostgreSQL unique violation (SQLSTATE 23505), when the server+-- supplied one in its primary message. Other failures deliberately remain opaque.+uniqueViolation :: UsageError -> Maybe Text+uniqueViolation = \case+  Pool.SessionUsageError+    ( Hasql.StatementSessionError+        _+        _+        _+        _+        _+        (Hasql.ServerStatementError (Hasql.ServerError "23505" message _ _ _))+      ) -> constraintName message+  _ -> Nothing++-- | Preserve a domain conflict for recognized unique indexes; otherwise keep the existing+-- fail-closed dependency error and never expose SQL or driver text.+postgresWriteError :: (Text -> Maybe AuthError) -> UsageError -> AuthError+postgresWriteError classify err =+  maybe (postgresUnavailable err) id (uniqueViolation err >>= classify)++constraintName :: Text -> Maybe Text+constraintName message =+  case Text.breakOn marker message of+    (_, rest)+      | Text.null rest -> Nothing+      | otherwise ->+          case Text.breakOn "\"" (Text.drop (Text.length marker) rest) of+            (name, closing)+              | not (Text.null name) && not (Text.null closing) -> Just name+            _ -> Nothing+  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).+runDatabasePool :: (IOE :> es) => Pool -> Eff (Database : es) a -> Eff es a+runDatabasePool pool = interpret_ \case+  RunSession sess -> liftIO (Pool.use pool sess)+  RunTransaction t -> liftIO (Pool.use pool (Tx.transaction Tx.ReadCommitted Tx.Write t))
+ src/Shomei/Persistence/Maintenance/Postgres.hs view
@@ -0,0 +1,377 @@+-- | Data hygiene: the batched sweep of expired and dead rows.+--+-- Nothing in Shōmei's domain layer ever deletes anything, so six tables would otherwise grow+-- without bound — most sharply @shomei_refresh_tokens@, which gains a row on every token+-- refresh, forever. This module is the counterweight: 'sweepOnce' performs one full pass,+-- deleting rows that are past their expiry plus a configured grace period.+--+-- Sweeping is an infrastructure maintenance concern rather than a domain operation — no+-- workflow will ever call it — so the statements live here as plain @hasql@ statements+-- instead of widening the seven core store ports (and every in-memory test interpreter) with+-- operations nothing else uses. The sweeper is the sole bulk-delete path.+--+-- Definitions used throughout:+--+-- * A /batched delete/ deletes at most @batchSize@ rows (or, for refresh tokens, at most+--   @batchSize@ sessions' worth of rows) per statement, so row locks and the enclosing+--   transaction stay short-lived. Most statements here bound themselves with PostgreSQL's+--   physical row address: @DELETE FROM t WHERE ctid IN (SELECT ctid FROM t WHERE .. LIMIT n)@.+--   @ctid@ is a system column identifying a row version.+--+-- * A /grace period/ is extra time past logical expiry before a row becomes sweepable, kept+--   for forensics and — for refresh tokens — to protect reuse detection.+--+-- * A /retention window/ is the maximum age of rows in an append-only table+--   (@shomei_login_attempts@, @shomei_auth_events@).+--+-- Each batch is its own @Pool.use@ session, deliberately /not/ one big transaction: locks+-- stay short and a crash mid-sweep loses nothing, because every delete here is idempotent.+-- The background thread and @shomei-admin sweep@ may therefore run concurrently without+-- coordination; a batch simply finds fewer rows.+module Shomei.Persistence.Maintenance.Postgres+  ( SweepConfig (..),+    defaultSweepConfig,+    SweepReport (..),+    emptySweepReport,+    sweepReportCounts,+    sweepReportTotal,+    sweepOnce,+  )+where++import Contravariant.Extras (contrazip2)+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.Prelude++-- | How much history to keep, and how large each delete batch may be.+--+-- The defaults are deliberately conservative where data is forensic and aggressive where it+-- is worthless: a one-time token is useless minutes after it expires, whereas an audit event+-- may be a compliance record.+data SweepConfig = SweepConfig+  { -- | Rows per @DELETE@ statement (sessions per statement, for refresh tokens).+    batchSize :: !Int,+    -- | Grace period before an expired or revoked session — and the whole rotation family of+    -- refresh tokens hanging off it — becomes sweepable. This must stay generous: reuse+    -- detection recognizes a replayed token by finding its @used@ row still present, so+    -- deleting those rows early would silently downgrade "token reuse" (which revokes the+    -- family) to "invalid token". After the grace period every token in the family is+    -- unusable anyway.+    deadSessionGraceDays :: !Int,+    -- | Grace period past expiry for email-verification tokens, password-reset tokens, and+    -- elapsed account lockouts. Pure debugging slack.+    oneTimeTokenGraceDays :: !Int,+    -- | Grace period past expiry for abandoned WebAuthn ceremonies, which are worthless+    -- seconds after expiry. An hour keeps live debugging possible.+    ceremonyGraceMinutes :: !Int,+    -- | Retention window for @shomei_login_attempts@. Brute-force counting reads a+    -- 15-minute window, so this is forensic slack over the biggest write-rate table.+    loginAttemptRetentionDays :: !Int,+    -- | Retention window for @shomei_auth_events@. 'Nothing' means retain forever, which is+    -- the default: the audit trail is the compliance record, and deleting it must be an+    -- explicit operator decision rather than something a default quietly does.+    authEventRetentionDays :: !(Maybe Int)+  }+  deriving stock (Show, Eq, Generic)++-- | See each field's documentation in 'SweepConfig' for why these values.+defaultSweepConfig :: SweepConfig+defaultSweepConfig =+  SweepConfig+    { batchSize = 1000,+      deadSessionGraceDays = 30,+      oneTimeTokenGraceDays = 7,+      ceremonyGraceMinutes = 60,+      loginAttemptRetentionDays = 90,+      authEventRetentionDays = Nothing+    }++-- | How many rows one 'sweepOnce' pass deleted, per table.+data SweepReport = SweepReport+  { refreshTokensDeleted :: !Int,+    sessionsDeleted :: !Int,+    verificationTokensDeleted :: !Int,+    resetTokensDeleted :: !Int,+    ceremoniesDeleted :: !Int,+    authorizationCodesDeleted :: !Int,+    lockoutsDeleted :: !Int,+    loginAttemptsDeleted :: !Int,+    -- | EP-9 time-bound role grants whose expiry has passed (past a grace period). Purely+    -- hygiene: an expired grant is already inert at the next token mint (the mint filters on+    -- @expires_at@), and the @role_granted@ audit payload records the window regardless.+    roleGrantsDeleted :: !Int,+    authEventsDeleted :: !Int+  }+  deriving stock (Show, Eq, Generic)++-- | The report of a sweep that deleted nothing.+emptySweepReport :: SweepReport+emptySweepReport =+  SweepReport+    { refreshTokensDeleted = 0,+      sessionsDeleted = 0,+      verificationTokensDeleted = 0,+      resetTokensDeleted = 0,+      ceremoniesDeleted = 0,+      authorizationCodesDeleted = 0,+      lockoutsDeleted = 0,+      loginAttemptsDeleted = 0,+      roleGrantsDeleted = 0,+      authEventsDeleted = 0+    }++-- | The report as @(table_name, rows_deleted)@ pairs in sweep order. The names are the+-- database table names minus the @shomei_@ prefix; log lines and @shomei-admin sweep@ both+-- render this, so operators see one vocabulary.+sweepReportCounts :: SweepReport -> [(Text, Int)]+sweepReportCounts r =+  [ ("refresh_tokens", r.refreshTokensDeleted),+    ("sessions", r.sessionsDeleted),+    ("verification_tokens", r.verificationTokensDeleted),+    ("reset_tokens", r.resetTokensDeleted),+    ("ceremonies", r.ceremoniesDeleted),+    ("authorization_codes", r.authorizationCodesDeleted),+    ("lockouts", r.lockoutsDeleted),+    ("login_attempts", r.loginAttemptsDeleted),+    ("role_grants", r.roleGrantsDeleted),+    ("auth_events", r.authEventsDeleted)+  ]++-- | Total rows deleted across every table.+sweepReportTotal :: SweepReport -> Int+sweepReportTotal = sum . map snd . sweepReportCounts++-- | Run one full sweep pass against @pool@, treating @now@ as the current time (injected so+-- tests can seed rows at fixed offsets). Returns the per-table deletion counts, or the first+-- 'DependencyUnavailable PostgreSQL' if the database was unreachable or a statement failed — an unreachable+-- database is an ordinary, expected outcome for a periodic maintenance task, not a crash.+--+-- Statement order is load-bearing. @shomei_refresh_tokens.session_id@ references+-- @shomei_sessions@ with no @ON DELETE@ action, so every dead session's tokens must be gone+-- before the session itself can be deleted.+sweepOnce :: Pool -> SweepConfig -> UTCTime -> IO (Either AuthError SweepReport)+sweepOnce pool cfg now = runExceptT do+  refreshTokensDeleted <- drain deadSessionTokensStmt deadSessionCutoff+  sessionsDeleted <- drain deadSessionsStmt deadSessionCutoff+  verificationTokensDeleted <- drain expiredVerificationTokensStmt oneTimeTokenCutoff+  resetTokensDeleted <- drain expiredResetTokensStmt oneTimeTokenCutoff+  ceremoniesDeleted <- drain expiredCeremoniesStmt ceremonyCutoff+  -- EP-5's authorization codes live 60 seconds and are consumed once. They need no grace period+  -- of their own: a code past `expires_at` can never be exchanged, consumed or not, so the+  -- ceremony grace window (which exists for exactly the same "short-lived, already useless"+  -- shape) is the right one to reuse.+  authorizationCodesDeleted <- drain expiredAuthorizationCodesStmt ceremonyCutoff+  lockoutsDeleted <- drain elapsedLockoutsStmt oneTimeTokenCutoff+  loginAttemptsDeleted <- drain oldLoginAttemptsStmt loginAttemptCutoff+  -- EP-9 time-bound grants past expiry. They reuse the one-time-token grace: an expired grant is+  -- already inert (the mint filters it), so the grace is pure forensic slack, like a spent+  -- verification token.+  roleGrantsDeleted <- drain expiredRoleGrantsStmt oneTimeTokenCutoff+  -- Retaining the audit trail forever is the default; deleting it is opt-in.+  authEventsDeleted <- case cfg.authEventRetentionDays of+    Nothing -> pure 0+    Just days -> drain oldAuthEventsStmt (daysAgo days)+  pure SweepReport {..}+  where+    drain stmt cutoff = ExceptT (drainTable pool stmt cutoff limit)++    -- A non-positive batch size would compile to LIMIT 0, deleting nothing forever. Clamp+    -- rather than fail: a misconfigured sweeper that still works is better than one that+    -- silently no-ops.+    limit = fromIntegral (max 1 cfg.batchSize) :: Int64++    daysAgo d = addUTCTime (negate (fromIntegral d * 86400)) now+    minutesAgo m = addUTCTime (negate (fromIntegral m * 60)) now++    deadSessionCutoff = daysAgo cfg.deadSessionGraceDays+    oneTimeTokenCutoff = daysAgo cfg.oneTimeTokenGraceDays+    ceremonyCutoff = minutesAgo cfg.ceremonyGraceMinutes+    loginAttemptCutoff = daysAgo cfg.loginAttemptRetentionDays++-- | Run one statement repeatedly until it deletes nothing, summing the rows it removed.+--+-- The terminator is "this batch deleted zero rows", not "this batch deleted fewer than+-- @limit@ rows": 'deadSessionTokensStmt' bounds itself by /sessions/, so a batch of one+-- session can legitimately delete a whole rotation family's worth of tokens. Every statement+-- here is guaranteed to make progress while rows match — in particular+-- 'deadSessionTokensStmt' only selects sessions that still have at least one token — so a+-- zero result means the predicate is drained.+drainTable :: Pool -> Statement (UTCTime, Int64) Int64 -> UTCTime -> Int64 -> IO (Either AuthError Int)+drainTable pool stmt cutoff limit = fmap (either (Left . postgresUnavailable) Right) (go 0)+  where+    go :: Int64 -> IO (Either UsageError Int)+    go !acc = do+      res <- Pool.use pool (Session.statement (cutoff, limit) stmt)+      case res of+        Left err -> pure (Left err)+        Right deleted+          | deleted <= 0 -> pure (Right (fromIntegral acc))+          | otherwise -> go (acc + deleted)++-- Statements -----------------------------------------------------------------++-- | @$1@ is the cutoff timestamp, @$2@ the batch limit.+cutoffAndLimit :: E.Params (UTCTime, Int64)+cutoffAndLimit =+  contrazip2+    (E.param (E.nonNullable E.timestamptz))+    (E.param (E.nonNullable E.int8))++-- | A bounded delete of the rows a predicate selects, counted.+batchedDelete :: Text -> Statement (UTCTime, Int64) Int64+batchedDelete sql = preparable sql cutoffAndLimit D.rowsAffected++-- | Every refresh token belonging to a session that expired, or was revoked, before the+-- cutoff.+--+-- This batches by /session/ rather than by row, which the @ctid IN (SELECT ctid .. LIMIT n)@+-- shape used elsewhere cannot do safely here: @parent_token_id@ is a self-referencing foreign+-- key with no @ON DELETE@ action, checked at end of statement, so a row-bounded batch that+-- happened to split a rotation family — deleting a parent while its child survives into the+-- next batch — raises+-- @violates foreign key constraint "shomei_refresh_tokens_parent_token_id_fkey"@. Every+-- member of a rotation family shares one @session_id@, so deleting a whole session's tokens+-- in one statement is always internally consistent.+--+-- The @EXISTS@ guard keeps the drain loop honest: without it, a batch could select only+-- already-tokenless sessions, delete zero rows, and stop while other dead sessions still hold+-- tokens.+deadSessionTokensStmt :: Statement (UTCTime, Int64) Int64+deadSessionTokensStmt =+  batchedDelete+    """+    DELETE FROM shomei.shomei_refresh_tokens rt+    WHERE rt.session_id IN (+      SELECT s.session_id+      FROM shomei.shomei_sessions s+      WHERE (s.expires_at <= $1 OR (s.status = 'revoked' AND s.revoked_at <= $1))+        AND EXISTS (+          SELECT 1 FROM shomei.shomei_refresh_tokens rt2+          WHERE rt2.session_id = s.session_id)+      LIMIT $2)+    """++-- | Sessions dead past the cutoff that no longer have any refresh tokens. The @NOT EXISTS@+-- guard means a partially swept family never strands a token whose session is gone; the+-- leftovers are collected by the next cycle, after 'deadSessionTokensStmt' drains them.+deadSessionsStmt :: Statement (UTCTime, Int64) Int64+deadSessionsStmt =+  batchedDelete+    """+    DELETE FROM shomei.shomei_sessions+    WHERE ctid IN (+      SELECT s2.ctid+      FROM shomei.shomei_sessions s2+      WHERE (s2.expires_at <= $1 OR (s2.status = 'revoked' AND s2.revoked_at <= $1))+        AND NOT EXISTS (+          SELECT 1 FROM shomei.shomei_refresh_tokens rt+          WHERE rt.session_id = s2.session_id)+      LIMIT $2)+    """++expiredVerificationTokensStmt :: Statement (UTCTime, Int64) Int64+expiredVerificationTokensStmt =+  batchedDelete+    """+    DELETE FROM shomei.shomei_email_verification_tokens+    WHERE ctid IN (+      SELECT ctid FROM shomei.shomei_email_verification_tokens+      WHERE expires_at <= $1+      LIMIT $2)+    """++expiredResetTokensStmt :: Statement (UTCTime, Int64) Int64+expiredResetTokensStmt =+  batchedDelete+    """+    DELETE FROM shomei.shomei_password_reset_tokens+    WHERE ctid IN (+      SELECT ctid FROM shomei.shomei_password_reset_tokens+      WHERE expires_at <= $1+      LIMIT $2)+    """++expiredCeremoniesStmt :: Statement (UTCTime, Int64) Int64+expiredCeremoniesStmt =+  batchedDelete+    """+    DELETE FROM shomei.shomei_webauthn_pending_ceremonies+    WHERE ctid IN (+      SELECT ctid FROM shomei.shomei_webauthn_pending_ceremonies+      WHERE expires_at <= $1+      LIMIT $2)+    """++-- | Authorization codes past their expiry (EP-5). Consumed rows are swept the same way: a+-- consumed code is refused by `expires_at > now` in the consume statement anyway, so keeping it+-- past expiry buys nothing.+expiredAuthorizationCodesStmt :: Statement (UTCTime, Int64) Int64+expiredAuthorizationCodesStmt =+  batchedDelete+    """+    DELETE FROM shomei.shomei_oauth_authorization_codes+    WHERE ctid IN (+      SELECT ctid FROM shomei.shomei_oauth_authorization_codes+      WHERE expires_at <= $1+      LIMIT $2)+    """++-- | Lockout rows whose lock has elapsed. Rows with a NULL @locked_until@ are accumulating+-- failure counts for an account that is not currently locked; they are one row per account+-- that has ever failed a login and are left alone.+elapsedLockoutsStmt :: Statement (UTCTime, Int64) Int64+elapsedLockoutsStmt =+  batchedDelete+    """+    DELETE FROM shomei.shomei_account_lockouts+    WHERE ctid IN (+      SELECT ctid FROM shomei.shomei_account_lockouts+      WHERE locked_until IS NOT NULL AND locked_until <= $1+      LIMIT $2)+    """++-- | EP-9 role grants whose @expires_at@ has passed the cutoff. Forever grants (@expires_at IS+-- NULL@) and grants still within the grace window are spared; the partial index+-- @shomei_role_grants_expires_at_idx@ keeps the scan cheap.+expiredRoleGrantsStmt :: Statement (UTCTime, Int64) Int64+expiredRoleGrantsStmt =+  batchedDelete+    """+    DELETE FROM shomei.shomei_role_grants+    WHERE ctid IN (+      SELECT ctid FROM shomei.shomei_role_grants+      WHERE expires_at IS NOT NULL AND expires_at <= $1+      LIMIT $2)+    """++oldLoginAttemptsStmt :: Statement (UTCTime, Int64) Int64+oldLoginAttemptsStmt =+  batchedDelete+    """+    DELETE FROM shomei.shomei_login_attempts+    WHERE ctid IN (+      SELECT ctid FROM shomei.shomei_login_attempts+      WHERE occurred_at <= $1+      LIMIT $2)+    """++oldAuthEventsStmt :: Statement (UTCTime, Int64) Int64+oldAuthEventsStmt =+  batchedDelete+    """+    DELETE FROM shomei.shomei_auth_events+    WHERE ctid IN (+      SELECT ctid FROM shomei.shomei_auth_events+      WHERE created_at <= $1+      LIMIT $2)+    """
+ src/Shomei/Persistence/Pool/Postgres.hs view
@@ -0,0 +1,41 @@+-- | Acquire a @hasql@ connection pool from a libpq connection string.+module Shomei.Persistence.Pool.Postgres+  ( acquirePool,+  )+where++import Data.Text (Text)+import Data.Text qualified as Text+import Data.Time (DiffTime)+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.Session qualified as Session++-- | 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.+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)))+        ]+    )+  where+    sessionSetup ms =+      "SET statement_timeout = "+        <> Text.pack (show ms)+        <> "; SET idle_in_transaction_session_timeout = "+        <> Text.pack (show ms)
+ src/Shomei/ServiceAccount/Postgres.hs view
@@ -0,0 +1,212 @@+-- | PostgreSQL interpreter for the EP-4 service-account store.+module Shomei.ServiceAccount.Postgres+  ( runServiceAccountStorePostgres,+  )+where++import Contravariant.Extras (contrazip2, contrazip3, contrazip8)+import Data.Aeson (Result (..), Value)+import Data.Set qualified as Set+import Data.Text qualified as Text+import Data.UUID (UUID)+import Effectful (Eff, IOE, (:>))+import Effectful.Dispatch.Dynamic (interpret_)+import Effectful.Error.Static (Error, throwError)+import Hasql.Decoders qualified as D+import Hasql.Encoders qualified as E+import Hasql.Session qualified as Session+import Hasql.Statement (Statement, preparable)+import Shomei.Error (AuthError (..))+import Shomei.Id+  ( serviceAccountDbIdFromUUID,+    serviceAccountDbIdToUUID,+    userIdFromUUID,+    userIdToUUID,+  )+import Shomei.Persistence.Database.Postgres (Database, postgresUnavailable, runSession)+import Shomei.Prelude+import Shomei.ServiceAccount.Domain+  ( NewServiceAccount (..),+    ServiceAccount (..),+    ServiceAccountStatus (..),+  )+import Shomei.ServiceAccount.Store (ServiceAccountStore (..))++-- | The stored row, column order matching @shomei_service_accounts@:+-- @(service_account_id, client_id, user_id, secret_hash, display_name, allowed_scopes, status,+-- created_at, rotated_at, revoked_at)@. @allowed_scopes :: Set Scope@ rides as a @jsonb@ array+-- of scope texts, as @shomei_webauthn_credentials.transports@ does.+type ServiceAccountRow = (UUID, Text, UUID, Text, Text, Value, Text, UTCTime, Maybe UTCTime, Maybe UTCTime)++-- | The @status@ column's two values. Kept in one place so the encoder and the decoder cannot+-- drift: a typo would silently make every account look revoked.+renderStatus :: ServiceAccountStatus -> Text+renderStatus = \case+  ServiceAccountActive -> "active"+  ServiceAccountRevoked -> "revoked"++parseStatus :: Text -> Either Text ServiceAccountStatus+parseStatus = \case+  "active" -> Right ServiceAccountActive+  "revoked" -> Right ServiceAccountRevoked+  other -> Left ("invalid service-account status: " <> other)++runServiceAccountStorePostgres ::+  (Database :> es, IOE :> es, Error AuthError :> es) =>+  Eff (ServiceAccountStore : es) a ->+  Eff es a+runServiceAccountStorePostgres = interpret_ \case+  CreateServiceAccount NewServiceAccount {serviceAccountId, clientId, userId, secretHash, displayName, allowedScopes, createdAt} -> do+    let sa =+          ServiceAccount+            { serviceAccountId,+              clientId,+              userId,+              secretHash,+              displayName,+              allowedScopes,+              status = ServiceAccountActive,+              createdAt,+              rotatedAt = Nothing,+              revokedAt = Nothing+            }+    res <- runSession (Session.statement (toInsertRow sa) insertStmt)+    either dbFail (const (pure sa)) res+  FindServiceAccountByClientId cid -> do+    res <- runSession (Session.statement cid findByClientIdStmt)+    row <- either dbFail pure res+    traverse rebuild row+  ListServiceAccounts -> do+    res <- runSession (Session.statement () listStmt)+    rows <- either dbFail pure res+    traverse rebuild rows+  RotateServiceAccountSecret sid h t -> do+    res <- runSession (Session.statement (serviceAccountDbIdToUUID sid, h, t) rotateSecretStmt)+    either dbFail (const (pure ())) res+  RevokeServiceAccount sid t -> do+    res <- runSession (Session.statement (serviceAccountDbIdToUUID sid, t) revokeStmt)+    either dbFail (const (pure ())) res+  where+    dbFail = throwError . postgresUnavailable+    rebuild r = either (throwError . InternalAuthError) pure (rebuildServiceAccount r)++-- | The eight columns an INSERT writes. @rotated_at@ and @revoked_at@ are always NULL on a+-- fresh row, so they are literals in the statement rather than parameters.+type InsertRow = (UUID, Text, UUID, Text, Text, Value, Text, UTCTime)++toInsertRow :: ServiceAccount -> InsertRow+toInsertRow ServiceAccount {serviceAccountId, clientId, userId, secretHash, displayName, allowedScopes, status, createdAt} =+  ( serviceAccountDbIdToUUID serviceAccountId,+    clientId,+    userIdToUUID userId,+    secretHash,+    displayName,+    toJSON (Set.toList allowedScopes),+    renderStatus status,+    createdAt+  )++rebuildServiceAccount :: ServiceAccountRow -> Either Text ServiceAccount+rebuildServiceAccount (said, cid, uid, sh, dn, scopesJson, st, ca, ra, rva) = do+  scopes <- case fromJSON scopesJson of+    Success ss -> Right (Set.fromList ss)+    Error msg -> Left ("invalid allowed_scopes json: " <> Text.pack msg)+  status <- parseStatus st+  pure+    ServiceAccount+      { serviceAccountId = serviceAccountDbIdFromUUID said,+        clientId = cid,+        userId = userIdFromUUID uid,+        secretHash = sh,+        displayName = dn,+        allowedScopes = scopes,+        status,+        createdAt = ca,+        rotatedAt = ra,+        revokedAt = rva+      }++serviceAccountRowDecoder :: D.Row ServiceAccountRow+serviceAccountRowDecoder =+  (,,,,,,,,,)+    <$> D.column (D.nonNullable D.uuid)+    <*> D.column (D.nonNullable D.text)+    <*> D.column (D.nonNullable D.uuid)+    <*> D.column (D.nonNullable D.text)+    <*> D.column (D.nonNullable D.text)+    <*> D.column (D.nonNullable D.jsonb)+    <*> D.column (D.nonNullable D.text)+    <*> D.column (D.nonNullable D.timestamptz)+    <*> D.column (D.nullable D.timestamptz)+    <*> D.column (D.nullable D.timestamptz)++insertRowEncoder :: E.Params InsertRow+insertRowEncoder =+  contrazip8+    (E.param (E.nonNullable E.uuid))+    (E.param (E.nonNullable E.text))+    (E.param (E.nonNullable E.uuid))+    (E.param (E.nonNullable E.text))+    (E.param (E.nonNullable E.text))+    (E.param (E.nonNullable E.jsonb))+    (E.param (E.nonNullable E.text))+    (E.param (E.nonNullable E.timestamptz))++-- | The SELECT column list (matches 'ServiceAccountRow' / 'serviceAccountRowDecoder' order).+selectCols :: Text+selectCols =+  "service_account_id, client_id, user_id, secret_hash, display_name, allowed_scopes, status, created_at, rotated_at, revoked_at"++insertStmt :: Statement InsertRow ()+insertStmt =+  preparable+    """+    INSERT INTO shomei.shomei_service_accounts+      (service_account_id, client_id, user_id, secret_hash, display_name, allowed_scopes,+       status, created_at, rotated_at, revoked_at)+    VALUES ($1, $2, $3, $4, $5, $6, $7, $8, NULL, NULL)+    """+    insertRowEncoder+    D.noResult++findByClientIdStmt :: Statement Text (Maybe ServiceAccountRow)+findByClientIdStmt =+  preparable+    ("SELECT " <> selectCols <> " FROM shomei.shomei_service_accounts WHERE client_id = $1")+    (E.param (E.nonNullable E.text))+    (D.rowMaybe serviceAccountRowDecoder)++-- | Newest first, tie-broken by id so the order is total (the in-memory interpreter sorts the+-- same way, and the servant suite walks both).+listStmt :: Statement () [ServiceAccountRow]+listStmt =+  preparable+    ("SELECT " <> selectCols <> " FROM shomei.shomei_service_accounts ORDER BY created_at DESC, service_account_id DESC")+    E.noParams+    (D.rowList serviceAccountRowDecoder)++rotateSecretStmt :: Statement (UUID, Text, UTCTime) ()+rotateSecretStmt =+  preparable+    """+    UPDATE shomei.shomei_service_accounts+    SET secret_hash = $2, rotated_at = $3+    WHERE service_account_id = $1+    """+    ( contrazip3+        (E.param (E.nonNullable E.uuid))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.timestamptz))+    )+    D.noResult++revokeStmt :: Statement (UUID, UTCTime) ()+revokeStmt =+  preparable+    """+    UPDATE shomei.shomei_service_accounts+    SET status = 'revoked', revoked_at = $2+    WHERE service_account_id = $1+    """+    (contrazip2 (E.param (E.nonNullable E.uuid)) (E.param (E.nonNullable E.timestamptz)))+    D.noResult
+ src/Shomei/Session/LoginAttempt/Postgres.hs view
@@ -0,0 +1,225 @@+-- | PostgreSQL interpreter for the 'LoginAttemptStore' port (EP-2 brute-force protection).+--+-- Attempts are appended to @shomei_login_attempts@ (an append-only forensic log); the+-- per-account lockout state lives in @shomei_account_lockouts@. Windowed failure counting is+-- asymmetric: the per-account count only counts failures since the most recent success (so a+-- successful login resets the account's brute-force progress), while the per-IP count is a+-- plain windowed count (so an attacker cannot reset the IP throttle by logging into their own+-- account). Both are still bounded by the caller-supplied window cutoff.+module Shomei.Session.LoginAttempt.Postgres+  ( runLoginAttemptStorePostgres,+  )+where++import Contravariant.Extras (contrazip2, contrazip4, contrazip6)+import Data.Int (Int32, Int64)+import Data.UUID (UUID)+import Effectful (Eff, IOE, (:>))+import Effectful.Dispatch.Dynamic (interpret_)+import Effectful.Error.Static (Error, throwError)+import Hasql.Decoders qualified as D+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.Prelude+import Shomei.Session.LoginAttempt.Domain+  ( AccountKey (..),+    AccountLockout (..),+    ClientIp (..),+    FailureOutcome (..),+    LockPolicy (..),+    NewLoginAttempt (..),+  )+import Shomei.Session.LoginAttempt.Store (LoginAttemptStore (..))++runLoginAttemptStorePostgres ::+  (Database :> es, IOE :> es, Error AuthError :> es) =>+  Eff (LoginAttemptStore : es) a ->+  Eff es a+runLoginAttemptStorePostgres = interpret_ \case+  RecordLoginFailure na windowStart policy -> do+    aid <- genLoginAttemptId+    let AccountKey k = na.accountKey+        ClientIp ip = na.clientIp+        row = (loginAttemptIdToUUID aid, k, ip, loginOutcomeToText na.outcome, na.occurredAt, attemptFactorToText na.factor)+    res <- runTransaction do+      _ <- Tx.statement k lockAccountKeyStmt+      Tx.statement row insertAttemptStmt+      n64 <- Tx.statement (k, windowStart) countByAccountStmt+      prior <- Tx.statement k findLockoutStmt+      let failures = fromIntegral n64+          stillLocked = maybe False (maybe False (> na.occurredAt) . secondOf3) prior+      lockedNow <- case policy of+        Just p+          | failures >= p.maxFailures && not stillLocked -> do+              Tx.statement (k, fromIntegral failures, Just p.lockUntil, na.occurredAt) upsertLockoutStmt+              pure True+        _ -> pure False+      pure+        FailureOutcome+          { attemptId = aid,+            failures,+            priorLockout = rebuildLockout na.accountKey <$> prior,+            lockedNow+          }+    either dbFail pure res+  ConvertLoginAttemptToSuccess aid -> do+    res <- runSession (Session.statement (loginAttemptIdToUUID aid) convertAttemptStmt)+    either dbFail (const (pure ())) res+  DiscardLoginAttempt aid -> do+    res <- runSession (Session.statement (loginAttemptIdToUUID aid) discardAttemptStmt)+    either dbFail (const (pure ())) res+  CountRecentFailuresByAccount (AccountKey k) cutoff -> do+    res <- runSession (Session.statement (k, cutoff) countByAccountStmt)+    either dbFail (pure . fromIntegral) res+  CountRecentFailuresByIp (ClientIp ip) cutoff -> do+    res <- runSession (Session.statement (ip, cutoff) countByIpStmt)+    either dbFail (pure . fromIntegral) res+  GetAccountLockout k@(AccountKey kt) -> do+    res <- runSession (Session.statement kt findLockoutStmt)+    row <- either dbFail pure res+    pure (fmap (rebuildLockout k) row)+  SetAccountLockout lo -> do+    let AccountKey k = lo.accountKey+        row = (k, fromIntegral lo.failedCount :: Int32, lo.lockedUntil, lo.updatedAt)+    res <- runSession (Session.statement row upsertLockoutStmt)+    either dbFail (const (pure ())) res+  ClearAccountLockout (AccountKey k) -> do+    res <- runSession (Session.statement k deleteLockoutStmt)+    either dbFail (const (pure ())) res+  where+    dbFail = throwError . postgresUnavailable+    secondOf3 (_, value, _) = value++rebuildLockout :: AccountKey -> (Int32, Maybe UTCTime, UTCTime) -> AccountLockout+rebuildLockout k (fc, lu, ua) =+  AccountLockout+    { accountKey = k,+      failedCount = fromIntegral fc,+      lockedUntil = lu,+      updatedAt = ua+    }++type AttemptRow = (UUID, Text, Text, Text, UTCTime, Text)++insertAttemptStmt :: Statement AttemptRow ()+insertAttemptStmt =+  preparable+    """+    INSERT INTO shomei.shomei_login_attempts+      (attempt_id, account_key, client_ip, outcome, occurred_at, factor)+    VALUES ($1, $2, $3, $4, $5, $6)+    """+    ( contrazip6+        (E.param (E.nonNullable E.uuid))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.timestamptz))+        (E.param (E.nonNullable E.text))+    )+    D.noResult++-- | Serialize failure accounting for one opaque account key until the surrounding transaction+-- commits or rolls back. The query deliberately returns one row so Hasql proves the lock was+-- acquired before the insert and count run.+lockAccountKeyStmt :: Statement Text Int32+lockAccountKeyStmt =+  preparable+    "SELECT 1::int4 FROM pg_advisory_xact_lock(hashtextextended($1, 0))"+    (E.param (E.nonNullable E.text))+    (D.singleRow (D.column (D.nonNullable D.int4)))++convertAttemptStmt :: Statement UUID ()+convertAttemptStmt =+  preparable+    "UPDATE shomei.shomei_login_attempts SET outcome = 'success' WHERE attempt_id = $1"+    (E.param (E.nonNullable E.uuid))+    D.noResult++discardAttemptStmt :: Statement UUID ()+discardAttemptStmt =+  preparable+    "DELETE FROM shomei.shomei_login_attempts WHERE attempt_id = $1 AND outcome = 'failure'"+    (E.param (E.nonNullable E.uuid))+    D.noResult++-- Per-account failures in the window AND strictly after the most recent success.+countByAccountStmt :: Statement (Text, UTCTime) Int64+countByAccountStmt =+  preparable+    """+    SELECT count(*) FROM shomei.shomei_login_attempts+    WHERE account_key = $1 AND outcome = 'failure' AND occurred_at >= $2+      AND occurred_at > COALESCE(+            (SELECT max(occurred_at) FROM shomei.shomei_login_attempts+             WHERE account_key = $1 AND outcome = 'success'),+            '-infinity'::timestamptz)+    """+    (contrazip2 (E.param (E.nonNullable E.text)) (E.param (E.nonNullable E.timestamptz)))+    (D.singleRow (D.column (D.nonNullable D.int8)))++-- Per-IP failures in the window (plain windowed count; no success reset).+countByIpStmt :: Statement (Text, UTCTime) Int64+countByIpStmt =+  preparable+    """+    SELECT count(*) FROM shomei.shomei_login_attempts+    WHERE client_ip = $1 AND outcome = 'failure' AND occurred_at >= $2+    """+    (contrazip2 (E.param (E.nonNullable E.text)) (E.param (E.nonNullable E.timestamptz)))+    (D.singleRow (D.column (D.nonNullable D.int8)))++findLockoutStmt :: Statement Text (Maybe (Int32, Maybe UTCTime, UTCTime))+findLockoutStmt =+  preparable+    """+    SELECT failed_count, locked_until, updated_at+    FROM shomei.shomei_account_lockouts+    WHERE account_key = $1+    """+    (E.param (E.nonNullable E.text))+    (D.rowMaybe lockoutRowDecoder)++lockoutRowDecoder :: D.Row (Int32, Maybe UTCTime, UTCTime)+lockoutRowDecoder =+  (,,)+    <$> D.column (D.nonNullable D.int4)+    <*> D.column (D.nullable D.timestamptz)+    <*> D.column (D.nonNullable D.timestamptz)++type LockoutRow = (Text, Int32, Maybe UTCTime, UTCTime)++upsertLockoutStmt :: Statement LockoutRow ()+upsertLockoutStmt =+  preparable+    """+    INSERT INTO shomei.shomei_account_lockouts+      (account_key, failed_count, locked_until, updated_at)+    VALUES ($1, $2, $3, $4)+    ON CONFLICT (account_key) DO UPDATE+      SET failed_count = EXCLUDED.failed_count,+          locked_until = EXCLUDED.locked_until,+          updated_at = EXCLUDED.updated_at+    """+    ( contrazip4+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.int4))+        (E.param (E.nullable E.timestamptz))+        (E.param (E.nonNullable E.timestamptz))+    )+    D.noResult++deleteLockoutStmt :: Statement Text ()+deleteLockoutStmt =+  preparable+    """+    DELETE FROM shomei.shomei_account_lockouts WHERE account_key = $1+    """+    (E.param (E.nonNullable E.text))+    D.noResult
+ src/Shomei/Session/Postgres.hs view
@@ -0,0 +1,201 @@+-- | PostgreSQL interpreter for the 'SessionStore' port.+module Shomei.Session.Postgres+  ( runSessionStorePostgres,++    -- * Statements shared with the unit-of-work interpreter++    -- | Exported so @Shomei.Session.UnitOfWork.Postgres@ can lift them into a transaction with+    --     @Hasql.Transaction.statement@ instead of restating the SQL. Keep them here: two+    --     copies of an INSERT drift, and the columns are the interpreter's business, not the+    --     transaction's.+    SessionRow,+    insertSessionStmt,+    mkSession,+    revokeSessionStmt,+    revokeAllUserSessionsStmt,+  )+where++import Contravariant.Extras (contrazip11, contrazip2)+import Data.Set qualified as Set+import Data.UUID (UUID)+import Effectful (Eff, IOE, (:>))+import Effectful.Dispatch.Dynamic (interpret_)+import Effectful.Error.Static (Error, throwError)+import Hasql.Decoders qualified as D+import Hasql.Encoders qualified as E+import Hasql.Session qualified as Session+import Hasql.Statement (Statement, preparable)+import Shomei.Authorization.Claims.Domain (Scope (..))+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.Prelude+import Shomei.Session.Domain (NewSession (..), Session (..), SessionKind (InteractiveSession), SessionStatus (SessionActive))+import Shomei.Session.Store (SessionStore (..))++type SessionRow = (UUID, UUID, Text, UTCTime, UTCTime, Maybe UTCTime, Maybe UUID, Maybe Text, Maybe Text, [Text], Maybe UTCTime)++runSessionStorePostgres ::+  (Database :> es, IOE :> es, Error AuthError :> es) =>+  Eff (SessionStore : es) a ->+  Eff es a+runSessionStorePostgres = interpret_ \case+  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+          )+    res <- runSession (Session.statement row insertSessionStmt)+    either dbFail (const (pure session)) res+  FindSessionById sid -> do+    res <- runSession (Session.statement (sessionIdToUUID sid) findSessionByIdStmt)+    row <- either dbFail pure res+    traverse rebuild row+  RevokeSession sid t -> do+    res <- runSession (Session.statement (sessionIdToUUID sid, t) revokeSessionStmt)+    either dbFail (const (pure ())) res+  RevokeAllUserSessions uid t -> do+    res <- runSession (Session.statement (userIdToUUID uid, t) revokeAllUserSessionsStmt)+    either dbFail (const (pure ())) res+  ListSessionsForUser uid -> do+    res <- runSession (Session.statement (userIdToUUID uid) listSessionsForUserStmt)+    rows <- either dbFail pure res+    traverse rebuild rows+  where+    dbFail = throwError . postgresUnavailable+    rebuild r = either (throwError . InternalAuthError) pure (rebuildSession r)++mkSession :: SessionId -> NewSession -> Session+mkSession sid ns =+  Session+    { sessionId = sid,+      userId = ns.userId,+      status = SessionActive,+      createdAt = ns.createdAt,+      expiresAt = ns.expiresAt,+      revokedAt = Nothing,+      actor = ns.actor,+      oauthClientId = ns.oauthClientId,+      kind = ns.kind,+      grantedScopes = ns.grantedScopes,+      authenticatedAt = ns.authenticatedAt+    }++rebuildSession :: SessionRow -> Either Text Session+rebuildSession (sid, uid, st, c, e, r, act, oauthClientId, mKind, scopeTexts, mAuthenticatedAt) = do+  status <- sessionStatusFromText st+  kind <- maybe (Right InteractiveSession) sessionKindFromText mKind+  pure+    Session+      { sessionId = sessionIdFromUUID sid,+        userId = userIdFromUUID uid,+        status = status,+        createdAt = c,+        expiresAt = e,+        revokedAt = r,+        actor = userIdFromUUID <$> act,+        oauthClientId,+        kind,+        grantedScopes = Set.fromList (map Scope scopeTexts),+        authenticatedAt = fromMaybe c mAuthenticatedAt+      }++sessionRowDecoder :: D.Row SessionRow+sessionRowDecoder =+  (,,,,,,,,,,)+    <$> D.column (D.nonNullable D.uuid)+    <*> D.column (D.nonNullable D.uuid)+    <*> D.column (D.nonNullable D.text)+    <*> D.column (D.nonNullable D.timestamptz)+    <*> D.column (D.nonNullable D.timestamptz)+    <*> D.column (D.nullable D.timestamptz)+    <*> D.column (D.nullable D.uuid)+    <*> D.column (D.nullable D.text)+    <*> D.column (D.nullable D.text)+    <*> D.column (D.nonNullable (D.listArray (D.nonNullable D.text)))+    <*> D.column (D.nullable D.timestamptz)++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)+    """+    ( contrazip11+        (E.param (E.nonNullable E.uuid))+        (E.param (E.nonNullable E.uuid))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.timestamptz))+        (E.param (E.nonNullable E.timestamptz))+        (E.param (E.nullable E.timestamptz))+        (E.param (E.nullable E.uuid))+        (E.param (E.nullable E.text))+        (E.param (E.nullable E.text))+        (E.param (E.nonNullable (E.foldableArray (E.nonNullable E.text))))+        (E.param (E.nullable E.timestamptz))+    )+    D.noResult++-- | Every session of one user, newest first, in every status. Unpaginated by design (see the+-- port's haddock); @shomei_sessions@ already indexes @user_id@, so this is one index scan.+listSessionsForUserStmt :: Statement UUID [SessionRow]+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+    FROM shomei.shomei_sessions+    WHERE user_id = $1+    ORDER BY created_at DESC, session_id DESC+    """+    (E.param (E.nonNullable E.uuid))+    (D.rowList sessionRowDecoder)++findSessionByIdStmt :: Statement UUID (Maybe SessionRow)+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+    FROM shomei.shomei_sessions+    WHERE session_id = $1+    """+    (E.param (E.nonNullable E.uuid))+    (D.rowMaybe sessionRowDecoder)++revokeSessionStmt :: Statement (UUID, UTCTime) (Maybe UUID)+revokeSessionStmt =+  preparable+    """+    UPDATE shomei.shomei_sessions+    SET status = 'revoked', revoked_at = $2+    WHERE session_id = $1+      AND status = 'active'+    RETURNING session_id+    """+    (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 =+  preparable+    """+    UPDATE shomei.shomei_sessions+    SET status = 'revoked', revoked_at = $2+    WHERE user_id = $1 AND status = 'active'+    """+    (contrazip2 (E.param (E.nonNullable E.uuid)) (E.param (E.nonNullable E.timestamptz)))+    D.noResult
+ src/Shomei/Session/RefreshToken/Postgres.hs view
@@ -0,0 +1,248 @@+-- | PostgreSQL interpreter for the 'RefreshTokenStore' port, including the recursive-CTE+-- family revocation used by standalone OAuth revocation.+module Shomei.Session.RefreshToken.Postgres+  ( runRefreshTokenStorePostgres,++    -- * Statements shared with the unit-of-work interpreter++    -- | Exported so @Shomei.Session.UnitOfWork.Postgres@ can lift them into a transaction with+    --     @Hasql.Transaction.statement@ instead of restating the SQL. 'markUsedStmt' in+    --     particular is a compare-and-swap whose exact shape is owned by+    --     @docs/plans/28-enforce-absolute-session-expiry-and-atomic-token-state-transitions.md@;+    --     lift it, never retype it.+    RefreshTokenRow,+    insertRefreshTokenStmt,+    markUsedStmt,+    mkPersisted,+    refreshTokenHashText,+    revokeSessionTokensStmt,+    revokeUserTokensStmt,+  )+where++import Contravariant.Extras (contrazip2, contrazip9)+import Data.UUID (UUID)+import Effectful (Eff, IOE, (:>))+import Effectful.Dispatch.Dynamic (interpret_)+import Effectful.Error.Static (Error, throwError)+import Hasql.Decoders qualified as D+import Hasql.Encoders qualified as E+import Hasql.Session qualified as Session+import Hasql.Statement (Statement, preparable)+import Shomei.Error (AuthError (..))+import Shomei.Id+  ( RefreshTokenId,+    genRefreshTokenId,+    refreshTokenIdFromUUID,+    refreshTokenIdToUUID,+    sessionIdFromUUID,+    sessionIdToUUID,+    userIdToUUID,+  )+import Shomei.Persistence.Codec.Postgres (refreshTokenStatusFromText, refreshTokenStatusToText)+import Shomei.Persistence.Database.Postgres (Database, postgresUnavailable, runSession)+import Shomei.Prelude+import Shomei.Session.RefreshToken.Domain+  ( NewRefreshToken (..),+    PersistedRefreshToken (..),+    RefreshTokenHash (..),+    RefreshTokenStatus (RefreshTokenActive),+  )+import Shomei.Session.RefreshToken.Store (RefreshTokenStore (..))++type RefreshTokenRow =+  (UUID, UUID, Text, Maybe UUID, Text, UTCTime, UTCTime, Maybe UTCTime, Maybe UTCTime)++runRefreshTokenStorePostgres ::+  (Database :> es, IOE :> es, Error AuthError :> es) =>+  Eff (RefreshTokenStore : es) a ->+  Eff es a+runRefreshTokenStorePostgres = interpret_ \case+  CreateRefreshToken nrt -> do+    rid <- genRefreshTokenId+    let persisted = mkPersisted rid nrt+        row =+          ( refreshTokenIdToUUID rid,+            sessionIdToUUID nrt.sessionId,+            refreshTokenHashText nrt.tokenHash,+            fmap refreshTokenIdToUUID nrt.parentTokenId,+            refreshTokenStatusToText RefreshTokenActive,+            nrt.createdAt,+            nrt.expiresAt,+            Nothing,+            Nothing+          )+    res <- runSession (Session.statement row insertRefreshTokenStmt)+    either dbFail (const (pure persisted)) res+  FindRefreshTokenByHash h -> do+    res <- runSession (Session.statement (refreshTokenHashText h) findByHashStmt)+    row <- either dbFail pure res+    traverse rebuild row+  MarkRefreshTokenUsed rid t -> do+    res <- runSession (Session.statement (refreshTokenIdToUUID rid, t) markUsedStmt)+    either dbFail (pure . isJust) res+  RevokeRefreshTokenFamily rid t -> do+    res <- runSession (Session.statement (refreshTokenIdToUUID rid, t) revokeFamilyStmt)+    either dbFail (const (pure ())) res+  RevokeSessionRefreshTokens sid t -> do+    res <- runSession (Session.statement (sessionIdToUUID sid, t) revokeSessionTokensStmt)+    either dbFail (const (pure ())) res+  RevokeAllUserRefreshTokens uid t -> do+    res <- runSession (Session.statement (userIdToUUID uid, t) revokeUserTokensStmt)+    either dbFail (const (pure ())) res+  where+    dbFail = throwError . postgresUnavailable+    rebuild r = either (throwError . InternalAuthError) pure (rebuildToken r)++refreshTokenHashText :: RefreshTokenHash -> Text+refreshTokenHashText (RefreshTokenHash t) = t++mkPersisted :: RefreshTokenId -> NewRefreshToken -> PersistedRefreshToken+mkPersisted rid nrt =+  PersistedRefreshToken+    { refreshTokenId = rid,+      sessionId = nrt.sessionId,+      tokenHash = nrt.tokenHash,+      parentTokenId = nrt.parentTokenId,+      status = RefreshTokenActive,+      createdAt = nrt.createdAt,+      expiresAt = nrt.expiresAt,+      usedAt = Nothing,+      revokedAt = Nothing+    }++rebuildToken :: RefreshTokenRow -> Either Text PersistedRefreshToken+rebuildToken (rid, sid, h, parent, st, c, e, used, revoked) = do+  status <- refreshTokenStatusFromText st+  pure+    PersistedRefreshToken+      { refreshTokenId = refreshTokenIdFromUUID rid,+        sessionId = sessionIdFromUUID sid,+        tokenHash = RefreshTokenHash h,+        parentTokenId = fmap refreshTokenIdFromUUID parent,+        status = status,+        createdAt = c,+        expiresAt = e,+        usedAt = used,+        revokedAt = revoked+      }++tokenRowDecoder :: D.Row RefreshTokenRow+tokenRowDecoder =+  (,,,,,,,,)+    <$> D.column (D.nonNullable D.uuid)+    <*> D.column (D.nonNullable D.uuid)+    <*> D.column (D.nonNullable D.text)+    <*> D.column (D.nullable D.uuid)+    <*> D.column (D.nonNullable D.text)+    <*> D.column (D.nonNullable D.timestamptz)+    <*> D.column (D.nonNullable D.timestamptz)+    <*> D.column (D.nullable D.timestamptz)+    <*> D.column (D.nullable D.timestamptz)++insertRefreshTokenStmt :: Statement RefreshTokenRow ()+insertRefreshTokenStmt =+  preparable+    """+    INSERT INTO shomei.shomei_refresh_tokens+      (refresh_token_id, session_id, token_hash, parent_token_id, status,+       created_at, expires_at, used_at, revoked_at)+    VALUES ($1, $2, $3, $4, $5, $6, $7, $8, $9)+    """+    ( contrazip9+        (E.param (E.nonNullable E.uuid))+        (E.param (E.nonNullable E.uuid))+        (E.param (E.nonNullable E.text))+        (E.param (E.nullable E.uuid))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.timestamptz))+        (E.param (E.nonNullable E.timestamptz))+        (E.param (E.nullable E.timestamptz))+        (E.param (E.nullable E.timestamptz))+    )+    D.noResult++findByHashStmt :: Statement Text (Maybe RefreshTokenRow)+findByHashStmt =+  preparable+    """+    SELECT refresh_token_id, session_id, token_hash, parent_token_id, status,+           created_at, expires_at, used_at, revoked_at+    FROM shomei.shomei_refresh_tokens+    WHERE token_hash = $1+    """+    (E.param (E.nonNullable E.text))+    (D.rowMaybe tokenRowDecoder)++-- | Compare-and-swap: the @status = 'active'@ guard and the write are one statement, so two+-- concurrent presentations of the same refresh token cannot both transition it. Under READ+-- COMMITTED the second UPDATE blocks on the first's row lock, re-evaluates the guard against+-- the committed row (now @used@), matches nothing, and returns no row.+markUsedStmt :: Statement (UUID, UTCTime) (Maybe UUID)+markUsedStmt =+  preparable+    """+    UPDATE shomei.shomei_refresh_tokens+    SET status = 'used', used_at = $2+    WHERE refresh_token_id = $1+      AND status = 'active'+    RETURNING refresh_token_id+    """+    (contrazip2 (E.param (E.nonNullable E.uuid)) (E.param (E.nonNullable E.timestamptz)))+    (D.rowMaybe (D.column (D.nonNullable D.uuid)))++-- Walk up from the presented token to the family root (the ancestor with no parent),+-- then walk down from that root to collect every descendant, and revoke the whole family.+revokeFamilyStmt :: Statement (UUID, UTCTime) ()+revokeFamilyStmt =+  preparable+    """+    WITH RECURSIVE ancestors AS (+      SELECT refresh_token_id, parent_token_id+      FROM shomei.shomei_refresh_tokens+      WHERE refresh_token_id = $1+      UNION+      SELECT t.refresh_token_id, t.parent_token_id+      FROM shomei.shomei_refresh_tokens t+      JOIN ancestors a ON t.refresh_token_id = a.parent_token_id+    ),+    root AS (+      SELECT refresh_token_id FROM ancestors WHERE parent_token_id IS NULL LIMIT 1+    ),+    family AS (+      SELECT refresh_token_id FROM root+      UNION+      SELECT t.refresh_token_id+      FROM shomei.shomei_refresh_tokens t+      JOIN family f ON t.parent_token_id = f.refresh_token_id+    )+    UPDATE shomei.shomei_refresh_tokens+    SET status = 'revoked', revoked_at = $2+    WHERE refresh_token_id IN (SELECT refresh_token_id FROM family)+    """+    (contrazip2 (E.param (E.nonNullable E.uuid)) (E.param (E.nonNullable E.timestamptz)))+    D.noResult++revokeSessionTokensStmt :: Statement (UUID, UTCTime) ()+revokeSessionTokensStmt =+  preparable+    """+    UPDATE shomei.shomei_refresh_tokens+    SET status = 'revoked', revoked_at = $2+    WHERE session_id = $1+    """+    (contrazip2 (E.param (E.nonNullable E.uuid)) (E.param (E.nonNullable E.timestamptz)))+    D.noResult++revokeUserTokensStmt :: Statement (UUID, UTCTime) ()+revokeUserTokensStmt =+  preparable+    """+    UPDATE shomei.shomei_refresh_tokens rt+    SET status = 'revoked', revoked_at = $2+    FROM shomei.shomei_sessions s+    WHERE rt.session_id = s.session_id+      AND s.user_id = $1+    """+    (contrazip2 (E.param (E.nonNullable E.uuid)) (E.param (E.nonNullable E.timestamptz)))+    D.noResult
+ src/Shomei/Session/UnitOfWork/Postgres.hs view
@@ -0,0 +1,186 @@+-- | PostgreSQL interpreter for the 'AuthUnitOfWork' port: each operation is exactly one+-- @BEGIN … COMMIT@.+--+-- This module uses 'Shomei.Persistence.Database.Postgres.runTransaction' for workflow write+-- tails. 'Shomei.Session.LoginAttempt.Postgres' also owns one transaction because its+-- transaction-scoped advisory lock must enclose the corresponding insert and count; that is a+-- serialized store operation rather than a workflow tail. Other interpreters issue one statement+-- per 'Shomei.Persistence.Database.Postgres.runSession', which is one pool checkout per statement.+--+-- No SQL is written here. Every statement is the prepared 'Statement' its own store+-- interpreter already uses, lifted into the transaction with 'Tx.statement'. That matters most+-- for 'markUsedStmt', the refresh-token compare-and-swap whose shape is owned by+-- @docs/plans/28-enforce-absolute-session-expiry-and-atomic-token-state-transitions.md@: this+-- module moves it inside a transaction and reads its result, but never alters it.+module Shomei.Session.UnitOfWork.Postgres+  ( runAuthUnitOfWorkPostgres,+  )+where++import Data.Foldable (traverse_)+import Data.Set qualified as Set+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 Shomei.Account.Credential.Postgres (updatePasswordHashStmt)+import Shomei.Account.Password.Domain (PasswordHash (..))+import Shomei.Account.PasswordReset.Postgres qualified as PR+import Shomei.Audit.Event.Codec (projectAuthEvent)+import Shomei.Audit.Event.Domain (AuthEvent)+import Shomei.Audit.Publisher.Postgres (AuthEventRow, insertAuthEventStmt)+import Shomei.Authorization.Claims.Domain (Scope (..))+import Shomei.Error (AuthError (..))+import Shomei.Id+  ( RefreshTokenId,+    genRefreshTokenId,+    genSessionId,+    passwordResetTokenIdToUUID,+    refreshTokenIdToUUID,+    sessionIdToUUID,+    userIdToUUID,+  )+import Shomei.Persistence.Codec.Postgres (refreshTokenStatusToText, sessionKindToText, sessionStatusToText)+import Shomei.Persistence.Database.Postgres (Database, postgresUnavailable, runTransaction)+import Shomei.Prelude+import Shomei.Session.Domain (Session (..), SessionStatus (SessionActive))+import Shomei.Session.Postgres+  ( SessionRow,+    insertSessionStmt,+    mkSession,+    revokeAllUserSessionsStmt,+    revokeSessionStmt,+  )+import Shomei.Session.RefreshToken.Domain (NewRefreshToken (..))+import Shomei.Session.RefreshToken.Domain qualified as RT+import Shomei.Session.RefreshToken.Postgres+  ( RefreshTokenRow,+    insertRefreshTokenStmt,+    markUsedStmt,+    mkPersisted,+    refreshTokenHashText,+  )+import Shomei.Session.RefreshToken.Postgres qualified as RTP+import Shomei.Session.UnitOfWork.Store (AuthUnitOfWork (..), NewSessionToken (..), RotationOutcome (..))++runAuthUnitOfWorkPostgres ::+  (Database :> es, IOE :> es, Error AuthError :> es) =>+  Eff (AuthUnitOfWork : es) a ->+  Eff es a+runAuthUnitOfWorkPostgres = interpret_ \case+  PersistNewSession ns nst mkEvents -> do+    -- The ids are generated here, before the transaction opens, exactly as the per-table+    -- interpreters generate them: they are client-side (TypeID/UUIDv7-style) values, so no+    -- round-trip is needed and the events can name the session id.+    sid <- genSessionId+    rid <- genRefreshTokenId+    let session = mkSession sid ns+        newToken =+          NewRefreshToken+            { sessionId = sid,+              tokenHash = nst.tokenHash,+              parentTokenId = Nothing,+              createdAt = nst.createdAt,+              expiresAt = nst.expiresAt+            }+        persisted = mkPersisted rid newToken+    eventRows <- traverse toEventRow (mkEvents sid)+    res <- runTransaction do+      Tx.statement (sessionRow session) insertSessionStmt+      Tx.statement (tokenRow rid newToken) insertRefreshTokenStmt+      traverse_ (\row -> Tx.statement row insertAuthEventStmt) eventRows+    either dbFail (const (pure (session, persisted))) res+  RotateRefreshToken presentedId usedAt newToken ev -> do+    rid <- genRefreshTokenId+    eventRow <- toEventRow ev+    let persisted = mkPersisted rid newToken+    res <- runTransaction do+      -- The compare-and-swap runs first and its result decides the rest. A conflict leaves the+      -- transaction with nothing but a no-op UPDATE to commit; there is no need to abort it,+      -- and nothing to roll back.+      won <- Tx.statement (refreshTokenIdToUUID presentedId, usedAt) markUsedStmt+      case won of+        Nothing -> pure RotationConflict+        Just _ -> do+          Tx.statement (tokenRow rid newToken) insertRefreshTokenStmt+          Tx.statement eventRow insertAuthEventStmt+          pure (Rotated persisted)+    either dbFail pure res+  CompletePasswordReset tid uid newHash ts events -> do+    eventRows <- traverse toEventRow events+    res <- runTransaction do+      won <- Tx.statement (passwordResetTokenIdToUUID tid, ts) PR.markConsumedStmt+      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, ts) RTP.revokeUserTokensStmt+          -- The consumed token is no longer active, so this revokes only its live siblings.+          Tx.statement (userIdToUUID uid, ts) PR.revokeUserTokensStmt+          True <$ traverse_ (\row -> Tx.statement row insertAuthEventStmt) eventRows+    either dbFail pure res+  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, ts) RTP.revokeUserTokensStmt+      traverse_ (\row -> Tx.statement row insertAuthEventStmt) eventRows+    either dbFail pure res+  RevokeSessionWithTokens sid ts events -> do+    eventRows <- traverse toEventRow events+    res <- runTransaction do+      won <- Tx.statement (sessionIdToUUID sid, ts) revokeSessionStmt+      case won of+        Nothing -> pure False+        Just _ -> do+          Tx.statement (sessionIdToUUID sid, ts) RTP.revokeSessionTokensStmt+          True <$ traverse_ (\row -> Tx.statement row insertAuthEventStmt) eventRows+    either dbFail pure res+  where+    dbFail = throwError . postgresUnavailable++passwordHashText :: PasswordHash -> Text+passwordHashText (PasswordHash t) = t++-- | Mint the event's row id outside the transaction (it is a random UUID, not a database+-- default), and project the event exactly as 'Shomei.Audit.Publisher.Postgres' does.+toEventRow :: (IOE :> es) => AuthEvent -> Eff es AuthEventRow+toEventRow ev = do+  eid <- liftIO UUIDv4.nextRandom+  let (mUser, mSession, etype, payload, ts) = projectAuthEvent ev+  pure (eid, mUser, mSession, etype, payload, ts)++-- | The column tuple 'insertSessionStmt' encodes, built from the session this interpreter just+-- constructed. A fresh session is always active and never revoked.+sessionRow :: Session -> SessionRow+sessionRow session =+  ( sessionIdToUUID session.sessionId,+    userIdToUUID session.userId,+    sessionStatusToText SessionActive,+    session.createdAt,+    session.expiresAt,+    Nothing,+    userIdToUUID <$> session.actor,+    session.oauthClientId,+    Just (sessionKindToText session.kind),+    [scope | Scope scope <- Set.toList session.grantedScopes],+    Just session.authenticatedAt+  )++-- | The column tuple 'insertRefreshTokenStmt' encodes. A freshly inserted token is always+-- active, never used, never revoked.+tokenRow :: RefreshTokenId -> NewRefreshToken -> RefreshTokenRow+tokenRow rid nrt =+  ( refreshTokenIdToUUID rid,+    sessionIdToUUID nrt.sessionId,+    refreshTokenHashText nrt.tokenHash,+    fmap refreshTokenIdToUUID nrt.parentTokenId,+    refreshTokenStatusToText RT.RefreshTokenActive,+    nrt.createdAt,+    nrt.expiresAt,+    Nothing,+    Nothing+  )
+ src/Shomei/SigningKey/Postgres.hs view
@@ -0,0 +1,214 @@+-- | PostgreSQL interpreter for the 'SigningKeyStore' port. JWK material is stored as+-- opaque @text@ (IP-4); only @shomei-jwt@ interprets it.+module Shomei.SigningKey.Postgres+  ( runSigningKeyStorePostgres,+  )+where++import Contravariant.Extras (contrazip3, contrazip9)+import Effectful (Eff, (:>))+import Effectful.Dispatch.Dynamic (interpret_)+import Effectful.Error.Static (Error, throwError)+import Hasql.Decoders qualified as D+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.Prelude+import Shomei.SigningKey.Domain (SigningKeyStatus (KeyActive), StoredSigningKey (..))+import Shomei.SigningKey.Store (SigningKeyStore (..))++type KeyRow = (Text, Text, Text, Text, Text, UTCTime, Maybe UTCTime, Maybe UTCTime, Maybe UTCTime)++runSigningKeyStorePostgres ::+  (Database :> es, Error AuthError :> es) =>+  Eff (SigningKeyStore : es) a ->+  Eff es a+runSigningKeyStorePostgres = interpret_ \case+  ListActiveSigningKeys -> do+    res <- runSession (Session.statement () listActiveStmt)+    rows <- either dbFail pure res+    traverse rebuild rows+  ListPublishableSigningKeys -> do+    res <- runSession (Session.statement () listPublishableStmt)+    rows <- either dbFail pure res+    traverse rebuild rows+  FindSigningKeyByKid kid -> do+    res <- runSession (Session.statement kid findByKidStmt)+    row <- either dbFail pure res+    traverse rebuild row+  InsertSigningKey k -> do+    res <- runSession (Session.statement (keyRow k) insertKeyStmt)+    either dbFail (const (pure ())) res+  UpdateSigningKeyStatus kid st t -> do+    res <- runSession (Session.statement (kid, signingKeyStatusToText st, t) updateStatusStmt)+    either dbFail (const (pure ())) res+  ReplaceActiveSigningKey key t -> do+    let active = key {status = KeyActive, activatedAt = Just t}+    res <- runTransaction do+      Tx.statement t retireActiveStmt+      Tx.statement (keyRow active) upsertActiveStmt+    either dbFail (const (pure ())) res+  where+    dbFail = throwError . postgresUnavailable+    rebuild r = either (throwError . InternalAuthError) pure (rebuildKey r)++keyRow :: StoredSigningKey -> KeyRow+keyRow k =+  ( k.keyId,+    k.algorithm,+    k.publicKeyJwk,+    k.privateKeyJwk,+    signingKeyStatusToText k.status,+    k.createdAt,+    k.activatedAt,+    k.retiredAt,+    k.revokedAt+  )++rebuildKey :: KeyRow -> Either Text StoredSigningKey+rebuildKey (kid, alg, pub, priv, st, c, act, ret, rev) = do+  status <- signingKeyStatusFromText st+  pure+    StoredSigningKey+      { keyId = kid,+        algorithm = alg,+        publicKeyJwk = pub,+        privateKeyJwk = priv,+        status = status,+        createdAt = c,+        activatedAt = act,+        retiredAt = ret,+        revokedAt = rev+      }++keyRowDecoder :: D.Row KeyRow+keyRowDecoder =+  (,,,,,,,,)+    <$> D.column (D.nonNullable D.text)+    <*> D.column (D.nonNullable D.text)+    <*> D.column (D.nonNullable D.text)+    <*> D.column (D.nonNullable D.text)+    <*> D.column (D.nonNullable D.text)+    <*> D.column (D.nonNullable D.timestamptz)+    <*> D.column (D.nullable D.timestamptz)+    <*> D.column (D.nullable D.timestamptz)+    <*> D.column (D.nullable D.timestamptz)++listActiveStmt :: Statement () [KeyRow]+listActiveStmt =+  preparable+    """+    SELECT key_id, algorithm, public_key_jwk, private_key_jwk, status,+           created_at, activated_at, retired_at, revoked_at+    FROM shomei.shomei_signing_keys+    WHERE status = 'active'+    """+    E.noParams+    (D.rowList keyRowDecoder)++-- | The keys that belong in the published JWKS and the verifier key set: @active@ plus+-- @retired@ (still trusted so tokens minted before a rotation keep verifying). Ordered by+-- @created_at@ for stable output.+listPublishableStmt :: Statement () [KeyRow]+listPublishableStmt =+  preparable+    """+    SELECT key_id, algorithm, public_key_jwk, private_key_jwk, status,+           created_at, activated_at, retired_at, revoked_at+    FROM shomei.shomei_signing_keys+    WHERE status IN ('active','retired')+    ORDER BY created_at+    """+    E.noParams+    (D.rowList keyRowDecoder)++findByKidStmt :: Statement Text (Maybe KeyRow)+findByKidStmt =+  preparable+    """+    SELECT key_id, algorithm, public_key_jwk, private_key_jwk, status,+           created_at, activated_at, retired_at, revoked_at+    FROM shomei.shomei_signing_keys+    WHERE key_id = $1+    """+    (E.param (E.nonNullable E.text))+    (D.rowMaybe keyRowDecoder)++insertKeyStmt :: Statement KeyRow ()+insertKeyStmt =+  preparable+    """+    INSERT INTO shomei.shomei_signing_keys+      (key_id, algorithm, public_key_jwk, private_key_jwk, status,+       created_at, activated_at, retired_at, revoked_at)+    VALUES ($1, $2, $3, $4, $5, $6, $7, $8, $9)+    """+    ( contrazip9+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.timestamptz))+        (E.param (E.nullable E.timestamptz))+        (E.param (E.nullable E.timestamptz))+        (E.param (E.nullable E.timestamptz))+    )+    D.noResult++updateStatusStmt :: Statement (Text, Text, UTCTime) ()+updateStatusStmt =+  preparable+    """+    UPDATE shomei.shomei_signing_keys+    SET status = $2,+        activated_at = CASE WHEN $2 = 'active'  THEN $3 ELSE activated_at END,+        retired_at   = CASE WHEN $2 = 'retired' THEN $3 ELSE retired_at END,+        revoked_at   = CASE WHEN $2 = 'revoked' THEN $3 ELSE revoked_at END+    WHERE key_id = $1+    """+    ( contrazip3+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.timestamptz))+    )+    D.noResult++retireActiveStmt :: Statement UTCTime ()+retireActiveStmt =+  preparable+    """+    UPDATE shomei.shomei_signing_keys+    SET status = 'retired', retired_at = $1+    WHERE status = 'active'+    """+    (E.param (E.nonNullable E.timestamptz))+    D.noResult++upsertActiveStmt :: Statement KeyRow ()+upsertActiveStmt =+  preparable+    """+    INSERT INTO shomei.shomei_signing_keys+      (key_id, algorithm, public_key_jwk, private_key_jwk, status,+       created_at, activated_at, retired_at, revoked_at)+    VALUES ($1, $2, $3, $4, $5, $6, $7, $8, $9)+    ON CONFLICT (key_id) DO UPDATE+    SET status = 'active', activated_at = EXCLUDED.activated_at+    """+    ( contrazip9+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.timestamptz))+        (E.param (E.nullable E.timestamptz))+        (E.param (E.nullable E.timestamptz))+        (E.param (E.nullable E.timestamptz))+    )+    D.noResult
+ src/Shomei/Time/Postgres.hs view
@@ -0,0 +1,14 @@+-- | The 'Clock' port interpreted as the real wall clock.+module Shomei.Time.Postgres+  ( runClockIO,+  )+where++import Data.Time (getCurrentTime)+import Effectful (Eff, IOE, liftIO, (:>))+import Effectful.Dispatch.Dynamic (interpret_)+import Shomei.Time.Store (Clock (..))++runClockIO :: (IOE :> es) => Eff (Clock : es) a -> Eff es a+runClockIO = interpret_ \case+  Now -> liftIO getCurrentTime
+ test/Main.hs view
@@ -0,0 +1,2685 @@+-- | Integration tests for the PostgreSQL adapters, run against throwaway databases+-- provisioned by @shomei-migrations:test-support@ (ephemeral-pg + pg-migrate). Each test gets a+-- fresh migrated database, acquires a hasql pool, runs the real interpreters, and asserts+-- behavior — first port-by-port round-trips, then EP-2's workflows driven through the+-- 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 Data.ByteString (ByteString)+import Data.ByteString qualified as BS+import Data.Either (isLeft)+import Data.IORef (IORef, atomicModifyIORef', modifyIORef', newIORef, readIORef)+import Data.Int (Int64)+import Data.List (sort, tails)+import Data.Maybe (isJust, isNothing)+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Time (UTCTime (..), addUTCTime, fromGregorian, getCurrentTime)+import Effectful (Eff, IOE, liftIO, runEff, (:>))+import Effectful.Dispatch.Dynamic (interpose, interpret_, 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.Email.Domain (Email, emailText, mkEmail)+import Shomei.Account.Lifecycle.Workflow+  ( ConfirmEmailVerification (..),+    ConfirmPasswordReset (..),+    RequestEmailVerification (..),+    RequestPasswordReset (..),+    confirmEmailVerification,+    confirmPasswordReset,+    requestEmailVerification,+    requestPasswordReset,+  )+import Shomei.Account.LoginId.Domain (LoginId, loginIdText, mkLoginId)+import Shomei.Account.Notification.Domain (Notification (..))+import Shomei.Account.Notification.Store (Notifier (..))+import Shomei.Account.OneTimeToken.Domain (OneTimeToken, OneTimeTokenHash (..), OneTimeTokenStatus (..))+import Shomei.Account.Password.Breach.Store (PasswordBreachChecker)+import Shomei.Account.Password.Domain (PasswordHash (..), PlainPassword (..))+import Shomei.Account.Password.Hash.Postgres+  ( Argon2Params (..),+    argon2HardFloor,+    defaultArgon2Params,+    dummyHashFor,+    hashPasswordArgon2id,+    newHashingLimiter,+    peakHashingConcurrency,+    runPasswordHasherCrypto,+    runTokenGenCrypto,+    trialArgon2Derivation,+    verifyPasswordArgon2id,+    withHashingPermit,+  )+import Shomei.Account.Password.Hash.Store (PasswordHasher, hashPassword, verifyPasswordDummy)+import Shomei.Account.PasswordReset.Domain (NewPasswordResetToken (..), PersistedPasswordResetToken (..))+import Shomei.Account.PasswordReset.Postgres (runPasswordResetTokenStorePostgres)+import Shomei.Account.PasswordReset.Store+  ( PasswordResetTokenStore,+    createPasswordResetToken,+    findPasswordResetTokenByHash,+    markPasswordResetTokenConsumed,+  )+import Shomei.Account.User.Domain (NewUser (..), User (..), UserStatus (..))+import Shomei.Account.User.Postgres (runUserStorePostgres)+import Shomei.Account.User.Store+  ( UserCursor (..),+    UserListQuery (..),+    UserStore,+    createUser,+    emptyUserListQuery,+    findUserByEmail,+    findUserById,+    findUserByLoginId,+    listUsers,+    markUserEmailVerified,+    updateUserStatus,+  )+import Shomei.Account.Verification.Domain (NewVerificationToken (..), PersistedVerificationToken (..))+import Shomei.Account.Verification.Postgres (runVerificationTokenStorePostgres)+import Shomei.Account.Verification.Store+  ( VerificationTokenStore,+    createVerificationToken,+    findVerificationTokenByHash,+    markVerificationTokenConsumed,+  )+import Shomei.Audit.Event.Codec (reconstructAuthEvent)+import Shomei.Audit.Event.Domain qualified as Event+import Shomei.Audit.Publisher.Postgres (runAuthEventPublisherPostgres)+import Shomei.Audit.Publisher.Store (AuthEventPublisher, publishAuthEvent)+import Shomei.Audit.Reader.Postgres (runAuthEventReaderPostgres)+import Shomei.Audit.Reader.Store+  ( AuditCursor (..),+    AuditEventQuery (..),+    AuthEventReader,+    StoredAuthEvent (..),+    countAuthEvents,+    emptyAuditQuery,+    queryAuthEvents,+  )+import Shomei.Authorization.Claims.Domain (Audience (..), AuthClaims (..), Issuer (..), Permission (..), Role (..), Scope (..))+import Shomei.Authorization.Claims.Store (ClaimsEnricher, runClaimsEnricherNull)+import Shomei.Authorization.Role.Postgres (runRoleStorePostgres)+import Shomei.Authorization.Role.Store+  ( RoleDefinition (..),+    RoleStore,+    allowPermission,+    defineRole,+    disallowPermission,+    grantRole,+    listDefinedRoles,+    listPermissionsForRole,+    listRolesForUser,+    permissionsForRoles,+    revokeRole,+  )+import Shomei.Authorization.Role.Workflow (grantRoleTo)+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.Mfa.RecoveryCode.Postgres (runRecoveryCodeStorePostgres)+import Shomei.Mfa.RecoveryCode.Store+  ( RecoveryCodeStore,+    consumeRecoveryCode,+    countUnusedRecoveryCodes,+    replaceRecoveryCodes,+  )+import Shomei.Mfa.Totp.Algorithm (TotpSecret (..))+import Shomei.Mfa.Totp.Domain (NewRecoveryCode (..), NewTotpCredential (..), TotpCredential (..))+import Shomei.Mfa.Totp.Postgres+  ( TotpEncryptionKey,+    runTotpCredentialStorePostgres,+    totpEncryptionKeyFromBytes,+  )+import Shomei.Mfa.Totp.Store+  ( TotpCredentialStore,+    confirmTotp,+    deleteTotpByUser,+    findTotpByUser,+    setTotpLastUsedCounter,+    upsertTotpEnrollment,+  )+import Shomei.Migrations.TestSupport (withShomeiMigratedDatabase)+import Shomei.OAuth.AuthorizationCode.Domain (AuthorizationCode (..), NewAuthorizationCode (..))+import Shomei.OAuth.AuthorizationCode.Postgres (runOAuthCodeStorePostgres)+import Shomei.OAuth.AuthorizationCode.Store+  ( OAuthCodeStore,+    bindAuthorizationCodeSession,+    consumeAuthorizationCode,+    deleteExpiredAuthorizationCodes,+    findConsumedAuthorizationCode,+    putAuthorizationCode,+  )+import Shomei.OAuth.Client.Domain+  ( ClientType (..),+    NewOAuthClient (..),+    OAuthClient (..),+    OAuthClientStatus (..),+  )+import Shomei.OAuth.Client.Postgres (runOAuthClientStorePostgres)+import Shomei.OAuth.Client.Store+  ( OAuthClientStore,+    createOAuthClient,+    findOAuthClientByClientId,+    listOAuthClients,+    revokeOAuthClient,+  )+import Shomei.OAuth.IdToken.Domain (IdToken (..))+import Shomei.Passkey.Ceremony.Port (WebAuthnCeremony)+import Shomei.Passkey.Ceremony.Postgres (runPendingCeremonyStorePostgres)+import Shomei.Passkey.Ceremony.Store (PendingCeremonyStore, putPendingCeremony, takePendingCeremony)+import Shomei.Passkey.Domain+  ( CeremonyKind (..),+    NewPasskeyCredential (..),+    PasskeyCredential (..),+    PendingCeremony (..),+    PublicKeyBytes (..),+    SignatureCounter (..),+    UserHandle (..),+    WebAuthnCredentialId (..),+  )+import Shomei.Passkey.Postgres (runPasskeyStorePostgres)+import Shomei.Passkey.Store+  ( PasskeyStore,+    countPasskeysByUser,+    createPasskey,+    deletePasskey,+    findPasskeyByCredentialId,+    findPasskeysByUser,+    findPasskeysByUserHandle,+    updatePasskeySignCounter,+  )+import Shomei.Persistence.Database.Postgres (Database (..), runDatabasePool)+import Shomei.Persistence.Maintenance.Postgres+  ( SweepConfig (..),+    SweepReport (..),+    defaultSweepConfig,+    emptySweepReport,+    sweepOnce,+  )+import Shomei.Persistence.Pool.Postgres (acquirePool)+import Shomei.ServiceAccount.Domain (NewServiceAccount (..), ServiceAccount (..), ServiceAccountStatus (..))+import Shomei.ServiceAccount.Postgres (runServiceAccountStorePostgres)+import Shomei.ServiceAccount.Store+  ( ServiceAccountStore,+    createServiceAccount,+    findServiceAccountByClientId,+    listServiceAccounts,+    revokeServiceAccount,+    rotateServiceAccountSecret,+  )+import Shomei.Session.Authentication.Workflow (login, logout, refresh, signup)+import Shomei.Session.Command (ClientContext (..), LoginCommand (..), LogoutCommand (..), 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)+import Shomei.Session.LoginAttempt.Store+  ( LoginAttemptStore,+    clearAccountLockout,+    countRecentFailuresByAccount,+    countRecentFailuresByIp,+    getAccountLockout,+    recordLoginFailure,+    setAccountLockout,+  )+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.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.Workflow (buildEnrichedClaims)+import Shomei.SigningKey.Domain (SigningKeyStatus (..), StoredSigningKey (..))+import Shomei.SigningKey.Postgres (runSigningKeyStorePostgres)+import Shomei.SigningKey.Signer (TokenSigner (..))+import Shomei.SigningKey.Store (SigningKeyStore, findSigningKeyByKid, insertSigningKey, listActiveSigningKeys, listPublishableSigningKeys, replaceActiveSigningKey, updateSigningKeyStatus)+import Shomei.Test.InMemory (emptyWorld, runPasswordBreachCheckerFake, runWebAuthnCeremonyFake)+import Shomei.Time.Postgres (runClockIO)+import Shomei.Time.Store (Clock (..), now)+import Test.Tasty (TestTree, defaultMain, testGroup)+import Test.Tasty.HUnit (Assertion, assertBool, assertEqual, assertFailure, testCase, (@?=))++-- | The full interpreter stack used by every test. The store interpreters are peeled+-- first (Database/IOE/Error remain available to them); @TokenSigner@ is a trivial fake+-- because real signing is EP-4.+type AppEffects =+  '[ UserStore,+     RoleStore,+     CredentialStore,+     SessionStore,+     RefreshTokenStore,+     AuthUnitOfWork,+     VerificationTokenStore,+     PasswordResetTokenStore,+     LoginAttemptStore,+     PasskeyStore,+     PendingCeremonyStore,+     ServiceAccountStore,+     OAuthClientStore,+     OAuthCodeStore,+     TotpCredentialStore,+     RecoveryCodeStore,+     Notifier,+     ClaimsEnricher,+     WebAuthnCeremony,+     AuthEventPublisher,+     AuthEventReader,+     SigningKeyStore,+     TokenSigner,+     PasswordBreachChecker,+     PasswordHasher,+     TokenGen,+     Clock,+     Database,+     Error AuthError,+     IOE+   ]++runApp :: Pool -> Eff AppEffects a -> IO (Either AuthError a)+runApp pool action = do+  ref <- newIORef []+  runAppWithNotifications ref pool action++runAppWithNotifications :: IORef [Notification] -> Pool -> Eff AppEffects a -> IO (Either AuthError a)+runAppWithNotifications ref pool action = do+  wref <- newIORef (emptyWorld (UTCTime (fromGregorian 2000 1 1) 0))+  limiter <- newHashingLimiter 2+  ( runEff+      . runErrorNoCallStack+      . runDatabasePool pool+      . runClockIO+      . runTokenGenCrypto+      -- Cheap parameters: these workflow tests hash real passwords, and the production cost+      -- (~100 ms per hash) would dominate the suite. The argon2 tests below cover the real ones.+      . runPasswordHasherCrypto limiter cheapParams+      . runPasswordBreachCheckerFake wref+      . runTokenSignerFake+      . runSigningKeyStorePostgres+      . runAuthEventReaderPostgres+      . runAuthEventPublisherPostgres+      . runWebAuthnCeremonyFake wref+      . runClaimsEnricherNull+      . runNotifierRef ref+      . runRecoveryCodeStorePostgres+      . runTotpCredentialStorePostgres testTotpKey+      . runOAuthCodeStorePostgres+      . runOAuthClientStorePostgres+      . runServiceAccountStorePostgres+      . runPendingCeremonyStorePostgres+      . runPasskeyStorePostgres+      . runLoginAttemptStorePostgres+      . runPasswordResetTokenStorePostgres+      . runVerificationTokenStorePostgres+      . runAuthUnitOfWorkPostgres+      . runRefreshTokenStorePostgres+      . runSessionStorePostgres+      . runCredentialStorePostgres+      . runRoleStorePostgres+      . runUserStorePostgres+    )+    action++-- | Run the stack with a FIXED clock (the EP-2 lockout tests need to advance time+-- deterministically across calls against the same database). Notifications are discarded.+runAppAtTime :: UTCTime -> Pool -> Eff AppEffects a -> IO (Either AuthError a)+runAppAtTime t pool action = do+  ref <- newIORef []+  wref <- newIORef (emptyWorld t)+  limiter <- newHashingLimiter 2+  ( runEff+      . runErrorNoCallStack+      . runDatabasePool pool+      . runClockFixed t+      . runTokenGenCrypto+      . runPasswordHasherCrypto limiter cheapParams+      . runPasswordBreachCheckerFake wref+      . runTokenSignerFake+      . runSigningKeyStorePostgres+      . runAuthEventReaderPostgres+      . runAuthEventPublisherPostgres+      . runWebAuthnCeremonyFake wref+      . runClaimsEnricherNull+      . runNotifierRef ref+      . runRecoveryCodeStorePostgres+      . runTotpCredentialStorePostgres testTotpKey+      . runOAuthCodeStorePostgres+      . runOAuthClientStorePostgres+      . runServiceAccountStorePostgres+      . runPendingCeremonyStorePostgres+      . runPasskeyStorePostgres+      . runLoginAttemptStorePostgres+      . runPasswordResetTokenStorePostgres+      . runVerificationTokenStorePostgres+      . runAuthUnitOfWorkPostgres+      . runRefreshTokenStorePostgres+      . runSessionStorePostgres+      . runCredentialStorePostgres+      . runRoleStorePostgres+      . runUserStorePostgres+    )+    action++runClockFixed :: UTCTime -> Eff (Clock : es) a -> Eff es a+runClockFixed t = interpret_ \case+  Now -> pure t++-- | A trivial 'TokenSigner' (real signing is EP-4); the DB-state assertions never inspect+-- the access token's contents.+runTokenSignerFake :: Eff (TokenSigner : es) a -> Eff es a+runTokenSignerFake = interpret_ \case+  SignAccessToken _ -> pure (AccessToken "test-access-token")+  SignIdToken _ -> pure (IdToken "test-id-token")++runNotifierRef :: (IOE :> es) => IORef [Notification] -> Eff (Notifier : es) a -> Eff es a+runNotifierRef ref = interpret_ \case+  SendNotification n -> liftIO (modifyIORef' ref (n :))++-- Helpers --------------------------------------------------------------------++cfg :: ShomeiConfig+cfg = defaultShomeiConfig (Issuer "shomei") (Audience "shomei-clients")++-- | Tightened thresholds for the EP-2 lockout test (lock after 3 per-account failures).+lockCfg :: ShomeiConfig+lockCfg = cfg {rateLimitConfig = defaultRateLimitConfig {maxFailedLoginsPerAccount = 3}}++t0 :: UTCTime+t0 = UTCTime (fromGregorian 2026 1 1) 0++aliceEmail :: Email+aliceEmail = mkEmail' "alice@example.com"++bobEmail :: Email+bobEmail = mkEmail' "bob@example.com"++aliceLogin :: LoginId+aliceLogin = either (error . show) id (mkLoginId (emailText aliceEmail))++bobLogin :: LoginId+bobLogin = either (error . show) id (mkLoginId (emailText bobEmail))++strongPw :: PlainPassword+strongPw = PlainPassword "correct horse battery staple"++mkEmail' :: Text -> Email+mkEmail' t = case mkEmail t of+  Right e -> e+  Left err -> error ("bad test email: " <> show err)++mkLoginId' :: Text -> LoginId+mkLoginId' t = case mkLoginId t of+  Right l -> l+  Left err -> error ("bad test login id: " <> show err)++-- | Run an action over a fresh migrated database and a pool.+withDb :: (Pool -> IO a) -> IO a+withDb action = withShomeiMigratedDatabase \connStr -> do+  pool <- acquirePool 4 10 30000 connStr+  action pool++-- | Unwrap the @Either AuthError@ from 'runApp' (the interpreter-level failure channel).+expectApp :: (Show e) => Either e a -> IO a+expectApp = either (\e -> assertFailure ("interpreter error: " <> show e)) pure++-- | Unwrap a workflow's own @Either AuthError@ result.+expectRight :: (Show e) => Either e a -> IO a+expectRight = either (\e -> assertFailure ("expected Right, got Left: " <> show e)) pure++-- | Run a (possibly multi-statement) SQL script directly against the pool, for seeding.+execSql :: Pool -> Text -> IO ()+execSql pool sql = do+  res <- Pool.use pool (Session.script sql)+  either (\e -> assertFailure ("seed script failed: " <> show e)) pure res++-- | Assert that a raw SQL script is rejected with one exact PostgreSQL SQLSTATE.+execSqlExpectState :: Pool -> Text -> Text -> IO ()+execSqlExpectState pool expected sql = do+  result <- Pool.use pool (Session.script sql)+  case result of+    Left (Pool.SessionUsageError (Hasql.ScriptSessionError _ (Hasql.ServerError actual _ _ _ _))) ->+      actual @?= expected+    Left err -> assertFailure ("expected SQLSTATE " <> Text.unpack expected <> ", got: " <> show err)+    Right () -> assertFailure ("expected SQLSTATE " <> Text.unpack expected <> ", but SQL succeeded")++-- | Unwrap the typed dependency result that 'sweepOnce' returns.+expectSweep :: Either AuthError SweepReport -> IO SweepReport+expectSweep = either (\e -> assertFailure ("sweep failed: " <> show e)) pure++-- | A scalar @count(*)@ (or any single-bigint) query, run directly against the pool.+scalarInt :: Pool -> Text -> IO Int+scalarInt pool sql = do+  res <- Pool.use pool (Session.statement () stmt)+  either (\e -> assertFailure ("scalar query failed: " <> show e)) pure res+  where+    stmt =+      preparable+        sql+        E.noParams+        (D.singleRow (fromIntegral64 <$> D.column (D.nonNullable D.int8)))+    fromIntegral64 :: Int64 -> Int+    fromIntegral64 = fromIntegral++-- | A single @bytea@ column, run directly against the pool (used to inspect @secret_enc@).+scalarBytea :: Pool -> Text -> IO ByteString+scalarBytea pool sql = do+  res <- Pool.use pool (Session.statement () stmt)+  either (\e -> assertFailure ("scalar bytea query failed: " <> show e)) pure res+  where+    stmt = preparable sql E.noParams (D.singleRow (D.column (D.nonNullable D.bytea)))++-- | A fixed 32-byte AES-256-GCM key for the TOTP round-trip tests. Value is irrelevant; the test+-- only proves encrypt-then-decrypt is the identity and that the ciphertext is not the plaintext.+testTotpKey :: TotpEncryptionKey+testTotpKey = case totpEncryptionKeyFromBytes (BS.replicate 32 7) of+  Right k -> k+  Left e -> error ("bad test TOTP key: " <> Text.unpack e)++-- | 20 raw secret bytes (the RFC 6238 Appendix B secret).+totpRawSecret :: ByteString+totpRawSecret = "12345678901234567890"++-- Field accessors: OverloadedRecordDot is unreliable for these DuplicateRecordFields records.+tcSecret :: TotpCredential -> TotpSecret+tcSecret TotpCredential {secret} = secret++tcConfirmedAt :: TotpCredential -> Maybe UTCTime+tcConfirmedAt TotpCredential {confirmedAt} = confirmedAt++tcLastUsedCounter :: TotpCredential -> Maybe Int64+tcLastUsedCounter TotpCredential {lastUsedCounter} = lastUsedCounter++-- Tests ----------------------------------------------------------------------++main :: IO ()+main = defaultMain (testGroup "shomei-postgres" tests)++tests :: [TestTree]+tests =+  [ testUserRoundTrip,+    testUserNoEmailAndUniqueLoginId,+    testSchemaRejectsInvalidUserStatusAndCaseVariantIdentities,+    testListUsersOrderFilterAndPaging,+    testUserStatusIsCompareAndSwap,+    testUserStatusCasUnderRace,+    testListSessionsForUser,+    testCredentialRoundTrip,+    testCredentialUniquePerUser,+    testPoolStatementTimeoutIsApplied,+    testSessionRevoke,+    testSessionActorRoundTrip,+    testSessionKindRoundTrip,+    testSessionGrantedScopesRoundTrip,+    testSessionKindNullReadsInteractive,+    testRefreshTokenMarkUsed,+    testVerificationTokenRoundTrip,+    testPasswordResetTokenRoundTrip,+    testMarkUserEmailVerified,+    testSigningKeys,+    testPublishableSigningKeys,+    testSigningKeyTransitionTimestamps,+    testSigningKeyOneActiveInvariant,+    testPublishEvent,+    testAuditEventReader,+    testWorkflowSignup,+    testLoginRoundTripBudget,+    testFailedLoginRoundTripBudget,+    testRefreshRoundTripBudget,+    testLogoutRoundTripBudget,+    testPasswordResetRoundTripBudget,+    testWorkflowRefreshRotation,+    testWorkflowReuseRevokesFamily,+    testWorkflowAccountVerification,+    testWorkflowPasswordReset,+    testRevokeSessionIsCompareAndSwap,+    testLoginAttemptStore,+    testLockoutRecordAndCountIsAtomicUnderRace,+    testWorkflowLockout,+    testPasskeyCreateAndFind,+    testPasskeyUpdateCountDelete,+    testPasskeyCounterIsCompareAndSwap,+    testPasskeyCounterCasUnderRace,+    testServiceAccountRoundTrip,+    testOAuthClientRoundTrip,+    testAuthorizationCodeRoundTrip,+    testAuthorizationCodeConsumeIsAtomicUnderRace,+    testTotpCredentialRoundTrip,+    testTotpCounterIsCompareAndSwap,+    testTotpCounterCasUnderRace,+    testTotpEncryptionAtRest,+    testRecoveryCodeCasAndReplace,+    testPendingCeremonyConsumeOnce,+    testPendingCeremonyExpired,+    testArgon2NewHashesArePhcFormatted,+    testArgon2RejectsUnparameterizedHashes,+    testArgon2ParamsChangeLeavesOldHashesVerifiable,+    testArgon2MalformedHashesVerifyFalse,+    testArgon2DummyHashTracksConfiguredParams,+    testArgon2HardFloorMatchesTheImplementation,+    testHashingLimiterBoundsConcurrency 1,+    testHashingLimiterBoundsConcurrency 2,+    testInterpreterForcesTheHashInsideThePermit,+    testDummyVerificationTakesAPermit,+    testSweepDeletesExpiredRows,+    testSweepIsIdempotent,+    testSweepAuthEventRetention,+    testSweepBatchesUntilDrained,+    testSweepBatchesWholeTokenFamilies,+    testRoleRegistry,+    testRoleGrants,+    testRoleGrantForeignKeys,+    testGrantedRoleReachesEnrichedClaims,+    testRolePermissions,+    testRolePermissionForeignKey,+    testExpiringGrants+  ]++-- | The registry: seeded with @admin@ by the migration, idempotent definition, sorted listing.+testRoleRegistry :: TestTree+testRoleRegistry =+  testCase "role registry: seeded with admin; define is idempotent; list is sorted" $ withDb \pool -> do+    result <- runApp pool do+      seeded <- listDefinedRoles+      ts <- now+      firstDefine <- defineRole (Role "auditor") (Just "read the audit trail") ts+      secondDefine <- defineRole (Role "auditor") (Just "a different description") ts+      after' <- listDefinedRoles+      pure (seeded, firstDefine, secondDefine, after')+    (seeded, firstDefine, secondDefine, after') <- expectApp result+    map (.role) seeded @?= [Role "admin"]+    firstDefine @?= True+    -- Re-defining is a no-op: it reports no change and does NOT overwrite the description.+    secondDefine @?= False+    map (.role) after' @?= [Role "admin", Role "auditor"]+    map (.description) after' @?= [Just adminSeedDescription, Just "read the audit trail"]++-- | Grants: idempotent insert, listing, revocation, and the "nothing to revoke" report.+testRoleGrants :: TestTree+testRoleGrants =+  testCase "role grants: idempotent grant/revoke round-trip" $ withDb \pool -> do+    result <- runApp pool do+      u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})+      ts <- now+      _ <- defineRole (Role "auditor") Nothing ts+      firstGrant <- grantRole u.userId (Role "admin") Nothing Nothing ts+      secondGrant <- grantRole u.userId (Role "admin") Nothing Nothing ts+      _ <- grantRole u.userId (Role "auditor") (Just u.userId) Nothing ts+      granted <- listRolesForUser u.userId ts+      firstRevoke <- revokeRole u.userId (Role "admin")+      secondRevoke <- revokeRole u.userId (Role "admin")+      remaining <- listRolesForUser u.userId ts+      pure (firstGrant, secondGrant, granted, firstRevoke, secondRevoke, remaining)+    (firstGrant, secondGrant, granted, firstRevoke, secondRevoke, remaining) <- expectApp result+    firstGrant @?= True+    secondGrant @?= False+    granted @?= Set.fromList [Role "admin", Role "auditor"]+    firstRevoke @?= True+    secondRevoke @?= False+    remaining @?= Set.singleton (Role "auditor")++-- | The database enforces both foreign keys, so code that bypasses 'Shomei.Authorization.Role.Workflow'+-- still cannot create a dangling grant. Hasql command failures cross the adapter boundary as+-- 'DependencyUnavailable'; the workflow catches both cases first and returns a typed error.+testRoleGrantForeignKeys :: TestTree+testRoleGrantForeignKeys =+  testCase "role grants: FKs reject undefined roles and unknown users; workflow pre-checks" $ withDb \pool -> do+    setup <- runApp pool do+      u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})+      pure u.userId+    uid <- expectApp setup++    -- Raw port, undefined role: the shomei_role_grants.role FK fires.+    rawUndefinedRole <- runApp pool do+      ts <- now+      grantRole uid (Role "nosuchrole") Nothing Nothing ts+    expectDependencyError "grant of an undefined role" rawUndefinedRole++    -- Raw port, unknown user: the shomei_role_grants.user_id FK fires.+    ghost <- genUserId+    rawUnknownUser <- runApp pool do+      ts <- now+      grantRole ghost (Role "admin") Nothing Nothing ts+    expectDependencyError "grant to a nonexistent user" rawUnknownUser++    -- The workflow refuses both BEFORE touching the table, with typed errors.+    workflowUndefinedRole <- runApp pool (grantRoleTo Nothing Nothing uid (Role "nosuchrole"))+    expectApp workflowUndefinedRole >>= \r -> r @?= Left (RoleNotDefined (Role "nosuchrole"))++    workflowUnknownUser <- runApp pool (grantRoleTo Nothing Nothing ghost (Role "admin"))+    expectApp workflowUnknownUser >>= \r -> r @?= Left UserNotFound++    -- And the happy path still lands a row plus exactly one role_granted audit event.+    ok <- runApp pool (grantRoleTo Nothing Nothing uid (Role "admin"))+    expectApp ok >>= \r -> r @?= Right True+    again <- runApp pool (grantRoleTo Nothing Nothing uid (Role "admin"))+    expectApp again >>= \r -> r @?= Right False+    grants <- scalarInt pool "SELECT count(*) FROM shomei.shomei_role_grants"+    grants @?= 1+    events <- scalarInt pool "SELECT count(*) FROM shomei.shomei_auth_events WHERE event_type = 'role_granted'"+    events @?= 1+  where+    expectDependencyError what = \case+      Left (DependencyUnavailable PostgreSQL) -> pure ()+      Left e -> assertFailure (what <> ": expected PostgreSQL dependency failure, got " <> show e)+      Right _ -> assertFailure (what <> ": expected the foreign key to reject it")++-- | The claims path end to end over the real store: a role granted through the workflow shows+-- up in the claims 'buildEnrichedClaims' assembles, which is what every token mint signs.+testGrantedRoleReachesEnrichedClaims :: TestTree+testGrantedRoleReachesEnrichedClaims =+  testCase "buildEnrichedClaims reads roles from the real PostgreSQL store" $ withDb \pool -> do+    result <- runApp pool do+      u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})+      sid <- genSessionId+      ts <- now+      before <- buildEnrichedClaims cfg u.userId sid ts+      _ <- grantRoleTo Nothing Nothing u.userId (Role "admin")+      after' <- buildEnrichedClaims cfg u.userId sid ts+      pure (before, after')+    (before, after') <- expectApp result+    before.roles @?= Set.empty+    after'.roles @?= Set.singleton (Role "admin")+    -- Shōmei persists no scopes; the null enricher adds none.+    after'.scopes @?= Set.empty++-- | Role→permission wiring (EP-9): idempotent allow, single-role listing, deduplicated union+-- across a role set, and disallow with its "nothing to detach" report.+testRolePermissions :: TestTree+testRolePermissions =+  testCase "role permissions: allow/list/union/disallow round-trip" $ withDb \pool -> do+    result <- runApp pool do+      ts <- now+      _ <- defineRole (Role "support") (Just "support staff") ts+      _ <- defineRole (Role "billing") (Just "billing staff") ts+      firstAllow <- allowPermission (Role "support") (Permission "tickets:write") ts+      dupAllow <- allowPermission (Role "support") (Permission "tickets:write") ts+      _ <- allowPermission (Role "support") (Permission "tickets:read") ts+      -- Overlapping permission on a second role, to prove the union deduplicates.+      _ <- allowPermission (Role "billing") (Permission "tickets:read") ts+      _ <- allowPermission (Role "billing") (Permission "invoices:read") ts+      supportPerms <- listPermissionsForRole (Role "support")+      union <- permissionsForRoles (Set.fromList [Role "support", Role "billing"])+      firstDisallow <- disallowPermission (Role "support") (Permission "tickets:write")+      secondDisallow <- disallowPermission (Role "support") (Permission "tickets:write")+      afterDisallow <- listPermissionsForRole (Role "support")+      pure (firstAllow, dupAllow, supportPerms, union, firstDisallow, secondDisallow, afterDisallow)+    (firstAllow, dupAllow, supportPerms, union, firstDisallow, secondDisallow, afterDisallow) <- expectApp result+    firstAllow @?= True+    dupAllow @?= False+    supportPerms @?= Set.fromList [Permission "tickets:read", Permission "tickets:write"]+    union @?= Set.fromList [Permission "invoices:read", Permission "tickets:read", Permission "tickets:write"]+    firstDisallow @?= True+    secondDisallow @?= False+    afterDisallow @?= Set.singleton (Permission "tickets:read")++-- | The @shomei_role_permissions.role@ FK rejects attaching a permission to an undefined role,+-- exactly as the grants FK rejects granting one. The raw port surfaces the Hasql command+-- failure as 'DependencyUnavailable PostgreSQL'.+testRolePermissionForeignKey :: TestTree+testRolePermissionForeignKey =+  testCase "role permissions: allow on an undefined role hits the FK" $ withDb \pool -> do+    res <- runApp pool do+      ts <- now+      allowPermission (Role "nosuchrole") (Permission "tickets:write") ts+    case res of+      Left (DependencyUnavailable PostgreSQL) -> pure ()+      Left e -> assertFailure ("expected PostgreSQL dependency failure, got " <> show e)+      Right _ -> assertFailure "expected the FK to reject a permission on an undefined role"++-- | Time-bound grants (EP-9): a grant with an expiry drops out of 'listRolesForUser' as of an+-- instant past it, but is present as of an instant before it; re-granting with a different expiry+-- reports a change and the new window wins, while an identical re-grant reports none.+testExpiringGrants :: TestTree+testExpiringGrants =+  testCase "expiring grants: as-of filter, and upsert reports change only when expiry moves" $ withDb \pool -> do+    result <- runApp pool do+      u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})+      ts <- now+      let expiry = addUTCTime 3600 ts -- one hour out+      _ <- grantRole u.userId (Role "admin") Nothing (Just expiry) ts+      liveNow <- listRolesForUser u.userId ts -- before expiry: present+      liveAfter <- listRolesForUser u.userId (addUTCTime 7200 ts) -- after expiry: gone+      -- Identical re-grant: no change.+      sameAgain <- grantRole u.userId (Role "admin") Nothing (Just expiry) ts+      -- Re-grant moving the expiry further out: a change, and the new window applies.+      let expiry2 = addUTCTime 10800 ts+      moved <- grantRole u.userId (Role "admin") Nothing (Just expiry2) ts+      liveAtOldExpiry <- listRolesForUser u.userId (addUTCTime 7200 ts) -- now inside the new window+      pure (liveNow, liveAfter, sameAgain, moved, liveAtOldExpiry)+    (liveNow, liveAfter, sameAgain, moved, liveAtOldExpiry) <- expectApp result+    liveNow @?= Set.singleton (Role "admin")+    liveAfter @?= Set.empty+    sameAgain @?= False+    moved @?= True+    liveAtOldExpiry @?= Set.singleton (Role "admin")++-- | The description the @shomei-role-grants@ migration seeds onto the @admin@ role.+adminSeedDescription :: Text+adminSeedDescription = "Full access to the shomei /admin surface and admin CLI-equivalent HTTP routes"++-- | The TOTP credential store's contract against real PostgreSQL: the raw secret survives the+-- encrypt→store→decrypt round-trip, @confirm@ and the last-used counter land, and delete removes+-- the row.+testTotpCredentialRoundTrip :: TestTree+testTotpCredentialRoundTrip =+  testCase "totp credential: enroll, find (raw secret round-trips), confirm, counter, delete" $ withDb \pool -> do+    result <- runApp pool do+      u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})+      tcid <- genTotpCredentialId+      t <- now+      created <-+        upsertTotpEnrollment+          NewTotpCredential {totpCredentialId = tcid, userId = u.userId, secret = TotpSecret totpRawSecret, createdAt = t}+      found0 <- findTotpByUser u.userId+      confirmTotp tcid t+      counterAdvanced <- setTotpLastUsedCounter tcid 42+      found1 <- findTotpByUser u.userId+      deleteTotpByUser u.userId+      found2 <- findTotpByUser u.userId+      pure (created, found0, counterAdvanced, found1, found2)+    (created, found0, counterAdvanced, found1, found2) <- expectApp result+    tcSecret created @?= TotpSecret totpRawSecret+    fmap tcSecret found0 @?= Just (TotpSecret totpRawSecret)+    fmap tcConfirmedAt found0 @?= Just Nothing+    counterAdvanced @?= True+    fmap (isJust . tcConfirmedAt) found1 @?= Just True+    fmap tcLastUsedCounter found1 @?= Just (Just 42)+    found2 @?= Nothing++testTotpCounterIsCompareAndSwap :: TestTree+testTotpCounterIsCompareAndSwap =+  testCase "totp counter advances only to a strictly newer value" $ withDb \pool -> do+    result <- runApp pool do+      u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})+      tcid <- genTotpCredentialId+      t <- now+      _ <-+        upsertTotpEnrollment+          NewTotpCredential {totpCredentialId = tcid, userId = u.userId, secret = TotpSecret totpRawSecret, createdAt = t}+      first <- setTotpLastUsedCounter tcid 42+      same <- setTotpLastUsedCounter tcid 42+      older <- setTotpLastUsedCounter tcid 41+      newer <- setTotpLastUsedCounter tcid 43+      stored <- findTotpByUser u.userId+      pure (first, same, older, newer, stored)+    (first, same, older, newer, stored) <- expectApp result+    (first, same, older, newer) @?= (True, False, False, True)+    fmap tcLastUsedCounter stored @?= Just (Just 43)++testTotpCounterCasUnderRace :: TestTree+testTotpCounterCasUnderRace =+  testCase "totp counter: eight racing updates have one winner" $ withDb \pool -> do+    seeded <- runApp pool do+      u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})+      tcid <- genTotpCredentialId+      t <- now+      _ <-+        upsertTotpEnrollment+          NewTotpCredential {totpCredentialId = tcid, userId = u.userId, secret = TotpSecret totpRawSecret, createdAt = t}+      pure tcid+    tcid <- expectApp seeded+    gate <- newEmptyMVar+    dones <- replicateM 8 do+      done <- newEmptyMVar+      _ <- forkIO do+        readMVar gate+        putMVar done =<< runApp pool (setTotpLastUsedCounter tcid 42)+      pure done+    putMVar gate ()+    results <- traverse (\done -> expectApp =<< takeMVar done) dones+    length (filter id results) @?= 1++-- | The stored @secret_enc@ is genuine ciphertext: it differs from the plaintext secret and is+-- longer by exactly the 12-byte nonce and 16-byte GCM tag. Decryption is proven by the round-trip+-- test above; here we prove nothing recoverable sits at rest.+testTotpEncryptionAtRest :: TestTree+testTotpEncryptionAtRest =+  testCase "totp secret is encrypted at rest (ciphertext differs from plaintext, nonce+tag framed)" $ withDb \pool -> do+    result <- runApp pool do+      u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})+      tcid <- genTotpCredentialId+      t <- now+      _ <- upsertTotpEnrollment NewTotpCredential {totpCredentialId = tcid, userId = u.userId, secret = TotpSecret totpRawSecret, createdAt = t}+      pure ()+    _ <- expectApp result+    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++-- | 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+testRecoveryCodeCasAndReplace =+  testCase "recovery codes: replace-set, consume-once CAS, count drops, regeneration replaces" $ withDb \pool -> do+    result <- runApp pool do+      u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})+      t <- now+      ids <- replicateM 3 genRecoveryCodeId+      let mk i h = NewRecoveryCode {recoveryCodeId = i, codeHash = h, createdAt = t}+          codes = zipWith mk ids ["h1", "h2", "h3"]+      replaceRecoveryCodes u.userId codes+      countBefore <- countUnusedRecoveryCodes u.userId+      firstConsume <- consumeRecoveryCode u.userId "h1" t+      secondConsume <- consumeRecoveryCode u.userId "h1" t+      countAfter <- countUnusedRecoveryCodes u.userId+      ids2 <- replicateM 2 genRecoveryCodeId+      replaceRecoveryCodes u.userId (zipWith mk ids2 ["n1", "n2"])+      countAfterReplace <- countUnusedRecoveryCodes u.userId+      oldConsume <- consumeRecoveryCode u.userId "h2" t+      pure (countBefore, firstConsume, secondConsume, countAfter, countAfterReplace, oldConsume)+    (countBefore, firstConsume, secondConsume, countAfter, countAfterReplace, oldConsume) <- expectApp result+    countBefore @?= 3+    firstConsume @?= True+    secondConsume @?= False+    countAfter @?= 2+    countAfterReplace @?= 2+    oldConsume @?= False++testUserRoundTrip :: TestTree+testUserRoundTrip = testCase "create + find user round-trips" $ withDb \pool -> do+  result <- runApp pool do+    u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Just "Alice"})+    byId <- findUserById u.userId+    byEmail <- findUserByEmail aliceEmail+    pure (u, byId, byEmail)+  (u, byId, byEmail) <- expectApp result+  fmap (.userId) byId @?= Just u.userId+  fmap (.loginId) byId @?= Just aliceLogin+  fmap (.email) byId @?= Just (Just aliceEmail)+  fmap (.displayName) byId @?= Just (Just "Alice")+  fmap (.userId) byEmail @?= Just u.userId++-- | The M3 acceptance: a user can be created with NO email, round-trips by login id with+-- @email IS NULL@, the @login_id@ unique index rejects a duplicate principal, and the+-- partial unique index on @email@ permits multiple NULL emails.+testUserNoEmailAndUniqueLoginId :: TestTree+testUserNoEmailAndUniqueLoginId =+  testCase "user: NULL email round-trips; login_id unique; NULL emails don't collide" $ withDb \pool -> do+    let svc = mkLoginId' "svc-bot"+        svc2 = mkLoginId' "svc-bot-2"+    created <- runApp pool do+      u <- createUser (NewUser {loginId = svc, email = Nothing, displayName = Nothing})+      byLogin <- findUserByLoginId svc+      pure (u, byLogin)+    (u, byLogin) <- expectApp created+    fmap (.email) byLogin @?= Just Nothing+    fmap (.loginId) byLogin @?= Just svc+    fmap (.userId) byLogin @?= Just u.userId+    -- Unique-index conflicts retain their domain meaning at the persistence boundary.+    dup <- runApp pool (createUser (NewUser {loginId = svc, email = Nothing, displayName = Nothing}))+    dup @?= Left LoginIdAlreadyRegistered+    -- a second no-email user with a distinct login id is allowed: NULL emails don't collide+    second <- runApp pool (createUser (NewUser {loginId = svc2, email = Nothing, displayName = Nothing}))+    _ <- expectApp second+    nullEmails <- scalarInt pool "SELECT count(*) FROM shomei.shomei_users WHERE email IS NULL"+    nullEmails @?= 2+    _ <- expectApp =<< runApp pool (createUser (NewUser {loginId = mkLoginId' "email-owner", email = Just aliceEmail, displayName = Nothing}))+    dupEmail <- runApp pool (createUser (NewUser {loginId = mkLoginId' "email-collider", email = Just aliceEmail, displayName = Nothing}))+    dupEmail @?= Left EmailAlreadyRegistered++-- | The database remains a trust boundary even for writers that bypass Shomei's codecs.+-- Invalid persisted vocabulary is a CHECK violation, while login ids and email addresses are+-- unique independently of case.+testSchemaRejectsInvalidUserStatusAndCaseVariantIdentities :: TestTree+testSchemaRejectsInvalidUserStatusAndCaseVariantIdentities =+  testCase "schema rejects invalid user status and case-variant identities" $ withDb \pool -> do+    execSql+      pool+      """+      INSERT INTO shomei.shomei_users+        (user_id, email, display_name, status, created_at, updated_at, login_id)+      VALUES+        ('11111111-1111-1111-1111-111111111111', 'alice@example.com', 'Alice', 'active', now(), now(), 'alice');+      """+    execSqlExpectState+      pool+      "23514"+      """+      INSERT INTO shomei.shomei_users+        (user_id, email, display_name, status, created_at, updated_at, login_id)+      VALUES+        ('22222222-2222-2222-2222-222222222222', 'bogus@example.com', NULL, 'bogus', now(), now(), 'bogus');+      """+    execSqlExpectState+      pool+      "23505"+      """+      INSERT INTO shomei.shomei_users+        (user_id, email, display_name, status, created_at, updated_at, login_id)+      VALUES+        ('33333333-3333-3333-3333-333333333333', 'Alice@Example.com', NULL, 'active', now(), now(), 'other-login');+      """+    execSqlExpectState+      pool+      "23505"+      """+      INSERT INTO shomei.shomei_users+        (user_id, email, display_name, status, created_at, updated_at, login_id)+      VALUES+        ('44444444-4444-4444-4444-444444444444', 'other@example.com', NULL, 'active', now(), now(), 'Alice');+      """++-- | The admin listing's three promises, against the real statement: newest-first order, the+-- status filter, and a keyset walk that is both disjoint and complete.+--+-- The walk matters more than it looks. An OFFSET pager over @ORDER BY created_at DESC@ would+-- pass a two-page test on distinct timestamps and silently skip or repeat rows the moment two+-- users share one — which is exactly what a bulk import produces. The cursor compares the whole+-- @(created_at, user_id)@ tuple, so this test seeds three users and asserts the pages partition+-- them.+testListUsersOrderFilterAndPaging :: TestTree+testListUsersOrderFilterAndPaging = testCase "listUsers: newest-first, status-filtered, keyset-paged" $ withDb \pool -> do+  result <- runApp pool do+    u1 <- createUser (NewUser {loginId = mkLoginId' "one", email = Nothing, displayName = Nothing})+    u2 <- createUser (NewUser {loginId = mkLoginId' "two", email = Nothing, displayName = Nothing})+    u3 <- createUser (NewUser {loginId = mkLoginId' "three", email = Nothing, displayName = Nothing})+    ts <- now+    _ <- updateUserStatus u2.userId [UserActive] UserSuspended ts+    everyone <- listUsers emptyUserListQuery+    suspended <- listUsers emptyUserListQuery {queryStatus = Just UserSuspended}+    active <- listUsers emptyUserListQuery {queryStatus = Just UserActive}+    page1 <- listUsers emptyUserListQuery {queryLimit = 2}+    page2 <- case reverse page1 of+      [] -> pure []+      (lastUser : _) ->+        listUsers+          emptyUserListQuery+            { queryLimit = 2,+              queryBefore = Just (UserCursor {cursorCreatedAt = lastUser.createdAt, cursorUserId = lastUser.userId})+            }+    pure (u1, u2, u3, everyone, suspended, active, page1, page2)+  (u1, u2, u3, everyone, suspended, active, page1, page2) <- expectApp result++  -- Newest first. Rows created in one transaction can share a created_at, so assert on the set+  -- and on the ordering key rather than on a fixed permutation.+  map (.userId) everyone `shouldContainExactly` [u1.userId, u2.userId, u3.userId]+  assertBool "newest-first" (isDescending (map (\u -> (u.createdAt, u.userId)) everyone))++  map (.userId) suspended @?= [u2.userId]+  map (.userId) active `shouldContainExactly` [u1.userId, u3.userId]++  -- The keyset walk partitions the users: no overlap, nothing lost.+  length page1 @?= 2+  length page2 @?= 1+  (map (.userId) page1 <> map (.userId) page2) `shouldContainExactly` [u1.userId, u2.userId, u3.userId]++testUserStatusIsCompareAndSwap :: TestTree+testUserStatusIsCompareAndSwap =+  testCase "user status changes only from an allowed current status" $ withDb \pool -> do+    result <- runApp pool do+      user <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})+      first <- updateUserStatus user.userId [UserActive] UserSuspended t0+      second <- updateUserStatus user.userId [UserActive] UserSuspended t0+      stored <- findUserById user.userId+      pure (first, second, stored)+    (first, second, stored) <- expectApp result+    (first, second) @?= (True, False)+    fmap (.status) stored @?= Just UserSuspended++testUserStatusCasUnderRace :: TestTree+testUserStatusCasUnderRace =+  testCase "user status: eight racing suspends have one winner" $ withDb \pool -> do+    seeded <- runApp pool do+      user <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})+      pure user.userId+    uid <- expectApp seeded+    gate <- newEmptyMVar+    dones <- replicateM 8 do+      done <- newEmptyMVar+      _ <- forkIO do+        readMVar gate+        putMVar done =<< runApp pool (updateUserStatus uid [UserActive] UserSuspended t0)+      pure done+    putMVar gate ()+    results <- traverse (\done -> expectApp =<< takeMVar done) dones+    length (filter id results) @?= 1++testListSessionsForUser :: TestTree+testListSessionsForUser = testCase "listSessionsForUser returns every status, newest-first, for one user only" $ withDb \pool -> do+  result <- runApp pool do+    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})+    revokeSession s1.sessionId t+    aliceSessions <- listSessionsForUser alice.userId+    pure (s1, s2, aliceSessions)+  (s1, s2, aliceSessions) <- expectApp result+  -- Bob's session is absent; a revoked session is still listed (an admin must see it).+  map (.sessionId) aliceSessions @?= [s2.sessionId, s1.sessionId]+  map (.status) aliceSessions @?= [SessionActive, SessionRevoked]++-- | Set equality with a readable failure, without imposing an order.+shouldContainExactly :: (Ord a, Show a) => [a] -> [a] -> Assertion+shouldContainExactly actual expected = sort actual @?= sort expected++isDescending :: (Ord a) => [a] -> Bool+isDescending xs = and (zipWith (>=) xs (drop 1 xs))++testCredentialRoundTrip :: TestTree+testCredentialRoundTrip = testCase "create credential + find-by-email" $ withDb \pool -> do+  result <- runApp pool do+    u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})+    h <- hashPassword strongPw+    _ <- createPasswordCredential u.userId aliceLogin (Just aliceEmail) h+    byEmail <- findPasswordCredentialByEmail aliceEmail+    byLogin <- findPasswordCredentialByLoginId aliceLogin+    pure (u, h, byEmail, byLogin)+  (u, h, byEmail, byLogin) <- expectApp result+  fmap (.userId) byEmail @?= Just u.userId+  fmap (.email) byEmail @?= Just (Just aliceEmail)+  fmap (.passwordHash) byEmail @?= Just h+  fmap (.userId) byLogin @?= Just u.userId+  fmap (.loginId) byLogin @?= Just aliceLogin+  duplicateLogin <- runApp pool (createPasswordCredential u.userId aliceLogin (Just bobEmail) h)+  duplicateLogin @?= Left LoginIdAlreadyRegistered+  duplicateEmail <- runApp pool (createPasswordCredential u.userId bobLogin (Just aliceEmail) h)+  duplicateEmail @?= Left EmailAlreadyRegistered++testCredentialUniquePerUser :: TestTree+testCredentialUniquePerUser = testCase "one password credential per user is a database invariant" $ withDb \pool -> do+  execSql+    pool+    "INSERT INTO shomei.shomei_users (user_id, login_id, email, status, created_at, updated_at) VALUES ('10000000-0000-0000-0000-000000000001', 'unique-owner', 'unique-owner@example.com', 'active', now(), now()); INSERT INTO shomei.shomei_password_credentials (credential_id, user_id, login_id, email, password_hash, created_at, updated_at) VALUES ('20000000-0000-0000-0000-000000000001', '10000000-0000-0000-0000-000000000001', 'unique-owner', 'unique-owner@example.com', 'hash-one', now(), now())"+  duplicate <-+    Pool.use+      pool+      ( Session.script+          "INSERT INTO shomei.shomei_password_credentials (credential_id, user_id, login_id, email, password_hash, created_at, updated_at) VALUES ('20000000-0000-0000-0000-000000000002', '10000000-0000-0000-0000-000000000001', 'unique-owner-two', 'unique-owner-two@example.com', 'hash-two', now(), now())"+      )+  case duplicate of+    Left err ->+      assertBool+        ("expected the user_id unique index, got: " <> show err)+        ("23505" `Text.isInfixOf` Text.pack (show err) || "shomei_password_credentials_user_id_key" `Text.isInfixOf` Text.pack (show err))+    Right () -> assertFailure "a second password credential for one user was accepted"+  scalarInt+    pool+    "SELECT count(*) FROM pg_indexes WHERE schemaname = 'shomei' AND indexname = 'shomei_password_credentials_user_id_key'"+    >>= (@?= 1)++testPoolStatementTimeoutIsApplied :: TestTree+testPoolStatementTimeoutIsApplied = testCase "pool connections bound statements and idle transactions" $+  withShomeiMigratedDatabase \connStr -> do+    pool <- acquirePool 1 10 200 connStr+    configured <- Pool.use pool (Session.statement () timeoutSettingsStatement)+    either (assertFailure . ("could not read pool timeout settings: " <>) . show) pure configured+      >>= (@?= ("200ms", "200ms"))+    statementResult <- Pool.use pool (Session.script "SELECT pg_sleep(1)")+    assertPoolFailureMentions ["57014", "statement timeout"] statementResult++    beginResult <- Pool.use pool (Session.script "BEGIN")+    either (assertFailure . ("could not begin idle-timeout probe: " <>) . show) pure beginResult+    threadDelay 400000+    idleResult <- Pool.use pool (Session.script "SELECT 1")+    case idleResult of+      Left _ -> pure ()+      Right () -> assertFailure "the connection survived past idle_in_transaction_session_timeout"+    Pool.release pool+  where+    timeoutSettingsStatement =+      preparable+        "SELECT current_setting('statement_timeout'), current_setting('idle_in_transaction_session_timeout')"+        E.noParams+        (D.singleRow ((,) <$> D.column (D.nonNullable D.text) <*> D.column (D.nonNullable D.text)))+    assertPoolFailureMentions needles = \case+      Left err ->+        assertBool+          ("expected one of " <> show needles <> " in pool failure: " <> show err)+          (any (\needle -> Text.toLower needle `Text.isInfixOf` Text.toLower (Text.pack (show err))) needles)+      Right () -> assertFailure ("expected PostgreSQL timeout failure mentioning one of " <> show needles)++testSessionRevoke :: TestTree+testSessionRevoke = testCase "create session + revoke" $ withDb \pool -> do+  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})+    revokeSession s.sessionId t+    findSessionById s.sessionId+  found <- expectApp result+  fmap (.status) found @?= Just SessionRevoked++testSessionActorRoundTrip :: TestTree+testSessionActorRoundTrip = testCase "create delegated session persists actor" $ withDb \pool -> do+  result <- runApp pool do+    subject <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})+    operator <- createUser (NewUser {loginId = bobLogin, email = Just bobEmail, displayName = Nothing})+    t <- now+    delegated <-+      createSession+        ( NewSession+            { userId = subject.userId,+              createdAt = t,+              expiresAt = addUTCTime 3600 t,+              actor = Just operator.userId,+              oauthClientId = Nothing,+              kind = DelegatedSession,+              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})+    foundDelegated <- findSessionById delegated.sessionId+    foundNormal <- findSessionById normal.sessionId+    pure (operator.userId, foundDelegated, foundNormal)+  (op, foundDelegated, foundNormal) <- expectApp result+  fmap (.actor) foundDelegated @?= Just (Just op)+  fmap (.actor) foundNormal @?= Just Nothing++testSessionKindRoundTrip :: TestTree+testSessionKindRoundTrip = testCase "create session persists its kind (machine, delegated, interactive)" $ withDb \pool -> do+  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})+    foundInteractive <- findSessionById interactive.sessionId+    foundMachine <- findSessionById machine.sessionId+    foundDelegated <- findSessionById delegated.sessionId+    pure (foundInteractive, foundMachine, foundDelegated)+  (foundInteractive, foundMachine, foundDelegated) <- expectApp result+  fmap (.kind) foundInteractive @?= Just InteractiveSession+  fmap (.kind) foundMachine @?= Just MachineSession+  fmap (.kind) foundDelegated @?= Just DelegatedSession++testSessionGrantedScopesRoundTrip :: TestTree+testSessionGrantedScopesRoundTrip = testCase "session scopes and auth time round-trip; legacy values fall back" $ withDb \pool -> do+  let granted = Set.fromList [Scope "openid", Scope "kawa:read"]+  created <- runApp pool do+    user <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})+    t <- now+    let authenticated = addUTCTime (-30) t+    session <-+      createSession+        NewSession+          { userId = user.userId,+            createdAt = t,+            expiresAt = addUTCTime 3600 t,+            actor = Nothing,+            oauthClientId = Just "oauthclient_roundtrip",+            kind = InteractiveSession,+            grantedScopes = granted,+            authenticatedAt = authenticated+          }+    found <- findSessionById session.sessionId+    pure (session.sessionId, authenticated, found)+  (sessionId, authenticated, found) <- expectApp created+  fmap (.grantedScopes) found @?= Just granted+  fmap (.authenticatedAt) found @?= Just authenticated++  execSql pool "UPDATE shomei.shomei_sessions SET authenticated_at = NULL"+  legacy <- expectApp =<< runApp pool (findSessionById sessionId)+  fmap (.authenticatedAt) legacy @?= fmap (.createdAt) legacy++  execSql+    pool+    """+    INSERT INTO shomei.shomei_sessions+      (session_id, user_id, status, created_at, expires_at, kind)+    SELECT+      '00000000-0000-4000-8000-000000000052'::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 granted_scopes = '{}'::text[]"+  defaulted @?= 1++testSessionKindNullReadsInteractive :: TestTree+testSessionKindNullReadsInteractive = testCase "a session row whose kind is NULL reads as interactive" $ 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})+  session <- expectApp created+  execSql pool "UPDATE shomei.shomei_sessions SET kind = NULL"+  found <- expectApp =<< runApp pool (findSessionById session.sessionId)+  fmap (.kind) found @?= Just InteractiveSession++-- | 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+-- and leaves the row (including the winner's @used_at@) untouched. This is the statement-level+-- guarantee that makes two concurrent refreshes of one token impossible to both succeed.+testRefreshTokenMarkUsed :: TestTree+testRefreshTokenMarkUsed = testCase "refresh token: find-by-hash + mark-used is a compare-and-swap" $ withDb \pool -> do+  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})+    h <- hashRefreshToken (RefreshToken "token-1")+    persisted <-+      createRefreshToken+        NewRefreshToken+          { sessionId = s.sessionId,+            tokenHash = h,+            parentTokenId = Nothing,+            createdAt = t,+            expiresAt = addUTCTime 86400 t+          }+    beforeUse <- findRefreshTokenByHash h+    firstMark <- markRefreshTokenUsed persisted.refreshTokenId t+    afterUse <- findRefreshTokenByHash h+    secondMark <- markRefreshTokenUsed persisted.refreshTokenId (addUTCTime 60 t)+    afterSecond <- findRefreshTokenByHash h+    pure (beforeUse, afterUse, firstMark, secondMark, afterSecond)+  (beforeUse, afterUse, firstMark, secondMark, afterSecond) <- expectApp result+  fmap (.status) beforeUse @?= Just RefreshTokenActive+  fmap (.status) afterUse @?= Just RefreshTokenUsed+  firstMark @?= True+  secondMark @?= False+  -- The loser overwrote nothing: the row still carries the winner's used_at.+  fmap (.usedAt) afterSecond @?= fmap (.usedAt) afterUse+  fmap (.status) afterSecond @?= Just RefreshTokenUsed++testVerificationTokenRoundTrip :: TestTree+testVerificationTokenRoundTrip = testCase "verification token: consume is a compare-and-swap" $ withDb \pool -> do+  result <- runApp pool do+    u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})+    t <- now+    let h = OneTimeTokenHash "hash:verify-1"+    persisted <-+      createVerificationToken+        NewVerificationToken+          { userId = u.userId,+            tokenHash = h,+            createdAt = t,+            expiresAt = addUTCTime 3600 t+          }+    before <- findVerificationTokenByHash h+    firstConsume <- markVerificationTokenConsumed persisted.verificationTokenId t+    after <- findVerificationTokenByHash h+    secondConsume <- markVerificationTokenConsumed persisted.verificationTokenId (addUTCTime 60 t)+    afterSecond <- findVerificationTokenByHash h+    pure (before, after, firstConsume, secondConsume, afterSecond)+  (before, after, firstConsume, secondConsume, afterSecond) <- expectApp result+  fmap (.status) before @?= Just OneTimeTokenActive+  fmap (.status) after @?= Just OneTimeTokenConsumed+  firstConsume @?= True+  secondConsume @?= False+  fmap (.consumedAt) afterSecond @?= fmap (.consumedAt) after++testPasswordResetTokenRoundTrip :: TestTree+testPasswordResetTokenRoundTrip = testCase "password reset token: consume is a compare-and-swap" $ withDb \pool -> do+  result <- runApp pool do+    u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})+    t <- now+    let h = OneTimeTokenHash "hash:reset-1"+    persisted <-+      createPasswordResetToken+        NewPasswordResetToken+          { userId = u.userId,+            tokenHash = h,+            createdAt = t,+            expiresAt = addUTCTime 3600 t+          }+    before <- findPasswordResetTokenByHash h+    firstConsume <- markPasswordResetTokenConsumed persisted.passwordResetTokenId t+    after <- findPasswordResetTokenByHash h+    secondConsume <- markPasswordResetTokenConsumed persisted.passwordResetTokenId (addUTCTime 60 t)+    afterSecond <- findPasswordResetTokenByHash h+    pure (before, after, firstConsume, secondConsume, afterSecond)+  (before, after, firstConsume, secondConsume, afterSecond) <- expectApp result+  fmap (.status) before @?= Just OneTimeTokenActive+  fmap (.status) after @?= Just OneTimeTokenConsumed+  firstConsume @?= True+  secondConsume @?= False+  fmap (.consumedAt) afterSecond @?= fmap (.consumedAt) after++testMarkUserEmailVerified :: TestTree+testMarkUserEmailVerified = testCase "mark user email verified sets the timestamp" $ withDb \pool -> do+  result <- runApp pool do+    u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})+    t <- now+    markUserEmailVerified u.userId t+    findUserById u.userId+  found <- expectApp result+  assertBool "email_verified_at is populated" (maybe False (isJust . (.emailVerifiedAt)) found)++testSigningKeys :: TestTree+testSigningKeys = testCase "insert + list signing keys" $ withDb \pool -> do+  result <- runApp pool do+    t <- now+    let key =+          StoredSigningKey+            { keyId = "kid-1",+              algorithm = "ES256",+              publicKeyJwk = "{\"kty\":\"EC\"}",+              privateKeyJwk = "{\"kty\":\"EC\",\"d\":\"x\"}",+              status = KeyActive,+              createdAt = t,+              activatedAt = Just t,+              retiredAt = Nothing,+              revokedAt = Nothing+            }+    insertSigningKey key+    active <- listActiveSigningKeys+    byKid <- findSigningKeyByKid "kid-1"+    pure (active, byKid)+  (active, byKid) <- expectApp result+  fmap (.keyId) active @?= ["kid-1"]+  fmap (.keyId) byKid @?= Just "kid-1"++-- | @listPublishableSigningKeys@ returns exactly the active + retired keys (the JWKS+-- contents), while @listActiveSigningKeys@ still returns only the signing key.+testPublishableSigningKeys :: TestTree+testPublishableSigningKeys = testCase "publishable signing keys are active + retired" $ withDb \pool -> do+  result <- runApp pool do+    t <- now+    let key kid st =+          StoredSigningKey+            { keyId = kid,+              algorithm = "ES256",+              publicKeyJwk = "{\"kty\":\"EC\"}",+              privateKeyJwk = "{\"kty\":\"EC\",\"d\":\"x\"}",+              status = st,+              createdAt = t,+              activatedAt = Just t,+              retiredAt = Nothing,+              revokedAt = Nothing+            }+    -- Insert each row Pending, then drive it to its target status through the port, so+    -- the test exercises updateSigningKeyStatus rather than trusting the insert.+    forM_ [("k-active", KeyActive), ("k-retired", KeyRetired), ("k-revoked", KeyRevoked)] \(kid, st) -> do+      insertSigningKey (key kid KeyPending)+      updateSigningKeyStatus kid st t+    insertSigningKey (key "k-pending" KeyPending)+    publishable <- listPublishableSigningKeys+    active <- listActiveSigningKeys+    pure (publishable, active)+  (publishable, active) <- expectApp result+  sort (fmap (.keyId) publishable) @?= ["k-active", "k-retired"]+  fmap (.keyId) active @?= ["k-active"]++testSigningKeyTransitionTimestamps :: TestTree+testSigningKeyTransitionTimestamps = testCase "signing-key transitions stamp activated, retired, and revoked times" $ withDb \pool -> do+  let activated = t0+      retired = addUTCTime 60 t0+      revoked = addUTCTime 120 t0+      key = signingKeyFixture "k-stamped" KeyPending t0+  result <- runAppAtTime t0 pool do+    insertSigningKey key+    updateSigningKeyStatus key.keyId KeyActive activated+    updateSigningKeyStatus key.keyId KeyRetired retired+    updateSigningKeyStatus key.keyId KeyRevoked revoked+    findSigningKeyByKid key.keyId+  stored <- expectApp result >>= maybe (assertFailure "stamped signing key disappeared") pure+  stored.activatedAt @?= Just activated+  stored.retiredAt @?= Just retired+  stored.revokedAt @?= Just revoked++testSigningKeyOneActiveInvariant :: TestTree+testSigningKeyOneActiveInvariant = testCase "one-active index rejects a second insert and atomic replacement retires the old key" $ withDb \pool -> do+  let replacedAt = addUTCTime 60 t0+      old = (signingKeyFixture "k-old" KeyActive t0) {activatedAt = Just t0}+      new = signingKeyFixture "k-new" KeyActive replacedAt+  expectApp =<< runAppAtTime t0 pool (insertSigningKey old)++  duplicate <- runAppAtTime t0 pool (insertSigningKey new)+  duplicate @?= Left (DependencyUnavailable PostgreSQL)++  replacement <- runAppAtTime replacedAt pool do+    replaceActiveSigningKey new replacedAt+    active <- listActiveSigningKeys+    oldAfter <- findSigningKeyByKid old.keyId+    newAfter <- findSigningKeyByKid new.keyId+    pure (active, oldAfter, newAfter)+  (active, oldAfter, newAfter) <- expectApp replacement+  fmap (.keyId) active @?= [new.keyId]+  fmap (.status) oldAfter @?= Just KeyRetired+  fmap (.retiredAt) oldAfter @?= Just (Just replacedAt)+  fmap (.status) newAfter @?= Just KeyActive+  fmap (.activatedAt) newAfter @?= Just (Just replacedAt)++signingKeyFixture :: Text -> SigningKeyStatus -> UTCTime -> StoredSigningKey+signingKeyFixture kid keyStatus created =+  StoredSigningKey+    { keyId = kid,+      algorithm = "ES256",+      publicKeyJwk = "{\"kty\":\"EC\"}",+      privateKeyJwk = "{\"kty\":\"EC\",\"d\":\"x\"}",+      status = keyStatus,+      createdAt = created,+      activatedAt = Nothing,+      retiredAt = Nothing,+      revokedAt = Nothing+    }++testPublishEvent :: TestTree+testPublishEvent = testCase "publish auth event lands a row" $ withDb \pool -> do+  result <- runApp pool do+    t <- now+    publishAuthEvent (Event.LoginFailed (Event.LoginFailedData (Just (AccountKey "k-alice")) Nothing t))+  _ <- expectApp result+  n <- scalarInt pool "SELECT count(*) FROM shomei.shomei_auth_events"+  n @?= 1++testAuditEventReader :: TestTree+testAuditEventReader = testCase "audit reader: filter + order + keyset pagination + reconstruct" $ withDb \pool -> do+  let tt :: Int -> UTCTime+      tt n = addUTCTime (fromIntegral n) t0+  result <- runApp pool do+    alice <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})+    bob <- createUser (NewUser {loginId = bobLogin, email = Just bobEmail, displayName = Nothing})+    s1 <- genSessionId+    s2 <- genSessionId+    -- Five events at strictly increasing times (newest = tt 4).+    publishAuthEvent (Event.LoginFailed (Event.LoginFailedData (Just (AccountKey "k-alice")) (Just alice.userId) (tt 0)))+    publishAuthEvent (Event.LoginSucceeded (Event.LoginSucceededData alice.userId s1 (tt 1)))+    publishAuthEvent (Event.LoginFailed (Event.LoginFailedData (Just (AccountKey "k-bob")) (Just bob.userId) (tt 2)))+    publishAuthEvent (Event.PasswordChanged (Event.PasswordChangedData alice.userId (tt 3)))+    publishAuthEvent (Event.LoginSucceeded (Event.LoginSucceededData bob.userId s2 (tt 4)))+    allEvents <- queryAuthEvents emptyAuditQuery+    aliceEvents <- queryAuthEvents emptyAuditQuery {queryUserId = Just (userIdToUUID alice.userId)}+    failedEvents <- queryAuthEvents emptyAuditQuery {queryEventTypes = ["login_failed"]}+    windowEvents <- queryAuthEvents emptyAuditQuery {querySince = Just (tt 1), queryUntil = Just (tt 3)}+    total <- countAuthEvents emptyAuditQuery+    failedTotal <- countAuthEvents emptyAuditQuery {queryEventTypes = ["login_failed"]}+    page1 <- queryAuthEvents emptyAuditQuery {queryLimit = 2}+    page2 <- case page1 of+      [] -> pure []+      rows ->+        let lastRow = last rows+            cur = AuditCursor (storedCreatedAt lastRow) (storedEventId lastRow)+         in queryAuthEvents emptyAuditQuery {queryLimit = 2, queryBefore = Just cur}+    pure (alice.userId, allEvents, aliceEvents, failedEvents, windowEvents, total, failedTotal, page1, page2)+  (aliceUserId, allEvents, aliceEvents, failedEvents, windowEvents, total, failedTotal, page1, page2) <- expectApp result+  -- newest-first ordering across all five+  map storedEventType allEvents+    @?= ["login_succeeded", "password_changed", "login_failed", "login_succeeded", "login_failed"]+  -- user filter includes a failed proof once its credential resolves to Alice.+  map storedEventType aliceEvents @?= ["password_changed", "login_succeeded", "login_failed"]+  -- type filter: the two failed logins (tt 2 = bob, tt 0 = alice)+  map storedEventType failedEvents @?= ["login_failed", "login_failed"]+  -- since (inclusive) tt1 .. until (exclusive) tt3 → tt2 then tt1+  map storedEventType windowEvents @?= ["login_failed", "login_succeeded"]+  total @?= 5+  failedTotal @?= 2+  -- keyset pagination walks the set with no gaps or repeats+  length page1 @?= 2+  length page2 @?= 2+  let ids1 = map storedEventId page1+      ids2 = map storedEventId page2+  assertBool "pages are disjoint" (all (`notElem` ids2) ids1)+  map storedEventType (page1 <> page2) @?= ["login_succeeded", "password_changed", "login_failed", "login_succeeded"]+  -- the oldest failed-login row reconstructs to the typed event we published+  case reverse failedEvents of+    (oldest : _) ->+      reconstructAuthEvent (storedEventType oldest) (storedPayload oldest)+        @?= Right (Event.LoginFailed (Event.LoginFailedData (Just (AccountKey "k-alice")) (Just aliceUserId) (tt 0)))+    [] -> assertFailure "expected at least one failed-login row"++testWorkflowSignup :: TestTree+testWorkflowSignup = testCase "workflow: signup persists user + session + token" $ withDb \pool -> do+  inner <- runApp pool (signup cfg (SignupCommand aliceLogin (Just aliceEmail) strongPw (Just "Alice")))+  _ <- expectApp inner >>= expectRight+  users <- scalarInt pool "SELECT count(*) FROM shomei.shomei_users"+  sessions <- scalarInt pool "SELECT count(*) FROM shomei.shomei_sessions"+  toks <- scalarInt pool "SELECT count(*) FROM shomei.shomei_refresh_tokens"+  users @?= 1+  sessions @?= 1+  toks @?= 1++-- Round-trip budget ----------------------------------------------------------++-- | Count every 'Database' dispatch a workflow makes.+--+-- 'interpose' replaces the 'Database' handler for the wrapped action only; re-'send'ing the+-- operation from inside the handler dispatches to the /upstream/ handler ('runDatabasePool'),+-- 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.+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, ()))+  case op of+    RunSession sess -> send (RunSession sess)+    RunTransaction t -> send (RunTransaction t)++-- | A successful password login costs exactly ten database round-trips:+--+--   1. @countRecentFailuresByIp@   (per-IP throttle)+--   2. @recordLoginFailure@        (ONE transaction: advisory lock + provisional insert + count)+--   3. @findPasswordCredentialByLoginId@+--   4. @findUserById@+--   5. @countPasskeysByUser@       (MFA gate: passkey factor)+--   6. @findTotpByUser@            (MFA gate: confirmed-TOTP factor — EP-7)+--   7. @convertLoginAttemptToSuccess@+--   8. @persistNewSession@         (ONE transaction: session + refresh token + 2 audit events)+--   9. @listRolesForUser@          (the roles claim, via @buildEnrichedClaims@)+--  10. @permissionsForRoles@       (the permissions claim, via @buildEnrichedClaims@ — EP-9)+--+-- 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.+--+-- 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+-- single-row indexed lookup on @user_id@. (The @recovery-codes@ count is read only inside the+-- challenge branch, which this no-factor login does not enter.)+--+-- Step 9 is the price of a populated @roles@ claim: every user-session mint reads the grant+-- table once. It is a single-row indexed lookup on the primary key prefix, and it buys the+-- alternative — re-reading roles on every /verification/ — never happening.+--+-- Step 10 was added by EP-9's @permissions@ claim: @buildEnrichedClaims@ resolves the effective+-- 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+-- changing the constant.+testLoginRoundTripBudget :: TestTree+testLoginRoundTripBudget = testCase "a successful login costs exactly 10 database round-trips" $ 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)))+  _ <- expectApp loginRes >>= expectRight+  readIORef counter >>= (@?= 10)++-- | A wrong password costs four checkouts: 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+  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"))))+  expectApp loginRes >>= (@?= Left InvalidCredentials)+  readIORef counter >>= (@?= 4)++-- | A token refresh costs exactly five database round-trips:+--+--   1. @findRefreshTokenByHash@+--   2. @findSessionById@+--   3. @rotateRefreshToken@     (ONE transaction: mark-used CAS + child insert + rotation event)+--   4. @listRolesForUser@       (the roles claim, via @buildEnrichedClaims@)+--   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.+--+-- 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+  signupRes <- runApp pool (signup cfg (SignupCommand aliceLogin (Just aliceEmail) strongPw Nothing))+  (_, pair) <- expectApp signupRes >>= expectRight+  counter <- newIORef 0+  refreshRes <- runApp pool (countingDatabase counter (refresh cfg (RefreshCommand pair.refreshToken)))+  _ <- expectApp refreshRes >>= expectRight+  readIORef counter >>= (@?= 5)++-- | Logout costs two database round-trips: 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+  signupRes <- runApp pool (signup cfg (SignupCommand aliceLogin (Just aliceEmail) strongPw Nothing))+  (user, _) <- expectApp signupRes >>= expectRight+  sessionsRes <- runApp pool (listSessionsForUser user.userId)+  sessions <- expectApp sessionsRes+  sid <- case sessions of+    session : _ -> pure session.sessionId+    [] -> assertFailure "expected signup to create a session"+  counter <- newIORef 0+  logoutRes <- runApp pool (countingDatabase counter (logout cfg (LogoutCommand sid)))+  _ <- expectApp logoutRes >>= expectRight+  readIORef counter >>= (@?= 2)++-- | Password-reset confirmation costs three database round-trips: 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+  notifications <- newIORef []+  signupRes <- runAppWithNotifications notifications pool (signup cfg (SignupCommand aliceLogin (Just aliceEmail) strongPw Nothing))+  _ <- expectApp signupRes >>= expectRight+  requestRes <- runAppWithNotifications notifications pool (requestPasswordReset cfg (RequestPasswordReset aliceEmail))+  _ <- expectApp requestRes >>= expectRight+  raw <- latestResetToken =<< readIORef notifications+  counter <- newIORef 0+  confirmRes <-+    runAppWithNotifications+      notifications+      pool+      ( countingDatabase+          counter+          (confirmPasswordReset cfg (ConfirmPasswordReset raw (PlainPassword "correct horse battery staple two")))+      )+  _ <- expectApp confirmRes >>= expectRight+  readIORef counter >>= (@?= 3)++testWorkflowRefreshRotation :: TestTree+testWorkflowRefreshRotation = testCase "workflow: refresh rotation marks used + inserts child" $ withDb \pool -> do+  signupRes <- runApp pool (signup cfg (SignupCommand aliceLogin (Just aliceEmail) strongPw Nothing))+  (_, pair) <- expectApp signupRes >>= expectRight+  refreshRes <- runApp pool (refresh cfg (RefreshCommand pair.refreshToken))+  _ <- expectApp refreshRes >>= expectRight+  toks <- scalarInt pool "SELECT count(*) FROM shomei.shomei_refresh_tokens"+  used <- scalarInt pool "SELECT count(*) FROM shomei.shomei_refresh_tokens WHERE status = 'used'"+  children <- scalarInt pool "SELECT count(*) FROM shomei.shomei_refresh_tokens WHERE parent_token_id IS NOT NULL"+  toks @?= 2+  used @?= 1+  children @?= 1++testWorkflowReuseRevokesFamily :: TestTree+testWorkflowReuseRevokesFamily = testCase "workflow: reuse revokes the family + session" $ withDb \pool -> do+  signupRes <- runApp pool (signup cfg (SignupCommand aliceLogin (Just aliceEmail) strongPw Nothing))+  (_, pair) <- expectApp signupRes >>= expectRight+  rotateRes <- runApp pool (refresh cfg (RefreshCommand pair.refreshToken))+  _ <- expectApp rotateRes >>= expectRight+  reuseRes <- runApp pool (refresh cfg (RefreshCommand pair.refreshToken))+  reuse <- expectApp reuseRes+  reuse @?= Left RefreshTokenReuseDetected+  revokedToks <- scalarInt pool "SELECT count(*) FROM shomei.shomei_refresh_tokens WHERE status = 'revoked'"+  totalToks <- scalarInt pool "SELECT count(*) FROM shomei.shomei_refresh_tokens"+  revokedSessions <- scalarInt pool "SELECT count(*) FROM shomei.shomei_sessions WHERE status = 'revoked'"+  assertBool "every refresh token in the family is revoked" (revokedToks == totalToks)+  revokedSessions @?= 1++testWorkflowAccountVerification :: TestTree+testWorkflowAccountVerification = testCase "workflow: account verification consumes token + marks user" $ withDb \pool -> do+  notifications <- newIORef []+  signupRes <- runAppWithNotifications notifications pool (signup cfg (SignupCommand aliceLogin (Just aliceEmail) strongPw Nothing))+  _ <- expectApp signupRes >>= expectRight+  requestRes <- runAppWithNotifications notifications pool (requestEmailVerification cfg (RequestEmailVerification aliceEmail))+  _ <- expectApp requestRes >>= expectRight+  raw <- latestVerificationToken =<< readIORef notifications+  confirmRes <- runAppWithNotifications notifications pool (confirmEmailVerification cfg (ConfirmEmailVerification raw))+  _ <- expectApp confirmRes >>= expectRight+  verified <- scalarInt pool "SELECT count(*) FROM shomei.shomei_users WHERE email_verified_at IS NOT NULL"+  consumed <- scalarInt pool "SELECT count(*) FROM shomei.shomei_email_verification_tokens WHERE status = 'consumed'"+  verified @?= 1+  consumed @?= 1++testWorkflowPasswordReset :: TestTree+testWorkflowPasswordReset = testCase "workflow: password reset changes password and revokes sessions" $ withDb \pool -> do+  notifications <- newIORef []+  signupRes <- runAppWithNotifications notifications pool (signup cfg (SignupCommand aliceLogin (Just aliceEmail) strongPw Nothing))+  (_, pair) <- expectApp signupRes >>= expectRight+  firstRequest <- runAppWithNotifications notifications pool (requestPasswordReset cfg (RequestPasswordReset aliceEmail))+  _ <- expectApp firstRequest >>= expectRight+  first <- latestResetToken =<< readIORef notifications+  secondRequest <- runAppWithNotifications notifications pool (requestPasswordReset cfg (RequestPasswordReset aliceEmail))+  _ <- expectApp secondRequest >>= expectRight+  second <- latestResetToken =<< readIORef notifications+  confirmRes <- runAppWithNotifications notifications pool (confirmPasswordReset cfg (ConfirmPasswordReset first (PlainPassword "correct horse battery staple two")))+  _ <- expectApp confirmRes >>= expectRight+  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")))+  _ <- expectApp loginRes >>= expectRight+  oldRefreshRes <- runAppWithNotifications notifications pool (refresh cfg (RefreshCommand pair.refreshToken))+  oldRefresh <- expectApp oldRefreshRes+  oldRefresh @?= Left Err.SessionRevoked+  consumed <- scalarInt pool "SELECT count(*) FROM shomei.shomei_password_reset_tokens WHERE status = 'consumed'"+  revokedReset <- scalarInt pool "SELECT count(*) FROM shomei.shomei_password_reset_tokens WHERE status = 'revoked'"+  revokedSessions <- scalarInt pool "SELECT count(*) FROM shomei.shomei_sessions WHERE status = 'revoked'"+  revokedRefresh <- scalarInt pool "SELECT count(*) FROM shomei.shomei_refresh_tokens WHERE status = 'revoked'"+  consumed @?= 1+  revokedReset @?= 1+  assertBool "existing sessions are revoked" (revokedSessions >= 1)+  assertBool "existing refresh tokens are revoked" (revokedRefresh >= 1)++testRevokeSessionIsCompareAndSwap :: TestTree+testRevokeSessionIsCompareAndSwap =+  testCase "session-scoped revoke unit of work publishes only for the CAS winner" $ withDb \pool -> do+    signupRes <- runApp pool (signup cfg (SignupCommand aliceLogin (Just aliceEmail) strongPw Nothing))+    (user, _) <- expectApp signupRes >>= expectRight+    sessionsRes <- runApp pool (listSessionsForUser user.userId)+    sessions <- expectApp sessionsRes+    sid <- case sessions of+      session : _ -> pure session.sessionId+      [] -> assertFailure "expected signup to create a session"+    result <- runApp pool do+      ts <- now+      let event = Event.SessionRevoked (Event.SessionRevokedData sid Nothing ts)+      first <- revokeSessionWithTokens sid ts [event]+      second <- revokeSessionWithTokens sid ts [event]+      pure (first, second)+    expectApp result >>= (@?= (True, False))+    revokedSessions <- scalarInt pool "SELECT count(*) FROM shomei.shomei_sessions WHERE status = 'revoked'"+    revokedTokens <- scalarInt pool "SELECT count(*) FROM shomei.shomei_refresh_tokens WHERE status = 'revoked'"+    revokeEvents <- scalarInt pool "SELECT count(*) FROM shomei.shomei_auth_events WHERE event_type = 'session_revoked'"+    revokedSessions @?= 1+    revokedTokens @?= 1+    revokeEvents @?= 1++testLoginAttemptStore :: TestTree+testLoginAttemptStore = testCase "login attempt store: record + windowed count + lockout upsert/clear" $ withDb \pool -> do+  let key = AccountKey "k-abc"+      ip = ClientIp "1.2.3.4"+  result <- runApp pool do+    t <- now+    let cutoff = addUTCTime (-900) t+        failure fromIp =+          NewLoginAttempt+            { accountKey = key,+              clientIp = fromIp,+              outcome = LoginFailure,+              occurredAt = t,+              factor = FactorTotp+            }+    _ <- recordLoginFailure (failure ip) cutoff Nothing+    _ <- recordLoginFailure (failure ip) cutoff Nothing+    _ <- recordLoginFailure (failure (ClientIp "9.9.9.9")) cutoff Nothing+    accFails <- countRecentFailuresByAccount key cutoff+    ipFails <- countRecentFailuresByIp ip cutoff+    future <- countRecentFailuresByAccount key (addUTCTime 3600 t)+    setAccountLockout (AccountLockout key 5 (Just (addUTCTime 900 t)) t)+    lo1 <- getAccountLockout key+    clearAccountLockout key+    lo2 <- getAccountLockout key+    pure (accFails, ipFails, future, lo1, lo2)+  (accFails, ipFails, future, lo1, lo2) <- expectApp result+  accFails @?= 3 -- all three failures share the account key+  ipFails @?= 2 -- only two came from 1.2.3.4+  future @?= 0 -- a cutoff in the future excludes everything+  fmap (.failedCount) lo1 @?= Just 5+  lo2 @?= Nothing++testLockoutRecordAndCountIsAtomicUnderRace :: TestTree+testLockoutRecordAndCountIsAtomicUnderRace =+  testCase "lockout: eight racing failures count 1..8 and lock once" $ withDb \pool -> do+    let key = AccountKey "race-key"+        ip = ClientIp "10.0.0.9"+        cutoff = addUTCTime (-900) t0+        policy = LockPolicy 5 (addUTCTime 900 t0)+        failure =+          NewLoginAttempt+            { accountKey = key,+              clientIp = ip,+              outcome = LoginFailure,+              occurredAt = t0,+              factor = FactorPassword+            }+    gate <- newEmptyMVar+    dones <- replicateM 8 do+      done <- newEmptyMVar+      _ <- forkIO do+        readMVar gate+        putMVar done =<< runApp pool (recordLoginFailure failure cutoff (Just policy))+      pure done+    putMVar gate ()+    outcomes <- traverse (\done -> expectApp =<< takeMVar done) dones+    sort (map (.failures) outcomes) @?= [1 .. 8]+    length (filter (.lockedNow) outcomes) @?= 1++testWorkflowLockout :: TestTree+testWorkflowLockout = testCase "workflow over PostgreSQL: lock-after-N then unlock-after-cooldown" $ withDb \pool -> do+  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"))+  _ <- runAppAtTime t0 pool badLogin >>= expectApp+  _ <- runAppAtTime t0 pool badLogin >>= expectApp+  r3 <- runAppAtTime t0 pool badLogin >>= expectApp+  r3 @?= Left InvalidCredentials+  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 @?= 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+  _ <- expectRight ok+  remaining <- scalarInt pool "SELECT count(*) FROM shomei.shomei_account_lockouts"+  remaining @?= 0++-- Passkey field accessors: OverloadedRecordDot is unreliable for these+-- DuplicateRecordFields records (MasterPlan 3 discovery), so read via record-pattern.+pkPasskeyId :: PasskeyCredential -> PasskeyId+pkPasskeyId PasskeyCredential {passkeyId} = passkeyId++pkSignCounter :: PasskeyCredential -> SignatureCounter+pkSignCounter PasskeyCredential {signCounter} = signCounter++pkLastUsedAt :: PasskeyCredential -> Maybe UTCTime+pkLastUsedAt PasskeyCredential {lastUsedAt} = lastUsedAt++pkTransports :: PasskeyCredential -> [Text]+pkTransports PasskeyCredential {transports} = transports++pkLabel :: PasskeyCredential -> Maybe Text+pkLabel PasskeyCredential {label} = label++-- | A 'NewPasskeyCredential' with canned bytes for the given user and time.+newPasskey :: User -> UTCTime -> NewPasskeyCredential+newPasskey u t =+  NewPasskeyCredential+    { userId = u.userId,+      credentialId = WebAuthnCredentialId "cred-1",+      userHandle = UserHandle "uh-1",+      publicKey = PublicKeyBytes "pk-1",+      signCounter = SignatureCounter 0,+      transports = ["usb", "nfc"],+      label = Just "key",+      createdAt = t+    }++-- | Field accessors for the EP-4 service-account record: 'DuplicateRecordFields' makes+-- @value.field@ unreliable here, as it does for the passkey record above.+saStatus :: ServiceAccount -> ServiceAccountStatus+saStatus ServiceAccount {status} = status++saSecretHash :: ServiceAccount -> Text+saSecretHash ServiceAccount {secretHash} = secretHash++saRotatedAt :: ServiceAccount -> Maybe UTCTime+saRotatedAt ServiceAccount {rotatedAt} = rotatedAt++saRevokedAt :: ServiceAccount -> Maybe UTCTime+saRevokedAt ServiceAccount {revokedAt} = revokedAt++saId :: ServiceAccount -> ServiceAccountDbId+saId ServiceAccount {serviceAccountId} = serviceAccountId++saAllowedScopes :: ServiceAccount -> Set.Set Scope+saAllowedScopes ServiceAccount {allowedScopes} = allowedScopes++-- | EP-4: the whole service-account lifecycle against real PostgreSQL — create, find by+-- client id, rotate the secret, revoke — mirroring the in-memory+-- 'Shomei.ServiceAccountStoreSpec'. Proves the jsonb @allowed_scopes@ round-trip, the+-- @status@ text encoding, and that a revoked row survives so the grant workflow can still+-- resolve (and refuse) it.+testServiceAccountRoundTrip :: TestTree+testServiceAccountRoundTrip =+  testCase "service accounts: create + find by client id + rotate + revoke" $ withDb \pool -> do+    result <- runApp pool do+      u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})+      t <- now+      said <- genServiceAccountDbId+      let scopes = Set.fromList [Scope "kawa:ingest", Scope "signal:raise"]+      created <-+        createServiceAccount+          NewServiceAccount+            { serviceAccountId = said,+              clientId = idText said,+              userId = u.userId,+              secretHash = "hash-one",+              displayName = "rei connector",+              allowedScopes = scopes,+              createdAt = t+            }+      afterCreate <- findServiceAccountByClientId (idText said)+      listed <- listServiceAccounts+      rotateServiceAccountSecret said "hash-two" t+      afterRotate <- findServiceAccountByClientId (idText said)+      revokeServiceAccount said t+      afterRevoke <- findServiceAccountByClientId (idText said)+      pure (created, afterCreate, listed, afterRotate, afterRevoke, scopes)+    (created, afterCreate, listed, afterRotate, afterRevoke, scopes) <- expectApp result+    -- a fresh account is active with no rotation/revocation stamps+    saStatus created @?= ServiceAccountActive+    saRotatedAt created @?= Nothing+    -- the lookup by client id resolves, and the jsonb scope set survived the round trip+    fmap saId afterCreate @?= Just (saId created)+    fmap saAllowedScopes afterCreate @?= Just scopes+    map saId listed @?= [saId created]+    -- rotation swaps the hash and stamps rotated_at, without revoking+    fmap saSecretHash afterRotate @?= Just "hash-two"+    assertBool "rotated_at is stamped" (maybe False (isJust . saRotatedAt) afterRotate)+    fmap saStatus afterRotate @?= Just ServiceAccountActive+    -- revocation flips status and stamps revoked_at; the ROW SURVIVES so the lookup still resolves+    fmap saStatus afterRevoke @?= Just ServiceAccountRevoked+    assertBool "revoked_at is stamped" (maybe False (isJust . saRevokedAt) afterRevoke)+    n <- scalarInt pool "SELECT count(*) FROM shomei.shomei_service_accounts"+    n @?= 1++-- Field accessors: 'OAuthClient' shares field names with 'ServiceAccount' and 'User', so read+-- it by record pattern (the MasterPlan-3 DuplicateRecordFields caution).++ocStatus :: OAuthClient -> OAuthClientStatus+ocStatus OAuthClient {status} = status++ocSecretHash :: OAuthClient -> Maybe Text+ocSecretHash OAuthClient {secretHash} = secretHash++ocRevokedAt :: OAuthClient -> Maybe UTCTime+ocRevokedAt OAuthClient {revokedAt} = revokedAt++ocId :: OAuthClient -> OAuthClientId+ocId OAuthClient {oauthClientId} = oauthClientId++ocClientType :: OAuthClient -> ClientType+ocClientType OAuthClient {clientType} = clientType++ocRedirectUris :: OAuthClient -> [Text]+ocRedirectUris OAuthClient {redirectUris} = redirectUris++ocAllowedScopes :: OAuthClient -> Set.Set Scope+ocAllowedScopes OAuthClient {allowedScopes} = allowedScopes++-- | EP-5: the OAuth-client lifecycle against real PostgreSQL — create (confidential and public),+-- find by client id, list, revoke — mirroring the in-memory 'Shomei.OAuthClientStoreSpec'.+--+-- Proves the two jsonb round-trips (@redirect_uris@ as an ordered array, @allowed_scopes@ as a+-- set), the @client_type@ and @status@ text encodings, that a public client's @secret_hash@ is a+-- real SQL NULL rather than an empty string, and that a revoked row survives so the authorize+-- endpoint can resolve (and refuse) it.+testOAuthClientRoundTrip :: TestTree+testOAuthClientRoundTrip =+  testCase "oauth clients: create confidential + public, find, list, revoke" $ withDb \pool -> do+    result <- runApp pool do+      t <- now+      confId <- genOAuthClientId+      pubId <- genOAuthClientId+      let scopes = Set.fromList [Scope "openid", Scope "profile"]+          uris = ["https://app.example.com/callback", "https://app.example.com/other"]+      confidential <-+        createOAuthClient+          NewOAuthClient+            { oauthClientId = confId,+              clientId = idText confId,+              secretHash = Just "hash-one",+              clientType = ConfidentialClient,+              displayName = "grafana",+              redirectUris = uris,+              allowedScopes = scopes,+              createdAt = t+            }+      public <-+        createOAuthClient+          NewOAuthClient+            { oauthClientId = pubId,+              clientId = idText pubId,+              secretHash = Nothing,+              clientType = PublicClient,+              displayName = "spa",+              redirectUris = ["https://spa.example.com/cb"],+              allowedScopes = Set.singleton (Scope "openid"),+              createdAt = t+            }+      afterCreate <- findOAuthClientByClientId (idText confId)+      foundPublic <- findOAuthClientByClientId (idText pubId)+      listed <- listOAuthClients+      revokeOAuthClient confId t+      afterRevoke <- findOAuthClientByClientId (idText confId)+      pure (confidential, public, afterCreate, foundPublic, listed, afterRevoke, scopes, uris)+    (confidential, public, afterCreate, foundPublic, listed, afterRevoke, scopes, uris) <- expectApp result+    -- a fresh client is active and unrevoked+    ocStatus confidential @?= OAuthClientActive+    ocRevokedAt confidential @?= Nothing+    ocClientType public @?= PublicClient+    -- the lookup resolves, and both jsonb columns survived the round trip (uris keep their order)+    fmap ocId afterCreate @?= Just (ocId confidential)+    fmap ocAllowedScopes afterCreate @?= Just scopes+    fmap ocRedirectUris afterCreate @?= Just uris+    fmap ocSecretHash afterCreate @?= Just (Just "hash-one")+    -- a public client's secret_hash is a real NULL+    fmap ocSecretHash foundPublic @?= Just Nothing+    fmap ocClientType foundPublic @?= Just PublicClient+    length listed @?= 2+    -- revocation flips status and stamps revoked_at; the ROW SURVIVES so the lookup still resolves+    fmap ocStatus afterRevoke @?= Just OAuthClientRevoked+    assertBool "revoked_at is stamped" (maybe False (isJust . ocRevokedAt) afterRevoke)+    nullSecrets <- scalarInt pool "SELECT count(*) FROM shomei.shomei_oauth_clients WHERE secret_hash IS NULL"+    nullSecrets @?= 1++-- | EP-5: the authorization-code lifecycle against real PostgreSQL — store, consume once, replay,+-- expiry, and the batched sweep — mirroring the in-memory 'Shomei.OAuthCodeStoreSpec'.+testAuthorizationCodeRoundTrip :: TestTree+testAuthorizationCodeRoundTrip =+  testCase "authorization codes: consume once, replay misses, expiry misses" $ withDb \pool -> do+    result <- runApp pool do+      u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})+      t <- now+      let scopes = Set.fromList [Scope "openid", Scope "profile"]+          mk h expiresAt =+            NewAuthorizationCode+              { codeHash = h,+                clientId = "oauthclient_x",+                redirectUri = "https://app.example.com/callback",+                userId = u.userId,+                scopes,+                nonce = Just "n-0S6",+                codeChallenge = Just (Text.replicate 43 "a"),+                authTime = t,+                createdAt = t,+                expiresAt+              }+      putAuthorizationCode (mk "hash-live" (addUTCTime 60 t))+      putAuthorizationCode (mk "hash-expired" (addUTCTime 60 t))+      first' <- consumeAuthorizationCode "hash-live" t+      sid <- genSessionId+      bindAuthorizationCodeSession "hash-live" sid+      bound <- findConsumedAuthorizationCode "hash-live" t+      replay <- consumeAuthorizationCode "hash-live" t+      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+    -- 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"+      Just c -> do+        c.clientId @?= "oauthclient_x"+        c.redirectUri @?= "https://app.example.com/callback"+        c.scopes @?= scopes+        c.nonce @?= Just "n-0S6"+        c.codeChallenge @?= Just (Text.replicate 43 "a")+        assertBool "consumed_at is stamped" (isJust c.consumedAt)+        c.sessionId @?= Nothing+    fmap (.sessionId) bound @?= Just (Just sid)+    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.+    remaining <- scalarInt pool "SELECT count(*) FROM shomei.shomei_oauth_authorization_codes"+    remaining @?= 0++-- | The property the single-statement `UPDATE … WHERE consumed_at IS NULL … RETURNING` exists for:+-- two exchanges of the same code, racing on separate connections, and __exactly one wins__.+--+-- A read-then-write implementation passes every sequential test above and fails this one, handing+-- two clients a token from one code.+testAuthorizationCodeConsumeIsAtomicUnderRace :: TestTree+testAuthorizationCodeConsumeIsAtomicUnderRace =+  testCase "authorization codes: two racing consumes, exactly one winner" $ withDb \pool -> do+    seeded <- runApp pool do+      u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})+      t <- now+      putAuthorizationCode+        NewAuthorizationCode+          { codeHash = "hash-raced",+            clientId = "oauthclient_x",+            redirectUri = "https://app.example.com/callback",+            userId = u.userId,+            scopes = Set.singleton (Scope "openid"),+            nonce = Nothing,+            codeChallenge = Nothing,+            authTime = t,+            createdAt = t,+            expiresAt = addUTCTime 60 t+          }+      pure t+    t <- expectApp seeded++    -- A start gate, so the contenders reach the UPDATE together rather than one after another.+    -- Without it the two threads would very likely serialize and the case would pass even against+    -- a read-then-write implementation. Even so this race is opportunistic: what actually+    -- guarantees the property is that the consume is ONE statement.+    gate <- newEmptyMVar+    dones <- replicateM 8 do+      done <- newEmptyMVar+      _ <- forkIO do+        readMVar gate+        putMVar done =<< runApp pool (consumeAuthorizationCode "hash-raced" t)+      pure done+    putMVar gate ()+    results <- traverse (\d -> expectApp =<< takeMVar d) dones+    length (filter isJust results) @?= 1++    consumedRows <- scalarInt pool "SELECT count(*) FROM shomei.shomei_oauth_authorization_codes WHERE consumed_at IS NOT NULL"+    consumedRows @?= 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)+    byUser <- findPasskeysByUser u.userId+    byCred <- findPasskeyByCredentialId (WebAuthnCredentialId "cred-1")+    byHandle <- findPasskeysByUserHandle (UserHandle "uh-1")+    pure (created, byUser, byCred, byHandle)+  (created, byUser, byCred, byHandle) <- expectApp result+  -- all three lookups resolve to the created passkey+  map pkPasskeyId byUser @?= [pkPasskeyId created]+  fmap pkPasskeyId byCred @?= Just (pkPasskeyId created)+  map pkPasskeyId byHandle @?= [pkPasskeyId created]+  -- the jsonb transports + bigint counter + label survived the round trip+  fmap pkTransports byCred @?= Just ["usb", "nfc"]+  fmap pkLabel byCred @?= Just (Just "key")+  fmap pkSignCounter byCred @?= Just (SignatureCounter 0)+  n <- scalarInt pool "SELECT count(*) FROM shomei.shomei_webauthn_credentials"+  n @?= 1++testPasskeyUpdateCountDelete :: TestTree+testPasskeyUpdateCountDelete = testCase "passkey store: update sign counter + count + delete (user-scoped)" $ withDb \pool -> do+  result <- runApp pool do+    u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})+    t <- now+    created <- createPasskey (newPasskey u t)+    let pid = pkPasskeyId created+    counterAdvanced <- updatePasskeySignCounter pid (SignatureCounter 42) t+    afterUpdate <- findPasskeyByCredentialId (WebAuthnCredentialId "cred-1")+    cnt <- countPasskeysByUser u.userId+    otherUid <- genUserId+    deletePasskey otherUid pid -- wrong user: must NOT delete+    pure (counterAdvanced, afterUpdate, cnt, u.userId, pid)+  (counterAdvanced, afterUpdate, cnt, uid, pid) <- expectApp result+  counterAdvanced @?= True+  fmap pkSignCounter afterUpdate @?= Just (SignatureCounter 42)+  assertBool "last_used_at is populated after the counter bump" (maybe False (isJust . pkLastUsedAt) afterUpdate)+  cnt @?= 1+  afterWrongUser <- scalarInt pool "SELECT count(*) FROM shomei.shomei_webauthn_credentials"+  afterWrongUser @?= 1 -- wrong-user delete left it+  _ <- runApp pool (deletePasskey uid pid) >>= expectApp+  afterOwner <- scalarInt pool "SELECT count(*) FROM shomei.shomei_webauthn_credentials"+  afterOwner @?= 0 -- owner delete removed it++testPasskeyCounterIsCompareAndSwap :: TestTree+testPasskeyCounterIsCompareAndSwap =+  testCase "passkey counter advances atomically and preserves counterless authenticators" $ withDb \pool -> do+    result <- runApp pool do+      u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})+      t <- now+      created <- createPasskey (newPasskey u t)+      let pid = pkPasskeyId created+      zeroToZero <- updatePasskeySignCounter pid (SignatureCounter 0) t+      first <- updatePasskeySignCounter pid (SignatureCounter 42) t+      zeroAfterNonzero <- updatePasskeySignCounter pid (SignatureCounter 0) t+      same <- updatePasskeySignCounter pid (SignatureCounter 42) t+      older <- updatePasskeySignCounter pid (SignatureCounter 41) t+      newer <- updatePasskeySignCounter pid (SignatureCounter 43) t+      stored <- findPasskeyByCredentialId (WebAuthnCredentialId "cred-1")+      pure (zeroToZero, first, zeroAfterNonzero, same, older, newer, stored)+    (zeroToZero, first, zeroAfterNonzero, same, older, newer, stored) <- expectApp result+    (zeroToZero, first, zeroAfterNonzero, same, older, newer)+      @?= (True, True, False, False, False, True)+    fmap pkSignCounter stored @?= Just (SignatureCounter 43)++testPasskeyCounterCasUnderRace :: TestTree+testPasskeyCounterCasUnderRace =+  testCase "passkey counter: eight racing nonzero updates have one winner" $ withDb \pool -> do+    seeded <- runApp pool do+      u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})+      t <- now+      created <- createPasskey (newPasskey u t)+      pure (pkPasskeyId created, t)+    (pid, t) <- expectApp seeded+    gate <- newEmptyMVar+    dones <- replicateM 8 do+      done <- newEmptyMVar+      _ <- forkIO do+        readMVar gate+        putMVar done =<< runApp pool (updatePasskeySignCounter pid (SignatureCounter 42) t)+      pure done+    putMVar gate ()+    results <- traverse (\done -> expectApp =<< takeMVar done) dones+    length (filter id results) @?= 1++testPendingCeremonyConsumeOnce :: TestTree+testPendingCeremonyConsumeOnce = testCase "pending ceremony store: put then take consumes exactly once" $ withDb \pool -> do+  result <- runApp pool do+    cid <- genCeremonyId+    t <- now+    putPendingCeremony+      PendingCeremony+        { ceremonyId = cid,+          userId = Nothing,+          kind = RegistrationCeremony,+          optionsBlob = "{\"challenge\":\"abc\"}",+          createdAt = t,+          expiresAt = addUTCTime 300 t+        }+    first <- takePendingCeremony cid t+    pure (cid, t, first)+  (cid, t, first) <- expectApp result+  assertBool "first take returns the ceremony" (isJust first)+  afterFirst <- scalarInt pool "SELECT count(*) FROM shomei.shomei_webauthn_pending_ceremonies"+  afterFirst @?= 0 -- DELETE ... RETURNING removed it+  second <- runApp pool (takePendingCeremony cid t) >>= expectApp+  second @?= (Nothing :: Maybe PendingCeremony)++testPendingCeremonyExpired :: TestTree+testPendingCeremonyExpired = testCase "pending ceremony store: expired ceremony is not returned" $ withDb \pool -> do+  result <- runApp pool do+    cid <- genCeremonyId+    t <- now+    putPendingCeremony+      PendingCeremony+        { ceremonyId = cid,+          userId = Nothing,+          kind = AuthenticationCeremony,+          optionsBlob = "{\"challenge\":\"xyz\"}",+          createdAt = t,+          expiresAt = t -- expires immediately+        }+    -- "now" is past expiry: returns Nothing but still removes the stale row+    takePendingCeremony cid (addUTCTime 1 t)+  taken <- expectApp result+  taken @?= (Nothing :: Maybe PendingCeremony)+  remaining <- scalarInt pool "SELECT count(*) FROM shomei.shomei_webauthn_pending_ceremonies"+  remaining @?= 0++-- Argon2 parameters ----------------------------------------------------------++-- | Cheap parameters, so the parameter tests do not each pay the ~100 ms production cost.+cheapParams :: Argon2Params+cheapParams = Argon2Params {memoryKiB = 8192, iterations = 1, parallelism = 1}++testArgon2NewHashesArePhcFormatted :: TestTree+testArgon2NewHashesArePhcFormatted =+  testCase "argon2: new hashes are PHC-formatted and verify" do+    PasswordHash stored <- hashPasswordArgon2id defaultArgon2Params "hunter2"+    assertBool+      ("expected a PHC prefix carrying the default params, got " <> Text.unpack stored)+      ("$argon2id$v=19$m=65536,t=3,p=1$" `Text.isPrefixOf` stored)+    verifyPasswordArgon2id "hunter2" (PasswordHash stored) @?= True+    verifyPasswordArgon2id "wrong" (PasswordHash stored) @?= False++testArgon2RejectsUnparameterizedHashes :: TestTree+testArgon2RejectsUnparameterizedHashes =+  testCase "argon2: an unparameterized three-part hash is rejected" do+    let unparameterized =+          PasswordHash "argon2id$4gw0llx5tfM4Dfi23hUsTA==$8zWIeRIFVtmuSuMdAv4MW13Fsw1BCjfREVf4eaHwp+I="+    verifyPasswordArgon2id "correct horse battery staple" unparameterized @?= False++testArgon2ParamsChangeLeavesOldHashesVerifiable :: TestTree+testArgon2ParamsChangeLeavesOldHashesVerifiable =+  testCase "argon2: changing params leaves old hashes verifiable" do+    -- A hash made with the defaults, and one made with different params, coexist.+    defaultHash <- hashPasswordArgon2id defaultArgon2Params "hunter2"+    cheapHash <- hashPasswordArgon2id cheapParams "hunter2"+    assertBool "the two hashes differ" (defaultHash /= cheapHash)++    -- Each verifies with the parameters IT carries, not with any ambient configuration.+    verifyPasswordArgon2id "hunter2" defaultHash @?= True+    verifyPasswordArgon2id "hunter2" cheapHash @?= True++testArgon2MalformedHashesVerifyFalse :: TestTree+testArgon2MalformedHashesVerifyFalse =+  testCase "argon2: malformed hashes verify False without crashing" do+    let malformed =+          [ "$argon2id$v=19$m=notanumber,t=3,p=1$AAAAAAAAAAAAAAAAAAAAAA==$AAAA",+            "$argon2id$v=99$m=65536,t=3,p=1$AAAAAAAAAAAAAAAAAAAAAA==$AAAA",+            "$argon2id$v=19$m=65536,t=3$AAAAAAAAAAAAAAAAAAAAAA==$AAAA",+            "$argon2id$v=19$m=0,t=3,p=1$AAAAAAAAAAAAAAAAAAAAAA==$AAAA",+            "$argon2i$v=19$m=65536,t=3,p=1$AAAAAAAAAAAAAAAAAAAAAA==$AAAA",+            "not-a-hash",+            ""+          ]+    forM_ malformed \h ->+      assertBool+        ("expected False for " <> Text.unpack h)+        (not (verifyPasswordArgon2id "hunter2" (PasswordHash h)))++-- | The login timing oracle, at the level where it is actually created.+--+-- A login that never reaches a stored hash burns 'dummyHashFor' instead. That must cost what+-- verifying a real hash costs, or response time reveals whether an account exists. This is+-- asserted structurally — same embedded parameters — rather than with a stopwatch, because+-- equal parameters mean equal Argon2 work by construction, and a wall-clock assertion would+-- be flaky. ('Shomei.Session.Authentication.TimingSpec' asserts the complementary property: that every+-- login path performs exactly one such operation.)+testArgon2DummyHashTracksConfiguredParams :: TestTree+testArgon2DummyHashTracksConfiguredParams =+  testCase "argon2: the dummy hash carries the configured params, so a miss costs what a hit costs" do+    forM_ [defaultArgon2Params, cheapParams, Argon2Params 19456 2 1] \params -> do+      real <- hashPasswordArgon2id params "hunter2"+      let dummy = dummyHashFor params+      assertEqual+        ("the dummy must derive with the same params as a real hash, for " <> show params)+        (costFields real)+        (costFields dummy)+      -- It must be well-formed: a malformed dummy would return False WITHOUT hashing (~9 µs+      -- versus ~100 ms), silently reopening the oracle it exists to close. Verifying against+      -- it does full Argon2 work and then fails the comparison, which is exactly the point.+      verifyPasswordArgon2id "hunter2" dummy @?= False+  where+    -- The version and parameter fields of a PHC string: everything that decides the cost.+    costFields (PasswordHash t) = case Text.splitOn "$" t of+      ("" : "argon2id" : version : params : _) -> Just (version, params)+      _ -> Nothing++testArgon2HardFloorMatchesTheImplementation :: TestTree+testArgon2HardFloorMatchesTheImplementation =+  testCase "argon2: the boot hard floor matches the implementation" do+    let rejected = Argon2Params 64 1 16+        boundary = Argon2Params 128 1 16+    assertBool "m=64,p=16 must be below the hard floor" (isJust (argon2HardFloor rejected))+    trialArgon2Derivation rejected >>= assertBool "the implementation must reject m=64,p=16" . isLeft+    argon2HardFloor boundary @?= Nothing+    trialArgon2Derivation boundary >>= \case+      Right () -> pure ()+      Left failure -> assertFailure ("the hard-floor boundary must derive: " <> show failure)++-- Hashing limiter -------------------------------------------------------------++-- | At most @limit@ Argon2 derivations may run at once, no matter how many requests arrive.+--+-- Sixteen threads race for permits. Each holds its permit for a fixed 25 ms before hashing, so+-- the first @limit@ of them are provably in flight together and the high-water mark reaches+-- @limit@ exactly. The assertion that matters is @peak <= limit@ — that is the bound; the+-- @peak == limit@ half only confirms the test actually saturated the gate rather than+-- trivially passing.+testHashingLimiterBoundsConcurrency :: Int -> TestTree+testHashingLimiterBoundsConcurrency limit =+  testCase ("hashing limiter: peak concurrency never exceeds the limit (" <> show limit <> ")") do+    limiter <- newHashingLimiter limit+    dones <- replicateM 16 newEmptyMVar+    forM_ (zip [1 :: Int ..] dones) \(i, done) ->+      void $ forkIO do+        h <- withHashingPermit limiter do+          threadDelay 25_000+          hashPasswordArgon2id cheapParams ("pw" <> Text.pack (show i))+        putMVar done (i, h)+    results <- mapM takeMVar dones++    forM_ results \(_, h) -> do+      let PasswordHash phc = h+      void (evaluate (Text.length phc))++    peak <- peakHashingConcurrency limiter+    assertBool ("peak " <> show peak <> " exceeded the limit " <> show limit) (peak <= limit)+    assertEqual "the test must saturate the gate, or it proves nothing" limit peak++    -- Every hash is real and verifies: the gate serializes work, it does not corrupt it.+    forM_ results \(i, h) ->+      assertBool+        ("hash " <> show i <> " must verify")+        (verifyPasswordArgon2id ("pw" <> Text.pack (show i)) h)++-- | The bound must hold through the effect interpreter, not merely around 'withHashingPermit'.+-- A refactor that dropped the bracket from 'runPasswordHasherCrypto' would leave the previous+-- test green and the server unbounded.+testInterpreterForcesTheHashInsideThePermit :: TestTree+testInterpreterForcesTheHashInsideThePermit =+  testCase "hashing limiter: the interpreter forces HashPassword inside its permit" do+    limiter <- newHashingLimiter 1+    dones <- replicateM 8 newEmptyMVar+    forM_ (zip [1 :: Int ..] dones) \(i, done) ->+      void $ forkIO do+        h <-+          runEff+            . runPasswordHasherCrypto limiter cheapParams+            $ hashPassword (PlainPassword ("pw" <> Text.pack (show i)))+        forceStart <- getMonotonicTimeNSec+        let PasswordHash phc = h+        _ <- evaluate (Text.length phc)+        forceEnd <- getMonotonicTimeNSec+        putMVar done (i, h, forceStart, forceEnd)+    results <- mapM takeMVar dones+    peak <- peakHashingConcurrency limiter+    assertBool "the interpreter never acquired a permit" (peak >= 1)+    assertBool ("interpreter allowed " <> show peak <> " concurrent hashes") (peak <= 1)++    let windows = [(forceStart, forceEnd) | (_, _, forceStart, forceEnd) <- results]+        overlap (a0, a1) (b0, b1) = a0 < b1 && b0 < a1+    caps <- getNumCapabilities+    when (caps >= 2) $+      forM_ [(a, b) | a : rest <- tails windows, b <- rest] \(a, b) ->+        assertBool ("post-return forcing windows overlap: " <> show (a, b)) (not (overlap a b))++    -- Capability-independent half: one cheap derivation sets the bar on this machine.+    w0 <- getMonotonicTimeNSec+    _ <- hashPasswordArgon2id cheapParams "warm"+    w1 <- getMonotonicTimeNSec+    forM_ results \(i, h, forceStart, forceEnd) -> do+      assertBool+        ("hash " <> show i <> " was forced after the interpreter returned")+        ((forceEnd - forceStart) * 2 < (w1 - w0))+      assertBool+        ("hash " <> show i <> " must verify")+        (verifyPasswordArgon2id ("pw" <> Text.pack (show i)) h)++-- | A verification of a *dummy* hash also takes a permit — the miss path must be bounded+-- exactly like the hit path, or a flood of logins for nonexistent accounts bypasses the gate.+testDummyVerificationTakesAPermit :: TestTree+testDummyVerificationTakesAPermit =+  testCase "hashing limiter: the dummy verification path is bounded too" do+    limiter <- newHashingLimiter 1+    dones <- replicateM 4 newEmptyMVar+    forM_ dones \done ->+      void $ forkIO do+        runEff . runPasswordHasherCrypto limiter cheapParams $ verifyPasswordDummy (PlainPassword "pw")+        putMVar done ()+    _ <- mapM takeMVar dones+    peak <- peakHashingConcurrency limiter+    peak @?= 1++-- Maintenance sweep ----------------------------------------------------------++-- | A database with one row on each side of every sweep cutoff.+--+-- Ages are expressed relative to the database's @now()@; 'sweepOnce' is handed Haskell's+-- 'getCurrentTime'. The two clocks differ by milliseconds while every offset here is hours or+-- days, so no row sits near a boundary.+--+-- Three sessions: one expired 40 days ago (dead by @expires_at@, holding a three-token+-- rotation family so the sweep must respect @parent_token_id@'s self-referencing foreign+-- key); one revoked 40 days ago but with a far-future @expires_at@ (dead only by the+-- @revoked_at@ branch of the sweep's OR predicate); and one live session that must survive+-- with both of its tokens.+seedSweepFixture :: Pool -> IO ()+seedSweepFixture pool =+  execSql+    pool+    """+    INSERT INTO shomei.shomei_users (user_id, email, display_name, status, created_at, updated_at, login_id) VALUES+      ('11111111-1111-1111-1111-111111111111', 'sweep1@example.com', 'Sweep One', 'active', now() - interval '90 days', now(), 'sweep1@example.com'),+      ('22222222-2222-2222-2222-222222222222', 'sweep2@example.com', 'Sweep Two', 'active', now() - interval '90 days', now(), 'sweep2@example.com');++    INSERT INTO shomei.shomei_sessions (session_id, user_id, status, created_at, expires_at, revoked_at) VALUES+      ('aaaaaaaa-0000-0000-0000-000000000001', '11111111-1111-1111-1111-111111111111', 'active',  now() - interval '60 days', now() - interval '40 days', NULL),+      ('aaaaaaaa-0000-0000-0000-000000000002', '11111111-1111-1111-1111-111111111111', 'revoked', now() - interval '60 days', now() + interval '30 days', now() - interval '40 days'),+      ('aaaaaaaa-0000-0000-0000-000000000003', '22222222-2222-2222-2222-222222222222', 'active',  now() - interval '1 day',   now() + interval '30 days', NULL);++    -- A three-generation rotation family on the expired session, then a single token on the+    -- revoked one, then two live tokens that must survive.+    INSERT INTO shomei.shomei_refresh_tokens+      (refresh_token_id, session_id, token_hash, parent_token_id, status, created_at, expires_at, used_at, revoked_at) VALUES+      ('bbbbbbbb-0000-0000-0000-000000000001', 'aaaaaaaa-0000-0000-0000-000000000001', 'hash-dead-1', NULL,                                   'used',   now() - interval '60 days', now() - interval '40 days', now() - interval '59 days', NULL),+      ('bbbbbbbb-0000-0000-0000-000000000002', 'aaaaaaaa-0000-0000-0000-000000000001', 'hash-dead-2', 'bbbbbbbb-0000-0000-0000-000000000001', 'used',   now() - interval '59 days', now() - interval '40 days', now() - interval '58 days', NULL),+      ('bbbbbbbb-0000-0000-0000-000000000003', 'aaaaaaaa-0000-0000-0000-000000000001', 'hash-dead-3', 'bbbbbbbb-0000-0000-0000-000000000002', 'active', now() - interval '58 days', now() - interval '40 days', NULL, NULL),+      ('bbbbbbbb-0000-0000-0000-000000000011', 'aaaaaaaa-0000-0000-0000-000000000002', 'hash-revk-1', NULL,                                   'revoked', now() - interval '60 days', now() + interval '30 days', NULL, now() - interval '40 days'),+      ('cccccccc-0000-0000-0000-000000000001', 'aaaaaaaa-0000-0000-0000-000000000003', 'hash-live-1', NULL,                                   'used',   now() - interval '1 day', now() + interval '30 days', now() - interval '1 hour', NULL),+      ('cccccccc-0000-0000-0000-000000000002', 'aaaaaaaa-0000-0000-0000-000000000003', 'hash-live-2', 'cccccccc-0000-0000-0000-000000000001', 'active', now() - interval '1 hour', now() + interval '30 days', NULL, NULL);++    -- One expired past the 7-day grace, one still live.+    INSERT INTO shomei.shomei_email_verification_tokens+      (verification_token_id, user_id, token_hash, status, created_at, expires_at, consumed_at, revoked_at) VALUES+      ('dddddddd-0000-0000-0000-000000000001', '11111111-1111-1111-1111-111111111111', 'vhash-old', 'active', now() - interval '11 days', now() - interval '10 days', NULL, NULL),+      ('dddddddd-0000-0000-0000-000000000002', '11111111-1111-1111-1111-111111111111', 'vhash-new', 'active', now(), now() + interval '1 day', NULL, NULL);++    INSERT INTO shomei.shomei_password_reset_tokens+      (password_reset_token_id, user_id, token_hash, status, created_at, expires_at, consumed_at, revoked_at) VALUES+      ('eeeeeeee-0000-0000-0000-000000000001', '11111111-1111-1111-1111-111111111111', 'phash-old', 'active', now() - interval '11 days', now() - interval '10 days', NULL, NULL),+      ('eeeeeeee-0000-0000-0000-000000000002', '11111111-1111-1111-1111-111111111111', 'phash-new', 'active', now(), now() + interval '1 day', NULL, NULL);++    -- Expired 2 hours ago (past the 60-minute grace); expired 30 minutes ago (inside it); live.+    INSERT INTO shomei.shomei_webauthn_pending_ceremonies (ceremony_id, user_id, kind, options_blob, created_at, expires_at) VALUES+      ('ffffffff-0000-0000-0000-000000000001', NULL, 'authentication', '\\x00'::bytea, now() - interval '3 hours',  now() - interval '2 hours'),+      ('ffffffff-0000-0000-0000-000000000002', NULL, 'authentication', '\\x00'::bytea, now() - interval '90 minutes', now() - interval '30 minutes'),+      ('ffffffff-0000-0000-0000-000000000003', NULL, 'registration',   '\\x00'::bytea, now(), now() + interval '1 hour');++    -- Elapsed past the 7-day grace; elapsed yesterday (inside it); not locked at all.+    INSERT INTO shomei.shomei_account_lockouts (account_key, failed_count, locked_until, updated_at) VALUES+      ('lockout-elapsed', 5, now() - interval '10 days', now() - interval '10 days'),+      ('lockout-recent',  5, now() - interval '1 day',   now() - interval '1 day'),+      ('lockout-counting', 2, NULL, now());++    -- EP-5 authorization codes: expired 2 hours ago (past the 60-minute ceremony grace, which+    -- these share); expired 30 minutes ago (inside it); live. The consumed-but-expired one goes+    -- too -- a consumed code is already unusable, so keeping it past expiry buys nothing.+    INSERT INTO shomei.shomei_oauth_authorization_codes+      (code_hash, client_id, user_id, redirect_uri, scopes, nonce, code_challenge, auth_time, created_at, expires_at, consumed_at) VALUES+      ('codehash-old',      'oauthclient_x', '11111111-1111-1111-1111-111111111111', 'https://app.test/cb', '["openid"]'::jsonb, NULL, NULL, now() - interval '3 hours',  now() - interval '3 hours',  now() - interval '2 hours',  NULL),+      ('codehash-consumed', 'oauthclient_x', '11111111-1111-1111-1111-111111111111', 'https://app.test/cb', '["openid"]'::jsonb, NULL, NULL, now() - interval '3 hours',  now() - interval '3 hours',  now() - interval '2 hours',  now() - interval '2 hours'),+      ('codehash-recent',   'oauthclient_x', '11111111-1111-1111-1111-111111111111', 'https://app.test/cb', '["openid"]'::jsonb, NULL, NULL, now() - interval '90 minutes', now() - interval '90 minutes', now() - interval '30 minutes', NULL),+      ('codehash-live',     'oauthclient_x', '11111111-1111-1111-1111-111111111111', 'https://app.test/cb', '["openid"]'::jsonb, NULL, NULL, now(), now(), now() + interval '1 minute', NULL);++    -- Past the 90-day retention window; inside it.+    INSERT INTO shomei.shomei_login_attempts (attempt_id, account_key, client_ip, outcome, occurred_at) VALUES+      ('99999999-0000-0000-0000-000000000001', 'acct', '10.0.0.1', 'failure', now() - interval '100 days'),+      ('99999999-0000-0000-0000-000000000002', 'acct', '10.0.0.1', 'failure', now() - interval '10 days');++    -- Audit events are retained forever by default; the 400-day-old one only goes when an+    -- explicit retention window is configured.+    INSERT INTO shomei.shomei_auth_events (event_id, user_id, session_id, event_type, payload, created_at) VALUES+      ('88888888-0000-0000-0000-000000000001', NULL, NULL, 'login_succeeded', '{}'::jsonb, now() - interval '400 days'),+      ('88888888-0000-0000-0000-000000000002', NULL, NULL, 'login_succeeded', '{}'::jsonb, now());++    -- EP-9 time-bound role grants: one expired past the 7-day grace (swept), one expired inside+    -- it (kept), and one forever grant with a NULL expiry (never swept). 'admin' is seeded by the+    -- migration; a second role is defined here so both live grants can hang off one user.+    INSERT INTO shomei.shomei_roles (role, description, created_at) VALUES+      ('auditor', 'sweep fixture role', now()) ON CONFLICT (role) DO NOTHING;+    INSERT INTO shomei.shomei_role_grants (user_id, role, granted_by, granted_at, expires_at) VALUES+      ('11111111-1111-1111-1111-111111111111', 'admin',   NULL, now() - interval '60 days', now() - interval '10 days'),+      ('22222222-2222-2222-2222-222222222222', 'admin',   NULL, now() - interval '60 days', now() - interval '1 day'),+      ('11111111-1111-1111-1111-111111111111', 'auditor', NULL, now() - interval '60 days', NULL);+    """++testSweepDeletesExpiredRows :: TestTree+testSweepDeletesExpiredRows =+  testCase "maintenance sweep: deletes exactly the expired rows and spares the rest" $ withDb \pool -> do+    seedSweepFixture pool+    t <- getCurrentTime+    report <- sweepOnce pool defaultSweepConfig t >>= expectSweep+    report+      @?= SweepReport+        { -- three from the expired session's rotation family, one from the revoked session+          refreshTokensDeleted = 4,+          -- the expired one and the revoked one; the live session stays+          sessionsDeleted = 2,+          verificationTokensDeleted = 1,+          resetTokensDeleted = 1,+          ceremoniesDeleted = 1,+          -- the two that expired past the grace window (one of them already consumed); the+          -- recently-expired one and the live one stay+          authorizationCodesDeleted = 2,+          lockoutsDeleted = 1,+          loginAttemptsDeleted = 1,+          -- the one grant expired past the 7-day grace; the recently-expired and the forever+          -- (NULL expiry) grants stay+          roleGrantsDeleted = 1,+          -- retention disabled by default+          authEventsDeleted = 0+        }++    -- The survivors are exactly the rows on the live side of each cutoff.+    scalarInt pool "SELECT count(*) FROM shomei.shomei_sessions" >>= (@?= 1)+    scalarInt pool "SELECT count(*) FROM shomei.shomei_refresh_tokens" >>= (@?= 2)+    scalarInt pool "SELECT count(*) FROM shomei.shomei_email_verification_tokens" >>= (@?= 1)+    scalarInt pool "SELECT count(*) FROM shomei.shomei_password_reset_tokens" >>= (@?= 1)+    scalarInt pool "SELECT count(*) FROM shomei.shomei_webauthn_pending_ceremonies" >>= (@?= 2)+    scalarInt pool "SELECT count(*) FROM shomei.shomei_account_lockouts" >>= (@?= 2)+    scalarInt pool "SELECT count(*) FROM shomei.shomei_login_attempts" >>= (@?= 1)+    scalarInt pool "SELECT count(*) FROM shomei.shomei_auth_events" >>= (@?= 2)+    -- The two live grants survive (recently expired, still in grace; and the forever grant).+    scalarInt pool "SELECT count(*) FROM shomei.shomei_role_grants" >>= (@?= 2)+    -- Users are never swept.+    scalarInt pool "SELECT count(*) FROM shomei.shomei_users" >>= (@?= 2)+    -- The live session kept its whole token chain, parent link intact.+    scalarInt+      pool+      "SELECT count(*) FROM shomei.shomei_refresh_tokens WHERE session_id = 'aaaaaaaa-0000-0000-0000-000000000003'"+      >>= (@?= 2)++testSweepIsIdempotent :: TestTree+testSweepIsIdempotent =+  testCase "maintenance sweep: a second sweep is a no-op" $ withDb \pool -> do+    seedSweepFixture pool+    t <- getCurrentTime+    _ <- sweepOnce pool defaultSweepConfig t >>= expectSweep+    second <- sweepOnce pool defaultSweepConfig t >>= expectSweep+    second @?= emptySweepReport++testSweepAuthEventRetention :: TestTree+testSweepAuthEventRetention =+  testCase "maintenance sweep: audit events go only when a retention window is configured" $ withDb \pool -> do+    seedSweepFixture pool+    t <- getCurrentTime+    -- Default config leaves both events in place.+    def <- sweepOnce pool defaultSweepConfig t >>= expectSweep+    def.authEventsDeleted @?= 0+    scalarInt pool "SELECT count(*) FROM shomei.shomei_auth_events" >>= (@?= 2)++    -- A 365-day window takes the 400-day-old event and nothing else.+    let retaining = defaultSweepConfig {authEventRetentionDays = Just 365}+    withWindow <- sweepOnce pool retaining t >>= expectSweep+    withWindow @?= emptySweepReport {authEventsDeleted = 1}+    scalarInt pool "SELECT count(*) FROM shomei.shomei_auth_events" >>= (@?= 1)++testSweepBatchesUntilDrained :: TestTree+testSweepBatchesUntilDrained =+  testCase "maintenance sweep: batches until drained" $ withDb \pool -> do+    -- 25 expired ceremonies with a batch size of 10 needs three passes of the drain loop.+    execSql+      pool+      """+      INSERT INTO shomei.shomei_webauthn_pending_ceremonies (ceremony_id, user_id, kind, options_blob, created_at, expires_at)+      SELECT gen_random_uuid(), NULL, 'authentication', '\\x00'::bytea, now() - interval '3 hours', now() - interval '2 hours'+      FROM generate_series(1, 25);+      """+    t <- getCurrentTime+    report <- sweepOnce pool defaultSweepConfig {batchSize = 10} t >>= expectSweep+    report.ceremoniesDeleted @?= 25+    scalarInt pool "SELECT count(*) FROM shomei.shomei_webauthn_pending_ceremonies" >>= (@?= 0)++-- | A whole rotation family must be deleted by one statement: @parent_token_id@ is a+-- self-referencing foreign key with no @ON DELETE@ action, so a row-bounded batch that split+-- a family would fail with a foreign-key violation. 'sweepOnce' batches by /session/ to avoid+-- this, which a batch size of 1 exercises directly — one session per statement, five tokens.+testSweepBatchesWholeTokenFamilies :: TestTree+testSweepBatchesWholeTokenFamilies =+  testCase "maintenance sweep: a batch never splits a refresh-token rotation family" $ withDb \pool -> do+    execSql+      pool+      """+      INSERT INTO shomei.shomei_users (user_id, email, display_name, status, created_at, updated_at, login_id) VALUES+        ('11111111-1111-1111-1111-111111111111', 'fam@example.com', 'Fam', 'active', now(), now(), 'fam@example.com');++      INSERT INTO shomei.shomei_sessions (session_id, user_id, status, created_at, expires_at, revoked_at) VALUES+        ('aaaaaaaa-0000-0000-0000-000000000001', '11111111-1111-1111-1111-111111111111', 'active', now() - interval '60 days', now() - interval '40 days', NULL),+        ('aaaaaaaa-0000-0000-0000-000000000002', '11111111-1111-1111-1111-111111111111', 'active', now() - interval '60 days', now() - interval '40 days', NULL);++      INSERT INTO shomei.shomei_refresh_tokens+        (refresh_token_id, session_id, token_hash, parent_token_id, status, created_at, expires_at, used_at, revoked_at) VALUES+        ('bbbbbbbb-0000-0000-0000-000000000001', 'aaaaaaaa-0000-0000-0000-000000000001', 'h1', NULL,                                   'used',   now(), now() - interval '40 days', now(), NULL),+        ('bbbbbbbb-0000-0000-0000-000000000002', 'aaaaaaaa-0000-0000-0000-000000000001', 'h2', 'bbbbbbbb-0000-0000-0000-000000000001', 'used',   now(), now() - interval '40 days', now(), NULL),+        ('bbbbbbbb-0000-0000-0000-000000000003', 'aaaaaaaa-0000-0000-0000-000000000001', 'h3', 'bbbbbbbb-0000-0000-0000-000000000002', 'active', now(), now() - interval '40 days', NULL, NULL),+        ('bbbbbbbb-0000-0000-0000-000000000011', 'aaaaaaaa-0000-0000-0000-000000000002', 'h4', NULL,                                   'used',   now(), now() - interval '40 days', now(), NULL),+        ('bbbbbbbb-0000-0000-0000-000000000012', 'aaaaaaaa-0000-0000-0000-000000000002', 'h5', 'bbbbbbbb-0000-0000-0000-000000000011', 'active', now(), now() - interval '40 days', NULL, NULL);+      """+    t <- getCurrentTime+    report <- sweepOnce pool defaultSweepConfig {batchSize = 1} t >>= expectSweep+    report.refreshTokensDeleted @?= 5+    report.sessionsDeleted @?= 2+    scalarInt pool "SELECT count(*) FROM shomei.shomei_refresh_tokens" >>= (@?= 0)+    scalarInt pool "SELECT count(*) FROM shomei.shomei_sessions" >>= (@?= 0)++latestVerificationToken :: [Notification] -> IO OneTimeToken+latestVerificationToken = \case+  EmailVerificationRequested {token = raw} : _ -> pure raw+  _ -> assertFailure "expected email-verification notification"++latestResetToken :: [Notification] -> IO OneTimeToken+latestResetToken = \case+  PasswordResetRequested {token = raw} : _ -> pure raw+  _ -> assertFailure "expected password-reset notification"