-- | 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 (MVar, forkIO, killThread, newEmptyMVar, putMVar, readMVar, takeMVar, threadDelay)
import Control.Exception (SomeException, bracket, bracket_, evaluate, try)
import Control.Monad (forM, forM_, replicateM, void, when, (<=<))
import Crypto.Cipher.AES (AES256)
import Crypto.Cipher.Types (AEAD, AEADMode (AEAD_GCM), AuthTag (..), aeadInit, aeadSimpleEncrypt, cipherInit)
import Crypto.Error (CryptoFailable (..))
import Data.ByteArray qualified as BA
import Data.ByteString (ByteString)
import Data.ByteString qualified as BS
import Data.Either (isLeft)
import Data.IORef (IORef, atomicModifyIORef', modifyIORef', newIORef, readIORef)
import Data.Int (Int64)
import Data.List (sort, tails)
import Data.Maybe (isJust, isNothing)
import Data.Set qualified as Set
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Text.Encoding qualified as TE
import Data.Time (UTCTime (..), addUTCTime, fromGregorian, getCurrentTime)
import Effectful (Eff, IOE, liftIO, runEff, (:>))
import Effectful.Dispatch.Dynamic (interpose, interpret_, passthrough, send)
import Effectful.Error.Static (Error, runErrorNoCallStack)
import GHC.Clock (getMonotonicTimeNSec)
import GHC.Conc (getNumCapabilities)
import Hasql.Decoders qualified as D
import Hasql.Encoders qualified as E
import Hasql.Errors qualified as Hasql
import Hasql.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, updatePasswordHash)
import Shomei.Account.Email.Domain (Email, emailText, mkEmail)
import Shomei.Account.Lifecycle.Workflow
( ConfirmEmailVerification (..),
ConfirmPasswordReset (..),
RequestEmailVerification (..),
RequestPasswordReset (..),
confirmEmailVerification,
confirmPasswordReset,
requestEmailVerification,
requestPasswordReset,
)
import Shomei.Account.LoginId.Domain (LoginId, loginIdText, mkLoginId)
import Shomei.Account.Notification.Domain (Notification (..))
import Shomei.Account.Notification.Store (Notifier (..))
import Shomei.Account.OneTimeToken.Domain (OneTimeToken, OneTimeTokenHash (..), OneTimeTokenStatus (..))
import Shomei.Account.Password.Breach.Store (PasswordBreachChecker)
import Shomei.Account.Password.Domain (PasswordHash (..), PlainPassword (..))
import Shomei.Account.Password.Hash.Postgres
( Argon2Params (..),
argon2HardFloor,
defaultArgon2Params,
dummyHashFor,
hashPasswordArgon2id,
newHashingLimiter,
peakHashingConcurrency,
runPasswordHasherCrypto,
runTokenGenCrypto,
trialArgon2Derivation,
verifyPasswordArgon2id,
withHashingPermit,
)
import Shomei.Account.Password.Hash.Store (PasswordHasher, hashPassword, verifyPasswordDummy)
import Shomei.Account.PasswordReset.Domain (NewPasswordResetToken (..), PersistedPasswordResetToken (..))
import Shomei.Account.PasswordReset.Postgres (runPasswordResetTokenStorePostgres)
import Shomei.Account.PasswordReset.Store
( PasswordResetTokenStore,
createPasswordResetToken,
findPasswordResetTokenByHash,
markPasswordResetTokenConsumed,
)
import Shomei.Account.User.Domain (NewUser (..), User (..), UserStatus (..))
import Shomei.Account.User.Postgres (runUserStorePostgres)
import Shomei.Account.User.Store
( UserCursor (..),
UserListQuery (..),
UserStore (..),
createUser,
emptyUserListQuery,
findUserByEmail,
findUserById,
findUserByLoginId,
listUsers,
markUserEmailVerified,
updateUserStatus,
)
import Shomei.Account.Verification.Domain (NewVerificationToken (..), PersistedVerificationToken (..))
import Shomei.Account.Verification.Postgres (runVerificationTokenStorePostgres)
import Shomei.Account.Verification.Store
( VerificationTokenStore,
createVerificationToken,
findVerificationTokenByHash,
markVerificationTokenConsumed,
)
import Shomei.Audit.Event.Codec (reconstructAuthEvent)
import Shomei.Audit.Event.Domain qualified as Event
import Shomei.Audit.Publisher.Postgres (runAuthEventPublisherPostgres)
import Shomei.Audit.Publisher.Store (AuthEventPublisher, publishAuthEvent)
import Shomei.Audit.Reader.Postgres (runAuthEventReaderPostgres)
import Shomei.Audit.Reader.Store
( AuditCursor (..),
AuditEventQuery (..),
AuthEventReader,
StoredAuthEvent (..),
countAuthEvents,
emptyAuditQuery,
queryAuthEvents,
)
import Shomei.Authorization.Claims.Domain (Audience (..), AuthClaims (..), Issuer (..), Permission (..), Role (..), Scope (..))
import Shomei.Authorization.Claims.Store (ClaimsEnricher, runClaimsEnricherNull)
import Shomei.Authorization.Role.Postgres (runRoleStorePostgres)
import Shomei.Authorization.Role.Store
( RoleDefinition (..),
RoleStore,
allowPermission,
defineRole,
disallowPermission,
grantRole,
listDefinedRoles,
listPermissionsForRole,
listRolesForUser,
permissionsForRoles,
revokeRole,
)
import Shomei.Authorization.Role.Workflow (grantRoleTo)
import Shomei.Config (RateLimitConfig (..), ShomeiConfig (..), defaultRateLimitConfig, defaultShomeiConfig)
import Shomei.Error (AuthDependency (PostgreSQL), AuthError (DependencyUnavailable, EmailAlreadyRegistered, InvalidCredentials, LoginIdAlreadyRegistered, PasswordResetTokenInvalid, RefreshTokenReuseDetected, RoleNotDefined, UserNotFound))
import Shomei.Error qualified as Err
import Shomei.Id (OAuthClientId, PasskeyId, ServiceAccountDbId, genCeremonyId, genOAuthClientId, genRecoveryCodeId, genServiceAccountDbId, genSessionId, genTotpCredentialId, genUserId, idText, totpCredentialIdToUUID, userIdToUUID)
import Shomei.Mfa.RecoveryCode.Postgres (runRecoveryCodeStorePostgres)
import Shomei.Mfa.RecoveryCode.Store
( RecoveryCodeStore,
consumeRecoveryCode,
countUnusedRecoveryCodes,
replaceRecoveryCodes,
)
import Shomei.Mfa.Totp.Algorithm (TotpSecret (..), totpCode, totpCounter)
import Shomei.Mfa.Totp.Domain (NewRecoveryCode (..), NewTotpCredential (..), TotpCredential (..))
import Shomei.Mfa.Totp.Postgres
( TotpEncryptionKey,
checkTotpEnvelopeVersions,
migrateTotpEnvelopeBatch,
runTotpCredentialStorePostgres,
totpEncryptionKeyFromBytes,
)
import Shomei.Mfa.Totp.Store
( TotpCredentialStore,
confirmTotp,
deleteTotpByUser,
findTotpByUser,
setTotpLastUsedCounter,
upsertTotpEnrollment,
)
import Shomei.Mfa.Workflow (MfaCompletion (..), completeMfa, prepareMfaChallenge)
import Shomei.Migrations.TestSupport (withShomeiMigratedDatabase)
import Shomei.OAuth.AuthorizationCode.Domain (AuthorizationCode (..), NewAuthorizationCode (..))
import Shomei.OAuth.AuthorizationCode.Postgres (runOAuthCodeStorePostgres)
import Shomei.OAuth.AuthorizationCode.Store
( OAuthCodeStore,
bindAuthorizationCodeSession,
consumeAuthorizationCode,
findConsumedAuthorizationCode,
putAuthorizationCode,
)
import Shomei.OAuth.Client.Domain
( ClientType (..),
NewOAuthClient (..),
OAuthClient (..),
OAuthClientStatus (..),
)
import Shomei.OAuth.Client.Postgres (runOAuthClientStorePostgres)
import Shomei.OAuth.Client.Store
( OAuthClientStore,
createOAuthClient,
findOAuthClientByClientId,
listOAuthClients,
revokeOAuthClient,
)
import Shomei.OAuth.IdToken.Domain (IdToken (..))
import Shomei.Passkey.Ceremony.Port (WebAuthnCeremony)
import Shomei.Passkey.Ceremony.Postgres (runPendingCeremonyStorePostgres)
import Shomei.Passkey.Ceremony.Store (PendingCeremonyStore, putPendingCeremony, takePendingCeremony)
import Shomei.Passkey.Domain
( CeremonyKind (..),
NewPasskeyCredential (..),
PasskeyCredential (..),
PendingCeremony (..),
PublicKeyBytes (..),
SignatureCounter (..),
UserHandle (..),
WebAuthnCredentialId (..),
)
import Shomei.Passkey.Postgres (runPasskeyStorePostgres)
import Shomei.Passkey.Store
( PasskeyStore,
countPasskeysByUser,
createPasskey,
deletePasskey,
findPasskeyByCredentialId,
findPasskeysByUser,
findPasskeysByUserHandle,
updatePasskeySignCounter,
)
import Shomei.Persistence.Database.Postgres (Database (..), TransactionRetryPolicy (..), retryableTransactionError, runDatabasePool, runDatabasePoolWith, runTransaction)
import Shomei.Persistence.Maintenance.Postgres
( SweepConfig (..),
SweepReport (..),
defaultSweepConfig,
emptySweepReport,
sweepOnce,
)
import Shomei.Persistence.Pool.Postgres (Pool, acquirePool)
import Shomei.Persistence.Pool.Postgres qualified as Pool
import Shomei.Persistence.Transaction.Postgres qualified as Tx
import Shomei.ServiceAccount.Domain (NewServiceAccount (..), ServiceAccount (..), ServiceAccountStatus (..))
import Shomei.ServiceAccount.Postgres (runServiceAccountStorePostgres)
import Shomei.ServiceAccount.Store
( ServiceAccountStore,
createServiceAccount,
findServiceAccountByClientId,
listServiceAccounts,
revokeServiceAccount,
rotateServiceAccountSecret,
)
import Shomei.Session.Authentication.Workflow (login, logout, refresh, signup)
import Shomei.Session.Command (ClientContext (..), LoginCommand (..), LogoutCommand (..), ProofContext (..), RefreshCommand (..), SignupCommand (..))
import Shomei.Session.Domain (NewSession (..), Session (..), SessionKind (..), SessionStatus (..))
import Shomei.Session.LoginAttempt.Domain (AccountKey (..), AccountLockout (..), AttemptFactor (..), ClientIp (..), FailureOutcome (..), LockPolicy (..), LoginOutcome (..), NewLoginAttempt (..))
import Shomei.Session.LoginAttempt.Postgres (runLoginAttemptStorePostgres)
import Shomei.Session.LoginAttempt.Store
( LoginAttemptStore,
clearAccountLockout,
countRecentFailuresByAccount,
countRecentFailuresByIp,
getAccountLockout,
recordLoginFailure,
setAccountLockout,
)
import Shomei.Session.Postgres (runSessionStorePostgres)
import Shomei.Session.RefreshToken.Domain (NewRefreshToken (..), PersistedRefreshToken (..), RefreshToken (..), RefreshTokenStatus (..))
import Shomei.Session.RefreshToken.Postgres (runRefreshTokenStorePostgres)
import Shomei.Session.RefreshToken.Store (RefreshTokenStore (..), createRefreshToken, findRefreshTokenByHash, markRefreshTokenUsed)
import Shomei.Session.Store (SessionCursor (..), SessionListQuery (..), SessionStore, createSession, createSessionWithinLimit, emptySessionListQuery, findSessionById, listSessionPage, listSessionsForUser, revokeSession)
import Shomei.Session.Token.Domain (AccessToken (..), TokenPair (..))
import Shomei.Session.Token.Generator (TokenGen, hashRefreshToken)
import Shomei.Session.UnitOfWork.Postgres (runAuthUnitOfWorkPostgres)
import Shomei.Session.UnitOfWork.Store (AuthUnitOfWork, completePasswordChange, completePasswordReset, revokeSessionWithTokens, revokeUserSessionsWithAudit)
import Shomei.Session.Workflow (buildEnrichedClaims)
import Shomei.SigningKey.Domain (SigningKeyStatus (..), StoredSigningKey (..))
import Shomei.SigningKey.Postgres (runSigningKeyStorePostgres)
import Shomei.SigningKey.Signer (TokenSigner (..))
import Shomei.SigningKey.Store (SigningKeyStore, findSigningKeyByKid, insertSigningKey, listActiveSigningKeys, listPublishableSigningKeys, replaceActiveSigningKey, updateSigningKeyStatus)
import Shomei.Test.InMemory (emptyWorld, runPasswordBreachCheckerFake, runWebAuthnCeremonyFake)
import Shomei.Time.Postgres (runClockIO)
import Shomei.Time.Store (Clock (..), now)
import System.Timeout (timeout)
import Test.Tasty (TestTree, defaultMain, testGroup)
import Test.Tasty.HUnit (Assertion, assertBool, assertEqual, assertFailure, testCase, (@?=))
-- | The full interpreter stack used by every test. The store interpreters are peeled
-- first (Database/IOE/Error remain available to them); @TokenSigner@ is a trivial fake
-- because real signing is EP-4.
type AppEffects =
'[ UserStore,
RoleStore,
CredentialStore,
SessionStore,
RefreshTokenStore,
AuthUnitOfWork,
VerificationTokenStore,
PasswordResetTokenStore,
LoginAttemptStore,
PasskeyStore,
PendingCeremonyStore,
ServiceAccountStore,
OAuthClientStore,
OAuthCodeStore,
TotpCredentialStore,
RecoveryCodeStore,
Notifier,
ClaimsEnricher,
WebAuthnCeremony,
AuthEventPublisher,
AuthEventReader,
SigningKeyStore,
TokenSigner,
PasswordBreachChecker,
PasswordHasher,
TokenGen,
Clock,
Database,
Error AuthError,
IOE
]
runApp :: Pool -> Eff AppEffects a -> IO (Either AuthError a)
runApp pool action = do
ref <- newIORef []
runAppWithNotifications ref pool action
runAppWithNotifications :: IORef [Notification] -> Pool -> Eff AppEffects a -> IO (Either AuthError a)
runAppWithNotifications ref pool action = do
wref <- newIORef (emptyWorld (UTCTime (fromGregorian 2000 1 1) 0))
limiter <- newHashingLimiter 2
( runEff
. runErrorNoCallStack
. runDatabasePool pool
. runClockIO
. runTokenGenCrypto
-- Cheap parameters: these workflow tests hash real passwords, and the production cost
-- (~100 ms per hash) would dominate the suite. The argon2 tests below cover the real ones.
. runPasswordHasherCrypto limiter cheapParams
. runPasswordBreachCheckerFake wref
. runTokenSignerFake
. runSigningKeyStorePostgres
. runAuthEventReaderPostgres
. runAuthEventPublisherPostgres
. runWebAuthnCeremonyFake wref
. runClaimsEnricherNull
. runNotifierRef ref
. runRecoveryCodeStorePostgres
. runTotpCredentialStorePostgres testTotpKey
. runOAuthCodeStorePostgres
. runOAuthClientStorePostgres
. runServiceAccountStorePostgres
. runPendingCeremonyStorePostgres
. runPasskeyStorePostgres
. runLoginAttemptStorePostgres
. runPasswordResetTokenStorePostgres
. runVerificationTokenStorePostgres
. runAuthUnitOfWorkPostgres
. runRefreshTokenStorePostgres
. runSessionStorePostgres
. runCredentialStorePostgres
. runRoleStorePostgres
. runUserStorePostgres
)
action
-- | Run the stack with a FIXED clock (the EP-2 lockout tests need to advance time
-- deterministically across calls against the same database). Notifications are discarded.
runAppAtTime :: UTCTime -> Pool -> Eff AppEffects a -> IO (Either AuthError a)
runAppAtTime t pool action = do
ref <- newIORef []
wref <- newIORef (emptyWorld t)
limiter <- newHashingLimiter 2
( runEff
. runErrorNoCallStack
. runDatabasePool pool
. runClockFixed t
. runTokenGenCrypto
. runPasswordHasherCrypto limiter cheapParams
. runPasswordBreachCheckerFake wref
. runTokenSignerFake
. runSigningKeyStorePostgres
. runAuthEventReaderPostgres
. runAuthEventPublisherPostgres
. runWebAuthnCeremonyFake wref
. runClaimsEnricherNull
. runNotifierRef ref
. runRecoveryCodeStorePostgres
. runTotpCredentialStorePostgres testTotpKey
. runOAuthCodeStorePostgres
. runOAuthClientStorePostgres
. runServiceAccountStorePostgres
. runPendingCeremonyStorePostgres
. runPasskeyStorePostgres
. runLoginAttemptStorePostgres
. runPasswordResetTokenStorePostgres
. runVerificationTokenStorePostgres
. runAuthUnitOfWorkPostgres
. runRefreshTokenStorePostgres
. runSessionStorePostgres
. runCredentialStorePostgres
. runRoleStorePostgres
. runUserStorePostgres
)
action
runClockFixed :: UTCTime -> Eff (Clock : es) a -> Eff es a
runClockFixed t = interpret_ \case
Now -> pure t
-- | A trivial 'TokenSigner' (real signing is EP-4); the DB-state assertions never inspect
-- the access token's contents.
runTokenSignerFake :: Eff (TokenSigner : es) a -> Eff es a
runTokenSignerFake = interpret_ \case
SignAccessToken _ -> pure (AccessToken "test-access-token")
SignIdToken _ -> pure (IdToken "test-id-token")
runNotifierRef :: (IOE :> es) => IORef [Notification] -> Eff (Notifier : es) a -> Eff es a
runNotifierRef ref = interpret_ \case
SendNotification n -> liftIO (modifyIORef' ref (n :))
-- Helpers --------------------------------------------------------------------
cfg :: ShomeiConfig
cfg = defaultShomeiConfig (Issuer "shomei") (Audience "shomei-clients")
-- | Tightened thresholds for the EP-2 lockout test (lock after 3 per-account failures).
lockCfg :: ShomeiConfig
lockCfg = cfg {rateLimitConfig = defaultRateLimitConfig {maxFailedLoginsPerAccount = 3}}
t0 :: UTCTime
t0 = UTCTime (fromGregorian 2026 1 1) 0
aliceEmail :: Email
aliceEmail = mkEmail' "alice@example.com"
bobEmail :: Email
bobEmail = mkEmail' "bob@example.com"
aliceLogin :: LoginId
aliceLogin = either (error . show) id (mkLoginId (emailText aliceEmail))
bobLogin :: LoginId
bobLogin = either (error . show) id (mkLoginId (emailText bobEmail))
strongPw :: PlainPassword
strongPw = PlainPassword "correct horse battery staple"
mkEmail' :: Text -> Email
mkEmail' t = case mkEmail t of
Right e -> e
Left err -> error ("bad test email: " <> show err)
mkLoginId' :: Text -> LoginId
mkLoginId' t = case mkLoginId t of
Right l -> l
Left err -> error ("bad test login id: " <> show err)
-- | Run an action over a fresh migrated database and a pool.
withDb :: (Pool -> IO a) -> IO a
withDb action = withShomeiMigratedDatabase \connStr -> do
pool <- acquirePool 4 10 30000 connStr
action pool
-- | Unwrap the @Either AuthError@ from 'runApp' (the interpreter-level failure channel).
expectApp :: (Show e) => Either e a -> IO a
expectApp = either (\e -> assertFailure ("interpreter error: " <> show e)) pure
-- | Unwrap a workflow's own @Either AuthError@ result.
expectRight :: (Show e) => Either e a -> IO a
expectRight = either (\e -> assertFailure ("expected Right, got Left: " <> show e)) pure
-- | Run a (possibly multi-statement) SQL script directly against the pool, for seeding.
execSql :: Pool -> Text -> IO ()
execSql pool sql = do
res <- Pool.use pool (Session.script sql)
either (\e -> assertFailure ("seed script failed: " <> show e)) pure res
-- | Assert that a raw SQL script is rejected with one exact PostgreSQL SQLSTATE.
execSqlExpectState :: Pool -> Text -> Text -> IO ()
execSqlExpectState pool expected sql = do
result <- Pool.use pool (Session.script sql)
case result of
Left (Pool.SessionUsageError (Hasql.ScriptSessionError _ (Hasql.ServerError actual _ _ _ _))) ->
actual @?= expected
Left err -> assertFailure ("expected SQLSTATE " <> Text.unpack expected <> ", got: " <> show err)
Right () -> assertFailure ("expected SQLSTATE " <> Text.unpack expected <> ", but SQL succeeded")
-- | Unwrap the typed dependency result that 'sweepOnce' returns.
expectSweep :: Either AuthError SweepReport -> IO SweepReport
expectSweep = either (\e -> assertFailure ("sweep failed: " <> show e)) pure
-- | A scalar @count(*)@ (or any single-bigint) query, run directly against the pool.
scalarInt :: Pool -> Text -> IO Int
scalarInt pool sql = do
res <- Pool.use pool (Session.statement () stmt)
either (\e -> assertFailure ("scalar query failed: " <> show e)) pure res
where
stmt =
preparable
sql
E.noParams
(D.singleRow (fromIntegral64 <$> D.column (D.nonNullable D.int8)))
fromIntegral64 :: Int64 -> Int
fromIntegral64 = fromIntegral
-- | A single @bytea@ column, run directly against the pool (used to inspect @secret_enc@).
scalarBytea :: Pool -> Text -> IO ByteString
scalarBytea pool sql = do
res <- Pool.use pool (Session.statement () stmt)
either (\e -> assertFailure ("scalar bytea query failed: " <> show e)) pure res
where
stmt = preparable sql E.noParams (D.singleRow (D.column (D.nonNullable D.bytea)))
-- | A fixed 32-byte AES-256-GCM key for the TOTP round-trip tests. Value is irrelevant; the test
-- only proves encrypt-then-decrypt is the identity and that the ciphertext is not the plaintext.
testTotpKey :: TotpEncryptionKey
testTotpKey = case totpEncryptionKeyFromBytes (BS.replicate 32 7) of
Right k -> k
Left e -> error ("bad test TOTP key: " <> Text.unpack e)
-- | 20 raw secret bytes (the RFC 6238 Appendix B secret).
totpRawSecret :: ByteString
totpRawSecret = "12345678901234567890"
-- Field accessors: OverloadedRecordDot is unreliable for these DuplicateRecordFields records.
tcSecret :: TotpCredential -> TotpSecret
tcSecret TotpCredential {secret} = secret
tcConfirmedAt :: TotpCredential -> Maybe UTCTime
tcConfirmedAt TotpCredential {confirmedAt} = confirmedAt
tcLastUsedCounter :: TotpCredential -> Maybe Int64
tcLastUsedCounter TotpCredential {lastUsedCounter} = lastUsedCounter
-- Tests ----------------------------------------------------------------------
main :: IO ()
main = defaultMain (testGroup "shomei-postgres" tests)
tests :: [TestTree]
tests =
[ testManagedPoolOwnership,
testPersistenceClock,
testAdminQueryPlans,
testRefreshRotationRace,
testResetAndVerificationRaces,
testRecoveryAndCeremonyRaces,
testSweepVersusLiveRotation,
testRetryBudgets,
testTransactionDeadline,
testShrinkingStatementBudget,
testSessionQuotaQueryPlan,
testActiveSessionQuota,
testBulkRevocation,
testSessionPages,
testSessionQueryPlan,
testDatabaseTimeouts,
testUserRoundTrip,
testUserNoEmailAndUniqueLoginId,
testFieldBudgets,
testSchemaRejectsInvalidUserStatusAndCaseVariantIdentities,
testListUsersOrderFilterAndPaging,
testUserStatusIsCompareAndSwap,
testUserStatusCasUnderRace,
testListSessionsForUser,
testCredentialRoundTrip,
testCredentialUniquePerUser,
testPoolStatementTimeoutIsApplied,
testSessionRevoke,
testSessionActorRoundTrip,
testSessionKindRoundTrip,
testSessionGrantedScopesRoundTrip,
testSessionRememberedRoundTrip,
testSessionKindNullFailsClosed,
testRefreshTokenMarkUsed,
testVerificationTokenRoundTrip,
testPasswordResetTokenRoundTrip,
testMarkUserEmailVerified,
testSigningKeys,
testPublishableSigningKeys,
testSigningKeyTransitionTimestamps,
testSigningKeyOneActiveInvariant,
testPublishEvent,
testAuditEventReader,
testWorkflowSignup,
testLoginRoundTripBudget,
testFailedLoginRoundTripBudget,
testRefreshRoundTripBudget,
testLogoutRoundTripBudget,
testPasswordResetRoundTripBudget,
testWorkflowRefreshRotation,
testWorkflowReuseRevokesFamily,
testWorkflowAccountVerification,
testWorkflowPasswordReset,
testRevokeSessionIsCompareAndSwap,
testLoginAttemptStore,
testLockoutRecordAndCountIsAtomicUnderRace,
testWorkflowLockout,
testPasskeyCreateAndFind,
testPasskeyQuotaRace,
testPasskeyUpdateCountDelete,
testPasskeyCounterIsCompareAndSwap,
testPasskeyCounterCasUnderRace,
testServiceAccountRoundTrip,
testOAuthClientRoundTrip,
testAuthorizationCodeRoundTrip,
testAuthorizationCodeConsumeIsAtomicUnderRace,
testTotpCredentialRoundTrip,
testTotpCounterIsCompareAndSwap,
testTotpCounterCasUnderRace,
testTotpEncryptionAtRest,
testTotpEnvelopeBinding,
testTotpEnvelopeConversion,
testTotpConversionBatches,
testTotpConvertedFactor,
testTotpConversionConflict,
testRecoveryCodeCasAndReplace,
testPendingCeremonyConsumeOnce,
testPendingCeremonyExpired,
testArgon2NewHashesArePhcFormatted,
testArgon2RejectsUnparameterizedHashes,
testArgon2ParamsChangeLeavesOldHashesVerifiable,
testArgon2MalformedHashesVerifyFalse,
testArgon2DummyHashTracksConfiguredParams,
testArgon2HardFloorMatchesTheImplementation,
testHashingLimiterBoundsConcurrency 1,
testHashingLimiterBoundsConcurrency 2,
testInterpreterForcesTheHashInsideThePermit,
testDummyVerificationTakesAPermit,
testSweepDeletesExpiredRows,
testSweepIsIdempotent,
testSweepAuthEventRetention,
testSweepBatchesUntilDrained,
testSweepBatchesWholeTokenFamilies,
testRoleRegistry,
testRoleGrants,
testRoleGrantForeignKeys,
testGrantedRoleReachesEnrichedClaims,
testRolePermissions,
testRolePermissionForeignKey,
testExpiringGrants
]
-- | The registry: seeded with @admin@ by the migration, idempotent definition, sorted listing.
testRoleRegistry :: TestTree
testRoleRegistry =
testCase "role registry: seeded with admin; define is idempotent; list is sorted" $ withDb \pool -> do
result <- runApp pool do
seeded <- listDefinedRoles
ts <- now
firstDefine <- defineRole (Role "auditor") (Just "read the audit trail") ts
secondDefine <- defineRole (Role "auditor") (Just "a different description") ts
after' <- listDefinedRoles
pure (seeded, firstDefine, secondDefine, after')
(seeded, firstDefine, secondDefine, after') <- expectApp result
map (.role) seeded @?= [Role "admin"]
firstDefine @?= True
-- Re-defining is a no-op: it reports no change and does NOT overwrite the description.
secondDefine @?= False
map (.role) after' @?= [Role "admin", Role "auditor"]
map (.description) after' @?= [Just adminSeedDescription, Just "read the audit trail"]
-- | Grants: idempotent insert, listing, revocation, and the "nothing to revoke" report.
testRoleGrants :: TestTree
testRoleGrants =
testCase "role grants: idempotent grant/revoke round-trip" $ withDb \pool -> do
result <- runApp pool do
u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})
ts <- now
_ <- defineRole (Role "auditor") Nothing ts
firstGrant <- grantRole u.userId (Role "admin") Nothing Nothing ts
secondGrant <- grantRole u.userId (Role "admin") Nothing Nothing ts
_ <- grantRole u.userId (Role "auditor") (Just u.userId) Nothing ts
granted <- listRolesForUser u.userId ts
firstRevoke <- revokeRole u.userId (Role "admin")
secondRevoke <- revokeRole u.userId (Role "admin")
remaining <- listRolesForUser u.userId ts
pure (firstGrant, secondGrant, granted, firstRevoke, secondRevoke, remaining)
(firstGrant, secondGrant, granted, firstRevoke, secondRevoke, remaining) <- expectApp result
firstGrant @?= True
secondGrant @?= False
granted @?= Set.fromList [Role "admin", Role "auditor"]
firstRevoke @?= True
secondRevoke @?= False
remaining @?= Set.singleton (Role "auditor")
-- | The database enforces both foreign keys, so code that bypasses 'Shomei.Authorization.Role.Workflow'
-- still cannot create a dangling grant. Hasql command failures cross the adapter boundary as
-- 'DependencyUnavailable'; the workflow catches both cases first and returns a typed error.
testRoleGrantForeignKeys :: TestTree
testRoleGrantForeignKeys =
testCase "role grants: FKs reject undefined roles and unknown users; workflow pre-checks" $ withDb \pool -> do
setup <- runApp pool do
u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})
pure u.userId
uid <- expectApp setup
-- Raw port, undefined role: the shomei_role_grants.role FK fires.
rawUndefinedRole <- runApp pool do
ts <- now
grantRole uid (Role "nosuchrole") Nothing Nothing ts
expectDependencyError "grant of an undefined role" rawUndefinedRole
-- Raw port, unknown user: the shomei_role_grants.user_id FK fires.
ghost <- genUserId
rawUnknownUser <- runApp pool do
ts <- now
grantRole ghost (Role "admin") Nothing Nothing ts
expectDependencyError "grant to a nonexistent user" rawUnknownUser
-- The workflow refuses both BEFORE touching the table, with typed errors.
workflowUndefinedRole <- runApp pool (grantRoleTo Nothing Nothing uid (Role "nosuchrole"))
expectApp workflowUndefinedRole >>= \r -> r @?= Left (RoleNotDefined (Role "nosuchrole"))
workflowUnknownUser <- runApp pool (grantRoleTo Nothing Nothing ghost (Role "admin"))
expectApp workflowUnknownUser >>= \r -> r @?= Left UserNotFound
-- And the happy path still lands a row plus exactly one role_granted audit event.
ok <- runApp pool (grantRoleTo Nothing Nothing uid (Role "admin"))
expectApp ok >>= \r -> r @?= Right True
again <- runApp pool (grantRoleTo Nothing Nothing uid (Role "admin"))
expectApp again >>= \r -> r @?= Right False
grants <- scalarInt pool "SELECT count(*) FROM shomei.shomei_role_grants"
grants @?= 1
events <- scalarInt pool "SELECT count(*) FROM shomei.shomei_auth_events WHERE event_type = 'role_granted'"
events @?= 1
where
expectDependencyError what = \case
Left (DependencyUnavailable PostgreSQL) -> pure ()
Left e -> assertFailure (what <> ": expected PostgreSQL dependency failure, got " <> show e)
Right _ -> assertFailure (what <> ": expected the foreign key to reject it")
-- | The claims path end to end over the real store: a role granted through the workflow shows
-- up in the claims 'buildEnrichedClaims' assembles, which is what every token mint signs.
testGrantedRoleReachesEnrichedClaims :: TestTree
testGrantedRoleReachesEnrichedClaims =
testCase "buildEnrichedClaims reads roles from the real PostgreSQL store" $ withDb \pool -> do
result <- runApp pool do
u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})
sid <- genSessionId
ts <- now
before <- buildEnrichedClaims cfg u.userId sid ts
_ <- grantRoleTo Nothing Nothing u.userId (Role "admin")
after' <- buildEnrichedClaims cfg u.userId sid ts
pure (before, after')
(before, after') <- expectApp result
before.roles @?= Set.empty
after'.roles @?= Set.singleton (Role "admin")
-- Shōmei persists no scopes; the null enricher adds none.
after'.scopes @?= Set.empty
-- | Role→permission wiring (EP-9): idempotent allow, single-role listing, deduplicated union
-- across a role set, and disallow with its "nothing to detach" report.
testRolePermissions :: TestTree
testRolePermissions =
testCase "role permissions: allow/list/union/disallow round-trip" $ withDb \pool -> do
result <- runApp pool do
ts <- now
_ <- defineRole (Role "support") (Just "support staff") ts
_ <- defineRole (Role "billing") (Just "billing staff") ts
firstAllow <- allowPermission (Role "support") (Permission "tickets:write") ts
dupAllow <- allowPermission (Role "support") (Permission "tickets:write") ts
_ <- allowPermission (Role "support") (Permission "tickets:read") ts
-- Overlapping permission on a second role, to prove the union deduplicates.
_ <- allowPermission (Role "billing") (Permission "tickets:read") ts
_ <- allowPermission (Role "billing") (Permission "invoices:read") ts
supportPerms <- listPermissionsForRole (Role "support")
union <- permissionsForRoles (Set.fromList [Role "support", Role "billing"])
firstDisallow <- disallowPermission (Role "support") (Permission "tickets:write")
secondDisallow <- disallowPermission (Role "support") (Permission "tickets:write")
afterDisallow <- listPermissionsForRole (Role "support")
pure (firstAllow, dupAllow, supportPerms, union, firstDisallow, secondDisallow, afterDisallow)
(firstAllow, dupAllow, supportPerms, union, firstDisallow, secondDisallow, afterDisallow) <- expectApp result
firstAllow @?= True
dupAllow @?= False
supportPerms @?= Set.fromList [Permission "tickets:read", Permission "tickets:write"]
union @?= Set.fromList [Permission "invoices:read", Permission "tickets:read", Permission "tickets:write"]
firstDisallow @?= True
secondDisallow @?= False
afterDisallow @?= Set.singleton (Permission "tickets:read")
-- | The @shomei_role_permissions.role@ FK rejects attaching a permission to an undefined role,
-- exactly as the grants FK rejects granting one. The raw port surfaces the Hasql command
-- failure as 'DependencyUnavailable PostgreSQL'.
testRolePermissionForeignKey :: TestTree
testRolePermissionForeignKey =
testCase "role permissions: allow on an undefined role hits the FK" $ withDb \pool -> do
res <- runApp pool do
ts <- now
allowPermission (Role "nosuchrole") (Permission "tickets:write") ts
case res of
Left (DependencyUnavailable PostgreSQL) -> pure ()
Left e -> assertFailure ("expected PostgreSQL dependency failure, got " <> show e)
Right _ -> assertFailure "expected the FK to reject a permission on an undefined role"
-- | Time-bound grants (EP-9): a grant with an expiry drops out of 'listRolesForUser' as of an
-- instant past it, but is present as of an instant before it; re-granting with a different expiry
-- reports a change and the new window wins, while an identical re-grant reports none.
testExpiringGrants :: TestTree
testExpiringGrants =
testCase "expiring grants: as-of filter, and upsert reports change only when expiry moves" $ withDb \pool -> do
result <- runApp pool do
u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})
ts <- now
let expiry = addUTCTime 3600 ts -- one hour out
_ <- grantRole u.userId (Role "admin") Nothing (Just expiry) ts
liveNow <- listRolesForUser u.userId ts -- before expiry: present
liveAfter <- listRolesForUser u.userId (addUTCTime 7200 ts) -- after expiry: gone
-- Identical re-grant: no change.
sameAgain <- grantRole u.userId (Role "admin") Nothing (Just expiry) ts
-- Re-grant moving the expiry further out: a change, and the new window applies.
let expiry2 = addUTCTime 10800 ts
moved <- grantRole u.userId (Role "admin") Nothing (Just expiry2) ts
liveAtOldExpiry <- listRolesForUser u.userId (addUTCTime 7200 ts) -- now inside the new window
pure (liveNow, liveAfter, sameAgain, moved, liveAtOldExpiry)
(liveNow, liveAfter, sameAgain, moved, liveAtOldExpiry) <- expectApp result
liveNow @?= Set.singleton (Role "admin")
liveAfter @?= Set.empty
sameAgain @?= False
moved @?= True
liveAtOldExpiry @?= Set.singleton (Role "admin")
-- | The description the @shomei-role-grants@ migration seeds onto the @admin@ role.
adminSeedDescription :: Text
adminSeedDescription = "Full access to the shomei /admin surface and admin CLI-equivalent HTTP routes"
-- | The TOTP credential store's contract against real PostgreSQL: the raw secret survives the
-- encrypt→store→decrypt round-trip, @confirm@ and the last-used counter land, and delete removes
-- the row.
testTotpCredentialRoundTrip :: TestTree
testTotpCredentialRoundTrip =
testCase "totp credential: enroll, find (raw secret round-trips), confirm, counter, delete" $ withDb \pool -> do
result <- runApp pool do
u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})
tcid <- genTotpCredentialId
t <- now
created <-
upsertTotpEnrollment
NewTotpCredential {totpCredentialId = tcid, userId = u.userId, secret = TotpSecret totpRawSecret, createdAt = t}
found0 <- findTotpByUser u.userId
confirmTotp tcid t
counterAdvanced <- setTotpLastUsedCounter tcid 42
found1 <- findTotpByUser u.userId
deleteTotpByUser u.userId
found2 <- findTotpByUser u.userId
pure (created, found0, counterAdvanced, found1, found2)
(created, found0, counterAdvanced, found1, found2) <- expectApp result
tcSecret created @?= TotpSecret totpRawSecret
fmap tcSecret found0 @?= Just (TotpSecret totpRawSecret)
fmap tcConfirmedAt found0 @?= Just Nothing
counterAdvanced @?= True
fmap (isJust . tcConfirmedAt) found1 @?= Just True
fmap tcLastUsedCounter found1 @?= Just (Just 42)
found2 @?= Nothing
testTotpCounterIsCompareAndSwap :: TestTree
testTotpCounterIsCompareAndSwap =
testCase "totp counter advances only to a strictly newer value" $ withDb \pool -> do
result <- runApp pool do
u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})
tcid <- genTotpCredentialId
t <- now
_ <-
upsertTotpEnrollment
NewTotpCredential {totpCredentialId = tcid, userId = u.userId, secret = TotpSecret totpRawSecret, createdAt = t}
first <- setTotpLastUsedCounter tcid 42
same <- setTotpLastUsedCounter tcid 42
older <- setTotpLastUsedCounter tcid 41
newer <- setTotpLastUsedCounter tcid 43
stored <- findTotpByUser u.userId
pure (first, same, older, newer, stored)
(first, same, older, newer, stored) <- expectApp result
(first, same, older, newer) @?= (True, False, False, True)
fmap tcLastUsedCounter stored @?= Just (Just 43)
testTotpCounterCasUnderRace :: TestTree
testTotpCounterCasUnderRace =
testCase "totp counter: eight racing updates have one winner" $ withDb \pool -> do
seeded <- runApp pool do
u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})
tcid <- genTotpCredentialId
t <- now
_ <-
upsertTotpEnrollment
NewTotpCredential {totpCredentialId = tcid, userId = u.userId, secret = TotpSecret totpRawSecret, createdAt = t}
pure tcid
tcid <- expectApp seeded
gate <- newEmptyMVar
dones <- replicateM 8 do
done <- newEmptyMVar
_ <- forkIO do
readMVar gate
putMVar done =<< runApp pool (setTotpLastUsedCounter tcid 42)
pure done
putMVar gate ()
results <- traverse (\done -> expectApp =<< takeMVar done) dones
length (filter id results) @?= 1
-- | The stored @secret_enc@ is genuine ciphertext: it differs from the plaintext secret and is
-- longer by exactly the 12-byte nonce and 16-byte GCM tag. Decryption is proven by the round-trip
-- test above; here we prove nothing recoverable sits at rest.
testTotpEncryptionAtRest :: TestTree
testTotpEncryptionAtRest =
testCase "totp secret is encrypted at rest (ciphertext differs from plaintext, nonce+tag framed)" $ withDb \pool -> do
result <- runApp pool do
u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})
tcid <- genTotpCredentialId
t <- now
_ <- upsertTotpEnrollment NewTotpCredential {totpCredentialId = tcid, userId = u.userId, secret = TotpSecret totpRawSecret, createdAt = t}
pure ()
_ <- expectApp result
stored <- scalarBytea pool "SELECT secret_enc FROM shomei.shomei_totp_credentials LIMIT 1"
assertBool "stored ciphertext must differ from the plaintext secret" (stored /= totpRawSecret)
-- 12-byte nonce + 20-byte ciphertext + 16-byte GCM tag
BS.length stored @?= 54
testTotpEnvelopeBinding :: TestTree
testTotpEnvelopeBinding =
testCase "totp envelopes bind pending/confirmed rows and reject transplant, version and payload tampering" $ withDb \pool -> do
(alice, bob) <-
expectApp =<< runApp pool do
a <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})
b <- createUser (NewUser {loginId = bobLogin, email = Just bobEmail, displayName = Nothing})
forM_ [a, b] \u -> do
tcid <- genTotpCredentialId
t <- now
_ <- upsertTotpEnrollment NewTotpCredential {totpCredentialId = tcid, userId = u.userId, secret = TotpSecret totpRawSecret, createdAt = t}
pure ()
pure (a, b)
let aliceId = "'" <> Text.pack (show (userIdToUUID alice.userId)) <> "'"
bobId = "'" <> Text.pack (show (userIdToUUID bob.userId)) <> "'"
restore = execSql pool ("UPDATE shomei.shomei_totp_credentials SET secret_enc = saved.secret_enc, envelope_version = 1 FROM saved WHERE shomei_totp_credentials.user_id = saved.user_id")
-- Persist snapshots in an ordinary fixture table because pool checkouts may differ.
execSql pool "CREATE TABLE saved AS SELECT * FROM shomei.shomei_totp_credentials"
forM_ [False, True] \confirmed -> do
when confirmed $ execSql pool "UPDATE shomei.shomei_totp_credentials SET confirmed_at = created_at"
execSql pool ("UPDATE shomei.shomei_totp_credentials SET secret_enc = (SELECT secret_enc FROM saved WHERE user_id = " <> aliceId <> ") WHERE user_id = " <> bobId)
transplanted <- runApp pool (findTotpByUser bob.userId)
assertBool "transplanted secret rejected" (isLeft transplanted)
restore
forM_ [0, 6, 18, 53] \offset -> do
execSql pool ("UPDATE shomei.shomei_totp_credentials SET secret_enc = set_byte(secret_enc, " <> Text.pack (show (offset :: Int)) <> ", get_byte(secret_enc, " <> Text.pack (show offset) <> ") # 1)")
tampered <- runApp pool (findTotpByUser alice.userId)
assertBool "marker/nonce/ciphertext/tag tampering rejected" (isLeft tampered)
restore
execSql pool "UPDATE shomei.shomei_totp_credentials SET envelope_version = 0"
legacy <- runApp pool (findTotpByUser alice.userId)
assertBool "strict runtime never sniffs a legacy version" (isLeft legacy)
restore
changedId <- genTotpCredentialId
let newId = "'" <> Text.pack (show (totpCredentialIdToUUID changedId)) <> "'"
execSql pool ("UPDATE shomei.shomei_totp_credentials SET totp_credential_id = " <> newId <> " WHERE user_id = " <> aliceId)
relabeled <- runApp pool (findTotpByUser alice.userId)
assertBool "credential-id mutation rejected" (isLeft relabeled)
execSql pool "UPDATE shomei.shomei_totp_credentials SET totp_credential_id = saved.totp_credential_id FROM saved WHERE shomei_totp_credentials.user_id = saved.user_id"
replacement <-
expectApp =<< runApp pool do
tcid <- genTotpCredentialId
t <- now
c <- upsertTotpEnrollment NewTotpCredential {totpCredentialId = tcid, userId = alice.userId, secret = TotpSecret totpRawSecret, createdAt = t}
found <- findTotpByUser alice.userId
pure (c, found)
fmap (\TotpCredential {totpCredentialId} -> totpCredentialId) (snd replacement)
@?= Just (case fst replacement of TotpCredential {totpCredentialId} -> totpCredentialId)
-- Legacy format is deliberately constructed only in tests, never through a runtime writer.
legacyTotpBlob :: ByteString
legacyTotpBlob = case cipherInit (BS.replicate 32 7) >>= (\cipher -> aeadInit AEAD_GCM cipher (BS.replicate 12 3)) :: CryptoFailable (AEAD AES256) of
CryptoFailed _ -> error "test-only AES initialization failed"
CryptoPassed st ->
let (tag, ciphertext) = aeadSimpleEncrypt st (BS.empty :: ByteString) totpRawSecret 16
in BS.replicate 12 3 <> ciphertext <> BA.convert (unAuthTag tag)
testTotpEnvelopeConversion :: TestTree
testTotpEnvelopeConversion =
testCase "totp conversion is keyless-checkable, resumable, strict and nonce-fresh" $ withDb \pool -> do
uid <-
expectApp =<< runApp pool do
a <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})
tcid <- genTotpCredentialId
t <- now
_ <- upsertTotpEnrollment NewTotpCredential {totpCredentialId = tcid, userId = a.userId, secret = TotpSecret totpRawSecret, createdAt = t}
pure a.userId
let seed =
preparable
"UPDATE shomei.shomei_totp_credentials SET secret_enc = $1, envelope_version = 0"
(E.param (E.nonNullable E.bytea))
D.noResult
_ <- expectRight =<< Pool.use pool (Session.statement legacyTotpBlob seed)
checkTotpEnvelopeVersions pool >>= (@?= Right (1, 0))
wrongKey <- expectRight (totpEncryptionKeyFromBytes (BS.replicate 32 8))
failed <- migrateTotpEnvelopeBatch wrongKey pool
assertBool "wrong key fails without changing rows" (isLeft failed)
checkTotpEnvelopeVersions pool >>= (@?= Right (1, 0))
execSql pool "UPDATE shomei.shomei_totp_credentials SET secret_enc = set_byte(secret_enc, 47, get_byte(secret_enc, 47) # 1)"
corrupt <- migrateTotpEnvelopeBatch testTotpKey pool
assertBool "invalid legacy tag leaves the row unchanged" (isLeft corrupt)
checkTotpEnvelopeVersions pool >>= (@?= Right (1, 0))
_ <- expectRight =<< Pool.use pool (Session.statement legacyTotpBlob seed)
migrateTotpEnvelopeBatch testTotpKey pool >>= (@?= Right 1)
checkTotpEnvelopeVersions pool >>= (@?= Right (0, 0))
migrateTotpEnvelopeBatch testTotpKey pool >>= (@?= Right 0)
actual <- expectApp =<< runApp pool (findTotpByUser uid)
fmap tcSecret actual @?= Just (TotpSecret totpRawSecret)
stored <- scalarBytea pool "SELECT secret_enc FROM shomei.shomei_totp_credentials LIMIT 1"
assertBool "conversion uses a fresh nonce" (BS.take 12 (BS.drop 6 stored) /= BS.take 12 legacyTotpBlob)
testTotpConversionBatches :: TestTree
testTotpConversionBatches =
testCase "totp conversion resumes after 100 rows and preserves pending/confirmed state" $ withDb \pool -> do
_ <-
expectApp =<< runApp pool do
forM_ [1 .. 101 :: Int] \i -> do
lid <- either (error . show) pure (mkLoginId ("totp-batch-" <> Text.pack (show i)))
u <- createUser (NewUser {loginId = lid, email = Nothing, displayName = Nothing})
tcid <- genTotpCredentialId
t <- now
_ <- upsertTotpEnrollment NewTotpCredential {totpCredentialId = tcid, userId = u.userId, secret = TotpSecret totpRawSecret, createdAt = t}
when (even i) (confirmTotp tcid t)
let seed =
preparable
"UPDATE shomei.shomei_totp_credentials SET secret_enc = $1, envelope_version = 0"
(E.param (E.nonNullable E.bytea))
D.noResult
_ <- expectRight =<< Pool.use pool (Session.statement legacyTotpBlob seed)
migrateTotpEnvelopeBatch testTotpKey pool >>= (@?= Right 100)
checkTotpEnvelopeVersions pool >>= (@?= Right (1, 0))
-- An interruption here requires no retained process state or cursor.
migrateTotpEnvelopeBatch testTotpKey pool >>= (@?= Right 1)
checkTotpEnvelopeVersions pool >>= (@?= Right (0, 0))
scalarInt pool "SELECT count(*) FROM shomei.shomei_totp_credentials WHERE confirmed_at IS NOT NULL" >>= (@?= 50)
scalarInt pool "SELECT count(DISTINCT substring(secret_enc FROM 7 FOR 12)) FROM shomei.shomei_totp_credentials" >>= (@?= 101)
testTotpConvertedFactor :: TestTree
testTotpConvertedFactor =
testCase "totp factor completion succeeds with the same secret before and after offline conversion" $ withDb \pool -> do
u <-
expectApp =<< runAppAtTime t0 pool do
a <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})
tcid <- genTotpCredentialId
_ <- upsertTotpEnrollment NewTotpCredential {totpCredentialId = tcid, userId = a.userId, secret = TotpSecret totpRawSecret, createdAt = t0}
confirmTotp tcid t0
pure a
let completeAt ts = do
result <- runAppAtTime ts pool do
(cid, _, methods) <- prepareMfaChallenge cfg u ts
liftIO (assertBool "TOTP offered" ("totp" `elem` methods))
completeMfa
cfg
(ProofContext (ClientIp "test-ip") AccountKey)
cid
(MfaTotp (totpCode 6 (TotpSecret totpRawSecret) (totpCounter ts)))
_ <- expectApp result >>= expectRight
pure ()
completeAt t0
let seed =
preparable
"UPDATE shomei.shomei_totp_credentials SET secret_enc = $1, envelope_version = 0"
(E.param (E.nonNullable E.bytea))
D.noResult
_ <- expectRight =<< Pool.use pool (Session.statement legacyTotpBlob seed)
migrateTotpEnvelopeBatch testTotpKey pool >>= (@?= Right 1)
completeAt (addUTCTime 30 t0)
testTotpConversionConflict :: TestTree
testTotpConversionConflict =
testCase "totp converter CAS preserves enrollment changed after its snapshot" $
withShomeiMigratedDatabase \connStr -> do
pool <- acquirePool 4 10 30000 connStr
gatePool <- acquirePool 1 10 30000 connStr
u <-
expectApp =<< runApp pool do
a <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})
tcid <- genTotpCredentialId
t <- now
_ <- upsertTotpEnrollment NewTotpCredential {totpCredentialId = tcid, userId = a.userId, secret = TotpSecret totpRawSecret, createdAt = t}
pure a
let seed =
preparable
"UPDATE shomei.shomei_totp_credentials SET secret_enc = $1, envelope_version = 0"
(E.param (E.nonNullable E.bytea))
D.noResult
awaitLock sql =
let loop n = do
count <- scalarInt pool sql
if count > 0
then pure ()
else
if n == (0 :: Int) then assertFailure "advisory-lock barrier not reached" else threadDelay 10000 >> loop (n - 1)
in loop 500
_ <- expectRight =<< Pool.use pool (Session.statement legacyTotpBlob seed)
-- A separate one-connection pool holds a session lock that gates the converter lock.
execSql gatePool "SELECT pg_advisory_lock(1936224116, 2)"
blocker <- newEmptyMVar
_ <- forkIO $ do
result <- Pool.use pool (Session.script "BEGIN; SELECT pg_advisory_xact_lock(1936224116, 1); SELECT pg_advisory_xact_lock(1936224116, 2); COMMIT")
putMVar blocker result
awaitLock "SELECT count(*) FROM pg_locks WHERE locktype = 'advisory' AND classid = 1936224116 AND objid = 1 AND granted"
converted <- newEmptyMVar
_ <- forkIO (putMVar converted =<< migrateTotpEnvelopeBatch testTotpKey pool)
awaitLock "SELECT count(*) FROM pg_locks WHERE locktype = 'advisory' AND classid = 1936224116 AND objid = 1 AND NOT granted"
fresh <-
expectApp =<< runApp pool do
tcid <- genTotpCredentialId
t <- now
upsertTotpEnrollment NewTotpCredential {totpCredentialId = tcid, userId = u.userId, secret = TotpSecret "new enrollment secret", createdAt = t}
execSql gatePool "SELECT pg_advisory_unlock(1936224116, 2)"
_ <- expectRight =<< takeMVar blocker
takeMVar converted >>= (@?= Right 0)
stored <- expectApp =<< runApp pool (findTotpByUser u.userId)
fmap tcSecret stored @?= Just (tcSecret fresh)
Pool.release gatePool
Pool.release pool
-- | The recovery-code store's contract: a replaced set is the live set, consumption is a
-- consume-once compare-and-set, the unused count tracks it, and regeneration drops the old set.
testRecoveryCodeCasAndReplace :: TestTree
testRecoveryCodeCasAndReplace =
testCase "recovery codes: replace-set, consume-once CAS, count drops, regeneration replaces" $ withDb \pool -> do
result <- runApp pool do
u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})
t <- now
ids <- replicateM 3 genRecoveryCodeId
let mk i h = NewRecoveryCode {recoveryCodeId = i, codeHash = h, createdAt = t}
codes = zipWith mk ids ["h1", "h2", "h3"]
replaceRecoveryCodes u.userId codes
countBefore <- countUnusedRecoveryCodes u.userId
firstConsume <- consumeRecoveryCode u.userId "h1" t
secondConsume <- consumeRecoveryCode u.userId "h1" t
countAfter <- countUnusedRecoveryCodes u.userId
ids2 <- replicateM 2 genRecoveryCodeId
replaceRecoveryCodes u.userId (zipWith mk ids2 ["n1", "n2"])
countAfterReplace <- countUnusedRecoveryCodes u.userId
oldConsume <- consumeRecoveryCode u.userId "h2" t
pure (countBefore, firstConsume, secondConsume, countAfter, countAfterReplace, oldConsume)
(countBefore, firstConsume, secondConsume, countAfter, countAfterReplace, oldConsume) <- expectApp result
countBefore @?= 3
firstConsume @?= True
secondConsume @?= False
countAfter @?= 2
countAfterReplace @?= 2
oldConsume @?= False
testUserRoundTrip :: TestTree
testUserRoundTrip = testCase "create + find user round-trips" $ withDb \pool -> do
result <- runApp pool do
u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Just "Alice"})
byId <- findUserById u.userId
byEmail <- findUserByEmail aliceEmail
pure (u, byId, byEmail)
(u, byId, byEmail) <- expectApp result
fmap (.userId) byId @?= Just u.userId
fmap (.loginId) byId @?= Just aliceLogin
fmap (.email) byId @?= Just (Just aliceEmail)
fmap (.displayName) byId @?= Just (Just "Alice")
fmap (.userId) byEmail @?= Just u.userId
-- | The M3 acceptance: a user can be created with NO email, round-trips by login id with
-- @email IS NULL@, the @login_id@ unique index rejects a duplicate principal, and the
-- partial unique index on @email@ permits multiple NULL emails.
testUserNoEmailAndUniqueLoginId :: TestTree
testUserNoEmailAndUniqueLoginId =
testCase "user: NULL email round-trips; login_id unique; NULL emails don't collide" $ withDb \pool -> do
let svc = mkLoginId' "svc-bot"
svc2 = mkLoginId' "svc-bot-2"
created <- runApp pool do
u <- createUser (NewUser {loginId = svc, email = Nothing, displayName = Nothing})
byLogin <- findUserByLoginId svc
pure (u, byLogin)
(u, byLogin) <- expectApp created
fmap (.email) byLogin @?= Just Nothing
fmap (.loginId) byLogin @?= Just svc
fmap (.userId) byLogin @?= Just u.userId
-- Unique-index conflicts retain their domain meaning at the persistence boundary.
dup <- runApp pool (createUser (NewUser {loginId = svc, email = Nothing, displayName = Nothing}))
dup @?= Left LoginIdAlreadyRegistered
-- a second no-email user with a distinct login id is allowed: NULL emails don't collide
second <- runApp pool (createUser (NewUser {loginId = svc2, email = Nothing, displayName = Nothing}))
_ <- expectApp second
nullEmails <- scalarInt pool "SELECT count(*) FROM shomei.shomei_users WHERE email IS NULL"
nullEmails @?= 2
_ <- expectApp =<< runApp pool (createUser (NewUser {loginId = mkLoginId' "email-owner", email = Just aliceEmail, displayName = Nothing}))
dupEmail <- runApp pool (createUser (NewUser {loginId = mkLoginId' "email-collider", email = Just aliceEmail, displayName = Nothing}))
dupEmail @?= Left EmailAlreadyRegistered
-- | The database remains a trust boundary even for writers that bypass Shomei's codecs.
-- Invalid persisted vocabulary is a CHECK violation, while login ids and email addresses are
-- unique independently of case.
testSchemaRejectsInvalidUserStatusAndCaseVariantIdentities :: TestTree
testSchemaRejectsInvalidUserStatusAndCaseVariantIdentities =
testCase "schema rejects invalid user status and case-variant identities" $ withDb \pool -> do
execSql
pool
"""
INSERT INTO shomei.shomei_users
(user_id, email, display_name, status, created_at, updated_at, login_id)
VALUES
('11111111-1111-1111-1111-111111111111', 'alice@example.com', 'Alice', 'active', now(), now(), 'alice');
"""
execSqlExpectState
pool
"23514"
"""
INSERT INTO shomei.shomei_users
(user_id, email, display_name, status, created_at, updated_at, login_id)
VALUES
('22222222-2222-2222-2222-222222222222', 'bogus@example.com', NULL, 'bogus', now(), now(), 'bogus');
"""
execSqlExpectState
pool
"23505"
"""
INSERT INTO shomei.shomei_users
(user_id, email, display_name, status, created_at, updated_at, login_id)
VALUES
('33333333-3333-3333-3333-333333333333', 'Alice@Example.com', NULL, 'active', now(), now(), 'other-login');
"""
execSqlExpectState
pool
"23505"
"""
INSERT INTO shomei.shomei_users
(user_id, email, display_name, status, created_at, updated_at, login_id)
VALUES
('44444444-4444-4444-4444-444444444444', 'other@example.com', NULL, 'active', now(), now(), 'Alice');
"""
-- | The admin listing's three promises, against the real statement: newest-first order, the
-- status filter, and a keyset walk that is both disjoint and complete.
--
-- The walk matters more than it looks. An OFFSET pager over @ORDER BY created_at DESC@ would
-- pass a two-page test on distinct timestamps and silently skip or repeat rows the moment two
-- users share one — which is exactly what a bulk import produces. The cursor compares the whole
-- @(created_at, user_id)@ tuple, so this test seeds three users and asserts the pages partition
-- them.
testListUsersOrderFilterAndPaging :: TestTree
testListUsersOrderFilterAndPaging = testCase "listUsers: newest-first, status-filtered, keyset-paged" $ withDb \pool -> do
result <- runApp pool do
u1 <- createUser (NewUser {loginId = mkLoginId' "one", email = Nothing, displayName = Nothing})
u2 <- createUser (NewUser {loginId = mkLoginId' "two", email = Nothing, displayName = Nothing})
u3 <- createUser (NewUser {loginId = mkLoginId' "three", email = Nothing, displayName = Nothing})
ts <- now
_ <- updateUserStatus u2.userId [UserActive] UserSuspended ts
everyone <- listUsers emptyUserListQuery
suspended <- listUsers emptyUserListQuery {queryStatus = Just UserSuspended}
active <- listUsers emptyUserListQuery {queryStatus = Just UserActive}
page1 <- listUsers emptyUserListQuery {queryLimit = 2}
page2 <- case reverse page1 of
[] -> pure []
(lastUser : _) ->
listUsers
emptyUserListQuery
{ queryLimit = 2,
queryBefore = Just (UserCursor {cursorCreatedAt = lastUser.createdAt, cursorUserId = lastUser.userId})
}
pure (u1, u2, u3, everyone, suspended, active, page1, page2)
(u1, u2, u3, everyone, suspended, active, page1, page2) <- expectApp result
-- Newest first. Rows created in one transaction can share a created_at, so assert on the set
-- and on the ordering key rather than on a fixed permutation.
map (.userId) everyone `shouldContainExactly` [u1.userId, u2.userId, u3.userId]
assertBool "newest-first" (isDescending (map (\u -> (u.createdAt, u.userId)) everyone))
map (.userId) suspended @?= [u2.userId]
map (.userId) active `shouldContainExactly` [u1.userId, u3.userId]
-- The keyset walk partitions the users: no overlap, nothing lost.
length page1 @?= 2
length page2 @?= 1
(map (.userId) page1 <> map (.userId) page2) `shouldContainExactly` [u1.userId, u2.userId, u3.userId]
testUserStatusIsCompareAndSwap :: TestTree
testUserStatusIsCompareAndSwap =
testCase "user status changes only from an allowed current status" $ withDb \pool -> do
result <- runApp pool do
user <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})
first <- updateUserStatus user.userId [UserActive] UserSuspended t0
second <- updateUserStatus user.userId [UserActive] UserSuspended t0
stored <- findUserById user.userId
pure (first, second, stored)
(first, second, stored) <- expectApp result
(first, second) @?= (True, False)
fmap (.status) stored @?= Just UserSuspended
testUserStatusCasUnderRace :: TestTree
testUserStatusCasUnderRace =
testCase "user status: eight racing suspends have one winner" $ withDb \pool -> do
seeded <- runApp pool do
user <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})
pure user.userId
uid <- expectApp seeded
gate <- newEmptyMVar
dones <- replicateM 8 do
done <- newEmptyMVar
_ <- forkIO do
readMVar gate
putMVar done =<< runApp pool (updateUserStatus uid [UserActive] UserSuspended t0)
pure done
putMVar gate ()
results <- traverse (\done -> expectApp =<< takeMVar done) dones
length (filter id results) @?= 1
testListSessionsForUser :: TestTree
testListSessionsForUser = testCase "listSessionsForUser returns every status, newest-first, for one user only" $ withDb \pool -> do
result <- runApp pool do
alice <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})
bob <- createUser (NewUser {loginId = bobLogin, email = Just bobEmail, displayName = Nothing})
t <- now
s1 <- createSession (NewSession {userId = alice.userId, createdAt = t, expiresAt = addUTCTime 3600 t, actor = Nothing, oauthClientId = Nothing, kind = InteractiveSession, grantedScopes = Set.empty, authenticatedAt = t, remembered = False})
s2 <- createSession (NewSession {userId = alice.userId, createdAt = addUTCTime 1 t, expiresAt = addUTCTime 3600 t, actor = Nothing, oauthClientId = Nothing, kind = InteractiveSession, grantedScopes = Set.empty, authenticatedAt = addUTCTime 1 t, remembered = False})
_ <- createSession (NewSession {userId = bob.userId, createdAt = t, expiresAt = addUTCTime 3600 t, actor = Nothing, oauthClientId = Nothing, kind = InteractiveSession, grantedScopes = Set.empty, authenticatedAt = t, remembered = False})
revokeSession s1.sessionId t
aliceSessions <- listSessionsForUser alice.userId
pure (s1, s2, aliceSessions)
(s1, s2, aliceSessions) <- expectApp result
-- Bob's session is absent; a revoked session is still listed (an admin must see it).
map (.sessionId) aliceSessions @?= [s2.sessionId, s1.sessionId]
map (.status) aliceSessions @?= [SessionActive, SessionRevoked]
-- | Set equality with a readable failure, without imposing an order.
shouldContainExactly :: (Ord a, Show a) => [a] -> [a] -> Assertion
shouldContainExactly actual expected = sort actual @?= sort expected
isDescending :: (Ord a) => [a] -> Bool
isDescending xs = and (zipWith (>=) xs (drop 1 xs))
testCredentialRoundTrip :: TestTree
testCredentialRoundTrip = testCase "create credential + find-by-email" $ withDb \pool -> do
result <- runApp pool do
u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})
h <- hashPassword strongPw
_ <- createPasswordCredential u.userId aliceLogin (Just aliceEmail) h
byEmail <- findPasswordCredentialByEmail aliceEmail
byLogin <- findPasswordCredentialByLoginId aliceLogin
pure (u, h, byEmail, byLogin)
(u, h, byEmail, byLogin) <- expectApp result
fmap (.userId) byEmail @?= Just u.userId
fmap (.email) byEmail @?= Just (Just aliceEmail)
fmap (.passwordHash) byEmail @?= Just h
fmap (.userId) byLogin @?= Just u.userId
fmap (.loginId) byLogin @?= Just aliceLogin
duplicateLogin <- runApp pool (createPasswordCredential u.userId aliceLogin (Just bobEmail) h)
duplicateLogin @?= Left LoginIdAlreadyRegistered
duplicateEmail <- runApp pool (createPasswordCredential u.userId bobLogin (Just aliceEmail) h)
duplicateEmail @?= Left EmailAlreadyRegistered
testCredentialUniquePerUser :: TestTree
testCredentialUniquePerUser = testCase "one password credential per user is a database invariant" $ withDb \pool -> do
execSql
pool
"INSERT INTO shomei.shomei_users (user_id, login_id, email, status, created_at, updated_at) VALUES ('10000000-0000-0000-0000-000000000001', 'unique-owner', 'unique-owner@example.com', 'active', now(), now()); INSERT INTO shomei.shomei_password_credentials (credential_id, user_id, login_id, email, password_hash, created_at, updated_at) VALUES ('20000000-0000-0000-0000-000000000001', '10000000-0000-0000-0000-000000000001', 'unique-owner', 'unique-owner@example.com', 'hash-one', now(), now())"
duplicate <-
Pool.use
pool
( Session.script
"INSERT INTO shomei.shomei_password_credentials (credential_id, user_id, login_id, email, password_hash, created_at, updated_at) VALUES ('20000000-0000-0000-0000-000000000002', '10000000-0000-0000-0000-000000000001', 'unique-owner-two', 'unique-owner-two@example.com', 'hash-two', now(), now())"
)
case duplicate of
Left err ->
assertBool
("expected the user_id unique index, got: " <> show err)
("23505" `Text.isInfixOf` Text.pack (show err) || "shomei_password_credentials_user_id_key" `Text.isInfixOf` Text.pack (show err))
Right () -> assertFailure "a second password credential for one user was accepted"
scalarInt
pool
"SELECT count(*) FROM pg_indexes WHERE schemaname = 'shomei' AND indexname = 'shomei_password_credentials_user_id_key'"
>>= (@?= 1)
testPoolStatementTimeoutIsApplied :: TestTree
testPoolStatementTimeoutIsApplied = testCase "pool connections bound statements and idle transactions" $
withShomeiMigratedDatabase \connStr -> do
pool <- acquirePool 1 10 200 connStr
configured <- Pool.use pool (Session.statement () timeoutSettingsStatement)
either (assertFailure . ("could not read pool timeout settings: " <>) . show) pure configured
>>= (@?= ("200ms", "200ms"))
statementResult <- Pool.use pool (Session.script "SELECT pg_sleep(1)")
assertPoolFailureMentions ["57014", "statement timeout"] statementResult
beginResult <- Pool.use pool (Session.script "BEGIN")
either (assertFailure . ("could not begin idle-timeout probe: " <>) . show) pure beginResult
threadDelay 400000
idleResult <- Pool.use pool (Session.script "SELECT 1")
case idleResult of
Left _ -> pure ()
Right () -> assertFailure "the connection survived past idle_in_transaction_session_timeout"
Pool.release pool
where
timeoutSettingsStatement =
preparable
"SELECT current_setting('statement_timeout'), current_setting('idle_in_transaction_session_timeout')"
E.noParams
(D.singleRow ((,) <$> D.column (D.nonNullable D.text) <*> D.column (D.nonNullable D.text)))
assertPoolFailureMentions needles = \case
Left err ->
assertBool
("expected one of " <> show needles <> " in pool failure: " <> show err)
(any (\needle -> Text.toLower needle `Text.isInfixOf` Text.toLower (Text.pack (show err))) needles)
Right () -> assertFailure ("expected PostgreSQL timeout failure mentioning one of " <> show needles)
testSessionRevoke :: TestTree
testSessionRevoke = testCase "create session + revoke" $ withDb \pool -> do
result <- runApp pool do
u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})
t <- now
s <- createSession (NewSession {userId = u.userId, createdAt = t, expiresAt = addUTCTime 3600 t, actor = Nothing, oauthClientId = Nothing, kind = InteractiveSession, grantedScopes = Set.empty, authenticatedAt = t, remembered = False})
revokeSession s.sessionId t
revokeSession s.sessionId (addUTCTime 60 t)
findSessionById s.sessionId
found <- expectApp result
fmap (.status) found @?= Just SessionRevoked
fmap (.revokedAt) found @?= fmap (Just . (.createdAt)) found
testSessionActorRoundTrip :: TestTree
testSessionActorRoundTrip = testCase "create delegated session persists actor" $ withDb \pool -> do
result <- runApp pool do
subject <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})
operator <- createUser (NewUser {loginId = bobLogin, email = Just bobEmail, displayName = Nothing})
t <- now
delegated <-
createSession
( NewSession
{ userId = subject.userId,
createdAt = t,
expiresAt = addUTCTime 3600 t,
actor = Just operator.userId,
oauthClientId = Nothing,
kind = DelegatedSession,
grantedScopes = Set.empty,
authenticatedAt = t,
remembered = False
}
)
normal <- createSession (NewSession {userId = subject.userId, createdAt = t, expiresAt = addUTCTime 3600 t, actor = Nothing, oauthClientId = Nothing, kind = InteractiveSession, grantedScopes = Set.empty, authenticatedAt = t, remembered = False})
foundDelegated <- findSessionById delegated.sessionId
foundNormal <- findSessionById normal.sessionId
pure (operator.userId, foundDelegated, foundNormal)
(op, foundDelegated, foundNormal) <- expectApp result
fmap (.actor) foundDelegated @?= Just (Just op)
fmap (.actor) foundNormal @?= Just Nothing
testSessionKindRoundTrip :: TestTree
testSessionKindRoundTrip = testCase "create session persists its kind (machine, delegated, interactive)" $ withDb \pool -> do
result <- runApp pool do
subject <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})
t <- now
interactive <- createSession (NewSession {userId = subject.userId, createdAt = t, expiresAt = addUTCTime 3600 t, actor = Nothing, oauthClientId = Nothing, kind = InteractiveSession, grantedScopes = Set.empty, authenticatedAt = t, remembered = False})
machine <- createSession (NewSession {userId = subject.userId, createdAt = t, expiresAt = addUTCTime 3600 t, actor = Nothing, oauthClientId = Nothing, kind = MachineSession, grantedScopes = Set.empty, authenticatedAt = t, remembered = False})
delegated <- createSession (NewSession {userId = subject.userId, createdAt = t, expiresAt = addUTCTime 3600 t, actor = Just subject.userId, oauthClientId = Nothing, kind = DelegatedSession, grantedScopes = Set.empty, authenticatedAt = t, remembered = False})
foundInteractive <- findSessionById interactive.sessionId
foundMachine <- findSessionById machine.sessionId
foundDelegated <- findSessionById delegated.sessionId
pure (foundInteractive, foundMachine, foundDelegated)
(foundInteractive, foundMachine, foundDelegated) <- expectApp result
fmap (.kind) foundInteractive @?= Just InteractiveSession
fmap (.kind) foundMachine @?= Just MachineSession
fmap (.kind) foundDelegated @?= Just DelegatedSession
testSessionGrantedScopesRoundTrip :: TestTree
testSessionGrantedScopesRoundTrip = testCase "session scopes and auth time round-trip; legacy values fall back" $ withDb \pool -> do
let granted = Set.fromList [Scope "openid", Scope "kawa:read"]
created <- runApp pool do
user <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})
t <- now
let authenticated = addUTCTime (-30) t
session <-
createSession
NewSession
{ userId = user.userId,
createdAt = t,
expiresAt = addUTCTime 3600 t,
actor = Nothing,
oauthClientId = Just "oauthclient_roundtrip",
kind = InteractiveSession,
grantedScopes = granted,
authenticatedAt = authenticated,
remembered = False
}
found <- findSessionById session.sessionId
pure (session.sessionId, authenticated, found)
(sessionId, authenticated, found) <- expectApp created
fmap (.grantedScopes) found @?= Just granted
fmap (.authenticatedAt) found @?= Just authenticated
execSql pool "UPDATE shomei.shomei_sessions SET authenticated_at = NULL"
legacy <- expectApp =<< runApp pool (findSessionById sessionId)
fmap (.authenticatedAt) legacy @?= fmap (.createdAt) legacy
execSql
pool
"""
INSERT INTO shomei.shomei_sessions
(session_id, user_id, status, created_at, expires_at, kind)
SELECT
'00000000-0000-4000-8000-000000000052'::uuid,
user_id,
'active',
now(),
now() + interval '1 hour',
'interactive'
FROM shomei.shomei_users
LIMIT 1
"""
defaulted <- scalarInt pool "SELECT count(*) FROM shomei.shomei_sessions WHERE granted_scopes = '{}'::text[]"
defaulted @?= 1
testSessionRememberedRoundTrip :: TestTree
testSessionRememberedRoundTrip = testCase "a session's remembered flag round-trips; rows from before the column read remembered" $ withDb \pool -> do
created <- runApp pool do
user <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})
t <- now
let new remembered =
NewSession
{ userId = user.userId,
createdAt = t,
expiresAt = addUTCTime 3600 t,
actor = Nothing,
oauthClientId = Nothing,
kind = InteractiveSession,
grantedScopes = Set.empty,
authenticatedAt = t,
remembered
}
rememberedSession <- createSession (new True)
forgottenSession <- createSession (new False)
(,) <$> findSessionById rememberedSession.sessionId <*> findSessionById forgottenSession.sessionId
(foundRemembered, foundForgotten) <- expectApp created
fmap (.remembered) foundRemembered @?= Just True
fmap (.remembered) foundForgotten @?= Just False
execSql
pool
"""
INSERT INTO shomei.shomei_sessions
(session_id, user_id, status, created_at, expires_at, kind)
SELECT
'00000000-0000-4000-8000-000000000053'::uuid,
user_id,
'active',
now(),
now() + interval '1 hour',
'interactive'
FROM shomei.shomei_users
LIMIT 1
"""
defaulted <- scalarInt pool "SELECT count(*) FROM shomei.shomei_sessions WHERE remembered"
defaulted @?= 2
testSessionKindNullFailsClosed :: TestTree
testSessionKindNullFailsClosed = testCase "NULL session provenance is rejected by the schema and fails closed after constraint bypass" $ withDb \pool -> do
created <- runApp pool do
user <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})
t <- now
createSession (NewSession {userId = user.userId, createdAt = t, expiresAt = addUTCTime 3600 t, actor = Nothing, oauthClientId = Nothing, kind = InteractiveSession, grantedScopes = Set.empty, authenticatedAt = t, remembered = False})
session <- expectApp created
execSqlExpectState pool "23502" "UPDATE shomei.shomei_sessions SET kind = NULL"
execSql pool "ALTER TABLE shomei.shomei_sessions ALTER COLUMN kind DROP NOT NULL; UPDATE shomei.shomei_sessions SET kind = NULL"
found <- runApp pool (findSessionById session.sessionId)
case found of
Left (Err.InternalAuthError _) -> pure ()
_ -> assertFailure "missing provenance must never decode as interactive"
-- | Pins the compare-and-swap semantics of the @UPDATE … AND status = 'active' RETURNING@
-- statement: the first mark wins and stamps @used_at@, a second mark of the same token loses
-- and leaves the row (including the winner's @used_at@) untouched. This is the statement-level
-- guarantee that makes two concurrent refreshes of one token impossible to both succeed.
testRefreshTokenMarkUsed :: TestTree
testRefreshTokenMarkUsed = testCase "refresh token: find-by-hash + mark-used is a compare-and-swap" $ withDb \pool -> do
result <- runApp pool do
u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})
t <- now
s <- createSession (NewSession {userId = u.userId, createdAt = t, expiresAt = addUTCTime 3600 t, actor = Nothing, oauthClientId = Nothing, kind = InteractiveSession, grantedScopes = Set.empty, authenticatedAt = t, remembered = False})
h <- hashRefreshToken (RefreshToken "token-1")
persisted <-
createRefreshToken
NewRefreshToken
{ sessionId = s.sessionId,
tokenHash = h,
parentTokenId = Nothing,
createdAt = t,
expiresAt = addUTCTime 86400 t
}
beforeUse <- findRefreshTokenByHash h
firstMark <- markRefreshTokenUsed persisted.refreshTokenId t
afterUse <- findRefreshTokenByHash h
secondMark <- markRefreshTokenUsed persisted.refreshTokenId (addUTCTime 60 t)
afterSecond <- findRefreshTokenByHash h
pure (beforeUse, afterUse, firstMark, secondMark, afterSecond)
(beforeUse, afterUse, firstMark, secondMark, afterSecond) <- expectApp result
fmap (.status) beforeUse @?= Just RefreshTokenActive
fmap (.status) afterUse @?= Just RefreshTokenUsed
firstMark @?= True
secondMark @?= False
-- The loser overwrote nothing: the row still carries the winner's used_at.
fmap (.usedAt) afterSecond @?= fmap (.usedAt) afterUse
fmap (.status) afterSecond @?= Just RefreshTokenUsed
testVerificationTokenRoundTrip :: TestTree
testVerificationTokenRoundTrip = testCase "verification token: consume is a compare-and-swap" $ withDb \pool -> do
result <- runApp pool do
u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})
t <- now
let h = OneTimeTokenHash "hash:verify-1"
persisted <-
createVerificationToken
NewVerificationToken
{ userId = u.userId,
tokenHash = h,
createdAt = t,
expiresAt = addUTCTime 3600 t
}
before <- findVerificationTokenByHash h
firstConsume <- markVerificationTokenConsumed persisted.verificationTokenId t
after <- findVerificationTokenByHash h
secondConsume <- markVerificationTokenConsumed persisted.verificationTokenId (addUTCTime 60 t)
afterSecond <- findVerificationTokenByHash h
pure (before, after, firstConsume, secondConsume, afterSecond)
(before, after, firstConsume, secondConsume, afterSecond) <- expectApp result
fmap (.status) before @?= Just OneTimeTokenActive
fmap (.status) after @?= Just OneTimeTokenConsumed
firstConsume @?= True
secondConsume @?= False
fmap (.consumedAt) afterSecond @?= fmap (.consumedAt) after
testPasswordResetTokenRoundTrip :: TestTree
testPasswordResetTokenRoundTrip = testCase "password reset token: consume is a compare-and-swap" $ withDb \pool -> do
result <- runApp pool do
u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})
t <- now
let h = OneTimeTokenHash "hash:reset-1"
persisted <-
createPasswordResetToken
NewPasswordResetToken
{ userId = u.userId,
tokenHash = h,
createdAt = t,
expiresAt = addUTCTime 3600 t
}
before <- findPasswordResetTokenByHash h
firstConsume <- markPasswordResetTokenConsumed persisted.passwordResetTokenId t
after <- findPasswordResetTokenByHash h
secondConsume <- markPasswordResetTokenConsumed persisted.passwordResetTokenId (addUTCTime 60 t)
afterSecond <- findPasswordResetTokenByHash h
pure (before, after, firstConsume, secondConsume, afterSecond)
(before, after, firstConsume, secondConsume, afterSecond) <- expectApp result
fmap (.status) before @?= Just OneTimeTokenActive
fmap (.status) after @?= Just OneTimeTokenConsumed
firstConsume @?= True
secondConsume @?= False
fmap (.consumedAt) afterSecond @?= fmap (.consumedAt) after
testMarkUserEmailVerified :: TestTree
testMarkUserEmailVerified = testCase "mark user email verified sets the timestamp" $ withDb \pool -> do
result <- runApp pool do
u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})
t <- now
markUserEmailVerified u.userId t
findUserById u.userId
found <- expectApp result
assertBool "email_verified_at is populated" (maybe False (isJust . (.emailVerifiedAt)) found)
testSigningKeys :: TestTree
testSigningKeys = testCase "insert + list signing keys" $ withDb \pool -> do
result <- runApp pool do
t <- now
let key =
StoredSigningKey
{ keyId = "kid-1",
algorithm = "ES256",
publicKeyJwk = "{\"kty\":\"EC\"}",
privateKeyJwk = "{\"kty\":\"EC\",\"d\":\"x\"}",
status = KeyActive,
createdAt = t,
activatedAt = Just t,
retiredAt = Nothing,
revokedAt = Nothing
}
insertSigningKey key
active <- listActiveSigningKeys
byKid <- findSigningKeyByKid "kid-1"
pure (active, byKid)
(active, byKid) <- expectApp result
fmap (.keyId) active @?= ["kid-1"]
fmap (.keyId) byKid @?= Just "kid-1"
-- | @listPublishableSigningKeys@ returns exactly the active + retired keys (the JWKS
-- contents), while @listActiveSigningKeys@ still returns only the signing key.
testPublishableSigningKeys :: TestTree
testPublishableSigningKeys = testCase "publishable signing keys are active + retired" $ withDb \pool -> do
result <- runApp pool do
t <- now
let key kid st =
StoredSigningKey
{ keyId = kid,
algorithm = "ES256",
publicKeyJwk = "{\"kty\":\"EC\"}",
privateKeyJwk = "{\"kty\":\"EC\",\"d\":\"x\"}",
status = st,
createdAt = t,
activatedAt = Just t,
retiredAt = Nothing,
revokedAt = Nothing
}
-- Insert each row Pending, then drive it to its target status through the port, so
-- the test exercises updateSigningKeyStatus rather than trusting the insert.
forM_ [("k-active", KeyActive), ("k-retired", KeyRetired), ("k-revoked", KeyRevoked)] \(kid, st) -> do
insertSigningKey (key kid KeyPending)
updateSigningKeyStatus kid st t
insertSigningKey (key "k-pending" KeyPending)
publishable <- listPublishableSigningKeys
active <- listActiveSigningKeys
pure (publishable, active)
(publishable, active) <- expectApp result
sort (fmap (.keyId) publishable) @?= ["k-active", "k-retired"]
fmap (.keyId) active @?= ["k-active"]
testSigningKeyTransitionTimestamps :: TestTree
testSigningKeyTransitionTimestamps = testCase "signing-key transitions stamp activated, retired, and revoked times" $ withDb \pool -> do
let activated = t0
retired = addUTCTime 60 t0
revoked = addUTCTime 120 t0
key = signingKeyFixture "k-stamped" KeyPending t0
result <- runAppAtTime t0 pool do
insertSigningKey key
updateSigningKeyStatus key.keyId KeyActive activated
updateSigningKeyStatus key.keyId KeyRetired retired
updateSigningKeyStatus key.keyId KeyRevoked revoked
findSigningKeyByKid key.keyId
stored <- expectApp result >>= maybe (assertFailure "stamped signing key disappeared") pure
stored.activatedAt @?= Just activated
stored.retiredAt @?= Just retired
stored.revokedAt @?= Just revoked
testSigningKeyOneActiveInvariant :: TestTree
testSigningKeyOneActiveInvariant = testCase "one-active index rejects a second insert and atomic replacement retires the old key" $ withDb \pool -> do
let replacedAt = addUTCTime 60 t0
old = (signingKeyFixture "k-old" KeyActive t0) {activatedAt = Just t0}
new = signingKeyFixture "k-new" KeyActive replacedAt
expectApp =<< runAppAtTime t0 pool (insertSigningKey old)
duplicate <- runAppAtTime t0 pool (insertSigningKey new)
duplicate @?= Left (DependencyUnavailable PostgreSQL)
replacement <- runAppAtTime replacedAt pool do
replaceActiveSigningKey new replacedAt
active <- listActiveSigningKeys
oldAfter <- findSigningKeyByKid old.keyId
newAfter <- findSigningKeyByKid new.keyId
pure (active, oldAfter, newAfter)
(active, oldAfter, newAfter) <- expectApp replacement
fmap (.keyId) active @?= [new.keyId]
fmap (.status) oldAfter @?= Just KeyRetired
fmap (.retiredAt) oldAfter @?= Just (Just replacedAt)
fmap (.status) newAfter @?= Just KeyActive
fmap (.activatedAt) newAfter @?= Just (Just replacedAt)
signingKeyFixture :: Text -> SigningKeyStatus -> UTCTime -> StoredSigningKey
signingKeyFixture kid keyStatus created =
StoredSigningKey
{ keyId = kid,
algorithm = "ES256",
publicKeyJwk = "{\"kty\":\"EC\"}",
privateKeyJwk = "{\"kty\":\"EC\",\"d\":\"x\"}",
status = keyStatus,
createdAt = created,
activatedAt = Nothing,
retiredAt = Nothing,
revokedAt = Nothing
}
testPublishEvent :: TestTree
testPublishEvent = testCase "publish auth event lands a row" $ withDb \pool -> do
result <- runApp pool do
t <- now
publishAuthEvent (Event.LoginFailed (Event.LoginFailedData (Just (AccountKey "k-alice")) Nothing t))
_ <- expectApp result
n <- scalarInt pool "SELECT count(*) FROM shomei.shomei_auth_events"
n @?= 1
testAuditEventReader :: TestTree
testAuditEventReader = testCase "audit reader: filter + order + keyset pagination + reconstruct" $ withDb \pool -> do
let tt :: Int -> UTCTime
tt n = addUTCTime (fromIntegral n) t0
result <- runApp pool do
alice <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})
bob <- createUser (NewUser {loginId = bobLogin, email = Just bobEmail, displayName = Nothing})
s1 <- genSessionId
s2 <- genSessionId
-- Five events at strictly increasing times (newest = tt 4).
publishAuthEvent (Event.LoginFailed (Event.LoginFailedData (Just (AccountKey "k-alice")) (Just alice.userId) (tt 0)))
publishAuthEvent (Event.LoginSucceeded (Event.LoginSucceededData alice.userId s1 (tt 1)))
publishAuthEvent (Event.LoginFailed (Event.LoginFailedData (Just (AccountKey "k-bob")) (Just bob.userId) (tt 2)))
publishAuthEvent (Event.PasswordChanged (Event.PasswordChangedData alice.userId (tt 3)))
publishAuthEvent (Event.LoginSucceeded (Event.LoginSucceededData bob.userId s2 (tt 4)))
allEvents <- queryAuthEvents emptyAuditQuery
aliceEvents <- queryAuthEvents emptyAuditQuery {queryUserId = Just (userIdToUUID alice.userId)}
failedEvents <- queryAuthEvents emptyAuditQuery {queryEventTypes = ["login_failed"]}
windowEvents <- queryAuthEvents emptyAuditQuery {querySince = Just (tt 1), queryUntil = Just (tt 3)}
total <- countAuthEvents emptyAuditQuery
failedTotal <- countAuthEvents emptyAuditQuery {queryEventTypes = ["login_failed"]}
page1 <- queryAuthEvents emptyAuditQuery {queryLimit = 2}
page2 <- case page1 of
[] -> pure []
rows ->
let lastRow = last rows
cur = AuditCursor (storedCreatedAt lastRow) (storedEventId lastRow)
in queryAuthEvents emptyAuditQuery {queryLimit = 2, queryBefore = Just cur}
pure (alice.userId, allEvents, aliceEvents, failedEvents, windowEvents, total, failedTotal, page1, page2)
(aliceUserId, allEvents, aliceEvents, failedEvents, windowEvents, total, failedTotal, page1, page2) <- expectApp result
-- newest-first ordering across all five
map storedEventType allEvents
@?= ["login_succeeded", "password_changed", "login_failed", "login_succeeded", "login_failed"]
-- user filter includes a failed proof once its credential resolves to Alice.
map storedEventType aliceEvents @?= ["password_changed", "login_succeeded", "login_failed"]
-- type filter: the two failed logins (tt 2 = bob, tt 0 = alice)
map storedEventType failedEvents @?= ["login_failed", "login_failed"]
-- since (inclusive) tt1 .. until (exclusive) tt3 → tt2 then tt1
map storedEventType windowEvents @?= ["login_failed", "login_succeeded"]
total @?= 5
failedTotal @?= 2
-- keyset pagination walks the set with no gaps or repeats
length page1 @?= 2
length page2 @?= 2
let ids1 = map storedEventId page1
ids2 = map storedEventId page2
assertBool "pages are disjoint" (all (`notElem` ids2) ids1)
map storedEventType (page1 <> page2) @?= ["login_succeeded", "password_changed", "login_failed", "login_succeeded"]
-- the oldest failed-login row reconstructs to the typed event we published
case reverse failedEvents of
(oldest : _) ->
reconstructAuthEvent (storedEventType oldest) (storedPayload oldest)
@?= Right (Event.LoginFailed (Event.LoginFailedData (Just (AccountKey "k-alice")) (Just aliceUserId) (tt 0)))
[] -> assertFailure "expected at least one failed-login row"
testWorkflowSignup :: TestTree
testWorkflowSignup = testCase "workflow: signup persists user + session + token" $ withDb \pool -> do
inner <- runApp pool (signup cfg (SignupCommand aliceLogin (Just aliceEmail) strongPw (Just "Alice")))
_ <- expectApp inner >>= expectRight
users <- scalarInt pool "SELECT count(*) FROM shomei.shomei_users"
sessions <- scalarInt pool "SELECT count(*) FROM shomei.shomei_sessions"
toks <- scalarInt pool "SELECT count(*) FROM shomei.shomei_refresh_tokens"
users @?= 1
sessions @?= 1
toks @?= 1
-- Round-trip budget ----------------------------------------------------------
-- | Count every 'Database' dispatch a workflow makes.
--
-- 'interpose' replaces the 'Database' handler for the wrapped action only; re-'send'ing the
-- operation from inside the handler dispatches to the /upstream/ handler ('runDatabasePool'),
-- not back into this one, so the workflow still talks to PostgreSQL and there is no recursion.
-- Both constructors are counted: a @RunSession@ is one pool checkout for one
-- statement, and a @RunTransaction@ is one pool checkout for the whole transaction. That is
-- exactly the quantity these tests pin — logical Database port operations. A transaction
-- is one operation even when it contains several SQL statements and budget-setting queries;
-- these counters are not a wire-level network round-trip measurement.
countingDatabase :: (Database :> es, IOE :> es) => IORef Int -> Eff es a -> Eff es a
countingDatabase counter = interpose \_env op -> do
liftIO (atomicModifyIORef' counter \n -> (n + 1, ()))
case op of
RunSession sess -> send (RunSession sess)
RunTransaction t -> send (RunTransaction t)
-- | A successful password login costs exactly ten database operations:
--
-- 1. @countRecentFailuresByIp@ (per-IP throttle)
-- 2. @recordLoginFailure@ (ONE transaction: advisory lock + provisional insert + count)
-- 3. @findPasswordCredentialByLoginId@
-- 4. @findUserById@
-- 5. @countPasskeysByUser@ (MFA gate: passkey factor)
-- 6. @findTotpByUser@ (MFA gate: confirmed-TOTP factor — EP-7)
-- 7. @convertLoginAttemptToSuccess@
-- 8. @persistNewSession@ (ONE transaction: session + refresh token + 2 audit events)
-- 9. @listRolesForUser@ (the roles claim, via @buildEnrichedClaims@)
-- 10. @permissionsForRoles@ (the permissions claim, via @buildEnrichedClaims@ — EP-9)
--
-- There is deliberately no @clearAccountLockout@: the record transaction found no standing row
-- and did not reach the account threshold.
-- Password verification and access-token signing are CPU-only and cost no database operation.
--
-- Step 7 was added by EP-7's generalized MFA gate: login now challenges for /any/ enrolled
-- second factor, so it reads the TOTP credential alongside the passkey count. It is one
-- 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 database operation to the login path. Find it before
-- changing the constant.
testLoginRoundTripBudget :: TestTree
testLoginRoundTripBudget = testCase "a successful login costs exactly 10 database operations" $ withDb \pool -> do
signupRes <- runApp pool (signup cfg (SignupCommand aliceLogin (Just aliceEmail) strongPw Nothing))
_ <- expectApp signupRes >>= expectRight
counter <- newIORef 0
let ctx = ClientContext (ClientIp "10.0.0.1") (AccountKey (loginIdText aliceLogin))
loginRes <- runApp pool (countingDatabase counter (login cfg ctx (LoginCommand aliceLogin strongPw False)))
_ <- expectApp loginRes >>= expectRight
readIORef counter >>= (@?= 10)
-- | A wrong password costs four database operations: per-IP count, atomic record-and-count transaction,
-- credential lookup, and the @LoginFailed@ audit insert. The user row is only needed after the
-- password succeeds, and hashing itself is CPU-only.
testFailedLoginRoundTripBudget :: TestTree
testFailedLoginRoundTripBudget = testCase "a wrong password costs exactly 4 database operations" $ withDb \pool -> do
signupRes <- runApp pool (signup cfg (SignupCommand aliceLogin (Just aliceEmail) strongPw Nothing))
_ <- expectApp signupRes >>= expectRight
counter <- newIORef 0
let ctx = ClientContext (ClientIp "10.0.0.1") (AccountKey (loginIdText aliceLogin))
loginRes <- runApp pool (countingDatabase counter (login cfg ctx (LoginCommand aliceLogin (PlainPassword "wrong") False)))
expectApp loginRes >>= (@?= Left InvalidCredentials)
readIORef counter >>= (@?= 4)
-- | A token refresh costs exactly five database operations:
--
-- 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 database operation by design.
--
-- Step 4 is what makes a role change take effect on refresh rather than only at the next login;
-- step 5 (EP-9) does the same for a permission re-wiring or a grant expiry.
testRefreshRoundTripBudget :: TestTree
testRefreshRoundTripBudget = testCase "a token refresh costs exactly 5 database operations" $ withDb \pool -> do
signupRes <- runApp pool (signup cfg (SignupCommand aliceLogin (Just aliceEmail) strongPw Nothing))
(_, pair) <- expectApp signupRes >>= expectRight
counter <- newIORef 0
refreshRes <- runApp pool (countingDatabase counter (refresh cfg (RefreshCommand pair.refreshToken)))
_ <- expectApp refreshRes >>= expectRight
readIORef counter >>= (@?= 5)
-- | Logout costs two database operations: one session lookup and one transaction that CASes
-- the session, revokes its refresh tokens, and inserts the audit event.
testLogoutRoundTripBudget :: TestTree
testLogoutRoundTripBudget = testCase "logout costs exactly 2 database operations" $ withDb \pool -> do
signupRes <- runApp pool (signup cfg (SignupCommand aliceLogin (Just aliceEmail) strongPw Nothing))
(user, pair) <- expectApp signupRes >>= expectRight
sessionsRes <- runApp pool (listSessionsForUser user.userId)
sessions <- expectApp sessionsRes
sid <- case sessions of
session : _ -> pure session.sessionId
[] -> assertFailure "expected signup to create a session"
counter <- newIORef 0
logoutRes <- runApp pool (countingDatabase counter (logout cfg (LogoutCommand sid)))
_ <- expectApp logoutRes >>= expectRight
readIORef counter >>= (@?= 2)
replay <- expectApp =<< runApp pool (refresh cfg (RefreshCommand pair.refreshToken))
replay @?= Left Err.SessionRevoked
scalarInt pool "SELECT count(*) FROM shomei.shomei_auth_events WHERE event_type='session_revoked'" >>= (@?= 1)
scalarInt pool "SELECT count(*) FROM shomei.shomei_auth_events WHERE event_type='refresh_token_reuse_detected'" >>= (@?= 0)
-- | Password-reset confirmation costs three database operations: token lookup, user lookup,
-- and one transaction for the consume/hash/revocation/event tail.
testPasswordResetRoundTripBudget :: TestTree
testPasswordResetRoundTripBudget = testCase "password reset confirmation costs exactly 3 database operations" $ withDb \pool -> do
notifications <- newIORef []
signupRes <- runAppWithNotifications notifications pool (signup cfg (SignupCommand aliceLogin (Just aliceEmail) strongPw Nothing))
_ <- expectApp signupRes >>= expectRight
requestRes <- runAppWithNotifications notifications pool (requestPasswordReset cfg (RequestPasswordReset aliceEmail))
_ <- expectApp requestRes >>= expectRight
raw <- latestResetToken =<< readIORef notifications
counter <- newIORef 0
confirmRes <-
runAppWithNotifications
notifications
pool
( countingDatabase
counter
(confirmPasswordReset cfg (ConfirmPasswordReset raw (PlainPassword "correct horse battery staple two")))
)
_ <- expectApp confirmRes >>= expectRight
readIORef counter >>= (@?= 3)
testWorkflowRefreshRotation :: TestTree
testWorkflowRefreshRotation = testCase "workflow: refresh rotation marks used + inserts child" $ withDb \pool -> do
signupRes <- runApp pool (signup cfg (SignupCommand aliceLogin (Just aliceEmail) strongPw Nothing))
(_, pair) <- expectApp signupRes >>= expectRight
refreshRes <- runApp pool (refresh cfg (RefreshCommand pair.refreshToken))
_ <- expectApp refreshRes >>= expectRight
toks <- scalarInt pool "SELECT count(*) FROM shomei.shomei_refresh_tokens"
used <- scalarInt pool "SELECT count(*) FROM shomei.shomei_refresh_tokens WHERE status = 'used'"
children <- scalarInt pool "SELECT count(*) FROM shomei.shomei_refresh_tokens WHERE parent_token_id IS NOT NULL"
toks @?= 2
used @?= 1
children @?= 1
testWorkflowReuseRevokesFamily :: TestTree
testWorkflowReuseRevokesFamily = testCase "workflow: reuse revokes the family + session" $ withDb \pool -> do
signupRes <- runApp pool (signup cfg (SignupCommand aliceLogin (Just aliceEmail) strongPw Nothing))
(_, pair) <- expectApp signupRes >>= expectRight
rotateRes <- runApp pool (refresh cfg (RefreshCommand pair.refreshToken))
_ <- expectApp rotateRes >>= expectRight
reuseRes <- runApp pool (refresh cfg (RefreshCommand pair.refreshToken))
reuse <- expectApp reuseRes
reuse @?= Left RefreshTokenReuseDetected
revokedToks <- scalarInt pool "SELECT count(*) FROM shomei.shomei_refresh_tokens WHERE status = 'revoked'"
totalToks <- scalarInt pool "SELECT count(*) FROM shomei.shomei_refresh_tokens"
revokedSessions <- scalarInt pool "SELECT count(*) FROM shomei.shomei_sessions WHERE status = 'revoked'"
assertBool "every refresh token in the family is revoked" (revokedToks == totalToks)
revokedSessions @?= 1
testWorkflowAccountVerification :: TestTree
testWorkflowAccountVerification = testCase "workflow: account verification consumes token + marks user" $ withDb \pool -> do
notifications <- newIORef []
signupRes <- runAppWithNotifications notifications pool (signup cfg (SignupCommand aliceLogin (Just aliceEmail) strongPw Nothing))
_ <- expectApp signupRes >>= expectRight
requestRes <- runAppWithNotifications notifications pool (requestEmailVerification cfg (RequestEmailVerification aliceEmail))
_ <- expectApp requestRes >>= expectRight
raw <- latestVerificationToken =<< readIORef notifications
confirmRes <- runAppWithNotifications notifications pool (confirmEmailVerification cfg (ConfirmEmailVerification raw))
_ <- expectApp confirmRes >>= expectRight
verified <- scalarInt pool "SELECT count(*) FROM shomei.shomei_users WHERE email_verified_at IS NOT NULL"
consumed <- scalarInt pool "SELECT count(*) FROM shomei.shomei_email_verification_tokens WHERE status = 'consumed'"
verified @?= 1
consumed @?= 1
testWorkflowPasswordReset :: TestTree
testWorkflowPasswordReset = testCase "workflow: password reset changes password and revokes sessions" $ withDb \pool -> do
notifications <- newIORef []
signupRes <- runAppWithNotifications notifications pool (signup cfg (SignupCommand aliceLogin (Just aliceEmail) strongPw Nothing))
(_, pair) <- expectApp signupRes >>= expectRight
firstRequest <- runAppWithNotifications notifications pool (requestPasswordReset cfg (RequestPasswordReset aliceEmail))
_ <- expectApp firstRequest >>= expectRight
first <- latestResetToken =<< readIORef notifications
secondRequest <- runAppWithNotifications notifications pool (requestPasswordReset cfg (RequestPasswordReset aliceEmail))
_ <- expectApp secondRequest >>= expectRight
second <- latestResetToken =<< readIORef notifications
confirmRes <- runAppWithNotifications notifications pool (confirmPasswordReset cfg (ConfirmPasswordReset first (PlainPassword "correct horse battery staple two")))
_ <- expectApp confirmRes >>= expectRight
siblingRes <- runAppWithNotifications notifications pool (confirmPasswordReset cfg (ConfirmPasswordReset second (PlainPassword "correct horse battery staple three")))
sibling <- expectApp siblingRes
sibling @?= Left PasswordResetTokenInvalid
loginRes <- runAppWithNotifications notifications pool (login cfg (ClientContext (ClientIp "test-ip") (AccountKey (loginIdText aliceLogin))) (LoginCommand aliceLogin (PlainPassword "correct horse battery staple two") False))
_ <- expectApp loginRes >>= expectRight
oldRefreshRes <- runAppWithNotifications notifications pool (refresh cfg (RefreshCommand pair.refreshToken))
oldRefresh <- expectApp oldRefreshRes
oldRefresh @?= Left Err.SessionRevoked
consumed <- scalarInt pool "SELECT count(*) FROM shomei.shomei_password_reset_tokens WHERE status = 'consumed'"
revokedReset <- scalarInt pool "SELECT count(*) FROM shomei.shomei_password_reset_tokens WHERE status = 'revoked'"
revokedSessions <- scalarInt pool "SELECT count(*) FROM shomei.shomei_sessions WHERE status = 'revoked'"
revokedRefresh <- scalarInt pool "SELECT count(*) FROM shomei.shomei_refresh_tokens WHERE status = 'revoked'"
consumed @?= 1
revokedReset @?= 1
assertBool "existing sessions are revoked" (revokedSessions >= 1)
assertBool "existing refresh tokens are revoked" (revokedRefresh >= 1)
testRevokeSessionIsCompareAndSwap :: TestTree
testRevokeSessionIsCompareAndSwap =
testCase "session-scoped revoke unit of work publishes only for the CAS winner" $ withDb \pool -> do
signupRes <- runApp pool (signup cfg (SignupCommand aliceLogin (Just aliceEmail) strongPw Nothing))
(user, _) <- expectApp signupRes >>= expectRight
sessionsRes <- runApp pool (listSessionsForUser user.userId)
sessions <- expectApp sessionsRes
sid <- case sessions of
session : _ -> pure session.sessionId
[] -> assertFailure "expected signup to create a session"
result <- runApp pool do
ts <- now
let event = Event.SessionRevoked (Event.SessionRevokedData sid Nothing ts)
first <- revokeSessionWithTokens sid ts [event]
second <- revokeSessionWithTokens sid ts [event]
pure (first, second)
expectApp result >>= (@?= (True, False))
revokedSessions <- scalarInt pool "SELECT count(*) FROM shomei.shomei_sessions WHERE status = 'revoked'"
revokedTokens <- scalarInt pool "SELECT count(*) FROM shomei.shomei_refresh_tokens WHERE status = 'revoked'"
revokeEvents <- scalarInt pool "SELECT count(*) FROM shomei.shomei_auth_events WHERE event_type = 'session_revoked'"
revokedSessions @?= 1
revokedTokens @?= 1
revokeEvents @?= 1
testLoginAttemptStore :: TestTree
testLoginAttemptStore = testCase "login attempt store: record + windowed count + lockout upsert/clear" $ withDb \pool -> do
let key = AccountKey "k-abc"
ip = ClientIp "1.2.3.4"
result <- runApp pool do
t <- now
let cutoff = addUTCTime (-900) t
failure fromIp =
NewLoginAttempt
{ accountKey = key,
clientIp = fromIp,
outcome = LoginFailure,
occurredAt = t,
factor = FactorTotp
}
_ <- recordLoginFailure (failure ip) cutoff Nothing
_ <- recordLoginFailure (failure ip) cutoff Nothing
_ <- recordLoginFailure (failure (ClientIp "9.9.9.9")) cutoff Nothing
accFails <- countRecentFailuresByAccount key cutoff
ipFails <- countRecentFailuresByIp ip cutoff
future <- countRecentFailuresByAccount key (addUTCTime 3600 t)
setAccountLockout (AccountLockout key 5 (Just (addUTCTime 900 t)) t)
lo1 <- getAccountLockout key
clearAccountLockout key
lo2 <- getAccountLockout key
pure (accFails, ipFails, future, lo1, lo2)
(accFails, ipFails, future, lo1, lo2) <- expectApp result
accFails @?= 3 -- all three failures share the account key
ipFails @?= 2 -- only two came from 1.2.3.4
future @?= 0 -- a cutoff in the future excludes everything
fmap (.failedCount) lo1 @?= Just 5
lo2 @?= Nothing
testLockoutRecordAndCountIsAtomicUnderRace :: TestTree
testLockoutRecordAndCountIsAtomicUnderRace =
testCase "lockout: eight racing failures count 1..8 and lock once" $ withDb \pool -> do
let key = AccountKey "race-key"
ip = ClientIp "10.0.0.9"
cutoff = addUTCTime (-900) t0
policy = LockPolicy 5 (addUTCTime 900 t0)
failure =
NewLoginAttempt
{ accountKey = key,
clientIp = ip,
outcome = LoginFailure,
occurredAt = t0,
factor = FactorPassword
}
gate <- newEmptyMVar
dones <- replicateM 8 do
done <- newEmptyMVar
_ <- forkIO do
readMVar gate
putMVar done =<< runApp pool (recordLoginFailure failure cutoff (Just policy))
pure done
putMVar gate ()
outcomes <- traverse (\done -> expectApp =<< takeMVar done) dones
sort (map (.failures) outcomes) @?= [1 .. 8]
length (filter (.lockedNow) outcomes) @?= 1
testWorkflowLockout :: TestTree
testWorkflowLockout = testCase "workflow over PostgreSQL: lock-after-N then unlock-after-cooldown" $ withDb \pool -> do
seeded <- runAppAtTime t0 pool (signup lockCfg (SignupCommand aliceLogin (Just aliceEmail) strongPw Nothing))
_ <- expectApp seeded >>= expectRight
let ctx = ClientContext (ClientIp "10.0.0.9") (AccountKey (loginIdText aliceLogin))
badLogin = login lockCfg ctx (LoginCommand aliceLogin (PlainPassword "wrong") False)
_ <- 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 False)) >>= expectApp
denied @?= Left InvalidCredentials
-- After the cooldown (15 min default) the correct password succeeds and clears the lockout.
ok <- runAppAtTime (addUTCTime (16 * 60) t0) pool (login lockCfg ctx (LoginCommand aliceLogin strongPw False)) >>= expectApp
_ <- expectRight ok
remaining <- scalarInt pool "SELECT count(*) FROM shomei.shomei_account_lockouts"
remaining @?= 0
-- Passkey field accessors: OverloadedRecordDot is unreliable for these
-- DuplicateRecordFields records (MasterPlan 3 discovery), so read via record-pattern.
pkPasskeyId :: PasskeyCredential -> PasskeyId
pkPasskeyId PasskeyCredential {passkeyId} = passkeyId
pkSignCounter :: PasskeyCredential -> SignatureCounter
pkSignCounter PasskeyCredential {signCounter} = signCounter
pkLastUsedAt :: PasskeyCredential -> Maybe UTCTime
pkLastUsedAt PasskeyCredential {lastUsedAt} = lastUsedAt
pkTransports :: PasskeyCredential -> [Text]
pkTransports PasskeyCredential {transports} = transports
pkLabel :: PasskeyCredential -> Maybe Text
pkLabel PasskeyCredential {label} = label
-- | A 'NewPasskeyCredential' with canned bytes for the given user and time.
newPasskey :: User -> UTCTime -> NewPasskeyCredential
newPasskey u t =
NewPasskeyCredential
{ userId = u.userId,
credentialId = WebAuthnCredentialId "cred-1",
userHandle = UserHandle "uh-1",
publicKey = PublicKeyBytes "pk-1",
signCounter = SignatureCounter 0,
transports = ["usb", "nfc"],
label = Just "key",
createdAt = t
}
-- | Field accessors for the EP-4 service-account record: 'DuplicateRecordFields' makes
-- @value.field@ unreliable here, as it does for the passkey record above.
saStatus :: ServiceAccount -> ServiceAccountStatus
saStatus ServiceAccount {status} = status
saSecretHash :: ServiceAccount -> Text
saSecretHash ServiceAccount {secretHash} = secretHash
saRotatedAt :: ServiceAccount -> Maybe UTCTime
saRotatedAt ServiceAccount {rotatedAt} = rotatedAt
saRevokedAt :: ServiceAccount -> Maybe UTCTime
saRevokedAt ServiceAccount {revokedAt} = revokedAt
saId :: ServiceAccount -> ServiceAccountDbId
saId ServiceAccount {serviceAccountId} = serviceAccountId
saAllowedScopes :: ServiceAccount -> Set.Set Scope
saAllowedScopes ServiceAccount {allowedScopes} = allowedScopes
-- | EP-4: the whole service-account lifecycle against real PostgreSQL — create, find by
-- client id, rotate the secret, revoke — mirroring the in-memory
-- 'Shomei.ServiceAccountStoreSpec'. Proves the jsonb @allowed_scopes@ round-trip, the
-- @status@ text encoding, and that a revoked row survives so the grant workflow can still
-- resolve (and refuse) it.
testServiceAccountRoundTrip :: TestTree
testServiceAccountRoundTrip =
testCase "service accounts: create + find by client id + rotate + revoke" $ withDb \pool -> do
result <- runApp pool do
u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})
t <- now
said <- genServiceAccountDbId
let scopes = Set.fromList [Scope "kawa:ingest", Scope "signal:raise"]
created <-
createServiceAccount
NewServiceAccount
{ serviceAccountId = said,
clientId = idText said,
userId = u.userId,
secretHash = "hash-one",
displayName = "rei connector",
allowedScopes = scopes,
createdAt = t
}
afterCreate <- findServiceAccountByClientId (idText said)
listed <- listServiceAccounts
rotateServiceAccountSecret said "hash-two" t
afterRotate <- findServiceAccountByClientId (idText said)
revokeServiceAccount said t
afterRevoke <- findServiceAccountByClientId (idText said)
pure (created, afterCreate, listed, afterRotate, afterRevoke, scopes)
(created, afterCreate, listed, afterRotate, afterRevoke, scopes) <- expectApp result
-- a fresh account is active with no rotation/revocation stamps
saStatus created @?= ServiceAccountActive
saRotatedAt created @?= Nothing
-- the lookup by client id resolves, and the jsonb scope set survived the round trip
fmap saId afterCreate @?= Just (saId created)
fmap saAllowedScopes afterCreate @?= Just scopes
map saId listed @?= [saId created]
-- rotation swaps the hash and stamps rotated_at, without revoking
fmap saSecretHash afterRotate @?= Just "hash-two"
assertBool "rotated_at is stamped" (maybe False (isJust . saRotatedAt) afterRotate)
fmap saStatus afterRotate @?= Just ServiceAccountActive
-- revocation flips status and stamps revoked_at; the ROW SURVIVES so the lookup still resolves
fmap saStatus afterRevoke @?= Just ServiceAccountRevoked
assertBool "revoked_at is stamped" (maybe False (isJust . saRevokedAt) afterRevoke)
n <- scalarInt pool "SELECT count(*) FROM shomei.shomei_service_accounts"
n @?= 1
-- Field accessors: 'OAuthClient' shares field names with 'ServiceAccount' and 'User', so read
-- it by record pattern (the MasterPlan-3 DuplicateRecordFields caution).
ocStatus :: OAuthClient -> OAuthClientStatus
ocStatus OAuthClient {status} = status
ocSecretHash :: OAuthClient -> Maybe Text
ocSecretHash OAuthClient {secretHash} = secretHash
ocRevokedAt :: OAuthClient -> Maybe UTCTime
ocRevokedAt OAuthClient {revokedAt} = revokedAt
ocId :: OAuthClient -> OAuthClientId
ocId OAuthClient {oauthClientId} = oauthClientId
ocClientType :: OAuthClient -> ClientType
ocClientType OAuthClient {clientType} = clientType
ocRedirectUris :: OAuthClient -> [Text]
ocRedirectUris OAuthClient {redirectUris} = redirectUris
ocAllowedScopes :: OAuthClient -> Set.Set Scope
ocAllowedScopes OAuthClient {allowedScopes} = allowedScopes
-- | EP-5: the OAuth-client lifecycle against real PostgreSQL — create (confidential and public),
-- find by client id, list, revoke — mirroring the in-memory 'Shomei.OAuthClientStoreSpec'.
--
-- Proves the two jsonb round-trips (@redirect_uris@ as an ordered array, @allowed_scopes@ as a
-- set), the @client_type@ and @status@ text encodings, that a public client's @secret_hash@ is a
-- real SQL NULL rather than an empty string, and that a revoked row survives so the authorize
-- endpoint can resolve (and refuse) it.
testOAuthClientRoundTrip :: TestTree
testOAuthClientRoundTrip =
testCase "oauth clients: create confidential + public, find, list, revoke" $ withDb \pool -> do
result <- runApp pool do
t <- now
confId <- genOAuthClientId
pubId <- genOAuthClientId
let scopes = Set.fromList [Scope "openid", Scope "profile"]
uris = ["https://app.example.com/callback", "https://app.example.com/other"]
confidential <-
createOAuthClient
NewOAuthClient
{ oauthClientId = confId,
clientId = idText confId,
secretHash = Just "hash-one",
clientType = ConfidentialClient,
displayName = "grafana",
redirectUris = uris,
allowedScopes = scopes,
createdAt = t
}
public <-
createOAuthClient
NewOAuthClient
{ oauthClientId = pubId,
clientId = idText pubId,
secretHash = Nothing,
clientType = PublicClient,
displayName = "spa",
redirectUris = ["https://spa.example.com/cb"],
allowedScopes = Set.singleton (Scope "openid"),
createdAt = t
}
afterCreate <- findOAuthClientByClientId (idText confId)
foundPublic <- findOAuthClientByClientId (idText pubId)
listed <- listOAuthClients
revokeOAuthClient confId t
afterRevoke <- findOAuthClientByClientId (idText confId)
pure (confidential, public, afterCreate, foundPublic, listed, afterRevoke, scopes, uris)
(confidential, public, afterCreate, foundPublic, listed, afterRevoke, scopes, uris) <- expectApp result
-- a fresh client is active and unrevoked
ocStatus confidential @?= OAuthClientActive
ocRevokedAt confidential @?= Nothing
ocClientType public @?= PublicClient
-- the lookup resolves, and both jsonb columns survived the round trip (uris keep their order)
fmap ocId afterCreate @?= Just (ocId confidential)
fmap ocAllowedScopes afterCreate @?= Just scopes
fmap ocRedirectUris afterCreate @?= Just uris
fmap ocSecretHash afterCreate @?= Just (Just "hash-one")
-- a public client's secret_hash is a real NULL
fmap ocSecretHash foundPublic @?= Just Nothing
fmap ocClientType foundPublic @?= Just PublicClient
length listed @?= 2
-- revocation flips status and stamps revoked_at; the ROW SURVIVES so the lookup still resolves
fmap ocStatus afterRevoke @?= Just OAuthClientRevoked
assertBool "revoked_at is stamped" (maybe False (isJust . ocRevokedAt) afterRevoke)
nullSecrets <- scalarInt pool "SELECT count(*) FROM shomei.shomei_oauth_clients WHERE secret_hash IS NULL"
nullSecrets @?= 1
-- | EP-5: the authorization-code lifecycle against real PostgreSQL — store, consume once, replay,
-- expiry, and the batched sweep — mirroring the in-memory 'Shomei.OAuthCodeStoreSpec'.
testAuthorizationCodeRoundTrip :: TestTree
testAuthorizationCodeRoundTrip =
testCase "authorization codes: consume once, replay misses, expiry misses" $ withDb \pool -> do
result <- runApp pool do
u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})
t <- now
let scopes = Set.fromList [Scope "openid", Scope "profile"]
mk h expiresAt =
NewAuthorizationCode
{ codeHash = h,
clientId = "oauthclient_x",
redirectUri = "https://app.example.com/callback",
userId = u.userId,
scopes,
nonce = Just "n-0S6",
codeChallenge = Just (Text.replicate 43 "a"),
authTime = t,
createdAt = t,
expiresAt
}
putAuthorizationCode (mk "hash-live" (addUTCTime 60 t))
putAuthorizationCode (mk "hash-expired" (addUTCTime 60 t))
first' <- consumeAuthorizationCode "hash-live" t
sid <- genSessionId
bindAuthorizationCodeSession "hash-live" sid
bound <- findConsumedAuthorizationCode "hash-live" t
replay <- consumeAuthorizationCode "hash-live" t
unknown <- consumeAuthorizationCode "hash-nope" t
-- One second past its expiry: the row is there, but it must not consume.
expired <- consumeAuthorizationCode "hash-expired" (addUTCTime 61 t)
pure (first', sid, bound, replay, unknown, expired, scopes, t)
(first', sid, bound, replay, unknown, expired, scopes, writtenAt) <- expectApp result
-- The consume returns every binding the exchange will re-check, and stamps consumed_at.
case first' of
Nothing -> assertFailure "the first consume must return the code"
Just c -> do
c.clientId @?= "oauthclient_x"
c.redirectUri @?= "https://app.example.com/callback"
c.scopes @?= scopes
c.nonce @?= Just "n-0S6"
c.codeChallenge @?= Just (Text.replicate 43 "a")
assertBool "consumed_at is stamped" (isJust c.consumedAt)
c.sessionId @?= Nothing
fmap (.sessionId) bound @?= Just (Just sid)
assertBool "a replay must miss" (isNothing replay)
assertBool "an unknown hash must miss" (isNothing unknown)
assertBool "an expired code must miss" (isNothing expired)
-- Only the bounded maintenance path deletes expired codes, including consumed rows.
report <- expectSweep =<< sweepOnce pool defaultSweepConfig {batchSize = 1, ceremonyGraceMinutes = 0} (addUTCTime 61 writtenAt)
report.authorizationCodesDeleted @?= 2
remaining <- scalarInt pool "SELECT count(*) FROM shomei.shomei_oauth_authorization_codes"
remaining @?= 0
-- | 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
testPasskeyQuotaRace :: TestTree
testPasskeyQuotaRace = testCase "passkey quota: eight database racers spend one final slot" $ withDb \pool -> do
u <- expectApp =<< runApp pool (createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing}))
gate <- newEmptyMVar
workers <- forM [1 .. 8 :: Int] \i -> do
done <- newEmptyMVar
_ <- forkIO do
readMVar gate
result <- runApp pool do
t <- now
createPasskey 1 ((newPasskey u t) {credentialId = WebAuthnCredentialId (BS.pack [fromIntegral i])})
putMVar done result
pure done
putMVar gate ()
results <- mapM (expectApp <=< takeMVar) workers
length [() | Right _ <- results] @?= 1
length [() | Left Err.PasskeyLimitReached <- results] @?= 7
scalarInt pool "SELECT count(*) FROM shomei.shomei_webauthn_credentials" >>= (@?= 1)
testPasskeyCreateAndFind :: TestTree
testPasskeyCreateAndFind = testCase "passkey store: create + find by user/credential-id/user-handle" $ withDb \pool -> do
result <- runApp pool do
u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})
t <- now
created <- either (error . show) pure =<< createPasskey 20 (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 <- either (error . show) pure =<< createPasskey 20 (newPasskey u t)
let pid = pkPasskeyId created
counterAdvanced <- updatePasskeySignCounter pid (SignatureCounter 42) t
afterUpdate <- findPasskeyByCredentialId (WebAuthnCredentialId "cred-1")
cnt <- countPasskeysByUser u.userId
otherUid <- genUserId
deletePasskey otherUid pid -- wrong user: must NOT delete
pure (counterAdvanced, afterUpdate, cnt, u.userId, pid)
(counterAdvanced, afterUpdate, cnt, uid, pid) <- expectApp result
counterAdvanced @?= True
fmap pkSignCounter afterUpdate @?= Just (SignatureCounter 42)
assertBool "last_used_at is populated after the counter bump" (maybe False (isJust . pkLastUsedAt) afterUpdate)
cnt @?= 1
afterWrongUser <- scalarInt pool "SELECT count(*) FROM shomei.shomei_webauthn_credentials"
afterWrongUser @?= 1 -- wrong-user delete left it
_ <- runApp pool (deletePasskey uid pid) >>= expectApp
afterOwner <- scalarInt pool "SELECT count(*) FROM shomei.shomei_webauthn_credentials"
afterOwner @?= 0 -- owner delete removed it
testPasskeyCounterIsCompareAndSwap :: TestTree
testPasskeyCounterIsCompareAndSwap =
testCase "passkey counter advances atomically and preserves counterless authenticators" $ withDb \pool -> do
result <- runApp pool do
u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})
t <- now
created <- either (error . show) pure =<< createPasskey 20 (newPasskey u t)
let pid = pkPasskeyId created
zeroToZero <- updatePasskeySignCounter pid (SignatureCounter 0) t
first <- updatePasskeySignCounter pid (SignatureCounter 42) t
zeroAfterNonzero <- updatePasskeySignCounter pid (SignatureCounter 0) t
same <- updatePasskeySignCounter pid (SignatureCounter 42) t
older <- updatePasskeySignCounter pid (SignatureCounter 41) t
newer <- updatePasskeySignCounter pid (SignatureCounter 43) t
stored <- findPasskeyByCredentialId (WebAuthnCredentialId "cred-1")
pure (zeroToZero, first, zeroAfterNonzero, same, older, newer, stored)
(zeroToZero, first, zeroAfterNonzero, same, older, newer, stored) <- expectApp result
(zeroToZero, first, zeroAfterNonzero, same, older, newer)
@?= (True, True, False, False, False, True)
fmap pkSignCounter stored @?= Just (SignatureCounter 43)
testPasskeyCounterCasUnderRace :: TestTree
testPasskeyCounterCasUnderRace =
testCase "passkey counter: eight racing nonzero updates have one winner" $ withDb \pool -> do
seeded <- runApp pool do
u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})
t <- now
created <- either (error . show) pure =<< createPasskey 20 (newPasskey u t)
pure (pkPasskeyId created, t)
(pid, t) <- expectApp seeded
gate <- newEmptyMVar
dones <- replicateM 8 do
done <- newEmptyMVar
_ <- forkIO do
readMVar gate
putMVar done =<< runApp pool (updatePasskeySignCounter pid (SignatureCounter 42) t)
pure done
putMVar gate ()
results <- traverse (\done -> expectApp =<< takeMVar done) dones
length (filter id results) @?= 1
testPendingCeremonyConsumeOnce :: TestTree
testPendingCeremonyConsumeOnce = testCase "pending ceremony store: put then take consumes exactly once" $ withDb \pool -> do
result <- runApp pool do
cid <- genCeremonyId
t <- now
putPendingCeremony
PendingCeremony
{ ceremonyId = cid,
userId = Nothing,
kind = RegistrationCeremony,
optionsBlob = "{\"challenge\":\"abc\"}",
createdAt = t,
expiresAt = addUTCTime 300 t
}
first <- takePendingCeremony cid t
pure (cid, t, first)
(cid, t, first) <- expectApp result
assertBool "first take returns the ceremony" (isJust first)
afterFirst <- scalarInt pool "SELECT count(*) FROM shomei.shomei_webauthn_pending_ceremonies"
afterFirst @?= 0 -- DELETE ... RETURNING removed it
second <- runApp pool (takePendingCeremony cid t) >>= expectApp
second @?= (Nothing :: Maybe PendingCeremony)
testPendingCeremonyExpired :: TestTree
testPendingCeremonyExpired = testCase "pending ceremony store: expired ceremony is not returned" $ withDb \pool -> do
result <- runApp pool do
cid <- genCeremonyId
t <- now
putPendingCeremony
PendingCeremony
{ ceremonyId = cid,
userId = Nothing,
kind = AuthenticationCeremony,
optionsBlob = "{\"challenge\":\"xyz\"}",
createdAt = t,
expiresAt = t -- expires immediately
}
-- "now" is past expiry: returns Nothing but still removes the stale row
takePendingCeremony cid (addUTCTime 1 t)
taken <- expectApp result
taken @?= (Nothing :: Maybe PendingCeremony)
remaining <- scalarInt pool "SELECT count(*) FROM shomei.shomei_webauthn_pending_ceremonies"
remaining @?= 0
-- Argon2 parameters ----------------------------------------------------------
-- | Cheap parameters, so the parameter tests do not each pay the ~100 ms production cost.
cheapParams :: Argon2Params
cheapParams = Argon2Params {memoryKiB = 8192, iterations = 1, parallelism = 1}
testArgon2NewHashesArePhcFormatted :: TestTree
testArgon2NewHashesArePhcFormatted =
testCase "argon2: new hashes are PHC-formatted and verify" do
PasswordHash stored <- hashPasswordArgon2id defaultArgon2Params "hunter2"
assertBool
("expected a PHC prefix carrying the default params, got " <> Text.unpack stored)
("$argon2id$v=19$m=65536,t=3,p=1$" `Text.isPrefixOf` stored)
verifyPasswordArgon2id "hunter2" (PasswordHash stored) @?= True
verifyPasswordArgon2id "wrong" (PasswordHash stored) @?= False
testArgon2RejectsUnparameterizedHashes :: TestTree
testArgon2RejectsUnparameterizedHashes =
testCase "argon2: an unparameterized three-part hash is rejected" do
let unparameterized =
PasswordHash "argon2id$4gw0llx5tfM4Dfi23hUsTA==$8zWIeRIFVtmuSuMdAv4MW13Fsw1BCjfREVf4eaHwp+I="
verifyPasswordArgon2id "correct horse battery staple" unparameterized @?= False
testArgon2ParamsChangeLeavesOldHashesVerifiable :: TestTree
testArgon2ParamsChangeLeavesOldHashesVerifiable =
testCase "argon2: changing params leaves old hashes verifiable" do
-- A hash made with the defaults, and one made with different params, coexist.
defaultHash <- hashPasswordArgon2id defaultArgon2Params "hunter2"
cheapHash <- hashPasswordArgon2id cheapParams "hunter2"
assertBool "the two hashes differ" (defaultHash /= cheapHash)
-- Each verifies with the parameters IT carries, not with any ambient configuration.
verifyPasswordArgon2id "hunter2" defaultHash @?= True
verifyPasswordArgon2id "hunter2" cheapHash @?= True
testArgon2MalformedHashesVerifyFalse :: TestTree
testArgon2MalformedHashesVerifyFalse =
testCase "argon2: malformed hashes verify False without crashing" do
let malformed =
[ "$argon2id$v=19$m=notanumber,t=3,p=1$AAAAAAAAAAAAAAAAAAAAAA==$AAAA",
"$argon2id$v=99$m=65536,t=3,p=1$AAAAAAAAAAAAAAAAAAAAAA==$AAAA",
"$argon2id$v=19$m=65536,t=3$AAAAAAAAAAAAAAAAAAAAAA==$AAAA",
"$argon2id$v=19$m=0,t=3,p=1$AAAAAAAAAAAAAAAAAAAAAA==$AAAA",
"$argon2i$v=19$m=65536,t=3,p=1$AAAAAAAAAAAAAAAAAAAAAA==$AAAA",
"not-a-hash",
""
]
forM_ malformed \h ->
assertBool
("expected False for " <> Text.unpack h)
(not (verifyPasswordArgon2id "hunter2" (PasswordHash h)))
-- | The login timing oracle, at the level where it is actually created.
--
-- A login that never reaches a stored hash burns 'dummyHashFor' instead. That must cost what
-- verifying a real hash costs, or response time reveals whether an account exists. This is
-- asserted structurally — same embedded parameters — rather than with a stopwatch, because
-- equal parameters mean equal Argon2 work by construction, and a wall-clock assertion would
-- be flaky. ('Shomei.Session.Authentication.TimingSpec' asserts the complementary property: that every
-- login path performs exactly one such operation.)
testArgon2DummyHashTracksConfiguredParams :: TestTree
testArgon2DummyHashTracksConfiguredParams =
testCase "argon2: the dummy hash carries the configured params, so a miss costs what a hit costs" do
forM_ [defaultArgon2Params, cheapParams, Argon2Params 19456 2 1] \params -> do
real <- hashPasswordArgon2id params "hunter2"
let dummy = dummyHashFor params
assertEqual
("the dummy must derive with the same params as a real hash, for " <> show params)
(costFields real)
(costFields dummy)
-- It must be well-formed: a malformed dummy would return False WITHOUT hashing (~9 µs
-- versus ~100 ms), silently reopening the oracle it exists to close. Verifying against
-- it does full Argon2 work and then fails the comparison, which is exactly the point.
verifyPasswordArgon2id "hunter2" dummy @?= False
where
-- The version and parameter fields of a PHC string: everything that decides the cost.
costFields (PasswordHash t) = case Text.splitOn "$" t of
("" : "argon2id" : version : params : _) -> Just (version, params)
_ -> Nothing
testArgon2HardFloorMatchesTheImplementation :: TestTree
testArgon2HardFloorMatchesTheImplementation =
testCase "argon2: the boot hard floor matches the implementation" do
let rejected = Argon2Params 64 1 16
boundary = Argon2Params 128 1 16
assertBool "m=64,p=16 must be below the hard floor" (isJust (argon2HardFloor rejected))
trialArgon2Derivation rejected >>= assertBool "the implementation must reject m=64,p=16" . isLeft
argon2HardFloor boundary @?= Nothing
trialArgon2Derivation boundary >>= \case
Right () -> pure ()
Left failure -> assertFailure ("the hard-floor boundary must derive: " <> show failure)
-- Hashing limiter -------------------------------------------------------------
-- | At most @limit@ Argon2 derivations may run at once, no matter how many requests arrive.
--
-- Sixteen threads race for permits. Each holds its permit for a fixed 25 ms before hashing, so
-- the first @limit@ of them are provably in flight together and the high-water mark reaches
-- @limit@ exactly. The assertion that matters is @peak <= limit@ — that is the bound; the
-- @peak == limit@ half only confirms the test actually saturated the gate rather than
-- trivially passing.
testHashingLimiterBoundsConcurrency :: Int -> TestTree
testHashingLimiterBoundsConcurrency limit =
testCase ("hashing limiter: peak concurrency never exceeds the limit (" <> show limit <> ")") do
limiter <- newHashingLimiter limit
dones <- replicateM 16 newEmptyMVar
forM_ (zip [1 :: Int ..] dones) \(i, done) ->
void $ forkIO do
h <- withHashingPermit limiter do
threadDelay 25_000
hashPasswordArgon2id cheapParams ("pw" <> Text.pack (show i))
putMVar done (i, h)
results <- mapM takeMVar dones
forM_ results \(_, h) -> do
let PasswordHash phc = h
void (evaluate (Text.length phc))
peak <- peakHashingConcurrency limiter
assertBool ("peak " <> show peak <> " exceeded the limit " <> show limit) (peak <= limit)
assertEqual "the test must saturate the gate, or it proves nothing" limit peak
-- Every hash is real and verifies: the gate serializes work, it does not corrupt it.
forM_ results \(i, h) ->
assertBool
("hash " <> show i <> " must verify")
(verifyPasswordArgon2id ("pw" <> Text.pack (show i)) h)
-- | The bound must hold through the effect interpreter, not merely around 'withHashingPermit'.
-- A refactor that dropped the bracket from 'runPasswordHasherCrypto' would leave the previous
-- test green and the server unbounded.
testInterpreterForcesTheHashInsideThePermit :: TestTree
testInterpreterForcesTheHashInsideThePermit =
testCase "hashing limiter: the interpreter forces HashPassword inside its permit" do
limiter <- newHashingLimiter 1
dones <- replicateM 8 newEmptyMVar
forM_ (zip [1 :: Int ..] dones) \(i, done) ->
void $ forkIO do
h <-
runEff
. runPasswordHasherCrypto limiter cheapParams
$ hashPassword (PlainPassword ("pw" <> Text.pack (show i)))
forceStart <- getMonotonicTimeNSec
let PasswordHash phc = h
_ <- evaluate (Text.length phc)
forceEnd <- getMonotonicTimeNSec
putMVar done (i, h, forceStart, forceEnd)
results <- mapM takeMVar dones
peak <- peakHashingConcurrency limiter
assertBool "the interpreter never acquired a permit" (peak >= 1)
assertBool ("interpreter allowed " <> show peak <> " concurrent hashes") (peak <= 1)
let windows = [(forceStart, forceEnd) | (_, _, forceStart, forceEnd) <- results]
overlap (a0, a1) (b0, b1) = a0 < b1 && b0 < a1
caps <- getNumCapabilities
when (caps >= 2) $
forM_ [(a, b) | a : rest <- tails windows, b <- rest] \(a, b) ->
assertBool ("post-return forcing windows overlap: " <> show (a, b)) (not (overlap a b))
-- Capability-independent half: one cheap derivation sets the bar on this machine.
w0 <- getMonotonicTimeNSec
_ <- hashPasswordArgon2id cheapParams "warm"
w1 <- getMonotonicTimeNSec
forM_ results \(i, h, forceStart, forceEnd) -> do
assertBool
("hash " <> show i <> " was forced after the interpreter returned")
((forceEnd - forceStart) * 2 < (w1 - w0))
assertBool
("hash " <> show i <> " must verify")
(verifyPasswordArgon2id ("pw" <> Text.pack (show i)) h)
-- | A verification of a *dummy* hash also takes a permit — the miss path must be bounded
-- exactly like the hit path, or a flood of logins for nonexistent accounts bypasses the gate.
testDummyVerificationTakesAPermit :: TestTree
testDummyVerificationTakesAPermit =
testCase "hashing limiter: the dummy verification path is bounded too" do
limiter <- newHashingLimiter 1
dones <- replicateM 4 newEmptyMVar
forM_ dones \done ->
void $ forkIO do
runEff . runPasswordHasherCrypto limiter cheapParams $ verifyPasswordDummy (PlainPassword "pw")
putMVar done ()
_ <- mapM takeMVar dones
peak <- peakHashingConcurrency limiter
peak @?= 1
-- Maintenance sweep ----------------------------------------------------------
-- | A database with one row on each side of every sweep cutoff.
--
-- Ages are expressed relative to the database's @now()@; 'sweepOnce' is handed Haskell's
-- 'getCurrentTime'. The two clocks differ by milliseconds while every offset here is hours or
-- days, so no row sits near a boundary.
--
-- Three sessions: one expired 40 days ago (dead by @expires_at@, holding a three-token
-- rotation family so the sweep must respect @parent_token_id@'s self-referencing foreign
-- key); one revoked 40 days ago but with a far-future @expires_at@ (dead only by the
-- @revoked_at@ branch of the sweep's OR predicate); and one live session that must survive
-- with both of its tokens.
seedSweepFixture :: Pool -> IO ()
seedSweepFixture pool =
execSql
pool
"""
INSERT INTO shomei.shomei_users (user_id, email, display_name, status, created_at, updated_at, login_id) VALUES
('11111111-1111-1111-1111-111111111111', 'sweep1@example.com', 'Sweep One', 'active', now() - interval '90 days', now(), 'sweep1@example.com'),
('22222222-2222-2222-2222-222222222222', 'sweep2@example.com', 'Sweep Two', 'active', now() - interval '90 days', now(), 'sweep2@example.com');
INSERT INTO shomei.shomei_sessions (session_id, user_id, status, created_at, expires_at, revoked_at) VALUES
('aaaaaaaa-0000-0000-0000-000000000001', '11111111-1111-1111-1111-111111111111', 'active', now() - interval '60 days', now() - interval '40 days', NULL),
('aaaaaaaa-0000-0000-0000-000000000002', '11111111-1111-1111-1111-111111111111', 'revoked', now() - interval '60 days', now() + interval '30 days', now() - interval '40 days'),
('aaaaaaaa-0000-0000-0000-000000000003', '22222222-2222-2222-2222-222222222222', 'active', now() - interval '1 day', now() + interval '30 days', NULL);
-- A three-generation rotation family on the expired session, then a single token on the
-- revoked one, then two live tokens that must survive.
INSERT INTO shomei.shomei_refresh_tokens
(refresh_token_id, session_id, token_hash, parent_token_id, status, created_at, expires_at, used_at, revoked_at) VALUES
('bbbbbbbb-0000-0000-0000-000000000001', 'aaaaaaaa-0000-0000-0000-000000000001', 'hash-dead-1', NULL, 'used', now() - interval '60 days', now() - interval '40 days', now() - interval '59 days', NULL),
('bbbbbbbb-0000-0000-0000-000000000002', 'aaaaaaaa-0000-0000-0000-000000000001', 'hash-dead-2', 'bbbbbbbb-0000-0000-0000-000000000001', 'used', now() - interval '59 days', now() - interval '40 days', now() - interval '58 days', NULL),
('bbbbbbbb-0000-0000-0000-000000000003', 'aaaaaaaa-0000-0000-0000-000000000001', 'hash-dead-3', 'bbbbbbbb-0000-0000-0000-000000000002', 'active', now() - interval '58 days', now() - interval '40 days', NULL, NULL),
('bbbbbbbb-0000-0000-0000-000000000011', 'aaaaaaaa-0000-0000-0000-000000000002', 'hash-revk-1', NULL, 'revoked', now() - interval '60 days', now() + interval '30 days', NULL, now() - interval '40 days'),
('cccccccc-0000-0000-0000-000000000001', 'aaaaaaaa-0000-0000-0000-000000000003', 'hash-live-1', NULL, 'used', now() - interval '1 day', now() + interval '30 days', now() - interval '1 hour', NULL),
('cccccccc-0000-0000-0000-000000000002', 'aaaaaaaa-0000-0000-0000-000000000003', 'hash-live-2', 'cccccccc-0000-0000-0000-000000000001', 'active', now() - interval '1 hour', now() + interval '30 days', NULL, NULL);
-- One expired past the 7-day grace, one still live.
INSERT INTO shomei.shomei_email_verification_tokens
(verification_token_id, user_id, token_hash, status, created_at, expires_at, consumed_at, revoked_at) VALUES
('dddddddd-0000-0000-0000-000000000001', '11111111-1111-1111-1111-111111111111', 'vhash-old', 'active', now() - interval '11 days', now() - interval '10 days', NULL, NULL),
('dddddddd-0000-0000-0000-000000000002', '11111111-1111-1111-1111-111111111111', 'vhash-new', 'active', now(), now() + interval '1 day', NULL, NULL);
INSERT INTO shomei.shomei_password_reset_tokens
(password_reset_token_id, user_id, token_hash, status, created_at, expires_at, consumed_at, revoked_at) VALUES
('eeeeeeee-0000-0000-0000-000000000001', '11111111-1111-1111-1111-111111111111', 'phash-old', 'active', now() - interval '11 days', now() - interval '10 days', NULL, NULL),
('eeeeeeee-0000-0000-0000-000000000002', '11111111-1111-1111-1111-111111111111', 'phash-new', 'active', now(), now() + interval '1 day', NULL, NULL);
-- Expired 2 hours ago (past the 60-minute grace); expired 30 minutes ago (inside it); live.
INSERT INTO shomei.shomei_webauthn_pending_ceremonies (ceremony_id, user_id, kind, options_blob, created_at, expires_at) VALUES
('ffffffff-0000-0000-0000-000000000001', NULL, 'authentication', '\\x00'::bytea, now() - interval '3 hours', now() - interval '2 hours'),
('ffffffff-0000-0000-0000-000000000002', NULL, 'authentication', '\\x00'::bytea, now() - interval '90 minutes', now() - interval '30 minutes'),
('ffffffff-0000-0000-0000-000000000003', NULL, 'registration', '\\x00'::bytea, now(), now() + interval '1 hour');
-- Elapsed past the 7-day grace; elapsed yesterday (inside it); not locked at all.
INSERT INTO shomei.shomei_account_lockouts (account_key, failed_count, locked_until, updated_at) VALUES
('lockout-elapsed', 5, now() - interval '10 days', now() - interval '10 days'),
('lockout-recent', 5, now() - interval '1 day', now() - interval '1 day'),
('lockout-counting', 2, NULL, now());
-- EP-5 authorization codes: expired 2 hours ago (past the 60-minute ceremony grace, which
-- these share); expired 30 minutes ago (inside it); live. The consumed-but-expired one goes
-- too -- a consumed code is already unusable, so keeping it past expiry buys nothing.
INSERT INTO shomei.shomei_oauth_authorization_codes
(code_hash, client_id, user_id, redirect_uri, scopes, nonce, code_challenge, auth_time, created_at, expires_at, consumed_at) VALUES
('codehash-old', 'oauthclient_x', '11111111-1111-1111-1111-111111111111', 'https://app.test/cb', '["openid"]'::jsonb, NULL, NULL, now() - interval '3 hours', now() - interval '3 hours', now() - interval '2 hours', NULL),
('codehash-consumed', 'oauthclient_x', '11111111-1111-1111-1111-111111111111', 'https://app.test/cb', '["openid"]'::jsonb, NULL, NULL, now() - interval '3 hours', now() - interval '3 hours', now() - interval '2 hours', now() - interval '2 hours'),
('codehash-recent', 'oauthclient_x', '11111111-1111-1111-1111-111111111111', 'https://app.test/cb', '["openid"]'::jsonb, NULL, NULL, now() - interval '90 minutes', now() - interval '90 minutes', now() - interval '30 minutes', NULL),
('codehash-live', 'oauthclient_x', '11111111-1111-1111-1111-111111111111', 'https://app.test/cb', '["openid"]'::jsonb, NULL, NULL, now(), now(), now() + interval '1 minute', NULL);
-- Past the 90-day retention window; inside it.
INSERT INTO shomei.shomei_login_attempts (attempt_id, account_key, client_ip, outcome, occurred_at) VALUES
('99999999-0000-0000-0000-000000000001', 'acct', '10.0.0.1', 'failure', now() - interval '100 days'),
('99999999-0000-0000-0000-000000000002', 'acct', '10.0.0.1', 'failure', now() - interval '10 days');
-- Audit events are retained forever by default; the 400-day-old one only goes when an
-- explicit retention window is configured.
INSERT INTO shomei.shomei_auth_events (event_id, user_id, session_id, event_type, payload, created_at) VALUES
('88888888-0000-0000-0000-000000000001', NULL, NULL, 'login_succeeded', '{}'::jsonb, now() - interval '400 days'),
('88888888-0000-0000-0000-000000000002', NULL, NULL, 'login_succeeded', '{}'::jsonb, now());
-- EP-9 time-bound role grants: one expired past the 7-day grace (swept), one expired inside
-- it (kept), and one forever grant with a NULL expiry (never swept). 'admin' is seeded by the
-- migration; a second role is defined here so both live grants can hang off one user.
INSERT INTO shomei.shomei_roles (role, description, created_at) VALUES
('auditor', 'sweep fixture role', now()) ON CONFLICT (role) DO NOTHING;
INSERT INTO shomei.shomei_role_grants (user_id, role, granted_by, granted_at, expires_at) VALUES
('11111111-1111-1111-1111-111111111111', 'admin', NULL, now() - interval '60 days', now() - interval '10 days'),
('22222222-2222-2222-2222-222222222222', 'admin', NULL, now() - interval '60 days', now() - interval '1 day'),
('11111111-1111-1111-1111-111111111111', 'auditor', NULL, now() - interval '60 days', NULL);
"""
testSweepDeletesExpiredRows :: TestTree
testSweepDeletesExpiredRows =
testCase "maintenance sweep: deletes exactly the expired rows and spares the rest" $ withDb \pool -> do
seedSweepFixture pool
t <- getCurrentTime
report <- sweepOnce pool defaultSweepConfig t >>= expectSweep
report
@?= SweepReport
{ -- three from the expired session's rotation family, one from the revoked session
refreshTokensDeleted = 4,
-- the expired one and the revoked one; the live session stays
sessionsDeleted = 2,
verificationTokensDeleted = 1,
resetTokensDeleted = 1,
ceremoniesDeleted = 1,
-- the two that expired past the grace window (one of them already consumed); the
-- recently-expired one and the live one stay
authorizationCodesDeleted = 2,
lockoutsDeleted = 1,
loginAttemptsDeleted = 1,
-- the one grant expired past the 7-day grace; the recently-expired and the forever
-- (NULL expiry) grants stay
roleGrantsDeleted = 1,
-- retention disabled by default
authEventsDeleted = 0
}
-- The survivors are exactly the rows on the live side of each cutoff.
scalarInt pool "SELECT count(*) FROM shomei.shomei_sessions" >>= (@?= 1)
scalarInt pool "SELECT count(*) FROM shomei.shomei_refresh_tokens" >>= (@?= 2)
scalarInt pool "SELECT count(*) FROM shomei.shomei_email_verification_tokens" >>= (@?= 1)
scalarInt pool "SELECT count(*) FROM shomei.shomei_password_reset_tokens" >>= (@?= 1)
scalarInt pool "SELECT count(*) FROM shomei.shomei_webauthn_pending_ceremonies" >>= (@?= 2)
scalarInt pool "SELECT count(*) FROM shomei.shomei_account_lockouts" >>= (@?= 2)
scalarInt pool "SELECT count(*) FROM shomei.shomei_login_attempts" >>= (@?= 1)
scalarInt pool "SELECT count(*) FROM shomei.shomei_auth_events" >>= (@?= 2)
-- The two live grants survive (recently expired, still in grace; and the forever grant).
scalarInt pool "SELECT count(*) FROM shomei.shomei_role_grants" >>= (@?= 2)
-- Users are never swept.
scalarInt pool "SELECT count(*) FROM shomei.shomei_users" >>= (@?= 2)
-- The live session kept its whole token chain, parent link intact.
scalarInt
pool
"SELECT count(*) FROM shomei.shomei_refresh_tokens WHERE session_id = 'aaaaaaaa-0000-0000-0000-000000000003'"
>>= (@?= 2)
testSweepIsIdempotent :: TestTree
testSweepIsIdempotent =
testCase "maintenance sweep: a second sweep is a no-op" $ withDb \pool -> do
seedSweepFixture pool
t <- getCurrentTime
_ <- sweepOnce pool defaultSweepConfig t >>= expectSweep
second <- sweepOnce pool defaultSweepConfig t >>= expectSweep
second @?= emptySweepReport
testSweepAuthEventRetention :: TestTree
testSweepAuthEventRetention =
testCase "maintenance sweep: audit events go only when a retention window is configured" $ withDb \pool -> do
seedSweepFixture pool
t <- getCurrentTime
-- Default config leaves both events in place.
def <- sweepOnce pool defaultSweepConfig t >>= expectSweep
def.authEventsDeleted @?= 0
scalarInt pool "SELECT count(*) FROM shomei.shomei_auth_events" >>= (@?= 2)
-- A 365-day window takes the 400-day-old event and nothing else.
let retaining = defaultSweepConfig {authEventRetentionDays = Just 365}
withWindow <- sweepOnce pool retaining t >>= expectSweep
withWindow @?= emptySweepReport {authEventsDeleted = 1}
scalarInt pool "SELECT count(*) FROM shomei.shomei_auth_events" >>= (@?= 1)
testSweepBatchesUntilDrained :: TestTree
testSweepBatchesUntilDrained =
testCase "maintenance sweep: batches until drained" $ withDb \pool -> do
-- 25 expired ceremonies with a batch size of 10 needs three passes of the drain loop.
execSql
pool
"""
INSERT INTO shomei.shomei_webauthn_pending_ceremonies (ceremony_id, user_id, kind, options_blob, created_at, expires_at)
SELECT gen_random_uuid(), NULL, 'authentication', '\\x00'::bytea, now() - interval '3 hours', now() - interval '2 hours'
FROM generate_series(1, 25);
"""
t <- getCurrentTime
report <- sweepOnce pool defaultSweepConfig {batchSize = 10} t >>= expectSweep
report.ceremoniesDeleted @?= 25
scalarInt pool "SELECT count(*) FROM shomei.shomei_webauthn_pending_ceremonies" >>= (@?= 0)
-- | A whole rotation family must be deleted by one statement: @parent_token_id@ is a
-- self-referencing foreign key with no @ON DELETE@ action, so a row-bounded batch that split
-- a family would fail with a foreign-key violation. 'sweepOnce' batches by /session/ to avoid
-- this, which a batch size of 1 exercises directly — one session per statement, five tokens.
testSweepBatchesWholeTokenFamilies :: TestTree
testSweepBatchesWholeTokenFamilies =
testCase "maintenance sweep: a batch never splits a refresh-token rotation family" $ withDb \pool -> do
execSql
pool
"""
INSERT INTO shomei.shomei_users (user_id, email, display_name, status, created_at, updated_at, login_id) VALUES
('11111111-1111-1111-1111-111111111111', 'fam@example.com', 'Fam', 'active', now(), now(), 'fam@example.com');
INSERT INTO shomei.shomei_sessions (session_id, user_id, status, created_at, expires_at, revoked_at) VALUES
('aaaaaaaa-0000-0000-0000-000000000001', '11111111-1111-1111-1111-111111111111', 'active', now() - interval '60 days', now() - interval '40 days', NULL),
('aaaaaaaa-0000-0000-0000-000000000002', '11111111-1111-1111-1111-111111111111', 'active', now() - interval '60 days', now() - interval '40 days', NULL);
INSERT INTO shomei.shomei_refresh_tokens
(refresh_token_id, session_id, token_hash, parent_token_id, status, created_at, expires_at, used_at, revoked_at) VALUES
('bbbbbbbb-0000-0000-0000-000000000001', 'aaaaaaaa-0000-0000-0000-000000000001', 'h1', NULL, 'used', now(), now() - interval '40 days', now(), NULL),
('bbbbbbbb-0000-0000-0000-000000000002', 'aaaaaaaa-0000-0000-0000-000000000001', 'h2', 'bbbbbbbb-0000-0000-0000-000000000001', 'used', now(), now() - interval '40 days', now(), NULL),
('bbbbbbbb-0000-0000-0000-000000000003', 'aaaaaaaa-0000-0000-0000-000000000001', 'h3', 'bbbbbbbb-0000-0000-0000-000000000002', 'active', now(), now() - interval '40 days', NULL, NULL),
('bbbbbbbb-0000-0000-0000-000000000011', 'aaaaaaaa-0000-0000-0000-000000000002', 'h4', NULL, 'used', now(), now() - interval '40 days', now(), NULL),
('bbbbbbbb-0000-0000-0000-000000000012', 'aaaaaaaa-0000-0000-0000-000000000002', 'h5', 'bbbbbbbb-0000-0000-0000-000000000011', 'active', now(), now() - interval '40 days', NULL, NULL);
"""
t <- getCurrentTime
report <- sweepOnce pool defaultSweepConfig {batchSize = 1} t >>= expectSweep
report.refreshTokensDeleted @?= 5
report.sessionsDeleted @?= 2
scalarInt pool "SELECT count(*) FROM shomei.shomei_refresh_tokens" >>= (@?= 0)
scalarInt pool "SELECT count(*) FROM shomei.shomei_sessions" >>= (@?= 0)
latestVerificationToken :: [Notification] -> IO OneTimeToken
latestVerificationToken = \case
EmailVerificationRequested {token = raw} : _ -> pure raw
_ -> assertFailure "expected email-verification notification"
latestResetToken :: [Notification] -> IO OneTimeToken
latestResetToken = \case
PasswordResetRequested {token = raw} : _ -> pure raw
_ -> assertFailure "expected password-reset notification"
testFieldBudgets :: TestTree
testFieldBudgets = testCase "new-write field budgets preserve legacy rows and security updates" $ withDb \pool -> do
-- Model an installed pre-budget row; trigger bypass exists only in this throwaway fixture.
execSql
pool
"""
BEGIN;
ALTER TABLE shomei.shomei_users DISABLE TRIGGER enforce_field_budgets;
INSERT INTO shomei.shomei_users(user_id, login_id, email, display_name, status, created_at, updated_at)
VALUES ('11111111-1111-1111-1111-111111111111', repeat('界',257), repeat('界',100)||'@a.b', repeat('界',257), 'active', now(), now());
ALTER TABLE shomei.shomei_users ENABLE TRIGGER enforce_field_budgets;
COMMIT;
"""
rows <- expectApp =<< runApp pool (listUsers emptyUserListQuery)
length rows @?= 1
let user = head rows
Text.length (loginIdText user.loginId) @?= 257
changed <- expectApp =<< runApp pool (updateUserStatus user.userId [UserActive] UserSuspended t0)
changed @?= True
execSqlExpectState pool "22001" "UPDATE shomei.shomei_users SET login_id = repeat('a',258)"
execSqlExpectState pool "22001" "UPDATE shomei.shomei_users SET email = repeat('é',126)||'@a.b'"
execSqlExpectState pool "22001" "UPDATE shomei.shomei_users SET display_name = repeat('界',258)"
execSql pool "UPDATE shomei.shomei_users SET login_id = repeat('🔑',256), email = repeat('é',125)||'@a.b', display_name = repeat('🔑',256)"
execSqlExpectState pool "22001" "INSERT INTO shomei.shomei_roles(role, created_at) VALUES (repeat('a',129),now())"
execSql pool "INSERT INTO shomei.shomei_roles(role, created_at) VALUES (repeat('界',128),now())"
testRetryBudgets :: TestTree
testRetryBudgets = testCase "transaction retries classify only rollback-safe states and stop at three attempts" $ withDb \pool -> do
execSql pool "CREATE SEQUENCE retry_attempts; CREATE TABLE retry_writes(value integer)"
let run policy body = runEff . runDatabasePoolWith policy pool $ runTransaction body
failure code = Tx.statement () (preparable ("DO $$ BEGIN INSERT INTO retry_writes VALUES(1); PERFORM nextval('retry_attempts'); RAISE EXCEPTION 'injected' USING ERRCODE = '" <> TE.decodeUtf8 code <> "'; END $$") E.noParams D.noResult)
forM_ ["40001", "40P01", "23505", "08006"] $ \code -> do
execSql pool "ALTER SEQUENCE retry_attempts RESTART WITH 1"
result <- run (TransactionRetryPolicy 3 1000) (failure code)
assertBool "injected transaction fails" (isLeft result)
count <- scalarInt pool "SELECT last_value FROM retry_attempts"
count @?= if code == "40001" || code == "40P01" then 3 else 1
scalarInt pool "SELECT count(*) FROM retry_writes" >>= (@?= 0)
scalarInt pool "SELECT 1::bigint" >>= (@?= 1)
retryableTransactionError Pool.AcquisitionTimeoutUsageError @?= False
retryableTransactionError (Pool.ConnectionUsageError (Hasql.OtherConnectionError "ambiguous commit")) @?= False
invalid <- run (TransactionRetryPolicy 0 1000) (Tx.statement () (preparable "INSERT INTO retry_writes VALUES(1)" E.noParams D.noResult))
assertBool "invalid policy does no work" (isLeft invalid)
scalarInt pool "SELECT count(*) FROM retry_writes" >>= (@?= 0)
testTransactionDeadline :: TestTree
testTransactionDeadline = testCase "transaction deadline cancels a real lock wait, rolls back and returns a usable sole connection" $
withShomeiMigratedDatabase \conn ->
bracket (acquirePool 1 1 30000 conn) Pool.release \pool ->
bracket (acquirePool 1 1 30000 conn) Pool.release \holder -> do
execSql pool "CREATE TABLE deadline_writes(value integer)"
bracket_
(execSql holder "SELECT pg_advisory_lock(1936224116, 17)")
(execSql holder "SELECT pg_advisory_unlock(1936224116, 17)")
do
started <- getMonotonicTimeNSec
result <-
timeout
2000000
( runEff . runDatabasePoolWith (TransactionRetryPolicy 3 100) pool $
runTransaction (Tx.statement () (preparable "DO $$ BEGIN INSERT INTO deadline_writes VALUES(1); PERFORM pg_advisory_xact_lock(1936224116, 17); END $$" E.noParams D.noResult))
)
ended <- getMonotonicTimeNSec
assertBool "deadline returns unavailable" (case result of Just (Left _) -> True; _ -> False)
assertBool "total deadline is finite" (ended - started < 2000000000)
usable <- timeout 1000000 (scalarInt pool "SELECT count(*) FROM deadline_writes")
usable @?= Just 0
completed <- newEmptyMVar
worker <- forkIO do
outcome <-
try @SomeException
( runEff . runDatabasePoolWith (TransactionRetryPolicy 3 500) pool $
runTransaction (Tx.statement () (preparable "DO $$ BEGIN INSERT INTO deadline_writes VALUES(2); PERFORM pg_advisory_xact_lock(1936224116, 17); END $$" E.noParams D.noResult))
)
putMVar completed outcome
let awaitWaiter = do
waiting <- scalarInt holder "SELECT count(*) FROM pg_locks WHERE locktype='advisory' AND classid=1936224116 AND objid=17 AND NOT granted"
if waiting > 0 then pure () else threadDelay 1000 >> awaitWaiter
barrier <- timeout 1000000 awaitWaiter
barrier @?= Just ()
killThread worker
cancelled <- timeout 2000000 (takeMVar completed)
assertBool "caller cancellation returns after cleanup" (case cancelled of Just (Left _) -> True; Just (Right (Left _)) -> True; _ -> False)
reused <- timeout 1000000 (scalarInt pool "SELECT count(*) FROM deadline_writes")
reused @?= Just 0
testDatabaseTimeouts :: TestTree
testDatabaseTimeouts = testCase "every connection installs statement and idle transaction timeouts; hung statement is cancelled" $
withShomeiMigratedDatabase \conn ->
bracket (acquirePool 2 1 75 conn) Pool.release \pool -> do
settings <- scalarInt pool "SELECT CASE WHEN current_setting('statement_timeout')='75ms' AND current_setting('idle_in_transaction_session_timeout')='75ms' THEN 1 ELSE 0 END::bigint"
settings @?= 1
execSqlExpectState pool "57014" "SELECT pg_sleep(1)"
scalarInt pool "SELECT 1::bigint" >>= (@?= 1)
testBulkRevocation :: TestTree
testBulkRevocation = testCase "bulk revoke: 10000 winners and audits stay atomic under failure and eight racers" $ withDb \pool -> do
user <- expectApp =<< runApp pool (createUser (NewUser aliceLogin Nothing Nothing))
actor <- genUserId
let uid = "'" <> Text.pack (show (userIdToUUID user.userId)) <> "'"
execSql pool ("INSERT INTO shomei.shomei_sessions(session_id,user_id,status,created_at,expires_at) SELECT gen_random_uuid(), " <> uid <> ", 'active', now(), now()+interval '1 day' FROM generate_series(1,10000)")
execSql pool "INSERT INTO shomei.shomei_refresh_tokens(refresh_token_id,session_id,token_hash,status,created_at,expires_at) SELECT gen_random_uuid(),session_id,md5(session_id::text),'active',created_at,expires_at FROM shomei.shomei_sessions"
execSql pool "ALTER TABLE shomei.shomei_auth_events ADD CONSTRAINT fail_bulk_audit CHECK(event_type <> 'session_revoked')"
failed <- runApp pool (revokeUserSessionsWithAudit actor user.userId t0)
assertBool "audit failure rejects entire operation" (isLeft failed)
scalarInt pool "SELECT count(*) FROM shomei.shomei_sessions WHERE status='active'" >>= (@?= 10000)
scalarInt pool "SELECT count(*) FROM shomei.shomei_refresh_tokens WHERE status='active'" >>= (@?= 10000)
execSql pool "ALTER TABLE shomei.shomei_auth_events DROP CONSTRAINT fail_bulk_audit"
start <- newEmptyMVar
completed <- replicateM 8 do
done <- newEmptyMVar
_ <- forkIO do
readMVar start
result <- runApp pool (revokeUserSessionsWithAudit actor user.userId t0)
putMVar done result
pure done
putMVar start ()
results <- traverse (expectApp <=< takeMVar) completed
sum results @?= 10000
length (filter (> 0) results) @?= 1
scalarInt pool "SELECT count(*) FROM shomei.shomei_auth_events WHERE event_type='session_revoked'" >>= (@?= 10000)
scalarInt pool "SELECT count(*) FROM shomei.shomei_refresh_tokens WHERE status<>'revoked'" >>= (@?= 0)
repeated <- expectApp =<< runApp pool (revokeUserSessionsWithAudit actor user.userId (addUTCTime 60 t0))
repeated @?= 0
scalarInt pool "SELECT count(*) FROM shomei.shomei_sessions WHERE revoked_at <> '2026-01-01T00:00:00Z'" >>= (@?= 0)
events <- expectApp =<< runApp pool (queryAuthEvents emptyAuditQuery {queryEventTypes = ["session_revoked"], queryLimit = 1})
case events of
[event] -> case reconstructAuthEvent event.storedEventType event.storedPayload of
Right (Event.SessionRevoked details) -> do
details.revokedBy @?= Just actor
details.occurredAt @?= t0
other -> assertFailure ("bulk payload failed reconstruction: " <> show other)
_ -> assertFailure "expected one event page"
testSessionPages :: TestTree
testSessionPages = testCase "session pages default to 50, cap at 200 and keyset-walk timestamp ties without gaps" $ withDb \pool -> do
user <- expectApp =<< runApp pool (createUser (NewUser aliceLogin Nothing Nothing))
let uid = "'" <> Text.pack (show (userIdToUUID user.userId)) <> "'"
execSql pool ("INSERT INTO shomei.shomei_sessions(session_id,user_id,status,created_at,expires_at) SELECT gen_random_uuid(), " <> uid <> ", 'active', '2026-01-01', '2027-01-01' FROM generate_series(1,505)")
first <- expectApp =<< runApp pool (listSessionPage user.userId emptySessionListQuery)
length first @?= 50
capped <- expectApp =<< runApp pool (listSessionPage user.userId (SessionListQuery 10000 Nothing))
length capped @?= 200
let walk cursor accumulated = do
page <- expectApp =<< runApp pool (listSessionPage user.userId (SessionListQuery 73 cursor))
case reverse page of
[] -> pure accumulated
lastRow : _ -> walk (Just (SessionCursor lastRow.createdAt lastRow.sessionId)) (accumulated <> map (.sessionId) page)
identifiers <- walk Nothing []
length identifiers @?= 505
Set.size (Set.fromList identifiers) @?= 505
testShrinkingStatementBudget :: TestTree
testShrinkingStatementBudget = testCase "transaction statement budgets shrink across successive slow statements and reset afterward" $ withDb \pool -> do
let pause = Tx.statement () (preparable "DO $$ BEGIN PERFORM pg_sleep(0.065); END $$" E.noParams D.noResult)
started <- getMonotonicTimeNSec
result <- runEff . runDatabasePoolWith (TransactionRetryPolicy 3 100) pool $ runTransaction (pause >> pause)
ended <- getMonotonicTimeNSec
assertBool "second statement cannot spend a fresh 100ms" (isLeft result)
assertBool "whole attempt remains bounded" (ended - started < 1000000000)
setting <- scalarInt pool "SELECT CASE WHEN current_setting('statement_timeout')='30s' THEN 1 ELSE 0 END::bigint"
setting @?= 1
testSessionQueryPlan :: TestTree
testSessionQueryPlan = testCase "session keyset index removes the 10000-row sort for a 50-row page" $ withDb \pool -> do
user <- expectApp =<< runApp pool (createUser (NewUser aliceLogin Nothing Nothing))
let uid = "'" <> Text.pack (show (userIdToUUID user.userId)) <> "'"
explain = do
result <-
Pool.use
pool
( Session.statement
()
( preparable
("EXPLAIN (ANALYZE, BUFFERS) SELECT * FROM shomei.shomei_sessions WHERE user_id=" <> uid <> " ORDER BY created_at DESC,session_id DESC LIMIT 50")
E.noParams
(D.rowList (D.column (D.nonNullable D.text)))
)
)
expectApp result
execSql pool ("INSERT INTO shomei.shomei_sessions(session_id,user_id,status,created_at,expires_at) SELECT gen_random_uuid(), " <> uid <> ", 'active', now(), now()+interval '1 day' FROM generate_series(1,10000)")
execSql pool "DROP INDEX IF EXISTS shomei.shomei_sessions_user_created_id_idx; ANALYZE shomei.shomei_sessions"
before <- explain
assertBool "baseline sorts the matching sessions" (any (Text.isInfixOf "Sort") before)
execSql pool "CREATE INDEX shomei_sessions_user_created_id_idx ON shomei.shomei_sessions(user_id,created_at DESC,session_id DESC)"
after <- explain
assertBool "bounded page uses ordered index" (any (Text.isInfixOf "shomei_sessions_user_created_id_idx") after)
assertBool "ordered index removes sort" (not (any (Text.isInfixOf "Sort") after))
writeFile "/tmp/shomei-session-query-plan.txt" (Text.unpack (Text.unlines (["Before compound index:"] <> before <> ["After compound index:"] <> after)))
testActiveSessionQuota :: TestTree
testActiveSessionQuota = testCase "active session quota serializes actor and subject budgets across replicas; expiry frees capacity" $ withDb \pool -> do
(actor, subject, otherSubject) <-
expectApp =<< runApp pool do
actor <- createUser (NewUser aliceLogin Nothing Nothing)
subject <- createUser (NewUser bobLogin Nothing Nothing)
other <- createUser (NewUser (either (error . show) id (mkLoginId "quota-other")) Nothing Nothing)
pure (actor, subject, other)
let new at uid acting expiry = NewSession uid at expiry acting Nothing DelegatedSession Set.empty at False
delegated = new t0 subject.userId (Just actor.userId) (addUTCTime 60 t0)
mint ns = runApp pool (createSessionWithinLimit 1 ns)
-- Eight independent interpreter invocations contend for the same final slot.
start <- newEmptyMVar
completions <- replicateM 8 do
done <- newEmptyMVar
_ <- forkIO (readMVar start >> mint delegated >>= putMVar done)
pure done
putMVar start ()
results <- traverse (expectApp <=< takeMVar) completions
length [() | Right _ <- results] @?= 1
length [() | Left Err.SessionLimitReached <- results] @?= 7
acrossSubjects <- expectApp =<< mint (new t0 otherSubject.userId (Just actor.userId) (addUTCTime 60 t0))
acrossSubjects @?= Left Err.SessionLimitReached
acrossActors <- expectApp =<< mint (new t0 subject.userId (Just otherSubject.userId) (addUTCTime 60 t0))
acrossActors @?= Left Err.SessionLimitReached
-- Existing rows survive lowering; expired rows do not spend the active budget.
expiredMint <- expectApp =<< runApp pool (createSessionWithinLimit 1 (new (addUTCTime 61 t0) subject.userId (Just actor.userId) (addUTCTime 120 t0)))
assertBool "expiry frees a slot without a sweep" (case expiredMint of Right _ -> True; _ -> False)
scalarInt pool "SELECT count(*) FROM shomei.shomei_sessions" >>= (@?= 2)
let future = addUTCTime (31 * 86400) t0
live <- expectApp =<< mint (new future subject.userId (Just actor.userId) (addUTCTime 60 future))
liveSession <- expectRight live
sweepStarted <- getMonotonicTimeNSec
report <- expectSweep =<< sweepOnce pool defaultSweepConfig {batchSize = 1} future
sweepEnded <- getMonotonicTimeNSec
assertBool "two successful delete batches yield at least 10ms each" (sweepEnded - sweepStarted >= 20000000)
report.sessionsDeleted @?= 2
surviving <- expectApp =<< runApp pool (findSessionById liveSession.sessionId)
fmap (.status) surviving @?= Just SessionActive
testSessionQuotaQueryPlan :: TestTree
testSessionQuotaQueryPlan = testCase "session quota indexes exclude expired history from the bounded live count" $ withDb \pool -> do
user <- expectApp =<< runApp pool (createUser (NewUser aliceLogin Nothing Nothing))
other <- expectApp =<< runApp pool (createUser (NewUser bobLogin Nothing Nothing))
let otherUid = "'" <> Text.pack (show (userIdToUUID other.userId)) <> "'"
uid = "'" <> Text.pack (show (userIdToUUID user.userId)) <> "'"
query = "EXPLAIN (ANALYZE,BUFFERS) SELECT count(*) FROM (SELECT 1 FROM shomei.shomei_sessions WHERE user_id=" <> uid <> " AND status='active' AND kind IN ('machine','delegated') AND expires_at > '2026-01-01' UNION ALL SELECT 1 FROM shomei.shomei_sessions WHERE actor_user_id=" <> uid <> " AND user_id<>" <> uid <> " AND status='active' AND kind IN ('machine','delegated') AND expires_at>'2026-01-01' LIMIT 1000) active"
explain = expectApp =<< Pool.use pool (Session.statement () (preparable query E.noParams (D.rowList (D.column (D.nonNullable D.text)))))
execSql pool ("INSERT INTO shomei.shomei_sessions(session_id,user_id,actor_user_id,status,kind,created_at,expires_at) SELECT gen_random_uuid()," <> uid <> "," <> uid <> ",'active','delegated','2025-01-01','2025-01-02' FROM generate_series(1,10000)")
execSql pool ("INSERT INTO shomei.shomei_sessions(session_id,user_id,actor_user_id,status,kind,created_at,expires_at) VALUES(gen_random_uuid()," <> uid <> "," <> uid <> ",'active','delegated','2026-01-01','2027-01-01')")
execSql pool ("INSERT INTO shomei.shomei_sessions(session_id,user_id,status,kind,created_at,expires_at) SELECT gen_random_uuid()," <> otherUid <> ",'active','machine','2026-01-01','2027-01-01' FROM generate_series(1,10000)")
execSql pool "DROP INDEX IF EXISTS shomei.shomei_sessions_active_subject_idx; DROP INDEX IF EXISTS shomei.shomei_sessions_active_actor_idx; ANALYZE shomei.shomei_sessions"
before <- explain
execSql pool "CREATE INDEX shomei_sessions_active_subject_idx ON shomei.shomei_sessions(user_id,expires_at) WHERE status='active' AND kind IN ('machine','delegated'); CREATE INDEX shomei_sessions_active_actor_idx ON shomei.shomei_sessions(actor_user_id,expires_at) WHERE status='active' AND kind IN ('machine','delegated')"
after <- explain
writeFile "/tmp/shomei-session-quota-plan.txt" (Text.unpack (Text.unlines (["Before active range indexes:"] <> before <> ["After active range indexes:"] <> after)))
assertBool "quota range indexes used" (any (Text.isInfixOf "shomei_sessions_active_") after)
testManagedPoolOwnership :: TestTree
testManagedPoolOwnership = testCase "managed pool restores interrupted/failed slots and preserves its ceiling across release" $
withShomeiMigratedDatabase \conn -> bracket (acquirePool 1 0.05 30000 conn) Pool.release \pool -> do
execSql pool "CREATE TABLE pool_cancel_writes(value integer)"
-- A gate inside a raw session makes caller interruption deterministic. This session is
-- not a retried database transaction, whose abstract type deliberately has no MonadIO.
forM_ [1 .. 12 :: Int] $ \_ -> do
entered <- newEmptyMVar
neverCommit <- newEmptyMVar
completed <- newEmptyMVar
worker <- forkIO do
result <-
try @SomeException
( Pool.use pool do
Session.script "BEGIN; INSERT INTO pool_cancel_writes VALUES(1)"
liftIO (putMVar entered () >> takeMVar neverCommit)
Session.script "COMMIT"
)
putMVar completed result
timeout 1000000 (takeMVar entered) >>= (@?= Just ())
killThread worker
outcome <- timeout 1000000 (takeMVar completed)
assertBool "interrupted session did not commit" (case outcome of Just (Left _) -> True; Just (Right (Left _)) -> True; _ -> False)
timeout 1000000 (scalarInt pool "SELECT count(*) FROM pool_cancel_writes") >>= (@?= Just 0)
-- Failed initialization must also return the reserved capacity, every time.
bracket (acquirePool 1 0.05 maxBound conn) Pool.release $ \invalid ->
forM_ [1 .. 3 :: Int] $ \_ -> do
outcome <- Pool.use invalid (pure ())
assertBool
"initialization failure retains its typed result, never a leaked-slot timeout"
(case outcome of Left (Pool.SessionUsageError _) -> True; _ -> False)
entered <- newEmptyMVar
finish <- newEmptyMVar
completed <- newEmptyMVar
_ <- forkIO do
result <- Pool.use pool (liftIO (putMVar entered () >> takeMVar finish))
putMVar completed result
timeout 1000000 (takeMVar entered) >>= (@?= Just ())
Pool.release pool
exhausted <- Pool.use pool (pure ())
exhausted @?= Left Pool.AcquisitionTimeoutUsageError
putMVar finish ()
timeout 1000000 (takeMVar completed) >>= (@?= Just (Right ()))
timeout 1000000 (scalarInt pool "SELECT 1::bigint") >>= (@?= Just 1)
testPersistenceClock :: TestTree
testPersistenceClock = testCase "user and credential timestamps follow Clock; password tails share their transaction timestamp" $ withDb \pool -> do
(user, credential) <-
expectApp =<< runAppAtTime t0 pool do
user <- createUser (NewUser aliceLogin Nothing Nothing)
credential <- createPasswordCredential user.userId aliceLogin Nothing (PasswordHash "initial-hash")
pure (user, credential)
user.createdAt @?= t0
user.updatedAt @?= t0
credential.createdAt @?= t0
credential.updatedAt @?= t0
let changedAt = addUTCTime 60 t0
(updatedUser, updatedCredential) <-
expectApp =<< runAppAtTime changedAt pool do
_ <- updateUserStatus user.userId [UserActive] UserSuspended changedAt
updatePasswordHash user.userId (PasswordHash "second-hash")
(,) <$> findUserById user.userId <*> findPasswordCredentialByLoginId aliceLogin
fmap (.updatedAt) updatedUser @?= Just changedAt
fmap (.updatedAt) updatedCredential @?= Just changedAt
let tailTime = addUTCTime 120 t0
-- A different ambient Clock proves the tail uses the one timestamp already chosen by its workflow.
expectApp =<< runAppAtTime t0 pool (completePasswordChange user.userId (PasswordHash "third-hash") tailTime [])
afterTail <- expectApp =<< runAppAtTime t0 pool (findPasswordCredentialByLoginId aliceLogin)
fmap (.updatedAt) afterTail @?= Just tailTime
fmap (.createdAt) afterTail @?= Just t0
reset <- expectApp =<< runAppAtTime t0 pool (createPasswordResetToken (NewPasswordResetToken user.userId (OneTimeTokenHash "clock-reset") t0 (addUTCTime 3600 t0)))
let resetTime = addUTCTime 180 t0
won <- expectApp =<< runAppAtTime t0 pool (completePasswordReset reset.passwordResetTokenId user.userId (PasswordHash "fourth-hash") resetTime [])
won @?= True
afterReset <- expectApp =<< runAppAtTime t0 pool (findPasswordCredentialByLoginId aliceLogin)
fmap (.updatedAt) afterReset @?= Just resetTime
fmap (.createdAt) afterReset @?= Just t0
-- Start every independent interpreter invocation together and never leave a failed worker
-- silently blocking the acceptance suite.
raceDatabase :: Int -> IO a -> IO [a]
raceDatabase count action = do
start <- newEmptyMVar
completed <- replicateM count do
done <- newEmptyMVar
_ <- forkIO do
readMVar start
outcome <- try @SomeException action
putMVar done outcome
pure done
putMVar start ()
forM completed \done -> do
outcome <- timeout 10000000 (takeMVar done)
case outcome of
Just (Right value) -> pure value
Just (Left _) -> assertFailure "database racer raised an exception"
Nothing -> assertFailure "database race did not reach its completion barrier"
readBarrier :: Int -> IORef Int -> MVar () -> IO ()
readBarrier racers count allRead = do
lastReader <- atomicModifyIORef' count (\n -> let next = n + 1 in (next, next == racers))
when lastReader (putMVar allRead ())
readMVar allRead
synchronizeUserRead :: (UserStore :> es, IOE :> es) => Int -> IORef Int -> MVar () -> Eff es a -> Eff es a
synchronizeUserRead racers count allRead = interpose \env -> \case
op@(FindUserById _) -> do
value <- passthrough env op
liftIO (readBarrier racers count allRead)
pure value
op -> passthrough env op
synchronizeRefreshRead :: (RefreshTokenStore :> es, IOE :> es) => Int -> IORef Int -> MVar () -> Eff es a -> Eff es a
synchronizeRefreshRead racers count allRead = interpose \env -> \case
op@(FindRefreshTokenByHash _) -> do
value <- passthrough env op
liftIO (readBarrier racers count allRead)
pure value
op -> passthrough env op
testRefreshRotationRace :: TestTree
testRefreshRotationRace = testCase "real refresh workflow race rotates once and treats the losing proof as theft" $ withDb \pool -> do
(_, pair) <- runApp pool (signup cfg (SignupCommand aliceLogin (Just aliceEmail) strongPw Nothing)) >>= expectApp >>= expectRight
readCount <- newIORef 0
allRead <- newEmptyMVar
results <- raceDatabase 2 (runApp pool (synchronizeRefreshRead 2 readCount allRead (refresh cfg (RefreshCommand pair.refreshToken)))) >>= traverse expectApp
length [() | Right _ <- results] @?= 1
length [() | Left RefreshTokenReuseDetected <- results] @?= 1
scalarInt pool "SELECT count(*) FROM shomei.shomei_refresh_tokens" >>= (@?= 2)
scalarInt pool "SELECT count(*) FROM shomei.shomei_refresh_tokens WHERE status<>'revoked'" >>= (@?= 0)
scalarInt pool "SELECT count(*) FROM shomei.shomei_sessions WHERE status='active'" >>= (@?= 0)
scalarInt pool "SELECT count(*) FROM shomei.shomei_auth_events WHERE event_type='refresh_token_rotated'" >>= (@?= 1)
scalarInt pool "SELECT count(*) FROM shomei.shomei_auth_events WHERE event_type='refresh_token_reuse_detected'" >>= (@?= 1)
scalarInt pool "SELECT count(*) FROM shomei.shomei_auth_events WHERE event_type='session_revoked'" >>= (@?= 0)
testResetAndVerificationRaces :: TestTree
testResetAndVerificationRaces = testCase "real reset and verification workflows each consume once and audit one winner" $ withDb \pool -> do
_ <- runApp pool (signup cfg (SignupCommand aliceLogin (Just aliceEmail) strongPw Nothing)) >>= expectApp >>= expectRight
notifications <- newIORef []
_ <- runAppWithNotifications notifications pool (requestPasswordReset cfg (RequestPasswordReset aliceEmail)) >>= expectApp >>= expectRight
sent <- readIORef notifications
resetToken <- case [raw | PasswordResetRequested {token = raw} <- sent] of
raw : _ -> pure raw
_ -> assertFailure "missing reset token fixture"
readCount <- newIORef 0
allRead <- newEmptyMVar
resets <-
raceDatabase
8
( runApp
pool
( synchronizeUserRead
8
readCount
allRead
(confirmPasswordReset cfg (ConfirmPasswordReset resetToken (PlainPassword "correct horse battery staple two")))
)
)
>>= traverse expectApp
length [() | Right () <- resets] @?= 1
length [() | Left PasswordResetTokenInvalid <- resets] @?= 7
scalarInt pool "SELECT count(*) FROM shomei.shomei_auth_events WHERE event_type='password_reset_completed'" >>= (@?= 1)
_ <- runAppWithNotifications notifications pool (requestEmailVerification cfg (RequestEmailVerification aliceEmail)) >>= expectApp >>= expectRight
sentVerification <- readIORef notifications
verificationToken <- case [raw | EmailVerificationRequested {token = raw} <- sentVerification] of
raw : _ -> pure raw
_ -> assertFailure "missing verification token fixture"
verificationReads <- newIORef 0
allVerificationRead <- newEmptyMVar
verifications <-
raceDatabase
8
( runApp
pool
( synchronizeUserRead
8
verificationReads
allVerificationRead
(confirmEmailVerification cfg (ConfirmEmailVerification verificationToken))
)
)
>>= traverse expectApp
length [() | Right () <- verifications] @?= 1
length [() | Left Err.VerificationTokenInvalid <- verifications] @?= 7
scalarInt pool "SELECT count(*) FROM shomei.shomei_auth_events WHERE event_type='email_verified'" >>= (@?= 1)
testRecoveryAndCeremonyRaces :: TestTree
testRecoveryAndCeremonyRaces = testCase "real recovery-code and pending-ceremony consume races have one persisted winner" $ withDb \pool -> do
(uid, cid, ts) <-
expectApp =<< runApp pool do
user <- createUser (NewUser aliceLogin Nothing Nothing)
ts <- now
rid <- genRecoveryCodeId
replaceRecoveryCodes user.userId [NewRecoveryCode rid "recovery-race" ts]
cid <- genCeremonyId
putPendingCeremony (PendingCeremony cid (Just user.userId) AuthenticationCeremony "signed-options-fixture" ts (addUTCTime 60 ts))
pure (user.userId, cid, ts)
recovery <- raceDatabase 8 (runApp pool (consumeRecoveryCode uid "recovery-race" ts)) >>= traverse expectApp
length (filter id recovery) @?= 1
scalarInt pool "SELECT count(*) FROM shomei.shomei_recovery_codes WHERE used_at IS NOT NULL" >>= (@?= 1)
ceremonies <- raceDatabase 8 (runApp pool (takePendingCeremony cid ts)) >>= traverse expectApp
length (filter isJust ceremonies) @?= 1
scalarInt pool "SELECT count(*) FROM shomei.shomei_webauthn_pending_ceremonies" >>= (@?= 0)
testSweepVersusLiveRotation :: TestTree
testSweepVersusLiveRotation = testCase "paced sweeper races a live refresh without deleting the rotation family" $ withDb \pool -> do
(user, pair) <- runApp pool (signup cfg (SignupCommand aliceLogin (Just aliceEmail) strongPw Nothing)) >>= expectApp >>= expectRight
let uid = "'" <> Text.pack (show (userIdToUUID user.userId)) <> "'"
execSql pool ("INSERT INTO shomei.shomei_sessions(session_id,user_id,status,created_at,expires_at) SELECT gen_random_uuid()," <> uid <> ",'active',now()-interval '32 days',now()-interval '31 days' FROM generate_series(1,10)")
cutoff <- getCurrentTime
-- Hold the sweep's first delete at a real SQL barrier while the live rotation commits.
execSql pool "CREATE FUNCTION shomei.test_sweep_barrier() RETURNS trigger LANGUAGE plpgsql AS $$ BEGIN PERFORM pg_advisory_xact_lock(1936224116,18); RETURN OLD; END $$; CREATE TRIGGER test_sweep_barrier BEFORE DELETE ON shomei.shomei_sessions FOR EACH ROW EXECUTE FUNCTION shomei.test_sweep_barrier()"
locked <- newEmptyMVar
unlock <- newEmptyMVar
holderDone <- newEmptyMVar
_ <- forkIO do
outcome <- Pool.use pool do
Session.script "SELECT pg_advisory_lock(1936224116,18)"
liftIO (putMVar locked () >> takeMVar unlock)
Session.script "SELECT pg_advisory_unlock(1936224116,18)"
putMVar holderDone outcome
takeMVar locked
swept <- newEmptyMVar
bracket_
(pure ())
(putMVar unlock () >> takeMVar holderDone >>= expectApp)
do
_ <- forkIO (sweepOnce pool defaultSweepConfig {batchSize = 1, deadSessionGraceDays = 0} cutoff >>= putMVar swept)
let awaitSweep = do
waiting <- scalarInt pool "SELECT count(*) FROM pg_locks WHERE locktype='advisory' AND classid=1936224116 AND objid=18 AND NOT granted"
if waiting > 0 then pure () else threadDelay 1000 >> awaitSweep
timeout 2000000 awaitSweep >>= (@?= Just ())
rotated <- expectApp =<< runApp pool (refresh cfg (RefreshCommand pair.refreshToken))
_ <- expectRight rotated
pure ()
report <- expectSweep =<< takeMVar swept
report.sessionsDeleted @?= 10
scalarInt pool "SELECT count(*) FROM shomei.shomei_sessions WHERE status='active'" >>= (@?= 1)
scalarInt pool "SELECT count(*) FROM shomei.shomei_refresh_tokens" >>= (@?= 2)
scalarInt pool "SELECT count(*) FROM shomei.shomei_refresh_tokens WHERE status='active'" >>= (@?= 1)
testAdminQueryPlans :: TestTree
testAdminQueryPlans = testCase "admin user and per-user audit pages use measured ordered indexes; small client catalog stays unindexed" $ withDb \pool -> do
let explain query = expectApp =<< Pool.use pool (Session.statement () (preparable ("EXPLAIN (ANALYZE, BUFFERS) " <> query) E.noParams (D.rowList (D.column (D.nonNullable D.text)))))
users = "SELECT * FROM shomei.shomei_users ORDER BY created_at DESC,user_id DESC LIMIT 50"
suspended = "SELECT * FROM shomei.shomei_users WHERE status='suspended' ORDER BY created_at DESC,user_id DESC LIMIT 50"
audit = "SELECT * FROM shomei.shomei_auth_events WHERE user_id='10000000-0000-0000-0000-000000000001' ORDER BY created_at DESC,event_id DESC LIMIT 50"
clients = "SELECT * FROM shomei.shomei_oauth_clients ORDER BY created_at DESC,oauth_client_id DESC"
execSql pool "INSERT INTO shomei.shomei_users(user_id,login_id,status,created_at,updated_at) SELECT gen_random_uuid(),'plan-user-'||i,CASE WHEN i%2=0 THEN 'active' ELSE 'suspended' END,now()-i*interval '1 second',now() FROM generate_series(1,10000) i"
execSql pool "INSERT INTO shomei.shomei_auth_events(event_id,user_id,event_type,payload,created_at) SELECT gen_random_uuid(),CASE WHEN i<=1000 THEN '10000000-0000-0000-0000-000000000001'::uuid ELSE '10000000-0000-0000-0000-000000000002'::uuid END,'login_succeeded','{}',now()+i*interval '1 second' FROM generate_series(1,11000) i"
execSql pool "INSERT INTO shomei.shomei_oauth_clients(oauth_client_id,client_id,client_type,display_name,redirect_uris,allowed_scopes,status,created_at) SELECT gen_random_uuid(),'plan-client-'||i,'public','Fixture','[]','[]','active',now() FROM generate_series(1,40) i"
execSql pool "DROP INDEX IF EXISTS shomei.shomei_users_created_id_idx; DROP INDEX IF EXISTS shomei.shomei_users_status_created_id_idx; DROP INDEX IF EXISTS shomei.shomei_auth_events_user_created_id_idx; ANALYZE shomei.shomei_users; ANALYZE shomei.shomei_auth_events; ANALYZE shomei.shomei_oauth_clients"
before <- traverse explain [users, suspended, audit, clients]
execSql pool "CREATE INDEX shomei_users_created_id_idx ON shomei.shomei_users(created_at DESC,user_id DESC); CREATE INDEX shomei_users_status_created_id_idx ON shomei.shomei_users(status,created_at DESC,user_id DESC); CREATE INDEX shomei_auth_events_user_created_id_idx ON shomei.shomei_auth_events(user_id,created_at DESC,event_id DESC)"
after <- traverse explain [users, suspended, audit, clients]
forM_ (zip (take 3 after) ["shomei_users_created_id_idx", "shomei_users_status_created_id_idx", "shomei_auth_events_user_created_id_idx"]) \(plan, indexName) -> do
assertBool "bounded page uses the ordered index" (any (Text.isInfixOf indexName) plan)
assertBool "bounded page needs no sort" (not (any (Text.isInfixOf "Sort") plan))
writeFile "/tmp/shomei-admin-query-plans.txt" (Text.unpack (Text.unlines (concat (zipWith3 (\name b a -> [name <> " before:"] <> b <> [name <> " after:"] <> a) ["Users", "Suspended users", "Per-user audit", "40-client catalog (no new index)"] before after))))