diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/shomei-postgres.cabal b/shomei-postgres.cabal new file mode 100644 --- /dev/null +++ b/shomei-postgres.cabal @@ -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 diff --git a/src/Shomei/Account/Credential/Postgres.hs b/src/Shomei/Account/Credential/Postgres.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Account/Credential/Postgres.hs @@ -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 diff --git a/src/Shomei/Account/Password/Hash/Postgres.hs b/src/Shomei/Account/Password/Hash/Postgres.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Account/Password/Hash/Postgres.hs @@ -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$\$\@. +-- +-- (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) diff --git a/src/Shomei/Account/PasswordReset/Postgres.hs b/src/Shomei/Account/PasswordReset/Postgres.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Account/PasswordReset/Postgres.hs @@ -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 diff --git a/src/Shomei/Account/User/Postgres.hs b/src/Shomei/Account/User/Postgres.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Account/User/Postgres.hs @@ -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) diff --git a/src/Shomei/Account/Verification/Postgres.hs b/src/Shomei/Account/Verification/Postgres.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Account/Verification/Postgres.hs @@ -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 diff --git a/src/Shomei/Audit/Publisher/Postgres.hs b/src/Shomei/Audit/Publisher/Postgres.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Audit/Publisher/Postgres.hs @@ -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 diff --git a/src/Shomei/Audit/Reader/Postgres.hs b/src/Shomei/Audit/Reader/Postgres.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Audit/Reader/Postgres.hs @@ -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))) diff --git a/src/Shomei/Authorization/Role/Postgres.hs b/src/Shomei/Authorization/Role/Postgres.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Authorization/Role/Postgres.hs @@ -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))) diff --git a/src/Shomei/Mfa/RecoveryCode/Postgres.hs b/src/Shomei/Mfa/RecoveryCode/Postgres.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Mfa/RecoveryCode/Postgres.hs @@ -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))) diff --git a/src/Shomei/Mfa/Totp/Postgres.hs b/src/Shomei/Mfa/Totp/Postgres.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Mfa/Totp/Postgres.hs @@ -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 diff --git a/src/Shomei/OAuth/AuthorizationCode/Postgres.hs b/src/Shomei/OAuth/AuthorizationCode/Postgres.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/OAuth/AuthorizationCode/Postgres.hs @@ -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 diff --git a/src/Shomei/OAuth/Client/Postgres.hs b/src/Shomei/OAuth/Client/Postgres.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/OAuth/Client/Postgres.hs @@ -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 diff --git a/src/Shomei/Passkey/Ceremony/Postgres.hs b/src/Shomei/Passkey/Ceremony/Postgres.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Passkey/Ceremony/Postgres.hs @@ -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) diff --git a/src/Shomei/Passkey/Postgres.hs b/src/Shomei/Passkey/Postgres.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Passkey/Postgres.hs @@ -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))) diff --git a/src/Shomei/Persistence/Codec/Postgres.hs b/src/Shomei/Persistence/Codec/Postgres.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Persistence/Codec/Postgres.hs @@ -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) diff --git a/src/Shomei/Persistence/Database/Postgres.hs b/src/Shomei/Persistence/Database/Postgres.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Persistence/Database/Postgres.hs @@ -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)) diff --git a/src/Shomei/Persistence/Maintenance/Postgres.hs b/src/Shomei/Persistence/Maintenance/Postgres.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Persistence/Maintenance/Postgres.hs @@ -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) + """ diff --git a/src/Shomei/Persistence/Pool/Postgres.hs b/src/Shomei/Persistence/Pool/Postgres.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Persistence/Pool/Postgres.hs @@ -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) diff --git a/src/Shomei/ServiceAccount/Postgres.hs b/src/Shomei/ServiceAccount/Postgres.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/ServiceAccount/Postgres.hs @@ -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 diff --git a/src/Shomei/Session/LoginAttempt/Postgres.hs b/src/Shomei/Session/LoginAttempt/Postgres.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Session/LoginAttempt/Postgres.hs @@ -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 diff --git a/src/Shomei/Session/Postgres.hs b/src/Shomei/Session/Postgres.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Session/Postgres.hs @@ -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 diff --git a/src/Shomei/Session/RefreshToken/Postgres.hs b/src/Shomei/Session/RefreshToken/Postgres.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Session/RefreshToken/Postgres.hs @@ -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 diff --git a/src/Shomei/Session/UnitOfWork/Postgres.hs b/src/Shomei/Session/UnitOfWork/Postgres.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Session/UnitOfWork/Postgres.hs @@ -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 + ) diff --git a/src/Shomei/SigningKey/Postgres.hs b/src/Shomei/SigningKey/Postgres.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/SigningKey/Postgres.hs @@ -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 diff --git a/src/Shomei/Time/Postgres.hs b/src/Shomei/Time/Postgres.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Time/Postgres.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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"