-- | 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.Monad (forM_, replicateM, void)
import Data.ByteString (ByteString)
import Data.ByteString qualified as BS
import Data.IORef (IORef, atomicModifyIORef', modifyIORef', newIORef, readIORef)
import Data.Int (Int64)
import Data.List (sort)
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 Hasql.Decoders qualified as D
import Hasql.Encoders qualified as E
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 (..),
    defaultArgon2Params,
    dummyHashFor,
    hashPasswordArgon2id,
    newHashingLimiter,
    peakHashingConcurrency,
    runPasswordHasherCrypto,
    runTokenGenCrypto,
    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, InvalidCredentials, RefreshTokenReuseDetected, RoleNotDefined, UserNotFound))
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,
    consumeAuthorizationCode,
    deleteExpiredAuthorizationCodes,
    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, refresh, signup)
import Shomei.Session.Command (ClientContext (..), LoginCommand (..), RefreshCommand (..), SignupCommand (..))
import Shomei.Session.Domain (NewSession (..), Session (..), SessionStatus (..))
import Shomei.Session.LoginAttempt.Domain (AccountKey (..), AccountLockout (..), ClientIp (..), LoginOutcome (..), NewLoginAttempt (..))
import Shomei.Session.LoginAttempt.Postgres (runLoginAttemptStorePostgres)
import Shomei.Session.LoginAttempt.Store
  ( LoginAttemptStore,
    clearAccountLockout,
    countRecentFailuresByAccount,
    countRecentFailuresByIp,
    getAccountLockout,
    recordLoginAttempt,
    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)
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, 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 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

-- | 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,
    testListUsersOrderFilterAndPaging,
    testListSessionsForUser,
    testCredentialRoundTrip,
    testSessionRevoke,
    testSessionActorRoundTrip,
    testRefreshTokenMarkUsed,
    testVerificationTokenRoundTrip,
    testPasswordResetTokenRoundTrip,
    testMarkUserEmailVerified,
    testSigningKeys,
    testPublishableSigningKeys,
    testPublishEvent,
    testAuditEventReader,
    testWorkflowSignup,
    testLoginRoundTripBudget,
    testRefreshRoundTripBudget,
    testWorkflowRefreshRotation,
    testWorkflowReuseRevokesFamily,
    testWorkflowAccountVerification,
    testWorkflowPasswordReset,
    testLoginAttemptStore,
    testWorkflowLockout,
    testPasskeyCreateAndFind,
    testPasskeyUpdateCountDelete,
    testServiceAccountRoundTrip,
    testOAuthClientRoundTrip,
    testAuthorizationCodeRoundTrip,
    testAuthorizationCodeConsumeIsAtomicUnderRace,
    testTotpCredentialRoundTrip,
    testTotpEncryptionAtRest,
    testRecoveryCodeCasAndReplace,
    testPendingCeremonyConsumeOnce,
    testPendingCeremonyExpired,
    testArgon2NewHashesArePhcFormatted,
    testArgon2RejectsUnparameterizedHashes,
    testArgon2ParamsChangeLeavesOldHashesVerifiable,
    testArgon2MalformedHashesVerifyFalse,
    testArgon2DummyHashTracksConfiguredParams,
    testHashingLimiterBoundsConcurrency 1,
    testHashingLimiterBoundsConcurrency 2,
    testInterpreterHonorsTheLimiter,
    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
      setTotpLastUsedCounter tcid 42
      found1 <- findTotpByUser u.userId
      deleteTotpByUser u.userId
      found2 <- findTotpByUser u.userId
      pure (created, found0, found1, found2)
    (created, found0, found1, found2) <- expectApp result
    tcSecret created @?= TotpSecret totpRawSecret
    fmap tcSecret found0 @?= Just (TotpSecret totpRawSecret)
    fmap tcConfirmedAt found0 @?= Just Nothing
    fmap (isJust . tcConfirmedAt) found1 @?= Just True
    fmap tcLastUsedCounter found1 @?= Just (Just 42)
    found2 @?= Nothing

-- | 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
    -- a duplicate login id is rejected by the unique index (interpreter surfaces a Left)
    dup <- runApp pool (createUser (NewUser {loginId = svc, email = Nothing, displayName = Nothing}))
    case dup of
      Left _ -> pure ()
      Right _ -> assertFailure "expected duplicate login_id to be rejected by the unique index"
    -- 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

