-- | Integration tests for the PostgreSQL adapters, run against throwaway databases
-- provisioned by @shomei-migrations:test-support@ (ephemeral-pg + pg-migrate). Each test gets a
-- fresh migrated database, acquires a hasql pool, runs the real interpreters, and asserts
-- behavior — first port-by-port round-trips, then EP-2's workflows driven through the
-- PostgreSQL interpreters with database-state assertions.
module Main (main) where
import Control.Concurrent (forkIO, newEmptyMVar, putMVar, readMVar, takeMVar, threadDelay)
import Control.Exception (evaluate)
import Control.Monad (forM_, replicateM, void, when)
import Data.ByteString (ByteString)
import Data.ByteString qualified as BS
import Data.Either (isLeft)
import Data.IORef (IORef, atomicModifyIORef', modifyIORef', newIORef, readIORef)
import Data.Int (Int64)
import Data.List (sort, tails)
import Data.Maybe (isJust, isNothing)
import Data.Set qualified as Set
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Time (UTCTime (..), addUTCTime, fromGregorian, getCurrentTime)
import Effectful (Eff, IOE, liftIO, runEff, (:>))
import Effectful.Dispatch.Dynamic (interpose, interpret_, send)
import Effectful.Error.Static (Error, runErrorNoCallStack)
import GHC.Clock (getMonotonicTimeNSec)
import GHC.Conc (getNumCapabilities)
import Hasql.Decoders qualified as D
import Hasql.Encoders qualified as E
import Hasql.Errors qualified as Hasql
import Hasql.Pool (Pool)
import Hasql.Pool qualified as Pool
import Hasql.Session qualified as Session
import Hasql.Statement (preparable)
import Shomei.Account.Credential.Domain (Credential (..))
import Shomei.Account.Credential.Postgres (runCredentialStorePostgres)
import Shomei.Account.Credential.Store (CredentialStore, createPasswordCredential, findPasswordCredentialByEmail, findPasswordCredentialByLoginId)
import Shomei.Account.Email.Domain (Email, emailText, mkEmail)
import Shomei.Account.Lifecycle.Workflow
( ConfirmEmailVerification (..),
ConfirmPasswordReset (..),
RequestEmailVerification (..),
RequestPasswordReset (..),
confirmEmailVerification,
confirmPasswordReset,
requestEmailVerification,
requestPasswordReset,
)
import Shomei.Account.LoginId.Domain (LoginId, loginIdText, mkLoginId)
import Shomei.Account.Notification.Domain (Notification (..))
import Shomei.Account.Notification.Store (Notifier (..))
import Shomei.Account.OneTimeToken.Domain (OneTimeToken, OneTimeTokenHash (..), OneTimeTokenStatus (..))
import Shomei.Account.Password.Breach.Store (PasswordBreachChecker)
import Shomei.Account.Password.Domain (PasswordHash (..), PlainPassword (..))
import Shomei.Account.Password.Hash.Postgres
( Argon2Params (..),
argon2HardFloor,
defaultArgon2Params,
dummyHashFor,
hashPasswordArgon2id,
newHashingLimiter,
peakHashingConcurrency,
runPasswordHasherCrypto,
runTokenGenCrypto,
trialArgon2Derivation,
verifyPasswordArgon2id,
withHashingPermit,
)
import Shomei.Account.Password.Hash.Store (PasswordHasher, hashPassword, verifyPasswordDummy)
import Shomei.Account.PasswordReset.Domain (NewPasswordResetToken (..), PersistedPasswordResetToken (..))
import Shomei.Account.PasswordReset.Postgres (runPasswordResetTokenStorePostgres)
import Shomei.Account.PasswordReset.Store
( PasswordResetTokenStore,
createPasswordResetToken,
findPasswordResetTokenByHash,
markPasswordResetTokenConsumed,
)
import Shomei.Account.User.Domain (NewUser (..), User (..), UserStatus (..))
import Shomei.Account.User.Postgres (runUserStorePostgres)
import Shomei.Account.User.Store
( UserCursor (..),
UserListQuery (..),
UserStore,
createUser,
emptyUserListQuery,
findUserByEmail,
findUserById,
findUserByLoginId,
listUsers,
markUserEmailVerified,
updateUserStatus,
)
import Shomei.Account.Verification.Domain (NewVerificationToken (..), PersistedVerificationToken (..))
import Shomei.Account.Verification.Postgres (runVerificationTokenStorePostgres)
import Shomei.Account.Verification.Store
( VerificationTokenStore,
createVerificationToken,
findVerificationTokenByHash,
markVerificationTokenConsumed,
)
import Shomei.Audit.Event.Codec (reconstructAuthEvent)
import Shomei.Audit.Event.Domain qualified as Event
import Shomei.Audit.Publisher.Postgres (runAuthEventPublisherPostgres)
import Shomei.Audit.Publisher.Store (AuthEventPublisher, publishAuthEvent)
import Shomei.Audit.Reader.Postgres (runAuthEventReaderPostgres)
import Shomei.Audit.Reader.Store
( AuditCursor (..),
AuditEventQuery (..),
AuthEventReader,
StoredAuthEvent (..),
countAuthEvents,
emptyAuditQuery,
queryAuthEvents,
)
import Shomei.Authorization.Claims.Domain (Audience (..), AuthClaims (..), Issuer (..), Permission (..), Role (..), Scope (..))
import Shomei.Authorization.Claims.Store (ClaimsEnricher, runClaimsEnricherNull)
import Shomei.Authorization.Role.Postgres (runRoleStorePostgres)
import Shomei.Authorization.Role.Store
( RoleDefinition (..),
RoleStore,
allowPermission,
defineRole,
disallowPermission,
grantRole,
listDefinedRoles,
listPermissionsForRole,
listRolesForUser,
permissionsForRoles,
revokeRole,
)
import Shomei.Authorization.Role.Workflow (grantRoleTo)
import Shomei.Config (RateLimitConfig (..), ShomeiConfig (..), defaultRateLimitConfig, defaultShomeiConfig)
import Shomei.Error (AuthDependency (PostgreSQL), AuthError (DependencyUnavailable, EmailAlreadyRegistered, InvalidCredentials, LoginIdAlreadyRegistered, PasswordResetTokenInvalid, RefreshTokenReuseDetected, RoleNotDefined, UserNotFound))
import Shomei.Error qualified as Err
import Shomei.Id (OAuthClientId, PasskeyId, ServiceAccountDbId, genCeremonyId, genOAuthClientId, genRecoveryCodeId, genServiceAccountDbId, genSessionId, genTotpCredentialId, genUserId, idText, userIdToUUID)
import Shomei.Mfa.RecoveryCode.Postgres (runRecoveryCodeStorePostgres)
import Shomei.Mfa.RecoveryCode.Store
( RecoveryCodeStore,
consumeRecoveryCode,
countUnusedRecoveryCodes,
replaceRecoveryCodes,
)
import Shomei.Mfa.Totp.Algorithm (TotpSecret (..))
import Shomei.Mfa.Totp.Domain (NewRecoveryCode (..), NewTotpCredential (..), TotpCredential (..))
import Shomei.Mfa.Totp.Postgres
( TotpEncryptionKey,
runTotpCredentialStorePostgres,
totpEncryptionKeyFromBytes,
)
import Shomei.Mfa.Totp.Store
( TotpCredentialStore,
confirmTotp,
deleteTotpByUser,
findTotpByUser,
setTotpLastUsedCounter,
upsertTotpEnrollment,
)
import Shomei.Migrations.TestSupport (withShomeiMigratedDatabase)
import Shomei.OAuth.AuthorizationCode.Domain (AuthorizationCode (..), NewAuthorizationCode (..))
import Shomei.OAuth.AuthorizationCode.Postgres (runOAuthCodeStorePostgres)
import Shomei.OAuth.AuthorizationCode.Store
( OAuthCodeStore,
bindAuthorizationCodeSession,
consumeAuthorizationCode,
deleteExpiredAuthorizationCodes,
findConsumedAuthorizationCode,
putAuthorizationCode,
)
import Shomei.OAuth.Client.Domain
( ClientType (..),
NewOAuthClient (..),
OAuthClient (..),
OAuthClientStatus (..),
)
import Shomei.OAuth.Client.Postgres (runOAuthClientStorePostgres)
import Shomei.OAuth.Client.Store
( OAuthClientStore,
createOAuthClient,
findOAuthClientByClientId,
listOAuthClients,
revokeOAuthClient,
)
import Shomei.OAuth.IdToken.Domain (IdToken (..))
import Shomei.Passkey.Ceremony.Port (WebAuthnCeremony)
import Shomei.Passkey.Ceremony.Postgres (runPendingCeremonyStorePostgres)
import Shomei.Passkey.Ceremony.Store (PendingCeremonyStore, putPendingCeremony, takePendingCeremony)
import Shomei.Passkey.Domain
( CeremonyKind (..),
NewPasskeyCredential (..),
PasskeyCredential (..),
PendingCeremony (..),
PublicKeyBytes (..),
SignatureCounter (..),
UserHandle (..),
WebAuthnCredentialId (..),
)
import Shomei.Passkey.Postgres (runPasskeyStorePostgres)
import Shomei.Passkey.Store
( PasskeyStore,
countPasskeysByUser,
createPasskey,
deletePasskey,
findPasskeyByCredentialId,
findPasskeysByUser,
findPasskeysByUserHandle,
updatePasskeySignCounter,
)
import Shomei.Persistence.Database.Postgres (Database (..), runDatabasePool)
import Shomei.Persistence.Maintenance.Postgres
( SweepConfig (..),
SweepReport (..),
defaultSweepConfig,
emptySweepReport,
sweepOnce,
)
import Shomei.Persistence.Pool.Postgres (acquirePool)
import Shomei.ServiceAccount.Domain (NewServiceAccount (..), ServiceAccount (..), ServiceAccountStatus (..))
import Shomei.ServiceAccount.Postgres (runServiceAccountStorePostgres)
import Shomei.ServiceAccount.Store
( ServiceAccountStore,
createServiceAccount,
findServiceAccountByClientId,
listServiceAccounts,
revokeServiceAccount,
rotateServiceAccountSecret,
)
import Shomei.Session.Authentication.Workflow (login, logout, refresh, signup)
import Shomei.Session.Command (ClientContext (..), LoginCommand (..), LogoutCommand (..), RefreshCommand (..), SignupCommand (..))
import Shomei.Session.Domain (NewSession (..), Session (..), SessionKind (..), SessionStatus (..))
import Shomei.Session.LoginAttempt.Domain (AccountKey (..), AccountLockout (..), AttemptFactor (..), ClientIp (..), FailureOutcome (..), LockPolicy (..), LoginOutcome (..), NewLoginAttempt (..))
import Shomei.Session.LoginAttempt.Postgres (runLoginAttemptStorePostgres)
import Shomei.Session.LoginAttempt.Store
( LoginAttemptStore,
clearAccountLockout,
countRecentFailuresByAccount,
countRecentFailuresByIp,
getAccountLockout,
recordLoginFailure,
setAccountLockout,
)
import Shomei.Session.Postgres (runSessionStorePostgres)
import Shomei.Session.RefreshToken.Domain (NewRefreshToken (..), PersistedRefreshToken (..), RefreshToken (..), RefreshTokenStatus (..))
import Shomei.Session.RefreshToken.Postgres (runRefreshTokenStorePostgres)
import Shomei.Session.RefreshToken.Store (RefreshTokenStore, createRefreshToken, findRefreshTokenByHash, markRefreshTokenUsed)
import Shomei.Session.Store (SessionStore, createSession, findSessionById, listSessionsForUser, revokeSession)
import Shomei.Session.Token.Domain (AccessToken (..), TokenPair (..))
import Shomei.Session.Token.Generator (TokenGen, hashRefreshToken)
import Shomei.Session.UnitOfWork.Postgres (runAuthUnitOfWorkPostgres)
import Shomei.Session.UnitOfWork.Store (AuthUnitOfWork, revokeSessionWithTokens)
import Shomei.Session.Workflow (buildEnrichedClaims)
import Shomei.SigningKey.Domain (SigningKeyStatus (..), StoredSigningKey (..))
import Shomei.SigningKey.Postgres (runSigningKeyStorePostgres)
import Shomei.SigningKey.Signer (TokenSigner (..))
import Shomei.SigningKey.Store (SigningKeyStore, findSigningKeyByKid, insertSigningKey, listActiveSigningKeys, listPublishableSigningKeys, replaceActiveSigningKey, updateSigningKeyStatus)
import Shomei.Test.InMemory (emptyWorld, runPasswordBreachCheckerFake, runWebAuthnCeremonyFake)
import Shomei.Time.Postgres (runClockIO)
import Shomei.Time.Store (Clock (..), now)
import Test.Tasty (TestTree, defaultMain, testGroup)
import Test.Tasty.HUnit (Assertion, assertBool, assertEqual, assertFailure, testCase, (@?=))
-- | The full interpreter stack used by every test. The store interpreters are peeled
-- first (Database/IOE/Error remain available to them); @TokenSigner@ is a trivial fake
-- because real signing is EP-4.
type AppEffects =
'[ UserStore,
RoleStore,
CredentialStore,
SessionStore,
RefreshTokenStore,
AuthUnitOfWork,
VerificationTokenStore,
PasswordResetTokenStore,
LoginAttemptStore,
PasskeyStore,
PendingCeremonyStore,
ServiceAccountStore,
OAuthClientStore,
OAuthCodeStore,
TotpCredentialStore,
RecoveryCodeStore,
Notifier,
ClaimsEnricher,
WebAuthnCeremony,
AuthEventPublisher,
AuthEventReader,
SigningKeyStore,
TokenSigner,
PasswordBreachChecker,
PasswordHasher,
TokenGen,
Clock,
Database,
Error AuthError,
IOE
]
runApp :: Pool -> Eff AppEffects a -> IO (Either AuthError a)
runApp pool action = do
ref <- newIORef []
runAppWithNotifications ref pool action
runAppWithNotifications :: IORef [Notification] -> Pool -> Eff AppEffects a -> IO (Either AuthError a)
runAppWithNotifications ref pool action = do
wref <- newIORef (emptyWorld (UTCTime (fromGregorian 2000 1 1) 0))
limiter <- newHashingLimiter 2
( runEff
. runErrorNoCallStack
. runDatabasePool pool
. runClockIO
. runTokenGenCrypto
-- Cheap parameters: these workflow tests hash real passwords, and the production cost
-- (~100 ms per hash) would dominate the suite. The argon2 tests below cover the real ones.
. runPasswordHasherCrypto limiter cheapParams
. runPasswordBreachCheckerFake wref
. runTokenSignerFake
. runSigningKeyStorePostgres
. runAuthEventReaderPostgres
. runAuthEventPublisherPostgres
. runWebAuthnCeremonyFake wref
. runClaimsEnricherNull
. runNotifierRef ref
. runRecoveryCodeStorePostgres
. runTotpCredentialStorePostgres testTotpKey
. runOAuthCodeStorePostgres
. runOAuthClientStorePostgres
. runServiceAccountStorePostgres
. runPendingCeremonyStorePostgres
. runPasskeyStorePostgres
. runLoginAttemptStorePostgres
. runPasswordResetTokenStorePostgres
. runVerificationTokenStorePostgres
. runAuthUnitOfWorkPostgres
. runRefreshTokenStorePostgres
. runSessionStorePostgres
. runCredentialStorePostgres
. runRoleStorePostgres
. runUserStorePostgres
)
action
-- | Run the stack with a FIXED clock (the EP-2 lockout tests need to advance time
-- deterministically across calls against the same database). Notifications are discarded.
runAppAtTime :: UTCTime -> Pool -> Eff AppEffects a -> IO (Either AuthError a)
runAppAtTime t pool action = do
ref <- newIORef []
wref <- newIORef (emptyWorld t)
limiter <- newHashingLimiter 2
( runEff
. runErrorNoCallStack
. runDatabasePool pool
. runClockFixed t
. runTokenGenCrypto
. runPasswordHasherCrypto limiter cheapParams
. runPasswordBreachCheckerFake wref
. runTokenSignerFake
. runSigningKeyStorePostgres
. runAuthEventReaderPostgres
. runAuthEventPublisherPostgres
. runWebAuthnCeremonyFake wref
. runClaimsEnricherNull
. runNotifierRef ref
. runRecoveryCodeStorePostgres
. runTotpCredentialStorePostgres testTotpKey
. runOAuthCodeStorePostgres
. runOAuthClientStorePostgres
. runServiceAccountStorePostgres
. runPendingCeremonyStorePostgres
. runPasskeyStorePostgres
. runLoginAttemptStorePostgres
. runPasswordResetTokenStorePostgres
. runVerificationTokenStorePostgres
. runAuthUnitOfWorkPostgres
. runRefreshTokenStorePostgres
. runSessionStorePostgres
. runCredentialStorePostgres
. runRoleStorePostgres
. runUserStorePostgres
)
action
runClockFixed :: UTCTime -> Eff (Clock : es) a -> Eff es a
runClockFixed t = interpret_ \case
Now -> pure t
-- | A trivial 'TokenSigner' (real signing is EP-4); the DB-state assertions never inspect
-- the access token's contents.
runTokenSignerFake :: Eff (TokenSigner : es) a -> Eff es a
runTokenSignerFake = interpret_ \case
SignAccessToken _ -> pure (AccessToken "test-access-token")
SignIdToken _ -> pure (IdToken "test-id-token")
runNotifierRef :: (IOE :> es) => IORef [Notification] -> Eff (Notifier : es) a -> Eff es a
runNotifierRef ref = interpret_ \case
SendNotification n -> liftIO (modifyIORef' ref (n :))
-- Helpers --------------------------------------------------------------------
cfg :: ShomeiConfig
cfg = defaultShomeiConfig (Issuer "shomei") (Audience "shomei-clients")
-- | Tightened thresholds for the EP-2 lockout test (lock after 3 per-account failures).
lockCfg :: ShomeiConfig
lockCfg = cfg {rateLimitConfig = defaultRateLimitConfig {maxFailedLoginsPerAccount = 3}}
t0 :: UTCTime
t0 = UTCTime (fromGregorian 2026 1 1) 0
aliceEmail :: Email
aliceEmail = mkEmail' "alice@example.com"
bobEmail :: Email
bobEmail = mkEmail' "bob@example.com"
aliceLogin :: LoginId
aliceLogin = either (error . show) id (mkLoginId (emailText aliceEmail))
bobLogin :: LoginId
bobLogin = either (error . show) id (mkLoginId (emailText bobEmail))
strongPw :: PlainPassword
strongPw = PlainPassword "correct horse battery staple"
mkEmail' :: Text -> Email
mkEmail' t = case mkEmail t of
Right e -> e
Left err -> error ("bad test email: " <> show err)
mkLoginId' :: Text -> LoginId
mkLoginId' t = case mkLoginId t of
Right l -> l
Left err -> error ("bad test login id: " <> show err)
-- | Run an action over a fresh migrated database and a pool.
withDb :: (Pool -> IO a) -> IO a
withDb action = withShomeiMigratedDatabase \connStr -> do
pool <- acquirePool 4 10 30000 connStr
action pool
-- | Unwrap the @Either AuthError@ from 'runApp' (the interpreter-level failure channel).
expectApp :: (Show e) => Either e a -> IO a
expectApp = either (\e -> assertFailure ("interpreter error: " <> show e)) pure
-- | Unwrap a workflow's own @Either AuthError@ result.
expectRight :: (Show e) => Either e a -> IO a
expectRight = either (\e -> assertFailure ("expected Right, got Left: " <> show e)) pure
-- | Run a (possibly multi-statement) SQL script directly against the pool, for seeding.
execSql :: Pool -> Text -> IO ()
execSql pool sql = do
res <- Pool.use pool (Session.script sql)
either (\e -> assertFailure ("seed script failed: " <> show e)) pure res
-- | Assert that a raw SQL script is rejected with one exact PostgreSQL SQLSTATE.
execSqlExpectState :: Pool -> Text -> Text -> IO ()
execSqlExpectState pool expected sql = do
result <- Pool.use pool (Session.script sql)
case result of
Left (Pool.SessionUsageError (Hasql.ScriptSessionError _ (Hasql.ServerError actual _ _ _ _))) ->
actual @?= expected
Left err -> assertFailure ("expected SQLSTATE " <> Text.unpack expected <> ", got: " <> show err)
Right () -> assertFailure ("expected SQLSTATE " <> Text.unpack expected <> ", but SQL succeeded")
-- | Unwrap the typed dependency result that 'sweepOnce' returns.
expectSweep :: Either AuthError SweepReport -> IO SweepReport
expectSweep = either (\e -> assertFailure ("sweep failed: " <> show e)) pure
-- | A scalar @count(*)@ (or any single-bigint) query, run directly against the pool.
scalarInt :: Pool -> Text -> IO Int
scalarInt pool sql = do
res <- Pool.use pool (Session.statement () stmt)
either (\e -> assertFailure ("scalar query failed: " <> show e)) pure res
where
stmt =
preparable
sql
E.noParams
(D.singleRow (fromIntegral64 <$> D.column (D.nonNullable D.int8)))
fromIntegral64 :: Int64 -> Int
fromIntegral64 = fromIntegral
-- | A single @bytea@ column, run directly against the pool (used to inspect @secret_enc@).
scalarBytea :: Pool -> Text -> IO ByteString
scalarBytea pool sql = do
res <- Pool.use pool (Session.statement () stmt)
either (\e -> assertFailure ("scalar bytea query failed: " <> show e)) pure res
where
stmt = preparable sql E.noParams (D.singleRow (D.column (D.nonNullable D.bytea)))
-- | A fixed 32-byte AES-256-GCM key for the TOTP round-trip tests. Value is irrelevant; the test
-- only proves encrypt-then-decrypt is the identity and that the ciphertext is not the plaintext.
testTotpKey :: TotpEncryptionKey
testTotpKey = case totpEncryptionKeyFromBytes (BS.replicate 32 7) of
Right k -> k
Left e -> error ("bad test TOTP key: " <> Text.unpack e)
-- | 20 raw secret bytes (the RFC 6238 Appendix B secret).
totpRawSecret :: ByteString
totpRawSecret = "12345678901234567890"
-- Field accessors: OverloadedRecordDot is unreliable for these DuplicateRecordFields records.
tcSecret :: TotpCredential -> TotpSecret
tcSecret TotpCredential {secret} = secret
tcConfirmedAt :: TotpCredential -> Maybe UTCTime
tcConfirmedAt TotpCredential {confirmedAt} = confirmedAt
tcLastUsedCounter :: TotpCredential -> Maybe Int64
tcLastUsedCounter TotpCredential {lastUsedCounter} = lastUsedCounter
-- Tests ----------------------------------------------------------------------
main :: IO ()
main = defaultMain (testGroup "shomei-postgres" tests)
tests :: [TestTree]
tests =
[ testUserRoundTrip,
testUserNoEmailAndUniqueLoginId,
testSchemaRejectsInvalidUserStatusAndCaseVariantIdentities,
testListUsersOrderFilterAndPaging,
testUserStatusIsCompareAndSwap,
testUserStatusCasUnderRace,
testListSessionsForUser,
testCredentialRoundTrip,
testCredentialUniquePerUser,
testPoolStatementTimeoutIsApplied,
testSessionRevoke,
testSessionActorRoundTrip,
testSessionKindRoundTrip,
testSessionGrantedScopesRoundTrip,
testSessionKindNullReadsInteractive,
testRefreshTokenMarkUsed,
testVerificationTokenRoundTrip,
testPasswordResetTokenRoundTrip,
testMarkUserEmailVerified,
testSigningKeys,
testPublishableSigningKeys,
testSigningKeyTransitionTimestamps,
testSigningKeyOneActiveInvariant,
testPublishEvent,
testAuditEventReader,
testWorkflowSignup,
testLoginRoundTripBudget,
testFailedLoginRoundTripBudget,
testRefreshRoundTripBudget,
testLogoutRoundTripBudget,
testPasswordResetRoundTripBudget,
testWorkflowRefreshRotation,
testWorkflowReuseRevokesFamily,
testWorkflowAccountVerification,
testWorkflowPasswordReset,
testRevokeSessionIsCompareAndSwap,
testLoginAttemptStore,
testLockoutRecordAndCountIsAtomicUnderRace,
testWorkflowLockout,
testPasskeyCreateAndFind,
testPasskeyUpdateCountDelete,
testPasskeyCounterIsCompareAndSwap,
testPasskeyCounterCasUnderRace,
testServiceAccountRoundTrip,
testOAuthClientRoundTrip,
testAuthorizationCodeRoundTrip,
testAuthorizationCodeConsumeIsAtomicUnderRace,
testTotpCredentialRoundTrip,
testTotpCounterIsCompareAndSwap,
testTotpCounterCasUnderRace,
testTotpEncryptionAtRest,
testRecoveryCodeCasAndReplace,
testPendingCeremonyConsumeOnce,
testPendingCeremonyExpired,
testArgon2NewHashesArePhcFormatted,
testArgon2RejectsUnparameterizedHashes,
testArgon2ParamsChangeLeavesOldHashesVerifiable,
testArgon2MalformedHashesVerifyFalse,
testArgon2DummyHashTracksConfiguredParams,
testArgon2HardFloorMatchesTheImplementation,
testHashingLimiterBoundsConcurrency 1,
testHashingLimiterBoundsConcurrency 2,
testInterpreterForcesTheHashInsideThePermit,
testDummyVerificationTakesAPermit,
testSweepDeletesExpiredRows,
testSweepIsIdempotent,
testSweepAuthEventRetention,
testSweepBatchesUntilDrained,
testSweepBatchesWholeTokenFamilies,
testRoleRegistry,
testRoleGrants,
testRoleGrantForeignKeys,
testGrantedRoleReachesEnrichedClaims,
testRolePermissions,
testRolePermissionForeignKey,
testExpiringGrants
]
-- | The registry: seeded with @admin@ by the migration, idempotent definition, sorted listing.
testRoleRegistry :: TestTree
testRoleRegistry =
testCase "role registry: seeded with admin; define is idempotent; list is sorted" $ withDb \pool -> do
result <- runApp pool do
seeded <- listDefinedRoles
ts <- now
firstDefine <- defineRole (Role "auditor") (Just "read the audit trail") ts
secondDefine <- defineRole (Role "auditor") (Just "a different description") ts
after' <- listDefinedRoles
pure (seeded, firstDefine, secondDefine, after')
(seeded, firstDefine, secondDefine, after') <- expectApp result
map (.role) seeded @?= [Role "admin"]
firstDefine @?= True
-- Re-defining is a no-op: it reports no change and does NOT overwrite the description.
secondDefine @?= False
map (.role) after' @?= [Role "admin", Role "auditor"]
map (.description) after' @?= [Just adminSeedDescription, Just "read the audit trail"]
-- | Grants: idempotent insert, listing, revocation, and the "nothing to revoke" report.
testRoleGrants :: TestTree
testRoleGrants =
testCase "role grants: idempotent grant/revoke round-trip" $ withDb \pool -> do
result <- runApp pool do
u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})
ts <- now
_ <- defineRole (Role "auditor") Nothing ts
firstGrant <- grantRole u.userId (Role "admin") Nothing Nothing ts
secondGrant <- grantRole u.userId (Role "admin") Nothing Nothing ts
_ <- grantRole u.userId (Role "auditor") (Just u.userId) Nothing ts
granted <- listRolesForUser u.userId ts
firstRevoke <- revokeRole u.userId (Role "admin")
secondRevoke <- revokeRole u.userId (Role "admin")
remaining <- listRolesForUser u.userId ts
pure (firstGrant, secondGrant, granted, firstRevoke, secondRevoke, remaining)
(firstGrant, secondGrant, granted, firstRevoke, secondRevoke, remaining) <- expectApp result
firstGrant @?= True
secondGrant @?= False
granted @?= Set.fromList [Role "admin", Role "auditor"]
firstRevoke @?= True
secondRevoke @?= False
remaining @?= Set.singleton (Role "auditor")
-- | The database enforces both foreign keys, so code that bypasses 'Shomei.Authorization.Role.Workflow'
-- still cannot create a dangling grant. Hasql command failures cross the adapter boundary as
-- 'DependencyUnavailable'; the workflow catches both cases first and returns a typed error.
testRoleGrantForeignKeys :: TestTree
testRoleGrantForeignKeys =
testCase "role grants: FKs reject undefined roles and unknown users; workflow pre-checks" $ withDb \pool -> do
setup <- runApp pool do
u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})
pure u.userId
uid <- expectApp setup
-- Raw port, undefined role: the shomei_role_grants.role FK fires.
rawUndefinedRole <- runApp pool do
ts <- now
grantRole uid (Role "nosuchrole") Nothing Nothing ts
expectDependencyError "grant of an undefined role" rawUndefinedRole
-- Raw port, unknown user: the shomei_role_grants.user_id FK fires.
ghost <- genUserId
rawUnknownUser <- runApp pool do
ts <- now
grantRole ghost (Role "admin") Nothing Nothing ts
expectDependencyError "grant to a nonexistent user" rawUnknownUser
-- The workflow refuses both BEFORE touching the table, with typed errors.
workflowUndefinedRole <- runApp pool (grantRoleTo Nothing Nothing uid (Role "nosuchrole"))
expectApp workflowUndefinedRole >>= \r -> r @?= Left (RoleNotDefined (Role "nosuchrole"))
workflowUnknownUser <- runApp pool (grantRoleTo Nothing Nothing ghost (Role "admin"))
expectApp workflowUnknownUser >>= \r -> r @?= Left UserNotFound
-- And the happy path still lands a row plus exactly one role_granted audit event.
ok <- runApp pool (grantRoleTo Nothing Nothing uid (Role "admin"))
expectApp ok >>= \r -> r @?= Right True
again <- runApp pool (grantRoleTo Nothing Nothing uid (Role "admin"))
expectApp again >>= \r -> r @?= Right False
grants <- scalarInt pool "SELECT count(*) FROM shomei.shomei_role_grants"
grants @?= 1
events <- scalarInt pool "SELECT count(*) FROM shomei.shomei_auth_events WHERE event_type = 'role_granted'"
events @?= 1
where
expectDependencyError what = \case
Left (DependencyUnavailable PostgreSQL) -> pure ()
Left e -> assertFailure (what <> ": expected PostgreSQL dependency failure, got " <> show e)
Right _ -> assertFailure (what <> ": expected the foreign key to reject it")
-- | The claims path end to end over the real store: a role granted through the workflow shows
-- up in the claims 'buildEnrichedClaims' assembles, which is what every token mint signs.
testGrantedRoleReachesEnrichedClaims :: TestTree
testGrantedRoleReachesEnrichedClaims =
testCase "buildEnrichedClaims reads roles from the real PostgreSQL store" $ withDb \pool -> do
result <- runApp pool do
u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})
sid <- genSessionId
ts <- now
before <- buildEnrichedClaims cfg u.userId sid ts
_ <- grantRoleTo Nothing Nothing u.userId (Role "admin")
after' <- buildEnrichedClaims cfg u.userId sid ts
pure (before, after')
(before, after') <- expectApp result
before.roles @?= Set.empty
after'.roles @?= Set.singleton (Role "admin")
-- Shōmei persists no scopes; the null enricher adds none.
after'.scopes @?= Set.empty
-- | Role→permission wiring (EP-9): idempotent allow, single-role listing, deduplicated union
-- across a role set, and disallow with its "nothing to detach" report.
testRolePermissions :: TestTree
testRolePermissions =
testCase "role permissions: allow/list/union/disallow round-trip" $ withDb \pool -> do
result <- runApp pool do
ts <- now
_ <- defineRole (Role "support") (Just "support staff") ts
_ <- defineRole (Role "billing") (Just "billing staff") ts
firstAllow <- allowPermission (Role "support") (Permission "tickets:write") ts
dupAllow <- allowPermission (Role "support") (Permission "tickets:write") ts
_ <- allowPermission (Role "support") (Permission "tickets:read") ts
-- Overlapping permission on a second role, to prove the union deduplicates.
_ <- allowPermission (Role "billing") (Permission "tickets:read") ts
_ <- allowPermission (Role "billing") (Permission "invoices:read") ts
supportPerms <- listPermissionsForRole (Role "support")
union <- permissionsForRoles (Set.fromList [Role "support", Role "billing"])
firstDisallow <- disallowPermission (Role "support") (Permission "tickets:write")
secondDisallow <- disallowPermission (Role "support") (Permission "tickets:write")
afterDisallow <- listPermissionsForRole (Role "support")
pure (firstAllow, dupAllow, supportPerms, union, firstDisallow, secondDisallow, afterDisallow)
(firstAllow, dupAllow, supportPerms, union, firstDisallow, secondDisallow, afterDisallow) <- expectApp result
firstAllow @?= True
dupAllow @?= False
supportPerms @?= Set.fromList [Permission "tickets:read", Permission "tickets:write"]
union @?= Set.fromList [Permission "invoices:read", Permission "tickets:read", Permission "tickets:write"]
firstDisallow @?= True
secondDisallow @?= False
afterDisallow @?= Set.singleton (Permission "tickets:read")
-- | The @shomei_role_permissions.role@ FK rejects attaching a permission to an undefined role,
-- exactly as the grants FK rejects granting one. The raw port surfaces the Hasql command
-- failure as 'DependencyUnavailable PostgreSQL'.
testRolePermissionForeignKey :: TestTree
testRolePermissionForeignKey =
testCase "role permissions: allow on an undefined role hits the FK" $ withDb \pool -> do
res <- runApp pool do
ts <- now
allowPermission (Role "nosuchrole") (Permission "tickets:write") ts
case res of
Left (DependencyUnavailable PostgreSQL) -> pure ()
Left e -> assertFailure ("expected PostgreSQL dependency failure, got " <> show e)
Right _ -> assertFailure "expected the FK to reject a permission on an undefined role"
-- | Time-bound grants (EP-9): a grant with an expiry drops out of 'listRolesForUser' as of an
-- instant past it, but is present as of an instant before it; re-granting with a different expiry
-- reports a change and the new window wins, while an identical re-grant reports none.
testExpiringGrants :: TestTree
testExpiringGrants =
testCase "expiring grants: as-of filter, and upsert reports change only when expiry moves" $ withDb \pool -> do
result <- runApp pool do
u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})
ts <- now
let expiry = addUTCTime 3600 ts -- one hour out
_ <- grantRole u.userId (Role "admin") Nothing (Just expiry) ts
liveNow <- listRolesForUser u.userId ts -- before expiry: present
liveAfter <- listRolesForUser u.userId (addUTCTime 7200 ts) -- after expiry: gone
-- Identical re-grant: no change.
sameAgain <- grantRole u.userId (Role "admin") Nothing (Just expiry) ts
-- Re-grant moving the expiry further out: a change, and the new window applies.
let expiry2 = addUTCTime 10800 ts
moved <- grantRole u.userId (Role "admin") Nothing (Just expiry2) ts
liveAtOldExpiry <- listRolesForUser u.userId (addUTCTime 7200 ts) -- now inside the new window
pure (liveNow, liveAfter, sameAgain, moved, liveAtOldExpiry)
(liveNow, liveAfter, sameAgain, moved, liveAtOldExpiry) <- expectApp result
liveNow @?= Set.singleton (Role "admin")
liveAfter @?= Set.empty
sameAgain @?= False
moved @?= True
liveAtOldExpiry @?= Set.singleton (Role "admin")
-- | The description the @shomei-role-grants@ migration seeds onto the @admin@ role.
adminSeedDescription :: Text
adminSeedDescription = "Full access to the shomei /admin surface and admin CLI-equivalent HTTP routes"
-- | The TOTP credential store's contract against real PostgreSQL: the raw secret survives the
-- encrypt→store→decrypt round-trip, @confirm@ and the last-used counter land, and delete removes
-- the row.
testTotpCredentialRoundTrip :: TestTree
testTotpCredentialRoundTrip =
testCase "totp credential: enroll, find (raw secret round-trips), confirm, counter, delete" $ withDb \pool -> do
result <- runApp pool do
u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})
tcid <- genTotpCredentialId
t <- now
created <-
upsertTotpEnrollment
NewTotpCredential {totpCredentialId = tcid, userId = u.userId, secret = TotpSecret totpRawSecret, createdAt = t}
found0 <- findTotpByUser u.userId
confirmTotp tcid t
counterAdvanced <- setTotpLastUsedCounter tcid 42
found1 <- findTotpByUser u.userId
deleteTotpByUser u.userId
found2 <- findTotpByUser u.userId
pure (created, found0, counterAdvanced, found1, found2)
(created, found0, counterAdvanced, found1, found2) <- expectApp result
tcSecret created @?= TotpSecret totpRawSecret
fmap tcSecret found0 @?= Just (TotpSecret totpRawSecret)
fmap tcConfirmedAt found0 @?= Just Nothing
counterAdvanced @?= True
fmap (isJust . tcConfirmedAt) found1 @?= Just True
fmap tcLastUsedCounter found1 @?= Just (Just 42)
found2 @?= Nothing
testTotpCounterIsCompareAndSwap :: TestTree
testTotpCounterIsCompareAndSwap =
testCase "totp counter advances only to a strictly newer value" $ withDb \pool -> do
result <- runApp pool do
u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})
tcid <- genTotpCredentialId
t <- now
_ <-
upsertTotpEnrollment
NewTotpCredential {totpCredentialId = tcid, userId = u.userId, secret = TotpSecret totpRawSecret, createdAt = t}
first <- setTotpLastUsedCounter tcid 42
same <- setTotpLastUsedCounter tcid 42
older <- setTotpLastUsedCounter tcid 41
newer <- setTotpLastUsedCounter tcid 43
stored <- findTotpByUser u.userId
pure (first, same, older, newer, stored)
(first, same, older, newer, stored) <- expectApp result
(first, same, older, newer) @?= (True, False, False, True)
fmap tcLastUsedCounter stored @?= Just (Just 43)
testTotpCounterCasUnderRace :: TestTree
testTotpCounterCasUnderRace =
testCase "totp counter: eight racing updates have one winner" $ withDb \pool -> do
seeded <- runApp pool do
u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})
tcid <- genTotpCredentialId
t <- now
_ <-
upsertTotpEnrollment
NewTotpCredential {totpCredentialId = tcid, userId = u.userId, secret = TotpSecret totpRawSecret, createdAt = t}
pure tcid
tcid <- expectApp seeded
gate <- newEmptyMVar
dones <- replicateM 8 do
done <- newEmptyMVar
_ <- forkIO do
readMVar gate
putMVar done =<< runApp pool (setTotpLastUsedCounter tcid 42)
pure done
putMVar gate ()
results <- traverse (\done -> expectApp =<< takeMVar done) dones
length (filter id results) @?= 1
-- | The stored @secret_enc@ is genuine ciphertext: it differs from the plaintext secret and is
-- longer by exactly the 12-byte nonce and 16-byte GCM tag. Decryption is proven by the round-trip
-- test above; here we prove nothing recoverable sits at rest.
testTotpEncryptionAtRest :: TestTree
testTotpEncryptionAtRest =
testCase "totp secret is encrypted at rest (ciphertext differs from plaintext, nonce+tag framed)" $ withDb \pool -> do
result <- runApp pool do
u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})
tcid <- genTotpCredentialId
t <- now
_ <- upsertTotpEnrollment NewTotpCredential {totpCredentialId = tcid, userId = u.userId, secret = TotpSecret totpRawSecret, createdAt = t}
pure ()
_ <- expectApp result
stored <- scalarBytea pool "SELECT secret_enc FROM shomei.shomei_totp_credentials LIMIT 1"
assertBool "stored ciphertext must differ from the plaintext secret" (stored /= totpRawSecret)
-- 12-byte nonce + 20-byte ciphertext + 16-byte GCM tag
BS.length stored @?= 48
-- | The recovery-code store's contract: a replaced set is the live set, consumption is a
-- consume-once compare-and-set, the unused count tracks it, and regeneration drops the old set.
testRecoveryCodeCasAndReplace :: TestTree
testRecoveryCodeCasAndReplace =
testCase "recovery codes: replace-set, consume-once CAS, count drops, regeneration replaces" $ withDb \pool -> do
result <- runApp pool do
u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})
t <- now
ids <- replicateM 3 genRecoveryCodeId
let mk i h = NewRecoveryCode {recoveryCodeId = i, codeHash = h, createdAt = t}
codes = zipWith mk ids ["h1", "h2", "h3"]
replaceRecoveryCodes u.userId codes
countBefore <- countUnusedRecoveryCodes u.userId
firstConsume <- consumeRecoveryCode u.userId "h1" t
secondConsume <- consumeRecoveryCode u.userId "h1" t
countAfter <- countUnusedRecoveryCodes u.userId
ids2 <- replicateM 2 genRecoveryCodeId
replaceRecoveryCodes u.userId (zipWith mk ids2 ["n1", "n2"])
countAfterReplace <- countUnusedRecoveryCodes u.userId
oldConsume <- consumeRecoveryCode u.userId "h2" t
pure (countBefore, firstConsume, secondConsume, countAfter, countAfterReplace, oldConsume)
(countBefore, firstConsume, secondConsume, countAfter, countAfterReplace, oldConsume) <- expectApp result
countBefore @?= 3
firstConsume @?= True
secondConsume @?= False
countAfter @?= 2
countAfterReplace @?= 2
oldConsume @?= False
testUserRoundTrip :: TestTree
testUserRoundTrip = testCase "create + find user round-trips" $ withDb \pool -> do
result <- runApp pool do
u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Just "Alice"})
byId <- findUserById u.userId
byEmail <- findUserByEmail aliceEmail
pure (u, byId, byEmail)
(u, byId, byEmail) <- expectApp result
fmap (.userId) byId @?= Just u.userId
fmap (.loginId) byId @?= Just aliceLogin
fmap (.email) byId @?= Just (Just aliceEmail)
fmap (.displayName) byId @?= Just (Just "Alice")
fmap (.userId) byEmail @?= Just u.userId
-- | The M3 acceptance: a user can be created with NO email, round-trips by login id with
-- @email IS NULL@, the @login_id@ unique index rejects a duplicate principal, and the
-- partial unique index on @email@ permits multiple NULL emails.
testUserNoEmailAndUniqueLoginId :: TestTree
testUserNoEmailAndUniqueLoginId =
testCase "user: NULL email round-trips; login_id unique; NULL emails don't collide" $ withDb \pool -> do
let svc = mkLoginId' "svc-bot"
svc2 = mkLoginId' "svc-bot-2"
created <- runApp pool do
u <- createUser (NewUser {loginId = svc, email = Nothing, displayName = Nothing})
byLogin <- findUserByLoginId svc
pure (u, byLogin)
(u, byLogin) <- expectApp created
fmap (.email) byLogin @?= Just Nothing
fmap (.loginId) byLogin @?= Just svc
fmap (.userId) byLogin @?= Just u.userId
-- Unique-index conflicts retain their domain meaning at the persistence boundary.
dup <- runApp pool (createUser (NewUser {loginId = svc, email = Nothing, displayName = Nothing}))
dup @?= Left LoginIdAlreadyRegistered
-- a second no-email user with a distinct login id is allowed: NULL emails don't collide
second <- runApp pool (createUser (NewUser {loginId = svc2, email = Nothing, displayName = Nothing}))
_ <- expectApp second
nullEmails <- scalarInt pool "SELECT count(*) FROM shomei.shomei_users WHERE email IS NULL"
nullEmails @?= 2
_ <- expectApp =<< runApp pool (createUser (NewUser {loginId = mkLoginId' "email-owner", email = Just aliceEmail, displayName = Nothing}))
dupEmail <- runApp pool (createUser (NewUser {loginId = mkLoginId' "email-collider", email = Just aliceEmail, displayName = Nothing}))
dupEmail @?= Left EmailAlreadyRegistered
-- | The database remains a trust boundary even for writers that bypass Shomei's codecs.
-- Invalid persisted vocabulary is a CHECK violation, while login ids and email addresses are
-- unique independently of case.
testSchemaRejectsInvalidUserStatusAndCaseVariantIdentities :: TestTree
testSchemaRejectsInvalidUserStatusAndCaseVariantIdentities =
testCase "schema rejects invalid user status and case-variant identities" $ withDb \pool -> do
execSql
pool
"""
INSERT INTO shomei.shomei_users
(user_id, email, display_name, status, created_at, updated_at, login_id)
VALUES
('11111111-1111-1111-1111-111111111111', 'alice@example.com', 'Alice', 'active', now(), now(), 'alice');
"""
execSqlExpectState
pool
"23514"
"""
INSERT INTO shomei.shomei_users
(user_id, email, display_name, status, created_at, updated_at, login_id)
VALUES
('22222222-2222-2222-2222-222222222222', 'bogus@example.com', NULL, 'bogus', now(), now(), 'bogus');
"""
execSqlExpectState
pool
"23505"
"""
INSERT INTO shomei.shomei_users
(user_id, email, display_name, status, created_at, updated_at, login_id)
VALUES
('33333333-3333-3333-3333-333333333333', 'Alice@Example.com', NULL, 'active', now(), now(), 'other-login');
"""
execSqlExpectState
pool
"23505"
"""
INSERT INTO shomei.shomei_users
(user_id, email, display_name, status, created_at, updated_at, login_id)
VALUES
('44444444-4444-4444-4444-444444444444', 'other@example.com', NULL, 'active', now(), now(), 'Alice');
"""
-- | The admin listing's three promises, against the real statement: newest-first order, the
-- status filter, and a keyset walk that is both disjoint and complete.
--
-- The walk matters more than it looks. An OFFSET pager over @ORDER BY created_at DESC@ would
-- pass a two-page test on distinct timestamps and silently skip or repeat rows the moment two
-- users share one — which is exactly what a bulk import produces. The cursor compares the whole
-- @(created_at, user_id)@ tuple, so this test seeds three users and asserts the pages partition
-- them.
testListUsersOrderFilterAndPaging :: TestTree
testListUsersOrderFilterAndPaging = testCase "listUsers: newest-first, status-filtered, keyset-paged" $ withDb \pool -> do
result <- runApp pool do
u1 <- createUser (NewUser {loginId = mkLoginId' "one", email = Nothing, displayName = Nothing})
u2 <- createUser (NewUser {loginId = mkLoginId' "two", email = Nothing, displayName = Nothing})
u3 <- createUser (NewUser {loginId = mkLoginId' "three", email = Nothing, displayName = Nothing})
ts <- now
_ <- updateUserStatus u2.userId [UserActive] UserSuspended ts
everyone <- listUsers emptyUserListQuery
suspended <- listUsers emptyUserListQuery {queryStatus = Just UserSuspended}
active <- listUsers emptyUserListQuery {queryStatus = Just UserActive}
page1 <- listUsers emptyUserListQuery {queryLimit = 2}
page2 <- case reverse page1 of
[] -> pure []
(lastUser : _) ->
listUsers
emptyUserListQuery
{ queryLimit = 2,
queryBefore = Just (UserCursor {cursorCreatedAt = lastUser.createdAt, cursorUserId = lastUser.userId})
}
pure (u1, u2, u3, everyone, suspended, active, page1, page2)
(u1, u2, u3, everyone, suspended, active, page1, page2) <- expectApp result
-- Newest first. Rows created in one transaction can share a created_at, so assert on the set
-- and on the ordering key rather than on a fixed permutation.
map (.userId) everyone `shouldContainExactly` [u1.userId, u2.userId, u3.userId]
assertBool "newest-first" (isDescending (map (\u -> (u.createdAt, u.userId)) everyone))
map (.userId) suspended @?= [u2.userId]
map (.userId) active `shouldContainExactly` [u1.userId, u3.userId]
-- The keyset walk partitions the users: no overlap, nothing lost.
length page1 @?= 2
length page2 @?= 1
(map (.userId) page1 <> map (.userId) page2) `shouldContainExactly` [u1.userId, u2.userId, u3.userId]
testUserStatusIsCompareAndSwap :: TestTree
testUserStatusIsCompareAndSwap =
testCase "user status changes only from an allowed current status" $ withDb \pool -> do
result <- runApp pool do
user <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})
first <- updateUserStatus user.userId [UserActive] UserSuspended t0
second <- updateUserStatus user.userId [UserActive] UserSuspended t0
stored <- findUserById user.userId
pure (first, second, stored)
(first, second, stored) <- expectApp result
(first, second) @?= (True, False)
fmap (.status) stored @?= Just UserSuspended
testUserStatusCasUnderRace :: TestTree
testUserStatusCasUnderRace =
testCase "user status: eight racing suspends have one winner" $ withDb \pool -> do
seeded <- runApp pool do
user <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})
pure user.userId
uid <- expectApp seeded
gate <- newEmptyMVar
dones <- replicateM 8 do
done <- newEmptyMVar
_ <- forkIO do
readMVar gate
putMVar done =<< runApp pool (updateUserStatus uid [UserActive] UserSuspended t0)
pure done
putMVar gate ()
results <- traverse (\done -> expectApp =<< takeMVar done) dones
length (filter id results) @?= 1
testListSessionsForUser :: TestTree
testListSessionsForUser = testCase "listSessionsForUser returns every status, newest-first, for one user only" $ withDb \pool -> do
result <- runApp pool do
alice <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})
bob <- createUser (NewUser {loginId = bobLogin, email = Just bobEmail, displayName = Nothing})
t <- now
s1 <- createSession (NewSession {userId = alice.userId, createdAt = t, expiresAt = addUTCTime 3600 t, actor = Nothing, oauthClientId = Nothing, kind = InteractiveSession, grantedScopes = Set.empty, authenticatedAt = t})
s2 <- createSession (NewSession {userId = alice.userId, createdAt = addUTCTime 1 t, expiresAt = addUTCTime 3600 t, actor = Nothing, oauthClientId = Nothing, kind = InteractiveSession, grantedScopes = Set.empty, authenticatedAt = addUTCTime 1 t})
_ <- createSession (NewSession {userId = bob.userId, createdAt = t, expiresAt = addUTCTime 3600 t, actor = Nothing, oauthClientId = Nothing, kind = InteractiveSession, grantedScopes = Set.empty, authenticatedAt = t})
revokeSession s1.sessionId t
aliceSessions <- listSessionsForUser alice.userId
pure (s1, s2, aliceSessions)
(s1, s2, aliceSessions) <- expectApp result
-- Bob's session is absent; a revoked session is still listed (an admin must see it).
map (.sessionId) aliceSessions @?= [s2.sessionId, s1.sessionId]
map (.status) aliceSessions @?= [SessionActive, SessionRevoked]
-- | Set equality with a readable failure, without imposing an order.
shouldContainExactly :: (Ord a, Show a) => [a] -> [a] -> Assertion
shouldContainExactly actual expected = sort actual @?= sort expected
isDescending :: (Ord a) => [a] -> Bool
isDescending xs = and (zipWith (>=) xs (drop 1 xs))
testCredentialRoundTrip :: TestTree
testCredentialRoundTrip = testCase "create credential + find-by-email" $ withDb \pool -> do
result <- runApp pool do
u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})
h <- hashPassword strongPw
_ <- createPasswordCredential u.userId aliceLogin (Just aliceEmail) h
byEmail <- findPasswordCredentialByEmail aliceEmail
byLogin <- findPasswordCredentialByLoginId aliceLogin
pure (u, h, byEmail, byLogin)
(u, h, byEmail, byLogin) <- expectApp result
fmap (.userId) byEmail @?= Just u.userId
fmap (.email) byEmail @?= Just (Just aliceEmail)
fmap (.passwordHash) byEmail @?= Just h
fmap (.userId) byLogin @?= Just u.userId
fmap (.loginId) byLogin @?= Just aliceLogin
duplicateLogin <- runApp pool (createPasswordCredential u.userId aliceLogin (Just bobEmail) h)
duplicateLogin @?= Left LoginIdAlreadyRegistered
duplicateEmail <- runApp pool (createPasswordCredential u.userId bobLogin (Just aliceEmail) h)
duplicateEmail @?= Left EmailAlreadyRegistered
testCredentialUniquePerUser :: TestTree
testCredentialUniquePerUser = testCase "one password credential per user is a database invariant" $ withDb \pool -> do
execSql
pool
"INSERT INTO shomei.shomei_users (user_id, login_id, email, status, created_at, updated_at) VALUES ('10000000-0000-0000-0000-000000000001', 'unique-owner', 'unique-owner@example.com', 'active', now(), now()); INSERT INTO shomei.shomei_password_credentials (credential_id, user_id, login_id, email, password_hash, created_at, updated_at) VALUES ('20000000-0000-0000-0000-000000000001', '10000000-0000-0000-0000-000000000001', 'unique-owner', 'unique-owner@example.com', 'hash-one', now(), now())"
duplicate <-
Pool.use
pool
( Session.script
"INSERT INTO shomei.shomei_password_credentials (credential_id, user_id, login_id, email, password_hash, created_at, updated_at) VALUES ('20000000-0000-0000-0000-000000000002', '10000000-0000-0000-0000-000000000001', 'unique-owner-two', 'unique-owner-two@example.com', 'hash-two', now(), now())"
)
case duplicate of
Left err ->
assertBool
("expected the user_id unique index, got: " <> show err)
("23505" `Text.isInfixOf` Text.pack (show err) || "shomei_password_credentials_user_id_key" `Text.isInfixOf` Text.pack (show err))
Right () -> assertFailure "a second password credential for one user was accepted"
scalarInt
pool
"SELECT count(*) FROM pg_indexes WHERE schemaname = 'shomei' AND indexname = 'shomei_password_credentials_user_id_key'"
>>= (@?= 1)
testPoolStatementTimeoutIsApplied :: TestTree
testPoolStatementTimeoutIsApplied = testCase "pool connections bound statements and idle transactions" $
withShomeiMigratedDatabase \connStr -> do
pool <- acquirePool 1 10 200 connStr
configured <- Pool.use pool (Session.statement () timeoutSettingsStatement)
either (assertFailure . ("could not read pool timeout settings: " <>) . show) pure configured
>>= (@?= ("200ms", "200ms"))
statementResult <- Pool.use pool (Session.script "SELECT pg_sleep(1)")
assertPoolFailureMentions ["57014", "statement timeout"] statementResult
beginResult <- Pool.use pool (Session.script "BEGIN")
either (assertFailure . ("could not begin idle-timeout probe: " <>) . show) pure beginResult
threadDelay 400000
idleResult <- Pool.use pool (Session.script "SELECT 1")
case idleResult of
Left _ -> pure ()
Right () -> assertFailure "the connection survived past idle_in_transaction_session_timeout"
Pool.release pool
where
timeoutSettingsStatement =
preparable
"SELECT current_setting('statement_timeout'), current_setting('idle_in_transaction_session_timeout')"
E.noParams
(D.singleRow ((,) <$> D.column (D.nonNullable D.text) <*> D.column (D.nonNullable D.text)))
assertPoolFailureMentions needles = \case
Left err ->
assertBool
("expected one of " <> show needles <> " in pool failure: " <> show err)
(any (\needle -> Text.toLower needle `Text.isInfixOf` Text.toLower (Text.pack (show err))) needles)
Right () -> assertFailure ("expected PostgreSQL timeout failure mentioning one of " <> show needles)
testSessionRevoke :: TestTree
testSessionRevoke = testCase "create session + revoke" $ withDb \pool -> do
result <- runApp pool do
u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})
t <- now
s <- createSession (NewSession {userId = u.userId, createdAt = t, expiresAt = addUTCTime 3600 t, actor = Nothing, oauthClientId = Nothing, kind = InteractiveSession, grantedScopes = Set.empty, authenticatedAt = t})
revokeSession s.sessionId t
findSessionById s.sessionId
found <- expectApp result
fmap (.status) found @?= Just SessionRevoked
testSessionActorRoundTrip :: TestTree
testSessionActorRoundTrip = testCase "create delegated session persists actor" $ withDb \pool -> do
result <- runApp pool do
subject <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})
operator <- createUser (NewUser {loginId = bobLogin, email = Just bobEmail, displayName = Nothing})
t <- now
delegated <-
createSession
( NewSession
{ userId = subject.userId,
createdAt = t,
expiresAt = addUTCTime 3600 t,
actor = Just operator.userId,
oauthClientId = Nothing,
kind = DelegatedSession,
grantedScopes = Set.empty,
authenticatedAt = t
}
)
normal <- createSession (NewSession {userId = subject.userId, createdAt = t, expiresAt = addUTCTime 3600 t, actor = Nothing, oauthClientId = Nothing, kind = InteractiveSession, grantedScopes = Set.empty, authenticatedAt = t})
foundDelegated <- findSessionById delegated.sessionId
foundNormal <- findSessionById normal.sessionId
pure (operator.userId, foundDelegated, foundNormal)
(op, foundDelegated, foundNormal) <- expectApp result
fmap (.actor) foundDelegated @?= Just (Just op)
fmap (.actor) foundNormal @?= Just Nothing
testSessionKindRoundTrip :: TestTree
testSessionKindRoundTrip = testCase "create session persists its kind (machine, delegated, interactive)" $ withDb \pool -> do
result <- runApp pool do
subject <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})
t <- now
interactive <- createSession (NewSession {userId = subject.userId, createdAt = t, expiresAt = addUTCTime 3600 t, actor = Nothing, oauthClientId = Nothing, kind = InteractiveSession, grantedScopes = Set.empty, authenticatedAt = t})
machine <- createSession (NewSession {userId = subject.userId, createdAt = t, expiresAt = addUTCTime 3600 t, actor = Nothing, oauthClientId = Nothing, kind = MachineSession, grantedScopes = Set.empty, authenticatedAt = t})
delegated <- createSession (NewSession {userId = subject.userId, createdAt = t, expiresAt = addUTCTime 3600 t, actor = Just subject.userId, oauthClientId = Nothing, kind = DelegatedSession, grantedScopes = Set.empty, authenticatedAt = t})
foundInteractive <- findSessionById interactive.sessionId
foundMachine <- findSessionById machine.sessionId
foundDelegated <- findSessionById delegated.sessionId
pure (foundInteractive, foundMachine, foundDelegated)
(foundInteractive, foundMachine, foundDelegated) <- expectApp result
fmap (.kind) foundInteractive @?= Just InteractiveSession
fmap (.kind) foundMachine @?= Just MachineSession
fmap (.kind) foundDelegated @?= Just DelegatedSession
testSessionGrantedScopesRoundTrip :: TestTree
testSessionGrantedScopesRoundTrip = testCase "session scopes and auth time round-trip; legacy values fall back" $ withDb \pool -> do
let granted = Set.fromList [Scope "openid", Scope "kawa:read"]
created <- runApp pool do
user <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})
t <- now
let authenticated = addUTCTime (-30) t
session <-
createSession
NewSession
{ userId = user.userId,
createdAt = t,
expiresAt = addUTCTime 3600 t,
actor = Nothing,
oauthClientId = Just "oauthclient_roundtrip",
kind = InteractiveSession,
grantedScopes = granted,
authenticatedAt = authenticated
}
found <- findSessionById session.sessionId
pure (session.sessionId, authenticated, found)
(sessionId, authenticated, found) <- expectApp created
fmap (.grantedScopes) found @?= Just granted
fmap (.authenticatedAt) found @?= Just authenticated
execSql pool "UPDATE shomei.shomei_sessions SET authenticated_at = NULL"
legacy <- expectApp =<< runApp pool (findSessionById sessionId)
fmap (.authenticatedAt) legacy @?= fmap (.createdAt) legacy
execSql
pool
"""
INSERT INTO shomei.shomei_sessions
(session_id, user_id, status, created_at, expires_at, kind)
SELECT
'00000000-0000-4000-8000-000000000052'::uuid,
user_id,
'active',
now(),
now() + interval '1 hour',
'interactive'
FROM shomei.shomei_users
LIMIT 1
"""
defaulted <- scalarInt pool "SELECT count(*) FROM shomei.shomei_sessions WHERE granted_scopes = '{}'::text[]"
defaulted @?= 1
testSessionKindNullReadsInteractive :: TestTree
testSessionKindNullReadsInteractive = testCase "a session row whose kind is NULL reads as interactive" $ withDb \pool -> do
created <- runApp pool do
user <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})
t <- now
createSession (NewSession {userId = user.userId, createdAt = t, expiresAt = addUTCTime 3600 t, actor = Nothing, oauthClientId = Nothing, kind = InteractiveSession, grantedScopes = Set.empty, authenticatedAt = t})
session <- expectApp created
execSql pool "UPDATE shomei.shomei_sessions SET kind = NULL"
found <- expectApp =<< runApp pool (findSessionById session.sessionId)
fmap (.kind) found @?= Just InteractiveSession
-- | Pins the compare-and-swap semantics of the @UPDATE … AND status = 'active' RETURNING@
-- statement: the first mark wins and stamps @used_at@, a second mark of the same token loses
-- and leaves the row (including the winner's @used_at@) untouched. This is the statement-level
-- guarantee that makes two concurrent refreshes of one token impossible to both succeed.
testRefreshTokenMarkUsed :: TestTree
testRefreshTokenMarkUsed = testCase "refresh token: find-by-hash + mark-used is a compare-and-swap" $ withDb \pool -> do
result <- runApp pool do
u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})
t <- now
s <- createSession (NewSession {userId = u.userId, createdAt = t, expiresAt = addUTCTime 3600 t, actor = Nothing, oauthClientId = Nothing, kind = InteractiveSession, grantedScopes = Set.empty, authenticatedAt = t})
h <- hashRefreshToken (RefreshToken "token-1")
persisted <-
createRefreshToken
NewRefreshToken
{ sessionId = s.sessionId,
tokenHash = h,
parentTokenId = Nothing,
createdAt = t,
expiresAt = addUTCTime 86400 t
}
beforeUse <- findRefreshTokenByHash h
firstMark <- markRefreshTokenUsed persisted.refreshTokenId t
afterUse <- findRefreshTokenByHash h
secondMark <- markRefreshTokenUsed persisted.refreshTokenId (addUTCTime 60 t)
afterSecond <- findRefreshTokenByHash h
pure (beforeUse, afterUse, firstMark, secondMark, afterSecond)
(beforeUse, afterUse, firstMark, secondMark, afterSecond) <- expectApp result
fmap (.status) beforeUse @?= Just RefreshTokenActive
fmap (.status) afterUse @?= Just RefreshTokenUsed
firstMark @?= True
secondMark @?= False
-- The loser overwrote nothing: the row still carries the winner's used_at.
fmap (.usedAt) afterSecond @?= fmap (.usedAt) afterUse
fmap (.status) afterSecond @?= Just RefreshTokenUsed
testVerificationTokenRoundTrip :: TestTree
testVerificationTokenRoundTrip = testCase "verification token: consume is a compare-and-swap" $ withDb \pool -> do
result <- runApp pool do
u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})
t <- now
let h = OneTimeTokenHash "hash:verify-1"
persisted <-
createVerificationToken
NewVerificationToken
{ userId = u.userId,
tokenHash = h,
createdAt = t,
expiresAt = addUTCTime 3600 t
}
before <- findVerificationTokenByHash h
firstConsume <- markVerificationTokenConsumed persisted.verificationTokenId t
after <- findVerificationTokenByHash h
secondConsume <- markVerificationTokenConsumed persisted.verificationTokenId (addUTCTime 60 t)
afterSecond <- findVerificationTokenByHash h
pure (before, after, firstConsume, secondConsume, afterSecond)
(before, after, firstConsume, secondConsume, afterSecond) <- expectApp result
fmap (.status) before @?= Just OneTimeTokenActive
fmap (.status) after @?= Just OneTimeTokenConsumed
firstConsume @?= True
secondConsume @?= False
fmap (.consumedAt) afterSecond @?= fmap (.consumedAt) after
testPasswordResetTokenRoundTrip :: TestTree
testPasswordResetTokenRoundTrip = testCase "password reset token: consume is a compare-and-swap" $ withDb \pool -> do
result <- runApp pool do
u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})
t <- now
let h = OneTimeTokenHash "hash:reset-1"
persisted <-
createPasswordResetToken
NewPasswordResetToken
{ userId = u.userId,
tokenHash = h,
createdAt = t,
expiresAt = addUTCTime 3600 t
}
before <- findPasswordResetTokenByHash h
firstConsume <- markPasswordResetTokenConsumed persisted.passwordResetTokenId t
after <- findPasswordResetTokenByHash h
secondConsume <- markPasswordResetTokenConsumed persisted.passwordResetTokenId (addUTCTime 60 t)
afterSecond <- findPasswordResetTokenByHash h
pure (before, after, firstConsume, secondConsume, afterSecond)
(before, after, firstConsume, secondConsume, afterSecond) <- expectApp result
fmap (.status) before @?= Just OneTimeTokenActive
fmap (.status) after @?= Just OneTimeTokenConsumed
firstConsume @?= True
secondConsume @?= False
fmap (.consumedAt) afterSecond @?= fmap (.consumedAt) after
testMarkUserEmailVerified :: TestTree
testMarkUserEmailVerified = testCase "mark user email verified sets the timestamp" $ withDb \pool -> do
result <- runApp pool do
u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})
t <- now
markUserEmailVerified u.userId t
findUserById u.userId
found <- expectApp result
assertBool "email_verified_at is populated" (maybe False (isJust . (.emailVerifiedAt)) found)
testSigningKeys :: TestTree
testSigningKeys = testCase "insert + list signing keys" $ withDb \pool -> do
result <- runApp pool do
t <- now
let key =
StoredSigningKey
{ keyId = "kid-1",
algorithm = "ES256",
publicKeyJwk = "{\"kty\":\"EC\"}",
privateKeyJwk = "{\"kty\":\"EC\",\"d\":\"x\"}",
status = KeyActive,
createdAt = t,
activatedAt = Just t,
retiredAt = Nothing,
revokedAt = Nothing
}
insertSigningKey key
active <- listActiveSigningKeys
byKid <- findSigningKeyByKid "kid-1"
pure (active, byKid)
(active, byKid) <- expectApp result
fmap (.keyId) active @?= ["kid-1"]
fmap (.keyId) byKid @?= Just "kid-1"
-- | @listPublishableSigningKeys@ returns exactly the active + retired keys (the JWKS
-- contents), while @listActiveSigningKeys@ still returns only the signing key.
testPublishableSigningKeys :: TestTree
testPublishableSigningKeys = testCase "publishable signing keys are active + retired" $ withDb \pool -> do
result <- runApp pool do
t <- now
let key kid st =
StoredSigningKey
{ keyId = kid,
algorithm = "ES256",
publicKeyJwk = "{\"kty\":\"EC\"}",
privateKeyJwk = "{\"kty\":\"EC\",\"d\":\"x\"}",
status = st,
createdAt = t,
activatedAt = Just t,
retiredAt = Nothing,
revokedAt = Nothing
}
-- Insert each row Pending, then drive it to its target status through the port, so
-- the test exercises updateSigningKeyStatus rather than trusting the insert.
forM_ [("k-active", KeyActive), ("k-retired", KeyRetired), ("k-revoked", KeyRevoked)] \(kid, st) -> do
insertSigningKey (key kid KeyPending)
updateSigningKeyStatus kid st t
insertSigningKey (key "k-pending" KeyPending)
publishable <- listPublishableSigningKeys
active <- listActiveSigningKeys
pure (publishable, active)
(publishable, active) <- expectApp result
sort (fmap (.keyId) publishable) @?= ["k-active", "k-retired"]
fmap (.keyId) active @?= ["k-active"]
testSigningKeyTransitionTimestamps :: TestTree
testSigningKeyTransitionTimestamps = testCase "signing-key transitions stamp activated, retired, and revoked times" $ withDb \pool -> do
let activated = t0
retired = addUTCTime 60 t0
revoked = addUTCTime 120 t0
key = signingKeyFixture "k-stamped" KeyPending t0
result <- runAppAtTime t0 pool do
insertSigningKey key
updateSigningKeyStatus key.keyId KeyActive activated
updateSigningKeyStatus key.keyId KeyRetired retired
updateSigningKeyStatus key.keyId KeyRevoked revoked
findSigningKeyByKid key.keyId
stored <- expectApp result >>= maybe (assertFailure "stamped signing key disappeared") pure
stored.activatedAt @?= Just activated
stored.retiredAt @?= Just retired
stored.revokedAt @?= Just revoked
testSigningKeyOneActiveInvariant :: TestTree
testSigningKeyOneActiveInvariant = testCase "one-active index rejects a second insert and atomic replacement retires the old key" $ withDb \pool -> do
let replacedAt = addUTCTime 60 t0
old = (signingKeyFixture "k-old" KeyActive t0) {activatedAt = Just t0}
new = signingKeyFixture "k-new" KeyActive replacedAt
expectApp =<< runAppAtTime t0 pool (insertSigningKey old)
duplicate <- runAppAtTime t0 pool (insertSigningKey new)
duplicate @?= Left (DependencyUnavailable PostgreSQL)
replacement <- runAppAtTime replacedAt pool do
replaceActiveSigningKey new replacedAt
active <- listActiveSigningKeys
oldAfter <- findSigningKeyByKid old.keyId
newAfter <- findSigningKeyByKid new.keyId
pure (active, oldAfter, newAfter)
(active, oldAfter, newAfter) <- expectApp replacement
fmap (.keyId) active @?= [new.keyId]
fmap (.status) oldAfter @?= Just KeyRetired
fmap (.retiredAt) oldAfter @?= Just (Just replacedAt)
fmap (.status) newAfter @?= Just KeyActive
fmap (.activatedAt) newAfter @?= Just (Just replacedAt)
signingKeyFixture :: Text -> SigningKeyStatus -> UTCTime -> StoredSigningKey
signingKeyFixture kid keyStatus created =
StoredSigningKey
{ keyId = kid,
algorithm = "ES256",
publicKeyJwk = "{\"kty\":\"EC\"}",
privateKeyJwk = "{\"kty\":\"EC\",\"d\":\"x\"}",
status = keyStatus,
createdAt = created,
activatedAt = Nothing,
retiredAt = Nothing,
revokedAt = Nothing
}
testPublishEvent :: TestTree
testPublishEvent = testCase "publish auth event lands a row" $ withDb \pool -> do
result <- runApp pool do
t <- now
publishAuthEvent (Event.LoginFailed (Event.LoginFailedData (Just (AccountKey "k-alice")) Nothing t))
_ <- expectApp result
n <- scalarInt pool "SELECT count(*) FROM shomei.shomei_auth_events"
n @?= 1
testAuditEventReader :: TestTree
testAuditEventReader = testCase "audit reader: filter + order + keyset pagination + reconstruct" $ withDb \pool -> do
let tt :: Int -> UTCTime
tt n = addUTCTime (fromIntegral n) t0
result <- runApp pool do
alice <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})
bob <- createUser (NewUser {loginId = bobLogin, email = Just bobEmail, displayName = Nothing})
s1 <- genSessionId
s2 <- genSessionId
-- Five events at strictly increasing times (newest = tt 4).
publishAuthEvent (Event.LoginFailed (Event.LoginFailedData (Just (AccountKey "k-alice")) (Just alice.userId) (tt 0)))
publishAuthEvent (Event.LoginSucceeded (Event.LoginSucceededData alice.userId s1 (tt 1)))
publishAuthEvent (Event.LoginFailed (Event.LoginFailedData (Just (AccountKey "k-bob")) (Just bob.userId) (tt 2)))
publishAuthEvent (Event.PasswordChanged (Event.PasswordChangedData alice.userId (tt 3)))
publishAuthEvent (Event.LoginSucceeded (Event.LoginSucceededData bob.userId s2 (tt 4)))
allEvents <- queryAuthEvents emptyAuditQuery
aliceEvents <- queryAuthEvents emptyAuditQuery {queryUserId = Just (userIdToUUID alice.userId)}
failedEvents <- queryAuthEvents emptyAuditQuery {queryEventTypes = ["login_failed"]}
windowEvents <- queryAuthEvents emptyAuditQuery {querySince = Just (tt 1), queryUntil = Just (tt 3)}
total <- countAuthEvents emptyAuditQuery
failedTotal <- countAuthEvents emptyAuditQuery {queryEventTypes = ["login_failed"]}
page1 <- queryAuthEvents emptyAuditQuery {queryLimit = 2}
page2 <- case page1 of
[] -> pure []
rows ->
let lastRow = last rows
cur = AuditCursor (storedCreatedAt lastRow) (storedEventId lastRow)
in queryAuthEvents emptyAuditQuery {queryLimit = 2, queryBefore = Just cur}
pure (alice.userId, allEvents, aliceEvents, failedEvents, windowEvents, total, failedTotal, page1, page2)
(aliceUserId, allEvents, aliceEvents, failedEvents, windowEvents, total, failedTotal, page1, page2) <- expectApp result
-- newest-first ordering across all five
map storedEventType allEvents
@?= ["login_succeeded", "password_changed", "login_failed", "login_succeeded", "login_failed"]
-- user filter includes a failed proof once its credential resolves to Alice.
map storedEventType aliceEvents @?= ["password_changed", "login_succeeded", "login_failed"]
-- type filter: the two failed logins (tt 2 = bob, tt 0 = alice)
map storedEventType failedEvents @?= ["login_failed", "login_failed"]
-- since (inclusive) tt1 .. until (exclusive) tt3 → tt2 then tt1
map storedEventType windowEvents @?= ["login_failed", "login_succeeded"]
total @?= 5
failedTotal @?= 2
-- keyset pagination walks the set with no gaps or repeats
length page1 @?= 2
length page2 @?= 2
let ids1 = map storedEventId page1
ids2 = map storedEventId page2
assertBool "pages are disjoint" (all (`notElem` ids2) ids1)
map storedEventType (page1 <> page2) @?= ["login_succeeded", "password_changed", "login_failed", "login_succeeded"]
-- the oldest failed-login row reconstructs to the typed event we published
case reverse failedEvents of
(oldest : _) ->
reconstructAuthEvent (storedEventType oldest) (storedPayload oldest)
@?= Right (Event.LoginFailed (Event.LoginFailedData (Just (AccountKey "k-alice")) (Just aliceUserId) (tt 0)))
[] -> assertFailure "expected at least one failed-login row"
testWorkflowSignup :: TestTree
testWorkflowSignup = testCase "workflow: signup persists user + session + token" $ withDb \pool -> do
inner <- runApp pool (signup cfg (SignupCommand aliceLogin (Just aliceEmail) strongPw (Just "Alice")))
_ <- expectApp inner >>= expectRight
users <- scalarInt pool "SELECT count(*) FROM shomei.shomei_users"
sessions <- scalarInt pool "SELECT count(*) FROM shomei.shomei_sessions"
toks <- scalarInt pool "SELECT count(*) FROM shomei.shomei_refresh_tokens"
users @?= 1
sessions @?= 1
toks @?= 1
-- Round-trip budget ----------------------------------------------------------
-- | Count every 'Database' dispatch a workflow makes.
--
-- 'interpose' replaces the 'Database' handler for the wrapped action only; re-'send'ing the
-- operation from inside the handler dispatches to the /upstream/ handler ('runDatabasePool'),
-- not back into this one, so the workflow still talks to PostgreSQL and there is no recursion.
-- Both constructors are counted: a @RunSession@ is one pool checkout for one
-- statement, and a @RunTransaction@ is one pool checkout for the whole transaction. That is
-- exactly the quantity these tests pin — network round-trips, not statements.
countingDatabase :: (Database :> es, IOE :> es) => IORef Int -> Eff es a -> Eff es a
countingDatabase counter = interpose \_env op -> do
liftIO (atomicModifyIORef' counter \n -> (n + 1, ()))
case op of
RunSession sess -> send (RunSession sess)
RunTransaction t -> send (RunTransaction t)
-- | A successful password login costs exactly ten database round-trips:
--
-- 1. @countRecentFailuresByIp@ (per-IP throttle)
-- 2. @recordLoginFailure@ (ONE transaction: advisory lock + provisional insert + count)
-- 3. @findPasswordCredentialByLoginId@
-- 4. @findUserById@
-- 5. @countPasskeysByUser@ (MFA gate: passkey factor)
-- 6. @findTotpByUser@ (MFA gate: confirmed-TOTP factor — EP-7)
-- 7. @convertLoginAttemptToSuccess@
-- 8. @persistNewSession@ (ONE transaction: session + refresh token + 2 audit events)
-- 9. @listRolesForUser@ (the roles claim, via @buildEnrichedClaims@)
-- 10. @permissionsForRoles@ (the permissions claim, via @buildEnrichedClaims@ — EP-9)
--
-- There is deliberately no @clearAccountLockout@: the record transaction found no standing row
-- and did not reach the account threshold.
-- Password verification and access-token signing are CPU-only and cost no round-trip.
--
-- Step 7 was added by EP-7's generalized MFA gate: login now challenges for /any/ enrolled
-- second factor, so it reads the TOTP credential alongside the passkey count. It is one
-- single-row indexed lookup on @user_id@. (The @recovery-codes@ count is read only inside the
-- challenge branch, which this no-factor login does not enter.)
--
-- Step 9 is the price of a populated @roles@ claim: every user-session mint reads the grant
-- table once. It is a single-row indexed lookup on the primary key prefix, and it buys the
-- alternative — re-reading roles on every /verification/ — never happening.
--
-- Step 10 was added by EP-9's @permissions@ claim: @buildEnrichedClaims@ resolves the effective
-- role set to its permission union with a single @role = ANY(...)@ query. It runs once per mint,
-- on the same principle as step 9 (resolve at mint, never at verification).
--
-- If this number drifts, something added a round-trip to the login path. Find it before
-- changing the constant.
testLoginRoundTripBudget :: TestTree
testLoginRoundTripBudget = testCase "a successful login costs exactly 10 database round-trips" $ withDb \pool -> do
signupRes <- runApp pool (signup cfg (SignupCommand aliceLogin (Just aliceEmail) strongPw Nothing))
_ <- expectApp signupRes >>= expectRight
counter <- newIORef 0
let ctx = ClientContext (ClientIp "10.0.0.1") (AccountKey (loginIdText aliceLogin))
loginRes <- runApp pool (countingDatabase counter (login cfg ctx (LoginCommand aliceLogin strongPw)))
_ <- expectApp loginRes >>= expectRight
readIORef counter >>= (@?= 10)
-- | A wrong password costs four checkouts: per-IP count, atomic record-and-count transaction,
-- credential lookup, and the @LoginFailed@ audit insert. The user row is only needed after the
-- password succeeds, and hashing itself is CPU-only.
testFailedLoginRoundTripBudget :: TestTree
testFailedLoginRoundTripBudget = testCase "a wrong password costs exactly 4 database round-trips" $ withDb \pool -> do
signupRes <- runApp pool (signup cfg (SignupCommand aliceLogin (Just aliceEmail) strongPw Nothing))
_ <- expectApp signupRes >>= expectRight
counter <- newIORef 0
let ctx = ClientContext (ClientIp "10.0.0.1") (AccountKey (loginIdText aliceLogin))
loginRes <- runApp pool (countingDatabase counter (login cfg ctx (LoginCommand aliceLogin (PlainPassword "wrong"))))
expectApp loginRes >>= (@?= Left InvalidCredentials)
readIORef counter >>= (@?= 4)
-- | A token refresh costs exactly five database round-trips:
--
-- 1. @findRefreshTokenByHash@
-- 2. @findSessionById@
-- 3. @rotateRefreshToken@ (ONE transaction: mark-used CAS + child insert + rotation event)
-- 4. @listRolesForUser@ (the roles claim, via @buildEnrichedClaims@)
-- 5. @permissionsForRoles@ (the permissions claim, via @buildEnrichedClaims@ — EP-9)
--
-- The user row is not read because @emailVerificationRequired@ is off in 'cfg'; turning it on
-- adds a further round-trip by design.
--
-- Step 4 is what makes a role change take effect on refresh rather than only at the next login;
-- step 5 (EP-9) does the same for a permission re-wiring or a grant expiry.
testRefreshRoundTripBudget :: TestTree
testRefreshRoundTripBudget = testCase "a token refresh costs exactly 5 database round-trips" $ withDb \pool -> do
signupRes <- runApp pool (signup cfg (SignupCommand aliceLogin (Just aliceEmail) strongPw Nothing))
(_, pair) <- expectApp signupRes >>= expectRight
counter <- newIORef 0
refreshRes <- runApp pool (countingDatabase counter (refresh cfg (RefreshCommand pair.refreshToken)))
_ <- expectApp refreshRes >>= expectRight
readIORef counter >>= (@?= 5)
-- | Logout costs two database round-trips: one session lookup and one transaction that CASes
-- the session, revokes its refresh tokens, and inserts the audit event.
testLogoutRoundTripBudget :: TestTree
testLogoutRoundTripBudget = testCase "logout costs exactly 2 database round-trips" $ withDb \pool -> do
signupRes <- runApp pool (signup cfg (SignupCommand aliceLogin (Just aliceEmail) strongPw Nothing))
(user, _) <- expectApp signupRes >>= expectRight
sessionsRes <- runApp pool (listSessionsForUser user.userId)
sessions <- expectApp sessionsRes
sid <- case sessions of
session : _ -> pure session.sessionId
[] -> assertFailure "expected signup to create a session"
counter <- newIORef 0
logoutRes <- runApp pool (countingDatabase counter (logout cfg (LogoutCommand sid)))
_ <- expectApp logoutRes >>= expectRight
readIORef counter >>= (@?= 2)
-- | Password-reset confirmation costs three database round-trips: token lookup, user lookup,
-- and one transaction for the consume/hash/revocation/event tail.
testPasswordResetRoundTripBudget :: TestTree
testPasswordResetRoundTripBudget = testCase "password reset confirmation costs exactly 3 database round-trips" $ withDb \pool -> do
notifications <- newIORef []
signupRes <- runAppWithNotifications notifications pool (signup cfg (SignupCommand aliceLogin (Just aliceEmail) strongPw Nothing))
_ <- expectApp signupRes >>= expectRight
requestRes <- runAppWithNotifications notifications pool (requestPasswordReset cfg (RequestPasswordReset aliceEmail))
_ <- expectApp requestRes >>= expectRight
raw <- latestResetToken =<< readIORef notifications
counter <- newIORef 0
confirmRes <-
runAppWithNotifications
notifications
pool
( countingDatabase
counter
(confirmPasswordReset cfg (ConfirmPasswordReset raw (PlainPassword "correct horse battery staple two")))
)
_ <- expectApp confirmRes >>= expectRight
readIORef counter >>= (@?= 3)
testWorkflowRefreshRotation :: TestTree
testWorkflowRefreshRotation = testCase "workflow: refresh rotation marks used + inserts child" $ withDb \pool -> do
signupRes <- runApp pool (signup cfg (SignupCommand aliceLogin (Just aliceEmail) strongPw Nothing))
(_, pair) <- expectApp signupRes >>= expectRight
refreshRes <- runApp pool (refresh cfg (RefreshCommand pair.refreshToken))
_ <- expectApp refreshRes >>= expectRight
toks <- scalarInt pool "SELECT count(*) FROM shomei.shomei_refresh_tokens"
used <- scalarInt pool "SELECT count(*) FROM shomei.shomei_refresh_tokens WHERE status = 'used'"
children <- scalarInt pool "SELECT count(*) FROM shomei.shomei_refresh_tokens WHERE parent_token_id IS NOT NULL"
toks @?= 2
used @?= 1
children @?= 1
testWorkflowReuseRevokesFamily :: TestTree
testWorkflowReuseRevokesFamily = testCase "workflow: reuse revokes the family + session" $ withDb \pool -> do
signupRes <- runApp pool (signup cfg (SignupCommand aliceLogin (Just aliceEmail) strongPw Nothing))
(_, pair) <- expectApp signupRes >>= expectRight
rotateRes <- runApp pool (refresh cfg (RefreshCommand pair.refreshToken))
_ <- expectApp rotateRes >>= expectRight
reuseRes <- runApp pool (refresh cfg (RefreshCommand pair.refreshToken))
reuse <- expectApp reuseRes
reuse @?= Left RefreshTokenReuseDetected
revokedToks <- scalarInt pool "SELECT count(*) FROM shomei.shomei_refresh_tokens WHERE status = 'revoked'"
totalToks <- scalarInt pool "SELECT count(*) FROM shomei.shomei_refresh_tokens"
revokedSessions <- scalarInt pool "SELECT count(*) FROM shomei.shomei_sessions WHERE status = 'revoked'"
assertBool "every refresh token in the family is revoked" (revokedToks == totalToks)
revokedSessions @?= 1
testWorkflowAccountVerification :: TestTree
testWorkflowAccountVerification = testCase "workflow: account verification consumes token + marks user" $ withDb \pool -> do
notifications <- newIORef []
signupRes <- runAppWithNotifications notifications pool (signup cfg (SignupCommand aliceLogin (Just aliceEmail) strongPw Nothing))
_ <- expectApp signupRes >>= expectRight
requestRes <- runAppWithNotifications notifications pool (requestEmailVerification cfg (RequestEmailVerification aliceEmail))
_ <- expectApp requestRes >>= expectRight
raw <- latestVerificationToken =<< readIORef notifications
confirmRes <- runAppWithNotifications notifications pool (confirmEmailVerification cfg (ConfirmEmailVerification raw))
_ <- expectApp confirmRes >>= expectRight
verified <- scalarInt pool "SELECT count(*) FROM shomei.shomei_users WHERE email_verified_at IS NOT NULL"
consumed <- scalarInt pool "SELECT count(*) FROM shomei.shomei_email_verification_tokens WHERE status = 'consumed'"
verified @?= 1
consumed @?= 1
testWorkflowPasswordReset :: TestTree
testWorkflowPasswordReset = testCase "workflow: password reset changes password and revokes sessions" $ withDb \pool -> do
notifications <- newIORef []
signupRes <- runAppWithNotifications notifications pool (signup cfg (SignupCommand aliceLogin (Just aliceEmail) strongPw Nothing))
(_, pair) <- expectApp signupRes >>= expectRight
firstRequest <- runAppWithNotifications notifications pool (requestPasswordReset cfg (RequestPasswordReset aliceEmail))
_ <- expectApp firstRequest >>= expectRight
first <- latestResetToken =<< readIORef notifications
secondRequest <- runAppWithNotifications notifications pool (requestPasswordReset cfg (RequestPasswordReset aliceEmail))
_ <- expectApp secondRequest >>= expectRight
second <- latestResetToken =<< readIORef notifications
confirmRes <- runAppWithNotifications notifications pool (confirmPasswordReset cfg (ConfirmPasswordReset first (PlainPassword "correct horse battery staple two")))
_ <- expectApp confirmRes >>= expectRight
siblingRes <- runAppWithNotifications notifications pool (confirmPasswordReset cfg (ConfirmPasswordReset second (PlainPassword "correct horse battery staple three")))
sibling <- expectApp siblingRes
sibling @?= Left PasswordResetTokenInvalid
loginRes <- runAppWithNotifications notifications pool (login cfg (ClientContext (ClientIp "test-ip") (AccountKey (loginIdText aliceLogin))) (LoginCommand aliceLogin (PlainPassword "correct horse battery staple two")))
_ <- expectApp loginRes >>= expectRight
oldRefreshRes <- runAppWithNotifications notifications pool (refresh cfg (RefreshCommand pair.refreshToken))
oldRefresh <- expectApp oldRefreshRes
oldRefresh @?= Left Err.SessionRevoked
consumed <- scalarInt pool "SELECT count(*) FROM shomei.shomei_password_reset_tokens WHERE status = 'consumed'"
revokedReset <- scalarInt pool "SELECT count(*) FROM shomei.shomei_password_reset_tokens WHERE status = 'revoked'"
revokedSessions <- scalarInt pool "SELECT count(*) FROM shomei.shomei_sessions WHERE status = 'revoked'"
revokedRefresh <- scalarInt pool "SELECT count(*) FROM shomei.shomei_refresh_tokens WHERE status = 'revoked'"
consumed @?= 1
revokedReset @?= 1
assertBool "existing sessions are revoked" (revokedSessions >= 1)
assertBool "existing refresh tokens are revoked" (revokedRefresh >= 1)
testRevokeSessionIsCompareAndSwap :: TestTree
testRevokeSessionIsCompareAndSwap =
testCase "session-scoped revoke unit of work publishes only for the CAS winner" $ withDb \pool -> do
signupRes <- runApp pool (signup cfg (SignupCommand aliceLogin (Just aliceEmail) strongPw Nothing))
(user, _) <- expectApp signupRes >>= expectRight
sessionsRes <- runApp pool (listSessionsForUser user.userId)
sessions <- expectApp sessionsRes
sid <- case sessions of
session : _ -> pure session.sessionId
[] -> assertFailure "expected signup to create a session"
result <- runApp pool do
ts <- now
let event = Event.SessionRevoked (Event.SessionRevokedData sid Nothing ts)
first <- revokeSessionWithTokens sid ts [event]
second <- revokeSessionWithTokens sid ts [event]
pure (first, second)
expectApp result >>= (@?= (True, False))
revokedSessions <- scalarInt pool "SELECT count(*) FROM shomei.shomei_sessions WHERE status = 'revoked'"
revokedTokens <- scalarInt pool "SELECT count(*) FROM shomei.shomei_refresh_tokens WHERE status = 'revoked'"
revokeEvents <- scalarInt pool "SELECT count(*) FROM shomei.shomei_auth_events WHERE event_type = 'session_revoked'"
revokedSessions @?= 1
revokedTokens @?= 1
revokeEvents @?= 1
testLoginAttemptStore :: TestTree
testLoginAttemptStore = testCase "login attempt store: record + windowed count + lockout upsert/clear" $ withDb \pool -> do
let key = AccountKey "k-abc"
ip = ClientIp "1.2.3.4"
result <- runApp pool do
t <- now
let cutoff = addUTCTime (-900) t
failure fromIp =
NewLoginAttempt
{ accountKey = key,
clientIp = fromIp,
outcome = LoginFailure,
occurredAt = t,
factor = FactorTotp
}
_ <- recordLoginFailure (failure ip) cutoff Nothing
_ <- recordLoginFailure (failure ip) cutoff Nothing
_ <- recordLoginFailure (failure (ClientIp "9.9.9.9")) cutoff Nothing
accFails <- countRecentFailuresByAccount key cutoff
ipFails <- countRecentFailuresByIp ip cutoff
future <- countRecentFailuresByAccount key (addUTCTime 3600 t)
setAccountLockout (AccountLockout key 5 (Just (addUTCTime 900 t)) t)
lo1 <- getAccountLockout key
clearAccountLockout key
lo2 <- getAccountLockout key
pure (accFails, ipFails, future, lo1, lo2)
(accFails, ipFails, future, lo1, lo2) <- expectApp result
accFails @?= 3 -- all three failures share the account key
ipFails @?= 2 -- only two came from 1.2.3.4
future @?= 0 -- a cutoff in the future excludes everything
fmap (.failedCount) lo1 @?= Just 5
lo2 @?= Nothing
testLockoutRecordAndCountIsAtomicUnderRace :: TestTree
testLockoutRecordAndCountIsAtomicUnderRace =
testCase "lockout: eight racing failures count 1..8 and lock once" $ withDb \pool -> do
let key = AccountKey "race-key"
ip = ClientIp "10.0.0.9"
cutoff = addUTCTime (-900) t0
policy = LockPolicy 5 (addUTCTime 900 t0)
failure =
NewLoginAttempt
{ accountKey = key,
clientIp = ip,
outcome = LoginFailure,
occurredAt = t0,
factor = FactorPassword
}
gate <- newEmptyMVar
dones <- replicateM 8 do
done <- newEmptyMVar
_ <- forkIO do
readMVar gate
putMVar done =<< runApp pool (recordLoginFailure failure cutoff (Just policy))
pure done
putMVar gate ()
outcomes <- traverse (\done -> expectApp =<< takeMVar done) dones
sort (map (.failures) outcomes) @?= [1 .. 8]
length (filter (.lockedNow) outcomes) @?= 1
testWorkflowLockout :: TestTree
testWorkflowLockout = testCase "workflow over PostgreSQL: lock-after-N then unlock-after-cooldown" $ withDb \pool -> do
seeded <- runAppAtTime t0 pool (signup lockCfg (SignupCommand aliceLogin (Just aliceEmail) strongPw Nothing))
_ <- expectApp seeded >>= expectRight
let ctx = ClientContext (ClientIp "10.0.0.9") (AccountKey (loginIdText aliceLogin))
badLogin = login lockCfg ctx (LoginCommand aliceLogin (PlainPassword "wrong"))
_ <- runAppAtTime t0 pool badLogin >>= expectApp
_ <- runAppAtTime t0 pool badLogin >>= expectApp
r3 <- runAppAtTime t0 pool badLogin >>= expectApp
r3 @?= Left InvalidCredentials
locked <- scalarInt pool "SELECT count(*) FROM shomei.shomei_account_lockouts WHERE locked_until IS NOT NULL"
locked @?= 1
-- The correct password while still locked returns the SAME generic error (no leak).
denied <- runAppAtTime t0 pool (login lockCfg ctx (LoginCommand aliceLogin strongPw)) >>= expectApp
denied @?= Left InvalidCredentials
-- After the cooldown (15 min default) the correct password succeeds and clears the lockout.
ok <- runAppAtTime (addUTCTime (16 * 60) t0) pool (login lockCfg ctx (LoginCommand aliceLogin strongPw)) >>= expectApp
_ <- expectRight ok
remaining <- scalarInt pool "SELECT count(*) FROM shomei.shomei_account_lockouts"
remaining @?= 0
-- Passkey field accessors: OverloadedRecordDot is unreliable for these
-- DuplicateRecordFields records (MasterPlan 3 discovery), so read via record-pattern.
pkPasskeyId :: PasskeyCredential -> PasskeyId
pkPasskeyId PasskeyCredential {passkeyId} = passkeyId
pkSignCounter :: PasskeyCredential -> SignatureCounter
pkSignCounter PasskeyCredential {signCounter} = signCounter
pkLastUsedAt :: PasskeyCredential -> Maybe UTCTime
pkLastUsedAt PasskeyCredential {lastUsedAt} = lastUsedAt
pkTransports :: PasskeyCredential -> [Text]
pkTransports PasskeyCredential {transports} = transports
pkLabel :: PasskeyCredential -> Maybe Text
pkLabel PasskeyCredential {label} = label
-- | A 'NewPasskeyCredential' with canned bytes for the given user and time.
newPasskey :: User -> UTCTime -> NewPasskeyCredential
newPasskey u t =
NewPasskeyCredential
{ userId = u.userId,
credentialId = WebAuthnCredentialId "cred-1",
userHandle = UserHandle "uh-1",
publicKey = PublicKeyBytes "pk-1",
signCounter = SignatureCounter 0,
transports = ["usb", "nfc"],
label = Just "key",
createdAt = t
}
-- | Field accessors for the EP-4 service-account record: 'DuplicateRecordFields' makes
-- @value.field@ unreliable here, as it does for the passkey record above.
saStatus :: ServiceAccount -> ServiceAccountStatus
saStatus ServiceAccount {status} = status
saSecretHash :: ServiceAccount -> Text
saSecretHash ServiceAccount {secretHash} = secretHash
saRotatedAt :: ServiceAccount -> Maybe UTCTime
saRotatedAt ServiceAccount {rotatedAt} = rotatedAt
saRevokedAt :: ServiceAccount -> Maybe UTCTime
saRevokedAt ServiceAccount {revokedAt} = revokedAt
saId :: ServiceAccount -> ServiceAccountDbId
saId ServiceAccount {serviceAccountId} = serviceAccountId
saAllowedScopes :: ServiceAccount -> Set.Set Scope
saAllowedScopes ServiceAccount {allowedScopes} = allowedScopes
-- | EP-4: the whole service-account lifecycle against real PostgreSQL — create, find by
-- client id, rotate the secret, revoke — mirroring the in-memory
-- 'Shomei.ServiceAccountStoreSpec'. Proves the jsonb @allowed_scopes@ round-trip, the
-- @status@ text encoding, and that a revoked row survives so the grant workflow can still
-- resolve (and refuse) it.
testServiceAccountRoundTrip :: TestTree
testServiceAccountRoundTrip =
testCase "service accounts: create + find by client id + rotate + revoke" $ withDb \pool -> do
result <- runApp pool do
u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})
t <- now
said <- genServiceAccountDbId
let scopes = Set.fromList [Scope "kawa:ingest", Scope "signal:raise"]
created <-
createServiceAccount
NewServiceAccount
{ serviceAccountId = said,
clientId = idText said,
userId = u.userId,
secretHash = "hash-one",
displayName = "rei connector",
allowedScopes = scopes,
createdAt = t
}
afterCreate <- findServiceAccountByClientId (idText said)
listed <- listServiceAccounts
rotateServiceAccountSecret said "hash-two" t
afterRotate <- findServiceAccountByClientId (idText said)
revokeServiceAccount said t
afterRevoke <- findServiceAccountByClientId (idText said)
pure (created, afterCreate, listed, afterRotate, afterRevoke, scopes)
(created, afterCreate, listed, afterRotate, afterRevoke, scopes) <- expectApp result
-- a fresh account is active with no rotation/revocation stamps
saStatus created @?= ServiceAccountActive
saRotatedAt created @?= Nothing
-- the lookup by client id resolves, and the jsonb scope set survived the round trip
fmap saId afterCreate @?= Just (saId created)
fmap saAllowedScopes afterCreate @?= Just scopes
map saId listed @?= [saId created]
-- rotation swaps the hash and stamps rotated_at, without revoking
fmap saSecretHash afterRotate @?= Just "hash-two"
assertBool "rotated_at is stamped" (maybe False (isJust . saRotatedAt) afterRotate)
fmap saStatus afterRotate @?= Just ServiceAccountActive
-- revocation flips status and stamps revoked_at; the ROW SURVIVES so the lookup still resolves
fmap saStatus afterRevoke @?= Just ServiceAccountRevoked
assertBool "revoked_at is stamped" (maybe False (isJust . saRevokedAt) afterRevoke)
n <- scalarInt pool "SELECT count(*) FROM shomei.shomei_service_accounts"
n @?= 1
-- Field accessors: 'OAuthClient' shares field names with 'ServiceAccount' and 'User', so read
-- it by record pattern (the MasterPlan-3 DuplicateRecordFields caution).
ocStatus :: OAuthClient -> OAuthClientStatus
ocStatus OAuthClient {status} = status
ocSecretHash :: OAuthClient -> Maybe Text
ocSecretHash OAuthClient {secretHash} = secretHash
ocRevokedAt :: OAuthClient -> Maybe UTCTime
ocRevokedAt OAuthClient {revokedAt} = revokedAt
ocId :: OAuthClient -> OAuthClientId
ocId OAuthClient {oauthClientId} = oauthClientId
ocClientType :: OAuthClient -> ClientType
ocClientType OAuthClient {clientType} = clientType
ocRedirectUris :: OAuthClient -> [Text]
ocRedirectUris OAuthClient {redirectUris} = redirectUris
ocAllowedScopes :: OAuthClient -> Set.Set Scope
ocAllowedScopes OAuthClient {allowedScopes} = allowedScopes
-- | EP-5: the OAuth-client lifecycle against real PostgreSQL — create (confidential and public),
-- find by client id, list, revoke — mirroring the in-memory 'Shomei.OAuthClientStoreSpec'.
--
-- Proves the two jsonb round-trips (@redirect_uris@ as an ordered array, @allowed_scopes@ as a
-- set), the @client_type@ and @status@ text encodings, that a public client's @secret_hash@ is a
-- real SQL NULL rather than an empty string, and that a revoked row survives so the authorize
-- endpoint can resolve (and refuse) it.
testOAuthClientRoundTrip :: TestTree
testOAuthClientRoundTrip =
testCase "oauth clients: create confidential + public, find, list, revoke" $ withDb \pool -> do
result <- runApp pool do
t <- now
confId <- genOAuthClientId
pubId <- genOAuthClientId
let scopes = Set.fromList [Scope "openid", Scope "profile"]
uris = ["https://app.example.com/callback", "https://app.example.com/other"]
confidential <-
createOAuthClient
NewOAuthClient
{ oauthClientId = confId,
clientId = idText confId,
secretHash = Just "hash-one",
clientType = ConfidentialClient,
displayName = "grafana",
redirectUris = uris,
allowedScopes = scopes,
createdAt = t
}
public <-
createOAuthClient
NewOAuthClient
{ oauthClientId = pubId,
clientId = idText pubId,
secretHash = Nothing,
clientType = PublicClient,
displayName = "spa",
redirectUris = ["https://spa.example.com/cb"],
allowedScopes = Set.singleton (Scope "openid"),
createdAt = t
}
afterCreate <- findOAuthClientByClientId (idText confId)
foundPublic <- findOAuthClientByClientId (idText pubId)
listed <- listOAuthClients
revokeOAuthClient confId t
afterRevoke <- findOAuthClientByClientId (idText confId)
pure (confidential, public, afterCreate, foundPublic, listed, afterRevoke, scopes, uris)
(confidential, public, afterCreate, foundPublic, listed, afterRevoke, scopes, uris) <- expectApp result
-- a fresh client is active and unrevoked
ocStatus confidential @?= OAuthClientActive
ocRevokedAt confidential @?= Nothing
ocClientType public @?= PublicClient
-- the lookup resolves, and both jsonb columns survived the round trip (uris keep their order)
fmap ocId afterCreate @?= Just (ocId confidential)
fmap ocAllowedScopes afterCreate @?= Just scopes
fmap ocRedirectUris afterCreate @?= Just uris
fmap ocSecretHash afterCreate @?= Just (Just "hash-one")
-- a public client's secret_hash is a real NULL
fmap ocSecretHash foundPublic @?= Just Nothing
fmap ocClientType foundPublic @?= Just PublicClient
length listed @?= 2
-- revocation flips status and stamps revoked_at; the ROW SURVIVES so the lookup still resolves
fmap ocStatus afterRevoke @?= Just OAuthClientRevoked
assertBool "revoked_at is stamped" (maybe False (isJust . ocRevokedAt) afterRevoke)
nullSecrets <- scalarInt pool "SELECT count(*) FROM shomei.shomei_oauth_clients WHERE secret_hash IS NULL"
nullSecrets @?= 1
-- | EP-5: the authorization-code lifecycle against real PostgreSQL — store, consume once, replay,
-- expiry, and the batched sweep — mirroring the in-memory 'Shomei.OAuthCodeStoreSpec'.
testAuthorizationCodeRoundTrip :: TestTree
testAuthorizationCodeRoundTrip =
testCase "authorization codes: consume once, replay misses, expiry misses" $ withDb \pool -> do
result <- runApp pool do
u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})
t <- now
let scopes = Set.fromList [Scope "openid", Scope "profile"]
mk h expiresAt =
NewAuthorizationCode
{ codeHash = h,
clientId = "oauthclient_x",
redirectUri = "https://app.example.com/callback",
userId = u.userId,
scopes,
nonce = Just "n-0S6",
codeChallenge = Just (Text.replicate 43 "a"),
authTime = t,
createdAt = t,
expiresAt
}
putAuthorizationCode (mk "hash-live" (addUTCTime 60 t))
putAuthorizationCode (mk "hash-expired" (addUTCTime 60 t))
first' <- consumeAuthorizationCode "hash-live" t
sid <- genSessionId
bindAuthorizationCodeSession "hash-live" sid
bound <- findConsumedAuthorizationCode "hash-live" t
replay <- consumeAuthorizationCode "hash-live" t
unknown <- consumeAuthorizationCode "hash-nope" t
-- One second past its expiry: the row is there, but it must not consume.
expired <- consumeAuthorizationCode "hash-expired" (addUTCTime 61 t)
deleteExpiredAuthorizationCodes (addUTCTime 61 t)
pure (first', sid, bound, replay, unknown, expired, scopes)
(first', sid, bound, replay, unknown, expired, scopes) <- expectApp result
-- The consume returns every binding the exchange will re-check, and stamps consumed_at.
case first' of
Nothing -> assertFailure "the first consume must return the code"
Just c -> do
c.clientId @?= "oauthclient_x"
c.redirectUri @?= "https://app.example.com/callback"
c.scopes @?= scopes
c.nonce @?= Just "n-0S6"
c.codeChallenge @?= Just (Text.replicate 43 "a")
assertBool "consumed_at is stamped" (isJust c.consumedAt)
c.sessionId @?= Nothing
fmap (.sessionId) bound @?= Just (Just sid)
assertBool "a replay must miss" (isNothing replay)
assertBool "an unknown hash must miss" (isNothing unknown)
assertBool "an expired code must miss" (isNothing expired)
-- The consumed row survives the consume (only the sweeper deletes), and the sweep above
-- removed both rows because both were past their expiry by then.
remaining <- scalarInt pool "SELECT count(*) FROM shomei.shomei_oauth_authorization_codes"
remaining @?= 0
-- | The property the single-statement `UPDATE … WHERE consumed_at IS NULL … RETURNING` exists for:
-- two exchanges of the same code, racing on separate connections, and __exactly one wins__.
--
-- A read-then-write implementation passes every sequential test above and fails this one, handing
-- two clients a token from one code.
testAuthorizationCodeConsumeIsAtomicUnderRace :: TestTree
testAuthorizationCodeConsumeIsAtomicUnderRace =
testCase "authorization codes: two racing consumes, exactly one winner" $ withDb \pool -> do
seeded <- runApp pool do
u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})
t <- now
putAuthorizationCode
NewAuthorizationCode
{ codeHash = "hash-raced",
clientId = "oauthclient_x",
redirectUri = "https://app.example.com/callback",
userId = u.userId,
scopes = Set.singleton (Scope "openid"),
nonce = Nothing,
codeChallenge = Nothing,
authTime = t,
createdAt = t,
expiresAt = addUTCTime 60 t
}
pure t
t <- expectApp seeded
-- A start gate, so the contenders reach the UPDATE together rather than one after another.
-- Without it the two threads would very likely serialize and the case would pass even against
-- a read-then-write implementation. Even so this race is opportunistic: what actually
-- guarantees the property is that the consume is ONE statement.
gate <- newEmptyMVar
dones <- replicateM 8 do
done <- newEmptyMVar
_ <- forkIO do
readMVar gate
putMVar done =<< runApp pool (consumeAuthorizationCode "hash-raced" t)
pure done
putMVar gate ()
results <- traverse (\d -> expectApp =<< takeMVar d) dones
length (filter isJust results) @?= 1
consumedRows <- scalarInt pool "SELECT count(*) FROM shomei.shomei_oauth_authorization_codes WHERE consumed_at IS NOT NULL"
consumedRows @?= 1
testPasskeyCreateAndFind :: TestTree
testPasskeyCreateAndFind = testCase "passkey store: create + find by user/credential-id/user-handle" $ withDb \pool -> do
result <- runApp pool do
u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})
t <- now
created <- createPasskey (newPasskey u t)
byUser <- findPasskeysByUser u.userId
byCred <- findPasskeyByCredentialId (WebAuthnCredentialId "cred-1")
byHandle <- findPasskeysByUserHandle (UserHandle "uh-1")
pure (created, byUser, byCred, byHandle)
(created, byUser, byCred, byHandle) <- expectApp result
-- all three lookups resolve to the created passkey
map pkPasskeyId byUser @?= [pkPasskeyId created]
fmap pkPasskeyId byCred @?= Just (pkPasskeyId created)
map pkPasskeyId byHandle @?= [pkPasskeyId created]
-- the jsonb transports + bigint counter + label survived the round trip
fmap pkTransports byCred @?= Just ["usb", "nfc"]
fmap pkLabel byCred @?= Just (Just "key")
fmap pkSignCounter byCred @?= Just (SignatureCounter 0)
n <- scalarInt pool "SELECT count(*) FROM shomei.shomei_webauthn_credentials"
n @?= 1
testPasskeyUpdateCountDelete :: TestTree
testPasskeyUpdateCountDelete = testCase "passkey store: update sign counter + count + delete (user-scoped)" $ withDb \pool -> do
result <- runApp pool do
u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})
t <- now
created <- createPasskey (newPasskey u t)
let pid = pkPasskeyId created
counterAdvanced <- updatePasskeySignCounter pid (SignatureCounter 42) t
afterUpdate <- findPasskeyByCredentialId (WebAuthnCredentialId "cred-1")
cnt <- countPasskeysByUser u.userId
otherUid <- genUserId
deletePasskey otherUid pid -- wrong user: must NOT delete
pure (counterAdvanced, afterUpdate, cnt, u.userId, pid)
(counterAdvanced, afterUpdate, cnt, uid, pid) <- expectApp result
counterAdvanced @?= True
fmap pkSignCounter afterUpdate @?= Just (SignatureCounter 42)
assertBool "last_used_at is populated after the counter bump" (maybe False (isJust . pkLastUsedAt) afterUpdate)
cnt @?= 1
afterWrongUser <- scalarInt pool "SELECT count(*) FROM shomei.shomei_webauthn_credentials"
afterWrongUser @?= 1 -- wrong-user delete left it
_ <- runApp pool (deletePasskey uid pid) >>= expectApp
afterOwner <- scalarInt pool "SELECT count(*) FROM shomei.shomei_webauthn_credentials"
afterOwner @?= 0 -- owner delete removed it
testPasskeyCounterIsCompareAndSwap :: TestTree
testPasskeyCounterIsCompareAndSwap =
testCase "passkey counter advances atomically and preserves counterless authenticators" $ withDb \pool -> do
result <- runApp pool do
u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})
t <- now
created <- createPasskey (newPasskey u t)
let pid = pkPasskeyId created
zeroToZero <- updatePasskeySignCounter pid (SignatureCounter 0) t
first <- updatePasskeySignCounter pid (SignatureCounter 42) t
zeroAfterNonzero <- updatePasskeySignCounter pid (SignatureCounter 0) t
same <- updatePasskeySignCounter pid (SignatureCounter 42) t
older <- updatePasskeySignCounter pid (SignatureCounter 41) t
newer <- updatePasskeySignCounter pid (SignatureCounter 43) t
stored <- findPasskeyByCredentialId (WebAuthnCredentialId "cred-1")
pure (zeroToZero, first, zeroAfterNonzero, same, older, newer, stored)
(zeroToZero, first, zeroAfterNonzero, same, older, newer, stored) <- expectApp result
(zeroToZero, first, zeroAfterNonzero, same, older, newer)
@?= (True, True, False, False, False, True)
fmap pkSignCounter stored @?= Just (SignatureCounter 43)
testPasskeyCounterCasUnderRace :: TestTree
testPasskeyCounterCasUnderRace =
testCase "passkey counter: eight racing nonzero updates have one winner" $ withDb \pool -> do
seeded <- runApp pool do
u <- createUser (NewUser {loginId = aliceLogin, email = Just aliceEmail, displayName = Nothing})
t <- now
created <- createPasskey (newPasskey u t)
pure (pkPasskeyId created, t)
(pid, t) <- expectApp seeded
gate <- newEmptyMVar
dones <- replicateM 8 do
done <- newEmptyMVar
_ <- forkIO do
readMVar gate
putMVar done =<< runApp pool (updatePasskeySignCounter pid (SignatureCounter 42) t)
pure done
putMVar gate ()
results <- traverse (\done -> expectApp =<< takeMVar done) dones
length (filter id results) @?= 1
testPendingCeremonyConsumeOnce :: TestTree
testPendingCeremonyConsumeOnce = testCase "pending ceremony store: put then take consumes exactly once" $ withDb \pool -> do
result <- runApp pool do
cid <- genCeremonyId
t <- now
putPendingCeremony
PendingCeremony
{ ceremonyId = cid,
userId = Nothing,
kind = RegistrationCeremony,
optionsBlob = "{\"challenge\":\"abc\"}",
createdAt = t,
expiresAt = addUTCTime 300 t
}
first <- takePendingCeremony cid t
pure (cid, t, first)
(cid, t, first) <- expectApp result
assertBool "first take returns the ceremony" (isJust first)
afterFirst <- scalarInt pool "SELECT count(*) FROM shomei.shomei_webauthn_pending_ceremonies"
afterFirst @?= 0 -- DELETE ... RETURNING removed it
second <- runApp pool (takePendingCeremony cid t) >>= expectApp
second @?= (Nothing :: Maybe PendingCeremony)
testPendingCeremonyExpired :: TestTree
testPendingCeremonyExpired = testCase "pending ceremony store: expired ceremony is not returned" $ withDb \pool -> do
result <- runApp pool do
cid <- genCeremonyId
t <- now
putPendingCeremony
PendingCeremony
{ ceremonyId = cid,
userId = Nothing,
kind = AuthenticationCeremony,
optionsBlob = "{\"challenge\":\"xyz\"}",
createdAt = t,
expiresAt = t -- expires immediately
}
-- "now" is past expiry: returns Nothing but still removes the stale row
takePendingCeremony cid (addUTCTime 1 t)
taken <- expectApp result
taken @?= (Nothing :: Maybe PendingCeremony)
remaining <- scalarInt pool "SELECT count(*) FROM shomei.shomei_webauthn_pending_ceremonies"
remaining @?= 0
-- Argon2 parameters ----------------------------------------------------------
-- | Cheap parameters, so the parameter tests do not each pay the ~100 ms production cost.
cheapParams :: Argon2Params
cheapParams = Argon2Params {memoryKiB = 8192, iterations = 1, parallelism = 1}
testArgon2NewHashesArePhcFormatted :: TestTree
testArgon2NewHashesArePhcFormatted =
testCase "argon2: new hashes are PHC-formatted and verify" do
PasswordHash stored <- hashPasswordArgon2id defaultArgon2Params "hunter2"
assertBool
("expected a PHC prefix carrying the default params, got " <> Text.unpack stored)
("$argon2id$v=19$m=65536,t=3,p=1$" `Text.isPrefixOf` stored)
verifyPasswordArgon2id "hunter2" (PasswordHash stored) @?= True
verifyPasswordArgon2id "wrong" (PasswordHash stored) @?= False
testArgon2RejectsUnparameterizedHashes :: TestTree
testArgon2RejectsUnparameterizedHashes =
testCase "argon2: an unparameterized three-part hash is rejected" do
let unparameterized =
PasswordHash "argon2id$4gw0llx5tfM4Dfi23hUsTA==$8zWIeRIFVtmuSuMdAv4MW13Fsw1BCjfREVf4eaHwp+I="
verifyPasswordArgon2id "correct horse battery staple" unparameterized @?= False
testArgon2ParamsChangeLeavesOldHashesVerifiable :: TestTree
testArgon2ParamsChangeLeavesOldHashesVerifiable =
testCase "argon2: changing params leaves old hashes verifiable" do
-- A hash made with the defaults, and one made with different params, coexist.
defaultHash <- hashPasswordArgon2id defaultArgon2Params "hunter2"
cheapHash <- hashPasswordArgon2id cheapParams "hunter2"
assertBool "the two hashes differ" (defaultHash /= cheapHash)
-- Each verifies with the parameters IT carries, not with any ambient configuration.
verifyPasswordArgon2id "hunter2" defaultHash @?= True
verifyPasswordArgon2id "hunter2" cheapHash @?= True
testArgon2MalformedHashesVerifyFalse :: TestTree
testArgon2MalformedHashesVerifyFalse =
testCase "argon2: malformed hashes verify False without crashing" do
let malformed =
[ "$argon2id$v=19$m=notanumber,t=3,p=1$AAAAAAAAAAAAAAAAAAAAAA==$AAAA",
"$argon2id$v=99$m=65536,t=3,p=1$AAAAAAAAAAAAAAAAAAAAAA==$AAAA",
"$argon2id$v=19$m=65536,t=3$AAAAAAAAAAAAAAAAAAAAAA==$AAAA",
"$argon2id$v=19$m=0,t=3,p=1$AAAAAAAAAAAAAAAAAAAAAA==$AAAA",
"$argon2i$v=19$m=65536,t=3,p=1$AAAAAAAAAAAAAAAAAAAAAA==$AAAA",
"not-a-hash",
""
]
forM_ malformed \h ->
assertBool
("expected False for " <> Text.unpack h)
(not (verifyPasswordArgon2id "hunter2" (PasswordHash h)))
-- | The login timing oracle, at the level where it is actually created.
--
-- A login that never reaches a stored hash burns 'dummyHashFor' instead. That must cost what
-- verifying a real hash costs, or response time reveals whether an account exists. This is
-- asserted structurally — same embedded parameters — rather than with a stopwatch, because
-- equal parameters mean equal Argon2 work by construction, and a wall-clock assertion would
-- be flaky. ('Shomei.Session.Authentication.TimingSpec' asserts the complementary property: that every
-- login path performs exactly one such operation.)
testArgon2DummyHashTracksConfiguredParams :: TestTree
testArgon2DummyHashTracksConfiguredParams =
testCase "argon2: the dummy hash carries the configured params, so a miss costs what a hit costs" do
forM_ [defaultArgon2Params, cheapParams, Argon2Params 19456 2 1] \params -> do
real <- hashPasswordArgon2id params "hunter2"
let dummy = dummyHashFor params
assertEqual
("the dummy must derive with the same params as a real hash, for " <> show params)
(costFields real)
(costFields dummy)
-- It must be well-formed: a malformed dummy would return False WITHOUT hashing (~9 µs
-- versus ~100 ms), silently reopening the oracle it exists to close. Verifying against
-- it does full Argon2 work and then fails the comparison, which is exactly the point.
verifyPasswordArgon2id "hunter2" dummy @?= False
where
-- The version and parameter fields of a PHC string: everything that decides the cost.
costFields (PasswordHash t) = case Text.splitOn "$" t of
("" : "argon2id" : version : params : _) -> Just (version, params)
_ -> Nothing
testArgon2HardFloorMatchesTheImplementation :: TestTree
testArgon2HardFloorMatchesTheImplementation =
testCase "argon2: the boot hard floor matches the implementation" do
let rejected = Argon2Params 64 1 16
boundary = Argon2Params 128 1 16
assertBool "m=64,p=16 must be below the hard floor" (isJust (argon2HardFloor rejected))
trialArgon2Derivation rejected >>= assertBool "the implementation must reject m=64,p=16" . isLeft
argon2HardFloor boundary @?= Nothing
trialArgon2Derivation boundary >>= \case
Right () -> pure ()
Left failure -> assertFailure ("the hard-floor boundary must derive: " <> show failure)
-- Hashing limiter -------------------------------------------------------------
-- | At most @limit@ Argon2 derivations may run at once, no matter how many requests arrive.
--
-- Sixteen threads race for permits. Each holds its permit for a fixed 25 ms before hashing, so
-- the first @limit@ of them are provably in flight together and the high-water mark reaches
-- @limit@ exactly. The assertion that matters is @peak <= limit@ — that is the bound; the
-- @peak == limit@ half only confirms the test actually saturated the gate rather than
-- trivially passing.
testHashingLimiterBoundsConcurrency :: Int -> TestTree
testHashingLimiterBoundsConcurrency limit =
testCase ("hashing limiter: peak concurrency never exceeds the limit (" <> show limit <> ")") do
limiter <- newHashingLimiter limit
dones <- replicateM 16 newEmptyMVar
forM_ (zip [1 :: Int ..] dones) \(i, done) ->
void $ forkIO do
h <- withHashingPermit limiter do
threadDelay 25_000
hashPasswordArgon2id cheapParams ("pw" <> Text.pack (show i))
putMVar done (i, h)
results <- mapM takeMVar dones
forM_ results \(_, h) -> do
let PasswordHash phc = h
void (evaluate (Text.length phc))
peak <- peakHashingConcurrency limiter
assertBool ("peak " <> show peak <> " exceeded the limit " <> show limit) (peak <= limit)
assertEqual "the test must saturate the gate, or it proves nothing" limit peak
-- Every hash is real and verifies: the gate serializes work, it does not corrupt it.
forM_ results \(i, h) ->
assertBool
("hash " <> show i <> " must verify")
(verifyPasswordArgon2id ("pw" <> Text.pack (show i)) h)
-- | The bound must hold through the effect interpreter, not merely around 'withHashingPermit'.
-- A refactor that dropped the bracket from 'runPasswordHasherCrypto' would leave the previous
-- test green and the server unbounded.
testInterpreterForcesTheHashInsideThePermit :: TestTree
testInterpreterForcesTheHashInsideThePermit =
testCase "hashing limiter: the interpreter forces HashPassword inside its permit" do
limiter <- newHashingLimiter 1
dones <- replicateM 8 newEmptyMVar
forM_ (zip [1 :: Int ..] dones) \(i, done) ->
void $ forkIO do
h <-
runEff
. runPasswordHasherCrypto limiter cheapParams
$ hashPassword (PlainPassword ("pw" <> Text.pack (show i)))
forceStart <- getMonotonicTimeNSec
let PasswordHash phc = h
_ <- evaluate (Text.length phc)
forceEnd <- getMonotonicTimeNSec
putMVar done (i, h, forceStart, forceEnd)
results <- mapM takeMVar dones
peak <- peakHashingConcurrency limiter
assertBool "the interpreter never acquired a permit" (peak >= 1)
assertBool ("interpreter allowed " <> show peak <> " concurrent hashes") (peak <= 1)
let windows = [(forceStart, forceEnd) | (_, _, forceStart, forceEnd) <- results]
overlap (a0, a1) (b0, b1) = a0 < b1 && b0 < a1
caps <- getNumCapabilities
when (caps >= 2) $
forM_ [(a, b) | a : rest <- tails windows, b <- rest] \(a, b) ->
assertBool ("post-return forcing windows overlap: " <> show (a, b)) (not (overlap a b))
-- Capability-independent half: one cheap derivation sets the bar on this machine.
w0 <- getMonotonicTimeNSec
_ <- hashPasswordArgon2id cheapParams "warm"
w1 <- getMonotonicTimeNSec
forM_ results \(i, h, forceStart, forceEnd) -> do
assertBool
("hash " <> show i <> " was forced after the interpreter returned")
((forceEnd - forceStart) * 2 < (w1 - w0))
assertBool
("hash " <> show i <> " must verify")
(verifyPasswordArgon2id ("pw" <> Text.pack (show i)) h)
-- | A verification of a *dummy* hash also takes a permit — the miss path must be bounded
-- exactly like the hit path, or a flood of logins for nonexistent accounts bypasses the gate.
testDummyVerificationTakesAPermit :: TestTree
testDummyVerificationTakesAPermit =
testCase "hashing limiter: the dummy verification path is bounded too" do
limiter <- newHashingLimiter 1
dones <- replicateM 4 newEmptyMVar
forM_ dones \done ->
void $ forkIO do
runEff . runPasswordHasherCrypto limiter cheapParams $ verifyPasswordDummy (PlainPassword "pw")
putMVar done ()
_ <- mapM takeMVar dones
peak <- peakHashingConcurrency limiter
peak @?= 1
-- Maintenance sweep ----------------------------------------------------------
-- | A database with one row on each side of every sweep cutoff.
--
-- Ages are expressed relative to the database's @now()@; 'sweepOnce' is handed Haskell's
-- 'getCurrentTime'. The two clocks differ by milliseconds while every offset here is hours or
-- days, so no row sits near a boundary.
--
-- Three sessions: one expired 40 days ago (dead by @expires_at@, holding a three-token
-- rotation family so the sweep must respect @parent_token_id@'s self-referencing foreign
-- key); one revoked 40 days ago but with a far-future @expires_at@ (dead only by the
-- @revoked_at@ branch of the sweep's OR predicate); and one live session that must survive
-- with both of its tokens.
seedSweepFixture :: Pool -> IO ()
seedSweepFixture pool =
execSql
pool
"""
INSERT INTO shomei.shomei_users (user_id, email, display_name, status, created_at, updated_at, login_id) VALUES
('11111111-1111-1111-1111-111111111111', 'sweep1@example.com', 'Sweep One', 'active', now() - interval '90 days', now(), 'sweep1@example.com'),
('22222222-2222-2222-2222-222222222222', 'sweep2@example.com', 'Sweep Two', 'active', now() - interval '90 days', now(), 'sweep2@example.com');
INSERT INTO shomei.shomei_sessions (session_id, user_id, status, created_at, expires_at, revoked_at) VALUES
('aaaaaaaa-0000-0000-0000-000000000001', '11111111-1111-1111-1111-111111111111', 'active', now() - interval '60 days', now() - interval '40 days', NULL),
('aaaaaaaa-0000-0000-0000-000000000002', '11111111-1111-1111-1111-111111111111', 'revoked', now() - interval '60 days', now() + interval '30 days', now() - interval '40 days'),
('aaaaaaaa-0000-0000-0000-000000000003', '22222222-2222-2222-2222-222222222222', 'active', now() - interval '1 day', now() + interval '30 days', NULL);
-- A three-generation rotation family on the expired session, then a single token on the
-- revoked one, then two live tokens that must survive.
INSERT INTO shomei.shomei_refresh_tokens
(refresh_token_id, session_id, token_hash, parent_token_id, status, created_at, expires_at, used_at, revoked_at) VALUES
('bbbbbbbb-0000-0000-0000-000000000001', 'aaaaaaaa-0000-0000-0000-000000000001', 'hash-dead-1', NULL, 'used', now() - interval '60 days', now() - interval '40 days', now() - interval '59 days', NULL),
('bbbbbbbb-0000-0000-0000-000000000002', 'aaaaaaaa-0000-0000-0000-000000000001', 'hash-dead-2', 'bbbbbbbb-0000-0000-0000-000000000001', 'used', now() - interval '59 days', now() - interval '40 days', now() - interval '58 days', NULL),
('bbbbbbbb-0000-0000-0000-000000000003', 'aaaaaaaa-0000-0000-0000-000000000001', 'hash-dead-3', 'bbbbbbbb-0000-0000-0000-000000000002', 'active', now() - interval '58 days', now() - interval '40 days', NULL, NULL),
('bbbbbbbb-0000-0000-0000-000000000011', 'aaaaaaaa-0000-0000-0000-000000000002', 'hash-revk-1', NULL, 'revoked', now() - interval '60 days', now() + interval '30 days', NULL, now() - interval '40 days'),
('cccccccc-0000-0000-0000-000000000001', 'aaaaaaaa-0000-0000-0000-000000000003', 'hash-live-1', NULL, 'used', now() - interval '1 day', now() + interval '30 days', now() - interval '1 hour', NULL),
('cccccccc-0000-0000-0000-000000000002', 'aaaaaaaa-0000-0000-0000-000000000003', 'hash-live-2', 'cccccccc-0000-0000-0000-000000000001', 'active', now() - interval '1 hour', now() + interval '30 days', NULL, NULL);
-- One expired past the 7-day grace, one still live.
INSERT INTO shomei.shomei_email_verification_tokens
(verification_token_id, user_id, token_hash, status, created_at, expires_at, consumed_at, revoked_at) VALUES
('dddddddd-0000-0000-0000-000000000001', '11111111-1111-1111-1111-111111111111', 'vhash-old', 'active', now() - interval '11 days', now() - interval '10 days', NULL, NULL),
('dddddddd-0000-0000-0000-000000000002', '11111111-1111-1111-1111-111111111111', 'vhash-new', 'active', now(), now() + interval '1 day', NULL, NULL);
INSERT INTO shomei.shomei_password_reset_tokens
(password_reset_token_id, user_id, token_hash, status, created_at, expires_at, consumed_at, revoked_at) VALUES
('eeeeeeee-0000-0000-0000-000000000001', '11111111-1111-1111-1111-111111111111', 'phash-old', 'active', now() - interval '11 days', now() - interval '10 days', NULL, NULL),
('eeeeeeee-0000-0000-0000-000000000002', '11111111-1111-1111-1111-111111111111', 'phash-new', 'active', now(), now() + interval '1 day', NULL, NULL);
-- Expired 2 hours ago (past the 60-minute grace); expired 30 minutes ago (inside it); live.
INSERT INTO shomei.shomei_webauthn_pending_ceremonies (ceremony_id, user_id, kind, options_blob, created_at, expires_at) VALUES
('ffffffff-0000-0000-0000-000000000001', NULL, 'authentication', '\\x00'::bytea, now() - interval '3 hours', now() - interval '2 hours'),
('ffffffff-0000-0000-0000-000000000002', NULL, 'authentication', '\\x00'::bytea, now() - interval '90 minutes', now() - interval '30 minutes'),
('ffffffff-0000-0000-0000-000000000003', NULL, 'registration', '\\x00'::bytea, now(), now() + interval '1 hour');
-- Elapsed past the 7-day grace; elapsed yesterday (inside it); not locked at all.
INSERT INTO shomei.shomei_account_lockouts (account_key, failed_count, locked_until, updated_at) VALUES
('lockout-elapsed', 5, now() - interval '10 days', now() - interval '10 days'),
('lockout-recent', 5, now() - interval '1 day', now() - interval '1 day'),
('lockout-counting', 2, NULL, now());
-- EP-5 authorization codes: expired 2 hours ago (past the 60-minute ceremony grace, which
-- these share); expired 30 minutes ago (inside it); live. The consumed-but-expired one goes
-- too -- a consumed code is already unusable, so keeping it past expiry buys nothing.
INSERT INTO shomei.shomei_oauth_authorization_codes
(code_hash, client_id, user_id, redirect_uri, scopes, nonce, code_challenge, auth_time, created_at, expires_at, consumed_at) VALUES
('codehash-old', 'oauthclient_x', '11111111-1111-1111-1111-111111111111', 'https://app.test/cb', '["openid"]'::jsonb, NULL, NULL, now() - interval '3 hours', now() - interval '3 hours', now() - interval '2 hours', NULL),
('codehash-consumed', 'oauthclient_x', '11111111-1111-1111-1111-111111111111', 'https://app.test/cb', '["openid"]'::jsonb, NULL, NULL, now() - interval '3 hours', now() - interval '3 hours', now() - interval '2 hours', now() - interval '2 hours'),
('codehash-recent', 'oauthclient_x', '11111111-1111-1111-1111-111111111111', 'https://app.test/cb', '["openid"]'::jsonb, NULL, NULL, now() - interval '90 minutes', now() - interval '90 minutes', now() - interval '30 minutes', NULL),
('codehash-live', 'oauthclient_x', '11111111-1111-1111-1111-111111111111', 'https://app.test/cb', '["openid"]'::jsonb, NULL, NULL, now(), now(), now() + interval '1 minute', NULL);
-- Past the 90-day retention window; inside it.
INSERT INTO shomei.shomei_login_attempts (attempt_id, account_key, client_ip, outcome, occurred_at) VALUES
('99999999-0000-0000-0000-000000000001', 'acct', '10.0.0.1', 'failure', now() - interval '100 days'),
('99999999-0000-0000-0000-000000000002', 'acct', '10.0.0.1', 'failure', now() - interval '10 days');
-- Audit events are retained forever by default; the 400-day-old one only goes when an
-- explicit retention window is configured.
INSERT INTO shomei.shomei_auth_events (event_id, user_id, session_id, event_type, payload, created_at) VALUES
('88888888-0000-0000-0000-000000000001', NULL, NULL, 'login_succeeded', '{}'::jsonb, now() - interval '400 days'),
('88888888-0000-0000-0000-000000000002', NULL, NULL, 'login_succeeded', '{}'::jsonb, now());
-- EP-9 time-bound role grants: one expired past the 7-day grace (swept), one expired inside
-- it (kept), and one forever grant with a NULL expiry (never swept). 'admin' is seeded by the
-- migration; a second role is defined here so both live grants can hang off one user.
INSERT INTO shomei.shomei_roles (role, description, created_at) VALUES
('auditor', 'sweep fixture role', now()) ON CONFLICT (role) DO NOTHING;
INSERT INTO shomei.shomei_role_grants (user_id, role, granted_by, granted_at, expires_at) VALUES
('11111111-1111-1111-1111-111111111111', 'admin', NULL, now() - interval '60 days', now() - interval '10 days'),
('22222222-2222-2222-2222-222222222222', 'admin', NULL, now() - interval '60 days', now() - interval '1 day'),
('11111111-1111-1111-1111-111111111111', 'auditor', NULL, now() - interval '60 days', NULL);
"""
testSweepDeletesExpiredRows :: TestTree
testSweepDeletesExpiredRows =
testCase "maintenance sweep: deletes exactly the expired rows and spares the rest" $ withDb \pool -> do
seedSweepFixture pool
t <- getCurrentTime
report <- sweepOnce pool defaultSweepConfig t >>= expectSweep
report
@?= SweepReport
{ -- three from the expired session's rotation family, one from the revoked session
refreshTokensDeleted = 4,
-- the expired one and the revoked one; the live session stays
sessionsDeleted = 2,
verificationTokensDeleted = 1,
resetTokensDeleted = 1,
ceremoniesDeleted = 1,
-- the two that expired past the grace window (one of them already consumed); the
-- recently-expired one and the live one stay
authorizationCodesDeleted = 2,
lockoutsDeleted = 1,
loginAttemptsDeleted = 1,
-- the one grant expired past the 7-day grace; the recently-expired and the forever
-- (NULL expiry) grants stay
roleGrantsDeleted = 1,
-- retention disabled by default
authEventsDeleted = 0
}
-- The survivors are exactly the rows on the live side of each cutoff.
scalarInt pool "SELECT count(*) FROM shomei.shomei_sessions" >>= (@?= 1)
scalarInt pool "SELECT count(*) FROM shomei.shomei_refresh_tokens" >>= (@?= 2)
scalarInt pool "SELECT count(*) FROM shomei.shomei_email_verification_tokens" >>= (@?= 1)
scalarInt pool "SELECT count(*) FROM shomei.shomei_password_reset_tokens" >>= (@?= 1)
scalarInt pool "SELECT count(*) FROM shomei.shomei_webauthn_pending_ceremonies" >>= (@?= 2)
scalarInt pool "SELECT count(*) FROM shomei.shomei_account_lockouts" >>= (@?= 2)
scalarInt pool "SELECT count(*) FROM shomei.shomei_login_attempts" >>= (@?= 1)
scalarInt pool "SELECT count(*) FROM shomei.shomei_auth_events" >>= (@?= 2)
-- The two live grants survive (recently expired, still in grace; and the forever grant).
scalarInt pool "SELECT count(*) FROM shomei.shomei_role_grants" >>= (@?= 2)
-- Users are never swept.
scalarInt pool "SELECT count(*) FROM shomei.shomei_users" >>= (@?= 2)
-- The live session kept its whole token chain, parent link intact.
scalarInt
pool
"SELECT count(*) FROM shomei.shomei_refresh_tokens WHERE session_id = 'aaaaaaaa-0000-0000-0000-000000000003'"
>>= (@?= 2)
testSweepIsIdempotent :: TestTree
testSweepIsIdempotent =
testCase "maintenance sweep: a second sweep is a no-op" $ withDb \pool -> do
seedSweepFixture pool
t <- getCurrentTime
_ <- sweepOnce pool defaultSweepConfig t >>= expectSweep
second <- sweepOnce pool defaultSweepConfig t >>= expectSweep
second @?= emptySweepReport
testSweepAuthEventRetention :: TestTree
testSweepAuthEventRetention =
testCase "maintenance sweep: audit events go only when a retention window is configured" $ withDb \pool -> do
seedSweepFixture pool
t <- getCurrentTime
-- Default config leaves both events in place.
def <- sweepOnce pool defaultSweepConfig t >>= expectSweep
def.authEventsDeleted @?= 0
scalarInt pool "SELECT count(*) FROM shomei.shomei_auth_events" >>= (@?= 2)
-- A 365-day window takes the 400-day-old event and nothing else.
let retaining = defaultSweepConfig {authEventRetentionDays = Just 365}
withWindow <- sweepOnce pool retaining t >>= expectSweep
withWindow @?= emptySweepReport {authEventsDeleted = 1}
scalarInt pool "SELECT count(*) FROM shomei.shomei_auth_events" >>= (@?= 1)
testSweepBatchesUntilDrained :: TestTree
testSweepBatchesUntilDrained =
testCase "maintenance sweep: batches until drained" $ withDb \pool -> do
-- 25 expired ceremonies with a batch size of 10 needs three passes of the drain loop.
execSql
pool
"""
INSERT INTO shomei.shomei_webauthn_pending_ceremonies (ceremony_id, user_id, kind, options_blob, created_at, expires_at)
SELECT gen_random_uuid(), NULL, 'authentication', '\\x00'::bytea, now() - interval '3 hours', now() - interval '2 hours'
FROM generate_series(1, 25);
"""
t <- getCurrentTime
report <- sweepOnce pool defaultSweepConfig {batchSize = 10} t >>= expectSweep
report.ceremoniesDeleted @?= 25
scalarInt pool "SELECT count(*) FROM shomei.shomei_webauthn_pending_ceremonies" >>= (@?= 0)
-- | A whole rotation family must be deleted by one statement: @parent_token_id@ is a
-- self-referencing foreign key with no @ON DELETE@ action, so a row-bounded batch that split
-- a family would fail with a foreign-key violation. 'sweepOnce' batches by /session/ to avoid
-- this, which a batch size of 1 exercises directly — one session per statement, five tokens.
testSweepBatchesWholeTokenFamilies :: TestTree
testSweepBatchesWholeTokenFamilies =
testCase "maintenance sweep: a batch never splits a refresh-token rotation family" $ withDb \pool -> do
execSql
pool
"""
INSERT INTO shomei.shomei_users (user_id, email, display_name, status, created_at, updated_at, login_id) VALUES
('11111111-1111-1111-1111-111111111111', 'fam@example.com', 'Fam', 'active', now(), now(), 'fam@example.com');
INSERT INTO shomei.shomei_sessions (session_id, user_id, status, created_at, expires_at, revoked_at) VALUES
('aaaaaaaa-0000-0000-0000-000000000001', '11111111-1111-1111-1111-111111111111', 'active', now() - interval '60 days', now() - interval '40 days', NULL),
('aaaaaaaa-0000-0000-0000-000000000002', '11111111-1111-1111-1111-111111111111', 'active', now() - interval '60 days', now() - interval '40 days', NULL);
INSERT INTO shomei.shomei_refresh_tokens
(refresh_token_id, session_id, token_hash, parent_token_id, status, created_at, expires_at, used_at, revoked_at) VALUES
('bbbbbbbb-0000-0000-0000-000000000001', 'aaaaaaaa-0000-0000-0000-000000000001', 'h1', NULL, 'used', now(), now() - interval '40 days', now(), NULL),
('bbbbbbbb-0000-0000-0000-000000000002', 'aaaaaaaa-0000-0000-0000-000000000001', 'h2', 'bbbbbbbb-0000-0000-0000-000000000001', 'used', now(), now() - interval '40 days', now(), NULL),
('bbbbbbbb-0000-0000-0000-000000000003', 'aaaaaaaa-0000-0000-0000-000000000001', 'h3', 'bbbbbbbb-0000-0000-0000-000000000002', 'active', now(), now() - interval '40 days', NULL, NULL),
('bbbbbbbb-0000-0000-0000-000000000011', 'aaaaaaaa-0000-0000-0000-000000000002', 'h4', NULL, 'used', now(), now() - interval '40 days', now(), NULL),
('bbbbbbbb-0000-0000-0000-000000000012', 'aaaaaaaa-0000-0000-0000-000000000002', 'h5', 'bbbbbbbb-0000-0000-0000-000000000011', 'active', now(), now() - interval '40 days', NULL, NULL);
"""
t <- getCurrentTime
report <- sweepOnce pool defaultSweepConfig {batchSize = 1} t >>= expectSweep
report.refreshTokensDeleted @?= 5
report.sessionsDeleted @?= 2
scalarInt pool "SELECT count(*) FROM shomei.shomei_refresh_tokens" >>= (@?= 0)
scalarInt pool "SELECT count(*) FROM shomei.shomei_sessions" >>= (@?= 0)
latestVerificationToken :: [Notification] -> IO OneTimeToken
latestVerificationToken = \case
EmailVerificationRequested {token = raw} : _ -> pure raw
_ -> assertFailure "expected email-verification notification"
latestResetToken :: [Notification] -> IO OneTimeToken
latestResetToken = \case
PasswordResetRequested {token = raw} : _ -> pure raw
_ -> assertFailure "expected password-reset notification"