-- | 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})
    updateUserStatus u2.userId UserSuspended
    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]

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})
    s2 <- createSession (NewSession {userId = alice.userId, createdAt = addUTCTime 1 t, expiresAt = addUTCTime 3600 t, actor = Nothing, oauthClientId = Nothing})
    _ <- createSession (NewSession {userId = bob.userId, createdAt = t, expiresAt = addUTCTime 3600 t, actor = Nothing, oauthClientId = Nothing})
    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

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})
    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
            }
        )
    normal <- createSession (NewSession {userId = subject.userId, createdAt = t, expiresAt = addUTCTime 3600 t, actor = Nothing, oauthClientId = Nothing})
    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

-- | 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})
    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
            }
    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
            }
    -- 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"]

testPublishEvent :: TestTree
testPublishEvent = testCase "publish auth event lands a row" $ withDb \pool -> do
  result <- runApp pool do
    t <- now
    publishAuthEvent (Event.LoginFailed (Event.LoginFailedData aliceLogin 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 aliceLogin (tt 0)))
    publishAuthEvent (Event.LoginSucceeded (Event.LoginSucceededData alice.userId s1 (tt 1)))
    publishAuthEvent (Event.LoginFailed (Event.LoginFailedData bobLogin (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 (allEvents, aliceEvents, failedEvents, windowEvents, total, failedTotal, page1, page2)
  (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: only alice's two rows, newest-first
  map storedEventType aliceEvents @?= ["password_changed", "login_succeeded"]
  -- 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 aliceLogin (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. @getAccountLockout@         (lockout gate)
--   3. @findPasswordCredentialByLoginId@
--   4. @findUserById@
--   5. @recordLoginAttempt@        (success row)
--   6. @countPasskeysByUser@       (MFA gate: passkey factor)
--   7. @findTotpByUser@            (MFA gate: confirmed-TOTP factor — EP-7)
--   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 lockout read at step 2 found nothing.
-- 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 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)

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
  requestRes <- runAppWithNotifications notifications pool (requestPasswordReset cfg (RequestPasswordReset aliceEmail))
  _ <- expectApp requestRes >>= expectRight
  raw <- latestResetToken =<< readIORef notifications
  confirmRes <- runAppWithNotifications notifications pool (confirmPasswordReset cfg (ConfirmPasswordReset raw (PlainPassword "correct horse battery staple two")))
  _ <- expectApp confirmRes >>= expectRight
  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 RefreshTokenReuseDetected
  consumed <- scalarInt pool "SELECT count(*) FROM shomei.shomei_password_reset_tokens WHERE status = 'consumed'"
  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
  assertBool "existing sessions are revoked" (revokedSessions >= 1)
  assertBool "existing refresh tokens are revoked" (revokedRefresh >= 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
    recordLoginAttempt (NewLoginAttempt key ip LoginFailure t)
    recordLoginAttempt (NewLoginAttempt key ip LoginFailure t)
    recordLoginAttempt (NewLoginAttempt key (ClientIp "9.9.9.9") LoginFailure t)
    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

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
      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', replay, unknown, expired, scopes)
    (first', 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)
    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
    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 (afterUpdate, cnt, u.userId, pid)
  (afterUpdate, cnt, uid, pid) <- expectApp result
  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

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

-- 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

    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.
testInterpreterHonorsTheLimiter :: TestTree
testInterpreterHonorsTheLimiter =
  testCase "hashing limiter: the PasswordHasher interpreter acquires a permit" do
    limiter <- newHashingLimiter 2
    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)))
        putMVar done h
    _ <- mapM takeMVar dones
    peak <- peakHashingConcurrency limiter
    -- Both halves matter. @peak <= 2@ is the bound. @peak >= 1@ proves a permit was taken at
    -- all: without it, deleting the bracket from the interpreter leaves @peak == 0@ and this
    -- test would pass while the server hashed without limit.
    assertBool ("interpreter allowed " <> show peak <> " concurrent hashes") (peak <= 2)
    assertBool "the interpreter never acquired a permit" (peak >= 1)

-- | 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"