packages feed

shomei-server (empty) → 0.3.0.0

raw patch · 40 files changed

+11642/−0 lines, 40 filesdep +aesondep +basedep +base64

Dependencies added: aeson, base, base64, bytestring, containers, contravariant-extras, crypton, directory, effectful, effectful-core, hasql, http-client, http-client-tls, http-types, iproute, jose, mime-mail, network, optparse-applicative, pg-migrate, process, ram, servant-health, servant-server, shomei-core, shomei-jwt, shomei-migrations, shomei-postgres, shomei-servant, shomei-server, shomei-webauthn, smtp-mail, stm, tasty, tasty-hunit, text, time, unix, unordered-containers, uuid, wai, warp

Files

+ CHANGELOG.md view
@@ -0,0 +1,96 @@+# Changelog for shomei-server++All notable changes to `shomei-server` are documented here. This package adheres to the+[PVP](https://pvp.haskell.org/) and is versioned independently of the other+Shōmei packages.++## 0.3.0.0 — 2026-11-05++- **Breaking:** internal dependency bounds follow the 0.3 API series; migration dependencies require `shomei-migrations ^>=0.2.0.1`.+- First Hackage publication; earlier version sections describe repository development milestones.++- Explicit lab overrides for HTTP webhooks and plaintext SMTP credentials now emit fixed secret-free boot warnings. The notification guide documents inherited outbound HTTP proxy settings.++- Signing-key CLI transactions use finite database retry/deadline defaults. Activation revalidates and locks the pending source row before retiring the old key; injected activation/rewrap write failures roll back wholly. Key assembly fails closed on multiple active rows even after index bypass.++- Audit CLI accepts canonical user/session TypeIDs and legacy UUID filters and emits canonical user/session IDs. HIBP failures have an injectable query/report boundary and a tested bounded, secret-free diagnostic.++- **Breaking:** ServerSettings gains bind host, finite connection limit (1024) and slow-client timeout (30 seconds). Standalone and embedded Warp hosts use shared `hostWarpSettings`; excess connections close immediately and all close paths restore capacity. Dhall/environment settings are synchronized.+- Container entrypoint delegates migration and active-key bootstrap to shared server boot. Request severity is error for 5xx, warn for 429 and info otherwise.++- **Breaking:** PostgreSQL assembly uses the managed `Shomei.Persistence.Pool.Postgres.Pool` and its `UsageError`, `use` and `release` operations. Interrupted/failed sessions discard their connection and restore capacity; the external pool dependency is removed.++- Machine and delegated mints atomically enforce the configurable active principal ceiling (default 1000), preserving existing sessions after lowering the cap. Expiry frees capacity; finite sweeper retention bounds ordinary history by issuance rate and retention.++- **Breaking:** database transactions use the bounded statement wrapper; session bulk revocation returns winning IDs and the audited unit of work returns a count. Administrative session HTTP listing returns a keyset page (default 50, maximum 200). Server transaction limits default to three attempts/five seconds.++- Enforce finite new-write identity, display-name, passkey-label and role/scope budgets; preserve legacy identity authentication and snapshots. Login passwords over 256 code points fail before credential proof accounting. PostgreSQL adds migration 0039; see `docs/user/input-limits.md`.++- Expose finite actor migration settings through `SHOMEI_LEGACY_ACTOR_UNTIL_UNIX` and+  `SHOMEI_EMIT_LEGACY_ACTOR` with matching Dhall fields. Follow the coordinated token upgrade guide.++- Expose the passkey enrollment ceiling through `SHOMEI_MAX_PASSKEYS_PER_USER` and Dhall+  `maxPasskeysPerUser` (default 20, accepted range 1–100).++- Add `shomei-admin totp migrate-envelopes --check|--offline`; shared server startup refuses+  legacy TOTP envelopes. See the MFA guide for the required offline upgrade and rollback steps.+- Require released `smtp-mail >=0.5.0.2`, which fixes the `getHostName` import conflict with+  `network >=3.2.10`.++- `SHOMEI_REMEMBERED_SESSION_TTL` and the Dhall field `rememberedSessionTtlSeconds` set the+  lifetime of a remembered session.++## 0.2.0.0 — 2026-08-27++- **Breaking:** secure cookie transport now uses `__Host-shomei_session` and+  `__Secure-shomei_refresh`. Existing browser sessions are logged out once; development deployments+  with `cookieSecure = false` retain the bare names.+- Unknown-length request bodies are metered while consumed and receive a Problem Details 413 when+  they cross the cap. Warp parser failures and escaped synchronous exceptions now use the same+  public 400/413/500 envelope, and hostile authentication-header bytes cannot escape UTF-8 decoding.+- Prometheus method labels now use a fixed eight-value vocabulary with correctly escaped values,+  elapsed-time accounting uses monotonic clocks, and readiness is bounded to two seconds with a+  one-second single-flight cache.+- `shomei-admin users create` reads passwords from stdin or `--password-file`, loads the+  deployment's Dhall password and HIBP breach policy, and can explicitly mark a bootstrap email+  verified. PostgreSQL diagnostics retain only a safe category and optional SQLSTATE; breach-check+  outages log one classified reason.+- **Breaking:** `SmtpConfig` and `WebhookConfig` no longer carry credentials. The server loads+  stripped secrets into non-printable runtime types, requires HTTPS webhooks and encrypted SMTP+  authentication unless env-only lab flags opt out, and signs webhooks over+  `<X-Shomei-Timestamp>.<raw body>` for receiver replay windows.+- Notification delivery now runs on a supervised bounded in-memory queue, keeping SMTP/webhook+  latency out of request handling. Queue capacity is configurable, overflow is audited without+  blocking, and graceful shutdown drains queued work before releasing the database pool.+- Notification delivery failures persist only stable reason codes; transport exceptions,+  rendered messages, webhook response bodies, and request URLs never reach logs or audit rows.+- Configuration adds `dbStatementTimeoutMs` / `SHOMEI_DB_STATEMENT_TIMEOUT_MS` (30 seconds by+  default), and the in-process sweeper uses a dedicated one-connection pool.+- **Breaking:** the Dhall schema now exports `{ Type, default }` with every loader key optional;+  annotated files use `Shomei::{ field = Some value }`. A test keeps schema and loader fields equal.+- **Breaking:** Dhall configuration rejects unknown fields and invalid WebAuthn policy names, and+  startup refuses empty WebAuthn origin sets. `SHOMEI_EMAIL_VERIFICATION_REQUIRED` now overlays the+  corresponding file setting.+- The server and `shomei-admin` refuse Argon2 costs that the implementation cannot represent or+  accept; server startup also performs one real derivation before acquiring a database pool.+- **Breaking:** configuration adds `allowedClockSkewSeconds` and validates issuer and audience as+  RFC 7519 StringOrURI values at boot.+- The admin CLI activates and rewraps signing keys transactionally, stamps `revoked_at`, and lists+  every lifecycle timestamp. The server refuses ambiguous multi-active key state.++Not yet published to Hackage: depends on `shomei-webauthn`, which is blocked+on a Hackage release of `webauthn` compatible with GHC 9.12.4 and `jose 0.13`.++Initial release contents:++- The `shomei-server` warp executable serving `ShomeiAPI` against PostgreSQL,+  with signing-key bootstrap, publication, and hot reload.+- WAI middleware stack: structured logging, Prometheus metrics, per-IP and+  per-account rate limiting, and request body limits.+- Health and readiness probes and graceful shutdown under a supervisor.+- Environment-driven configuration loader.+- HIBP breach checking enforced in the password workflows.+- The `shomei-admin` operations CLI: user and session administration,+  service-account and OAuth-client lifecycle, and zero-downtime signing-key+  rotation including encrypt-at-rest and rewrap.+- Password-reset and email-verification tokens are never logged.
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2026 Nadeem Bitar++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ app/Admin.hs view
@@ -0,0 +1,238 @@+-- | @shomei-admin@: the operational CLI (EP-4). Subcommands manage migrations, the signing-key+-- rotation lifecycle, and bootstrap user creation against a deployed Shōmei database, without the+-- HTTP server running. See @shomei-admin --help@.+module Main (main) where++import Control.Exception (finally)+import Data.List.NonEmpty qualified as NonEmpty+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.IO qualified as TextIO+import Database.PostgreSQL.Migrate (MigrationReport (..))+import Options.Applicative+import Shomei.Account.Password.Domain (PlainPassword (..))+import Shomei.Admin.Audit (AuditCommand, auditParser, runAudit)+import Shomei.Admin.Env (AdminEnv (..), loadAdminEnv)+import Shomei.Admin.Keys (keysActivate, keysGenerate, keysList, keysRetire, keysRevoke, keysRewrap)+import Shomei.Admin.OAuthClients (OAuthClientsCommand, oauthClientsParser, runOAuthClients)+import Shomei.Admin.Roles (RolesCommand, rolesParser, runRoles)+import Shomei.Admin.ServiceAccounts (ServiceAccountsCommand, runServiceAccounts, serviceAccountsParser)+import Shomei.Admin.Sweep (SweepOptions, runSweep, sweepParser)+import Shomei.Admin.Users (createUserAction)+import Shomei.Mfa.Totp.Postgres (checkTotpEnvelopeVersions, migrateTotpEnvelopeBatch, totpEncryptionKeyFromBase64)+import Shomei.Migrations (applyShomeiMigrations)+import Shomei.Server.Keys (loadKekFromEnv, loadNamedKekFromEnv)+import Shomei.SigningKey.Domain (SigningAlgorithm (ES256), signingAlgorithmFromText)+import System.Environment (lookupEnv)+import System.Exit (exitFailure)+import System.IO (hFlush, hIsTerminalDevice, hPutStr, hPutStrLn, hSetEcho, stderr, stdin)++-- The command tree -----------------------------------------------------------++data Command+  = Migrate+  | Keys KeysCommand+  | Users UsersCommand+  | Roles RolesCommand+  | ServiceAccounts ServiceAccountsCommand+  | OAuthClients OAuthClientsCommand+  | Audit AuditCommand+  | Sweep SweepOptions+  | TotpMigrateEnvelopes Bool Bool++data KeysCommand+  = KeysGenerate SigningAlgorithm+  | KeysActivate Text+  | KeysRetire Text+  | KeysRevoke Text+  | KeysList+  | KeysRewrap++data UsersCommand = UsersCreate+  { email :: Text,+    passwordFile :: Maybe FilePath,+    displayName :: Maybe Text,+    emailVerified :: Bool+  }++commandParser :: Parser Command+commandParser =+  hsubparser+    ( command "migrate" (info (pure Migrate) (progDesc "Apply pending database migrations"))+        <> command "keys" (info (Keys <$> keysParser) (progDesc "Manage signing keys"))+        <> command "users" (info (Users <$> usersParser) (progDesc "Manage user accounts"))+        <> command "roles" (info (Roles <$> rolesParser) (progDesc "Declare roles and grant them to users"))+        <> command "service-accounts" (info (ServiceAccounts <$> serviceAccountsParser) (progDesc "Manage OAuth2 client_credentials machine accounts"))+        <> command "oauth-clients" (info (OAuthClients <$> oauthClientsParser) (progDesc "Manage OAuth2/OIDC clients for the authorization-code flow"))+        <> command "audit" (info (Audit <$> auditParser) (progDesc "Query the audit log / security events"))+        <> command "sweep" (info (Sweep <$> sweepParser) (progDesc "Delete expired and dead rows once, then exit"))+        <> command "totp" (info totpParser (progDesc "Maintain encrypted TOTP envelopes"))+    )++totpParser :: Parser Command+totpParser =+  hsubparser+    ( command+        "migrate-envelopes"+        ( info+            ( TotpMigrateEnvelopes+                <$> switch (long "check" <> help "Read version counts only; requires no TOTP key")+                <*> switch (long "offline" <> help "Confirm all Shomei writers are stopped and a matching backup exists")+            )+            (progDesc "Convert legacy TOTP envelopes in resumable batches of at most 100 rows")+        )+    )++keysParser :: Parser KeysCommand+keysParser =+  hsubparser+    ( command "generate" (info (KeysGenerate <$> algOpt) (progDesc "Mint a new signing key in pending status"))+        <> command "activate" (info (KeysActivate <$> kidArg) (progDesc "Promote a pending key to active (old one auto-retires)"))+        <> command "retire" (info (KeysRetire <$> kidArg) (progDesc "Demote an active key to retired (still trusted)"))+        <> command "revoke" (info (KeysRevoke <$> kidArg) (progDesc "Mark a key revoked (immediately untrusted)"))+        <> command "list" (info (pure KeysList) (progDesc "Show every key with kid / status / timestamps"))+        <> command+          "rewrap"+          (info (pure KeysRewrap) (progDesc "Re-encrypt every private key from SHOMEI_KEY_ENCRYPTION_KEY_OLD to SHOMEI_KEY_ENCRYPTION_KEY"))+    )+  where+    kidArg = Text.pack <$> argument str (metavar "KID")+    algOpt =+      option+        (eitherReader (either (Left . Text.unpack) Right . signingAlgorithmFromText . Text.pack))+        (long "alg" <> metavar "ES256|RS256" <> value ES256 <> showDefaultWith (const "ES256") <> help "Signing algorithm for the new key")++usersParser :: Parser UsersCommand+usersParser =+  hsubparser+    (command "create" (info createOpts (progDesc "Create a user account")))+  where+    createOpts =+      UsersCreate+        <$> (Text.pack <$> strOption (long "email" <> metavar "EMAIL" <> help "User email address"))+        <*> optional (strOption (long "password-file" <> metavar "PATH" <> help "Read the password from PATH instead of stdin"))+        <*> optional (Text.pack <$> strOption (long "display-name" <> metavar "NAME" <> help "Optional display name"))+        <*> switch (long "email-verified" <> help "Mark the bootstrap user's email as already verified")++main :: IO ()+main = do+  cmd <- execParser opts+  run cmd+  where+    opts =+      info+        (commandParser <**> helper)+        (fullDesc <> progDesc "Operational CLI for a Shōmei deployment" <> header "shomei-admin")++run :: Command -> IO ()+run = \case+  Migrate -> do+    env <- loadAdminEnv+    applyShomeiMigrations env.connStr >>= \case+      Left migrationError -> do+        hPutStrLn stderr ("shomei-admin: schema migration failed: " <> show migrationError)+        exitFailure+      Right report ->+        putStrLn+          ( "migrations applied: "+              <> show (NonEmpty.length report.results)+              <> " in plan (started "+              <> show report.startedAt+              <> ", finished "+              <> show report.finishedAt+              <> "); run `shomei-migrate status` for per-migration detail"+          )+  Keys kc -> do+    env <- loadAdminEnv+    case kc of+      KeysGenerate alg -> do+        kek <- loadKekFromEnv+        keysGenerate kek alg env.pool+      KeysActivate kid -> keysActivate env.pool kid+      KeysRetire kid -> keysRetire env.pool kid+      KeysRevoke kid -> keysRevoke env.pool kid+      KeysList -> keysList env.pool+      KeysRewrap -> do+        newKek <- loadKekFromEnv+        oldKek <- loadNamedKekFromEnv "SHOMEI_KEY_ENCRYPTION_KEY_OLD"+        keysRewrap oldKek newKek env.pool+  Users (UsersCreate {email, passwordFile, displayName, emailVerified}) -> do+    password <- readPasswordSecret passwordFile+    env <- loadAdminEnv+    createUserAction env email password displayName emailVerified+  Roles rc -> do+    env <- loadAdminEnv+    runRoles env rc+  ServiceAccounts sc -> do+    env <- loadAdminEnv+    runServiceAccounts env sc+  OAuthClients oc -> do+    env <- loadAdminEnv+    runOAuthClients env oc+  Audit ac -> do+    env <- loadAdminEnv+    runAudit env ac+  Sweep opts -> do+    env <- loadAdminEnv+    runSweep env opts+  TotpMigrateEnvelopes check offline -> do+    env <- loadAdminEnv+    let die message = hPutStrLn stderr message >> exitFailure+        counts = checkTotpEnvelopeVersions env.pool >>= either (const (die "shomei-admin: TOTP version/schema check failed")) pure+    (legacy, invalid) <- counts+    putStrLn ("legacy=" <> show legacy <> " invalid_versions=" <> show invalid)+    if check+      then pure ()+      else do+        if not offline then die "shomei-admin: stop all Shomei writers, retain database/key backup, then pass --offline" else pure ()+        if invalid /= 0 then die "shomei-admin: unknown TOTP envelope version; conversion refused" else pure ()+        raw <- lookupEnv "SHOMEI_TOTP_ENCRYPTION_KEY"+        key <-+          either+            (const (die "shomei-admin: valid SHOMEI_TOTP_ENCRYPTION_KEY required"))+            pure+            (maybe (Left "missing") (totpEncryptionKeyFromBase64 . Text.pack) raw)+        let loop total conflicts = do+              (remaining, unknown) <- counts+              if unknown /= 0+                then die "shomei-admin: unknown TOTP envelope version"+                else+                  if remaining == 0+                    then putStrLn ("converted=" <> show total)+                    else do+                      converted <- migrateTotpEnvelopeBatch key env.pool >>= either (const (die "shomei-admin: TOTP batch failed; restore key/snapshot and retry; no unreadable row overwritten")) pure+                      if converted == 0 && conflicts >= (2 :: Int)+                        then die "shomei-admin: repeated conversion conflicts; verify all writers are stopped"+                        else loop (total + converted) (if converted == 0 then conflicts + 1 else 0)+        loop (0 :: Int) 0++-- | Read a secret without placing it in argv. A terminal gets a no-echo prompt; redirected+-- stdin and files are consumed in full. Remove exactly one conventional line ending so+-- @printf 'secret\n'@ and a one-line secret file preserve every other byte of the password.+readPasswordSecret :: Maybe FilePath -> IO PlainPassword+readPasswordSecret source = do+  raw <- maybe readPasswordStdin TextIO.readFile source+  let password = dropOneTrailingNewline raw+  if Text.null password+    then do+      hPutStrLn stderr "shomei-admin: password must not be empty"+      exitFailure+    else pure (PlainPassword password)+  where+    readPasswordStdin = do+      interactive <- hIsTerminalDevice stdin+      if interactive+        then do+          hPutStr stderr "Password: "+          hFlush stderr+          hSetEcho stdin False+          secret <- TextIO.hGetLine stdin `finally` hSetEcho stdin True+          hPutStrLn stderr ""+          pure secret+        else TextIO.getContents++    dropOneTrailingNewline input =+      case Text.stripSuffix "\r\n" input of+        Just withoutCrLf -> withoutCrLf+        Nothing -> fromMaybe input (Text.stripSuffix "\n" input)
+ app/Main.hs view
@@ -0,0 +1,8 @@+-- | The single @shomei-server@ executable entry point; all logic lives in the+-- @shomei-server@ library (the boot sequence).+module Main (main) where++import Shomei.Server.Boot qualified as Boot++main :: IO ()+main = Boot.main
+ app/Shomei/Admin/Audit.hs view
@@ -0,0 +1,192 @@+-- | @shomei-admin audit@ (EP-7, M3): read the append-only security audit trail without a+-- @psql@ shell. The subcommands are thin wrappers over the shared+-- 'Shomei.Audit.Reader.Store' query layer (the same one the HTTP @GET \/v1\/admin\/audit\/events@+-- endpoint uses), run through the PostgreSQL interpreter over the admin pool:+--+-- @+-- shomei-admin audit events  [--user USER_ID] [--session SESSION_ID] [--type T ...] [--since TS] [--until TS] [--limit N] [--json]+-- shomei-admin audit user    \<TYPEID-or-UUID\> [filters]   -- shortcut for --user+-- shomei-admin audit session \<TYPEID-or-UUID\> [filters]   -- shortcut for --session+-- shomei-admin audit count   [filters]           -- how many events match+-- @+--+-- Default output is one tab-separated line per event+-- (@created_at \\t event_type \\t user_id \\t session_id \\t event_id@); @--json@ emits one JSON+-- object per line (NDJSON), including the raw event payload.+module Shomei.Admin.Audit+  ( AuditCommand (..),+    AuditFilters (..),+    auditParser,+    runAudit,+    runAuditReader,+    toQuery,+    toJsonObject,+  )+where++import Control.Monad (forM_)+import Data.Aeson (Value, encode, object, (.=))+import Data.ByteString.Lazy.Char8 qualified as BLC+import Data.List (intercalate)+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Time (UTCTime)+import Data.Time.Format.ISO8601 (iso8601ParseM, iso8601Show)+import Data.UUID (UUID)+import Data.UUID qualified as UUID+import Effectful (Eff, IOE, runEff)+import Effectful.Error.Static (Error, runErrorNoCallStack)+import Options.Applicative+import Shomei.Admin.Env (AdminEnv (..))+import Shomei.Audit.Reader.Postgres (runAuthEventReaderPostgres)+import Shomei.Audit.Reader.Store+  ( AuditEventQuery (..),+    AuthEventReader,+    StoredAuthEvent (..),+    countAuthEvents,+    emptyAuditQuery,+    queryAuthEvents,+  )+import Shomei.Error (AuthError)+import Shomei.Id (idText, parseId, sessionIdFromUUID, sessionIdToUUID, userIdFromUUID, userIdToUUID)+import Shomei.Persistence.Database.Postgres (Database, runDatabasePool)+import Shomei.Persistence.Pool.Postgres (Pool)+import System.Exit (exitFailure)+import System.IO (hPutStrLn, stderr)++-- The command tree -----------------------------------------------------------++-- | Textual filters as they arrive from the command line (parsed/validated in 'toQuery').+data AuditFilters = AuditFilters+  { fUser :: !(Maybe Text),+    fSession :: !(Maybe Text),+    fTypes :: ![Text],+    fSince :: !(Maybe Text),+    fUntil :: !(Maybe Text),+    fLimit :: !Int,+    fJson :: !Bool+  }++data AuditCommand+  = AuditEvents AuditFilters+  | AuditUser Text AuditFilters+  | AuditSession Text AuditFilters+  | AuditCount AuditFilters++auditParser :: Parser AuditCommand+auditParser =+  hsubparser+    ( command "events" (info (AuditEvents <$> filtersParser) (progDesc "List audit events, most recent first"))+        <> command "user" (info (AuditUser <$> uuidArg "USER_ID" <*> filtersParser) (progDesc "Event timeline for one user"))+        <> command "session" (info (AuditSession <$> uuidArg "SESSION_ID" <*> filtersParser) (progDesc "Event timeline for one session"))+        <> command "count" (info (AuditCount <$> filtersParser) (progDesc "Count events matching the filters"))+    )+  where+    uuidArg mv = Text.pack <$> argument str (metavar mv)++filtersParser :: Parser AuditFilters+filtersParser =+  AuditFilters+    <$> optional (txt (long "user" <> metavar "USER_ID" <> help "Canonical user TypeID or legacy UUID"))+    <*> optional (txt (long "session" <> metavar "SESSION_ID" <> help "Canonical session TypeID or legacy UUID"))+    <*> many (txt (long "type" <> metavar "EVENT_TYPE" <> help "Filter by event type (repeatable)"))+    <*> optional (txt (long "since" <> metavar "ISO8601" <> help "Only events at or after this time (inclusive)"))+    <*> optional (txt (long "until" <> metavar "ISO8601" <> help "Only events strictly before this time"))+    <*> option auto (long "limit" <> metavar "N" <> value 50 <> showDefault <> help "Max rows (clamped to 1000)")+    <*> switch (long "json" <> help "Emit one JSON object per line (NDJSON)")+  where+    txt = fmap Text.pack . strOption++-- Execution ------------------------------------------------------------------++runAudit :: AdminEnv -> AuditCommand -> IO ()+runAudit env = \case+  AuditEvents f -> listEvents env f+  AuditUser uuid f -> listEvents env f {fUser = Just uuid}+  AuditSession uuid f -> listEvents env f {fSession = Just uuid}+  AuditCount f -> countEvents env f++listEvents :: AdminEnv -> AuditFilters -> IO ()+listEvents env f = do+  q <- toQuery f+  rows <- runReaderOrDie env.pool (queryAuthEvents q)+  if f.fJson+    then forM_ rows (BLC.putStrLn . encode . toJsonObject)+    else forM_ rows (putStrLn . tabLine)++countEvents :: AdminEnv -> AuditFilters -> IO ()+countEvents env f = do+  q <- toQuery f+  n <- runReaderOrDie env.pool (countAuthEvents q)+  print n++-- | Tab-separated line: @created_at \\t event_type \\t user_id \\t session_id \\t event_id@.+tabLine :: StoredAuthEvent -> String+tabLine s =+  intercalate+    "\t"+    [ iso8601Show s.storedCreatedAt,+      Text.unpack s.storedEventType,+      maybe "-" (Text.unpack . idText . userIdFromUUID) s.storedUserId,+      maybe "-" (Text.unpack . idText . sessionIdFromUUID) s.storedSessionId,+      UUID.toString s.storedEventId+    ]++toJsonObject :: StoredAuthEvent -> Value+toJsonObject s =+  object+    [ "eventId" .= UUID.toText s.storedEventId,+      "eventType" .= s.storedEventType,+      "userId" .= fmap (idText . userIdFromUUID) s.storedUserId,+      "sessionId" .= fmap (idText . sessionIdFromUUID) s.storedSessionId,+      "createdAt" .= iso8601Show s.storedCreatedAt,+      "payload" .= s.storedPayload+    ]++-- | Validate the textual filters into an 'AuditEventQuery' (a bad typed ID/UUID/timestamp aborts).+toQuery :: AuditFilters -> IO AuditEventQuery+toQuery f = do+  user <- parseIdentityOpt (fmap userIdToUUID . parseId) "--user" f.fUser+  session <- parseIdentityOpt (fmap sessionIdToUUID . parseId) "--session" f.fSession+  since <- parseTimeOpt "--since" f.fSince+  until_ <- parseTimeOpt "--until" f.fUntil+  pure+    emptyAuditQuery+      { queryUserId = user,+        querySessionId = session,+        queryEventTypes = f.fTypes,+        querySince = since,+        queryUntil = until_,+        queryLimit = f.fLimit+      }++parseIdentityOpt :: (Text -> Either Text UUID) -> String -> Maybe Text -> IO (Maybe UUID)+parseIdentityOpt _ _ Nothing = pure Nothing+parseIdentityOpt typed nm (Just raw) = case typed raw of+  Right uuid -> pure (Just uuid)+  Left _ -> maybe (die (nm <> ": expected a canonical typed id or legacy UUID")) (pure . Just) (UUID.fromText raw)++parseTimeOpt :: String -> Maybe Text -> IO (Maybe UTCTime)+parseTimeOpt _ Nothing = pure Nothing+parseTimeOpt nm (Just t) =+  maybe (die (nm <> ": invalid ISO-8601 timestamp: " <> Text.unpack t)) (pure . Just) (iso8601ParseM (Text.unpack t))++-- | Run a read over the 'AuthEventReader' PostgreSQL interpreter on the admin pool, aborting+-- on an infrastructure error. Mirrors @Shomei.Admin.Users.runSignup@'s minimal stack.+runAuditReader ::+  Pool ->+  Eff '[AuthEventReader, Database, Error AuthError, IOE] a ->+  IO (Either AuthError a)+runAuditReader pool =+  runEff+    . runErrorNoCallStack+    . runDatabasePool pool+    . runAuthEventReaderPostgres++runReaderOrDie :: Pool -> Eff '[AuthEventReader, Database, Error AuthError, IOE] a -> IO a+runReaderOrDie pool act = do+  res <- runAuditReader pool act+  either (\e -> die ("database error: " <> show e)) pure res++die :: String -> IO a+die msg = hPutStrLn stderr ("shomei-admin: " <> msg) >> exitFailure
+ app/Shomei/Admin/Env.hs view
@@ -0,0 +1,73 @@+-- | The configuration/assembly for @shomei-admin@.+--+-- A single stable entry point ('loadAdminEnv') reads @DATABASE_URL@, loads the same core Dhall+-- and environment policy as the server, and acquires a @hasql@ pool.+--+-- It deliberately skips server-only listen and pool validation. Every core field an admin+-- workflow consumes still comes from the deployment's real policy.+module Shomei.Admin.Env+  ( AdminEnv (..),+    loadAdminEnv,+  )+where++import Data.Foldable (for_)+import Data.Text (Text)+import Data.Text qualified as Text+import Shomei.Account.Password.Hash.Postgres (Argon2Params (..), argon2HardFloor, defaultArgon2Params)+import Shomei.Config (ShomeiConfig)+import Shomei.Persistence.Pool.Postgres (Pool, acquirePool)+import Shomei.Server.Config (defaultDbStatementTimeoutMs, loadCoreConfig)+import System.Environment (lookupEnv)+import Text.Read (readMaybe)++data AdminEnv = AdminEnv+  { config :: !ShomeiConfig,+    pool :: !Pool,+    connStr :: !Text,+    -- | Argon2id cost parameters for @users create@. Read from the same @SHOMEI_ARGON2_*@+    --     variables the server uses, so a password seeded by the CLI is hashed exactly as one+    --     created through @POST \/v1\/auth\/signup@ would be.+    argon2 :: !Argon2Params+  }++loadAdminEnv :: IO AdminEnv+loadAdminEnv = do+  cs <- requireEnv "DATABASE_URL"+  cfg <- loadCoreConfig+  params <- argon2FromEnv+  p <- acquirePool 4 10 defaultDbStatementTimeoutMs cs+  pure AdminEnv {config = cfg, pool = p, connStr = cs, argon2 = params}++argon2FromEnv :: IO Argon2Params+argon2FromEnv = do+  mem <- intEnvOr "SHOMEI_ARGON2_MEMORY_KIB" defaultArgon2Params.memoryKiB+  iters <- intEnvOr "SHOMEI_ARGON2_ITERATIONS" defaultArgon2Params.iterations+  lanes <- intEnvOr "SHOMEI_ARGON2_PARALLELISM" defaultArgon2Params.parallelism+  let params = Argon2Params {memoryKiB = mem, iterations = iters, parallelism = lanes}+  for_ (argon2HardFloor params) \why ->+    ioError+      ( userError+          ( "SHOMEI_ARGON2_MEMORY_KIB/SHOMEI_ARGON2_ITERATIONS/SHOMEI_ARGON2_PARALLELISM "+              <> "are rejected by the Argon2 implementation: "+              <> Text.unpack why+          )+      )+  pure params++intEnvOr :: Text -> Int -> IO Int+intEnvOr name def = do+  m <- lookupEnv (Text.unpack name)+  case m of+    Just v | not (null v) -> case readMaybe v of+      Just n | n > 0 -> pure n+      _ -> ioError (userError (Text.unpack name <> " must be a positive integer"))+    _ -> pure def++requireEnv :: Text -> IO Text+requireEnv name = do+  m <- lookupEnv (Text.unpack name)+  case m of+    Just v+      | let stripped = Text.strip (Text.pack v), not (Text.null stripped) -> pure stripped+    _ -> ioError (userError (Text.unpack name <> " is not set"))
+ app/Shomei/Admin/Keys.hs view
@@ -0,0 +1,349 @@+-- | The signing-key lifecycle for @shomei-admin@ (EP-4, M2): generate → activate (old key+-- auto-retires) → retire → revoke, plus the two read helpers @keys list@ and the+-- publishable-key read used to build a JWKS during rotation.+--+-- Key state is read and written with binary-local @hasql@ statements rather than the+-- 'Shomei.SigningKey.Store' effect, because (a) the effect's @ListActiveSigningKeys@ only+-- returns @active@ keys, but rotation needs to publish @active@ AND @retired@ keys, and (b) a CLI+-- benefits from one consistent, explicit SQL style with no effect-stack assembly. We deliberately+-- do NOT reuse @shomei-jwt@'s MasterPlan-1 @rotateSigningKey@ (which inserts new keys directly as+-- @active@); the CLI drives the fuller @pending → active → retired → revoked@ lifecycle, reusing+-- only key generation and the 'StoredSigningKey' conversion from @shomei-jwt@.+module Shomei.Admin.Keys+  ( keysGenerate,+    keysActivate,+    keysRetire,+    keysRevoke,+    keysList,+    keysRewrap,+    listPublishableSigningKeys,+    listAllKeys,+    summarizeUsageError,+  )+where++import Contravariant.Extras (contrazip2, contrazip9)+import Control.Monad (forM, forM_, unless)+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Time (UTCTime, getCurrentTime)+import Effectful (runEff)+import Hasql.Decoders qualified as D+import Hasql.Encoders qualified as E+import Hasql.Errors qualified as Hasql+import Hasql.Session (Session)+import Hasql.Session qualified as Session+import Hasql.Statement (Statement, preparable)+import Shomei.Persistence.Codec.Postgres (signingKeyStatusFromText, signingKeyStatusToText)+import Shomei.Persistence.Database.Postgres (runDatabasePool, runTransaction)+import Shomei.Persistence.Pool.Postgres (Pool)+import Shomei.Persistence.Pool.Postgres qualified as Pool+import Shomei.Persistence.Transaction.Postgres (Transaction)+import Shomei.Persistence.Transaction.Postgres qualified as Tx+import Shomei.Server.DatabaseError (summarizeUsageError)+import Shomei.SigningKey.Domain (SigningAlgorithm, SigningKeyStatus (..), StoredSigningKey (..), signingAlgorithmToText)+import Shomei.SigningKey.Key.Jwt (generateSigningKeyFor, toStoredSigningKeyFor)+import Shomei.SigningKey.Protection.Jwt+  ( KeyEncryptionKey,+    decryptPrivateJwk,+    encryptPrivateJwk,+    protectStoredSigningKey,+  )+import System.Exit (exitFailure)+import System.IO (hPutStrLn, stderr)++-- Public actions -------------------------------------------------------------++-- | Mint a new key for @alg@ in @pending@ status and print its @kid@. When a+-- key-encryption key is configured, the private material is encrypted before it is written,+-- so a rotation never introduces a plaintext row into an encrypted table.+keysGenerate :: KeyEncryptionKey -> SigningAlgorithm -> Pool -> IO ()+keysGenerate kek alg pool = do+  now <- getCurrentTime+  jwk <- generateSigningKeyFor alg+  stored <- either (die . Text.unpack) pure (toStoredSigningKeyFor alg now jwk)+  pending <-+    protectStoredSigningKey+      kek+      stored+        { status = KeyPending,+          activatedAt = Nothing,+          retiredAt = Nothing,+          revokedAt = Nothing+        }+  runSess pool (Session.statement (keyRow pending) insertKeyStmt)+  putStrLn ("generated pending " <> Text.unpack (signingAlgorithmToText alg) <> " key: " <> Text.unpack pending.keyId)++-- | Promote a @pending@ key to @active@ and demote every prior @active@ key to @retired@,+-- atomically at one timestamp. Refuses if the key is not @pending@.+keysActivate :: Pool -> Text -> IO ()+keysActivate pool kid = do+  mk <- runSess pool (Session.statement kid findByKidStmt) >>= rebuildMaybe+  key <- requireKey kid mk+  unless (key.status == KeyPending) (die ("key " <> Text.unpack kid <> " is " <> show key.status <> ", expected pending"))+  now <- getCurrentTime+  outcome <- runTx pool do+    pending <- Tx.statement kid lockPendingStmt+    case pending of+      Nothing -> pure Nothing+      Just _ -> do+        oldKids <- Tx.statement now retireActiveStmt+        Tx.statement (kid, now) setActiveStmt+        pure (Just oldKids)+  retired <- maybe (die "key is no longer pending; no activation was applied") pure outcome+  putStrLn ("activated " <> Text.unpack kid)+  forM_ retired \oldKid -> putStrLn ("retired (auto) " <> Text.unpack oldKid)++-- | Demote an @active@ key to @retired@ (still trusted in the JWKS), stamping @retired_at@.+keysRetire :: Pool -> Text -> IO ()+keysRetire pool kid = do+  key <- requireKey kid =<< (runSess pool (Session.statement kid findByKidStmt) >>= rebuildMaybe)+  unless (key.status == KeyActive) (die ("key " <> Text.unpack kid <> " is " <> show key.status <> "; cannot retire"))+  now <- getCurrentTime+  runSess pool (Session.statement (kid, now) setRetiredStmt)+  putStrLn ("retired " <> Text.unpack kid)++-- | Mark a key @revoked@ (immediately untrusted, removed from the JWKS). Allowed from any+-- state except @revoked@.+keysRevoke :: Pool -> Text -> IO ()+keysRevoke pool kid = do+  key <- requireKey kid =<< (runSess pool (Session.statement kid findByKidStmt) >>= rebuildMaybe)+  unless (key.status `elem` [KeyPending, KeyActive, KeyRetired]) (die ("key " <> Text.unpack kid <> " is already revoked"))+  now <- getCurrentTime+  runSess pool (Session.statement (kid, now) setRevokedStmt)+  putStrLn ("revoked " <> Text.unpack kid)++-- | Re-wrap every key under a new KEK: decrypt with @oldKek@, encrypt with @newKek@. Any+-- All-or-nothing: the full decrypt pass runs in memory /before/ the first write, so a wrong+-- @SHOMEI_KEY_ENCRYPTION_KEY_OLD@ aborts having modified nothing. (A half-rewrapped table+-- would be unreadable by either KEK.)+keysRewrap :: KeyEncryptionKey -> KeyEncryptionKey -> Pool -> IO ()+keysRewrap oldKek newKek pool = do+  keys <- listAllKeys pool+  -- Pass 1: decrypt everything, or die before touching a row.+  decrypted <- traverse decryptOne keys+  -- Pass 2: re-encrypt every row before opening the all-or-nothing write transaction.+  rewrapped <- forM decrypted \(k, plain) -> do+    enc <- encryptPrivateJwk newKek k.keyId plain+    pure (k.keyId, enc)+  runTx pool (forM_ rewrapped \row -> Tx.statement row setPrivateKeyStmt)+  putStrLn ("rewrapped " <> show (length decrypted) <> " key(s)")+  where+    decryptOne k =+      case decryptPrivateJwk oldKek k.keyId k.privateKeyJwk of+        Right plain -> pure (k, plain)+        Left err ->+          die+            ( "cannot decrypt key "+                <> Text.unpack k.keyId+                <> " with SHOMEI_KEY_ENCRYPTION_KEY_OLD ("+                <> show err+                <> "); no rows were modified"+            )++-- | Print every key with kid / status / timestamps.+keysList :: Pool -> IO ()+keysList pool = do+  keys <- listAllKeys pool+  if null keys+    then putStrLn "(no signing keys)"+    else forM_ keys \k ->+      putStrLn+        ( Text.unpack k.keyId+            <> "\t"+            <> show k.status+            <> "\tcreated="+            <> show k.createdAt+            <> "\tactivated="+            <> show k.activatedAt+            <> "\tretired="+            <> show k.retiredAt+            <> "\trevoked="+            <> show k.revokedAt+        )++-- Read helpers (also used by the integration tests) --------------------------++-- | Keys that belong in the published JWKS: @active@ and @retired@ (overlap during rotation).+listPublishableSigningKeys :: Pool -> IO [StoredSigningKey]+listPublishableSigningKeys pool = runSess pool (Session.statement () listPublishableStmt) >>= traverse rebuild++listAllKeys :: Pool -> IO [StoredSigningKey]+listAllKeys pool = runSess pool (Session.statement () listAllStmt) >>= traverse rebuild++-- Internals ------------------------------------------------------------------++requireKey :: Text -> Maybe StoredSigningKey -> IO StoredSigningKey+requireKey kid = maybe (die ("no such key: " <> Text.unpack kid)) pure++die :: String -> IO a+die msg = hPutStrLn stderr ("shomei-admin: " <> msg) >> exitFailure++runSess :: Pool -> Session a -> IO a+runSess pool s = do+  res <- Pool.use pool s+  either (\e -> die (Text.unpack (summarizeUsageError e))) pure res++runTx :: Pool -> Transaction a -> IO a+runTx pool transaction = do+  res <- runEff . runDatabasePool pool $ runTransaction transaction+  case res of+    Right value -> pure value+    Left err+      | uniqueViolation err ->+          die "another key became active concurrently; run keys list and retry"+      | otherwise -> die (Text.unpack (summarizeUsageError err))+  where+    uniqueViolation = \case+      Pool.SessionUsageError+        ( Hasql.StatementSessionError+            _+            _+            _+            _+            _+            (Hasql.ServerStatementError (Hasql.ServerError "23505" _ _ _ _))+          ) -> True+      _ -> False++rebuild :: KeyRow -> IO StoredSigningKey+rebuild r = either (\e -> die ("corrupt key row: " <> Text.unpack e)) pure (rebuildKey r)++rebuildMaybe :: Maybe KeyRow -> IO (Maybe StoredSigningKey)+rebuildMaybe = traverse rebuild++-- Row mapping and statements (mirror Shomei.SigningKey.Postgres) ---------++type KeyRow = (Text, Text, Text, Text, Text, UTCTime, Maybe UTCTime, Maybe UTCTime, Maybe UTCTime)++keyRow :: StoredSigningKey -> KeyRow+keyRow k =+  ( k.keyId,+    k.algorithm,+    k.publicKeyJwk,+    k.privateKeyJwk,+    signingKeyStatusToText k.status,+    k.createdAt,+    k.activatedAt,+    k.retiredAt,+    k.revokedAt+  )++rebuildKey :: KeyRow -> Either Text StoredSigningKey+rebuildKey (kid, alg, pub, priv, st, c, act, ret, rev) = do+  status <- signingKeyStatusFromText st+  pure StoredSigningKey {keyId = kid, algorithm = alg, publicKeyJwk = pub, privateKeyJwk = priv, status = status, createdAt = c, activatedAt = act, retiredAt = ret, revokedAt = rev}++keyRowDecoder :: D.Row KeyRow+keyRowDecoder =+  (,,,,,,,,)+    <$> D.column (D.nonNullable D.text)+    <*> D.column (D.nonNullable D.text)+    <*> D.column (D.nonNullable D.text)+    <*> D.column (D.nonNullable D.text)+    <*> D.column (D.nonNullable D.text)+    <*> D.column (D.nonNullable D.timestamptz)+    <*> D.column (D.nullable D.timestamptz)+    <*> D.column (D.nullable D.timestamptz)+    <*> D.column (D.nullable D.timestamptz)++findByKidStmt :: Statement Text (Maybe KeyRow)+findByKidStmt =+  preparable+    """+    SELECT key_id, algorithm, public_key_jwk, private_key_jwk, status, created_at, activated_at, retired_at, revoked_at+    FROM shomei.shomei_signing_keys WHERE key_id = $1+    """+    (E.param (E.nonNullable E.text))+    (D.rowMaybe keyRowDecoder)++listAllStmt :: Statement () [KeyRow]+listAllStmt =+  preparable+    """+    SELECT key_id, algorithm, public_key_jwk, private_key_jwk, status, created_at, activated_at, retired_at, revoked_at+    FROM shomei.shomei_signing_keys ORDER BY created_at+    """+    E.noParams+    (D.rowList keyRowDecoder)++listPublishableStmt :: Statement () [KeyRow]+listPublishableStmt =+  preparable+    """+    SELECT key_id, algorithm, public_key_jwk, private_key_jwk, status, created_at, activated_at, retired_at, revoked_at+    FROM shomei.shomei_signing_keys WHERE status IN ('active','retired') ORDER BY created_at+    """+    E.noParams+    (D.rowList keyRowDecoder)++insertKeyStmt :: Statement KeyRow ()+insertKeyStmt =+  preparable+    """+    INSERT INTO shomei.shomei_signing_keys+      (key_id, algorithm, public_key_jwk, private_key_jwk, status, created_at, activated_at, retired_at, revoked_at)+    VALUES ($1, $2, $3, $4, $5, $6, $7, $8, $9)+    """+    ( contrazip9+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.text))+        (E.param (E.nonNullable E.timestamptz))+        (E.param (E.nullable E.timestamptz))+        (E.param (E.nullable E.timestamptz))+        (E.param (E.nullable E.timestamptz))+    )+    D.noResult++-- | Replace a key's private material (encrypt-at-rest backfill and KEK rewrap). Never+-- touches @public_key_jwk@ or @status@.+setPrivateKeyStmt :: Statement (Text, Text) ()+setPrivateKeyStmt =+  preparable+    "UPDATE shomei.shomei_signing_keys SET private_key_jwk = $2 WHERE key_id = $1"+    (contrazip2 (E.param (E.nonNullable E.text)) (E.param (E.nonNullable E.text)))+    D.noResult++setActiveStmt :: Statement (Text, UTCTime) ()+setActiveStmt =+  preparable+    "UPDATE shomei.shomei_signing_keys SET status = 'active', activated_at = $2 WHERE key_id = $1"+    (contrazip2 (E.param (E.nonNullable E.text)) (E.param (E.nonNullable E.timestamptz)))+    D.noResult++setRetiredStmt :: Statement (Text, UTCTime) ()+setRetiredStmt =+  preparable+    "UPDATE shomei.shomei_signing_keys SET status = 'retired', retired_at = $2 WHERE key_id = $1"+    (contrazip2 (E.param (E.nonNullable E.text)) (E.param (E.nonNullable E.timestamptz)))+    D.noResult++retireActiveStmt :: Statement UTCTime [Text]+retireActiveStmt =+  preparable+    """+    UPDATE shomei.shomei_signing_keys+    SET status = 'retired', retired_at = $1+    WHERE status = 'active'+    RETURNING key_id+    """+    (E.param (E.nonNullable E.timestamptz))+    (D.rowList (D.column (D.nonNullable D.text)))++setRevokedStmt :: Statement (Text, UTCTime) ()+setRevokedStmt =+  preparable+    "UPDATE shomei.shomei_signing_keys SET status = 'revoked', revoked_at = $2 WHERE key_id = $1"+    (contrazip2 (E.param (E.nonNullable E.text)) (E.param (E.nonNullable E.timestamptz)))+    D.noResult++-- Revalidate and lock the source state inside the same transaction as retirement.+lockPendingStmt :: Statement Text (Maybe Text)+lockPendingStmt =+  preparable+    "SELECT key_id FROM shomei.shomei_signing_keys WHERE key_id=$1 AND status='pending' FOR UPDATE"+    (E.param (E.nonNullable E.text))+    (D.rowMaybe (D.column (D.nonNullable D.text)))
+ app/Shomei/Admin/OAuthClients.hs view
@@ -0,0 +1,346 @@+-- | @shomei-admin oauth-clients@ (MasterPlan 7 EP-5): register, list, and revoke the OAuth2 \/+-- OIDC relying parties that drive the authorization-code flow.+--+-- @+-- shomei-admin oauth-clients create --display-name TEXT --type confidential|public+--                                   --redirect-uri URI [--redirect-uri URI]...+--                                   [--scope S]...+-- shomei-admin oauth-clients list+-- shomei-admin oauth-clients revoke \<client_id\>+-- @+--+-- Registration is static — this CLI managing database rows — and there is no dynamic-registration+-- endpoint (RFC 7591). Nor are clients declarable in the config file: that would recreate exactly+-- the dual-source situation EP-4 is deprecating for service accounts.+--+-- __A confidential client's secret is generated here and printed exactly once.__ Only its SHA-256+-- digest is persisted. There is no @rotate-secret@ in this plan: unlike a service account, an+-- OAuth client's credential is held by an application an operator also controls, and a compromised+-- one is handled by revoking and re-registering. (Add rotation here if that proves wrong.)+--+-- A __public__ client (a browser SPA, a native or CLI app) has no secret at all. Its only binding+-- between the authorize and the token request is PKCE, which is therefore mandatory for it.+--+-- Unlike a service account, an OAuth client gets __no backing @shomei_users@ row__: it is never a+-- token subject. The token it exchanges a code for belongs to whichever user authenticated at+-- @\/oauth\/authorize@.+module Shomei.Admin.OAuthClients+  ( OAuthClientsCommand (..),+    oauthClientsParser,+    runOAuthClients,++    -- * Actions++    --++    -- | The subcommands as functions that /return/ what they did, with printing left to+    --     'runOAuthClients'. Exported so the integration suite can assert on the generated secret+    --     without capturing the process's stdout — which is not safe to do in a test runner that+    --     executes cases in parallel (an EP-4 discovery).+    createAction,+    revokeAction,+    listAction,+  )+where++import Control.Monad (forM_, unless, when)+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Time (UTCTime)+import Effectful (Eff, IOE, runEff)+import Effectful.Error.Static (Error, runErrorNoCallStack)+import Options.Applicative+import Shomei.Account.Password.Hash.Postgres (generateOpaqueToken)+import Shomei.Admin.Env (AdminEnv (..))+import Shomei.Audit.Event.Domain qualified as Event+import Shomei.Persistence.Pool.Postgres (Pool)++-- Read by /record pattern/ only, never through @OverloadedRecordDot@: 'OAuthClient' shares+-- @clientId@ / @displayName@ / @createdAt@ / @status@ with 'Shomei.ServiceAccount.Domain'.++import Shomei.Audit.Publisher.Postgres (runAuthEventPublisherPostgres)+import Shomei.Audit.Publisher.Store (AuthEventPublisher, publishAuthEvent)+import Shomei.Authorization.Claims.Domain (Scope (..))+import Shomei.Error (AuthError)+import Shomei.Id (OAuthClientId, genOAuthClientId, idText)+import Shomei.OAuth.Client.Domain+  ( ClientType (..),+    NewOAuthClient (..),+    OAuthClient (..),+    OAuthClientStatus (..),+  )+import Shomei.OAuth.Client.Postgres (runOAuthClientStorePostgres)+import Shomei.OAuth.Client.Store+  ( OAuthClientStore,+    findOAuthClientByClientId,+    listOAuthClients,+    revokeOAuthClient,+  )+import Shomei.OAuth.Client.Workflow (ClientRegistrationError (..), registerOAuthClient)+import Shomei.Persistence.Database.Postgres (Database, runDatabasePool)+import Shomei.ServiceAccount.Secret (sha256Hex)+import Shomei.Time.Postgres (runClockIO)+import Shomei.Time.Store (Clock, now)+import System.Exit (exitFailure)+import System.IO (hPutStrLn, stderr)++-- The command tree -----------------------------------------------------------++data OAuthClientsCommand+  = -- | display name, client type, redirect URIs, allowed scopes+    OAuthClientsCreate Text ClientType [Text] [Text]+  | OAuthClientsRevoke Text+  | OAuthClientsList++oauthClientsParser :: Parser OAuthClientsCommand+oauthClientsParser =+  hsubparser+    ( command "create" (info createOpts (progDesc "Register an OAuth2/OIDC client; prints a confidential client's secret once"))+        <> command "revoke" (info (OAuthClientsRevoke <$> clientIdArg) (progDesc "Refuse all future authorize and token requests for this client"))+        <> command "list" (info (pure OAuthClientsList) (progDesc "Show every OAuth client (never its secret hash)"))+    )+  where+    createOpts =+      OAuthClientsCreate+        <$> (Text.pack <$> strOption (long "display-name" <> metavar "TEXT" <> help "Human label, e.g. \"grafana\""))+        <*> option+          readClientType+          ( long "type"+              <> metavar "confidential|public"+              <> help "confidential: can keep a secret. public: cannot (SPA, native app); PKCE is then mandatory"+          )+        <*> many (Text.pack <$> strOption (long "redirect-uri" <> metavar "URI" <> help "An exact redirect target; repeatable. Matched by exact string equality"))+        <*> many (Text.pack <$> strOption (long "scope" <> metavar "SCOPE" <> help "A scope this client may request; repeatable"))+    clientIdArg = Text.pack <$> argument str (metavar "CLIENT_ID")++readClientType :: ReadM ClientType+readClientType = eitherReader \case+  "confidential" -> Right ConfidentialClient+  "public" -> Right PublicClient+  other -> Left ("must be confidential|public, got " <> other)++-- Field accessors ------------------------------------------------------------++ocId :: OAuthClient -> OAuthClientId+ocId OAuthClient {oauthClientId} = oauthClientId++ocClientId :: OAuthClient -> Text+ocClientId OAuthClient {clientId} = clientId++ocClientType :: OAuthClient -> ClientType+ocClientType OAuthClient {clientType} = clientType++ocDisplayName :: OAuthClient -> Text+ocDisplayName OAuthClient {displayName} = displayName++ocRedirectUris :: OAuthClient -> [Text]+ocRedirectUris OAuthClient {redirectUris} = redirectUris++ocAllowedScopes :: OAuthClient -> Set Scope+ocAllowedScopes OAuthClient {allowedScopes} = allowedScopes++ocStatus :: OAuthClient -> OAuthClientStatus+ocStatus OAuthClient {status} = status++ocCreatedAt :: OAuthClient -> UTCTime+ocCreatedAt OAuthClient {createdAt} = createdAt++-- Execution ------------------------------------------------------------------++-- | Register a client, returning it and — for a confidential client — the generated secret.+-- The secret is returned, never re-read: only its digest is persisted.+createAction :: AdminEnv -> Text -> ClientType -> [Text] -> [Text] -> IO (OAuthClient, Maybe Text)+createAction env displayName clientType rawUris rawScopes = do+  redirectUris <- parseRedirectUris rawUris+  when (Text.length displayName > 256) (die "display name exceeds 256 characters")+  scopes <- parseScopes rawScopes+  -- A public client is issued no secret at all, rather than one that is ignored: a credential+  -- that exists but is never checked is worse than none, because an operator will store it.+  mSecret <- case clientType of+    ConfidentialClient -> Just <$> generateOpaqueToken+    PublicClient -> pure Nothing+  registration <- runOrDie env.pool do+    ocid <- genOAuthClientId+    let cid = idText ocid+    ts <- now+    result <-+      registerOAuthClient+        env.config+        NewOAuthClient+          { oauthClientId = ocid,+            clientId = cid,+            secretHash = sha256Hex <$> mSecret,+            clientType,+            displayName,+            redirectUris,+            allowedScopes = scopes,+            createdAt = ts+          }+    case result of+      Left refused -> pure (Left refused)+      Right client -> do+        publishAuthEvent+          ( Event.OAuthClientCreated+              Event.OAuthClientCreatedData+                { oauthClientId = cid,+                  clientId = cid,+                  clientType = renderClientType clientType,+                  displayName,+                  redirectUris,+                  allowedScopes = scopes,+                  occurredAt = ts+                }+          )+        pure (Right client)+  client <- case registration of+    Left (PrivilegeScopesRefused refused) -> case Set.toList refused of+      [Scope scope] ->+        die+          ( "refused: "+              <> Text.unpack scope+              <> " is a privilege scope and cannot be registered on an OAuth client (it would make every user who authorizes through it hold it); grant it to a service account instead"+          )+      _ ->+        die+          ( "refused: "+              <> renderScopes refused+              <> " are privilege scopes and cannot be registered on an OAuth client (they would make every user who authorizes through it hold them); grant them to a service account instead"+          )+    Right registered -> pure registered+  pure (client, mSecret)++revokeAction :: AdminEnv -> Text -> IO OAuthClient+revokeAction env cid = do+  client <- requireClient env cid+  runOrDie env.pool do+    ts <- now+    revokeOAuthClient (ocId client) ts+    publishAuthEvent+      ( Event.OAuthClientRevoked+          Event.OAuthClientRevokedData+            { oauthClientId = idText (ocId client),+              clientId = ocClientId client,+              occurredAt = ts+            }+      )+  pure client++listAction :: AdminEnv -> IO [OAuthClient]+listAction env = runOrDie env.pool listOAuthClients++runOAuthClients :: AdminEnv -> OAuthClientsCommand -> IO ()+runOAuthClients env = \case+  OAuthClientsCreate displayName clientType rawUris rawScopes -> do+    (client, mSecret) <- createAction env displayName clientType rawUris rawScopes+    putStrLn ("client_id:     " <> Text.unpack (ocClientId client))+    case mSecret of+      Just secret ->+        putStrLn ("client_secret: " <> Text.unpack secret <> "  (shown once - store it now, it cannot be retrieved)")+      Nothing ->+        putStrLn "client_secret: (none - public client; PKCE with S256 is required at /oauth/authorize)"+    putStrLn ("redirect_uris: " <> Text.unpack (Text.unwords (ocRedirectUris client)))+    putStrLn ("scopes:        " <> renderScopes (ocAllowedScopes client))+  OAuthClientsRevoke cid -> do+    client <- revokeAction env cid+    putStrLn ("revoked " <> Text.unpack (ocClientId client))+    -- Access tokens are stateless JWTs; revoking the client stops new grants, not old tokens.+    putStrLn "note: tokens already issued through this client remain valid until they expire"+  OAuthClientsList -> do+    clients <- listAction env+    forM_ clients \c ->+      putStrLn+        ( Text.unpack (ocClientId c)+            <> "  "+            <> renderStatus (ocStatus c)+            <> "  "+            <> renderClientTypePadded (ocClientType c)+            <> "  "+            <> Text.unpack (ocDisplayName c)+            <> "  redirect_uris=["+            <> Text.unpack (Text.unwords (ocRedirectUris c))+            <> "]  scopes=["+            <> renderScopes (ocAllowedScopes c)+            <> "]  created="+            <> show (ocCreatedAt c)+        )++-- | Resolve a @client_id@ or exit 1, so a typo fails loudly instead of updating zero rows.+requireClient :: AdminEnv -> Text -> IO OAuthClient+requireClient env cid = do+  found <- runOrDie env.pool (findOAuthClientByClientId cid)+  maybe (die ("no oauth client with client_id " <> Text.unpack cid)) pure found++renderStatus :: OAuthClientStatus -> String+renderStatus = \case+  OAuthClientActive -> "active "+  OAuthClientRevoked -> "revoked"++renderClientType :: ClientType -> Text+renderClientType = \case+  ConfidentialClient -> "confidential"+  PublicClient -> "public"++renderClientTypePadded :: ClientType -> String+renderClientTypePadded = \case+  ConfidentialClient -> "confidential"+  PublicClient -> "public      "++renderScopes :: Set Scope -> String+renderScopes scopes = Text.unpack (Text.unwords [s | Scope s <- Set.toList scopes])++-- | Scopes are trimmed and must be non-blank; a scope containing whitespace could never be+-- expressed in the space-delimited OAuth2 @scope@ parameter.+parseScopes :: [Text] -> IO (Set Scope)+parseScopes raws = Set.fromList <$> traverse one raws+  where+    one raw =+      let trimmed = Text.strip raw+       in if Text.null trimmed || Text.any (== ' ') trimmed+            then die "invalid scope (must be non-blank, contain no spaces, and have at most 128 characters)"+            else pure (Scope trimmed)++-- | At least one redirect URI, each absolute and fragment-free.+--+-- A client with no registered URI could never complete a flow, and RFC 6749 §3.1.2 requires the+-- URI to be absolute and to carry no fragment (the fragment is where an implicit-flow response+-- would land, and the browser never sends it to the server anyway).+parseRedirectUris :: [Text] -> IO [Text]+parseRedirectUris raws = do+  uris <- traverse one raws+  unless (not (null uris)) (die "at least one --redirect-uri is required")+  pure uris+  where+    one raw =+      let trimmed = Text.strip raw+       in if not (any (`Text.isPrefixOf` trimmed) ["http://", "https://"])+            then die ("invalid redirect-uri: " <> show raw <> " (must be an absolute http(s) URL)")+            else+              if Text.any (== '#') trimmed+                then die ("invalid redirect-uri: " <> show raw <> " (must carry no fragment)")+                else pure trimmed++-- | The minimal chain these commands need. No @UserStore@: an OAuth client has no backing user.+runOAuthClientsEff ::+  Pool ->+  Eff '[OAuthClientStore, AuthEventPublisher, Clock, Database, Error AuthError, IOE] a ->+  IO (Either AuthError a)+runOAuthClientsEff pool =+  runEff+    . runErrorNoCallStack+    . runDatabasePool pool+    . runClockIO+    . runAuthEventPublisherPostgres+    . runOAuthClientStorePostgres++runOrDie ::+  Pool ->+  Eff '[OAuthClientStore, AuthEventPublisher, Clock, Database, Error AuthError, IOE] a ->+  IO a+runOrDie pool act = do+  res <- runOAuthClientsEff pool act+  either (\e -> die ("database error: " <> show e)) pure res++die :: String -> IO a+die msg = hPutStrLn stderr ("shomei-admin: " <> msg) >> exitFailure
+ app/Shomei/Admin/Roles.hs view
@@ -0,0 +1,349 @@+-- | @shomei-admin roles@ (MasterPlan 7 EP-1, extended by EP-9): declare roles, wire permissions+-- onto them, and grant them (optionally for a bounded window) to users — all without the HTTP+-- server running. This is the bootstrap path for the very first administrator: the @\/admin@+-- surface is gated on the @admin@ role, so something outside HTTP has to grant it.+--+-- @+-- shomei-admin roles define       \<NAME\> [--description TEXT]+-- shomei-admin roles list-defined+-- shomei-admin roles allow        \<ROLE\> \<PERMISSION\>+-- shomei-admin roles disallow     \<ROLE\> \<PERMISSION\>+-- shomei-admin roles show         \<ROLE\>+-- shomei-admin roles grant  --user \<user_… | UUID\> --role NAME [--expires-in \<dur\> | --expires-at \<ISO8601\>]+-- shomei-admin roles revoke --user \<user_… | UUID\> --role NAME+-- shomei-admin roles list   --user \<user_… | UUID\>+-- @+--+-- Granting a role that is not in the registry fails loudly (exit 1) rather than minting a role+-- no gate will ever check — that is what @roles define@ exists for. Likewise @allow@ refuses a+-- permission on an undefined role.+--+-- @define@, @list-defined@, @allow@, @disallow@, and @show@ talk to the+-- 'Shomei.Authorization.Role.Store.RoleStore' port directly: catalog metadata (including permission+-- wiring) is not a security event, so they publish no audit event. @grant@ and @revoke@ go+-- through 'Shomei.Authorization.Role.Workflow', which audits them as @role_granted@ / @role_revoked@ with a+-- @NULL@ actor (there is no authenticated admin on the box); a time-bound grant records its+-- expiry in the @role_granted@ payload.+module Shomei.Admin.Roles+  ( RolesCommand (..),+    GrantExpiry (..),+    rolesParser,+    runRoles,+  )+where++import Control.Monad (forM_)+import Data.Char (isDigit, isSpace)+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Time (NominalDiffTime, UTCTime, addUTCTime, getCurrentTime)+import Data.Time.Format.ISO8601 (iso8601ParseM, iso8601Show)+import Data.UUID qualified as UUID+import Effectful (Eff, IOE, runEff, (:>))+import Effectful.Error.Static (Error, runErrorNoCallStack)+import Options.Applicative+import Shomei.Account.User.Postgres (runUserStorePostgres)+import Shomei.Account.User.Store (UserStore)+import Shomei.Admin.Env (AdminEnv (..))+import Shomei.Audit.Publisher.Postgres (runAuthEventPublisherPostgres)+import Shomei.Audit.Publisher.Store (AuthEventPublisher)+import Shomei.Authorization.Claims.Domain (Permission (..), Role (..))+import Shomei.Authorization.Role.Postgres (runRoleStorePostgres)+import Shomei.Authorization.Role.Store+  ( RoleDefinition (..),+    RoleStore,+    allowPermission,+    defineRole,+    disallowPermission,+    listDefinedRoles,+    listPermissionsForRole,+  )+import Shomei.Authorization.Role.Workflow (grantRoleTo, revokeRoleFrom, rolesOf)+import Shomei.Error (AuthError (..))+import Shomei.Id (UserId, idText, parseId, userIdFromUUID)+import Shomei.Persistence.Database.Postgres (Database, runDatabasePool)+import Shomei.Persistence.Pool.Postgres (Pool)+import Shomei.Time.Postgres (runClockIO)+import Shomei.Time.Store (Clock, now)+import System.Exit (exitFailure)+import System.IO (hPutStrLn, stderr)++-- The command tree -----------------------------------------------------------++-- | How a grant's expiry was specified on the command line, resolved to an absolute instant at+-- run time (see 'resolveExpiry'). The two forms are mutually exclusive.+data GrantExpiry+  = -- | @--expires-in \<n\>(s|m|h|d)@: relative to the CLI's clock at run time.+    ExpiresIn NominalDiffTime+  | -- | @--expires-at \<ISO8601 UTC\>@: an absolute instant.+    ExpiresAt UTCTime+  deriving stock (Eq, Show)++data RolesCommand+  = RolesDefine Text (Maybe Text)+  | RolesListDefined+  | RolesAllow Text Text+  | RolesDisallow Text Text+  | RolesShow Text+  | RolesGrant Text Text (Maybe GrantExpiry)+  | RolesRevoke Text Text+  | RolesList Text++rolesParser :: Parser RolesCommand+rolesParser =+  hsubparser+    ( command "define" (info defineOpts (progDesc "Declare a role so it can be granted"))+        <> command "list-defined" (info (pure RolesListDefined) (progDesc "Show the role registry"))+        <> command "allow" (info allowOpts (progDesc "Attach a permission to a role"))+        <> command "disallow" (info disallowOpts (progDesc "Detach a permission from a role"))+        <> command "show" (info showOpts (progDesc "Show a role and the permissions it implies"))+        <> command "grant" (info (RolesGrant <$> userOpt <*> roleOpt <*> optional expiryOpt) (progDesc "Grant a defined role to a user"))+        <> command "revoke" (info (RolesRevoke <$> userOpt <*> roleOpt) (progDesc "Revoke a role from a user"))+        <> command "list" (info (RolesList <$> userOpt) (progDesc "Show the roles granted to a user"))+    )+  where+    defineOpts =+      RolesDefine+        <$> (Text.pack <$> argument str (metavar "NAME"))+        <*> optional (Text.pack <$> strOption (long "description" <> metavar "TEXT" <> help "What the role is for"))+    allowOpts = RolesAllow <$> roleArg <*> permissionArg+    disallowOpts = RolesDisallow <$> roleArg <*> permissionArg+    showOpts = RolesShow <$> roleArg+    roleArg = Text.pack <$> argument str (metavar "ROLE")+    permissionArg = Text.pack <$> argument str (metavar "PERMISSION")+    userOpt =+      Text.pack+        <$> strOption (long "user" <> metavar "USER_ID" <> help "Typed id (user_…) or bare UUID")+    roleOpt =+      Text.pack <$> strOption (long "role" <> metavar "NAME" <> help "Role name")+    -- '--expires-in' and '--expires-at' are alternatives: supplying both leaves the second flag+    -- unconsumed and optparse reports an error, which is the mutually-exclusive behaviour we want.+    expiryOpt =+      (ExpiresIn <$> option durationReader (long "expires-in" <> metavar "DURATION" <> help "Grant expiry as <n>(s|m|h|d), e.g. 4h"))+        <|> (ExpiresAt <$> option iso8601Reader (long "expires-at" <> metavar "ISO8601" <> help "Grant expiry as an ISO8601 UTC instant"))++-- | @<n>(s|m|h|d)@ → 'NominalDiffTime'. A bare number, a bad unit, or trailing junk is rejected.+durationReader :: ReadM NominalDiffTime+durationReader =+  eitherReader \s ->+    maybe (Left ("expected <n>(s|m|h|d), e.g. 4h; got " <> show s)) Right (parseDuration s)++parseDuration :: String -> Maybe NominalDiffTime+parseDuration s = case span isDigit s of+  (digits@(_ : _), [unit]) -> do+    n <- readInteger digits+    mult <- case unit of+      's' -> Just 1+      'm' -> Just 60+      'h' -> Just 3600+      'd' -> Just 86400+      _ -> Nothing+    pure (fromInteger (n * mult))+  _ -> Nothing+  where+    readInteger ds = case reads ds of+      [(n, "")] -> Just (n :: Integer)+      _ -> Nothing++-- | An ISO8601 UTC timestamp → 'UTCTime' (e.g. @2026-07-11T21:00:00Z@).+iso8601Reader :: ReadM UTCTime+iso8601Reader =+  eitherReader \s ->+    maybe (Left ("expected an ISO8601 UTC instant, e.g. 2026-07-11T21:00:00Z; got " <> show s)) Right (iso8601ParseM s)++-- Execution ------------------------------------------------------------------++-- | Resolve a parsed 'GrantExpiry' to an absolute instant. @--expires-in@ is relative to the CLI's+-- clock now; @--expires-at@ is already absolute. 'Nothing' (no flag) means the grant never expires.+resolveExpiry :: Maybe GrantExpiry -> IO (Maybe UTCTime)+resolveExpiry Nothing = pure Nothing+resolveExpiry (Just (ExpiresAt t)) = pure (Just t)+resolveExpiry (Just (ExpiresIn d)) = Just . addUTCTime d <$> getCurrentTime++-- | The outcome of a permission-wiring command, so the boundary (IO) prints or dies without the+-- eff needing to.+data AllowOutcome = AllowRoleUndefined | NewlyAllowed | AlreadyAllowed++data DisallowOutcome = DisallowRoleUndefined | Detached | NotAttached++data ShowOutcome = ShowRoleUndefined | ShowRole RoleDefinition (Set.Set Permission)++runRoles :: AdminEnv -> RolesCommand -> IO ()+runRoles env = \case+  RolesDefine rawRole mDesc -> do+    role <- parseRole rawRole+    fresh <- runOrDie env.pool do+      ts <- now+      defineRole role mDesc ts+    putStrLn+      if fresh+        then "defined role " <> roleString role+        else "role " <> roleString role <> " was already defined"+  RolesListDefined -> do+    defs <- runOrDie env.pool listDefinedRoles+    forM_ defs \d ->+      putStrLn (roleString d.role <> maybe "" (\t -> " — " <> Text.unpack t) d.description)+  RolesAllow rawRole rawPerm -> do+    role <- parseRole rawRole+    perm <- parsePermission rawPerm+    outcome <- runOrDie env.pool (allowEff role perm)+    case outcome of+      AllowRoleUndefined -> dieAuthError (RoleNotDefined role)+      NewlyAllowed -> putStrLn ("allowed " <> permString perm <> " for role " <> roleString role)+      AlreadyAllowed -> putStrLn ("role " <> roleString role <> " already allowed " <> permString perm)+  RolesDisallow rawRole rawPerm -> do+    role <- parseRole rawRole+    perm <- parsePermission rawPerm+    outcome <- runOrDie env.pool (disallowEff role perm)+    case outcome of+      DisallowRoleUndefined -> dieAuthError (RoleNotDefined role)+      Detached -> putStrLn ("disallowed " <> permString perm <> " for role " <> roleString role)+      NotAttached -> putStrLn ("role " <> roleString role <> " did not allow " <> permString perm)+  RolesShow rawRole -> do+    role <- parseRole rawRole+    outcome <- runOrDie env.pool (showEff role)+    case outcome of+      ShowRoleUndefined -> dieAuthError (RoleNotDefined role)+      ShowRole d perms -> do+        putStrLn (roleString d.role <> maybe "" (\t -> " — " <> Text.unpack t) d.description)+        if Set.null perms+          then putStrLn "  (no permissions)"+          else forM_ (Set.toList perms) \p -> putStrLn ("  " <> permString p)+  RolesGrant rawUser rawRole mExpiry -> do+    uid <- parseUserRef rawUser+    role <- parseRole rawRole+    expiry <- resolveExpiry mExpiry+    outcome <- runOrDie env.pool (grantRoleTo Nothing expiry uid role)+    case outcome of+      Left e -> dieAuthError e+      Right True ->+        putStrLn+          ( "granted "+              <> roleString role+              <> " to "+              <> Text.unpack (idText uid)+              <> maybe "" (\t -> " (expires " <> iso8601Show t <> ")") expiry+          )+      Right False -> putStrLn ("user already had role " <> roleString role)+  RolesRevoke rawUser rawRole -> do+    uid <- parseUserRef rawUser+    role <- parseRole rawRole+    outcome <- runOrDie env.pool (revokeRoleFrom Nothing uid role)+    case outcome of+      Left e -> dieAuthError e+      Right True -> putStrLn ("revoked " <> roleString role <> " from " <> Text.unpack (idText uid))+      Right False -> putStrLn "no such grant"+  RolesList rawUser -> do+    uid <- parseUserRef rawUser+    outcome <- runOrDie env.pool (rolesOf uid)+    case outcome of+      Left e -> dieAuthError e+      Right roles -> forM_ (Set.toList roles) (putStrLn . roleString)++-- | Attach a permission to a role, refusing an undefined role first (the FK backstops it, but a+-- typed pre-check gives a clear message and matches the grant path's behaviour).+allowEff :: (RoleStore :> es, Clock :> es) => Role -> Permission -> Eff es AllowOutcome+allowEff role perm = do+  defined <- definedRoleNames+  if not (role `Set.member` defined)+    then pure AllowRoleUndefined+    else do+      ts <- now+      changed <- allowPermission role perm ts+      pure (if changed then NewlyAllowed else AlreadyAllowed)++disallowEff :: (RoleStore :> es) => Role -> Permission -> Eff es DisallowOutcome+disallowEff role perm = do+  defined <- definedRoleNames+  if not (role `Set.member` defined)+    then pure DisallowRoleUndefined+    else do+      changed <- disallowPermission role perm+      pure (if changed then Detached else NotAttached)++showEff :: (RoleStore :> es) => Role -> Eff es ShowOutcome+showEff role = do+  defs <- listDefinedRoles+  case [d | d <- defs, d.role == role] of+    [] -> pure ShowRoleUndefined+    (d : _) -> ShowRole d <$> listPermissionsForRole role++definedRoleNames :: (RoleStore :> es) => Eff es (Set.Set Role)+definedRoleNames = Set.fromList . map (.role) <$> listDefinedRoles++-- | Render the typed errors the role workflows can return, each with the fix.+dieAuthError :: AuthError -> IO a+dieAuthError = \case+  UserNotFound -> die "user not found"+  RoleNotDefined (Role r) ->+    die+      ( "role not defined: "+          <> Text.unpack r+          <> " (define it first: shomei-admin roles define "+          <> Text.unpack r+          <> ")"+      )+  other -> die ("unexpected error: " <> show other)++-- | A user reference is either the typed id rendered by the API (@user_01ABC…@) or the bare+-- UUID the audit columns speak. Operators paste whichever they have in front of them.+parseUserRef :: Text -> IO UserId+parseUserRef raw =+  case parseId raw of+    Right uid -> pure uid+    Left _ ->+      case UUID.fromText raw of+        Just uuid -> pure (userIdFromUUID uuid)+        Nothing -> die ("--user must be a typed id (user_…) or a UUID, got " <> Text.unpack raw)++-- | Role names are trimmed and must be non-blank. Validating at the boundary keeps the+-- workflow free of shape checks (it treats a 'Role' as opaque text).+parseRole :: Text -> IO Role+parseRole raw =+  let trimmed = Text.strip raw+   in if Text.length raw > 128 || Text.null trimmed+        then die "role name must be non-blank and at most 128 characters"+        else pure (Role trimmed)++-- | Permission strings are trimmed and must be non-blank and contain no internal whitespace. The+-- @resource:verb@ shape is a documented convention, not enforced grammar — only blank/whitespace+-- strings are rejected.+parsePermission :: Text -> IO Permission+parsePermission raw =+  let trimmed = Text.strip raw+   in if Text.null trimmed || Text.any isSpace trimmed+        then die ("invalid permission: " <> show raw <> " (must be non-blank with no whitespace)")+        else pure (Permission trimmed)++roleString :: Role -> String+roleString (Role r) = Text.unpack r++permString :: Permission -> String+permString (Permission p) = Text.unpack p++-- | The minimal chain the role commands need, mirroring @Shomei.Admin.Users.runSignup@.+-- @UserStore@ is present because 'grantRoleTo' resolves the subject before granting.+runRolesEff ::+  Pool ->+  Eff '[UserStore, RoleStore, AuthEventPublisher, Clock, Database, Error AuthError, IOE] a ->+  IO (Either AuthError a)+runRolesEff pool =+  runEff+    . runErrorNoCallStack+    . runDatabasePool pool+    . runClockIO+    . runAuthEventPublisherPostgres+    . runRoleStorePostgres+    . runUserStorePostgres++runOrDie ::+  Pool ->+  Eff '[UserStore, RoleStore, AuthEventPublisher, Clock, Database, Error AuthError, IOE] a ->+  IO a+runOrDie pool act = do+  res <- runRolesEff pool act+  either (\e -> die ("database error: " <> show e)) pure res++die :: String -> IO a+die msg = hPutStrLn stderr ("shomei-admin: " <> msg) >> exitFailure
+ app/Shomei/Admin/ServiceAccounts.hs view
@@ -0,0 +1,313 @@+-- | @shomei-admin service-accounts@ (MasterPlan 7 EP-4): create, rotate, revoke, and list the+-- database-backed machine credentials that authenticate at @POST \/oauth\/token@ with the OAuth2+-- @client_credentials@ grant.+--+-- @+-- shomei-admin service-accounts create        --display-name TEXT [--scope S]...+-- shomei-admin service-accounts rotate-secret \<client_id\>+-- shomei-admin service-accounts revoke        \<client_id\>+-- shomei-admin service-accounts list+-- @+--+-- This is the runtime lifecycle the config-defined service accounts never had: creating,+-- rotating, or revoking one of those meant editing configuration and redeploying.+--+-- __The secret is generated here and printed exactly once.__ Only its SHA-256 digest is+-- persisted, so a lost secret cannot be recovered — it can only be replaced with+-- @rotate-secret@. The model is single-secret: rotation invalidates the old secret immediately,+-- with no overlap window. An operator who needs a zero-downtime handover creates a /second/+-- account, migrates consumers to it, then revokes the first.+--+-- Every service account owns a dedicated row in @shomei_users@, created here with @login_id@ set+-- to the account's @client_id@ and no password credential. That row is not a convenience: an+-- access token's @sub@ is a 'Shomei.Id.UserId' and @shomei_sessions.user_id@ has a foreign key+-- into @shomei_users@, so a token cannot be minted without one.+--+-- @create@, @rotate-secret@ and @revoke@ publish audit events; @list@ reads only, and never+-- prints a hash.+module Shomei.Admin.ServiceAccounts+  ( ServiceAccountsCommand (..),+    serviceAccountsParser,+    runServiceAccounts,++    -- * Actions++    --++    -- | The subcommands as functions that /return/ what they did, with printing left to+    --     'runServiceAccounts'. Exported so the integration suite can assert on the generated+    --     secret without capturing the process's stdout — which is not safe to do in a test+    --     runner that executes cases in parallel.+    createAction,+    rotateSecretAction,+    revokeAction,+    listAction,+  )+where++import Control.Monad (forM_, when)+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Time (UTCTime)+import Effectful (Eff, IOE, runEff)+import Effectful.Error.Static (Error, runErrorNoCallStack)+import Options.Applicative+import Shomei.Account.LoginId.Domain (mkLoginId)+import Shomei.Account.Password.Hash.Postgres (generateOpaqueToken)+import Shomei.Persistence.Pool.Postgres (Pool)++-- 'ServiceAccount' shares the field names @userId@ / @createdAt@ / @displayName@ with+-- 'Shomei.Account.User.Domain.User'. Both are imported with @(..)@ and read by /record pattern/ only,+-- never through @OverloadedRecordDot@: a record pattern names its constructor and so is+-- unambiguous, while @user.userId@ would not be.++import Shomei.Account.User.Domain (NewUser (..), User (..))+import Shomei.Account.User.Postgres (runUserStorePostgres)+import Shomei.Account.User.Store (UserStore, createUser)+import Shomei.Admin.Env (AdminEnv (..))+import Shomei.Audit.Event.Domain qualified as Event+import Shomei.Audit.Publisher.Postgres (runAuthEventPublisherPostgres)+import Shomei.Audit.Publisher.Store (AuthEventPublisher, publishAuthEvent)+import Shomei.Authorization.Claims.Domain (Scope (..))+import Shomei.Authorization.Scope.Domain (privilegeScopesIn)+import Shomei.Error (AuthError)+import Shomei.Id (ServiceAccountDbId, UserId, genServiceAccountDbId, idText)+import Shomei.Persistence.Database.Postgres (Database, runDatabasePool)+import Shomei.ServiceAccount.Domain (NewServiceAccount (..), ServiceAccount (..), ServiceAccountStatus (..))+import Shomei.ServiceAccount.Postgres (runServiceAccountStorePostgres)+import Shomei.ServiceAccount.Secret (sha256Hex)+import Shomei.ServiceAccount.Store+  ( ServiceAccountStore,+    createServiceAccount,+    findServiceAccountByClientId,+    listServiceAccounts,+    revokeServiceAccount,+    rotateServiceAccountSecret,+  )+import Shomei.Time.Postgres (runClockIO)+import Shomei.Time.Store (Clock, now)+import System.Exit (exitFailure)+import System.IO (hPutStrLn, stderr)++-- The command tree -----------------------------------------------------------++data ServiceAccountsCommand+  = ServiceAccountsCreate Text [Text]+  | ServiceAccountsRotateSecret Text+  | ServiceAccountsRevoke Text+  | ServiceAccountsList++serviceAccountsParser :: Parser ServiceAccountsCommand+serviceAccountsParser =+  hsubparser+    ( command "create" (info createOpts (progDesc "Create a service account; prints its secret once"))+        <> command "rotate-secret" (info (ServiceAccountsRotateSecret <$> clientIdArg) (progDesc "Replace the secret; the old one stops working immediately"))+        <> command "revoke" (info (ServiceAccountsRevoke <$> clientIdArg) (progDesc "Refuse all future tokens for this account"))+        <> command "list" (info (pure ServiceAccountsList) (progDesc "Show every service account (never its secret hash)"))+    )+  where+    createOpts =+      ServiceAccountsCreate+        <$> (Text.pack <$> strOption (long "display-name" <> metavar "TEXT" <> help "Human label, e.g. \"rei connector\""))+        <*> many (Text.pack <$> strOption (long "scope" <> metavar "SCOPE" <> help "A scope this account may request; repeatable"))+    clientIdArg = Text.pack <$> argument str (metavar "CLIENT_ID")++-- Field accessors ------------------------------------------------------------++saId :: ServiceAccount -> ServiceAccountDbId+saId ServiceAccount {serviceAccountId} = serviceAccountId++saClientId :: ServiceAccount -> Text+saClientId ServiceAccount {clientId} = clientId++saUserId :: ServiceAccount -> UserId+saUserId ServiceAccount {userId} = userId++saDisplayName :: ServiceAccount -> Text+saDisplayName ServiceAccount {displayName} = displayName++saAllowedScopes :: ServiceAccount -> Set Scope+saAllowedScopes ServiceAccount {allowedScopes} = allowedScopes++saStatus :: ServiceAccount -> ServiceAccountStatus+saStatus ServiceAccount {status} = status++saCreatedAt :: ServiceAccount -> UTCTime+saCreatedAt ServiceAccount {createdAt} = createdAt++saRotatedAt :: ServiceAccount -> Maybe UTCTime+saRotatedAt ServiceAccount {rotatedAt} = rotatedAt++-- Execution ------------------------------------------------------------------++-- | Create an account and its backing user, returning the account and the generated secret.+-- The secret is returned, never re-read: only its digest is persisted.+createAction :: AdminEnv -> Text -> [Text] -> IO (ServiceAccount, Text)+createAction env displayName rawScopes = do+  when (Text.length displayName > 256) (die "display name exceeds 256 characters")+  scopes <- parseScopes rawScopes+  forM_ (Set.toList (privilegeScopesIn env.config scopes)) \(Scope scope) ->+    hPutStrLn+      stderr+      ( "shomei-admin: warning: "+          <> Text.unpack scope+          <> " is a privilege scope; this account holds it as its own authority (see docs/user/security.md, \"Scopes are principal privilege\")"+      )+  secret <- generateOpaqueToken+  account <- runOrDie env.pool do+    said <- genServiceAccountDbId+    let cid = idText said+    ts <- now+    -- The backing principal. No password credential is created, so this row can never be+    -- logged into; it exists to satisfy the session/claims foreign keys.+    loginId <- either (const (error ("impossible: client id is not a valid login id: " <> Text.unpack cid))) pure (mkLoginId cid)+    User {userId = backingUserId} <- createUser NewUser {loginId, email = Nothing, displayName = Just displayName}+    account <-+      createServiceAccount+        NewServiceAccount+          { serviceAccountId = said,+            clientId = cid,+            userId = backingUserId,+            secretHash = sha256Hex secret,+            displayName,+            allowedScopes = scopes,+            createdAt = ts+          }+    publishAuthEvent+      ( Event.ServiceAccountCreated+          Event.ServiceAccountCreatedData+            { serviceAccountId = idText said,+              clientId = cid,+              userId = backingUserId,+              displayName,+              allowedScopes = scopes,+              occurredAt = ts+            }+      )+    pure account+  pure (account, secret)++-- | Replace the account's secret, returning it. The previous secret stops working immediately.+rotateSecretAction :: AdminEnv -> Text -> IO (ServiceAccount, Text)+rotateSecretAction env cid = do+  secret <- generateOpaqueToken+  account <- requireAccount env cid+  runOrDie env.pool do+    ts <- now+    rotateServiceAccountSecret (saId account) (sha256Hex secret) ts+    publishAuthEvent+      ( Event.ServiceAccountSecretRotated+          Event.ServiceAccountSecretRotatedData+            { serviceAccountId = idText (saId account),+              clientId = saClientId account,+              userId = saUserId account,+              occurredAt = ts+            }+      )+  pure (account, secret)++revokeAction :: AdminEnv -> Text -> IO ServiceAccount+revokeAction env cid = do+  account <- requireAccount env cid+  runOrDie env.pool do+    ts <- now+    revokeServiceAccount (saId account) ts+    publishAuthEvent+      ( Event.ServiceAccountRevoked+          Event.ServiceAccountRevokedData+            { serviceAccountId = idText (saId account),+              clientId = saClientId account,+              userId = saUserId account,+              occurredAt = ts+            }+      )+  pure account++listAction :: AdminEnv -> IO [ServiceAccount]+listAction env = runOrDie env.pool listServiceAccounts++runServiceAccounts :: AdminEnv -> ServiceAccountsCommand -> IO ()+runServiceAccounts env = \case+  ServiceAccountsCreate displayName rawScopes -> do+    (account, secret) <- createAction env displayName rawScopes+    putStrLn ("client_id:     " <> Text.unpack (saClientId account))+    putStrLn ("client_secret: " <> Text.unpack secret <> "  (shown once - store it now, it cannot be retrieved)")+    putStrLn ("scopes:        " <> renderScopes (saAllowedScopes account))+  ServiceAccountsRotateSecret cid -> do+    (account, secret) <- rotateSecretAction env cid+    putStrLn ("client_id:     " <> Text.unpack (saClientId account))+    putStrLn ("client_secret: " <> Text.unpack secret <> "  (shown once; the previous secret no longer works)")+  ServiceAccountsRevoke cid -> do+    account <- revokeAction env cid+    putStrLn ("revoked " <> Text.unpack (saClientId account))+    -- Access tokens are stateless JWTs: one minted a moment ago stays valid until it expires.+    putStrLn "note: tokens already issued to this account remain valid until they expire (default 5 minutes)"+  ServiceAccountsList -> do+    accounts <- listAction env+    forM_ accounts \a ->+      putStrLn+        ( Text.unpack (saClientId a)+            <> "  "+            <> renderStatus (saStatus a)+            <> "  "+            <> Text.unpack (saDisplayName a)+            <> "  scopes=["+            <> renderScopes (saAllowedScopes a)+            <> "]  created="+            <> show (saCreatedAt a)+            <> maybe "" (\t -> "  rotated=" <> show t) (saRotatedAt a)+        )++-- | Resolve a @client_id@ or exit 1. Every mutating subcommand names an account this way, so a+-- typo fails loudly instead of silently updating zero rows.+requireAccount :: AdminEnv -> Text -> IO ServiceAccount+requireAccount env cid = do+  found <- runOrDie env.pool (findServiceAccountByClientId cid)+  maybe (die ("no service account with client_id " <> Text.unpack cid)) pure found++renderStatus :: ServiceAccountStatus -> String+renderStatus = \case+  ServiceAccountActive -> "active "+  ServiceAccountRevoked -> "revoked"++renderScopes :: Set Scope -> String+renderScopes scopes = Text.unpack (Text.unwords [s | Scope s <- Set.toList scopes])++-- | Scopes are trimmed and must be non-blank; a scope containing whitespace could never be+-- expressed in the space-delimited OAuth2 @scope@ parameter.+parseScopes :: [Text] -> IO (Set Scope)+parseScopes raws = Set.fromList <$> traverse one raws+  where+    one raw =+      let trimmed = Text.strip raw+       in if Text.null trimmed || Text.any (== ' ') trimmed+            then die "invalid scope (must be non-blank, contain no spaces, and have at most 128 characters)"+            else pure (Scope trimmed)++-- | The minimal chain these commands need, mirroring @Shomei.Admin.Roles.runRolesEff@.+-- @UserStore@ is present because @create@ provisions the account's backing user row.+runServiceAccountsEff ::+  Pool ->+  Eff '[UserStore, ServiceAccountStore, AuthEventPublisher, Clock, Database, Error AuthError, IOE] a ->+  IO (Either AuthError a)+runServiceAccountsEff pool =+  runEff+    . runErrorNoCallStack+    . runDatabasePool pool+    . runClockIO+    . runAuthEventPublisherPostgres+    . runServiceAccountStorePostgres+    . runUserStorePostgres++runOrDie ::+  Pool ->+  Eff '[UserStore, ServiceAccountStore, AuthEventPublisher, Clock, Database, Error AuthError, IOE] a ->+  IO a+runOrDie pool act = do+  res <- runServiceAccountsEff pool act+  either (\e -> die ("database error: " <> show e)) pure res++die :: String -> IO a+die msg = hPutStrLn stderr ("shomei-admin: " <> msg) >> exitFailure
+ app/Shomei/Admin/Sweep.hs view
@@ -0,0 +1,132 @@+-- | @shomei-admin sweep@: delete expired and dead rows once, then exit.+--+-- The standalone server already runs this sweep on a background thread (see+-- @Shomei.Server.Boot.installSweeper@), which is the turnkey default. This subcommand exists+-- for operators who would rather schedule maintenance externally — a cron entry, a Kubernetes+-- CronJob — and who then set @SHOMEI_SWEEP_ENABLED=false@ on the server. Both triggers call+-- the same 'sweepOnce', so there is one implementation and two ways to fire it. Running both+-- concurrently is harmless: every delete is idempotent and a batch simply finds fewer rows.+--+-- @+-- shomei-admin sweep [--batch-size N] [--dead-session-grace-days N] [--one-time-token-grace-days N]+--                    [--ceremony-grace-minutes N] [--login-attempt-retention-days N]+--                    [--auth-event-retention-days N]+-- @+--+-- Exits 0 with one @table: count@ line per swept table, or 1 with the database error.+module Shomei.Admin.Sweep+  ( SweepOptions (..),+    defaultSweepOptions,+    sweepParser,+    sweepOptionsToConfig,+    runSweep,+    runSweepReport,+  )+where++import Data.Text qualified as Text+import Data.Time (getCurrentTime)+import Options.Applicative+import Shomei.Admin.Env (AdminEnv (..))+import Shomei.Error (AuthError)+import Shomei.Persistence.Maintenance.Postgres+  ( SweepConfig (..),+    SweepReport,+    defaultSweepConfig,+    sweepOnce,+    sweepReportCounts,+  )+import System.Exit (exitFailure)+import System.IO (hPutStrLn, stderr)++-- | The sweep knobs as they arrive from the command line. Defaults match+-- 'defaultSweepConfig', so a bare @shomei-admin sweep@ behaves exactly like one cycle of the+-- server's background sweeper.+data SweepOptions = SweepOptions+  { optBatchSize :: !Int,+    optDeadSessionGraceDays :: !Int,+    optOneTimeTokenGraceDays :: !Int,+    optCeremonyGraceMinutes :: !Int,+    optLoginAttemptRetentionDays :: !Int,+    -- | Absent retains the audit trail forever, which is the default.+    optAuthEventRetentionDays :: !(Maybe Int)+  }++-- | A bare @shomei-admin sweep@ with no flags, i.e. one cycle of the server's background+-- sweeper. The parser's flag defaults are taken from here.+defaultSweepOptions :: SweepOptions+defaultSweepOptions =+  SweepOptions+    { optBatchSize = defaultSweepConfig.batchSize,+      optDeadSessionGraceDays = defaultSweepConfig.deadSessionGraceDays,+      optOneTimeTokenGraceDays = defaultSweepConfig.oneTimeTokenGraceDays,+      optCeremonyGraceMinutes = defaultSweepConfig.ceremonyGraceMinutes,+      optLoginAttemptRetentionDays = defaultSweepConfig.loginAttemptRetentionDays,+      optAuthEventRetentionDays = defaultSweepConfig.authEventRetentionDays+    }++sweepParser :: Parser SweepOptions+sweepParser =+  SweepOptions+    <$> intOpt "batch-size" defaultSweepOptions.optBatchSize "Rows per DELETE (sessions per DELETE, for refresh tokens)"+    <*> intOpt "dead-session-grace-days" defaultSweepOptions.optDeadSessionGraceDays "Grace before an expired or revoked session and its refresh-token family are deleted"+    <*> intOpt "one-time-token-grace-days" defaultSweepOptions.optOneTimeTokenGraceDays "Grace before expired verification/reset tokens and elapsed lockouts are deleted"+    <*> intOpt "ceremony-grace-minutes" defaultSweepOptions.optCeremonyGraceMinutes "Grace before expired WebAuthn ceremonies are deleted"+    <*> intOpt "login-attempt-retention-days" defaultSweepOptions.optLoginAttemptRetentionDays "Maximum age of login-attempt rows"+    <*> optional+      ( option+          auto+          ( long "auth-event-retention-days"+              <> metavar "N"+              <> help "Maximum age of audit events. Omit to retain the audit trail forever (the default)."+          )+      )+  where+    intOpt name def helpText =+      option+        auto+        (long name <> metavar "N" <> value def <> showDefault <> help helpText)++sweepOptionsToConfig :: SweepOptions -> SweepConfig+sweepOptionsToConfig o =+  SweepConfig+    { batchSize = o.optBatchSize,+      deadSessionGraceDays = o.optDeadSessionGraceDays,+      oneTimeTokenGraceDays = o.optOneTimeTokenGraceDays,+      ceremonyGraceMinutes = o.optCeremonyGraceMinutes,+      loginAttemptRetentionDays = o.optLoginAttemptRetentionDays,+      authEventRetentionDays = o.optAuthEventRetentionDays+    }++-- | Run one sweep against the admin pool and hand back the report. Separated from 'runSweep'+-- so tests can assert on the counts without capturing stdout or catching @exitFailure@.+runSweepReport :: AdminEnv -> SweepOptions -> IO (Either AuthError SweepReport)+runSweepReport env opts = do+  now <- getCurrentTime+  sweepOnce env.pool (sweepOptionsToConfig opts) now++-- | Sweep once, print the per-table counts, and exit non-zero if the database was unreachable.+runSweep :: AdminEnv -> SweepOptions -> IO ()+runSweep env opts =+  runSweepReport env opts >>= \case+    Left err -> do+      hPutStrLn stderr ("shomei-admin: sweep failed: " <> show err)+      exitFailure+    Right report -> putStr (renderReport opts.optAuthEventRetentionDays report)++-- | Aligned @table: count@ lines. The audit row is annotated when retention is off, so an+-- operator reading @auth_events: 0@ is never left wondering whether the sweep tried and found+-- nothing or was never asked to look.+renderReport :: Maybe Int -> SweepReport -> String+renderReport authEventRetention report =+  unlines [line table deleted | (table, deleted) <- counts]+  where+    counts = sweepReportCounts report+    width = maximum [Text.length table | (table, _) <- counts] + 2+    line table deleted =+      let label = Text.unpack table <> ":"+          padded = label <> replicate (width - length label) ' '+          suffix+            | table == "auth_events", Nothing <- authEventRetention = " (retention disabled)"+            | otherwise = ""+       in padded <> show deleted <> suffix
+ app/Shomei/Admin/Users.hs view
@@ -0,0 +1,184 @@+-- | @shomei-admin users create@ (EP-4, M3): seed a user account without the HTTP API by+-- driving the existing 'Shomei.Session.Authentication.Workflow.signup' through the full PostgreSQL interpreter stack+-- (with a trivial 'TokenSigner' fake — the CLI does not need a real access token).+module Shomei.Admin.Users+  ( createUserAction,+  )+where++import Control.Monad (when)+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as Text+import Effectful (Eff, IOE, runEff)+import Effectful.Dispatch.Dynamic (interpret_)+import Effectful.Error.Static (Error, runErrorNoCallStack)+import Network.HTTP.Client (Manager)+import Network.HTTP.Client.TLS (newTlsManager)+import Shomei.Account.Credential.Postgres (runCredentialStorePostgres)+import Shomei.Account.Credential.Store (CredentialStore)+import Shomei.Account.Email.Domain (mkEmail)+import Shomei.Account.LoginId.Domain (loginIdText, mkLoginId)+import Shomei.Account.Password.Breach.Store (PasswordBreachChecker)+import Shomei.Account.Password.Domain (PasswordPolicy (..), PlainPassword (..))+import Shomei.Account.Password.Hash.Postgres (Argon2Params, HashingLimiter, newHashingLimiter, runPasswordHasherCrypto, runTokenGenCrypto)+import Shomei.Account.Password.Hash.Store (PasswordHasher)+import Shomei.Account.User.Domain (User (..))+import Shomei.Account.User.Postgres (runUserStorePostgres)+import Shomei.Account.User.Store (UserStore, markUserEmailVerified)+import Shomei.Admin.Env (AdminEnv (..))+import Shomei.Audit.Publisher.Postgres (runAuthEventPublisherPostgres)+import Shomei.Audit.Publisher.Store (AuthEventPublisher)+import Shomei.Authorization.Claims.Domain (Role (..))+import Shomei.Authorization.Claims.Store (ClaimsEnricher, runClaimsEnricherNull)+import Shomei.Authorization.Role.Postgres (runRoleStorePostgres)+import Shomei.Authorization.Role.Store (RoleStore)+import Shomei.Authorization.Role.Workflow (undefinedDefaultRoles)+import Shomei.Config (ShomeiConfig (..))+import Shomei.Error (AuthError)+import Shomei.Id (UserId)+import Shomei.OAuth.IdToken.Domain (IdToken (..))+import Shomei.Persistence.Database.Postgres (Database, runDatabasePool)+import Shomei.Persistence.Pool.Postgres (Pool)+import Shomei.Server.BreachChecker (runPasswordBreachCheckerHibp)+import Shomei.Session.Authentication.Workflow (signup)+import Shomei.Session.Command (SignupCommand (..))+import Shomei.Session.Token.Domain (AccessToken (..))+import Shomei.Session.Token.Generator (TokenGen)+import Shomei.Session.UnitOfWork.Postgres (runAuthUnitOfWorkPostgres)+import Shomei.Session.UnitOfWork.Store (AuthUnitOfWork)+import Shomei.SigningKey.Signer (TokenSigner (..))+import Shomei.Time.Postgres (runClockIO)+import Shomei.Time.Store (Clock, now)+import System.Exit (exitFailure)+import System.IO (hPutStrLn, stderr)++createUserAction :: AdminEnv -> Text -> PlainPassword -> Maybe Text -> Bool -> IO ()+createUserAction env emailArg password mDisplay verified = do+  email <- either (\e -> die ("invalid email: " <> show e)) pure (mkEmail emailArg)+  loginId <- either (\e -> die ("invalid login id: " <> show e)) pure (mkLoginId emailArg)+  -- The server validates 'defaultRoles' against the registry at boot; the CLI has no boot, so it+  -- checks here. Without this, a typo in SHOMEI_DEFAULT_ROLES surfaces as a raw foreign-key+  -- violation from deep inside 'signup', after the user row has already been written.+  checkDefaultRoles env+  let cmd =+        SignupCommand+          { loginId = loginId,+            email = Just email,+            password = password,+            displayName = mDisplay+          }+  -- The CLI hashes exactly one password, so a limiter of one is right and costs nothing.+  limiter <- newHashingLimiter 1+  manager <- newTlsManager+  outcome <-+    runSignup+      env.pool+      limiter+      env.argon2+      manager+      env.config.passwordPolicy.breachCheckTimeoutMs+      (signup env.config cmd)+  case outcome of+    Left infra -> die ("infrastructure error: " <> show infra)+    Right (Left rejected) -> die ("signup rejected: " <> show rejected)+    Right (Right (user, _)) -> do+      when verified do+        verifiedResult <- runMarkEmailVerified env.pool user.userId+        either (die . ("could not mark email verified: " <>) . show) pure verifiedResult+      putStrLn+        ( "created user "+            <> show user.userId+            <> " <"+            <> Text.unpack (loginIdText user.loginId)+            <> ">"+            <> if verified then " (email verified)" else ""+        )++-- | Run a 'signup' over the PostgreSQL interpreters, with a fake signer.+--+-- 'signup' applies @config.defaultRoles@ (reading the real 'RoleStore' and auditing each grant+-- through the real publisher), so a user created here receives exactly the roles an HTTP signup+-- would — no special-casing. 'ClaimsEnricher' is the null interpreter because the token this+-- path mints is the discarded fake one.+runSignup ::+  Pool ->+  HashingLimiter ->+  Argon2Params ->+  Manager ->+  Int ->+  Eff+    [ UserStore,+      RoleStore,+      CredentialStore,+      AuthUnitOfWork,+      PasswordBreachChecker,+      PasswordHasher,+      TokenSigner,+      ClaimsEnricher,+      AuthEventPublisher,+      Clock,+      TokenGen,+      Database,+      Error AuthError,+      IOE+    ]+    a ->+  IO (Either AuthError a)+runSignup pool limiter argon2 manager breachTimeoutMs =+  runEff+    . runErrorNoCallStack+    . runDatabasePool pool+    . runTokenGenCrypto+    . runClockIO+    . runAuthEventPublisherPostgres+    . runClaimsEnricherNull+    . runTokenSignerFake+    . runPasswordHasherCrypto limiter argon2+    . runPasswordBreachCheckerHibp manager breachTimeoutMs+    . runAuthUnitOfWorkPostgres+    . runCredentialStorePostgres+    . runRoleStorePostgres+    . runUserStorePostgres++-- | Refuse to create a user when @SHOMEI_DEFAULT_ROLES@ names a role missing from the registry,+-- with the same message the server prints at boot.+checkDefaultRoles :: AdminEnv -> IO ()+checkDefaultRoles env+  | Set.null env.config.defaultRoles = pure ()+  | otherwise = do+      outcome <-+        runEff+          . runErrorNoCallStack @AuthError+          . runDatabasePool env.pool+          . runRoleStorePostgres+          $ undefinedDefaultRoles env.config+      case outcome of+        Left e -> die ("could not validate defaultRoles: " <> show e)+        Right missing+          | Set.null missing -> pure ()+          | otherwise ->+              die+                ( "SHOMEI_DEFAULT_ROLES names undefined roles: "+                    <> Text.unpack (Text.intercalate ", " [r | Role r <- Set.toList missing])+                    <> " (define them first: shomei-admin roles define <name>)"+                )++runTokenSignerFake :: Eff (TokenSigner : es) a -> Eff es a+runTokenSignerFake = interpret_ \case+  SignAccessToken _ -> pure (AccessToken "admin-cli-token")+  SignIdToken _ -> pure (IdToken "admin-cli-id-token")++runMarkEmailVerified :: Pool -> UserId -> IO (Either AuthError ())+runMarkEmailVerified pool uid =+  runEff+    . runErrorNoCallStack+    . runDatabasePool pool+    . runClockIO+    . runUserStorePostgres+    $ do+      ts <- now+      markUserEmailVerified uid ts++die :: String -> IO a+die msg = hPutStrLn stderr ("shomei-admin: " <> msg) >> exitFailure
+ review-load/Main.hs view
@@ -0,0 +1,315 @@+{-# LANGUAGE ScopedTypeVariables #-}++-- | Isolated MasterPlan 9 workload. No caller-supplied database or HTTP target is accepted.+module Main (main) where++import Control.Concurrent (forkIO, killThread)+import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)+import Control.Exception (SomeException, bracket, throwIO, try)+import Control.Monad (forM, forM_, replicateM_, unless, void)+import Data.Aeson (Value (..), eitherDecode, encode, object, (.=))+import Data.Aeson.Key qualified as Key+import Data.Aeson.KeyMap qualified as KM+import Data.ByteString qualified as BS+import Data.ByteString.Char8 qualified as BS8+import Data.ByteString.Lazy qualified as LBS+import Data.Foldable (toList)+import Data.IORef (newIORef)+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.Encoding qualified as Text+import Data.UUID qualified as UUID+import GHC.Clock (getMonotonicTimeNSec)+import Hasql.Decoders qualified as D+import Hasql.Encoders qualified as E+import Hasql.Session qualified as Session+import Hasql.Statement (preparable)+import Network.HTTP.Client qualified as HTTP+import Network.HTTP.Types (Header, statusCode, urlEncode)+import Network.Wai.Handler.Warp qualified as Warp+import Servant.Health (ProbeVerdict (Healthy))+import Shomei.Account.Password.Hash.Postgres (Argon2Params (..), defaultArgon2Params, newHashingLimiter)+import Shomei.Authorization.Claims.Domain (Audience (..), Issuer (..))+import Shomei.Config (ObservabilityConfig (..), RateLimitConfig (..), ShomeiConfig (..), defaultShomeiConfig)+import Shomei.Id (UserId, genUserId, idText, parseId, userIdToUUID)+import Shomei.Mfa.Totp.Postgres (totpEncryptionKeyFromBytes)+import Shomei.Migrations.TestSupport (withShomeiMigratedDatabase)+import Shomei.Notify (noNotifierSecrets)+import Shomei.Notify.Queue (newNotifierQueue)+import Shomei.Persistence.Database.Postgres (defaultTransactionRetryPolicy)+import Shomei.Persistence.Pool.Postgres (Pool, acquirePool)+import Shomei.Persistence.Pool.Postgres qualified as Pool+import Shomei.Servant.Api (shomeiThrottledRoutes)+import Shomei.Servant.CachedJson (cachedJsonBytes)+import Shomei.Servant.OpenApi (openApiDocument)+import Shomei.Server.App (Env (..))+import Shomei.Server.Boot (application, hostMiddleware)+import Shomei.Server.Config (ProxyProtocolMode (..), ServerSettings (..), defaultSweepSettings)+import Shomei.Server.Keys (bootstrapKeys)+import Shomei.Server.Middleware.RateLimit (newRateLimiterFor)+import Shomei.Server.Middleware.TrustedProxy (emptyTrustedProxies)+import Shomei.Server.Observability.Metrics (newMetrics)+import Shomei.Server.Runtime (hostWarpSettings)+import Shomei.SigningKey.Domain (SigningAlgorithm (ES256))+import Shomei.SigningKey.Protection.Jwt (keyEncryptionKeyFromBase64)+import System.Directory (getTemporaryDirectory, removeFile)+import System.Environment (getArgs, setEnv)+import System.Exit (ExitCode (ExitSuccess), exitFailure)+import System.IO (hClose, hPutStrLn, openBinaryTempFile, stderr)+import System.Mem (performGC)+import System.Posix.Process (getProcessID)+import System.Process (readProcess, readProcessWithExitCode)+import System.Timeout (timeout)+import Text.Read (readMaybe)++main :: IO ()+main = do+  args <- getArgs+  (scenario, output) <- case args of+    ["--scenario", s, "--output", out] | s `elem` ["all", "sessions", "openapi", "argon2"] -> pure (s, out)+    _ -> hPutStrLn stderr "expected --scenario all|sessions|openapi|argon2 --output PATH; external targets are refused" >> exitFailure+  result <- timeout 180000000 (try @SomeException (workload scenario))+  case result of+    Just (Right report) -> LBS.writeFile output (encode report <> "\n")+    _ -> do+      LBS.writeFile output (encode (object ["scenario" .= scenario, "error_count" .= (1 :: Int), "result" .= ("failed_or_timed_out" :: Text)]) <> "\n")+      hPutStrLn stderr "isolated review workload failed; no credential-bearing exception is emitted"+      exitFailure++settings :: ServerSettings+settings =+  ServerSettings+    { serverPort = 0,+      serverBindHost = "127.0.0.1",+      serverMaxConnections = 1024,+      serverSlowClientTimeoutSeconds = 30,+      serverConnStr = "",+      serverTrustedProxies = emptyTrustedProxies,+      serverProxyProtocol = ProxyProtocolOff,+      serverDbPoolSize = 8,+      serverDbPoolAcquisitionTimeoutMs = 10000,+      serverDbStatementTimeoutMs = 30000,+      serverDbTransactionMaxAttempts = 3,+      serverDbTransactionDeadlineMs = 5000,+      serverNotifierQueueSize = 1024,+      serverWarnings = [],+      serverSweep = defaultSweepSettings,+      serverArgon2 = defaultArgon2Params,+      serverHashingMaxConcurrency = 2+    }++workload :: String -> IO Value+workload scenario = withShomeiMigratedDatabase \conn -> bracket (acquirePool 8 10 30000 conn) Pool.release \pool -> do+  started <- getMonotonicTimeNSec+  let base = defaultShomeiConfig (Issuer "review-fixture") (Audience "review-fixture")+      cfg = base {rateLimitConfig = base.rateLimitConfig {rateLimitEnabled = False}, observabilityConfig = base.observabilityConfig {requestLoggingEnabled = False, metricsEnabled = False}}+      kek = either (error . Text.unpack) id (keyEncryptionKeyFromBase64 "AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA=")+      totpKey = either (error . Text.unpack) id (totpEncryptionKeyFromBytes (BS.replicate 32 0))+  keys <- newIORef =<< bootstrapKeys kek ES256 pool+  manager <- HTTP.newManager (HTTP.managerSetProxy HTTP.noProxy HTTP.defaultManagerSettings {HTTP.managerResponseTimeout = HTTP.responseTimeoutMicro 5000000})+  hashing <- newHashingLimiter 2+  queue <- newNotifierQueue 1024+  limiter <- newRateLimiterFor shomeiThrottledRoutes cfg.rateLimitConfig+  metrics <- newMetrics+  runtime <- hostWarpSettings cfg settings Warp.defaultSettings+  let env =+        Env+          { envPool = pool,+            envDbRetryPolicy = defaultTransactionRetryPolicy,+            envConfig = cfg,+            envKeys = keys,+            envKek = kek,+            envHttpManager = manager,+            envNotifierSecrets = noNotifierSecrets,+            envNotifierQueue = queue,+            envArgon2Params = defaultArgon2Params,+            envHashingLimiter = hashing,+            envTotpKey = totpKey+          }+      app = hostMiddleware cfg settings limiter metrics (application env (pure Healthy) (pure Healthy))+  Warp.testWithApplicationSettings runtime (pure app) \port -> do+    let origin = "http://127.0.0.1:" <> show port+    hPutStrLn stderr "[review-load] session fixture and workload"+    sessions <- if scenario `elem` ["all", "sessions"] then sessionWork pool manager origin else pure Null+    hPutStrLn stderr "[review-load] repeated OpenAPI workload"+    openapi <- if scenario `elem` ["all", "openapi"] then openApiWork manager origin else pure Null+    hPutStrLn stderr "[review-load] bounded Argon2 workload"+    argon2 <- if scenario `elem` ["all", "argon2"] then argonWork origin else pure Null+    ended <- getMonotonicTimeNSec+    pure+      ( object+          [ "scenario" .= scenario,+            "target" .= ("isolated_loopback" :: Text),+            "error_count" .= (0 :: Int),+            "wall_ms" .= (fromIntegral (ended - started) / 1000000 :: Double),+            "configuration"+              .= object+                [ "argon2_memory_kib" .= defaultArgon2Params.memoryKiB,+                  "argon2_iterations" .= defaultArgon2Params.iterations,+                  "argon2_parallelism" .= defaultArgon2Params.parallelism,+                  "hashing_limit" .= (2 :: Int),+                  "rts_requested_capabilities" .= (2 :: Int),+                  "http_workers" .= (4 :: Int),+                  "rate_limit_enabled" .= False,+                  "max_connections" .= (1024 :: Int),+                  "total_deadline_seconds" .= (180 :: Int)+                ],+            "sessions" .= sessions,+            "openapi" .= openapi,+            "argon2" .= argon2+          ]+      )++failCheck :: Bool -> IO ()+failCheck condition = unless condition (ioError (userError "fixed workload acceptance failed"))++checked :: Either e a -> IO a+checked = either (const (ioError (userError "isolated fixture operation failed"))) pure++exec :: Pool -> Text -> IO ()+exec pool sql = checked =<< Pool.use pool (Session.script sql)++scalar :: Pool -> Text -> IO Int+scalar pool sql = fromIntegral <$> (checked =<< Pool.use pool (Session.statement () (preparable sql E.noParams (D.singleRow (D.column (D.nonNullable D.int8))))))++request :: HTTP.Manager -> String -> BS.ByteString -> [Header] -> Maybe Value -> IO (HTTP.Response LBS.ByteString)+request manager url method headers body = do+  req <- HTTP.parseRequest url+  HTTP.httpLbs+    req+      { HTTP.method = method,+        HTTP.requestHeaders = headers,+        HTTP.redirectCount = 0,+        HTTP.requestBody = maybe (HTTP.RequestBodyBS BS.empty) (HTTP.RequestBodyLBS . encode) body+      }+    manager++textAt :: [Text] -> Value -> IO Text+textAt [] (String text) = pure text+textAt (field : rest) (Object fields) = maybe (checked (Left ())) (textAt rest) (KM.lookup (Key.fromText field) fields)+textAt _ _ = checked (Left ())++sessionWork :: Pool -> HTTP.Manager -> String -> IO Value+sessionWork pool manager origin = do+  let password = "review-fixture-correct-horse-42" :: Text+      json = [("Content-Type", "application/json")]+  signup <- request manager (origin <> "/v1/auth/signup") "POST" json (Just (object ["loginId" .= ("review-admin" :: Text), "password" .= password, "displayName" .= ("Review" :: Text)]))+  failCheck (statusCode (HTTP.responseStatus signup) == 201)+  doc <- checked (eitherDecode (HTTP.responseBody signup))+  uidText <- textAt ["user", "userId"] doc+  uid :: UserId <- checked (parseId uidText)+  let uidSql = "'" <> UUID.toText (userIdToUUID uid) <> "'"+  exec pool ("INSERT INTO shomei.shomei_role_grants(user_id,role,granted_at) VALUES(" <> uidSql <> ",'admin',now())")+  login <- request manager (origin <> "/v1/auth/login") "POST" json (Just (object ["loginId" .= ("review-admin" :: Text), "password" .= password]))+  failCheck (statusCode (HTTP.responseStatus login) == 200)+  loginDoc <- checked (eitherDecode (HTTP.responseBody login))+  token <- textAt ["token", "accessToken"] loginDoc+  target <- genUserId+  let targetSql = "'" <> UUID.toText (userIdToUUID target) <> "'"+      headers = [("Authorization", "Bearer " <> Text.encodeUtf8 token)]+      path = origin <> "/v1/admin/users/" <> Text.unpack (idText target) <> "/sessions"+  exec pool ("INSERT INTO shomei.shomei_users(user_id,login_id,status,created_at,updated_at) VALUES(" <> targetSql <> ",'review-target','active',now(),now()); INSERT INTO shomei.shomei_sessions(session_id,user_id,status,kind,created_at,expires_at) SELECT gen_random_uuid()," <> targetSql <> ",'active','interactive',now(),now()+interval '1 day' FROM generate_series(1,10000)")+  started <- getMonotonicTimeNSec+  let walk cursor ids pages = do+        failCheck (pages < 64)+        let suffix = maybe "" (\value -> "&before=" <> BS8.unpack (urlEncode True (Text.encodeUtf8 value))) cursor+        response <- request manager (path <> "?limit=200" <> suffix) "GET" headers Nothing+        failCheck (statusCode (HTTP.responseStatus response) == 200)+        page <- checked (eitherDecode (HTTP.responseBody response))+        values <- case page of+          Object fields | Just (Array rows) <- KM.lookup "sessions" fields -> traverse (textAt ["sessionId"]) (toList rows)+          _ -> checked (Left ())+        failCheck (length values <= 200 && Set.size (Set.fromList values) == length values && Set.null (Set.intersection ids (Set.fromList values)))+        let nextIds = Set.union ids (Set.fromList values)+            next = case page of+              Object fields -> case KM.lookup "nextCursor" fields of+                Just (String c) -> Just c+                _ -> Nothing+              _ -> Nothing+        case next of+          Nothing -> pure (Set.size nextIds, pages + 1)+          Just c -> walk (Just c) nextIds (pages + 1)+  (total, pages) <- walk Nothing Set.empty (0 :: Int)+  failCheck (total == 10000 && pages == 51)+  revoked <- request manager path "DELETE" headers Nothing+  failCheck (statusCode (HTTP.responseStatus revoked) == 204)+  count <- scalar pool ("SELECT count(*) FROM shomei.shomei_sessions WHERE user_id=" <> targetSql <> " AND status='revoked'")+  audits <- scalar pool "SELECT count(*) FROM shomei.shomei_auth_events WHERE event_type='session_revoked'"+  failCheck (count == 10000 && audits == 10000)+  ended <- getMonotonicTimeNSec+  pure+    ( object+        [ "fixture_sessions" .= total,+          "page_size" .= (200 :: Int),+          "pages" .= pages,+          "revoked" .= count,+          "audit_events" .= audits,+          "old_unbounded_page_rows" .= (10000 :: Int),+          "current_max_page_rows" .= (200 :: Int),+          "bulk_unit_of_work_contract_calls" .= (1 :: Int),+          "wall_ms" .= (fromIntegral (ended - started) / 1000000 :: Double)+        ]+    )++parallel :: [IO a] -> IO [a]+parallel actions =+  bracket+    ( forM actions \action -> do+        done <- newEmptyMVar+        worker <- forkIO (try @SomeException action >>= putMVar done)+        pure (worker, done)+    )+    (mapM_ (killThread . fst))+    (traverse (\(_, done) -> takeMVar done >>= either throwIO pure))++rssKiB :: IO Int+rssKiB = do+  performGC+  pid <- getProcessID+  raw <- readProcess "ps" ["-o", "rss=", "-p", show pid] ""+  maybe (checked (Left ())) pure (readMaybe raw)++openApiWork :: HTTP.Manager -> String -> IO Value+openApiWork manager origin = do+  let expected = cachedJsonBytes openApiDocument+      one = do+        response <- request manager (origin <> "/openapi.json") "GET" [] Nothing+        failCheck (statusCode (HTTP.responseStatus response) == 200 && HTTP.responseBody response == expected)+  one+  warm <- rssKiB+  started <- getMonotonicTimeNSec+  samples <- forM [1 .. 4 :: Int] \_ -> do+    void (parallel [replicateM_ count one | count <- [63, 63, 62, 62]])+    rssKiB+  ended <- getMonotonicTimeNSec+  -- Same process includes the bounded load generator. A fixed generous noise allowance+  -- catches retention proportional to 1000 document copies without treating RSS as exact.+  failCheck (maximum samples - warm < 32768)+  pure+    ( object+        [ "requests" .= (1000 :: Int),+          "workers" .= (4 :: Int),+          "error_count" .= (0 :: Int),+          "wire_bytes_per_response" .= LBS.length expected,+          "warm_rss_kib" .= warm,+          "batch_rss_kib" .= samples,+          "memory_growth_allowance_kib" .= (32768 :: Int),+          "observer_shares_process" .= True,+          "wall_ms" .= (fromIntegral (ended - started) / 1000000 :: Double)+        ]+    )++argonWork :: String -> IO Value+argonWork origin = bracket create removeFile \path -> do+  pid <- getProcessID+  forM_ [("LOAD_USERS", "4"), ("PROBE_COUNT", "100"), ("LOAD_SECONDS", "10"), ("SIGNUP_LOOPS", "0"), ("SERVER_PID", show pid), ("LOAD_JSON_OUTPUT", path)] (uncurry setEnv)+  (code, _, _) <- readProcessWithExitCode "sh" ["scripts/argon2-load-test.sh", origin] ""+  failCheck (code == ExitSuccess)+  checked . eitherDecode =<< LBS.readFile path+  where+    create = do+      directory <- getTemporaryDirectory+      (path, handle) <- openBinaryTempFile directory "shomei-review-argon2.json"+      hClose handle+      pure path
+ shomei-server.cabal view
@@ -0,0 +1,353 @@+cabal-version: 3.0+name: shomei-server+version: 0.3.0.0+synopsis: Standalone Shōmei authentication service+description:+  The standalone deployment of Shōmei: a warp executable that serves ShomeiAPI+  against PostgreSQL, the WAI middleware stack (structured logging, Prometheus+  metrics, rate limiting, body limits), health and readiness probes, the+  environment-driven config loader, signing-key bootstrap and rotation, and+  breach-password checking. Also ships shomei-admin, an operations CLI for+  user administration and zero-downtime signing-key rotation. Other services+  verify its tokens by fetching its published JWKS.++homepage: https://github.com/shinzui/shomei+bug-reports: https://github.com/shinzui/shomei/issues+license: MIT+license-file: LICENSE+author: Nadeem Bitar+maintainer: nadeem@gmail.com+copyright: 2026 Nadeem Bitar+category: Web, Security+tested-with: ghc ==9.12.4+extra-doc-files: CHANGELOG.md++source-repository head+  type: git+  location: https://github.com/shinzui/shomei.git++flag review-load+  description: Build the isolated remediation workload tool (excluded from production builds).+  default: False+  manual: True++common warnings+  ghc-options:+    -Wall+    -Wcompat+    -Widentities+    -Wincomplete-record-updates+    -Wincomplete-uni-patterns+    -Wpartial-fields+    -Wredundant-constraints++common shared+  default-language: GHC2024+  default-extensions:+    BlockArguments+    DataKinds+    DeriveAnyClass+    DuplicateRecordFields+    LambdaCase+    MultilineStrings+    OverloadedLabels+    OverloadedRecordDot+    OverloadedStrings+    QualifiedDo+    TemplateHaskell+    TypeApplications+    TypeFamilies+    TypeOperators++library+  import: warnings, shared+  hs-source-dirs: src+  exposed-modules:+    Shomei.Health.Server+    Shomei.Notify+    Shomei.Notify.Queue+    Shomei.Server.App+    Shomei.Server.Boot+    Shomei.Server.BreachChecker+    Shomei.Server.Config+    Shomei.Server.DatabaseError+    Shomei.Server.ExceptionResponse+    Shomei.Server.Keys+    Shomei.Server.Middleware.BodyLimit+    Shomei.Server.Middleware.RateLimit+    Shomei.Server.Middleware.TrustedProxy+    Shomei.Server.Observability.Logging+    Shomei.Server.Observability.Metrics+    Shomei.Server.Runtime+    Shomei.Server.Supervisor++  build-depends:+    aeson >=2.1 && <2.3,+    base >=4.18 && <5,+    bytestring >=0.11 && <0.13,+    containers >=0.6 && <0.9,+    crypton >=1.1 && <1.2,+    effectful >=2.5 && <2.8,+    effectful-core >=2.5 && <2.8,+    hasql >=1.10 && <1.11,+    http-client >=0.7 && <0.8,+    http-client-tls >=0.3 && <0.5,+    http-types >=0.12 && <0.13,+    iproute >=1.7.8 && <1.8,+    jose >=0.13 && <0.14,+    mime-mail >=0.5 && <0.6,+    network >=3.1 && <3.3,+    pg-migrate >=1.2 && <1.3,+    process >=1.6 && <1.7,+    ram >=0.22 && <0.23,+    servant-health >=0.1 && <0.2,+    servant-server >=0.20.3 && <0.21,+    shomei-core ^>=0.3.0.0,+    shomei-jwt ^>=0.3.0.0,+    shomei-migrations ^>=0.2.0.1,+    shomei-postgres ^>=0.3.0.0,+    shomei-servant ^>=0.3.0.0,+    shomei-webauthn ^>=0.3.0.0,+    smtp-mail >=0.5.0.2 && <0.6,+    stm >=2.5 && <2.6,+    text >=2.0 && <2.2,+    time >=1.12 && <1.15,+    unix >=2.8 && <2.9,+    unordered-containers >=0.2 && <0.3,+    uuid >=1.3 && <1.4,+    wai >=3.2 && <3.3,+    warp >=3.3 && <3.5,++executable shomei-server+  import: warnings, shared+  hs-source-dirs: app+  main-is: Main.hs+  ghc-options:+    -threaded+    -rtsopts+    -with-rtsopts=-N++  build-depends:+    base >=4.18 && <5,+    shomei-server ^>=0.3.0.0,++-- EP-4: the operational CLI. A second executable in this package (MasterPlan 2 default;+-- avoids registering a new mori.dhall package). It reuses the same pool/config/key/interpreter+-- assembly the server uses, but needs no servant/wai.+executable shomei-admin+  import: warnings, shared+  hs-source-dirs: app+  main-is: Admin.hs+  ghc-options:+    -threaded+    -rtsopts+    -with-rtsopts=-N++  other-modules:+    Shomei.Admin.Audit+    Shomei.Admin.Env+    Shomei.Admin.Keys+    Shomei.Admin.OAuthClients+    Shomei.Admin.Roles+    Shomei.Admin.ServiceAccounts+    Shomei.Admin.Sweep+    Shomei.Admin.Users++  build-depends:+    aeson >=2.1 && <2.3,+    base >=4.18 && <5,+    bytestring >=0.11 && <0.13,+    containers >=0.6 && <0.9,+    contravariant-extras >=0.3 && <0.4,+    effectful >=2.5 && <2.8,+    effectful-core >=2.5 && <2.8,+    hasql >=1.10 && <1.11,+    http-client >=0.7 && <0.8,+    http-client-tls >=0.3 && <0.5,+    optparse-applicative >=0.19 && <0.20,+    pg-migrate >=1.2 && <1.3,+    shomei-core ^>=0.3.0.0,+    shomei-jwt ^>=0.3.0.0,+    shomei-migrations ^>=0.2.0.1,+    shomei-postgres ^>=0.3.0.0,+    shomei-server ^>=0.3.0.0,+    text >=2.0 && <2.2,+    time >=1.12 && <1.15,+    uuid >=1.3 && <1.4,++test-suite shomei-server-config-test+  import: warnings, shared+  type: exitcode-stdio-1.0+  hs-source-dirs: test+  main-is: Shomei/Server/ConfigSpec.hs+  ghc-options:+    -threaded+    -rtsopts+    -with-rtsopts=-N++  build-depends:+    aeson >=2.1 && <2.3,+    base >=4.18 && <5,+    bytestring >=0.11 && <0.13,+    containers >=0.6 && <0.9,+    directory >=1.3 && <1.4,+    process >=1.6 && <1.7,+    shomei-core ^>=0.3.0.0,+    shomei-postgres ^>=0.3.0.0,+    shomei-server ^>=0.3.0.0,+    tasty >=1.4 && <1.6,+    tasty-hunit >=0.10 && <0.11,+    text >=2.0 && <2.2,++test-suite shomei-admin-test+  import: warnings, shared+  type: exitcode-stdio-1.0+  hs-source-dirs:+    app+    test++  main-is: Admin/Main.hs+  ghc-options:+    -threaded+    -rtsopts+    -with-rtsopts=-N++  other-modules:+    Shomei.Admin.Audit+    Shomei.Admin.Env+    Shomei.Admin.Keys+    Shomei.Admin.OAuthClients+    Shomei.Admin.Roles+    Shomei.Admin.ServiceAccounts+    Shomei.Admin.Sweep+    Shomei.Admin.Users++  build-depends:+    aeson >=2.1 && <2.3,+    base >=4.18 && <5,+    bytestring >=0.11 && <0.13,+    containers >=0.6 && <0.9,+    contravariant-extras >=0.3 && <0.4,+    effectful >=2.5 && <2.8,+    effectful-core >=2.5 && <2.8,+    hasql >=1.10 && <1.11,+    http-client >=0.7 && <0.8,+    http-client-tls >=0.3 && <0.5,+    jose >=0.13 && <0.14,+    optparse-applicative >=0.19 && <0.20,+    ram >=0.22 && <0.23,+    shomei-core ^>=0.3.0.0,+    shomei-jwt ^>=0.3.0.0,+    shomei-migrations ^>=0.2.0.1,+    shomei-migrations:test-support ^>=0.2.0.1,+    shomei-postgres ^>=0.3.0.0,+    shomei-server ^>=0.3.0.0,+    tasty >=1.4 && <1.6,+    tasty-hunit >=0.10 && <0.11,+    text >=2.0 && <2.2,+    time >=1.12 && <1.15,+    uuid >=1.3 && <1.4,++test-suite shomei-server-test+  import: warnings, shared+  type: exitcode-stdio-1.0+  hs-source-dirs: test+  main-is: Main.hs+  other-modules:+    Shomei.Server.E2ESpec+    Shomei.Server.MiddlewareSpec+    Shomei.Server.NotifySpec+    Shomei.Server.RuntimeSpec+    Shomei.Server.SupervisorSpec++  ghc-options:+    -threaded+    -rtsopts+    -with-rtsopts=-N++  build-depends:+    aeson >=2.1 && <2.3,+    base >=4.18 && <5,+    base64 >=1.0 && <1.1,+    bytestring >=0.11 && <0.13,+    containers >=0.6 && <0.9,+    directory >=1.3 && <1.4,+    effectful >=2.5 && <2.8,+    effectful-core >=2.5 && <2.8,+    hasql >=1.10 && <1.11,+    http-client >=0.7 && <0.8,+    http-types >=0.12 && <0.13,+    network >=3.1 && <3.3,+    servant-health >=0.1 && <0.2,+    servant-health:testkit,+    shomei-core ^>=0.3.0.0,+    shomei-jwt ^>=0.3.0.0,+    shomei-migrations:test-support ^>=0.2.0.1,+    shomei-postgres ^>=0.3.0.0,+    shomei-servant ^>=0.3.0.0,+    shomei-server ^>=0.3.0.0,+    tasty >=1.4 && <1.6,+    tasty-hunit >=0.10 && <0.11,+    text >=2.0 && <2.2,+    time >=1.12 && <1.15,+    wai >=3.2 && <3.3,+    warp >=3.3 && <3.5,++test-suite shomei-health-test+  import: warnings, shared+  type: exitcode-stdio-1.0+  hs-source-dirs: test-health+  main-is: Main.hs+  ghc-options:+    -threaded+    -rtsopts+    -with-rtsopts=-N++  build-depends:+    base >=4.18 && <5,+    bytestring >=0.11 && <0.13,+    http-client >=0.7 && <0.8,+    servant-health >=0.1 && <0.2,+    servant-health:testkit,+    shomei-core ^>=0.3.0.0,+    shomei-jwt ^>=0.3.0.0,+    shomei-migrations:test-support ^>=0.2.0.1,+    shomei-postgres ^>=0.3.0.0,+    shomei-server ^>=0.3.0.0,+    tasty >=1.4 && <1.6,+    tasty-hunit >=0.10 && <0.11,++-- Isolated acceptance driver; never accepts a deployment database or external HTTP target.+executable shomei-review-load+  import: warnings, shared+  hs-source-dirs: review-load+  main-is: Main.hs++  if !flag(review-load)+    buildable: False+  ghc-options:+    -threaded+    -rtsopts+    -with-rtsopts=-N2++  build-depends:+    aeson >=2.1 && <2.3,+    base >=4.18 && <5,+    bytestring >=0.11 && <0.13,+    containers >=0.6 && <0.9,+    directory >=1.3 && <1.4,+    hasql >=1.10 && <1.11,+    http-client >=0.7 && <0.8,+    http-types >=0.12 && <0.13,+    process >=1.6 && <1.7,+    servant-health >=0.1 && <0.2,+    shomei-core ^>=0.3.0.0,+    shomei-jwt ^>=0.3.0.0,+    shomei-migrations:test-support ^>=0.2.0.1,+    shomei-postgres ^>=0.3.0.0,+    shomei-servant ^>=0.3.0.0,+    shomei-server ^>=0.3.0.0,+    text >=2.0 && <2.2,+    unix >=2.8 && <2.9,+    uuid >=1.3 && <1.4,+    warp >=3.3 && <3.5,
+ src/Shomei/Health/Server.hs view
@@ -0,0 +1,85 @@+-- | Production liveness and readiness policy for the standalone service.+module Shomei.Health.Server+  ( HealthPolicy (..),+    defaultHealthPolicy,+    buildHealthChecks,+    buildHealthChecksWith,+  )+where++import Control.Concurrent.MVar (modifyMVar, newMVar)+import Data.Word (Word64)+import GHC.Clock (getMonotonicTimeNSec)+import Servant.Health (ProbeCheck)+import Servant.Health.Check+  ( boolCheck,+    newFailureTracker,+    safeCheck,+    sequenceChecks,+    withProbeTimeout,+  )+import Shomei.Error (AuthError)+import Shomei.Server.App (Env, runAppIO)+import Shomei.SigningKey.Domain (StoredSigningKey)+import Shomei.SigningKey.Store (listActiveSigningKeys)++data HealthPolicy = HealthPolicy+  { readinessTimeoutMicros :: !Int,+    readinessCacheMicros :: !Int+  }+  deriving stock (Eq, Show)++defaultHealthPolicy :: HealthPolicy+defaultHealthPolicy =+  HealthPolicy+    { readinessTimeoutMicros = 2_000_000,+      readinessCacheMicros = 1_000_000+    }++-- | Production checks backed by the standalone server's interpreter stack.+buildHealthChecks :: Env -> IO (ProbeCheck, ProbeCheck)+buildHealthChecks env = buildHealthChecksWith defaultHealthPolicy (runAppIO env listActiveSigningKeys)++-- | Construct the two tracked checks once at startup. The injected query is the service-owned+-- IO bridge for @listActiveSigningKeys@: a typed execution failure is reported as @postgres@,+-- while a successful empty result is reported as @signing-key@.+buildHealthChecksWith :: HealthPolicy -> IO (Either AuthError [StoredSigningKey]) -> IO (ProbeCheck, ProbeCheck)+buildHealthChecksWith policy runSigningKeyQuery = do+  trackLiveness <- newFailureTracker+  trackReadiness <- newFailureTracker+  cachedReadiness <-+    cachedFor policy.readinessCacheMicros+      . withProbeTimeout policy.readinessTimeoutMicros "postgres"+      . sequenceChecks+      $ [ safeCheck "postgres" do+            runSigningKeyQuery >>= \case+              Left _ -> boolCheck "postgres" (pure False)+              Right keys -> boolCheck "signing-key" (pure (not (null keys)))+        ]+  let liveness =+        trackLiveness+          . withProbeTimeout 2_000_000 "liveness"+          . safeCheck "liveness"+          $ boolCheck "liveness" (pure True)+      readiness = trackReadiness cachedReadiness+  pure (liveness, readiness)++-- | Cache one readiness verdict for a short monotonic-time window. Holding the MVar while the+-- check runs makes cache refresh single-flight: concurrent probes share one dependency query.+cachedFor :: Int -> ProbeCheck -> IO ProbeCheck+cachedFor micros check+  | micros <= 0 = pure check+  | otherwise = do+      cache <- newMVar Nothing+      let windowNanos = fromIntegral micros * 1_000 :: Word64+      pure $ modifyMVar cache \stored -> do+        now <- getMonotonicTimeNSec+        case stored of+          Just (observedAt, verdict)+            | now >= observedAt,+              now - observedAt < windowNanos ->+                pure (stored, verdict)+          _ -> do+            verdict <- check+            observedAt <- getMonotonicTimeNSec+            pure (Just (observedAt, verdict), verdict)
+ src/Shomei/Notify.hs view
@@ -0,0 +1,649 @@+-- | Notification interpreters for the standalone server.+--+-- The core defines the 'Notifier' effect and emits a 'Notification' (recipient, one-time+-- link/token, expiry); turning that into a delivered message is this module's job. It provides+-- three built-in interpreters, selected by 'runNotifierFromConfig' from the operator's+-- 'Shomei.Config.NotifierTransport':+--+-- * 'runNotifierLog' writes the link to the server log (the default; development / log-scraping).+--+-- * 'runNotifierSmtp' delivers a plain-text email through a __provider relay__ (SES, SendGrid,+--   Resend, Postmark) over implicit-TLS / STARTTLS / plaintext-lab modes. Not a mail server.+--+-- * 'runNotifierWebhook' POSTs the notification as HMAC-signed JSON to a configured URL.+--+-- Both delivering interpreters are __fire-and-forget and hardened__: every exception is caught+-- inside the interpreter, a failed delivery logs one redacted line and publishes a+-- 'Shomei.Audit.Event.Domain.NotificationDeliveryFailed' audit event, and the triggering HTTP request+-- still succeeds. Their operational log lines never contain the one-time token. Operators who+-- want a provider Shōmei does not ship supply their own 'Notifier' interpreter.+module Shomei.Notify+  ( SmtpPassword (..),+    WebhookSecret (..),+    NotifierSecrets (..),+    noNotifierSecrets,+    smtpPasswordText,+    webhookSecretBytes,+    DeliveryReason (..),+    SmtpStage (..),+    reasonText,+    classifySmtpFailure,+    classifyWebhookFailure,+    redactDeliveryText,+    runNotifierEnqueue,+    runNotifierFromConfig,+    runNotifierLog,+    runNotifierSmtp,+    runNotifierWebhook,+    renderNotification,+    notificationTypeText,+    transportChannel,+    deliverNotification,+    webhookSignature,+  )+where++import Control.Concurrent (threadDelay)+import Control.Exception (IOException, SomeException, fromException, try)+import Crypto.Hash.Algorithms (SHA256)+import Crypto.MAC.HMAC (HMAC, hmac, hmacGetDigest)+import Data.Aeson (encode)+import Data.ByteArray.Encoding (Base (Base16), convertToBase)+import Data.ByteString (ByteString)+import Data.ByteString.Lazy qualified as BSL+import Data.Char (isSpace)+import Data.Text qualified as Text+import Data.Text.Encoding qualified as TE+import Data.Text.Lazy qualified as TL+import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)+import Data.Time.Format.ISO8601 (iso8601Show)+import Effectful (Eff, IOE, (:>))+import Effectful.Dispatch.Dynamic (interpret_)+import Network.HTTP.Client+  ( HttpException (..),+    HttpExceptionContent (..),+    Manager,+    RequestBody (RequestBodyBS),+    httpLbs,+    method,+    parseRequest,+    requestBody,+    requestHeaders,+    responseStatus,+    responseTimeout,+    responseTimeoutMicro,+  )+import Network.HTTP.Types.Status (statusCode, statusIsSuccessful)+import Network.Mail.Mime (Address (..), Mail, simpleMail')+import Network.Mail.SMTP+  ( sendMail',+    sendMailSTARTTLS',+    sendMailTLS',+    sendMailWithLogin',+    sendMailWithLoginSTARTTLS',+    sendMailWithLoginTLS',+  )+import Shomei.Account.Email.Domain (emailText)+import Shomei.Account.Notification.Domain (Notification (..))+import Shomei.Account.Notification.Store (Notifier (..))+import Shomei.Account.OneTimeToken.Domain (OneTimeToken, oneTimeTokenText)+import Shomei.Account.Password.Hash.Postgres (sha256Hex)+import Shomei.Audit.Event.Domain (AuthEvent (NotificationDeliveryFailed), NotificationDeliveryFailedData (..))+import Shomei.Audit.Publisher.Store (AuthEventPublisher, publishAuthEvent)+import Shomei.Config (NotifierConfig (..), NotifierTransport (..), ShomeiConfig (..), SmtpConfig (..), SmtpTlsMode (..), WebhookConfig (..))+import Shomei.Notify.Queue (NotifierQueue)+import Shomei.Notify.Queue qualified as Queue+import Shomei.Prelude+import Shomei.Time.Store (Clock, now)+import System.IO (hPutStrLn, stderr)+import System.IO.Error (ioeGetErrorString, isUserError)+import System.Timeout (timeout)+import Text.Read (readMaybe)++-- | Stable, secret-free reasons that may be written to logs and persisted audit rows.+-- Third-party exception text is inspected only long enough to select one of these values.+data DeliveryReason+  = ConnectFailed+  | TlsFailed+  | AuthFailed+  | Timeout+  | RejectedAt SmtpStage Int+  | DataRefused+  | InvalidUrl+  | HttpStatus Int+  | RedirectLoop+  | TransportError+  | QueueFull+  | ShuttingDown+  | ExpiredInQueue+  | Unknown+  deriving stock (Eq, Show)++data SmtpStage = AtEhlo | AtStartTls | AtMail | AtRcpt | AtData+  deriving stock (Eq, Show)++-- | SMTP credential material. Deliberately has no 'Show', 'Eq', or JSON instances: placing it+-- in a printable configuration or diagnostic structure is a type error.+newtype SmtpPassword = SmtpPassword Text++-- | Webhook HMAC key. Deliberately has no 'Show', 'Eq', or JSON instances.+newtype WebhookSecret = WebhookSecret Text++-- | Runtime-only notifier credentials, carried beside (never inside) 'ShomeiConfig'.+data NotifierSecrets = NotifierSecrets+  { smtpPassword :: !(Maybe SmtpPassword),+    webhookSecret :: !(Maybe WebhookSecret)+  }++noNotifierSecrets :: NotifierSecrets+noNotifierSecrets = NotifierSecrets {smtpPassword = Nothing, webhookSecret = Nothing}++smtpPasswordText :: SmtpPassword -> Text+smtpPasswordText (SmtpPassword password) = password++webhookSecretBytes :: WebhookSecret -> ByteString+webhookSecretBytes (WebhookSecret secret) = TE.encodeUtf8 secret++reasonText :: DeliveryReason -> Text+reasonText = \case+  ConnectFailed -> "connect_failed"+  TlsFailed -> "tls_failed"+  AuthFailed -> "auth_failed"+  Timeout -> "timeout"+  RejectedAt stage code -> "rejected_at_" <> smtpStageText stage <> ":" <> Text.pack (show code)+  DataRefused -> "data_refused"+  InvalidUrl -> "invalid_url"+  HttpStatus code -> "http_status:" <> Text.pack (show code)+  RedirectLoop -> "redirect_loop"+  TransportError -> "transport_error"+  QueueFull -> "queue_full"+  ShuttingDown -> "shutting_down"+  ExpiredInQueue -> "expired_in_queue"+  Unknown -> "unknown"++smtpStageText :: SmtpStage -> Text+smtpStageText = \case+  AtEhlo -> "ehlo"+  AtStartTls -> "starttls"+  AtMail -> "mail"+  AtRcpt -> "rcpt"+  AtData -> "data"++-- | Collapse smtp-mail failures into a vocabulary that cannot contain the rendered message.+classifySmtpFailure :: SomeException -> DeliveryReason+classifySmtpFailure err =+  case fromException err :: Maybe IOException of+    Just ioe+      | not (isUserError ioe) -> ConnectFailed+      | otherwise -> classifyUserError (Text.pack (ioeGetErrorString ioe))+    Nothing+      | looksLikeTls (Text.pack (show err)) -> TlsFailed+      | looksLikeConnectFailure (Text.pack (show err)) -> ConnectFailed+      | otherwise -> Unknown+  where+    classifyUserError msg+      | "timed out" `Text.isInfixOf` lower = Timeout+      | "authentication failed" `Text.isInfixOf` lower = AuthFailed+      | "cannot connect to the server" `Text.isInfixOf` lower = ConnectFailed+      | "connection refused" `Text.isInfixOf` lower = ConnectFailed+      | "failed to connect" `Text.isInfixOf` lower = ConnectFailed+      | "cannot accept any data" `Text.isInfixOf` lower = DataRefused+      | Just rejected <- parseRejected msg = rejected+      | otherwise = Unknown+      where+        lower = Text.toLower msg++-- | Collapse http-client failures without retaining the request, URL, headers, or response body.+classifyWebhookFailure :: SomeException -> DeliveryReason+classifyWebhookFailure err =+  case fromException err of+    Just (InvalidUrlException _ _) -> InvalidUrl+    Just (HttpExceptionRequest _ content) -> classifyHttpContent content+    Nothing -> TransportError+  where+    classifyHttpContent = \case+      ResponseTimeout -> Timeout+      ConnectionTimeout -> Timeout+      ConnectionFailure _ -> ConnectFailed+      TooManyRedirects _ -> RedirectLoop+      StatusCodeException response _ -> HttpStatus (statusCode (responseStatus response))+      InternalException inner+        | looksLikeTls (Text.pack (show inner)) -> TlsFailed+      _ -> TransportError++looksLikeTls :: Text -> Bool+looksLikeTls rendered =+  any (`Text.isInfixOf` rendered) ["HandshakeFailed", "TLSException", "TlsException"]++looksLikeConnectFailure :: Text -> Bool+looksLikeConnectFailure rendered =+  any+    (`Text.isInfixOf` rendered)+    ["HostCannotConnect", "Network.Socket.connect", "Connection refused"]++parseRejected :: Text -> Maybe DeliveryReason+parseRejected msg = do+  commandAndRest <- Text.stripPrefix "Unexpected reply to: " msg+  stage <- parseStage commandAndRest+  let (_, reply) = Text.breakOn "Got this instead: " commandAndRest+  guard (not (Text.null reply))+  code <- readMaybe (Text.unpack (Text.take 3 (Text.drop (Text.length "Got this instead: ") reply)))+  pure (RejectedAt stage code)+  where+    parseStage command+      | "EHLO" `Text.isPrefixOf` command || "HELO" `Text.isPrefixOf` command = Just AtEhlo+      | "STARTTLS" `Text.isPrefixOf` command = Just AtStartTls+      | "MAIL" `Text.isPrefixOf` command = Just AtMail+      | "RCPT" `Text.isPrefixOf` command = Just AtRcpt+      | "DATA" `Text.isPrefixOf` command = Just AtData+      | otherwise = Nothing++-- | Select the notifier interpreter from configuration and run it, reusing the server's shared+-- TLS 'Manager' for the webhook transport. A single dispatching handler both implements the+-- @alsoLogNotifications@ tee (log first, then deliver — no double delivery) and guards against a+-- selected transport whose sub-config is somehow absent by falling back to the log sender with a+-- one-line warning (boot validation makes that unreachable in the standalone server).+--+-- This is written as one 'interpret_' rather than the plan's @interpose@-based tee: forwarding to+-- an underlying handler by re-'send'ing inside an 'interpose' handler would re-enter the tee+-- handler and loop. Dispatching per notification is unambiguous and runs each delivery once.+runNotifierFromConfig ::+  (IOE :> es, AuthEventPublisher :> es, Clock :> es) =>+  Manager ->+  NotifierSecrets ->+  ShomeiConfig ->+  Eff (Notifier : es) a ->+  Eff es a+runNotifierFromConfig mgr secrets cfg = interpret_ \case+  SendNotification notification -> deliverNotification mgr secrets cfg notification++-- | The standalone request-path interpreter. Enqueueing is one bounded STM transaction and+-- never waits for a relay. Overflow and shutdown are still observable through the audit port.+runNotifierEnqueue ::+  (IOE :> es, AuthEventPublisher :> es, Clock :> es) =>+  NotifierQueue ->+  Text ->+  Eff (Notifier : es) a ->+  Eff es a+runNotifierEnqueue notifierQueue channel = interpret_ \case+  SendNotification notification -> do+    outcome <- liftIO (Queue.enqueueNotification notifierQueue notification)+    case outcome of+      Queue.Enqueued -> pure ()+      Queue.QueueFull -> publishDeliveryFailed channel notification QueueFull+      Queue.QueueClosed -> publishDeliveryFailed channel notification ShuttingDown++-- | Deliver one dequeued notification. Expired work is audited and skipped before any network+-- operation; otherwise this is exactly the synchronous interpreter's former dispatch path.+deliverNotification ::+  (IOE :> es, AuthEventPublisher :> es, Clock :> es) =>+  Manager ->+  NotifierSecrets ->+  ShomeiConfig ->+  Notification ->+  Eff es ()+deliverNotification mgr secrets cfg notification = do+  currentTime <- now+  if notificationExpiresAt notification <= currentTime+    then publishDeliveryFailed (transportChannel nc.notifierTransport) notification ExpiredInQueue+    else do+      when tee (logNotification nc notification)+      deliver notification+  where+    nc = cfg.notifierConfig+    tee = nc.alsoLogNotifications && nc.notifierTransport /= LogNotifier+    deliver = case nc.notifierTransport of+      LogNotifier -> logNotification nc+      SmtpNotifier -> maybe (logFallback "smtp" nc) (\sc -> deliverSmtp nc sc secrets.smtpPassword) nc.smtpConfig+      WebhookNotifier -> case (nc.webhookConfig, secrets.webhookSecret) of+        (Just wc, Just secret) -> deliverWebhook mgr wc secret+        _ -> \undeliverable -> publishDeliveryFailed "webhook" undeliverable AuthFailed++transportChannel :: NotifierTransport -> Text+transportChannel = \case+  LogNotifier -> "log"+  SmtpNotifier -> "smtp"+  WebhookNotifier -> "webhook"++notificationExpiresAt :: Notification -> UTCTime+notificationExpiresAt = \case+  EmailVerificationRequested _ _ expires -> expires+  PasswordResetRequested _ _ expires -> expires++-- | Fallback used only if a transport is selected with no sub-config (boot validation prevents+-- this): warn once and log the notification rather than silently dropping it.+logFallback :: (IOE :> es) => Text -> NotifierConfig -> Notification -> Eff es ()+logFallback which nc n = do+  liftIO (hPutStrLn stderr ("[shomei:" <> Text.unpack which <> "] no configuration; falling back to the log sender"))+  logNotification nc n++runNotifierLog :: (IOE :> es) => NotifierConfig -> Eff (Notifier : es) a -> Eff es a+runNotifierLog cfg = interpret_ \case+  SendNotification n -> logNotification cfg n++-- | Write one notification to stderr through 'renderNotification' (token redacted unless+-- 'NotifierConfig.logRawTokens'). The per-notification primitive shared by the log sender and the+-- @alsoLogNotifications@ tee.+logNotification :: (IOE :> es) => NotifierConfig -> Notification -> Eff es ()+logNotification cfg n = liftIO (hPutStrLn stderr (renderNotification cfg n))++-- | Render a notification as one log line.+--+-- By default the one-time token is __redacted__: the line carries only the first 8 hex+-- characters of its SHA-256, which is enough to correlate a log line with the token's+-- stored hash trail but useless for taking the account over (the token itself is 32 random+-- bytes). No link is printed either — a link without its token is noise.+--+-- Setting 'NotifierConfig.logRawTokens' (env @SHOMEI_NOTIFIER_LOG_SECRETS=true@) restores+-- the full clickable link. That is for local development, where the logged link is how you+-- complete the flow; in any shared environment it hands account takeover to whoever can+-- read the log.+renderNotification :: NotifierConfig -> Notification -> String+renderNotification cfg = \case+  EmailVerificationRequested email token expires ->+    line "email_verification" "/v1/auth/verify-email/confirm" email token expires+  PasswordResetRequested email token expires ->+    line "password_reset" "/v1/auth/password-reset/confirm" email token expires+  where+    line kind path email token expires =+      "[shomei:log] "+        <> kind+        <> " email="+        <> Text.unpack (emailText email)+        <> secretPart path token+        <> " expires_at="+        <> show expires+        <> hint+    secretPart path token+      | cfg.logRawTokens =+          " link="+            <> Text.unpack cfg.publicBaseUrl+            <> path+            <> "?token="+            <> Text.unpack (oneTimeTokenText token)+      | otherwise = " token_sha256=" <> Text.unpack (tokenPrefix token)+    hint+      | cfg.logRawTokens = ""+      | otherwise = " (set SHOMEI_NOTIFIER_LOG_SECRETS=true to log the full link in development)"++-- | The first 8 hex characters of the token's SHA-256 — a correlation handle, not a secret.+-- One-time tokens are stored as SHA-256 too (base64url rather than hex), so this prefix+-- ties a log line to its @token_hash@ row.+tokenPrefix :: OneTimeToken -> Text+tokenPrefix = Text.take 8 . sha256Hex . oneTimeTokenText++-- SMTP interpreter (EP-8) -----------------------------------------------------++-- | Deliver notifications as plain-text email through a __provider relay__ (SES, SendGrid,+-- Resend, Postmark). Fire-and-forget and hardened: every exception (including a timeout) is+-- caught, a failed send logs one redacted line and publishes a 'NotificationDeliveryFailed'+-- audit event, and the triggering workflow still returns success. This interpreter sits above+-- 'AuthEventPublisher'/'Clock' in the server stack, so it may publish and read the clock.+runNotifierSmtp ::+  (IOE :> es, AuthEventPublisher :> es, Clock :> es) =>+  NotifierConfig ->+  SmtpConfig ->+  Maybe SmtpPassword ->+  Eff (Notifier : es) a ->+  Eff es a+runNotifierSmtp nc sc password = interpret_ \case+  SendNotification n -> deliverSmtp nc sc password n++-- | Deliver one notification over SMTP: build the message, send it under a timeout, and on any+-- failure publish the redacted 'NotificationDeliveryFailed' event. The per-notification primitive+-- shared by 'runNotifierSmtp' and the config dispatcher.+deliverSmtp ::+  (IOE :> es, AuthEventPublisher :> es, Clock :> es) =>+  NotifierConfig ->+  SmtpConfig ->+  Maybe SmtpPassword ->+  Notification ->+  Eff es ()+deliverSmtp nc sc password n = do+  let (subject, body) = renderEmail nc n+      recipient = notificationRecipient n+      mail = simpleMail' (Address Nothing recipient) (Address Nothing sc.fromAddress) subject body+  outcome <- liftIO (try @SomeException (sendViaSmtp sc password mail))+  case outcome of+    Right () -> pure ()+    Left err -> publishDeliveryFailed "smtp" n (classifySmtpFailure err)++-- | Run the SMTP dialogue for one message under a timeout, choosing the connection mode from+-- 'SmtpTlsMode' and using the authenticated variant when credentials are present. Boot+-- validation guarantees username and password are both present or both absent. The explicit+-- mismatch branch keeps a hand-built embedding configuration from silently downgrading.+sendViaSmtp :: SmtpConfig -> Maybe SmtpPassword -> Mail -> IO ()+sendViaSmtp sc mp mail = do+  let SmtpConfig {host = h, port = p, tlsMode = tls, username = mu, timeoutSeconds = to} = sc+      host' = Text.unpack h+      port' = fromIntegral p+      creds = (,) <$> mu <*> fmap smtpPasswordText mp+      send = case (mu, mp, tls, creds) of+        (Just _, Nothing, _, _) -> ioError (userError "SMTP credentials are incomplete")+        (Nothing, Just _, _, _) -> ioError (userError "SMTP credentials are incomplete")+        (_, _, SmtpPlain, Just (u, pw)) -> sendMailWithLogin' host' port' (Text.unpack u) (Text.unpack pw) mail+        (_, _, SmtpPlain, Nothing) -> sendMail' host' port' mail+        (_, _, SmtpStartTls, Just (u, pw)) -> sendMailWithLoginSTARTTLS' host' port' (Text.unpack u) (Text.unpack pw) mail+        (_, _, SmtpStartTls, Nothing) -> sendMailSTARTTLS' host' port' mail+        (_, _, SmtpImplicitTls, Just (u, pw)) -> sendMailWithLoginTLS' host' port' (Text.unpack u) (Text.unpack pw) mail+        (_, _, SmtpImplicitTls, Nothing) -> sendMailTLS' host' port' mail+  result <- timeout (max 1 to * 1_000_000) send+  case result of+    Just () -> pure ()+    Nothing -> ioError (userError ("SMTP delivery to " <> host' <> " timed out after " <> show to <> "s"))++-- Shared rendering + failure reporting ----------------------------------------++-- | The event-style type string for a notification, used both in the failure audit event and as+-- the webhook @X-Shomei-Notification-Type@ header (M3). Kept identical to the audit @event_type@+-- vocabulary so a reader correlates the two.+notificationTypeText :: Notification -> Text+notificationTypeText = \case+  EmailVerificationRequested {} -> "email_verification_requested"+  PasswordResetRequested {} -> "password_reset_requested"++-- | The recipient address of a notification.+notificationRecipient :: Notification -> Text+notificationRecipient = \case+  EmailVerificationRequested e _ _ -> emailText e+  PasswordResetRequested e _ _ -> emailText e++-- | The fixed English subject and plain-text body for a notification. These are the only two+-- bodies Shōmei ever emails; there is no templating, i18n, or HTML part (operators who want+-- branded copy take the webhook or a custom interpreter). The confirm links reuse the exact+-- @\/v1@ routes 'renderNotification' logs, so host confirm pages keep working unchanged.+renderEmail :: NotifierConfig -> Notification -> (Text, TL.Text)+renderEmail nc = \case+  EmailVerificationRequested _ token expires ->+    ( "Verify your email address",+      TL.fromStrict+        ( body+            [ "Hello,",+              "",+              "Please confirm your email address by opening this link:",+              "",+              link "/v1/auth/verify-email/confirm" token,+              "",+              "This link expires at " <> isoUtc expires <> " (UTC). If you did not request this,",+              "you can ignore this message."+            ]+        )+    )+  PasswordResetRequested _ token expires ->+    ( "Reset your password",+      TL.fromStrict+        ( body+            [ "Hello,",+              "",+              "A password reset was requested for your account. Open this link to",+              "choose a new password:",+              "",+              link "/v1/auth/password-reset/confirm" token,+              "",+              "This link expires at " <> isoUtc expires <> " (UTC). If you did not request this,",+              "you can ignore this message and your password will remain unchanged."+            ]+        )+    )+  where+    body = Text.intercalate "\n"+    link path token = nc.publicBaseUrl <> path <> "?token=" <> oneTimeTokenText token+    isoUtc = Text.pack . iso8601Show++-- | Log one redacted line and publish a 'NotificationDeliveryFailed' audit event for a delivery+-- that failed after exhausting its attempts. Shared by the SMTP and webhook interpreters. The+-- token appears __nowhere__: only channel, notification type, recipient, and a closed reason+-- code are emitted. The defence-in-depth redactor makes a future free-text reason safe too.+publishDeliveryFailed ::+  (IOE :> es, AuthEventPublisher :> es, Clock :> es) =>+  -- | channel: @"smtp"@ | @"webhook"@+  Text ->+  Notification ->+  DeliveryReason ->+  Eff es ()+publishDeliveryFailed channel n reason = do+  let recipient = notificationRecipient n+      kind = notificationTypeText n+      safeReason = redactDeliveryText n (reasonText reason)+  liftIO+    ( hPutStrLn+        stderr+        ( Text.unpack+            ( "[shomei:"+                <> channel+                <> "] delivery_failed type="+                <> kind+                <> " recipient="+                <> recipient+                <> " reason="+                <> safeReason+            )+        )+    )+  occ <- now+  publishAuthEvent+    ( NotificationDeliveryFailed+        NotificationDeliveryFailedData+          { channel = channel,+            notificationType = kind,+            recipient = recipient,+            errorText = safeReason,+            occurredAt = occ+          }+    )++-- | Defence in depth for text associated with a delivery. The public failure path uses only+-- 'DeliveryReason', but this also removes the notification's token and any @token=@ parameter+-- before bounding the text in case a future transport threads richer context through here.+redactDeliveryText :: Notification -> Text -> Text+redactDeliveryText notification =+  truncateText+    . redactTokenParameters+    . Text.replace (oneTimeTokenText (notificationToken notification)) "<redacted>"++notificationToken :: Notification -> OneTimeToken+notificationToken = \case+  EmailVerificationRequested _ token _ -> token+  PasswordResetRequested _ token _ -> token++redactTokenParameters :: Text -> Text+redactTokenParameters input =+  case Text.breakOn "token=" input of+    (_, rest) | Text.null rest -> input+    (prefix, rest) ->+      let valueAndSuffix = Text.drop (Text.length "token=") rest+          suffix = Text.dropWhile isTokenCharacter valueAndSuffix+       in prefix <> "token=<redacted>" <> redactTokenParameters suffix+  where+    isTokenCharacter c = not (isSpace c || c `elem` ['&', '\'', '"'])++-- | Collapse whitespace (including newlines) to single spaces and cap at 500 characters, so an+-- error string is one safe line for a log and an audit payload.+truncateText :: Text -> Text+truncateText = Text.take 500 . Text.unwords . Text.words++-- Webhook interpreter (EP-8) --------------------------------------------------++-- | Deliver notifications as a signed JSON POST to a configured URL, reusing the server's shared+-- TLS 'Manager'. Same fire-and-forget hardening as 'runNotifierSmtp': all exceptions caught, a+-- non-2xx response counts as a failure, bounded retries with backoff, then one redacted log line+-- plus a 'NotificationDeliveryFailed' audit event. The JSON body is the notification's derived+-- 'ToJSON' (so it carries the raw token — the receiver builds the link), signed over the exact+-- bytes sent with @X-Shomei-Signature: sha256=<hex HMAC-SHA256>@.+runNotifierWebhook ::+  (IOE :> es, AuthEventPublisher :> es, Clock :> es) =>+  Manager ->+  WebhookConfig ->+  WebhookSecret ->+  Eff (Notifier : es) a ->+  Eff es a+runNotifierWebhook mgr wc secret = interpret_ \case+  SendNotification n -> deliverWebhook mgr wc secret n++-- | Deliver one notification over the webhook and, on ultimate failure, publish the redacted+-- 'NotificationDeliveryFailed' event. The per-notification primitive shared by+-- 'runNotifierWebhook' and the config dispatcher.+deliverWebhook ::+  (IOE :> es, AuthEventPublisher :> es, Clock :> es) =>+  Manager ->+  WebhookConfig ->+  WebhookSecret ->+  Notification ->+  Eff es ()+deliverWebhook mgr wc secret n = do+  result <- attemptWebhook mgr wc secret n+  case result of+    Nothing -> pure ()+    Just reason -> publishDeliveryFailed "webhook" n reason++-- | POST the notification, retrying up to 'WebhookConfig.maxAttempts' with @4^(k-1)@-second+-- backoff (1 s, 4 s, …) between attempts, each under the configured per-attempt timeout. Returns+-- 'Nothing' on the first 2xx, or a secret-free reason after the last attempt fails. All exceptions are+-- caught here; nothing escapes to the interpreter. Each retry gets a fresh timestamp and+-- signature so a receiver's replay window measures the actual attempt, not initial enqueue.+attemptWebhook :: (IOE :> es, Clock :> es) => Manager -> WebhookConfig -> WebhookSecret -> Notification -> Eff es (Maybe DeliveryReason)+attemptWebhook mgr wc secret n = do+  let WebhookConfig {url = u, timeoutSeconds = to, maxAttempts = maxA} = wc+      body = BSL.toStrict (encode n)+      kind = notificationTypeText n+      attempts = max 1 maxA+  reqE <- liftIO (try @SomeException (parseRequest (Text.unpack u)))+  case reqE of+    Left _ -> pure (Just InvalidUrl)+    Right req0 -> go req0 body kind attempts to 1+  where+    go req0 body kind attempts to k = do+      attemptTime <- now+      let timestamp = TE.encodeUtf8 (Text.pack (show (floor (utcTimeToPOSIXSeconds attemptTime) :: Integer)))+          sig = webhookSignature (webhookSecretBytes secret) timestamp body+          req =+            req0+              { method = "POST",+                requestBody = RequestBodyBS body,+                requestHeaders =+                  [ ("Content-Type", "application/json"),+                    ("X-Shomei-Signature", sig),+                    ("X-Shomei-Timestamp", timestamp),+                    ("X-Shomei-Notification-Type", TE.encodeUtf8 kind),+                    ("User-Agent", "shomei")+                  ],+                responseTimeout = responseTimeoutMicro (max 1 to * 1_000_000)+              }+      outcome <- liftIO (try @SomeException (httpLbs req mgr))+      let failed reason+            | k >= attempts = pure (Just reason)+            | otherwise = liftIO (threadDelay (4 ^ (k - 1) * 1_000_000)) >> go req0 body kind attempts to (k + 1)+      case outcome of+        Right resp+          | statusIsSuccessful (responseStatus resp) -> pure Nothing+          | otherwise -> failed (HttpStatus (statusCode (responseStatus resp)))+        Left err -> failed (classifyWebhookFailure err)++-- | The @X-Shomei-Signature@ header value: @sha256=@ followed by the lowercase-hex+-- HMAC-SHA256 of @<unix-seconds>.<exact raw body>@ under the shared secret.+webhookSignature :: ByteString -> ByteString -> ByteString -> ByteString+webhookSignature secret timestamp body =+  "sha256="+    <> convertToBase+      Base16+      (hmacGetDigest (hmac secret (timestamp <> "." <> body) :: HMAC SHA256))
+ src/Shomei/Notify/Queue.hs view
@@ -0,0 +1,96 @@+-- | A bounded, non-blocking notification queue shared by request handlers and the worker.+module Shomei.Notify.Queue+  ( NotifierQueue,+    EnqueueOutcome (..),+    newNotifierQueue,+    enqueueNotification,+    withDequeued,+    closeNotifierQueue,+    drainNotifierQueue,+  )+where++import Control.Concurrent (threadDelay)+import Control.Concurrent.STM+  ( TVar,+    atomically,+    modifyTVar',+    newTVarIO,+    readTVar,+    writeTVar,+  )+import Control.Concurrent.STM.TBQueue+  ( TBQueue,+    isFullTBQueue,+    lengthTBQueue,+    newTBQueueIO,+    readTBQueue,+    writeTBQueue,+  )+import Control.Exception (bracket)+import GHC.Clock (getMonotonicTimeNSec)+import Shomei.Account.Notification.Domain (Notification)++data NotifierQueue = NotifierQueue+  { queue :: !(TBQueue Notification),+    closed :: !(TVar Bool),+    inFlight :: !(TVar Int)+  }++data EnqueueOutcome = Enqueued | QueueFull | QueueClosed+  deriving stock (Eq, Show)++-- | Create a queue whose capacity is at least one item.+newNotifierQueue :: Int -> IO NotifierQueue+newNotifierQueue requestedCapacity = do+  q <- newTBQueueIO (fromIntegral (max 1 requestedCapacity))+  closed <- newTVarIO False+  inFlight <- newTVarIO 0+  pure NotifierQueue {queue = q, closed, inFlight}++-- | Attempt one enqueue without ever retrying or blocking.+enqueueNotification :: NotifierQueue -> Notification -> IO EnqueueOutcome+enqueueNotification notifierQueue notification = atomically do+  isClosed <- readTVar notifierQueue.closed+  if isClosed+    then pure QueueClosed+    else do+      full <- isFullTBQueue notifierQueue.queue+      if full+        then pure QueueFull+        else writeTBQueue notifierQueue.queue notification >> pure Enqueued++-- | Block for one item, mark it in flight while the action runs, and clear that mark even when+-- the delivery is cancelled or throws.+withDequeued :: NotifierQueue -> (Notification -> IO ()) -> IO ()+withDequeued notifierQueue action = bracket acquire release action+  where+    acquire = atomically do+      notification <- readTBQueue notifierQueue.queue+      modifyTVar' notifierQueue.inFlight (+ 1)+      pure notification+    release _ = atomically (modifyTVar' notifierQueue.inFlight (max 0 . subtract 1))++-- | Refuse all future enqueues. Existing queued items remain available to the worker.+closeNotifierQueue :: NotifierQueue -> IO ()+closeNotifierQueue notifierQueue = atomically (writeTVar notifierQueue.closed True)++-- | Wait until the queue is empty and no delivery is in flight, or until the monotonic deadline.+-- The returned count includes queued and in-flight items still present at the deadline.+drainNotifierQueue :: NotifierQueue -> Int -> IO Int+drainNotifierQueue notifierQueue timeoutSeconds = do+  started <- getMonotonicTimeNSec+  let deadline = started + fromIntegral (max 0 timeoutSeconds) * 1_000_000_000+      loop = do+        remaining <- atomically do+          queued <- lengthTBQueue notifierQueue.queue+          active <- readTVar notifierQueue.inFlight+          pure (fromIntegral queued + active)+        if remaining == 0+          then pure 0+          else do+            now <- getMonotonicTimeNSec+            if now >= deadline+              then pure remaining+              else threadDelay 50_000 >> loop+  loop
+ src/Shomei/Server/App.hs view
@@ -0,0 +1,215 @@+-- | The Shōmei server effect stack and its runner.+--+-- This single module fixes the one effect stack every server-side action runs in+-- ('AppEffects'), the environment needed to interpret it ('Env'), and the runner that+-- interprets it down to IO ('runAppIO'). It is servant-free: 'runAppIO' returns+-- @IO (Either AuthError a)@ with no HTTP types, so the same stack is reusable by the+-- automated test and (later) the embedded mode, not just the standalone warp boot.+--+-- The stack is the EP-5 servant port stack (@Shomei.Servant.Seam.AppEffects@) /extended/+-- with the two effects the PostgreSQL interpreters need beneath the ports: 'Database'+-- (the hasql layer the store interpreters issue SQL through) and @Error AuthError@ (the+-- channel the interpreters use to surface infrastructure failures). EP-5's handlers run in+-- the smaller stack and are bridged onto this one with @inject@ at assembly time+-- (see "Shomei.Server.Boot").+module Shomei.Server.App+  ( AppEffects,+    Env (..),+    runAppIO,+  )+where++import Data.IORef (IORef, readIORef)+import Effectful (Eff, IOE, runEff)+import Effectful.Error.Static (Error, runErrorNoCallStack)+import Network.HTTP.Client (Manager)+import Shomei.Account.Credential.Postgres (runCredentialStorePostgres)+import Shomei.Account.Credential.Store (CredentialStore)+import Shomei.Account.Notification.Store (Notifier)+import Shomei.Account.Password.Breach.Store (PasswordBreachChecker)+import Shomei.Account.Password.Domain (PasswordPolicy (breachCheckTimeoutMs))+import Shomei.Account.Password.Hash.Postgres (Argon2Params, HashingLimiter, runPasswordHasherCrypto, runTokenGenCrypto)+import Shomei.Account.Password.Hash.Store (PasswordHasher)+import Shomei.Account.PasswordReset.Postgres (runPasswordResetTokenStorePostgres)+import Shomei.Account.PasswordReset.Store (PasswordResetTokenStore)+import Shomei.Account.User.Postgres (runUserStorePostgres)+import Shomei.Account.User.Store (UserStore)+import Shomei.Account.Verification.Postgres (runVerificationTokenStorePostgres)+import Shomei.Account.Verification.Store (VerificationTokenStore)+import Shomei.Audit.Publisher.Postgres (runAuthEventPublisherPostgres)+import Shomei.Audit.Publisher.Store (AuthEventPublisher)+import Shomei.Audit.Reader.Postgres (runAuthEventReaderPostgres)+import Shomei.Audit.Reader.Store (AuthEventReader)+import Shomei.Authorization.Claims.Store (ClaimsEnricher, runClaimsEnricherNull)+import Shomei.Authorization.Role.Postgres (runRoleStorePostgres)+import Shomei.Authorization.Role.Store (RoleStore)+import Shomei.Config (NotifierConfig (notifierTransport), ShomeiConfig (notifierConfig, passwordPolicy), webauthnConfig)+import Shomei.Error (AuthError)+import Shomei.Mfa.RecoveryCode.Postgres (runRecoveryCodeStorePostgres)+import Shomei.Mfa.RecoveryCode.Store (RecoveryCodeStore)+import Shomei.Mfa.Totp.Postgres (TotpEncryptionKey, runTotpCredentialStorePostgres)+import Shomei.Mfa.Totp.Store (TotpCredentialStore)+import Shomei.Notify (NotifierSecrets, runNotifierEnqueue, transportChannel)+import Shomei.Notify.Queue (NotifierQueue)+import Shomei.OAuth.AuthorizationCode.Postgres (runOAuthCodeStorePostgres)+import Shomei.OAuth.AuthorizationCode.Store (OAuthCodeStore)+import Shomei.OAuth.Client.Postgres (runOAuthClientStorePostgres)+import Shomei.OAuth.Client.Store (OAuthClientStore)+import Shomei.Passkey.Ceremony.Port (WebAuthnCeremony)+import Shomei.Passkey.Ceremony.Postgres (runPendingCeremonyStorePostgres)+import Shomei.Passkey.Ceremony.Store (PendingCeremonyStore)+import Shomei.Passkey.Postgres (runPasskeyStorePostgres)+import Shomei.Passkey.Store (PasskeyStore)+import Shomei.Persistence.Database.Postgres (Database, TransactionRetryPolicy, runDatabasePoolWith)+import Shomei.Persistence.Pool.Postgres (Pool)+import Shomei.Prelude+import Shomei.Server.BreachChecker (runPasswordBreachCheckerHibp)+import Shomei.Server.Keys (LoadedKeys (..))+import Shomei.ServiceAccount.Postgres (runServiceAccountStorePostgres)+import Shomei.ServiceAccount.Store (ServiceAccountStore)+import Shomei.Session.LoginAttempt.Postgres (runLoginAttemptStorePostgres)+import Shomei.Session.LoginAttempt.Store (LoginAttemptStore)+import Shomei.Session.Postgres (runSessionStorePostgres)+import Shomei.Session.RefreshToken.Postgres (runRefreshTokenStorePostgres)+import Shomei.Session.RefreshToken.Store (RefreshTokenStore)+import Shomei.Session.Store (SessionStore)+import Shomei.Session.Token.Generator (TokenGen)+import Shomei.Session.UnitOfWork.Postgres (runAuthUnitOfWorkPostgres)+import Shomei.Session.UnitOfWork.Store (AuthUnitOfWork)+import Shomei.SigningKey.Postgres (runSigningKeyStorePostgres)+import Shomei.SigningKey.Protection.Jwt (KeyEncryptionKey)+import Shomei.SigningKey.Sign.Jwt (runTokenSignerJwt)+import Shomei.SigningKey.Signer (TokenSigner)+import Shomei.SigningKey.Store (SigningKeyStore)+import Shomei.SigningKey.Verifier (TokenVerifier)+import Shomei.SigningKey.Verify.Jwt (runTokenVerifierJwt)+import Shomei.Time.Postgres (runClockIO)+import Shomei.Time.Store (Clock)+import Shomei.WebAuthn.Ceremony (runWebAuthnCeremonyLibrary)++-- | The single effect stack the assembled server interprets. The high-level ports+-- come first (the handler's view); 'Database', @Error AuthError@, and 'IOE' sit beneath+-- them because the store/publisher/signing-key interpreters issue SQL through 'Database'+-- and surface failures through @Error AuthError@.+type AppEffects =+  '[ UserStore,+     RoleStore,+     CredentialStore,+     SessionStore,+     RefreshTokenStore,+     AuthUnitOfWork,+     VerificationTokenStore,+     PasswordResetTokenStore,+     LoginAttemptStore,+     PasskeyStore,+     PendingCeremonyStore,+     ServiceAccountStore,+     OAuthClientStore,+     OAuthCodeStore,+     TotpCredentialStore,+     RecoveryCodeStore,+     Notifier,+     ClaimsEnricher,+     WebAuthnCeremony,+     PasswordBreachChecker,+     PasswordHasher,+     TokenSigner,+     TokenVerifier,+     AuthEventPublisher,+     AuthEventReader,+     SigningKeyStore,+     Clock,+     TokenGen,+     Database,+     Error AuthError,+     IOE+   ]++-- | Everything the runtime needs to interpret 'AppEffects' down to IO: the live hasql+-- pool, the loaded config, and the current signing-key material (the private signing key,+-- the verifier's public key set, and the served JWKS document).+--+-- The key material is held in an 'IORef' rather than inlined, because+-- 'Shomei.Server.Keys.reloadKeys' swaps it while the server runs — that is what makes+-- @shomei-admin keys activate@ take effect without a restart.+data Env = Env+  { envPool :: !Pool,+    envDbRetryPolicy :: !TransactionRetryPolicy,+    envConfig :: !ShomeiConfig,+    envKeys :: !(IORef LoadedKeys),+    -- | the key-encryption key used to decrypt the signer during reloads. It is deliberately+    --     not part of 'ShomeiConfig', which is 'Show'able and serializable.+    envKek :: !KeyEncryptionKey,+    -- | the AES-256-GCM key that encrypts stored TOTP secrets (EP-7), loaded from+    --     @SHOMEI_TOTP_ENCRYPTION_KEY@. Deliberately not part of 'ShomeiConfig' (a secret). When+    --     TOTP is disabled this is a dummy key: enrollment is refused, so the store is+    --     unreachable, but the interpreter-stack shape stays fixed.+    envTotpKey :: !TotpEncryptionKey,+    -- | shared TLS manager for the HIBP breach-check interpreter (EP-3)+    envHttpManager :: !Manager,+    -- | runtime-only SMTP/webhook credentials; intentionally outside 'envConfig'+    envNotifierSecrets :: !NotifierSecrets,+    -- | bounded notification queue; request handlers only enqueue, while the supervised+    --     server worker performs delivery outside request latency.+    envNotifierQueue :: !NotifierQueue,+    -- | Argon2id cost parameters for hashing new passwords. Verification reads the parameters+    --     embedded in each stored hash, so this only affects hashes written from now on.+    envArgon2Params :: !Argon2Params,+    -- | bounds how many Argon2 derivations run at once, process-wide+    envHashingLimiter :: !HashingLimiter+  }++-- | Interpret the whole 'AppEffects' stack down to IO, surfacing an infrastructure+-- 'AuthError' as 'Left'. The composition is written outermost-last: read right-to-left it+-- peels 'AppEffects' head-to-tail. The ORDER is load-bearing — every SQL-issuing port is+-- interpreted ABOVE 'runDatabasePool' (so 'Database' is still in scope when they run), and+-- @Error AuthError@/'IOE' sit at the base. This is the same shape as @shomei-postgres@'s+-- own test harness, extended with EP-4's real signer/verifier interpreters.+--+-- The key material is re-read once per invocation (one invocation ≈ one request's port+-- batch), so a reload that lands between requests is picked up without rebuilding the WAI+-- application; a request already in flight finishes with the material it started with.+runAppIO :: Env -> Eff AppEffects a -> IO (Either AuthError a)+runAppIO env action = do+  keys <- readIORef env.envKeys+  runEff+    . runErrorNoCallStack+    . runDatabasePoolWith env.envDbRetryPolicy env.envPool+    . runTokenGenCrypto+    . runClockIO+    . runSigningKeyStorePostgres+    . runAuthEventReaderPostgres+    . runAuthEventPublisherPostgres+    . runTokenVerifierJwt keys.verifierJwks env.envConfig+    . runTokenSignerJwt keys.signingKey env.envConfig+    . runPasswordHasherCrypto env.envHashingLimiter env.envArgon2Params+    . runPasswordBreachCheckerHibp env.envHttpManager breachTimeoutMs+    . runWebAuthnCeremonyLibrary (webauthnConfig env.envConfig)+    -- The standalone server adds no claims of its own. An embedding host swaps this for its+    -- own 'ClaimsEnricher' interpreter where it builds 'Shomei.Servant.Seam.Env'.+    . runClaimsEnricherNull+    . runNotifierEnqueue+      env.envNotifierQueue+      (transportChannel env.envConfig.notifierConfig.notifierTransport)+    . runRecoveryCodeStorePostgres+    . runTotpCredentialStorePostgres env.envTotpKey+    . runOAuthCodeStorePostgres+    . runOAuthClientStorePostgres+    . runServiceAccountStorePostgres+    . runPendingCeremonyStorePostgres+    . runPasskeyStorePostgres+    . runLoginAttemptStorePostgres+    . runPasswordResetTokenStorePostgres+    . runVerificationTokenStorePostgres+    . runAuthUnitOfWorkPostgres+    . runRefreshTokenStorePostgres+    . runSessionStorePostgres+    . runCredentialStorePostgres+    . runRoleStorePostgres+    . runUserStorePostgres+    $ action+  where+    policy :: PasswordPolicy+    policy = env.envConfig.passwordPolicy+    breachTimeoutMs :: Int+    breachTimeoutMs = policy.breachCheckTimeoutMs
+ src/Shomei/Server/Boot.hs view
@@ -0,0 +1,550 @@+-- | Startup sequence and warp boot for the standalone Shōmei auth service.+--+-- 'main' runs the turnkey startup: load config → run migrations (idempotent) → acquire the+-- hasql pool → bootstrap the signing key → build the 'Env' → serve with warp. 'application'+-- builds the WAI app from the exact 'Shomei.Servant.Server.shomeiRoutes' tree and the+-- @AuthProtect "shomei-jwt"@ 'Context'. EP-5's handlers run in the smaller servant port+-- stack ('Shomei.Servant.Seam.AppEffects'); they are bridged onto this server's larger+-- PostgreSQL stack ('Shomei.Server.App.AppEffects') with @inject@ inside the seam env's+-- runner. Infrastructure failures remain typed through the seam; domain failures flow+-- through the same channel to the right status.+module Shomei.Server.Boot+  ( main,+    application,+    HostBackgroundTasks (..),+    installHostBackgroundTasks,+    hostMiddleware,+    edgeMiddleware,+    buildEnv,+    seamEnv,+    authContext,+    validateOidcIssuer,+    NotifierWorker (..),+    installNotifierWorker,+  )+where++-- 'Context' is hidden from the prelude (it re-exports lens's 'Context'); we mean+-- servant's 'Servant.Context' here.++import Control.Concurrent (forkIO, killThread)+import Data.Aeson ((.=))+import Data.Aeson.Key qualified as Key+import Data.ByteString qualified as BS+import Data.Foldable (traverse_)+import Data.IORef (newIORef, readIORef)+import Data.List.NonEmpty qualified as NonEmpty+import Data.Set qualified as Set+import Data.Text qualified as Text+import Data.Time (DiffTime, picosecondsToDiffTime)+import Database.PostgreSQL.Migrate (MigrationReport (..))+import Effectful (Eff, inject, runEff)+import Effectful.Error.Static (runErrorNoCallStack)+import GHC.Clock (getMonotonicTimeNSec)+import Network.HTTP.Client.TLS (newTlsManager)+import Network.Wai (Application, Middleware, Request)+import Network.Wai.Handler.Warp qualified as Warp+import Servant+  ( Context (EmptyContext, (:.)),+    ErrorFormatters,+    serveWithContext,+  )+import Servant.Health (ProbeCheck)+import Servant.Server.Experimental.Auth (AuthHandler)+import Shomei.Account.Password.Hash.Postgres (Argon2Failure (..), Argon2Params (..), argon2WarningFloor, hashingLimit, newHashingLimiter, sha256Hex, trialArgon2Derivation)+import Shomei.Audit.Publisher.Postgres (runAuthEventPublisherPostgres)+import Shomei.Authorization.Claims.Domain (Issuer (..), Role (..))+import Shomei.Authorization.Role.Postgres (runRoleStorePostgres)+import Shomei.Authorization.Role.Workflow (undefinedDefaultRoles)+import Shomei.Config (OAuthConfig (..), ObservabilityConfig (..), ShomeiConfig (..), SigningKeyConfig (..), TotpConfig (..), configSigningAlgorithm)+import Shomei.Error (AuthError)+import Shomei.Health.Server (buildHealthChecks)+import Shomei.Mfa.Totp.Postgres (TotpEncryptionKey, checkTotpEnvelopeVersions, totpEncryptionKeyFromBase64, totpEncryptionKeyFromBytes)+import Shomei.Migrations (applyShomeiMigrations)+import Shomei.Notify (deliverNotification)+import Shomei.Notify.Queue (closeNotifierQueue, drainNotifierQueue, newNotifierQueue, withDequeued)+import Shomei.Persistence.Database.Postgres (TransactionRetryPolicy (..), runDatabasePoolWith)+import Shomei.Persistence.Maintenance.Postgres (sweepOnce, sweepReportCounts)+import Shomei.Persistence.Pool.Postgres (acquirePool)+import Shomei.Persistence.Pool.Postgres qualified as Pool++-- '(.=)' is hidden from the prelude (it re-exports lens's state-setter of the same name);+-- we mean aeson's JSON pair constructor here.+import Shomei.Prelude hiding (Context, (.=))+import Shomei.Servant.Api (shomeiRoutesApi, shomeiThrottledRoutes)+import Shomei.Servant.Auth (AuthUser, authHandler)+import Shomei.Servant.Error (shomeiErrorFormatters)+import Shomei.Servant.Middleware (problemMiddleware)+import Shomei.Servant.Oidc (isAbsoluteHttpUrl)+import Shomei.Servant.Seam qualified as Seam+import Shomei.Servant.Server (shomeiRoutes)+import Shomei.Server.App (Env (..), runAppIO)+import Shomei.Server.Config (ProxyProtocolMode (..), ServerSettings (..), SweepSettings (..), loadConfig, loadNotifierSecretsFromEnv, toSweepConfig)+import Shomei.Server.Keys (LoadedKeys (..), bootstrapKeys, loadKekFromEnv, reloadKeys)+import Shomei.Server.Middleware.BodyLimit (bodyLimitMiddleware, defaultBodyLimitBytes)+import Shomei.Server.Middleware.RateLimit (RateLimiter, newRateLimiterFor, rateLimitMiddleware)+import Shomei.Server.Middleware.TrustedProxy (TrustedProxies, trustedProxyMiddleware, trustedProxyTexts)+import Shomei.Server.Observability.Logging (requestLoggingMiddleware)+import Shomei.Server.Observability.Metrics (Metrics, metricsEndpointMiddleware, metricsMiddleware, newMetrics)+import Shomei.Server.Runtime (hostWarpSettings)+import Shomei.Server.Supervisor (logJsonLine, supervisedLoop, supervisedLoopMicros)+import Shomei.Session.LoginAttempt.Domain (AccountKey (..))+import Shomei.Time.Postgres (runClockIO)+import System.Environment (lookupEnv)+import System.Exit (exitFailure)+import System.IO (BufferMode (LineBuffering), hPutStrLn, hSetBuffering, stderr, stdout)+import System.Posix.Signals (installHandler, sigHUP, sigINT, sigTERM)+import System.Posix.Signals qualified as Signals++-- | The full turnkey startup sequence.+main :: IO ()+main = do+  -- Line-buffer stdout so each structured JSON log line is flushed immediately (when stdout+  -- is a pipe/file it would otherwise be block-buffered and logs would not appear promptly).+  hSetBuffering stdout LineBuffering+  hSetBuffering stderr LineBuffering+  (cfg, settings) <- loadConfig+  let trustedProxySummary =+        case trustedProxyTexts settings.serverTrustedProxies of+          [] -> "none"+          entries -> Text.intercalate "," entries+      proxyProtocolSummary = case settings.serverProxyProtocol of+        ProxyProtocolOff -> "none"+        ProxyProtocolRequired -> "required"+  hPutStrLn+    stderr+    ( "[shomei] trusted proxies: "+        <> Text.unpack trustedProxySummary+        <> "; proxy protocol: "+        <> proxyProtocolSummary+    )+  traverse_+    (\warning -> hPutStrLn stderr ("[shomei] WARNING: " <> Text.unpack warning))+    settings.serverWarnings+  -- Warn, never refuse: a resource-starved dev box legitimately wants cheap hashing, but an+  -- operator must not weaken password storage without seeing it said out loud.+  traverse_+    (\w -> hPutStrLn stderr ("[shomei] WARNING: " <> Text.unpack w))+    (argon2WarningFloor settings.serverArgon2)+  trialArgon2Derivation settings.serverArgon2 >>= \case+    Right () -> pure ()+    Left (Argon2Failure why) -> do+      hPutStrLn+        stderr+        ( "[shomei] FATAL: the Argon2 implementation rejected the configured parameters (m="+            <> show settings.serverArgon2.memoryKiB+            <> "KiB,t="+            <> show settings.serverArgon2.iterations+            <> ",p="+            <> show settings.serverArgon2.parallelism+            <> "): "+            <> Text.unpack why+        )+      exitFailure+  validateOidcIssuer cfg+  env <- buildEnv cfg settings+  (liveness, readiness) <- buildHealthChecks env+  backgroundTasks <- installHostBackgroundTasks cfg settings env+  rl <- newRateLimiterFor shomeiThrottledRoutes cfg.rateLimitConfig+  metrics <- newMetrics+  let obs = cfg.observabilityConfig+      -- Graceful shutdown: SIGTERM (orchestrator stop) and SIGINT (Ctrl-C) trigger warp's+      -- shutdown action, which stops accepting new connections and waits up to the+      -- configured timeout for in-flight requests to finish. After warp returns we close the+      -- pool and exit 0.+      installShutdown closeSocket = do+        let stop sig = hPutStrLn stderr ("[shomei] received " <> sig <> "; draining in-flight requests") >> closeSocket+        _ <- installHandler sigTERM (Signals.Catch (stop "SIGTERM")) Nothing+        _ <- installHandler sigINT (Signals.Catch (stop "SIGINT")) Nothing+        pure ()+  warpSettings <- hostWarpSettings cfg settings (Warp.setInstallShutdownHandler installShutdown Warp.defaultSettings)+  hPutStrLn stderr ("[shomei] listening on :" <> show settings.serverPort)+  Warp.runSettings warpSettings (hostMiddleware cfg settings rl metrics (application env liveness readiness))+  stopHostBackgroundTasks backgroundTasks obs.gracefulShutdownTimeoutSeconds+  hPutStrLn stderr "[shomei] drain complete; closing connection pools"+  Pool.release env.envPool+  hPutStrLn stderr "[shomei] shutdown complete"++-- | Background services required to give an embedded host the standalone server's runtime+-- guarantees. Call 'stopHostBackgroundTasks' after the host server stops accepting requests;+-- it drains queued notifications within the same bounded shutdown budget and releases the+-- sweeper's isolated pool.+newtype HostBackgroundTasks = HostBackgroundTasks+  { stopHostBackgroundTasks :: Int -> IO ()+  }++-- | Install every process-wide and background service used by the standalone server: validate+-- configured default roles, refresh signing keys periodically and on @SIGHUP@, sweep expired+-- state, and deliver queued notifications. An embedding host calls this once after 'buildEnv'.+installHostBackgroundTasks :: ShomeiConfig -> ServerSettings -> Env -> IO HostBackgroundTasks+installHostBackgroundTasks cfg settings env = do+  validateDefaultRoles cfg env+  installKeyReload cfg env+  releaseSweeper <- installSweeper settings env+  notifierWorker <- installNotifierWorker env+  pure+    HostBackgroundTasks+      { stopHostBackgroundTasks = \timeoutSeconds -> do+          drainNotifierWorker notifierWorker timeoutSeconds+          releaseSweeper+      }++-- | The WAI edge used by the standalone server. Wrap the host's whole application so its own+-- routes receive the same trusted-proxy attribution, request IDs, metrics, body cap, and+-- per-client rate limiting as Shōmei's routes.+hostMiddleware :: ShomeiConfig -> ServerSettings -> RateLimiter -> Metrics -> Middleware+hostMiddleware cfg settings =+  edgeMiddleware cfg.observabilityConfig settings.serverTrustedProxies++-- | The WAI edge every host must install. The trusted-proxy rewrite is outermost so logging,+-- metrics, the limiter, and Servant's 'RemoteHost' all observe the same client address.+edgeMiddleware :: ObservabilityConfig -> TrustedProxies -> RateLimiter -> Metrics -> Middleware+edgeMiddleware obs proxies limiter metrics =+  trustedProxyMiddleware proxies+    . requestLoggingMiddleware obs+    . withMetrics+    . bodyLimitMiddleware defaultBodyLimitBytes+    . rateLimitMiddleware limiter+  where+    withMetrics+      | obs.metricsEnabled = metricsMiddleware metrics . metricsEndpointMiddleware metrics+      | otherwise = id++-- | Refuse to start with the OIDC provider enabled and an issuer that is not an absolute+-- @http(s)@ URL.+--+-- The issuer doubles as the provider's public base URL: every endpoint in the discovery document+-- is derived from it, and ID tokens carry it as @iss@. With the default issuer @"shomei"@ the+-- document would advertise @shomei\/oauth\/token@ — a relative URL no client can fetch — and the+-- failure would surface as an inscrutable error inside someone else's OIDC library. Checked+-- before the pool is acquired, because it needs nothing but config.+validateOidcIssuer :: ShomeiConfig -> IO ()+validateOidcIssuer cfg =+  when (cfg.oauthConfig.oidcEnabled && not (isAbsoluteHttpUrl iss)) do+    hPutStrLn+      stderr+      ( "shomei-server: oidcEnabled is set but issuer is not an absolute http(s) URL: "+          <> show iss+          <> "\nThe OIDC issuer is also the base URL every published endpoint is derived from."+          <> "\nSet SHOMEI_ISSUER (or `issuer` in the config file) to this deployment's public"+          <> " base URL, e.g. https://auth.example.com"+      )+    exitFailure+  where+    iss = case cfg.issuer of Issuer t -> t++-- | Refuse to start when @defaultRoles@ names a role missing from the @shomei_roles@ registry.+--+-- Validating once here rather than on every signup keeps the hot path free of catalog reads and+-- turns a config typo into an immediate, obvious startup failure instead of a stream of 500s on+-- an endpoint nobody is watching. The registry is append-only, so a role validated here cannot+-- later disappear — which is why 'Shomei.Authorization.Role.Workflow.applyDefaultRoles' does not re-check.+--+-- An embedding host that sets @defaultRoles@ should call+-- 'Shomei.Authorization.Role.Workflow.undefinedDefaultRoles' the same way where it assembles its ports.+validateDefaultRoles :: ShomeiConfig -> Env -> IO ()+validateDefaultRoles cfg env = do+  outcome <-+    runEff+      . runErrorNoCallStack @AuthError+      . runDatabasePoolWith env.envDbRetryPolicy env.envPool+      . runRoleStorePostgres+      $ undefinedDefaultRoles cfg+  case outcome of+    Left e -> die ("could not validate defaultRoles against the role registry: " <> show e)+    Right missing+      | Set.null missing -> pure ()+      | otherwise -> do+          let names = Text.intercalate ", " [r | Role r <- Set.toList missing]+              first' = case Set.toList missing of+                Role r : _ -> r+                [] -> "<role>"+          die+            ( "defaultRoles names undefined roles: "+                <> Text.unpack names+                <> "\ndefine them first: shomei-admin roles define "+                <> Text.unpack first'+            )+  where+    die msg = hPutStrLn stderr ("shomei-server: " <> msg) >> exitFailure++-- | Install the two triggers that refresh signing-key material on a running server, so+-- @shomei-admin keys activate@ / @keys revoke@ take effect with no restart: a periodic+-- background reload every @refreshIntervalSeconds@ (0 disables it), and a @SIGHUP@ handler+-- for a deterministic "apply now". Both call 'reloadKeys', which keeps the last good+-- material if a reload fails.+--+-- The periodic reload runs on 'supervisedLoop', the shared supervised-background-thread+-- idiom: a crash is logged and retried with backoff rather than killing the loop, and the+-- thread dies with the process. Note that 'supervisedLoop' runs its first cycle immediately,+-- so a reload happens right after 'bootstrapKeys' — harmless, since 'reloadKeys' is idempotent+-- and keeps the last good material on failure.+installKeyReload :: ShomeiConfig -> Env -> IO ()+installKeyReload cfg env = do+  when (interval > 0) (void (forkIO (supervisedLoop "key-reload" interval reload)))+  void (installHandler sigHUP (Signals.Catch onHup) Nothing)+  where+    interval = cfg.signingKeyConfig.refreshIntervalSeconds+    reload = reloadKeys env.envKek env.envPool env.envKeys+    onHup = hPutStrLn stderr "[shomei] SIGHUP: reloading signing keys" >> reload++-- | Fork the background expired-data sweeper, unless the operator disabled it in favor of+-- scheduling @shomei-admin sweep@ externally. Its one-connection pool is deliberately separate+-- from the request pool, so a long drain never consumes request capacity. The returned cleanup+-- releases that pool during graceful shutdown.+--+-- A 'Left' from 'sweepOnce' means the database was unreachable or a statement failed. That is+-- an ordinary outcome for periodic maintenance, not a crash: it is logged and the loop sleeps+-- a normal interval rather than entering 'supervisedLoop''s backoff, which is reserved for+-- genuine exceptions.+installSweeper :: ServerSettings -> Env -> IO (IO ())+installSweeper settings _env+  | not sweep.sweepEnabled = pure (pure ())+  | otherwise = do+      sweepPool <-+        acquirePool+          1+          (millisToDiffTime settings.serverDbPoolAcquisitionTimeoutMs)+          settings.serverDbStatementTimeoutMs+          settings.serverConnStr+      hPutStrLn+        stderr+        ( "[shomei] sweeper: every "+            <> show sweep.sweepIntervalSeconds+            <> "s, audit retention "+            <> maybe "disabled (retain forever)" (\d -> show d <> " days") sweep.sweepAuthEventRetentionDays+            <> ", on its own connection"+        )+      void (forkIO (supervisedLoop "sweeper" sweep.sweepIntervalSeconds (oneCycle sweepPool)))+      pure (Pool.release sweepPool)+  where+    sweep = settings.serverSweep+    oneCycle sweepPool = do+      -- Wall-clock time decides which rows are expired; a monotonic clock measures how long+      -- the sweep took, so an NTP step cannot produce a negative duration.+      cutoffNow <- getCurrentTime+      startTick <- getMonotonicTimeNSec+      result <- sweepOnce sweepPool (toSweepConfig sweep) cutoffNow+      endTick <- getMonotonicTimeNSec+      logSweepCycle (durationMs startTick endTick) result++    durationMs startTick endTick =+      fromIntegral (endTick - startTick) / 1_000_000 :: Double++    logSweepCycle elapsed = \case+      Left err ->+        logJsonLine+          [ "level" .= ("error" :: Text),+            "msg" .= ("sweep failed" :: Text),+            "task" .= ("sweeper" :: Text),+            "error" .= Text.pack (show err),+            "duration_ms" .= elapsed+          ]+      Right report ->+        logJsonLine+          ( [ "level" .= ("info" :: Text),+              "msg" .= ("sweep" :: Text)+            ]+              <> [Key.fromText table .= deleted | (table, deleted) <- sweepReportCounts report]+              <> ["duration_ms" .= elapsed]+          )++-- | Handle returned by 'installNotifierWorker'. EP-9's embedding assembly lifts the install+-- and drain calls verbatim so an embedding host receives the same delivery guarantees.+newtype NotifierWorker = NotifierWorker+  { drainNotifierWorker :: Int -> IO ()+  }++-- | Run one supervised delivery worker. Closing prevents new enqueue operations, then drain waits+-- within the server's graceful-shutdown budget before cancelling any remaining network call.+installNotifierWorker :: Env -> IO NotifierWorker+installNotifierWorker env = do+  workerThread <-+    forkIO+      ( supervisedLoopMicros+          "notifier"+          0+          (5 * 1_000_000)+          (300 * 1_000_000)+          oneCycle+      )+  pure+    NotifierWorker+      { drainNotifierWorker = \timeoutSeconds -> do+          closeNotifierQueue env.envNotifierQueue+          dropped <- drainNotifierQueue env.envNotifierQueue timeoutSeconds+          logJsonLine+            [ "level" .= (if dropped == 0 then "info" else "warn" :: Text),+              "msg" .= ("notifier drained" :: Text),+              "dropped" .= dropped+            ]+          killThread workerThread+      }+  where+    oneCycle =+      withDequeued env.envNotifierQueue \notification -> do+        result <-+          runEff+            . runErrorNoCallStack @AuthError+            . runDatabasePoolWith env.envDbRetryPolicy env.envPool+            . runClockIO+            . runAuthEventPublisherPostgres+            $ deliverNotification env.envHttpManager env.envNotifierSecrets env.envConfig notification+        case result of+          Right () -> pure ()+          Left err ->+            logJsonLine+              [ "level" .= ("error" :: Text),+                "msg" .= ("notifier delivery audit failed" :: Text),+                "task" .= ("notifier" :: Text),+                "error" .= Text.pack (show err)+              ]++-- | Run the schema migrations (idempotent), acquire the pool, and bootstrap the signing+-- key, yielding the assembled 'Env'. Shared by 'main' and by host applications that embed+-- the Shōmei API (the embedded demo builds its own 'Env' this way). Running+-- @shomei-migrate@ out-of-band is also supported for production.+buildEnv :: ShomeiConfig -> ServerSettings -> IO Env+buildEnv cfg settings = do+  alg <-+    either+      (\why -> hPutStrLn stderr ("[shomei] FATAL: signingKeyConfig.algorithm: " <> Text.unpack why) >> exitFailure)+      pure+      (configSigningAlgorithm cfg)+  applyShomeiMigrations settings.serverConnStr >>= \case+    Left migrationError -> do+      hPutStrLn stderr ("[shomei] FATAL: schema migration failed: " <> show migrationError)+      exitFailure+    Right report ->+      hPutStrLn+        stderr+        ("[shomei] schema migrations applied: " <> show (NonEmpty.length report.results) <> " migrations")+  hPutStrLn+    stderr+    ( "[shomei] db pool: size "+        <> show settings.serverDbPoolSize+        <> ", acquisition timeout "+        <> show settings.serverDbPoolAcquisitionTimeoutMs+        <> "ms, statement timeout "+        <> show settings.serverDbStatementTimeoutMs+        <> "ms"+    )+  pool <-+    acquirePool+      settings.serverDbPoolSize+      (millisToDiffTime settings.serverDbPoolAcquisitionTimeoutMs)+      settings.serverDbStatementTimeoutMs+      settings.serverConnStr+  checkTotpEnvelopeVersions pool >>= \case+    Right (0, 0) -> pure ()+    _ -> do+      Pool.release pool+      hPutStrLn stderr "[shomei] FATAL: TOTP envelope conversion required; stop writers and run shomei-admin totp migrate-envelopes --check, then --offline"+      exitFailure+  kek <- loadKekFromEnv+  totpKey <- loadTotpKeyFromEnv cfg+  notifierSecrets <- loadNotifierSecretsFromEnv cfg+  keys <- bootstrapKeys kek alg pool+  keysRef <- newIORef keys+  mgr <- newTlsManager+  limiter <- newHashingLimiter settings.serverHashingMaxConcurrency+  notifierQueue <- newNotifierQueue settings.serverNotifierQueueSize+  hPutStrLn+    stderr+    ( "[shomei] hashing concurrency "+        <> show (hashingLimit limiter)+        <> ", argon2 m="+        <> show settings.serverArgon2.memoryKiB+        <> "KiB,t="+        <> show settings.serverArgon2.iterations+        <> ",p="+        <> show settings.serverArgon2.parallelism+    )+  pure+    Env+      { envPool = pool,+        envDbRetryPolicy = TransactionRetryPolicy settings.serverDbTransactionMaxAttempts settings.serverDbTransactionDeadlineMs,+        envConfig = cfg,+        envKeys = keysRef,+        envKek = kek,+        envHttpManager = mgr,+        envNotifierSecrets = notifierSecrets,+        envNotifierQueue = notifierQueue,+        envArgon2Params = settings.serverArgon2,+        envHashingLimiter = limiter,+        envTotpKey = totpKey+      }++-- | The AES-256-GCM key that encrypts stored TOTP secrets (EP-7), loaded from+-- @SHOMEI_TOTP_ENCRYPTION_KEY@ (base64 of exactly 32 bytes; generate one with+-- @openssl rand -base64 32@).+--+-- When TOTP is enabled and the variable is absent or malformed, the server refuses to boot with+-- a loud message — an enabled factor whose secrets cannot be encrypted is a silent data-loss+-- trap. When TOTP is disabled the store is unreachable (enrollment is refused), so a valid key is+-- optional; a dummy all-zero key keeps the interpreter-stack shape fixed. A key supplied while+-- disabled is still validated, so a typo is caught before it is switched on.+loadTotpKeyFromEnv :: ShomeiConfig -> IO TotpEncryptionKey+loadTotpKeyFromEnv cfg = do+  raw <- lookupEnv "SHOMEI_TOTP_ENCRYPTION_KEY"+  let enabled = cfg.totpConfig.totpEnabled+  case fmap Text.pack raw of+    Just t | not (Text.null (Text.strip t)) ->+      case totpEncryptionKeyFromBase64 t of+        Right k -> pure k+        Left err -> die ("SHOMEI_TOTP_ENCRYPTION_KEY " <> Text.unpack err)+    _+      | enabled -> die "SHOMEI_TOTP_ENCRYPTION_KEY is required when totpEnabled is set (generate one with: openssl rand -base64 32)"+      | otherwise -> either (die . Text.unpack) pure (totpEncryptionKeyFromBytes (BS.replicate 32 0))+  where+    die msg = hPutStrLn stderr ("[shomei] " <> msg) >> exitFailure++-- | Milliseconds to a 'DiffTime', exactly (a 'DiffTime' counts picoseconds, so this loses+-- nothing). Used for the pool's acquisition timeout, which config carries as an integer count+-- of milliseconds.+millisToDiffTime :: Int -> DiffTime+millisToDiffTime ms = picosecondsToDiffTime (fromIntegral ms * 1_000_000_000)++-- | Build the WAI 'Application': EP-5's server with the @AuthProtect "shomei-jwt"@+-- 'Context'. Authentication is derived from the seam env's port runner and config, so it uses+-- the current verification keys and honors @sessionCheckMode@.+--+-- The served tree is 'shomeiRoutesApi' (EP-3): application routes under @\/v1@, JWKS and the+-- probes at unversioned root paths.+--+-- 'problemMiddleware' converts Servant's one un-formattable failure — the bare @405@ a method+-- mismatch raises below any 'ErrorFormatters' hook — into a problem document, so /every/ error+-- the process emits carries the same envelope.+application :: Env -> ProbeCheck -> ProbeCheck -> Application+application env liveness readiness =+  problemMiddleware (serveWithContext shomeiRoutesApi (authContext senv) (shomeiRoutes senv liveness readiness))+  where+    senv = seamEnv env++-- | The Servant 'Context' carrying the @AuthProtect "shomei-jwt"@ 'AuthHandler' (built from the+-- seam env itself) and the 'ErrorFormatters' that render Servant's own body-parse,+-- url-parse, header-parse, and not-found failures as RFC 9457 problem documents. A host app+-- embedding 'ShomeiAPI' serves with this same context.+authContext :: Seam.Env -> Context '[AuthHandler Request AuthUser, ErrorFormatters]+authContext senv =+  authHandler senv+    :. shomeiErrorFormatters+    :. EmptyContext++-- | Build EP-5's seam 'Seam.Env' from this server's assembly 'Env'. The port runner+-- bridges EP-5's smaller stack onto the PostgreSQL stack with @inject@ while preserving+-- its typed error channel.+seamEnv :: Env -> Seam.Env+seamEnv env =+  Seam.Env+    { Seam.runPorts = runPorts,+      Seam.config = env.envConfig,+      -- The JWKS getter reads swappable key material, so a rotation applied by 'reloadKeys'+      -- takes effect on the next request without rebuilding the WAI application. Token+      -- verification now goes through 'Seam.runPorts'; 'runAppIO' also re-reads these keys.+      Seam.jwksJson = (.jwksBody) <$> readIORef env.envKeys,+      Seam.accountKeyOf = AccountKey . sha256Hex+    }+  where+    runPorts :: forall a. Eff Seam.AppEffects a -> IO (Either AuthError a)+    runPorts act = runAppIO env (inject act)
+ src/Shomei/Server/BreachChecker.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE DataKinds #-}++-- | EP-3 production interpreter for 'PasswordBreachChecker': a HIBP Pwned Passwords range+-- query using k-anonymity. Only the 5-char SHA-1 prefix leaves the process; the full hash and the+-- plaintext never go on the wire. Constructed once when the effect stack is assembled, from a+-- shared TLS 'Manager' and a fixed per-call timeout (the EP-1 @breachCheckTimeoutMs@ policy).+--+-- Any transport error or timeout is caught and reported as 'BreachCheckUnavailable', leaving the+-- fail-open / fail-closed decision to 'Shomei.Account.Password.Breach.Workflow.enforceBreachPolicy'.+module Shomei.Server.BreachChecker (runPasswordBreachCheckerHibp, runPasswordBreachCheckerWith) where++import Control.Exception (SomeAsyncException, SomeException, fromException, throwIO, try)+import Data.ByteString.Lazy qualified as LBS+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.Encoding qualified as TE+import Effectful (Eff, IOE, liftIO, (:>))+import Effectful.Dispatch.Dynamic (interpret_)+import Network.HTTP.Client+  ( Manager,+    Request (..),+    httpLbs,+    parseRequest,+    responseBody,+    responseTimeoutMicro,+  )+import Network.HTTP.Types.Header (hUserAgent)+import Shomei.Account.Password.Breach.Store+  ( BreachResult (..),+    PasswordBreachChecker (..),+    parseHibpResponse,+    sha1PrefixSuffix,+  )+import Shomei.Notify (classifyWebhookFailure, reasonText)+import System.IO (hPutStrLn, stderr)++-- | Build the interpreter from a shared TLS manager and a timeout in milliseconds (pass+-- @cfg.passwordPolicy.breachCheckTimeoutMs@ at assembly time).+runPasswordBreachCheckerHibp ::+  (IOE :> es) => Manager -> Int -> Eff (PasswordBreachChecker : es) a -> Eff es a+runPasswordBreachCheckerHibp mgr timeoutMs = runPasswordBreachCheckerWith (queryRange mgr timeoutMs) (hPutStrLn stderr . Text.unpack)++-- | Injectable dependency/report boundary. Only the k-anonymity prefix reaches the query;+-- reports carry a closed reason code and never contain the prefix or exception text.+runPasswordBreachCheckerWith ::+  (IOE :> es) => (Text -> IO Text) -> (Text -> IO ()) -> Eff (PasswordBreachChecker : es) a -> Eff es a+runPasswordBreachCheckerWith query report = interpret_ \case+  CheckPasswordBreached plain -> liftIO do+    let (prefix, suffix) = sha1PrefixSuffix plain+    result <- try (query prefix) :: IO (Either SomeException Text)+    case result of+      Left err | Just _ <- (fromException err :: Maybe SomeAsyncException) -> throwIO err+      Left err -> do+        report ("[shomei:breach-check] unavailable reason=" <> reasonText (classifyWebhookFailure err))+        pure BreachCheckUnavailable+      Right body -> pure (if parseHibpResponse body suffix then Breached else NotBreached)++-- | Fetch the HIBP range bucket for a 5-char prefix as decoded text. Throws on transport+-- errors and timeouts (caught by the interpreter above).+queryRange :: Manager -> Int -> Text -> IO Text+queryRange mgr timeoutMs prefix = do+  base <- parseRequest ("https://api.pwnedpasswords.com/range/" <> Text.unpack prefix)+  let req =+        base+          { requestHeaders =+              ("Add-Padding", "true")+                : (hUserAgent, "shomei")+                : requestHeaders base,+            responseTimeout = responseTimeoutMicro (timeoutMs * 1000)+          }+  resp <- httpLbs req mgr+  pure (TE.decodeUtf8 (LBS.toStrict (responseBody resp)))
+ src/Shomei/Server/Config.hs view
@@ -0,0 +1,1471 @@+-- | Load runtime configuration into the core 'ShomeiConfig' plus the server-only+-- 'ServerSettings' (listen port, connection string).+--+-- Precedence (lowest to highest, twelve-factor): (1) built-in 'defaultShomeiConfig'; (2) a typed+-- Dhall file at @$SHOMEI_CONFIG@ (if set and present), rendered to JSON by the @dhall-to-json@+-- CLI and decoded here; (3) individual @SHOMEI_*@ / @PG_CONNECTION_STRING@ environment variables.+-- If @$SHOMEI_CONFIG@ is unset the file step is skipped and the server still boots from defaults+-- + env (preserving the turnkey behavior).+--+-- Dhall is rendered with the @dhall-to-json@ binary (provided by the toolchain / container) rather+-- than the heavyweight @dhall@ Haskell library, and the rendered JSON is decoded with @aeson@ into+-- a flat 'FileConfig' of optional scalar overrides — see EP-5's Decision Log. @loadConfigFromEnv@+-- remains as the env-only entry point used by EP-4's @shomei-admin@.+module Shomei.Server.Config+  ( ServerSettings (..),+    ProxyProtocolMode (..),+    SweepSettings (..),+    defaultSweepSettings,+    defaultDbStatementTimeoutMs,+    toSweepConfig,+    loadConfig,+    loadConfigFromEnv,+    loadCoreConfig,+    loadNotifierSecretsFromEnv,+    defaultRolesFromEnv,+    cookieTransportWarnings,+    FileConfig (..),+  )+where++-- Argon2Params is re-exported through 'ServerSettings'; import it from "Shomei.Account.Password.Hash.Postgres".++import Data.Aeson (eitherDecodeStrict')+import Data.Char (isDigit)+import Data.Foldable (for_)+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Text qualified as Text+import Data.Text.Encoding qualified as TE+import Data.Time (NominalDiffTime)+import Shomei.Account.Password.Domain (PasswordPolicy (..))+import Shomei.Account.Password.Hash.Postgres (Argon2Params (..), argon2HardFloor, defaultArgon2Params)+import Shomei.Authorization.Claims.Domain (Audience (..), Issuer (..), Role (..))+import Shomei.Config+  ( AttestationPolicy (..),+    CookieConfig (..),+    MachineTokenConfig (..),+    MfaConfig (..),+    NotifierConfig (..),+    NotifierTransport (..),+    OAuthConfig (..),+    ObservabilityConfig (..),+    RateLimitConfig (..),+    SameSitePolicy (..),+    SessionCheckMode (..),+    ShomeiConfig (..),+    SigningKeyConfig (..),+    SmtpConfig (..),+    SmtpTlsMode (..),+    TokenTransport (..),+    TotpConfig (..),+    UserVerificationPolicy (..),+    WebAuthnConfig (..),+    WebhookConfig (..),+    defaultCookieConfig,+    defaultShomeiConfig,+    normalizeOrigin,+    transportUsesCookies,+  )+import Shomei.Notify (NotifierSecrets (..), SmtpPassword (..), WebhookSecret (..))+import Shomei.Persistence.Maintenance.Postgres (SweepConfig (..), defaultSweepConfig)+import Shomei.Prelude+import Shomei.Server.Middleware.TrustedProxy (TrustedProxies, emptyTrustedProxies, parseTrustedProxies)+import Shomei.SigningKey.Verify.Jwt (checkStringOrUri)+import System.Environment (lookupEnv)+import System.IO (hPutStrLn, stderr)+import System.Process (readProcess)+import Text.Read (readMaybe)++-- | Server-only settings not part of the transport-agnostic 'ShomeiConfig'.+--+-- The pool knobs live here rather than in 'ShomeiConfig' because 'ShomeiConfig' is+-- deliberately infrastructure-agnostic — it has no @hasql@ types and no knowledge that+-- PostgreSQL exists. The pool is a server deployment concern exactly like the listen port.+data ServerSettings = ServerSettings+  { serverPort :: !Int,+    serverBindHost :: !Text,+    serverMaxConnections :: !Int,+    serverSlowClientTimeoutSeconds :: !Int,+    serverConnStr :: !Text,+    -- | socket peers allowed to supply X-Forwarded-For client identity+    serverTrustedProxies :: !TrustedProxies,+    -- | whether every TCP connection must carry a PROXY protocol v1 header+    serverProxyProtocol :: !ProxyProtocolMode,+    -- | connections held open by the @hasql@ pool+    serverDbPoolSize :: !Int,+    -- | how long a request waits for a free pooled connection before failing+    serverDbPoolAcquisitionTimeoutMs :: !Int,+    -- | PostgreSQL statement and idle-in-transaction timeout installed on every connection+    serverDbStatementTimeoutMs :: !Int,+    serverDbTransactionMaxAttempts :: !Int,+    serverDbTransactionDeadlineMs :: !Int,+    -- | bounded in-memory notification queue capacity+    serverNotifierQueueSize :: !Int,+    -- | non-fatal configuration posture warnings printed by the standalone boot path+    serverWarnings :: ![Text],+    -- | the background expired-data sweeper+    serverSweep :: !SweepSettings,+    -- | Argon2id cost parameters for hashing /new/ passwords. Existing hashes carry the+    --     parameters they were made with, so changing these never invalidates a credential.+    serverArgon2 :: !Argon2Params,+    -- | How many Argon2 derivations may run at once. Each pins a capability in an unsafe+    --     foreign call and transiently allocates its full memory cost, so this bounds both GC+    --     stalls and the memory spike. Raising it trades hot-path latency for login throughput.+    serverHashingMaxConcurrency :: !Int+  }+  deriving stock (Show, Generic)++data ProxyProtocolMode+  = ProxyProtocolOff+  | ProxyProtocolRequired+  deriving stock (Eq, Show, Generic)++-- | Two concurrent hashes bound the transient allocation at ~128 MiB and cap the capabilities+-- that can be pinned in unsafe FFI simultaneously, while still sustaining ~13–40 logins/second+-- at 50–150 ms per hash — far above any single-instance deployment's login rate. The+-- conservative end of the review's 2–4 suggestion: too-small merely queues logins, while+-- too-large is the global-GC-stall bug this bound exists to prevent.+defaultHashingMaxConcurrency :: Int+defaultHashingMaxConcurrency = 2++-- | Settings for the background expired-data sweeper (see 'Shomei.Persistence.Maintenance.Postgres').+--+-- These live here rather than in the core 'ShomeiConfig' for the same reason the pool knobs+-- do: retention is a deployment and storage concern with no domain meaning, and 'ShomeiConfig'+-- is deliberately infrastructure-agnostic.+--+-- 'sweepEnabled' is the off-switch. An operator who prefers external scheduling (cron, a+-- Kubernetes CronJob) sets @SHOMEI_SWEEP_ENABLED=false@ and runs @shomei-admin sweep@ instead;+-- both triggers call the same 'sweepOnce', and running them concurrently is harmless.+data SweepSettings = SweepSettings+  { sweepEnabled :: !Bool,+    -- | seconds between sweep cycles+    sweepIntervalSeconds :: !Int,+    sweepBatchSize :: !Int,+    sweepDeadSessionGraceDays :: !Int,+    sweepOneTimeTokenGraceDays :: !Int,+    sweepCeremonyGraceMinutes :: !Int,+    sweepLoginAttemptRetentionDays :: !Int,+    -- | 'Nothing' retains the audit trail forever, which is the default+    sweepAuthEventRetentionDays :: !(Maybe Int)+  }+  deriving stock (Show, Eq, Generic)++-- | Sweeper defaults: on, hourly, and with the grace periods documented on 'SweepConfig'.+defaultSweepSettings :: SweepSettings+defaultSweepSettings =+  SweepSettings+    { sweepEnabled = True,+      sweepIntervalSeconds = 3600,+      sweepBatchSize = defaultSweepConfig.batchSize,+      sweepDeadSessionGraceDays = defaultSweepConfig.deadSessionGraceDays,+      sweepOneTimeTokenGraceDays = defaultSweepConfig.oneTimeTokenGraceDays,+      sweepCeremonyGraceMinutes = defaultSweepConfig.ceremonyGraceMinutes,+      sweepLoginAttemptRetentionDays = defaultSweepConfig.loginAttemptRetentionDays,+      sweepAuthEventRetentionDays = defaultSweepConfig.authEventRetentionDays+    }++-- | Project the deployment-facing settings onto the sweep engine's own config record.+toSweepConfig :: SweepSettings -> SweepConfig+toSweepConfig s =+  SweepConfig+    { batchSize = s.sweepBatchSize,+      deadSessionGraceDays = s.sweepDeadSessionGraceDays,+      oneTimeTokenGraceDays = s.sweepOneTimeTokenGraceDays,+      ceremonyGraceMinutes = s.sweepCeremonyGraceMinutes,+      loginAttemptRetentionDays = s.sweepLoginAttemptRetentionDays,+      authEventRetentionDays = s.sweepAuthEventRetentionDays+    }++-- | The pool size a server boots with when neither the Dhall file nor the environment says+-- otherwise. Ten preserves the value that was hardcoded in @Shomei.Server.Boot.buildEnv@.+defaultDbPoolSize :: Int+defaultDbPoolSize = 10++-- | The acquisition timeout, in milliseconds, a server boots with by default: @hasql-pool@'s+-- own 10-second default, made explicit.+defaultDbPoolAcquisitionTimeoutMs :: Int+defaultDbPoolAcquisitionTimeoutMs = 10000++-- | Bound one PostgreSQL statement or an idle transaction to 30 seconds by default. Zero is the+-- explicit PostgreSQL off-switch for deployments that need an unbounded session.+defaultDbStatementTimeoutMs :: Int+defaultDbStatementTimeoutMs = 30000++defaultNotifierQueueSize :: Int+defaultNotifierQueueSize = 1024++-- | The flat, all-optional shape the Dhall config file is rendered into (via @dhall-to-json@).+-- Every field is a 'Maybe' scalar so a partial file is valid and absent keys fall back to the+-- defaults / env.+data FileConfig = FileConfig+  { issuer :: !(Maybe Text),+    audience :: !(Maybe Text),+    databaseUrl :: !(Maybe Text),+    port :: !(Maybe Int),+    bindHost :: !(Maybe Text),+    maxConnections :: !(Maybe Int),+    slowClientTimeoutSeconds :: !(Maybe Int),+    trustedProxies :: !(Maybe [Text]),+    proxyProtocol :: !(Maybe Text),+    -- | connections held open by the @hasql@ pool+    dbPoolSize :: !(Maybe Int),+    -- | how long a request waits for a free pooled connection, in milliseconds+    dbPoolAcquisitionTimeoutMs :: !(Maybe Int),+    -- | maximum statement or idle-in-transaction duration; zero disables both+    dbStatementTimeoutMs :: !(Maybe Int),+    dbTransactionMaxAttempts :: !(Maybe Int),+    dbTransactionDeadlineMs :: !(Maybe Int),+    -- | run the background expired-data sweeper in-process+    sweepEnabled :: !(Maybe Bool),+    sweepIntervalSeconds :: !(Maybe Int),+    sweepBatchSize :: !(Maybe Int),+    sweepDeadSessionGraceDays :: !(Maybe Int),+    sweepOneTimeTokenGraceDays :: !(Maybe Int),+    sweepCeremonyGraceMinutes :: !(Maybe Int),+    loginAttemptRetentionDays :: !(Maybe Int),+    -- | absent retains the audit trail forever; a value of 0 or less also means "forever"+    authEventRetentionDays :: !(Maybe Int),+    -- | Argon2id memory cost in KiB for newly hashed passwords+    argon2MemoryKiB :: !(Maybe Int),+    argon2Iterations :: !(Maybe Int),+    argon2Parallelism :: !(Maybe Int),+    -- | how many Argon2 derivations may run at once+    hashingMaxConcurrency :: !(Maybe Int),+    accessTokenTtlSeconds :: !(Maybe Int),+    refreshTokenTtlSeconds :: !(Maybe Int),+    sessionTtlSeconds :: !(Maybe Int),+    rememberedSessionTtlSeconds :: !(Maybe Int),+    maxPasskeysPerUser :: !(Maybe Int),+    maxActiveNonInteractiveSessions :: !(Maybe Int),+    publicBaseUrl :: !(Maybe Text),+    emailVerificationRequired :: !(Maybe Bool),+    -- | EP-8 notifier transport: @log@ (default) | @smtp@ | @webhook@. Secrets (SMTP password,+    --     webhook signing secret) are deliberately NOT config-file fields — they come from the+    --     environment only (@SHOMEI_SMTP_PASSWORD@, @SHOMEI_WEBHOOK_SECRET@).+    notifierTransport :: !(Maybe Text),+    -- | also tee every notification through the log sender (staged rollout). Default False.+    alsoLogNotifications :: !(Maybe Bool),+    smtpHost :: !(Maybe Text),+    smtpPort :: !(Maybe Int),+    -- | @plain@ (lab only) | @starttls@ | @implicit@+    smtpTlsMode :: !(Maybe Text),+    smtpUsername :: !(Maybe Text),+    smtpFromAddress :: !(Maybe Text),+    smtpTimeoutSeconds :: !(Maybe Int),+    webhookUrl :: !(Maybe Text),+    webhookTimeoutSeconds :: !(Maybe Int),+    webhookMaxAttempts :: !(Maybe Int),+    notifierQueueSize :: !(Maybe Int),+    rateLimitEnabled :: !(Maybe Bool),+    maxFailedLoginsPerAccount :: !(Maybe Int),+    maxFailedLoginsPerIp :: !(Maybe Int),+    perIpRequestsPerMinute :: !(Maybe Int),+    perIpBurst :: !(Maybe Int),+    lockoutWindowSeconds :: !(Maybe Int),+    lockoutDurationSeconds :: !(Maybe Int),+    metricsEnabled :: !(Maybe Bool),+    requestLoggingEnabled :: !(Maybe Bool),+    gracefulShutdownTimeoutSeconds :: !(Maybe Int),+    passwordMinLength :: !(Maybe Int),+    passwordMaxLength :: !(Maybe Int),+    passwordRejectCommon :: !(Maybe Bool),+    passwordRejectContextual :: !(Maybe Bool),+    passwordBreachCheckEnabled :: !(Maybe Bool),+    passwordBreachCheckFailClosed :: !(Maybe Bool),+    passwordBreachCheckTimeoutMs :: !(Maybe Int),+    webauthnRpId :: !(Maybe Text),+    webauthnRpName :: !(Maybe Text),+    webauthnOrigins :: !(Maybe [Text]),+    -- | @required@ | @preferred@ | @discouraged@+    webauthnUserVerification :: !(Maybe Text),+    -- | @none@ | @direct@+    webauthnAttestation :: !(Maybe Text),+    webauthnCeremonyTimeoutSeconds :: !(Maybe Int),+    webauthnPendingCeremonyTtlSeconds :: !(Maybe Int),+    mfaRequireSecondFactor :: !(Maybe Bool),+    -- | EP-7: enable the TOTP second factor (enrollment + login challenge). The AES-256-GCM+    --     encryption key for stored secrets is NOT here — it is a secret, read from+    --     @SHOMEI_TOTP_ENCRYPTION_KEY@; the server refuses to boot when TOTP is on and it is+    --     absent or malformed.+    totpEnabled :: !(Maybe Bool),+    totpEnrollmentTtlSeconds :: !(Maybe Int),+    machineTokenTtlSeconds :: !(Maybe Int),+    -- | enable the OIDC provider surface (discovery, @\/oauth\/authorize@). Requires @issuer@+    --     to be the deployment's public @http(s)@ base URL; the server refuses to boot otherwise.+    oidcEnabled :: !(Maybe Bool),+    -- | the host's login page, for the unauthenticated-authorize redirect+    oauthLoginUrl :: !(Maybe Text),+    oauthAuthorizationCodeTtlSeconds :: !(Maybe Int),+    oauthIdTokenTtlSeconds :: !(Maybe Int),+    -- | seconds of verifier tolerance for exp/nbf/iat; must be non-negative+    allowedClockSkewSeconds :: !(Maybe Int),+    legacyActorUntilUnix :: !(Maybe Int),+    emitLegacyActor :: !(Maybe Bool),+    -- | @ES256@ | @RS256@; the JWT signing algorithm for keys generated on first boot+    signingAlgorithm :: !(Maybe Text),+    -- | seconds between background reloads of signing-key material; 0 disables them+    keyRefreshIntervalSeconds :: !(Maybe Int),+    -- | @bearer@ | @cookie@ | @both@+    tokenTransport :: !(Maybe Text),+    cookieSecure :: !(Maybe Bool),+    -- | @strict@ | @lax@ | @none@+    cookieSameSite :: !(Maybe Text),+    -- | origins allowed to make cookie-authenticated mutating requests+    csrfAllowedOrigins :: !(Maybe [Text]),+    -- | roles granted to every new user at signup. Each must already exist in the+    --     @shomei_roles@ registry; the server refuses to boot otherwise.+    defaultRoles :: !(Maybe [Text])+  }+  deriving stock (Show, Generic)+  deriving anyclass (ToJSON)++instance FromJSON FileConfig where+  parseJSON = genericParseJSON defaultOptions {rejectUnknownFields = True}++-- | The full loader: defaults → Dhall file (if @$SHOMEI_CONFIG@) → env.+loadConfig :: IO (ShomeiConfig, ServerSettings)+loadConfig = do+  mFile <- loadDhallFile+  (cfg0, settings0) <- baseFromFile mFile+  overlayFromEnvBoth cfg0 settings0++-- | The env-only loader (no Dhall file). Stable entry point for @shomei-admin@.+loadConfigFromEnv :: IO (ShomeiConfig, ServerSettings)+loadConfigFromEnv = do+  (cfg, settings) <- baseDefaults+  overlayFromEnvBoth cfg settings++-- | Load only the transport-agnostic configuration: defaults → Dhall file → core environment+-- overlays. Administrative commands use this path so password policy, default roles, and other+-- workflow behavior match the server without requiring a server connection string or validating+-- listen/pool settings they do not consume.+loadCoreConfig :: IO ShomeiConfig+loadCoreConfig = do+  mFile <- loadDhallFile+  (cfg, _) <- baseFromFile mFile+  overlayCoreFromEnv cfg++-- Dhall file ----------------------------------------------------------------++loadDhallFile :: IO (Maybe FileConfig)+loadDhallFile = do+  mPath <- lookupEnv "SHOMEI_CONFIG"+  case mPath of+    Just path | not (null path) -> do+      out <- readProcess "dhall-to-json" ["--file", path] ""+      case eitherDecodeStrict' (TE.encodeUtf8 (Text.pack out)) of+        Right fc -> pure (Just fc)+        Left err -> do+          hPutStrLn stderr ("shomei: could not decode rendered Dhall config " <> path <> ": " <> err)+          ioError (userError ("invalid SHOMEI_CONFIG: " <> path))+    _ -> pure Nothing++baseDefaults :: IO (ShomeiConfig, ServerSettings)+baseDefaults =+  pure+    ( defaultShomeiConfig (Issuer "shomei") (Audience "shomei-clients"),+      ServerSettings+        { serverPort = 8080,+          serverBindHost = "*4",+          serverMaxConnections = 1024,+          serverSlowClientTimeoutSeconds = 30,+          serverConnStr = "",+          serverTrustedProxies = emptyTrustedProxies,+          serverProxyProtocol = ProxyProtocolOff,+          serverDbPoolSize = defaultDbPoolSize,+          serverDbPoolAcquisitionTimeoutMs = defaultDbPoolAcquisitionTimeoutMs,+          serverDbStatementTimeoutMs = defaultDbStatementTimeoutMs,+          serverDbTransactionMaxAttempts = 3,+          serverDbTransactionDeadlineMs = 5000,+          serverNotifierQueueSize = defaultNotifierQueueSize,+          serverWarnings = [],+          serverSweep = defaultSweepSettings,+          serverArgon2 = defaultArgon2Params,+          serverHashingMaxConcurrency = defaultHashingMaxConcurrency+        }+    )++baseFromFile :: Maybe FileConfig -> IO (ShomeiConfig, ServerSettings)+baseFromFile Nothing = baseDefaults+baseFromFile (Just fc) = do+  algFile <- traverse (normalizeSigningAlg "signingAlgorithm (config file)") fc.signingAlgorithm+  transportFile <- traverse (parseTransport "tokenTransport (config file)") fc.tokenTransport+  sameSiteFile <- traverse (parseSameSite "cookieSameSite (config file)") fc.cookieSameSite+  uvFile <- traverse (parseUserVerificationPolicy "webauthnUserVerification (config file)") fc.webauthnUserVerification+  attestationFile <- traverse (parseAttestationPolicy "webauthnAttestation (config file)") fc.webauthnAttestation+  notifierTransportFile <- traverse (parseNotifierTransport "notifierTransport (config file)") fc.notifierTransport+  smtpTlsModeFile <- traverse (parseSmtpTlsMode "smtpTlsMode (config file)") fc.smtpTlsMode+  csrfOriginsFile <- traverse normalizeOrigins fc.csrfAllowedOrigins+  trustedProxiesFile <- parseTrustedProxyList (fromMaybe [] fc.trustedProxies)+  proxyProtocolFile <- traverse (parseProxyProtocol "proxyProtocol (config file)") fc.proxyProtocol+  let iss = fromMaybe "shomei" fc.issuer+      aud = fromMaybe "shomei-clients" fc.audience+      cfg0 = defaultShomeiConfig (Issuer iss) (Audience aud)+  let cfg =+        cfg0+          { accessTokenTTL = maybe cfg0.accessTokenTTL fromIntegral fc.accessTokenTtlSeconds,+            refreshTokenTTL = maybe cfg0.refreshTokenTTL fromIntegral fc.refreshTokenTtlSeconds,+            sessionTTL = maybe cfg0.sessionTTL fromIntegral fc.sessionTtlSeconds,+            rememberedSessionTTL = maybe cfg0.rememberedSessionTTL fromIntegral fc.rememberedSessionTtlSeconds,+            maxPasskeysPerUser = fromMaybe cfg0.maxPasskeysPerUser fc.maxPasskeysPerUser,+            maxActiveNonInteractiveSessions = fromMaybe cfg0.maxActiveNonInteractiveSessions fc.maxActiveNonInteractiveSessions,+            notifierConfig =+              cfg0.notifierConfig+                { emailVerificationRequired = fromMaybe cfg0.notifierConfig.emailVerificationRequired fc.emailVerificationRequired,+                  publicBaseUrl = fromMaybe cfg0.notifierConfig.publicBaseUrl fc.publicBaseUrl,+                  notifierTransport = fromMaybe cfg0.notifierConfig.notifierTransport notifierTransportFile,+                  alsoLogNotifications = fromMaybe cfg0.notifierConfig.alsoLogNotifications fc.alsoLogNotifications,+                  smtpConfig = smtpFromFile smtpTlsModeFile fc,+                  webhookConfig = webhookFromFile fc+                },+            rateLimitConfig =+              cfg0.rateLimitConfig+                { rateLimitEnabled = fromMaybe cfg0.rateLimitConfig.rateLimitEnabled fc.rateLimitEnabled,+                  maxFailedLoginsPerAccount = fromMaybe cfg0.rateLimitConfig.maxFailedLoginsPerAccount fc.maxFailedLoginsPerAccount,+                  maxFailedLoginsPerIp = fromMaybe cfg0.rateLimitConfig.maxFailedLoginsPerIp fc.maxFailedLoginsPerIp,+                  lockoutWindow = maybe cfg0.rateLimitConfig.lockoutWindow fromIntegral fc.lockoutWindowSeconds,+                  lockoutDuration = maybe cfg0.rateLimitConfig.lockoutDuration fromIntegral fc.lockoutDurationSeconds,+                  perIpRequestsPerMinute = fromMaybe cfg0.rateLimitConfig.perIpRequestsPerMinute fc.perIpRequestsPerMinute,+                  perIpBurst = fromMaybe cfg0.rateLimitConfig.perIpBurst fc.perIpBurst+                },+            passwordPolicy =+              cfg0.passwordPolicy+                { minLength = fromMaybe cfg0.passwordPolicy.minLength fc.passwordMinLength,+                  maxLength = fromMaybe cfg0.passwordPolicy.maxLength fc.passwordMaxLength,+                  rejectCommonPasswords = fromMaybe cfg0.passwordPolicy.rejectCommonPasswords fc.passwordRejectCommon,+                  rejectContextualPasswords = fromMaybe cfg0.passwordPolicy.rejectContextualPasswords fc.passwordRejectContextual,+                  breachCheckEnabled = fromMaybe cfg0.passwordPolicy.breachCheckEnabled fc.passwordBreachCheckEnabled,+                  breachCheckFailClosed = fromMaybe cfg0.passwordPolicy.breachCheckFailClosed fc.passwordBreachCheckFailClosed,+                  breachCheckTimeoutMs = fromMaybe cfg0.passwordPolicy.breachCheckTimeoutMs fc.passwordBreachCheckTimeoutMs+                },+            observabilityConfig =+              cfg0.observabilityConfig+                { metricsEnabled = fromMaybe cfg0.observabilityConfig.metricsEnabled fc.metricsEnabled,+                  requestLoggingEnabled = fromMaybe cfg0.observabilityConfig.requestLoggingEnabled fc.requestLoggingEnabled,+                  gracefulShutdownTimeoutSeconds = fromMaybe cfg0.observabilityConfig.gracefulShutdownTimeoutSeconds fc.gracefulShutdownTimeoutSeconds+                },+            webauthnConfig = mergeWebAuthn (webauthnConfig cfg0) uvFile attestationFile fc,+            mfaConfig =+              cfg0.mfaConfig+                { requireSecondFactor = fromMaybe cfg0.mfaConfig.requireSecondFactor fc.mfaRequireSecondFactor+                },+            totpConfig = mergeTotp cfg0.totpConfig fc,+            machineTokenConfig =+              cfg0.machineTokenConfig+                { machineTokenTTL = maybe cfg0.machineTokenConfig.machineTokenTTL fromIntegral fc.machineTokenTtlSeconds+                },+            oauthConfig = mergeOAuth cfg0.oauthConfig fc,+            signingKeyConfig =+              cfg0.signingKeyConfig+                { algorithm = fromMaybe cfg0.signingKeyConfig.algorithm algFile,+                  refreshIntervalSeconds =+                    fromMaybe cfg0.signingKeyConfig.refreshIntervalSeconds fc.keyRefreshIntervalSeconds,+                  allowedClockSkewSeconds =+                    fromMaybe cfg0.signingKeyConfig.allowedClockSkewSeconds fc.allowedClockSkewSeconds,+                  legacyActorUntilUnix = fc.legacyActorUntilUnix,+                  emitLegacyActor = fromMaybe False fc.emitLegacyActor+                },+            tokenTransport = fromMaybe cfg0.tokenTransport transportFile,+            cookieConfig =+              cfg0.cookieConfig+                { secure = fromMaybe cfg0.cookieConfig.secure fc.cookieSecure,+                  sameSite = fromMaybe cfg0.cookieConfig.sameSite sameSiteFile,+                  allowedOrigins = fromMaybe cfg0.cookieConfig.allowedOrigins csrfOriginsFile+                },+            defaultRoles = maybe cfg0.defaultRoles roleSet fc.defaultRoles+          }+      settings =+        ServerSettings+          { serverPort = fromMaybe 8080 fc.port,+            serverBindHost = fromMaybe "*4" fc.bindHost,+            serverMaxConnections = fromMaybe 1024 fc.maxConnections,+            serverSlowClientTimeoutSeconds = fromMaybe 30 fc.slowClientTimeoutSeconds,+            serverConnStr = fromMaybe "" fc.databaseUrl,+            serverTrustedProxies = trustedProxiesFile,+            serverProxyProtocol = fromMaybe ProxyProtocolOff proxyProtocolFile,+            serverDbPoolSize = fromMaybe defaultDbPoolSize fc.dbPoolSize,+            serverDbPoolAcquisitionTimeoutMs =+              fromMaybe defaultDbPoolAcquisitionTimeoutMs fc.dbPoolAcquisitionTimeoutMs,+            serverDbStatementTimeoutMs =+              fromMaybe defaultDbStatementTimeoutMs fc.dbStatementTimeoutMs,+            serverDbTransactionMaxAttempts = fromMaybe 3 fc.dbTransactionMaxAttempts,+            serverDbTransactionDeadlineMs = fromMaybe 5000 fc.dbTransactionDeadlineMs,+            serverNotifierQueueSize = fromMaybe defaultNotifierQueueSize fc.notifierQueueSize,+            serverWarnings = [],+            serverSweep = mergeSweep defaultSweepSettings fc,+            serverArgon2 = mergeArgon2 defaultArgon2Params fc,+            serverHashingMaxConcurrency =+              fromMaybe defaultHashingMaxConcurrency fc.hashingMaxConcurrency+          }+  pure (cfg, settings)++-- | Apply the optional @argon2*@ fields of a decoded Dhall 'FileConfig' onto the Argon2+-- defaults. Constructed in full rather than record-updated, for the same+-- @-Wambiguous-fields@ reason as 'mergeSweep'.+mergeArgon2 :: Argon2Params -> FileConfig -> Argon2Params+mergeArgon2 base fc =+  Argon2Params+    { memoryKiB = fromMaybe base.memoryKiB fc.argon2MemoryKiB,+      iterations = fromMaybe base.iterations fc.argon2Iterations,+      parallelism = fromMaybe base.parallelism fc.argon2Parallelism+    }++-- | Apply the optional @sweep*@ / @*RetentionDays@ fields of a decoded Dhall 'FileConfig' onto+-- the sweeper defaults. A non-positive @authEventRetentionDays@ means "retain forever", the+-- same as omitting it — there is no other way to spell "disable" for a 'Maybe' field, and an+-- operator who writes @0@ plainly means "do not delete audit history".+--+-- 'SweepSettings' is constructed in full rather than record-updated: 'FileConfig' shares most+-- of these field names, and under @DuplicateRecordFields@ an update would rely on type-directed+-- disambiguation (a @-Wambiguous-fields@ warning, and a mechanism GHC plans to drop). Naming+-- the constructor resolves the fields unambiguously.+mergeSweep :: SweepSettings -> FileConfig -> SweepSettings+mergeSweep base fc =+  SweepSettings+    { sweepEnabled = fromMaybe base.sweepEnabled fc.sweepEnabled,+      sweepIntervalSeconds = fromMaybe base.sweepIntervalSeconds fc.sweepIntervalSeconds,+      sweepBatchSize = fromMaybe base.sweepBatchSize fc.sweepBatchSize,+      sweepDeadSessionGraceDays = fromMaybe base.sweepDeadSessionGraceDays fc.sweepDeadSessionGraceDays,+      sweepOneTimeTokenGraceDays = fromMaybe base.sweepOneTimeTokenGraceDays fc.sweepOneTimeTokenGraceDays,+      sweepCeremonyGraceMinutes = fromMaybe base.sweepCeremonyGraceMinutes fc.sweepCeremonyGraceMinutes,+      sweepLoginAttemptRetentionDays = fromMaybe base.sweepLoginAttemptRetentionDays fc.loginAttemptRetentionDays,+      sweepAuthEventRetentionDays = maybe base.sweepAuthEventRetentionDays positiveOrForever fc.authEventRetentionDays+    }++-- | A retention window of zero or fewer days disables deletion rather than deleting everything.+positiveOrForever :: Int -> Maybe Int+positiveOrForever n = if n > 0 then Just n else Nothing++-- Env overrides --------------------------------------------------------------++overlayFromEnvBoth :: ShomeiConfig -> ServerSettings -> IO (ShomeiConfig, ServerSettings)+overlayFromEnvBoth baseCfg baseSettings = do+  connStr <- textEnv "PG_CONNECTION_STRING" baseSettings.serverConnStr+  portV <- intEnv "SHOMEI_PORT" baseSettings.serverPort+  host <- textEnv "SHOMEI_BIND_HOST" baseSettings.serverBindHost+  connections <- intEnv "SHOMEI_MAX_CONNECTIONS" baseSettings.serverMaxConnections+  slowTimeout <- intEnv "SHOMEI_SLOW_CLIENT_TIMEOUT_SECONDS" baseSettings.serverSlowClientTimeoutSeconds+  trustedProxyOverride <- trustedProxiesEnv+  trustedProxies <- maybe (pure baseSettings.serverTrustedProxies) parseTrustedProxyList trustedProxyOverride+  proxyProtocol <- proxyProtocolEnv baseSettings.serverProxyProtocol+  poolSize <- intEnv "SHOMEI_DB_POOL_SIZE" baseSettings.serverDbPoolSize+  poolTimeout <- intEnv "SHOMEI_DB_POOL_ACQUISITION_TIMEOUT_MS" baseSettings.serverDbPoolAcquisitionTimeoutMs+  statementTimeout <- intEnv "SHOMEI_DB_STATEMENT_TIMEOUT_MS" baseSettings.serverDbStatementTimeoutMs+  transactionAttempts <- intEnv "SHOMEI_DB_TRANSACTION_MAX_ATTEMPTS" baseSettings.serverDbTransactionMaxAttempts+  transactionDeadline <- intEnv "SHOMEI_DB_TRANSACTION_DEADLINE_MS" baseSettings.serverDbTransactionDeadlineMs+  notifierQueueSize <- intEnv "SHOMEI_NOTIFIER_QUEUE_SIZE" baseSettings.serverNotifierQueueSize+  sweep <- overlaySweepFromEnv baseSettings.serverSweep+  argon2 <- overlayArgon2FromEnv baseSettings.serverArgon2+  hashingConcurrency <- intEnv "SHOMEI_HASHING_MAX_CONCURRENCY" baseSettings.serverHashingMaxConcurrency+  iss <- textEnv "SHOMEI_ISSUER" (issuerText baseCfg.issuer)+  aud <- textEnv "SHOMEI_AUDIENCE" (audienceText baseCfg.audience)+  requireStringOrUri "SHOMEI_ISSUER" "issuer" iss+  requireStringOrUri "SHOMEI_AUDIENCE" "audience" aud+  cfg <- overlayCoreFromEnv baseCfg {issuer = Issuer iss, audience = Audience aud}+  let WebAuthnConfig {origins = originList} = cfg.webauthnConfig+  when (null originList) $+    ioError+      ( userError+          "SHOMEI_WEBAUTHN_ORIGINS (Dhall field webauthnOrigins) must list at least one origin; an empty list would fail every passkey ceremony"+      )+  when (Text.null connStr) (ioError (userError "PG_CONNECTION_STRING is not set (and no databaseUrl in the Dhall config)"))+  -- Validated after the overlay so a bad value fails the boot whichever layer supplied it.+  -- A zero-size pool deadlocks every request and a zero acquisition timeout fails every+  -- checkout, so neither is a survivable "disable" setting: refuse to start.+  when (Text.null (Text.strip host)) (ioError (userError "SHOMEI_BIND_HOST (Dhall field bindHost) must be non-empty"))+  requirePositive "SHOMEI_MAX_CONNECTIONS" "maxConnections" connections+  requirePositive "SHOMEI_SLOW_CLIENT_TIMEOUT_SECONDS" "slowClientTimeoutSeconds" slowTimeout+  when (slowTimeout > maxBound `div` 1000000) (ioError (userError "SHOMEI_SLOW_CLIENT_TIMEOUT_SECONDS is not representable in microseconds"))+  requirePositive "SHOMEI_DB_POOL_SIZE" "dbPoolSize" poolSize+  requirePositive "SHOMEI_DB_POOL_ACQUISITION_TIMEOUT_MS" "dbPoolAcquisitionTimeoutMs" poolTimeout+  requireNonNegative "SHOMEI_DB_STATEMENT_TIMEOUT_MS" "dbStatementTimeoutMs" statementTimeout+  requirePositive "SHOMEI_DB_TRANSACTION_MAX_ATTEMPTS" "dbTransactionMaxAttempts" transactionAttempts+  requirePositive "SHOMEI_DB_TRANSACTION_DEADLINE_MS" "dbTransactionDeadlineMs" transactionDeadline+  when (transactionDeadline > min 2147483647 (maxBound `div` 1000)) (ioError (userError "SHOMEI_DB_TRANSACTION_DEADLINE_MS is not representable"))+  requirePositive "SHOMEI_NOTIFIER_QUEUE_SIZE" "notifierQueueSize" notifierQueueSize+  -- A zero interval would spin the sweeper; a zero batch size would make it delete nothing+  -- forever. Neither is a survivable "disable" setting — sweepEnabled=false is.+  requirePositive "SHOMEI_SWEEP_INTERVAL_SECONDS" "sweepIntervalSeconds" sweep.sweepIntervalSeconds+  requirePositive "SHOMEI_SWEEP_BATCH_SIZE" "sweepBatchSize" sweep.sweepBatchSize+  requirePositive "SHOMEI_LOGIN_ATTEMPT_RETENTION_DAYS" "loginAttemptRetentionDays" sweep.sweepLoginAttemptRetentionDays+  -- Grace periods may legitimately be zero ("sweep as soon as it expires"), only not negative,+  -- which would sweep rows that have not expired yet.+  requireNonNegative "SHOMEI_SWEEP_DEAD_SESSION_GRACE_DAYS" "sweepDeadSessionGraceDays" sweep.sweepDeadSessionGraceDays+  requireNonNegative "SHOMEI_SWEEP_ONE_TIME_TOKEN_GRACE_DAYS" "sweepOneTimeTokenGraceDays" sweep.sweepOneTimeTokenGraceDays+  requireNonNegative "SHOMEI_SWEEP_CEREMONY_GRACE_MINUTES" "sweepCeremonyGraceMinutes" sweep.sweepCeremonyGraceMinutes+  -- crypton rejects non-positive Argon2 costs with a CryptoFailed deep inside a login; a+  -- boot-time message naming the variable is kinder.+  requirePositive "SHOMEI_ARGON2_MEMORY_KIB" "argon2MemoryKiB" argon2.memoryKiB+  requirePositive "SHOMEI_ARGON2_ITERATIONS" "argon2Iterations" argon2.iterations+  requirePositive "SHOMEI_ARGON2_PARALLELISM" "argon2Parallelism" argon2.parallelism+  for_ (argon2HardFloor argon2) \why ->+    ioError+      ( userError+          ( "SHOMEI_ARGON2_MEMORY_KIB/SHOMEI_ARGON2_ITERATIONS/SHOMEI_ARGON2_PARALLELISM "+              <> "(Dhall fields argon2MemoryKiB/argon2Iterations/argon2Parallelism) are rejected "+              <> "by the Argon2 implementation: "+              <> Text.unpack why+          )+      )+  -- Zero permits would block every login forever.+  requirePositive "SHOMEI_HASHING_MAX_CONCURRENCY" "hashingMaxConcurrency" hashingConcurrency+  requireNonNegative+    "SHOMEI_ALLOWED_CLOCK_SKEW_SECONDS"+    "allowedClockSkewSeconds"+    cfg.signingKeyConfig.allowedClockSkewSeconds+  let rate = cfg.rateLimitConfig+  requirePositive "SHOMEI_MAX_FAILED_LOGINS_PER_ACCOUNT" "maxFailedLoginsPerAccount" rate.maxFailedLoginsPerAccount+  requirePositive "SHOMEI_MAX_FAILED_LOGINS_PER_IP" "maxFailedLoginsPerIp" rate.maxFailedLoginsPerIp+  requirePositive "SHOMEI_PER_IP_REQUESTS_PER_MINUTE" "perIpRequestsPerMinute" rate.perIpRequestsPerMinute+  requirePositive "SHOMEI_PER_IP_BURST" "perIpBurst" rate.perIpBurst+  when (rate.lockoutWindow <= 0) $+    ioError (userError "SHOMEI_LOCKOUT_WINDOW_SECONDS (Dhall field lockoutWindowSeconds) must be a positive number of seconds")+  when (rate.lockoutDuration <= 0) $+    ioError (userError "SHOMEI_LOCKOUT_DURATION_SECONDS (Dhall field lockoutDurationSeconds) must be a positive number of seconds")+  -- Validated after the overlay so a selected notifier transport is proven fully configured+  -- whichever layer supplied its fields (secrets always come from the environment).+  notifierWarnings <- validateNotifierConfig cfg.notifierConfig+  let warnings = notifierWarnings <> cookieTransportWarnings cfg+  pure+    ( cfg,+      ServerSettings+        { serverPort = portV,+          serverBindHost = host,+          serverMaxConnections = connections,+          serverSlowClientTimeoutSeconds = slowTimeout,+          serverConnStr = connStr,+          serverTrustedProxies = trustedProxies,+          serverProxyProtocol = proxyProtocol,+          serverDbPoolSize = poolSize,+          serverDbPoolAcquisitionTimeoutMs = poolTimeout,+          serverDbStatementTimeoutMs = statementTimeout,+          serverDbTransactionMaxAttempts = transactionAttempts,+          serverDbTransactionDeadlineMs = transactionDeadline,+          serverNotifierQueueSize = notifierQueueSize,+          serverWarnings = warnings,+          serverSweep = sweep,+          serverArgon2 = argon2,+          serverHashingMaxConcurrency = hashingConcurrency+        }+    )+  where+    issuerText (Issuer t) = t+    audienceText (Audience t) = t+    requirePositive = requireBound (> 0) "a positive integer"+    requireNonNegative = requireBound (>= 0) "a non-negative integer"+    requireStringOrUri envName dhallField value =+      case checkStringOrUri value of+        Right () -> pure ()+        Left reason ->+          ioError+            ( userError+                ( Text.unpack envName+                    <> " (Dhall field "+                    <> Text.unpack dhallField+                    <> ") "+                    <> Text.unpack reason+                    <> ", got "+                    <> show value+                )+            )+    requireBound ok expected envName dhallField n =+      unless (ok n) do+        ioError+          ( userError+              ( Text.unpack envName+                  <> " (Dhall field "+                  <> Text.unpack dhallField+                  <> ") must be "+                  <> expected+                  <> ", got "+                  <> show n+              )+          )++-- | Overlay the @SHOMEI_ARGON2_*@ environment variables onto the Argon2 cost parameters.+-- These affect only newly hashed passwords; see 'Shomei.Account.Password.Hash.Postgres.hashPasswordArgon2id'.+overlayArgon2FromEnv :: Argon2Params -> IO Argon2Params+overlayArgon2FromEnv base = do+  mem <- intEnvMaybe "SHOMEI_ARGON2_MEMORY_KIB"+  iters <- intEnvMaybe "SHOMEI_ARGON2_ITERATIONS"+  lanes <- intEnvMaybe "SHOMEI_ARGON2_PARALLELISM"+  pure+    Argon2Params+      { memoryKiB = fromMaybe base.memoryKiB mem,+        iterations = fromMaybe base.iterations iters,+        parallelism = fromMaybe base.parallelism lanes+      }++-- | Overlay the @SHOMEI_SWEEP_*@ / @SHOMEI_*_RETENTION_DAYS@ environment variables onto the+-- sweeper settings. As on the Dhall path, a non-positive @SHOMEI_AUTH_EVENT_RETENTION_DAYS@+-- means "retain forever" — that is how an operator turns audit deletion back off without+-- editing the config file.+overlaySweepFromEnv :: SweepSettings -> IO SweepSettings+overlaySweepFromEnv base = do+  enabled <- boolEnv "SHOMEI_SWEEP_ENABLED"+  interval <- intEnvMaybe "SHOMEI_SWEEP_INTERVAL_SECONDS"+  batch <- intEnvMaybe "SHOMEI_SWEEP_BATCH_SIZE"+  deadSession <- intEnvMaybe "SHOMEI_SWEEP_DEAD_SESSION_GRACE_DAYS"+  oneTimeToken <- intEnvMaybe "SHOMEI_SWEEP_ONE_TIME_TOKEN_GRACE_DAYS"+  ceremony <- intEnvMaybe "SHOMEI_SWEEP_CEREMONY_GRACE_MINUTES"+  loginAttempts <- intEnvMaybe "SHOMEI_LOGIN_ATTEMPT_RETENTION_DAYS"+  authEvents <- intEnvMaybe "SHOMEI_AUTH_EVENT_RETENTION_DAYS"+  pure+    SweepSettings+      { sweepEnabled = fromMaybe base.sweepEnabled enabled,+        sweepIntervalSeconds = fromMaybe base.sweepIntervalSeconds interval,+        sweepBatchSize = fromMaybe base.sweepBatchSize batch,+        sweepDeadSessionGraceDays = fromMaybe base.sweepDeadSessionGraceDays deadSession,+        sweepOneTimeTokenGraceDays = fromMaybe base.sweepOneTimeTokenGraceDays oneTimeToken,+        sweepCeremonyGraceMinutes = fromMaybe base.sweepCeremonyGraceMinutes ceremony,+        sweepLoginAttemptRetentionDays = fromMaybe base.sweepLoginAttemptRetentionDays loginAttempts,+        sweepAuthEventRetentionDays = maybe base.sweepAuthEventRetentionDays positiveOrForever authEvents+      }++overlayCoreFromEnv :: ShomeiConfig -> IO ShomeiConfig+overlayCoreFromEnv base = do+  acc <- ttlEnv "SHOMEI_ACCESS_TTL"+  ref <- ttlEnv "SHOMEI_REFRESH_TTL"+  ses <- ttlEnv "SHOMEI_SESSION_TTL"+  rememberedSes <- ttlEnv "SHOMEI_REMEMBERED_SESSION_TTL"+  activeSessionCap <- intEnvMaybe "SHOMEI_MAX_ACTIVE_NON_INTERACTIVE_SESSIONS"+  let activeCap = fromMaybe base.maxActiveNonInteractiveSessions activeSessionCap+  when (activeCap < 1) (ioError (userError "SHOMEI_MAX_ACTIVE_NON_INTERACTIVE_SESSIONS (Dhall field maxActiveNonInteractiveSessions) must be positive"))+  passkeyCap <- intEnvMaybe "SHOMEI_MAX_PASSKEYS_PER_USER"+  let cap = fromMaybe base.maxPasskeysPerUser passkeyCap+  when (cap < 1 || cap > 100) (ioError (userError "SHOMEI_MAX_PASSKEYS_PER_USER (Dhall field maxPasskeysPerUser) must be between 1 and 100"))+  tr <- transportEnv+  sc <- sessionCheckEnv+  wa <- overlayWebAuthnFromEnv base.webauthnConfig+  mfaRequired <- boolEnv "SHOMEI_MFA_REQUIRE_SECOND_FACTOR"+  totpCfg <- overlayTotpFromEnv base.totpConfig+  machineTokenTtl <- ttlEnv "SHOMEI_MACHINE_TOKEN_TTL"+  oauthCfg <- overlayOAuthFromEnv base.oauthConfig+  pwMin <- intEnvMaybe "SHOMEI_PASSWORD_MIN_LENGTH"+  pwMax <- intEnvMaybe "SHOMEI_PASSWORD_MAX_LENGTH"+  pwRejCommon <- boolEnv "SHOMEI_PASSWORD_REJECT_COMMON"+  pwRejCtx <- boolEnv "SHOMEI_PASSWORD_REJECT_CONTEXTUAL"+  pwBreach <- boolEnv "SHOMEI_PASSWORD_BREACH_CHECK"+  pwBreachFC <- boolEnv "SHOMEI_PASSWORD_BREACH_FAIL_CLOSED"+  pwBreachTo <- intEnvMaybe "SHOMEI_PASSWORD_BREACH_TIMEOUT_MS"+  alg <- signingAlgEnv+  keyRefresh <- keyRefreshIntervalEnv+  clockSkew <- clockSkewEnv+  actorUntil <- intEnvMaybe "SHOMEI_LEGACY_ACTOR_UNTIL_UNIX"+  legacyEmission <- boolEnv "SHOMEI_EMIT_LEGACY_ACTOR"+  let deadline = actorUntil <|> base.signingKeyConfig.legacyActorUntilUnix+      emitLegacy = fromMaybe base.signingKeyConfig.emitLegacyActor legacyEmission+  for_ deadline \value -> when (value <= 0) (ioError (userError "SHOMEI_LEGACY_ACTOR_UNTIL_UNIX (Dhall field legacyActorUntilUnix) must be a positive finite Unix timestamp"))+  when (emitLegacy && isNothing deadline) (ioError (userError "SHOMEI_EMIT_LEGACY_ACTOR requires SHOMEI_LEGACY_ACTOR_UNTIL_UNIX or legacyActorUntilUnix"))+  -- Deliberately env-only, with no Dhall-file field: logging raw one-time tokens must be an+  -- explicit per-process decision, not something that lingers unnoticed in a committed file.+  logSecrets <- boolEnv "SHOMEI_NOTIFIER_LOG_SECRETS"+  notifierCfg <- overlayNotifierFromEnv base.notifierConfig logSecrets+  rateLimitEnabled' <- boolEnv "SHOMEI_RATE_LIMIT_ENABLED"+  maxFailedLoginsPerAccount' <- intEnvMaybe "SHOMEI_MAX_FAILED_LOGINS_PER_ACCOUNT"+  maxFailedLoginsPerIp' <- intEnvMaybe "SHOMEI_MAX_FAILED_LOGINS_PER_IP"+  perIpRequestsPerMinute' <- intEnvMaybe "SHOMEI_PER_IP_REQUESTS_PER_MINUTE"+  perIpBurst' <- intEnvMaybe "SHOMEI_PER_IP_BURST"+  lockoutWindow' <- ttlEnv "SHOMEI_LOCKOUT_WINDOW_SECONDS"+  lockoutDuration' <- ttlEnv "SHOMEI_LOCKOUT_DURATION_SECONDS"+  cookieSecure' <- boolEnv "SHOMEI_COOKIE_SECURE"+  cookieSameSite' <- sameSiteEnv+  csrfOrigins <- csrfOriginsEnv+  defaultRoles' <- defaultRolesFromEnv+  pure+    base+      { accessTokenTTL = fromMaybe base.accessTokenTTL acc,+        defaultRoles = fromMaybe base.defaultRoles defaultRoles',+        notifierConfig = notifierCfg,+        rateLimitConfig =+          base.rateLimitConfig+            { rateLimitEnabled = fromMaybe base.rateLimitConfig.rateLimitEnabled rateLimitEnabled',+              maxFailedLoginsPerAccount = fromMaybe base.rateLimitConfig.maxFailedLoginsPerAccount maxFailedLoginsPerAccount',+              maxFailedLoginsPerIp = fromMaybe base.rateLimitConfig.maxFailedLoginsPerIp maxFailedLoginsPerIp',+              lockoutWindow = fromMaybe base.rateLimitConfig.lockoutWindow lockoutWindow',+              lockoutDuration = fromMaybe base.rateLimitConfig.lockoutDuration lockoutDuration',+              perIpRequestsPerMinute = fromMaybe base.rateLimitConfig.perIpRequestsPerMinute perIpRequestsPerMinute',+              perIpBurst = fromMaybe base.rateLimitConfig.perIpBurst perIpBurst'+            },+        signingKeyConfig =+          base.signingKeyConfig+            { algorithm = fromMaybe base.signingKeyConfig.algorithm alg,+              refreshIntervalSeconds = fromMaybe base.signingKeyConfig.refreshIntervalSeconds keyRefresh,+              allowedClockSkewSeconds = fromMaybe base.signingKeyConfig.allowedClockSkewSeconds clockSkew,+              legacyActorUntilUnix = deadline,+              emitLegacyActor = emitLegacy+            },+        refreshTokenTTL = fromMaybe base.refreshTokenTTL ref,+        sessionTTL = fromMaybe base.sessionTTL ses,+        rememberedSessionTTL = fromMaybe base.rememberedSessionTTL rememberedSes,+        maxPasskeysPerUser = cap,+        maxActiveNonInteractiveSessions = activeCap,+        tokenTransport = fromMaybe base.tokenTransport tr,+        cookieConfig =+          base.cookieConfig+            { secure = fromMaybe base.cookieConfig.secure cookieSecure',+              sameSite = fromMaybe base.cookieConfig.sameSite cookieSameSite',+              allowedOrigins = fromMaybe base.cookieConfig.allowedOrigins csrfOrigins+            },+        sessionCheckMode = fromMaybe base.sessionCheckMode sc,+        webauthnConfig = wa,+        mfaConfig =+          base.mfaConfig+            { requireSecondFactor = fromMaybe base.mfaConfig.requireSecondFactor mfaRequired+            },+        totpConfig = totpCfg,+        machineTokenConfig =+          base.machineTokenConfig+            { machineTokenTTL = fromMaybe base.machineTokenConfig.machineTokenTTL machineTokenTtl+            },+        oauthConfig = oauthCfg,+        passwordPolicy =+          base.passwordPolicy+            { minLength = fromMaybe base.passwordPolicy.minLength pwMin,+              maxLength = fromMaybe base.passwordPolicy.maxLength pwMax,+              rejectCommonPasswords = fromMaybe base.passwordPolicy.rejectCommonPasswords pwRejCommon,+              rejectContextualPasswords = fromMaybe base.passwordPolicy.rejectContextualPasswords pwRejCtx,+              breachCheckEnabled = fromMaybe base.passwordPolicy.breachCheckEnabled pwBreach,+              breachCheckFailClosed = fromMaybe base.passwordPolicy.breachCheckFailClosed pwBreachFC,+              breachCheckTimeoutMs = fromMaybe base.passwordPolicy.breachCheckTimeoutMs pwBreachTo+            }+      }++-- | Apply the optional @oidc*@ \/ @oauth*@ fields of a decoded Dhall 'FileConfig' onto the+-- 'OAuthConfig' defaults. Constructed in full rather than record-updated, for the same+-- @-Wambiguous-fields@ reason as 'mergeSweep'.+mergeOAuth :: OAuthConfig -> FileConfig -> OAuthConfig+mergeOAuth base fc =+  OAuthConfig+    { oidcEnabled = fromMaybe base.oidcEnabled fc.oidcEnabled,+      loginUrl = fc.oauthLoginUrl <|> base.loginUrl,+      authorizationCodeTTL = maybe base.authorizationCodeTTL fromIntegral fc.oauthAuthorizationCodeTtlSeconds,+      idTokenTTL = maybe base.idTokenTTL fromIntegral fc.oauthIdTokenTtlSeconds+    }++-- | Apply the optional @totp*@ fields of a decoded Dhall 'FileConfig' onto the 'TotpConfig'+-- defaults. Constructed in full rather than record-updated, for the same @-Wambiguous-fields@+-- reason as 'mergeSweep'.+mergeTotp :: TotpConfig -> FileConfig -> TotpConfig+mergeTotp base fc =+  TotpConfig+    { totpEnabled = fromMaybe base.totpEnabled fc.totpEnabled,+      enrollmentTTL = maybe base.enrollmentTTL fromIntegral fc.totpEnrollmentTtlSeconds+    }++-- | Overlay the @SHOMEI_TOTP_*@ environment variables onto the TOTP policy.+overlayTotpFromEnv :: TotpConfig -> IO TotpConfig+overlayTotpFromEnv base = do+  mEnabled <- boolEnv "SHOMEI_TOTP_ENABLED"+  mTtl <- ttlEnv "SHOMEI_TOTP_ENROLLMENT_TTL"+  pure+    TotpConfig+      { totpEnabled = fromMaybe base.totpEnabled mEnabled,+        enrollmentTTL = fromMaybe base.enrollmentTTL mTtl+      }++overlayOAuthFromEnv :: OAuthConfig -> IO OAuthConfig+overlayOAuthFromEnv base = do+  mEnabled <- boolEnv "SHOMEI_OIDC_ENABLED"+  mLoginUrl <- textEnvMaybe "SHOMEI_OAUTH_LOGIN_URL"+  mCodeTtl <- ttlEnv "SHOMEI_OAUTH_CODE_TTL"+  mIdTtl <- ttlEnv "SHOMEI_OAUTH_ID_TOKEN_TTL"+  pure+    OAuthConfig+      { oidcEnabled = fromMaybe base.oidcEnabled mEnabled,+        loginUrl = mLoginUrl <|> base.loginUrl,+        authorizationCodeTTL = fromMaybe base.authorizationCodeTTL mCodeTtl,+        idTokenTTL = fromMaybe base.idTokenTTL mIdTtl+      }++-- Notifier transport (EP-8) ---------------------------------------------------++-- | Conventional per-attempt defaults for the notifier transports. Missing scalar fields fall+-- back to these; they match the defaults documented on 'SmtpConfig'/'WebhookConfig'.+defaultSmtpTimeoutSeconds :: Int+defaultSmtpTimeoutSeconds = 10++defaultWebhookTimeoutSeconds :: Int+defaultWebhookTimeoutSeconds = 5++defaultWebhookMaxAttempts :: Int+defaultWebhookMaxAttempts = 3++-- | @log@ | @smtp@ | @webhook@. @label@ names the source in the error.+parseNotifierTransport :: Text -> Text -> IO NotifierTransport+parseNotifierTransport label t = case Text.toLower (Text.strip t) of+  "log" -> pure LogNotifier+  "smtp" -> pure SmtpNotifier+  "webhook" -> pure WebhookNotifier+  other -> ioError (userError (Text.unpack label <> " must be log|smtp|webhook, got " <> Text.unpack other))++-- | @plain@ (lab only) | @starttls@ | @implicit@. Accepts a couple of common spellings.+parseSmtpTlsMode :: Text -> Text -> IO SmtpTlsMode+parseSmtpTlsMode label t = case Text.toLower (Text.strip t) of+  "plain" -> pure SmtpPlain+  "starttls" -> pure SmtpStartTls+  "start-tls" -> pure SmtpStartTls+  "implicit" -> pure SmtpImplicitTls+  "implicit-tls" -> pure SmtpImplicitTls+  "tls" -> pure SmtpImplicitTls+  other -> ioError (userError (Text.unpack label <> " must be plain|starttls|implicit, got " <> Text.unpack other))++notifierTransportEnv :: IO (Maybe NotifierTransport)+notifierTransportEnv = do+  m <- lookupEnv "SHOMEI_NOTIFIER_TRANSPORT"+  case m of+    Nothing -> pure Nothing+    Just "" -> pure Nothing+    Just s -> Just <$> parseNotifierTransport "SHOMEI_NOTIFIER_TRANSPORT" (Text.pack s)++smtpTlsModeEnv :: IO (Maybe SmtpTlsMode)+smtpTlsModeEnv = do+  m <- lookupEnv "SHOMEI_SMTP_TLS_MODE"+  case m of+    Nothing -> pure Nothing+    Just "" -> pure Nothing+    Just s -> Just <$> parseSmtpTlsMode "SHOMEI_SMTP_TLS_MODE" (Text.pack s)++-- | Build a partial 'SmtpConfig' from the Dhall file's flat @smtp*@ fields, whenever any is+-- present. Credentials never enter this record. Missing scalars take their conventional defaults+-- (port 587, STARTTLS, 10 s); completeness is validated at boot.+smtpFromFile :: Maybe SmtpTlsMode -> FileConfig -> Maybe SmtpConfig+smtpFromFile tls fc+  | anyPresent =+      Just+        SmtpConfig+          { host = fromMaybe "" fc.smtpHost,+            port = fromMaybe 587 fc.smtpPort,+            tlsMode = fromMaybe SmtpStartTls tls,+            username = fc.smtpUsername,+            fromAddress = fromMaybe "" fc.smtpFromAddress,+            timeoutSeconds = fromMaybe defaultSmtpTimeoutSeconds fc.smtpTimeoutSeconds+          }+  | otherwise = Nothing+  where+    anyPresent =+      isJust fc.smtpHost+        || isJust fc.smtpPort+        || isJust tls+        || isJust fc.smtpUsername+        || isJust fc.smtpFromAddress+        || isJust fc.smtpTimeoutSeconds++-- | Build a partial 'WebhookConfig' from the Dhall file's flat @webhook*@ fields. The signing+-- secret never enters this record.+webhookFromFile :: FileConfig -> Maybe WebhookConfig+webhookFromFile fc+  | anyPresent =+      Just+        WebhookConfig+          { url = fromMaybe "" fc.webhookUrl,+            timeoutSeconds = fromMaybe defaultWebhookTimeoutSeconds fc.webhookTimeoutSeconds,+            maxAttempts = fromMaybe defaultWebhookMaxAttempts fc.webhookMaxAttempts+          }+  | otherwise = Nothing+  where+    anyPresent = isJust fc.webhookUrl || isJust fc.webhookTimeoutSeconds || isJust fc.webhookMaxAttempts++-- | Overlay the @SHOMEI_NOTIFIER_*@ / @SHOMEI_SMTP_*@ / @SHOMEI_WEBHOOK_*@ environment variables+-- onto the notifier policy the Dhall file produced. @logSecrets@ is the already-read+-- @SHOMEI_NOTIFIER_LOG_SECRETS@ (env-only; see 'overlayCoreFromEnv').+overlayNotifierFromEnv :: NotifierConfig -> Maybe Bool -> IO NotifierConfig+overlayNotifierFromEnv base logSecrets = do+  transport <- notifierTransportEnv+  alsoLog <- boolEnv "SHOMEI_NOTIFIER_ALSO_LOG"+  emailVerification <- boolEnv "SHOMEI_EMAIL_VERIFICATION_REQUIRED"+  publicBaseUrl' <- textEnvMaybe "SHOMEI_PUBLIC_BASE_URL"+  smtp <- overlaySmtpFromEnv base.smtpConfig+  webhook <- overlayWebhookFromEnv base.webhookConfig+  pure+    base+      { logRawTokens = fromMaybe base.logRawTokens logSecrets,+        emailVerificationRequired = fromMaybe base.emailVerificationRequired emailVerification,+        notifierTransport = fromMaybe base.notifierTransport transport,+        alsoLogNotifications = fromMaybe base.alsoLogNotifications alsoLog,+        publicBaseUrl = fromMaybe base.publicBaseUrl publicBaseUrl',+        smtpConfig = smtp,+        webhookConfig = webhook+      }++-- | Overlay the non-secret SMTP environment variables onto the file-supplied 'SmtpConfig' (or+-- build one if the environment supplies settings). The password is loaded separately into the+-- runtime-only 'NotifierSecrets'.+overlaySmtpFromEnv :: Maybe SmtpConfig -> IO (Maybe SmtpConfig)+overlaySmtpFromEnv base = do+  host <- textEnvMaybe "SHOMEI_SMTP_HOST"+  port <- intEnvMaybe "SHOMEI_SMTP_PORT"+  tls <- smtpTlsModeEnv+  username <- textEnvMaybe "SHOMEI_SMTP_USERNAME"+  fromAddr <- textEnvMaybe "SHOMEI_SMTP_FROM"+  timeout <- intEnvMaybe "SHOMEI_SMTP_TIMEOUT"+  let anyEnv =+        isJust host+          || isJust port+          || isJust tls+          || isJust username+          || isJust fromAddr+          || isJust timeout+  case base of+    Nothing | not anyEnv -> pure Nothing+    _ ->+      let SmtpConfig+            { host = bHost,+              port = bPort,+              tlsMode = bTls,+              username = bUser,+              fromAddress = bFrom,+              timeoutSeconds = bTimeout+            } = fromMaybe emptySmtp base+       in pure+            ( Just+                SmtpConfig+                  { host = fromMaybe bHost host,+                    port = fromMaybe bPort port,+                    tlsMode = fromMaybe bTls tls,+                    username = username <|> bUser,+                    fromAddress = fromMaybe bFrom fromAddr,+                    timeoutSeconds = fromMaybe bTimeout timeout+                  }+            )+  where+    emptySmtp =+      SmtpConfig+        { host = "",+          port = 587,+          tlsMode = SmtpStartTls,+          username = Nothing,+          fromAddress = "",+          timeoutSeconds = defaultSmtpTimeoutSeconds+        }++-- | Overlay the non-secret webhook environment variables onto the file-supplied 'WebhookConfig'+-- (or build one from the environment). The signing secret is loaded separately into+-- runtime-only 'NotifierSecrets'.+overlayWebhookFromEnv :: Maybe WebhookConfig -> IO (Maybe WebhookConfig)+overlayWebhookFromEnv base = do+  url <- textEnvMaybe "SHOMEI_WEBHOOK_URL"+  timeout <- intEnvMaybe "SHOMEI_WEBHOOK_TIMEOUT"+  maxAttempts <- intEnvMaybe "SHOMEI_WEBHOOK_MAX_ATTEMPTS"+  let anyEnv = isJust url || isJust timeout || isJust maxAttempts+  case base of+    Nothing | not anyEnv -> pure Nothing+    _ ->+      let WebhookConfig+            { url = bUrl,+              timeoutSeconds = bTimeout,+              maxAttempts = bMax+            } = fromMaybe emptyWebhook base+       in pure+            ( Just+                WebhookConfig+                  { url = fromMaybe bUrl url,+                    timeoutSeconds = fromMaybe bTimeout timeout,+                    maxAttempts = fromMaybe bMax maxAttempts+                  }+            )+  where+    emptyWebhook =+      WebhookConfig+        { url = "",+          timeoutSeconds = defaultWebhookTimeoutSeconds,+          maxAttempts = defaultWebhookMaxAttempts+        }++-- | Load credential material into a runtime-only value after the printable config is complete.+-- Values are stripped, and selected transports fail closed if their credential pair is partial.+loadNotifierSecretsFromEnv :: ShomeiConfig -> IO NotifierSecrets+loadNotifierSecretsFromEnv cfg = do+  smtpSecret <- fmap SmtpPassword <$> textEnvMaybe "SHOMEI_SMTP_PASSWORD"+  webhookSigningSecret <- fmap WebhookSecret <$> textEnvMaybe "SHOMEI_WEBHOOK_SECRET"+  case cfg.notifierConfig.notifierTransport of+    LogNotifier -> pure ()+    SmtpNotifier -> do+      let hasUsername = maybe False (isJust . (.username)) cfg.notifierConfig.smtpConfig+          hasPassword = isJust smtpSecret+      when (hasUsername /= hasPassword) $+        failWith+          "SMTP username and password must be set together (SHOMEI_SMTP_USERNAME / SHOMEI_SMTP_PASSWORD): both for an authenticated relay, or neither for a lab sink"+    WebhookNotifier ->+      when (isNothing webhookSigningSecret) $+        failWith "notifier transport webhook requires a non-empty SHOMEI_WEBHOOK_SECRET"+  pure NotifierSecrets {smtpPassword = smtpSecret, webhookSecret = webhookSigningSecret}+  where+    failWith = ioError . userError++-- | Refuse incomplete or unsafe non-secret notifier settings. Lab escape hatches are env-only;+-- plaintext unauthenticated SMTP is permitted but returned as a boot warning.+validateNotifierConfig :: NotifierConfig -> IO [Text]+validateNotifierConfig nc = do+  allowInsecureWebhook <- fromMaybe False <$> boolEnv "SHOMEI_WEBHOOK_ALLOW_INSECURE"+  allowPlaintextAuth <- fromMaybe False <$> boolEnv "SHOMEI_SMTP_ALLOW_PLAINTEXT_AUTH"+  case nc.notifierTransport of+    LogNotifier -> pure []+    SmtpNotifier -> case nc.smtpConfig of+      Nothing ->+        failWith "SHOMEI_NOTIFIER_TRANSPORT=smtp requires SMTP settings (at least SHOMEI_SMTP_HOST and SHOMEI_SMTP_FROM)"+      Just sc -> do+        let SmtpConfig {host = h, fromAddress = fromA, username = u, tlsMode = tls} = sc+        when (Text.null (Text.strip h)) (failWith "notifier transport smtp requires a non-empty SMTP host (SHOMEI_SMTP_HOST / smtpHost)")+        when (Text.null (Text.strip fromA)) (failWith "notifier transport smtp requires a non-empty from address (SHOMEI_SMTP_FROM / smtpFromAddress)")+        when (Text.null (Text.strip nc.publicBaseUrl)) (failWith "notifier transport smtp requires a non-empty publicBaseUrl (the email body embeds confirm links)")+        when (tls == SmtpPlain && isJust u && not allowPlaintextAuth) $+          failWith "smtpTlsMode=plain with authentication is refused (set SHOMEI_SMTP_ALLOW_PLAINTEXT_AUTH=true for a lab relay)"+        pure+          [ if isJust u then "smtpTlsMode=plain sends mail and SMTP credentials in the clear; explicit lab override" else "smtpTlsMode=plain sends mail in the clear; lab sinks only"+          | tls == SmtpPlain+          ]+    WebhookNotifier -> case nc.webhookConfig of+      Nothing ->+        failWith "SHOMEI_NOTIFIER_TRANSPORT=webhook requires SHOMEI_WEBHOOK_URL"+      Just wc -> do+        let normalizedUrl = Text.toLower (Text.strip wc.url)+            isHttps = Text.isPrefixOf "https://" normalizedUrl+            isHttp = Text.isPrefixOf "http://" normalizedUrl+        unless (isHttps || (isHttp && allowInsecureWebhook)) $+          failWith "webhookUrl must be https:// (set SHOMEI_WEBHOOK_ALLOW_INSECURE=true for a lab receiver)"+        pure ["webhookUrl uses HTTP under SHOMEI_WEBHOOK_ALLOW_INSECURE; one-time links travel in the clear; lab receivers only" | isHttp]+  where+    failWith = ioError . userError++-- | Apply the optional @webauthn*@ fields of a decoded Dhall 'FileConfig' onto a base+-- 'WebAuthnConfig'. The base record is read via record destructuring (not @value.field@ dot+-- syntax), which the new passkey/config records do not support under @DuplicateRecordFields@+-- (MasterPlan 3, EP-1 discovery); @fc.field@ dot access on 'FileConfig' is unaffected.+mergeWebAuthn :: WebAuthnConfig -> Maybe UserVerificationPolicy -> Maybe AttestationPolicy -> FileConfig -> WebAuthnConfig+mergeWebAuthn base uvFile attestationFile fc =+  base+    { rpId = fromMaybe baseRpId fc.webauthnRpId,+      rpName = fromMaybe baseRpName fc.webauthnRpName,+      origins = fromMaybe baseOrigins fc.webauthnOrigins,+      userVerification = fromMaybe baseUv uvFile,+      attestation = fromMaybe baseAtt attestationFile,+      ceremonyTimeout = maybe baseTimeout fromIntegral fc.webauthnCeremonyTimeoutSeconds,+      pendingCeremonyTTL = maybe baseTtl fromIntegral fc.webauthnPendingCeremonyTtlSeconds+    }+  where+    WebAuthnConfig+      { rpId = baseRpId,+        rpName = baseRpName,+        origins = baseOrigins,+        userVerification = baseUv,+        attestation = baseAtt,+        ceremonyTimeout = baseTimeout,+        pendingCeremonyTTL = baseTtl+      } = base++-- | Overlay the @SHOMEI_WEBAUTHN_*@ environment variables onto the WebAuthn policy.+overlayWebAuthnFromEnv :: WebAuthnConfig -> IO WebAuthnConfig+overlayWebAuthnFromEnv base = do+  rpId' <- textEnv "SHOMEI_WEBAUTHN_RP_ID" baseRpId+  rpName' <- textEnv "SHOMEI_WEBAUTHN_RP_NAME" baseRpName+  origins' <- originsEnv baseOrigins+  uv <- uvEnv+  att <- attestationEnv+  timeout' <- ttlEnv "SHOMEI_WEBAUTHN_CEREMONY_TIMEOUT"+  ttl' <- ttlEnv "SHOMEI_WEBAUTHN_PENDING_TTL"+  pure+    base+      { rpId = rpId',+        rpName = rpName',+        origins = origins',+        userVerification = fromMaybe baseUv uv,+        attestation = fromMaybe baseAtt att,+        ceremonyTimeout = fromMaybe baseTimeout timeout',+        pendingCeremonyTTL = fromMaybe baseTtl ttl'+      }+  where+    WebAuthnConfig+      { rpId = baseRpId,+        rpName = baseRpName,+        origins = baseOrigins,+        userVerification = baseUv,+        attestation = baseAtt,+        ceremonyTimeout = baseTimeout,+        pendingCeremonyTTL = baseTtl+      } = base+    -- A comma-separated list, e.g. "https://auth.example.com,https://www.example.com".+    originsEnv def = do+      m <- lookupEnv "SHOMEI_WEBAUTHN_ORIGINS"+      pure $ case m of+        Just v | not (null v) -> filter (not . Text.null) (map Text.strip (Text.splitOn "," (Text.pack v)))+        _ -> def+    uvEnv = do+      m <- lookupEnv "SHOMEI_WEBAUTHN_USER_VERIFICATION"+      case m of+        Nothing -> pure Nothing+        Just "" -> pure Nothing+        Just s -> Just <$> parseUserVerificationPolicy "SHOMEI_WEBAUTHN_USER_VERIFICATION" (Text.pack s)+    attestationEnv = do+      m <- lookupEnv "SHOMEI_WEBAUTHN_ATTESTATION"+      case m of+        Nothing -> pure Nothing+        Just "" -> pure Nothing+        Just s -> Just <$> parseAttestationPolicy "SHOMEI_WEBAUTHN_ATTESTATION" (Text.pack s)++boolEnv :: Text -> IO (Maybe Bool)+boolEnv name = do+  m <- lookupEnv (Text.unpack name)+  case m of+    Nothing -> pure Nothing+    Just "" -> pure Nothing+    Just s -> case Text.toLower (Text.pack s) of+      "true" -> pure (Just True)+      "false" -> pure (Just False)+      _ -> ioError (userError (Text.unpack name <> " must be true|false"))++-- | Parse a WebAuthn user-verification policy from either configuration source. Unknown text is+-- a boot error: silently falling back can weaken the ceremony an operator intended to require.+parseUserVerificationPolicy :: Text -> Text -> IO UserVerificationPolicy+parseUserVerificationPolicy label t = case Text.toLower (Text.strip t) of+  "required" -> pure UVRequired+  "preferred" -> pure UVPreferred+  "discouraged" -> pure UVDiscouraged+  other -> ioError (userError (Text.unpack label <> " must be required|preferred|discouraged, got " <> Text.unpack other))++-- | Parse a WebAuthn attestation policy from either configuration source.+parseAttestationPolicy :: Text -> Text -> IO AttestationPolicy+parseAttestationPolicy label t = case Text.toLower (Text.strip t) of+  "none" -> pure AttestationNone+  "direct" -> pure AttestationDirect+  other -> ioError (userError (Text.unpack label <> " must be none|direct, got " <> Text.unpack other))++textEnv :: Text -> Text -> IO Text+textEnv name def = do+  m <- lookupEnv (Text.unpack name)+  pure $ case m of+    Just v+      | let stripped = Text.strip (Text.pack v), not (Text.null stripped) -> stripped+    _ -> def++intEnv :: Text -> Int -> IO Int+intEnv name def = do+  m <- lookupEnv (Text.unpack name)+  case m of+    Nothing -> pure def+    Just "" -> pure def+    Just s -> case readMaybe s of+      Just n -> pure n+      Nothing -> ioError (userError (Text.unpack name <> " must be an integer"))++-- | Like 'textEnv' but overlay-only: absent or empty → 'Nothing', so a caller can distinguish+-- "the operator set nothing" from "the operator set the empty string" and fall back to the+-- config-file value rather than clobbering it.+textEnvMaybe :: Text -> IO (Maybe Text)+textEnvMaybe name = do+  m <- lookupEnv (Text.unpack name)+  pure $ case m of+    Just v+      | let stripped = Text.strip (Text.pack v), not (Text.null stripped) -> Just stripped+    _ -> Nothing++-- | Like 'intEnv' but overlay-only: absent/empty → Nothing, non-integer → error.+intEnvMaybe :: Text -> IO (Maybe Int)+intEnvMaybe name = do+  m <- lookupEnv (Text.unpack name)+  case m of+    Nothing -> pure Nothing+    Just "" -> pure Nothing+    Just s -> case readMaybe s of+      Just n -> pure (Just n)+      Nothing -> ioError (userError (Text.unpack name <> " must be an integer"))++ttlEnv :: Text -> IO (Maybe NominalDiffTime)+ttlEnv name = do+  m <- lookupEnv (Text.unpack name)+  case m of+    Nothing -> pure Nothing+    Just "" -> pure Nothing+    Just s -> case readMaybe s :: Maybe Integer of+      Just n -> pure (Just (fromIntegral n))+      Nothing -> ioError (userError (Text.unpack name <> " must be an integer (seconds)"))++transportEnv :: IO (Maybe TokenTransport)+transportEnv = do+  m <- lookupEnv "SHOMEI_TOKEN_TRANSPORT"+  case m of+    Nothing -> pure Nothing+    Just "" -> pure Nothing+    Just s -> Just <$> parseTransport "SHOMEI_TOKEN_TRANSPORT" (Text.pack s)++-- | @bearer@ | @cookie@ | @both@. @label@ names the source in the error.+parseTransport :: Text -> Text -> IO TokenTransport+parseTransport label t = case Text.toLower (Text.strip t) of+  "bearer" -> pure BearerToken+  "cookie" -> pure HttpOnlyCookie+  "both" -> pure BearerAndCookie+  other -> ioError (userError (Text.unpack label <> " must be bearer|cookie|both, got " <> Text.unpack other))++-- | @strict@ | @lax@ | @none@. Rejects anything else rather than silently defaulting: a typo+-- that quietly became @Lax@ when the operator meant @None@ would break their deployment in a+-- way that looks like a browser bug.+parseSameSite :: Text -> Text -> IO SameSitePolicy+parseSameSite label t = case Text.toLower (Text.strip t) of+  "strict" -> pure SameSiteStrict+  "lax" -> pure SameSiteLax+  "none" -> pure SameSiteNone+  other -> ioError (userError (Text.unpack label <> " must be strict|lax|none, got " <> Text.unpack other))++sameSiteEnv :: IO (Maybe SameSitePolicy)+sameSiteEnv = do+  m <- lookupEnv "SHOMEI_COOKIE_SAMESITE"+  case m of+    Nothing -> pure Nothing+    Just "" -> pure Nothing+    Just s -> Just <$> parseSameSite "SHOMEI_COOKIE_SAMESITE" (Text.pack s)++parseTrustedProxyList :: [Text] -> IO TrustedProxies+parseTrustedProxyList values =+  case parseTrustedProxies values of+    Left reason -> ioError (userError (Text.unpack reason))+    Right proxies -> pure proxies++-- | A comma-separated CIDR list. An explicitly empty value clears a file-supplied list.+trustedProxiesEnv :: IO (Maybe [Text])+trustedProxiesEnv = do+  value <- lookupEnv "SHOMEI_TRUSTED_PROXIES"+  pure case value of+    Nothing -> Nothing+    Just raw ->+      Just+        ( filter+            (not . Text.null)+            (Text.strip <$> Text.splitOn "," (Text.pack raw))+        )++parseProxyProtocol :: Text -> Text -> IO ProxyProtocolMode+parseProxyProtocol label value =+  case Text.toLower (Text.strip value) of+    "none" -> pure ProxyProtocolOff+    "required" -> pure ProxyProtocolRequired+    other ->+      ioError+        ( userError+            (Text.unpack label <> " must be none|required, got " <> Text.unpack other)+        )++proxyProtocolEnv :: ProxyProtocolMode -> IO ProxyProtocolMode+proxyProtocolEnv fallback = do+  value <- lookupEnv "SHOMEI_PROXY_PROTOCOL"+  case value of+    Nothing -> pure fallback+    Just "" -> pure fallback+    Just raw -> parseProxyProtocol "SHOMEI_PROXY_PROTOCOL" (Text.pack raw)++normalizeOrigins :: [Text] -> IO [Text]+normalizeOrigins = traverse normalizeOne+  where+    normalizeOne origin =+      case normalizeOrigin origin of+        Left reason -> ioError (userError (Text.unpack reason))+        Right normalized -> pure normalized++-- | Warn when browser-cookie transport still has development-only or insecure origin policy.+cookieTransportWarnings :: ShomeiConfig -> [Text]+cookieTransportWarnings cfg+  | not (transportUsesCookies cfg.tokenTransport) = []+  | otherwise = defaultWarning <> insecureWarnings+  where+    origins = cfg.cookieConfig.allowedOrigins+    defaultWarning =+      [ "cookie transport is on with the development default csrfAllowedOrigins = [http://localhost:8080]; browsers on any other origin get 403 csrf_rejected — set SHOMEI_CSRF_ALLOWED_ORIGINS"+      | origins == defaultCookieConfig.allowedOrigins+      ]+    insecureWarnings =+      [ "csrfAllowedOrigins entry "+          <> origin+          <> " is not https; with cookieSecure the browser will not send the cookies to it"+      | origin <- origins,+        not ("https://" `Text.isPrefixOf` origin || isLocalhostOrigin origin)+      ]+    isLocalhostOrigin origin =+      case Text.stripPrefix "http://localhost" origin of+        Just "" -> True+        Just suffix+          | Just port <- Text.stripPrefix ":" suffix ->+              not (Text.null port) && Text.all isDigit port+        _ -> False++-- | A comma-separated origin allow-list, e.g. @https://app.example.com,https://admin.example.com@.+csrfOriginsEnv :: IO (Maybe [Text])+csrfOriginsEnv = do+  m <- lookupEnv "SHOMEI_CSRF_ALLOWED_ORIGINS"+  case m of+    Just v+      | not (null v) ->+          Just <$> normalizeOrigins (filter (not . Text.null) (map Text.strip (Text.splitOn "," (Text.pack v))))+    _ -> pure Nothing++-- | Read @SHOMEI_DEFAULT_ROLES@: a comma-separated role list, e.g. @member,beta-tester@, granted+-- to every new user at signup. 'Nothing' when unset or empty. The names are validated against+-- the @shomei_roles@ registry at boot (see @Shomei.Server.Boot.validateDefaultRoles@), not here.+--+-- Exported because @shomei-admin@ assembles its own minimal 'ShomeiConfig' rather than running+-- this whole loader, and @shomei-admin users create@ drives the same @signup@ workflow the HTTP+-- route does — so it must see the same default roles, or a CLI-created user would silently+-- differ from an API-created one.+defaultRolesFromEnv :: IO (Maybe (Set Role))+defaultRolesFromEnv = do+  m <- lookupEnv "SHOMEI_DEFAULT_ROLES"+  pure case m of+    Just v | not (null v) -> Just (roleSet (Text.splitOn "," (Text.pack v)))+    _ -> Nothing++-- | Trim, drop blanks, and collect role names into a set. Shared by the Dhall and env paths so+-- @"member, , staff"@ means the same thing from either.+roleSet :: [Text] -> Set Role+roleSet = Set.fromList . map Role . filter (not . Text.null) . map Text.strip++-- | Read @SHOMEI_KEY_REFRESH_INTERVAL@ (seconds between signing-key reloads; 0 disables+-- the periodic reload). Rejects a negative value, which would otherwise silently disable+-- the refresh the operator meant to tighten.+keyRefreshIntervalEnv :: IO (Maybe Int)+keyRefreshIntervalEnv = do+  m <- intEnvMaybe "SHOMEI_KEY_REFRESH_INTERVAL"+  case m of+    Just n | n < 0 -> ioError (userError "SHOMEI_KEY_REFRESH_INTERVAL must be >= 0 (0 disables the periodic reload)")+    _ -> pure m++-- | Read the JWT verifier's tolerance for exp/nbf/iat. A negative value has no+-- semantic meaning (jose treats skew as absolute), so reject it at load.+clockSkewEnv :: IO (Maybe Int)+clockSkewEnv = do+  m <- intEnvMaybe "SHOMEI_ALLOWED_CLOCK_SKEW_SECONDS"+  case m of+    Just n+      | n < 0 ->+          ioError+            ( userError+                "SHOMEI_ALLOWED_CLOCK_SKEW_SECONDS (Dhall field allowedClockSkewSeconds) must be >= 0"+            )+    _ -> pure m++-- | Read and validate @SHOMEI_SIGNING_ALG@ (@ES256@|@RS256@); absent/empty → Nothing.+signingAlgEnv :: IO (Maybe Text)+signingAlgEnv = do+  m <- lookupEnv "SHOMEI_SIGNING_ALG"+  case m of+    Nothing -> pure Nothing+    Just "" -> pure Nothing+    Just s -> Just <$> normalizeSigningAlg "SHOMEI_SIGNING_ALG" (Text.pack s)++-- | Validate a signing-algorithm string from config (file or env), erroring on+-- anything other than @ES256@/@RS256@ so a typo fails the boot loudly. @label@ names+-- the source for the error message.+normalizeSigningAlg :: Text -> Text -> IO Text+normalizeSigningAlg label t = case Text.strip t of+  "ES256" -> pure "ES256"+  "RS256" -> pure "RS256"+  other -> ioError (userError (Text.unpack label <> " must be ES256|RS256, got " <> Text.unpack other))++sessionCheckEnv :: IO (Maybe SessionCheckMode)+sessionCheckEnv = do+  m <- lookupEnv "SHOMEI_SESSION_CHECK"+  case m of+    Nothing -> pure Nothing+    Just "" -> pure Nothing+    Just "token-only" -> pure (Just VerifyTokenOnly)+    Just "token-and-session" -> pure (Just VerifyTokenAndSession)+    Just other -> ioError (userError ("SHOMEI_SESSION_CHECK must be token-only|token-and-session, got " <> other))
+ src/Shomei/Server/DatabaseError.hs view
@@ -0,0 +1,27 @@+-- | Secret-free summaries of PostgreSQL pool failures suitable for operator output and logs.+--+-- A 'UsageError' can carry the SQL text, rendered parameters, and PostgreSQL's primary message.+-- Those details may include encrypted key envelopes or other credentials and must remain inside+-- the persistence boundary.+module Shomei.Server.DatabaseError (summarizeUsageError) where++import Data.Text (Text)+import Hasql.Errors qualified as Hasql+import Shomei.Persistence.Pool.Postgres (UsageError (..))++summarizeUsageError :: UsageError -> Text+summarizeUsageError = \case+  ConnectionUsageError _ -> "could not connect to PostgreSQL"+  AcquisitionTimeoutUsageError -> "timed out acquiring a connection"+  SessionUsageError+    ( Hasql.StatementSessionError+        _+        _+        _+        _+        _+        (Hasql.ServerStatementError (Hasql.ServerError code _ _ _ _))+      ) -> "statement failed (SQLSTATE " <> code <> ")"+  SessionUsageError (Hasql.ScriptSessionError _ (Hasql.ServerError code _ _ _ _)) ->+    "statement failed (SQLSTATE " <> code <> ")"+  SessionUsageError _ -> "statement failed"
+ src/Shomei/Server/ExceptionResponse.hs view
@@ -0,0 +1,22 @@+-- | Convert exceptions that escape WAI or Warp parsing into Shōmei's public error envelope.+module Shomei.Server.ExceptionResponse+  ( problemExceptionResponse,+  )+where++import Control.Exception (SomeAsyncException, SomeException, fromException, throw)+import Network.Wai (Response)+import Network.Wai.Handler.Warp (InvalidRequest (..))+import Shomei.Servant.Error (noProblemOccurrence, pcBadRequest, pcInternal, pcPayloadTooLarge)+import Shomei.Servant.Middleware (problemResponse)++-- | Warp's exception-response hook. Asynchronous cancellation must retain its control-flow+-- meaning; every synchronous failure receives a stable, detail-free public representation.+problemExceptionResponse :: SomeException -> Response+problemExceptionResponse err+  | Just _ <- (fromException err :: Maybe SomeAsyncException) = throw err+  | Just PayloadTooLarge <- (fromException err :: Maybe InvalidRequest) =+      problemResponse pcPayloadTooLarge noProblemOccurrence+  | Just _ <- (fromException err :: Maybe InvalidRequest) =+      problemResponse pcBadRequest noProblemOccurrence+  | otherwise = problemResponse pcInternal noProblemOccurrence
+ src/Shomei/Server/Keys.hs view
@@ -0,0 +1,220 @@+-- | Loading signing-key material, and refreshing it on a live server.+--+-- 'loadKeyMaterial' is __the__ stored→live load path: it reads every publishable key+-- (active + retired) and assembles the three things the runtime needs — the private key+-- that signs new tokens, the public key set the verifier trusts, and the precomputed JWKS+-- document served at @\/.well-known\/jwks.json@. 'bootstrapKeys' wraps it with first-boot+-- key generation; 'reloadKeys' wraps it with the swap-or-keep-last-good policy the+-- periodic refresh and the @SIGHUP@ handler both use.+--+-- Publishing retired keys alongside the active one is what makes rotation zero-downtime:+-- a token signed moments before @shomei-admin keys activate@ keeps verifying until it+-- expires, here and at every downstream that fetches the JWKS.+--+-- Private key material is encrypted at rest (see "Shomei.SigningKey.Protection.Jwt"). Only the+-- __signer__ is decrypted; the verifier key set and the published JWKS are built from the+-- public column, so a missing or wrong key-encryption key can never break verification of+-- outstanding tokens; runtime startup still requires the KEK so minting is always available.+--+-- Runs over a minimal stack — just 'SigningKeyStore' + 'Clock' + 'Database' ++-- @Error AuthError@ + 'IOE' against the pool — because it must run /before/ the full+-- 'Shomei.Server.App.Env' exists (there is no key yet to build it).+module Shomei.Server.Keys+  ( LoadedKeys (..),+    loadKeyMaterial,+    bootstrapKeys,+    reloadKeys,+    publishedKids,+    loadKekFromEnv,+    loadNamedKekFromEnv,+  )+where++import Crypto.JOSE.JWK (JWK, JWKSet)+import Data.Aeson (Value (Object))+import Data.Aeson qualified as Aeson+import Data.Aeson.KeyMap qualified as KM+import Data.Bifunctor (first)+import Data.Foldable (toList)+import Data.IORef (IORef, readIORef, writeIORef)+import Data.Text qualified as Text+import Effectful (Eff, IOE, runEff, (:>))+import Effectful.Error.Static (runErrorNoCallStack)+import Shomei.Error (AuthError)+import Shomei.Persistence.Database.Postgres (runDatabasePool)+import Shomei.Persistence.Pool.Postgres (Pool)+import Shomei.Prelude+import Shomei.SigningKey.Domain (SigningAlgorithm, SigningKeyStatus (KeyActive), StoredSigningKey (..))+import Shomei.SigningKey.Jwks.Jwt (KeySet (..), jwksDocument, keySetPublicJwks)+import Shomei.SigningKey.Key.Jwt (generateSigningKeyFor, keyKid, toStoredSigningKeyFor)+import Shomei.SigningKey.Postgres (runSigningKeyStorePostgres)+import Shomei.SigningKey.Protection.Jwt+  ( KeyDecryptError (..),+    KeyEncryptionKey,+    decryptStoredSigningKey,+    keyEncryptionKeyFromBase64,+    protectStoredSigningKey,+    publicJwkFromStored,+  )+import Shomei.SigningKey.Store+  ( SigningKeyStore,+    insertSigningKey,+    listActiveSigningKeys,+    listPublishableSigningKeys,+  )+import Shomei.Time.Postgres (runClockIO)+import Shomei.Time.Store (Clock, now)+import System.Environment (lookupEnv)+import System.IO (hPutStrLn, stderr)++-- | Read @SHOMEI_KEY_ENCRYPTION_KEY@ (32 bytes, base64).+loadKekFromEnv :: IO KeyEncryptionKey+loadKekFromEnv = loadNamedKekFromEnv "SHOMEI_KEY_ENCRYPTION_KEY"++-- | Read a required KEK from the named environment variable.+loadNamedKekFromEnv :: String -> IO KeyEncryptionKey+loadNamedKekFromEnv name = do+  raw <- lookupEnv name+  case raw of+    Nothing -> fatal "is not set (32 bytes, base64: head -c 32 /dev/urandom | base64)"+    Just "" -> fatal "is empty (32 bytes, base64: head -c 32 /dev/urandom | base64)"+    Just v -> either (fatal . Text.unpack) pure (keyEncryptionKeyFromBase64 (Text.pack v))+  where+    fatal reason = ioError (userError (name <> " " <> reason))++-- | Everything derived from the signing-key table in one load: the private key that signs+-- new tokens, the public key set the verifier trusts, and the precomputed JWKS document.+-- Swapped atomically on reload — readers see the old or the new record, never a mixture.+data LoadedKeys = LoadedKeys+  { signingKey :: !JWK,+    verifierJwks :: !JWKSet,+    jwksBody :: !Value+  }++-- | Load all publishable keys and assemble 'LoadedKeys'. A corrupt key row (one whose+-- stored JWK JSON does not parse, or whose ciphertext does not authenticate) fails the+-- whole load rather than being skipped silently: publishing a key set that is missing a key+-- downstreams may still hold tokens for is exactly the outage this module exists to prevent.+loadKeyMaterial :: KeyEncryptionKey -> Pool -> IO (Either Text LoadedKeys)+loadKeyMaterial kek pool = do+  result :: Either AuthError [StoredSigningKey] <-+    runEff+      . runErrorNoCallStack+      . runDatabasePool pool+      . runClockIO+      . runSigningKeyStorePostgres+      $ listPublishableSigningKeys+  pure (either (Left . Text.pack . show) (assembleKeys kek) result)++-- | Assemble the loaded rows. Exactly one active key must exist; multiple active rows+-- fail closed even if an external writer bypassed the database invariant. Every+-- publishable key is published and trusted, the signer included.+--+-- Public material comes from @public_key_jwk@ and needs no key-encryption key; only the+-- signer's @private_key_jwk@ is decrypted.+assembleKeys :: KeyEncryptionKey -> [StoredSigningKey] -> Either Text LoadedKeys+assembleKeys kek stored = do+  publics <- traverse toPublic stored+  signerRow <-+    case [sk | sk <- stored, sk.status == KeyActive] of+      [one] -> Right one+      [] -> Left "no active signing key"+      several ->+        Left+          ( "multiple active signing keys ("+              <> Text.intercalate ", " (map (.keyId) several)+              <> ") violate shomei_signing_keys_one_active; retire all but one with shomei-admin keys retire"+          )+  signerJwk <- first (decryptError signerRow) (decryptStoredSigningKey kek signerRow)+  -- The signer's own row is in 'stored', so its public projection is in 'publics'.+  signerPub <-+    maybe (Left ("signing key " <> signerRow.keyId <> " has no public material")) Right $+      lookup signerRow.keyId [(sk.keyId, jwk) | (sk, jwk) <- publics]+  let others = [jwk | (sk, jwk) <- publics, sk.keyId /= signerRow.keyId]+  pure+    LoadedKeys+      { signingKey = signerJwk,+        verifierJwks = keySetPublicJwks (KeySet signerPub others),+        jwksBody = decodeJwks (jwksDocument (signerPub : others))+      }+  where+    toPublic sk = (\jwk -> (sk, jwk)) <$> first (publicError sk) (publicJwkFromStored sk)+    publicError sk err = "signing key " <> sk.keyId <> " has unparseable public JWK JSON: " <> err+    decryptError sk = \case+      KeyDecryptFailed ->+        "signing key "+          <> sk.keyId+          <> " did not decrypt: SHOMEI_KEY_ENCRYPTION_KEY is wrong, or the row was tampered with"+      MalformedEncryptedKey reason ->+        "signing key " <> sk.keyId <> " has a malformed encrypted private key: " <> reason+      KeyJsonInvalid reason ->+        "signing key " <> sk.keyId <> " has unparseable private JWK JSON: " <> reason+    -- jwksDocument emits a JWKSet object, so the decode cannot fail; the fallback keeps+    -- the total signature rather than partially matching on it.+    decodeJwks = fromMaybe (Object KM.empty) . Aeson.decode++-- | Establish key material at boot. Generates and persists one active key for @alg@ on+-- first boot (guarded on "no active key", so restarts reuse the existing key and+-- previously-issued tokens stay verifiable); then loads via 'loadKeyMaterial'. Unlike a+-- reload, a failure here is fatal: there is no previous material to fall back on.+bootstrapKeys :: KeyEncryptionKey -> SigningAlgorithm -> Pool -> IO LoadedKeys+bootstrapKeys kek alg pool = do+  result :: Either AuthError () <-+    runEff+      . runErrorNoCallStack+      . runDatabasePool pool+      . runClockIO+      . runSigningKeyStorePostgres+      $ ensureActiveKey kek alg+  either (ioError . userError . show) pure result+  loaded <- loadKeyMaterial kek pool+  either (ioError . userError . Text.unpack) pure loaded++-- | Generate and insert an active key for @alg@ when the store has no active key. The new+-- key is encrypted before it is persisted, so a fresh+-- deployment never writes an unencrypted private key.+ensureActiveKey :: (SigningKeyStore :> es, Clock :> es, IOE :> es) => KeyEncryptionKey -> SigningAlgorithm -> Eff es ()+ensureActiveKey kek alg = do+  active <- listActiveSigningKeys+  when (null active) do+    t <- now+    jwk <- liftIO (generateSigningKeyFor alg)+    stored <- liftIO (either (ioError . userError . Text.unpack) pure (toStoredSigningKeyFor alg t jwk))+    protected <- liftIO (protectStoredSigningKey kek stored)+    insertSigningKey protected++-- | Reload key material and swap it in. On failure keep the last good material and log to+-- stderr: an operator mistake mid-rotation (say, retiring the only active key) must not+-- take the server down — it can still verify everything it issued and still sign with the+-- stale key, which downstreams still trust. The @\/health\/ready@ probe fails meanwhile, so+-- orchestration notices.+--+-- Safe from any thread: a plain 'writeIORef' of an immutable record, so a concurrent+-- request sees the old or the new material in full, never a mixture.+reloadKeys :: KeyEncryptionKey -> Pool -> IORef LoadedKeys -> IO ()+reloadKeys kek pool ref = do+  before <- readIORef ref+  loadKeyMaterial kek pool >>= either warn (swap before)+  where+    swap before after = do+      writeIORef ref after+      -- Only announce a reload that changed something, so the steady-state log stays quiet+      -- at one reload per refresh interval.+      when (kidsOf before /= kidsOf after) do+        hPutStrLn stderr $+          "[shomei] signing keys reloaded: active="+            <> Text.unpack (keyKid after.signingKey)+            <> " published="+            <> Text.unpack (Text.intercalate "," (publishedKids after))+    warn reason =+      hPutStrLn stderr ("[shomei] key reload failed: " <> Text.unpack reason <> "; keeping previous key material")+    kidsOf ks = (keyKid ks.signingKey, publishedKids ks)++-- | The @kid@ of every key in the published JWKS document, in document order.+publishedKids :: LoadedKeys -> [Text]+publishedKids ks = case ks.jwksBody of+  Object top | Just (Aeson.Array arr) <- KM.lookup "keys" top -> mapMaybe kidOf (toList arr)+  _ -> []+  where+    kidOf (Object k) | Just (Aeson.String kid) <- KM.lookup "kid" k = Just kid+    kidOf _ = Nothing
+ src/Shomei/Server/Middleware/BodyLimit.hs view
@@ -0,0 +1,58 @@+-- | Refuse oversized request bodies before they reach a handler (EP-8).+--+-- Nothing else in the stack bounds how much a client may send: warp has no request-body size+-- setting (body limiting is a middleware concern), and Shōmei's JSON handlers happily begin+-- consuming whatever arrives. This middleware answers HTTP 413 to any request that declares a+-- @Content-Length@ above the cap, without reading a byte of the body. Bodies without a declared+-- length are metered chunk by chunk as the downstream application consumes them.+module Shomei.Server.Middleware.BodyLimit+  ( bodyLimitMiddleware,+    defaultBodyLimitBytes,+  )+where++import Control.Exception (Exception, catch, throwIO)+import Control.Monad (when)+import Data.ByteString qualified as BS+import Data.IORef (atomicModifyIORef', newIORef, readIORef, writeIORef)+import Data.Word (Word64)+import Network.Wai+  ( Middleware,+    RequestBodyLength (KnownLength),+    getRequestBodyChunk,+    requestBodyLength,+    setRequestBodyChunks,+  )+import Shomei.Servant.Error (noProblemOccurrence, pcPayloadTooLarge)+import Shomei.Servant.Middleware (problemResponse)++data BodyOverCap = BodyOverCap Word64+  deriving stock (Show)+  deriving anyclass (Exception)++-- | 1 MiB. Three orders of magnitude above the largest legitimate Shōmei request body (a+-- WebAuthn attestation), and small enough that a flood of maximal bodies cannot exhaust memory.+defaultBodyLimitBytes :: Word64+defaultBodyLimitBytes = 1024 * 1024++-- | Reject a request once its declared or observed body length is strictly greater than @limit@.+bodyLimitMiddleware :: Word64 -> Middleware+bodyLimitMiddleware limit app req respond+  | KnownLength n <- requestBodyLength req, n > limit = respond tooLarge+  | otherwise = do+      seen <- newIORef 0+      responded <- newIORef False+      let metered = do+            chunk <- getRequestBodyChunk req+            total <-+              atomicModifyIORef' seen \n ->+                let n' = n + fromIntegral (BS.length chunk)+                 in (n', n')+            when (total > limit) (throwIO (BodyOverCap limit))+            pure chunk+          respond' res = writeIORef responded True >> respond res+      app (setRequestBodyChunks metered req) respond' `catch` \e@(BodyOverCap _) -> do+        already <- readIORef responded+        if already then throwIO e else respond tooLarge+  where+    tooLarge = problemResponse pcPayloadTooLarge noProblemOccurrence
+ src/Shomei/Server/Middleware/RateLimit.hs view
@@ -0,0 +1,180 @@+-- | A per-IP request-rate limiter as a WAI 'Middleware' (EP-2, M4).+--+-- This is an in-process token bucket (an STM @TVar (HashMap ByteString Bucket)@ keyed by client+-- IP), deliberately NOT a distributed/Redis store: this plan targets a single-instance+-- deployment (see the MasterPlan Decision Log). Each bucket holds up to @capacity@ tokens and+-- refills at @refillPerSec@; a request with no token left is rejected with HTTP 429 BEFORE it+-- reaches the Servant application or the database. The limiter is scoped to the unauthenticated+-- POST endpoints (login/signup/refresh and EP-1's verify-email/password-reset request routes) so+-- authenticated traffic bearing a valid token is never throttled, and it is a no-op when+-- @rateLimitEnabled@ is False.+--+-- Distinct from the per-account brute-force lockout (which is PostgreSQL-backed and survives+-- restarts): this request-rate state is in-memory and resets on restart, which is acceptable+-- because it bounds raw request volume, not authentication failures.+--+-- == Bucket eviction (EP-4)+--+-- A bucket per client IP that is never removed is an unbounded-memory denial-of-service+-- primitive: a slow scan of the address space grows the map forever. Every @sweepEvery@+-- throttled requests, 'takeToken' therefore prunes — inside the same STM transaction it was+-- already running — every bucket that has refilled to capacity.+--+-- That policy is /semantically lossless/, which is why it needs no tuning knob: 'takeToken'+-- treats an absent key as a fresh full bucket, so a full bucket and a missing bucket are+-- indistinguishable to every subsequent request. No request that would have been throttled is+-- admitted, and none that would have been admitted is throttled. Cost is @O(size)@ once per+-- @sweepEvery@ calls, i.e. amortized @O(1)@. An idle server never prunes, which is harmless:+-- no requests means no new buckets either, so the map cannot grow while unpruned.+--+-- == Contention+--+-- All buckets live in one @TVar (HashMap ByteString Bucket)@ whose root pointer every+-- throttled request rewrites, so concurrent 'takeToken' transactions conflict and retry: the+-- limiter is a serialization point under very high concurrency. This is accepted for the+-- documented single-instance posture (throttled routes are the unauthenticated auth endpoints,+-- which are low-volume by construction, and each is about to spend ~100 ms in Argon2 anyway).+-- If it ever profiles hot, the escape hatch is to shard the map across N @TVar@s keyed by a+-- hash of the client IP; nothing outside this module observes the single-@TVar@ representation.+module Shomei.Server.Middleware.RateLimit+  ( RateLimiter,+    newRateLimiter,+    newRateLimiterFor,+    newRateLimiterWith,+    rateLimitMiddleware,+    throttledPath,+    takeToken,+    bucketCount,+  )+where++import Control.Concurrent.STM (TVar, atomically, newTVarIO, readTVar, readTVarIO, writeTVar)+import Data.ByteString (ByteString)+import Data.HashMap.Strict (HashMap)+import Data.HashMap.Strict qualified as HM+import Data.Text.Encoding (encodeUtf8)+import GHC.Clock (getMonotonicTimeNSec)+import Network.Wai (Middleware, Request, pathInfo, remoteHost, requestMethod)+import Shomei.Config (RateLimitConfig (..))+import Shomei.Servant.Api (shomeiThrottledRoutes)+import Shomei.Servant.ClientIp (clientIpText)+import Shomei.Servant.Error (pcTooManyRequests, retryAfterOccurrence)+import Shomei.Servant.Middleware (problemResponse)+import Shomei.Servant.Throttle (ThrottledRoute, matchesThrottledRoute)++-- | One bucket per client IP: current token level + last-refill time (monotonic seconds).+data Bucket = Bucket !Double !Double++data RateLimiter = RateLimiter+  { buckets :: !(TVar (HashMap ByteString Bucket)),+    -- | Counts 'takeToken' calls since the last prune; see 'sweepEvery'.+    sweepCounter :: !(TVar Int),+    -- | Prune fully-refilled buckets every this many 'takeToken' calls (always >= 1).+    sweepEvery :: !Int,+    -- | perIpBurst+    capacity :: !Double,+    -- | perIpRequestsPerMinute / 60+    refillPerSec :: !Double,+    enabled :: !Bool,+    -- | Derived once from the API's 'Shomei.Servant.PreHandler.RateLimited' markers.+    throttled :: ![ThrottledRoute]+  }++-- | How many 'takeToken' calls pass between prunes. Large enough that the @O(size)@ prune is+-- lost in the noise of the Argon2 hash the throttled request is about to perform, small enough+-- that a scanning attacker cannot accumulate many buckets between sweeps.+defaultSweepEvery :: Int+defaultSweepEvery = 4096++-- | Build a limiter from the configured policy. Buckets are created lazily per client IP and+-- pruned once they refill (see the module haddock).+newRateLimiter :: RateLimitConfig -> IO RateLimiter+newRateLimiter = newRateLimiterFor shomeiThrottledRoutes++-- | Build a limiter over an explicitly derived route set. Embedding hosts can derive this from+-- their own Servant API; the standalone server passes 'shomeiThrottledRoutes'.+newRateLimiterFor :: [ThrottledRoute] -> RateLimitConfig -> IO RateLimiter+newRateLimiterFor = newRateLimiterWithFor defaultSweepEvery++-- | 'newRateLimiter' with the prune interval given explicitly. A test seam: production wants+-- 'newRateLimiter', but a test that had to issue 4096 requests to observe one prune would be+-- measuring the wrong thing. Values below 1 are clamped to 1.+newRateLimiterWith :: Int -> RateLimitConfig -> IO RateLimiter+newRateLimiterWith every = newRateLimiterWithFor every shomeiThrottledRoutes++newRateLimiterWithFor :: Int -> [ThrottledRoute] -> RateLimitConfig -> IO RateLimiter+newRateLimiterWithFor every routes cfg = do+  tv <- newTVarIO HM.empty+  counter <- newTVarIO 0+  pure+    RateLimiter+      { buckets = tv,+        sweepCounter = counter,+        sweepEvery = max 1 every,+        capacity = fromIntegral cfg.perIpBurst,+        refillPerSec = fromIntegral cfg.perIpRequestsPerMinute / 60,+        enabled = cfg.rateLimitEnabled,+        throttled = routes+      }++-- | How many per-IP buckets the limiter is currently holding. Exposed so a test can assert the+-- map stays bounded; nothing in the server reads it.+bucketCount :: RateLimiter -> IO Int+bucketCount rl = HM.size <$> readTVarIO rl.buckets++-- | Try to take one token for @key@ at time @nowSecs@; 'True' = allowed, 'False' = rejected.+-- A new key starts with a full bucket.+--+-- Every @sweepEvery@ calls this also prunes fully-refilled buckets, in the same transaction.+-- The just-touched key survives its own sweep whenever it is not itself full — and when it is+-- full, dropping it changes nothing (see the module haddock's losslessness argument).+takeToken :: RateLimiter -> ByteString -> Double -> IO Bool+takeToken rl key nowSecs = atomically do+  m <- readTVar rl.buckets+  let Bucket lvl t0 = HM.lookupDefault (Bucket rl.capacity nowSecs) key m+      refilled = min rl.capacity (lvl + (nowSecs - t0) * rl.refillPerSec)+      allowed = refilled >= 1+      taken = if allowed then refilled - 1 else refilled+      updated = HM.insert key (Bucket taken nowSecs) m+  sinceSweep <- readTVar rl.sweepCounter+  if sinceSweep + 1 >= rl.sweepEvery+    then do+      writeTVar rl.sweepCounter 0+      writeTVar rl.buckets (HM.filter (not . fullyRefilled) updated)+    else do+      writeTVar rl.sweepCounter (sinceSweep + 1)+      writeTVar rl.buckets updated+  pure allowed+  where+    -- Would this bucket have refilled to capacity by now? Then it is indistinguishable from an+    -- absent key, and dropping it is observationally a no-op.+    fullyRefilled (Bucket lvl t0) = lvl + (nowSecs - t0) * rl.refillPerSec >= rl.capacity++-- | The WAI middleware. Passes non-throttled paths straight through.+rateLimitMiddleware :: RateLimiter -> Middleware+rateLimitMiddleware rl app req respond+  | not rl.enabled || not (throttledPath rl req) = app req respond+  | otherwise = do+      nowSecs <- monotonicSeconds+      allowed <- takeToken rl (clientKey req) nowSecs+      if allowed then app req respond else respond tooMany+  where+    -- The same RFC 9457 document every other application error path returns, with+    -- @Retry-After@. This+    -- answers before Servant ever routes the request, so it cannot go through the handler+    -- error mapping — it shares the catalog constant instead.+    tooMany = problemResponse pcTooManyRequests (retryAfterOccurrence 60)++-- | Match the request against the routes derived from the API type. Method, path length, and+-- every literal segment must agree; captures match exactly one segment.+throttledPath :: RateLimiter -> Request -> Bool+throttledPath rl req = matchesThrottledRoute rl.throttled (requestMethod req) (pathInfo req)++-- | The per-IP key: the client's host address WITHOUT the ephemeral source port (otherwise+-- each connection would get its own bucket). Behind a reverse proxy this is the proxy address; a+-- trusted @X-Forwarded-For@ policy is out of scope for this single-instance plan.+clientKey :: Request -> ByteString+clientKey = encodeUtf8 . clientIpText . remoteHost++monotonicSeconds :: IO Double+monotonicSeconds = (\ns -> fromIntegral ns / 1e9) <$> getMonotonicTimeNSec
+ src/Shomei/Server/Middleware/TrustedProxy.hs view
@@ -0,0 +1,86 @@+-- | Resolve a client address only when the immediate peer is an explicitly trusted proxy.+module Shomei.Server.Middleware.TrustedProxy+  ( TrustedProxies,+    emptyTrustedProxies,+    parseTrustedProxies,+    trustedProxyTexts,+    isTrustedPeer,+    forwardedClient,+    trustedProxyMiddleware,+  )+where++import Data.ByteString (ByteString)+import Data.ByteString.Char8 qualified as BC+import Data.IP (IP (..), IPRange (..), fromSockAddr, ipv4ToIPv6, isMatchedTo, toSockAddr)+import Data.Maybe (listToMaybe)+import Data.Text qualified as Text+import Network.Wai (Middleware, Request (..))+import Shomei.Prelude+import Text.Read (readMaybe)++newtype TrustedProxies = TrustedProxies [IPRange]+  deriving stock (Eq, Show)++emptyTrustedProxies :: TrustedProxies+emptyTrustedProxies = TrustedProxies []++trustedProxyTexts :: TrustedProxies -> [Text]+trustedProxyTexts (TrustedProxies ranges) = Text.pack . show <$> ranges++-- | Parse CIDR ranges. A bare address means a single-host @/32@ or @/128@ range.+parseTrustedProxies :: [Text] -> Either Text TrustedProxies+parseTrustedProxies = fmap TrustedProxies . traverse parseOne+  where+    parseOne raw =+      let value = Text.strip raw+          cidr+            | Text.any (== '/') value = value+            | Text.any (== ':') value = value <> "/128"+            | otherwise = value <> "/32"+       in maybe+            (Left ("trustedProxies: " <> raw <> " is not an IP address or CIDR block"))+            Right+            (readMaybe (Text.unpack cidr))++isTrustedPeer :: TrustedProxies -> IP -> Bool+isTrustedPeer (TrustedProxies ranges) ip = any (inRange ip) ranges+  where+    inRange (IPv4 address) (IPv4Range range) = address `isMatchedTo` range+    inRange (IPv6 address) (IPv6Range range) = address `isMatchedTo` range+    inRange (IPv4 address) (IPv6Range range) = ipv4ToIPv6 address `isMatchedTo` range+    inRange _ _ = False++-- | Resolve the rightmost untrusted forwarded hop. If every forwarded hop is trusted,+-- the leftmost hop is the original client. Headers are ignored unless the socket peer is trusted.+forwardedClient :: TrustedProxies -> Request -> Maybe IP+forwardedClient proxies req = do+  (peer, _) <- fromSockAddr (remoteHost req)+  guard (isTrustedPeer proxies peer)+  let hops =+        concatMap+          (mapMaybe parseHop . BC.split ',')+          [value | (name, value) <- requestHeaders req, name == "X-Forwarded-For"]+      untrusted = filter (not . isTrustedPeer proxies) hops+  case untrusted of+    [] -> listToMaybe hops+    _ -> listToMaybe (reverse untrusted)++-- | Accept the address forms emitted by common proxies: a bare address, IPv4 with a port,+-- or bracketed IPv6 with an optional port. Malformed entries are ignored.+parseHop :: ByteString -> Maybe IP+parseHop raw = readMaybe (BC.unpack address)+  where+    value = BC.strip raw+    address+      | Just rest <- BC.stripPrefix "[" value = BC.takeWhile (/= ']') rest+      | BC.count ':' value == 1 = BC.takeWhile (/= ':') value+      | otherwise = value++-- | Rewrite 'remoteHost' before downstream middleware and handlers read it.+trustedProxyMiddleware :: TrustedProxies -> Middleware+trustedProxyMiddleware proxies app req =+  app+    case forwardedClient proxies req of+      Nothing -> req+      Just ip -> req {remoteHost = toSockAddr (ip, 0)}
+ src/Shomei/Server/Observability/Logging.hs view
@@ -0,0 +1,165 @@+-- | Request-ID + structured-JSON request logging WAI 'Middleware' (EP-3, M1).+--+-- This is the OUTERMOST middleware in the server's WAI stack (IP-4): every request — including+-- any EP-2's rate limiter rejects with 429 — produces exactly one structured log line on stdout+-- carrying a correlation id. The correlation id (a short unique @request_id@) is taken from an+-- incoming @X-Request-Id@ header (sanitized to defeat log injection) or generated, and echoed+-- back in the @X-Request-Id@ response header.+--+-- Logging hygiene (a hard rule): the line is built ONLY from the request method, path, response+-- status, wall-clock duration, and the peer IP. It never reads request/response bodies or+-- sensitive headers (Authorization, Cookie), so no password, token, or cookie can leak.+--+-- Line atomicity (EP-4): a line is rendered to one /strict/ 'ByteString' by 'renderLogLine' and+-- written with a single 'BS.hPut'. A lazy write hands the handle chunk by chunk, taking and+-- releasing the handle lock each time, so a line-buffered handle may flush another thread's+-- chunk between two chunks of ours — interleaving two log lines and breaking the+-- one-JSON-object-per-line contract downstream pipelines rely on. One strict write cannot.+module Shomei.Server.Observability.Logging+  ( requestLoggingMiddleware,+    renderLogLine,+    emitLine,+    logServerError,+    serverErrorLine,+    responseLogLevel,+  )+where++import Control.Exception (SomeException)+import Data.Aeson (Value, encode, object, (.=))+import Data.Aeson.Key (Key)+import Data.Aeson.Key qualified as Key+import Data.ByteString (ByteString)+import Data.ByteString qualified as BS+import Data.ByteString.Char8 qualified as BC+import Data.ByteString.Lazy qualified as BL+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.Encoding (decodeUtf8Lenient, encodeUtf8)+import Data.UUID qualified as UUID+import Data.UUID.V4 qualified as UUIDv4+import Data.Word (Word64)+import GHC.Clock (getMonotonicTimeNSec)+import Network.HTTP.Types (Status (statusCode))+import Network.Wai+  ( Middleware,+    Request,+    mapResponseHeaders,+    rawPathInfo,+    remoteHost,+    requestHeaders,+    requestMethod,+    responseStatus,+  )+import Servant.Health.Paths (healthRawPaths)+import Shomei.Config (LogFormat (..), ObservabilityConfig (..))+import Shomei.Servant.ClientIp (clientIpText)+import System.IO (Handle, stdout)++requestLoggingMiddleware :: ObservabilityConfig -> Middleware+requestLoggingMiddleware cfg app req respond+  | not cfg.requestLoggingEnabled = app req respond+  | rawPathInfo req `elem` healthRawPaths = app req respond+  | otherwise = do+      reqId <- resolveRequestId req+      start <- getMonotonicTimeNSec+      app req \res -> do+        received <- respond (mapResponseHeaders (("X-Request-Id", reqId) :) res)+        end <- getMonotonicTimeNSec+        emit cfg.logFormat (lineFields reqId req (statusCode (responseStatus res)) (durationMs start end))+        pure received++-- | The fields every line carries, in a stable order.+lineFields :: ByteString -> Request -> Int -> Double -> [(Key, Value)]+lineFields reqId req status durMs =+  [ "level" .= responseLogLevel status,+    "msg" .= ("request" :: Text),+    "request_id" .= decodeUtf8Lenient reqId,+    "method" .= decodeUtf8Lenient (requestMethod req),+    "path" .= decodeUtf8Lenient (rawPathInfo req),+    "status" .= status,+    "duration_ms" .= durMs,+    "client_ip" .= clientIp req+  ]++emit :: LogFormat -> [(Key, Value)] -> IO ()+emit fmt fields = emitLine stdout (renderLogLine fmt fields)++-- | Render one complete log line — trailing newline included — as a strict 'ByteString'.+--+-- Pure, so the "exactly one line, and for 'LogJson' a valid JSON object" property is directly+-- testable. 'LogPlain' strips control characters (including the newline) from every rendered+-- value, which is what stops a hostile field value from forging a second log line;+-- 'LogJson' needs no such filter because the encoder escapes them.+renderLogLine :: LogFormat -> [(Key, Value)] -> ByteString+renderLogLine fmt fields = render fmt fields <> "\n"+  where+    render LogJson fs = BL.toStrict (encode (object fs))+    render LogPlain fs =+      encodeUtf8 (Text.intercalate " " [Key.toText k <> "=" <> renderVal v | (k, v) <- fs])+    renderVal v = Text.filter printable (decodeUtf8Lenient (BL.toStrict (encode v)))+    printable c = c >= ' ' && c /= '"'++-- | Write one pre-rendered line with a single 'BS.hPut', which holds the handle lock once and+-- so cannot interleave with a concurrent writer's line.+emitLine :: Handle -> ByteString -> IO ()+emitLine = BS.hPut++-- | Warp's @setOnException@ hook: report an exception that escaped a handler as one structured+-- JSON line on __stdout__, the same stream and shape as request lines, so an operator tailing+-- the log stream sees it. Warp's own default prints unstructured prose to stderr, where nobody+-- is looking.+--+-- Note this is stdout, unlike "Shomei.Server.Supervisor"'s @logJsonLine@ (stderr): a failed+-- request belongs with the requests, a failed background task does not.+logServerError :: Maybe Request -> SomeException -> IO ()+logServerError mreq e = emitLine stdout (serverErrorLine mreq e)++-- | The line 'logServerError' writes. Split out so a test can assert on the bytes rather than+-- capture the process's stdout. The request's method and path are included when warp knew+-- which request failed (it does not, for an exception raised before the request line parsed).+serverErrorLine :: Maybe Request -> SomeException -> ByteString+serverErrorLine mreq e = renderLogLine LogJson (base <> requestFields)+  where+    base =+      [ "level" .= ("error" :: Text),+        "msg" .= ("unhandled exception" :: Text),+        "error" .= Text.pack (show e)+      ]+    requestFields = case mreq of+      Nothing -> []+      Just req ->+        [ "method" .= decodeUtf8Lenient (requestMethod req),+          "path" .= decodeUtf8Lenient (rawPathInfo req)+        ]++durationMs :: Word64 -> Word64 -> Double+durationMs start end = fromIntegral (end - start) / 1_000_000++-- | The correlation id: a sanitized incoming @X-Request-Id@, or a freshly generated+-- @req_<uuid>@. Sanitizing (allow only @[A-Za-z0-9_.:-]@, cap length) stops a malicious client+-- from injecting a newline and forging a second log line.+resolveRequestId :: Request -> IO ByteString+resolveRequestId req =+  case lookup "X-Request-Id" (requestHeaders req) of+    Just raw | not (BS.null cleaned) -> pure cleaned+      where+        cleaned = sanitize raw+    _ -> do+      u <- UUIDv4.nextRandom+      pure ("req_" <> BC.filter (/= '-') (BC.pack (UUID.toString u)))+  where+    sanitize = BS.take 64 . BC.filter allowed+    allowed c = c `elem` ("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789_.:-" :: String)++-- | The peer host as text (dotted-quad for IPv4), with the ephemeral port dropped.+clientIp :: Request -> Text+clientIp = clientIpText . remoteHost++-- Ordinary authentication failures are attacker-triggerable and stay at info, avoiding+-- warning floods. Availability failures and throttling need operational attention.+responseLogLevel :: Int -> Text+responseLogLevel status+  | status >= 500 = "error"+  | status == 429 = "warn"+  | otherwise = "info"
+ src/Shomei/Server/Observability/Metrics.hs view
@@ -0,0 +1,220 @@+-- | A small hand-rolled Prometheus metrics registry and the WAI middleware that records and+-- exposes it (EP-3, M2).+--+-- We deliberately do NOT pull in @prometheus-client@: it is not registered in the project's+-- dependency registry and would add a Hackage build plus transitive deps for what is, here, a+-- handful of counters, one gauge, and one latency histogram. Consistent with this plan's+-- hand-rolled request-logging decision, the registry is plain 'IORef's updated with+-- 'atomicModifyIORef'' and the @/metrics@ body is rendered as Prometheus text exposition by hand.+--+-- Metrics exposed:+--+--   * @http_requests_total{method,status}@ — counter of handled requests.+--   * @http_requests_in_flight@ — gauge of requests currently being handled.+--   * @http_request_duration_seconds@ — latency histogram (fixed buckets) with @_sum@/@_count@.+--   * @shomei_logins_succeeded_total@ / @shomei_logins_failed_total@ /+--     @shomei_tokens_issued_total@ — domain counters derived from the HTTP method/path/status+--     (a @POST /v1/auth/login@ → 200 is a success and issues a token; → 401 is a failure;+--     @POST /v1/auth/signup@ → 201 and @/v1/auth/refresh@ → 200 issue a token). This+--     HTTP-derived approach avoids instrumenting the effect stack; see the Decision Log.+module Shomei.Server.Observability.Metrics+  ( Metrics,+    newMetrics,+    metricsMiddleware,+    metricsEndpointMiddleware,+    exportMetrics,+  )+where++import Control.Exception (finally)+import Data.ByteString (ByteString)+import Data.ByteString.Builder (Builder, byteString, doubleDec, intDec, toLazyByteString)+import Data.ByteString.Lazy qualified as BL+import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef)+import Data.List (sortOn)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.Encoding (decodeLatin1, encodeUtf8)+import GHC.Clock (getMonotonicTimeNSec)+import Network.HTTP.Types (Status (statusCode), methodGet, status200)+import Network.Wai+  ( Middleware,+    Request,+    rawPathInfo,+    requestMethod,+    responseLBS,+    responseStatus,+  )++data Metrics = Metrics+  { reqTotal :: !(IORef (Map (Text, Int) Int)),+    inFlight :: !(IORef Int),+    durSum :: !(IORef Double),+    durCount :: !(IORef Int),+    durBuckets :: !(IORef (Map Double Int)),+    loginsOk :: !(IORef Int),+    loginsFail :: !(IORef Int),+    tokensIssued :: !(IORef Int)+  }++histogramBuckets :: [Double]+histogramBuckets = [0.005, 0.01, 0.025, 0.05, 0.1, 0.25, 0.5, 1, 2.5, 5, 10]++newMetrics :: IO Metrics+newMetrics =+  Metrics+    <$> newIORef Map.empty+    <*> newIORef 0+    <*> newIORef 0+    <*> newIORef 0+    <*> newIORef (Map.fromList [(le, 0) | le <- histogramBuckets])+    <*> newIORef 0+    <*> newIORef 0+    <*> newIORef 0++bumpInt :: IORef Int -> Int -> IO ()+bumpInt ref n = atomicModifyIORef' ref (\x -> (x + n, ()))++observeDuration :: Metrics -> Double -> IO ()+observeDuration m secs = do+  bumpInt m.durCount 1+  atomicModifyIORef' m.durSum (\s -> (s + secs, ()))+  atomicModifyIORef' m.durBuckets (\bs -> (Map.mapWithKey (\le c -> if secs <= le then c + 1 else c) bs, ()))++-- | Instrument every request: in-flight gauge, total counter, latency histogram, and the+-- HTTP-derived domain counters.+--+-- The in-flight gauge is decremented in a 'finally', not in the response continuation: an+-- application that throws instead of responding (the infrastructure path — @Shomei.Server.Boot@+-- raises an 'IOError' when the database is unreachable, which flies past this middleware to+-- warp) would otherwise inflate the gauge permanently, and after a week of sporadic 500s the+-- gauge — and every dashboard and alert built on it — reads a fiction. Placing the decrement in+-- the release action rather than alongside the latency observation is what makes it run exactly+-- once on every path, including an async exception delivered after the continuation returned.+--+-- The latency histogram and the request counter deliberately stay in the continuation: a+-- request aborted by an exception produced no response status to label, so it is counted+-- nowhere rather than counted wrong.+metricsMiddleware :: Metrics -> Middleware+metricsMiddleware m app req respond = do+  bumpInt m.inFlight 1+  start <- monotonicSeconds+  let handleResponse res = do+        received <- respond res+        end <- monotonicSeconds+        observeDuration m (end - start)+        recordRequest m req (statusCode (responseStatus res))+        pure received+  app req handleResponse `finally` bumpInt m.inFlight (-1)++recordRequest :: Metrics -> Request -> Int -> IO ()+recordRequest m req status = do+  let method = methodLabel (requestMethod req)+      path = rawPathInfo req+  atomicModifyIORef' m.reqTotal (\mp -> (Map.insertWith (+) (method, status) 1 mp, ()))+  case (requestMethod req, path, status) of+    ("POST", "/v1/auth/login", 200) -> bumpInt m.loginsOk 1 >> bumpInt m.tokensIssued 1+    ("POST", "/v1/auth/login", 401) -> bumpInt m.loginsFail 1+    ("POST", "/v1/auth/signup", 201) -> bumpInt m.tokensIssued 1+    ("POST", "/v1/auth/refresh", 200) -> bumpInt m.tokensIssued 1+    -- EP-4: the OAuth2 token endpoint mints machine tokens, and it is unversioned. Without this+    -- arm, a deployment that has migrated its services to /oauth/token watches+    -- shomei_tokens_issued_total fall toward zero while it is issuing more tokens than ever.+    ("POST", "/oauth/token", 200) -> bumpInt m.tokensIssued 1+    _ -> pure ()++-- | Serve @GET /metrics@ directly (bypassing Servant); pass everything else through.+metricsEndpointMiddleware :: Metrics -> Middleware+metricsEndpointMiddleware m app req respond+  | requestMethod req == methodGet && rawPathInfo req == "/metrics" = do+      body <- exportMetrics m+      respond (responseLBS status200 [("Content-Type", "text/plain; version=0.0.4")] body)+  | otherwise = app req respond++-- | Render the whole registry as Prometheus text exposition.+exportMetrics :: Metrics -> IO BL.ByteString+exportMetrics m = do+  reqs <- readIORef m.reqTotal+  flight <- readIORef m.inFlight+  dsum <- readIORef m.durSum+  dcount <- readIORef m.durCount+  buckets <- readIORef m.durBuckets+  ok <- readIORef m.loginsOk+  failed <- readIORef m.loginsFail+  issued <- readIORef m.tokensIssued+  pure+    ( toLazyByteString+        ( mconcat+            ( reqLines reqs+                <> flightLines flight+                <> histLines dsum dcount buckets+                <> domainLines ok failed issued+            )+        )+    )+  where+    reqLines reqs =+      helpType "http_requests_total" "counter"+        : [ line ("http_requests_total" <> labels [("method", method), ("status", tshow status)]) (intDec n)+          | ((method, status), n) <- Map.toList reqs+          ]+    flightLines flight =+      [ helpType "http_requests_in_flight" "gauge",+        line "http_requests_in_flight" (intDec flight)+      ]+    histLines dsum dcount buckets =+      helpType "http_request_duration_seconds" "histogram"+        : [ line ("http_request_duration_seconds_bucket" <> labels [("le", tshow le)]) (intDec c)+          | (le, c) <- sortOn fst (Map.toList buckets)+          ]+          <> [ line ("http_request_duration_seconds_bucket" <> labels [("le", "+Inf")]) (intDec dcount),+               line "http_request_duration_seconds_sum" (doubleDec dsum),+               line "http_request_duration_seconds_count" (intDec dcount)+             ]+    domainLines ok failed issued =+      [ helpType "shomei_logins_succeeded_total" "counter",+        line "shomei_logins_succeeded_total" (intDec ok),+        helpType "shomei_logins_failed_total" "counter",+        line "shomei_logins_failed_total" (intDec failed),+        helpType "shomei_tokens_issued_total" "counter",+        line "shomei_tokens_issued_total" (intDec issued)+      ]++-- Rendering helpers ----------------------------------------------------------++line :: Builder -> Builder -> Builder+line name val = name <> byteString " " <> val <> byteString "\n"++helpType :: ByteString -> ByteString -> Builder+helpType name ty = byteString "# TYPE " <> byteString name <> byteString " " <> byteString ty <> byteString "\n"++labels :: [(ByteString, Text)] -> Builder+labels [] = mempty+labels ls = byteString "{" <> go ls <> byteString "}"+  where+    go [] = mempty+    go [x] = lbl x+    go (x : xs) = lbl x <> byteString "," <> go xs+    lbl (k, v) = byteString k <> byteString "=\"" <> byteString (encodeUtf8 (escapeLabelValue v)) <> byteString "\""++-- | Keep attacker-controlled HTTP extension methods out of the series-key vocabulary.+methodLabel :: ByteString -> Text+methodLabel method+  | method `elem` ["GET", "HEAD", "POST", "PUT", "PATCH", "DELETE", "OPTIONS"] = decodeLatin1 method+  | otherwise = "other"++-- | Prometheus text-format label escaping: backslash first, then quote and newline.+escapeLabelValue :: Text -> Text+escapeLabelValue = Text.concatMap \case+  '\\' -> "\\\\"+  '"' -> "\\\""+  '\n' -> "\\n"+  c -> Text.singleton c++monotonicSeconds :: IO Double+monotonicSeconds = (\ns -> fromIntegral ns / 1e9) <$> getMonotonicTimeNSec++tshow :: (Show a) => a -> Text+tshow = Text.pack . show
+ src/Shomei/Server/Runtime.hs view
@@ -0,0 +1,53 @@+-- | Shared Warp lifecycle for standalone and embedded hosts. Rejected connections never+-- wait for a permit. Warp brackets onOpen/onClose even when onOpen returns False; track+-- admitted worker identities so rejected closes cannot release someone else's capacity.+module Shomei.Server.Runtime (hostWarpSettings) where++import Control.Concurrent (myThreadId)+import Control.Concurrent.STM (atomically, newTVarIO, readTVar, writeTVar)+import Control.Monad (when)+import Data.Set qualified as Set+import Data.String (fromString)+import Data.Text qualified as Text+import Network.Wai.Handler.Warp qualified as Warp+import Shomei.Config (ObservabilityConfig (..), ShomeiConfig (..))+import Shomei.Server.Config (ProxyProtocolMode (..), ServerSettings (..))+import Shomei.Server.ExceptionResponse (problemExceptionResponse)+import Shomei.Server.Observability.Logging (logServerError)++hostWarpSettings :: ShomeiConfig -> ServerSettings -> Warp.Settings -> IO Warp.Settings+hostWarpSettings cfg settings base = do+  when+    (settings.serverMaxConnections <= 0 || settings.serverSlowClientTimeoutSeconds <= 0 || settings.serverSlowClientTimeoutSeconds > maxBound `div` 1000000 || Text.null settings.serverBindHost)+    (ioError (userError "host bind, connection limit and slow-client timeout must be finite and positive"))+  admitted <- newTVarIO Set.empty+  let onOpen _ = do+        worker <- myThreadId+        atomically do+          active <- readTVar admitted+          if Set.size active >= settings.serverMaxConnections+            then pure False+            else do+              writeTVar admitted (Set.insert worker active)+              pure True+      onClose _ = do+        worker <- myThreadId+        atomically do+          active <- readTVar admitted+          writeTVar admitted (Set.delete worker active)+      proxy = case settings.serverProxyProtocol of+        ProxyProtocolOff -> Warp.setProxyProtocolNone+        ProxyProtocolRequired -> Warp.setProxyProtocolRequired+      onException request err = when (Warp.defaultShouldDisplayException err) (logServerError request err)+  pure+    $ Warp.setPort settings.serverPort+      . Warp.setHost (fromString (Text.unpack settings.serverBindHost))+      . Warp.setTimeout settings.serverSlowClientTimeoutSeconds+      . Warp.setOnOpen onOpen+      . Warp.setOnClose onClose+      . Warp.setGracefulShutdownTimeout (Just cfg.observabilityConfig.gracefulShutdownTimeoutSeconds)+      . Warp.setServerName "shomei"+      . Warp.setOnException onException+      . Warp.setOnExceptionResponse problemExceptionResponse+      . proxy+    $ base
+ src/Shomei/Server/Supervisor.hs view
@@ -0,0 +1,130 @@+-- | The house idiom for supervised background threads.+--+-- A /background thread/ here means a periodic maintenance task forked at server boot: the+-- expired-data sweeper ("Shomei.Persistence.Maintenance.Postgres"), the signing-key reload+-- ("Shomei.Server.Keys"), and whatever later plans add. Every one of them wants the same+-- three things, and none of them wants a supervisor hierarchy:+--+-- 1. Run a cycle, then sleep, forever.+-- 2. If a cycle throws, log loudly and try again later — never take the server down. A failed+--    sweep is strictly less bad than downtime, and the realistic failure mode is "the database+--    was briefly unreachable", which fixes itself.+-- 3. Back off while the failure persists, so a database outage does not turn into a tight+--    retry loop that fills the disk with log lines.+--+-- 'supervisedLoop' is that, and nothing more. It is not respawned by a monitor thread, and it+-- dies with the process: fork it with plain @forkIO@ from @Shomei.Server.Boot.main@ and let+-- process exit collect it. No shutdown plumbing is needed because every cycle is idempotent —+-- a cycle interrupted by exit simply did not happen, and the next boot picks it up.+module Shomei.Server.Supervisor+  ( supervisedLoop,+    supervisedLoopMicros,+    logJsonLine,+  )+where++import Control.Concurrent (threadDelay)+import Control.Exception (SomeAsyncException, SomeException, fromException, throwIO, try)+import Data.Aeson (Value, encode, object, (.=))+import Data.Aeson.Key (Key)+import Data.ByteString.Lazy qualified as BL+import Data.Text (Text)+import Data.Text qualified as Text+import System.IO (stderr)++-- | Seconds to wait after the first crash.+initialBackoffSeconds :: Int+initialBackoffSeconds = 5++-- | The ceiling the backoff doubles up to. Five minutes is long enough that a night-long+-- outage costs a few hundred log lines rather than a few million, and short enough that+-- recovery is noticed promptly.+maxBackoffSeconds :: Int+maxBackoffSeconds = 300++-- | Run @cycleAction@ forever, sleeping @intervalSeconds@ between clean cycles.+--+-- The first cycle runs immediately, so a freshly booted server does its maintenance at once+-- rather than after a full interval. A crash — any synchronous 'SomeException' — is caught,+-- logged as one structured JSON line on stderr, and retried after an exponential backoff+-- (5 s, doubling to a 300 s ceiling). The backoff resets after the next clean cycle. The loop+-- never rethrows a synchronous exception.+--+-- Asynchronous exceptions are re-thrown rather than swallowed, so that killing the thread (or+-- the process shutting down) actually stops it instead of being mistaken for a failed cycle+-- and retried. @taskName@ appears in every log line this loop emits.+supervisedLoop ::+  -- | Task name, e.g. @"sweeper"@.+  Text ->+  -- | Seconds to sleep between clean cycles.+  Int ->+  -- | One cycle.+  IO () ->+  IO ()+supervisedLoop taskName intervalSeconds =+  -- A non-positive interval would spin the loop at full speed, so clamp to one second: a+  -- misconfigured task that runs too often is recoverable, one that pins a core is not.+  supervisedLoopMicros+    taskName+    (max 1 intervalSeconds * microsPerSecond)+    (initialBackoffSeconds * microsPerSecond)+    (maxBackoffSeconds * microsPerSecond)++-- | 'supervisedLoop' with every duration in microseconds and the backoff bounds given+-- explicitly. Exposed so tests can exercise the crash/backoff/recovery path in milliseconds+-- instead of minutes; production code wants 'supervisedLoop'.+supervisedLoopMicros ::+  -- | Task name.+  Text ->+  -- | Microseconds between clean cycles.+  Int ->+  -- | Microseconds to wait after the first crash.+  Int ->+  -- | Ceiling the backoff doubles up to.+  Int ->+  -- | One cycle.+  IO () ->+  IO ()+supervisedLoopMicros taskName intervalMicros initialBackoff maxBackoff cycleAction =+  loop initialBackoff+  where+    loop backoff = do+      outcome <- try cycleAction+      case outcome of+        Right () -> do+          threadDelay intervalMicros+          loop initialBackoff+        Left err+          -- A ThreadKilled or an async cancellation means someone wants this thread gone.+          | isAsyncException err -> throwIO err+          | otherwise -> do+              logCrash taskName err backoff+              threadDelay backoff+              loop (min maxBackoff (backoff * 2))++microsPerSecond :: Int+microsPerSecond = 1_000_000++-- | Is this an asynchronous exception (@ThreadKilled@, @AsyncCancelled@, a timeout)? Both+-- @AsyncException@ and @async@'s @AsyncCancelled@ route through 'SomeAsyncException', so this+-- one check covers them.+isAsyncException :: SomeException -> Bool+isAsyncException err = case fromException err of+  Just (_ :: SomeAsyncException) -> True+  Nothing -> False++-- | @backoffMicros@ is the wait about to be taken, so successive crashes log 5, 10, 20, …+logCrash :: Text -> SomeException -> Int -> IO ()+logCrash taskName err backoffMicros =+  logJsonLine+    [ "level" .= ("error" :: Text),+      "msg" .= ("background task crashed" :: Text),+      "task" .= taskName,+      "error" .= Text.pack (show err),+      "backoff_s" .= (fromIntegral backoffMicros / 1_000_000 :: Double)+    ]++-- | Emit one structured JSON log line on stderr. Background tasks log here rather than on+-- stdout, where 'Shomei.Server.Observability.Logging' emits one line per HTTP request.+logJsonLine :: [(Key, Value)] -> IO ()+logJsonLine fields = BL.hPut stderr (encode (object fields) <> "\n")
+ test-health/Main.hs view
@@ -0,0 +1,143 @@+module Main (main) where++import Control.Concurrent (threadDelay)+import Data.ByteString qualified as BS+import Data.IORef (modifyIORef', newIORef, readIORef, writeIORef)+import Data.Maybe (listToMaybe)+import GHC.Clock (getMonotonicTimeNSec)+import Network.HTTP.Client (defaultManagerSettings, newManager)+import Servant.Health (ProbeVerdict (..))+import Servant.Health.TestKit (probeContractTests)+import Shomei.Account.Password.Hash.Postgres (Argon2Params (..), newHashingLimiter)+import Shomei.Authorization.Claims.Domain (Audience (..), Issuer (..))+import Shomei.Config (defaultShomeiConfig)+import Shomei.Error (AuthDependency (PostgreSQL), AuthError (DependencyUnavailable))+import Shomei.Health.Server (HealthPolicy (..), buildHealthChecksWith, defaultHealthPolicy)+import Shomei.Mfa.Totp.Postgres (TotpEncryptionKey, totpEncryptionKeyFromBytes)+import Shomei.Migrations.TestSupport (withShomeiMigratedDatabase)+import Shomei.Notify (noNotifierSecrets)+import Shomei.Notify.Queue (newNotifierQueue)+import Shomei.Persistence.Database.Postgres (defaultTransactionRetryPolicy)+import Shomei.Persistence.Pool.Postgres (acquirePool)+import Shomei.Persistence.Pool.Postgres qualified as Pool+import Shomei.Prelude+import Shomei.Server.App (Env (..), runAppIO)+import Shomei.Server.Boot (application)+import Shomei.Server.Config (defaultDbStatementTimeoutMs)+import Shomei.Server.Keys (bootstrapKeys)+import Shomei.SigningKey.Domain (SigningAlgorithm (ES256), SigningKeyStatus (KeyRevoked), StoredSigningKey (..))+import Shomei.SigningKey.Protection.Jwt (KeyEncryptionKey, keyEncryptionKeyFromBase64)+import Shomei.SigningKey.Store (listActiveSigningKeys, updateSigningKeyStatus)+import Shomei.Time.Store (now)+import Test.Tasty (TestTree, defaultMain, testGroup)+import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))++main :: IO ()+main =+  withShomeiMigratedDatabase \connectionString -> do+    env <- buildTestEnv connectionString+    defaultMain (tests env)++tests :: Env -> TestTree+tests env =+  testGroup+    "Shomei health policy"+    [ probeContractTests+        "servant-health contract through the standalone application builder"+        (\liveness readiness -> pure (application env liveness readiness)),+      testCase "readiness distinguishes active keys, missing keys, and PostgreSQL unavailability" do+        (_, readiness) <- buildHealthChecksWith noCachePolicy (runAppIO env listActiveSigningKeys)+        readiness >>= (@?= Healthy)++        active <- expectRight =<< runAppIO env listActiveSigningKeys+        key <- maybe (assertFailure "bootstrap did not create an active signing key") pure (listToMaybe active)+        timestamp <- expectRight =<< runAppIO env now+        expectRight =<< runAppIO env (updateSigningKeyStatus key.keyId KeyRevoked timestamp)+        readiness >>= assertFailedAs "signing-key"++        unavailablePool <- acquirePool 1 1 defaultDbStatementTimeoutMs "postgresql://127.0.0.1:1/postgres"+        (_, unavailableReadiness) <-+          buildHealthChecksWith noCachePolicy (runAppIO env {envPool = unavailablePool} listActiveSigningKeys)+        unavailableReadiness >>= assertFailedAs "postgres"+        Pool.release unavailablePool,+      testCase "tracked readiness preserves onset, resets after recovery, and starts a new run" do+        queryResult <- newIORef (Left (DependencyUnavailable PostgreSQL))+        (_, readiness) <- buildHealthChecksWith noCachePolicy (readIORef queryResult)+        first <- readiness+        second <- readiness+        failureOnset first @?= failureOnset second+        writeIORef queryResult (Right [error "the policy checks only whether the list is empty"])+        readiness >>= (@?= Healthy)+        writeIORef queryResult (Left (DependencyUnavailable PostgreSQL))+        third <- readiness+        case (failureOnset first, failureOnset third) of+          (Just old, Just new) -> unless (new >= old) (assertFailure "a new failing run moved backwards")+          _ -> assertFailure "expected tracked failures before and after recovery",+      testCase "readiness is evaluated at most once per window" do+        calls <- newIORef (0 :: Int)+        let query = do+              modifyIORef' calls (+ 1)+              pure (Right [error "the policy checks only whether the list is empty"])+        (_, readiness) <- buildHealthChecksWith defaultHealthPolicy query+        readiness >>= (@?= Healthy)+        readiness >>= (@?= Healthy)+        readIORef calls >>= (@?= 1)+        threadDelay 1_100_000+        readiness >>= (@?= Healthy)+        readIORef calls >>= (@?= 2),+      testCase "readiness times out as a postgres failure" do+        let policy = defaultHealthPolicy {readinessTimeoutMicros = 200_000, readinessCacheMicros = 0}+            query = threadDelay 5_000_000 >> pure (Right [])+        (_, readiness) <- buildHealthChecksWith policy query+        started <- getMonotonicTimeNSec+        verdict <- readiness+        finished <- getMonotonicTimeNSec+        assertFailedAs "postgres" verdict+        let elapsedSeconds = fromIntegral (finished - started) / 1e9 :: Double+        assertBool ("readiness took " <> show elapsedSeconds <> " seconds") (elapsedSeconds < 2)+    ]++noCachePolicy :: HealthPolicy+noCachePolicy = defaultHealthPolicy {readinessCacheMicros = 0}++buildTestEnv :: Text -> IO Env+buildTestEnv connectionString = do+  pool <- acquirePool 4 10 defaultDbStatementTimeoutMs connectionString+  keys <- newIORef =<< bootstrapKeys testKek ES256 pool+  manager <- newManager defaultManagerSettings+  limiter <- newHashingLimiter 2+  notifierQueue <- newNotifierQueue 64+  let config = defaultShomeiConfig (Issuer "shomei") (Audience "shomei-clients")+  pure+    Env+      { envPool = pool,+        envDbRetryPolicy = defaultTransactionRetryPolicy,+        envConfig = config,+        envKeys = keys,+        envKek = testKek,+        envHttpManager = manager,+        envNotifierSecrets = noNotifierSecrets,+        envNotifierQueue = notifierQueue,+        envArgon2Params = Argon2Params {memoryKiB = 8192, iterations = 1, parallelism = 1},+        envHashingLimiter = limiter,+        envTotpKey = testTotpKey+      }++testKek :: KeyEncryptionKey+testKek = either (error . show) id (keyEncryptionKeyFromBase64 "AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA=")++testTotpKey :: TotpEncryptionKey+testTotpKey = either (error . show) id (totpEncryptionKeyFromBytes (BS.replicate 32 0))++expectRight :: (Show e) => Either e a -> IO a+expectRight = either (assertFailure . show) pure++assertFailedAs :: Text -> ProbeVerdict -> IO ()+assertFailedAs expected = \case+  Unhealthy actual _ -> actual @?= expected+  Healthy -> assertFailure ("expected an unhealthy " <> show expected <> " verdict")++failureOnset :: ProbeVerdict -> Maybe UTCTime+failureOnset = \case+  Healthy -> Nothing+  Unhealthy _ onset -> Just onset
+ test/Admin/Main.hs view
@@ -0,0 +1,1077 @@+-- | Integration tests for @shomei-admin@ (EP-4), against throwaway PostgreSQL databases+-- provisioned by @shomei-migrations:test-support@. They drive the real CLI action functions and+-- assert database state, and — the headline — prove the signing-key rotation lifecycle with+-- overlapping-key JWKS verification.+module Main (main) where++import Control.Exception (try)+import Control.Monad (forM_, void)+import Crypto.JOSE.JWK (JWK, JWKSet (JWKSet))+import Data.Aeson qualified as Aeson+import Data.Aeson.KeyMap qualified as KeyMap+import Data.ByteArray.Encoding (Base (Base64), convertToBase)+import Data.ByteString.Char8 qualified as BS8+import Data.IORef (newIORef, readIORef)+import Data.Int (Int64)+import Data.List (find)+import Data.Maybe (isJust)+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.Encoding qualified as TE+import Data.Time (addUTCTime, getCurrentTime)+import Data.UUID qualified as UUID+import Effectful (Eff, IOE, runEff)+import Effectful.Dispatch.Dynamic (interpret_)+import Effectful.Error.Static (Error, runErrorNoCallStack)+import Hasql.Decoders qualified as D+import Hasql.Encoders qualified as E+import Hasql.Errors qualified as Hasql+import Hasql.Session qualified as Session+import Hasql.Statement (preparable)+import Options.Applicative (ParserResult (..), defaultPrefs, execParserPure, info)+import Shomei.Account.Password.Domain (PasswordPolicy (..), PlainPassword (..))+import Shomei.Account.Password.Hash.Postgres (Argon2Params (..), sha256Hex)+import Shomei.Account.User.Postgres (runUserStorePostgres)+import Shomei.Admin.Audit (AuditFilters (..), runAuditReader, toJsonObject, toQuery)+import Shomei.Admin.Env (AdminEnv (..))+import Shomei.Admin.Keys+  ( keysActivate,+    keysGenerate,+    keysRetire,+    keysRevoke,+    keysRewrap,+    listAllKeys,+    listPublishableSigningKeys,+    summarizeUsageError,+  )+import Shomei.Admin.OAuthClients qualified as OAuthClients+import Shomei.Admin.Roles (GrantExpiry (..), RolesCommand (..), rolesParser, runRoles)+import Shomei.Admin.ServiceAccounts (createAction, listAction, revokeAction, rotateSecretAction)+import Shomei.Admin.Sweep (SweepOptions (..), defaultSweepOptions, runSweepReport)+import Shomei.Admin.Users (createUserAction)+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.Store+  ( AuditEventQuery (..),+    StoredAuthEvent (..),+    countAuthEvents,+    emptyAuditQuery,+    queryAuthEvents,+  )+import Shomei.Authorization.Claims.Domain (Audience (..), AuthClaims (..), Issuer (..), Role (..), Scope (..))+import Shomei.Config (ShomeiConfig (..), defaultShomeiConfig)+import Shomei.Error (AuthError (OAuthClientInvalid))+import Shomei.Id (genSessionId, genUserId, idText, sessionIdToUUID, userIdToUUID)+import Shomei.Migrations.TestSupport (withShomeiMigratedDatabase)+import Shomei.OAuth.Client.Domain (ClientType (..), OAuthClient (..), OAuthClientStatus (..))+import Shomei.OAuth.IdToken.Domain (IdToken (..))+import Shomei.Persistence.Database.Postgres (Database, runDatabasePool)+import Shomei.Persistence.Maintenance.Postgres (SweepReport (..))+import Shomei.Persistence.Pool.Postgres (Pool, acquirePool)+import Shomei.Persistence.Pool.Postgres qualified as Pool++-- qualified: 'Shomei.Admin.Keys' exports a same-named listPublishableSigningKeys++import Shomei.Server.Config (defaultDbStatementTimeoutMs)+import Shomei.Server.Keys (LoadedKeys (..), bootstrapKeys, reloadKeys)+import Shomei.Server.Keys qualified as Keys+import Shomei.ServiceAccount.ClientCredentials.Workflow (ClientCredentialsGrant (..), GrantedToken (..), grantClientCredentials)+import Shomei.ServiceAccount.Domain (ServiceAccount (..))+import Shomei.ServiceAccount.Postgres (runServiceAccountStorePostgres)+import Shomei.Session.Postgres (runSessionStorePostgres)+import Shomei.Session.Token.Domain (AccessToken (..))+import Shomei.SigningKey.Domain (SigningAlgorithm (ES256), SigningKeyStatus (..), StoredSigningKey (..))+import Shomei.SigningKey.Key.Jwt (keyKid)+import Shomei.SigningKey.Protection.Jwt+  ( KeyDecryptError (KeyDecryptFailed),+    KeyEncryptionKey,+    decryptStoredSigningKey,+    isEncryptedPrivateJwk,+    keyEncryptionKeyFromBase64,+    publicJwkFromStored,+  )+import Shomei.SigningKey.Sign.Jwt (signAccessToken)+import Shomei.SigningKey.Signer (TokenSigner (..))+import Shomei.SigningKey.Verify.Jwt (verifyToken)+import Shomei.Time.Postgres (runClockIO)+import System.Exit (ExitCode (..))+import Test.Tasty (TestTree, defaultMain, testGroup)+import Test.Tasty.HUnit (assertBool, assertEqual, assertFailure, testCase, (@?=))++cfg :: ShomeiConfig+cfg = defaultShomeiConfig (Issuer "shomei") (Audience "shomei-clients")++-- | Cheap Argon2 parameters for tests. @users create@ hashes a real password, and the+-- production cost (~100 ms) would dominate this suite. Strength is irrelevant here.+testArgon2Params :: Argon2Params+testArgon2Params = Argon2Params {memoryKiB = 8192, iterations = 1, parallelism = 1}++withDb :: (Pool -> Text -> IO a) -> IO a+withDb action = withShomeiMigratedDatabase \connStr -> do+  pool <- acquirePool 4 10 defaultDbStatementTimeoutMs connStr+  action pool connStr++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 (fromI <$> D.column (D.nonNullable D.int8)))+    fromI :: Int64 -> Int+    fromI = fromIntegral++-- | 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++execSqlExpectState :: Pool -> Text -> Text -> IO ()+execSqlExpectState pool expected sql = do+  res <- Pool.use pool (Session.script sql)+  case res of+    Left err | sqlState err == Just expected -> pure ()+    Left err -> assertFailure ("expected SQLSTATE " <> Text.unpack expected <> ", got " <> show err)+    Right () -> assertFailure ("expected SQLSTATE " <> Text.unpack expected <> ", but SQL succeeded")+  where+    sqlState = \case+      Pool.SessionUsageError (Hasql.ScriptSessionError _ (Hasql.ServerError code _ _ _ _)) -> Just code+      Pool.SessionUsageError+        ( Hasql.StatementSessionError+            _+            _+            _+            _+            _+            (Hasql.ServerStatementError (Hasql.ServerError code _ _ _ _))+          ) -> Just code+      _ -> Nothing++-- | Run a CLI action that is expected to abort. The action functions call 'exitFailure' on a+-- user error, which throws 'ExitCode' — catching it is how a test observes a nonzero exit.+expectExitFailure :: String -> IO () -> IO ()+expectExitFailure what action = do+  result <- try @ExitCode action+  case result of+    Left (ExitFailure _) -> pure ()+    Left ExitSuccess -> assertFailure (what <> ": expected a nonzero exit, got success")+    Right () -> assertFailure (what <> ": expected the command to abort")++main :: IO ()+main =+  defaultMain+    ( testGroup+        "shomei-admin"+        [ testMigrateEmpty,+          testLifecycleOverlap,+          testReloadPicksUpRotation,+          testReloadKeepsLastGoodMaterial,+          testGeneratesEncryptedWithKek,+          testJwksNeedsNoKek,+          testRewrapRotatesTheKek,+          testRewrapWithWrongOldKekModifiesNothing,+          testKeyWriteRollback,+          testMultipleActiveFailClosed,+          testUsageErrorSummary,+          testUserCreate,+          testUserCreateEmailVerified,+          testUserCreateAppliesPasswordPolicy,+          testAuditQuery,+          testSweepCommand,+          testRolesLifecycle,+          testRolesGrantOfUndefinedRoleFails,+          testRolesGrantToUnknownUserFails,+          testRolesPermissionWiring,+          testRolesGrantWithExpiry,+          testRolesGrantBothExpiryFlagsFailsToParse,+          testUserCreateAppliesDefaultRoles,+          testUserCreateRefusesUndefinedDefaultRoles,+          testServiceAccountsLifecycle,+          testServiceAccountsPrivilegeScopeAllowed,+          testServiceAccountsRotateAndRevoke,+          testServiceAccountsUnknownClientIdFails,+          testOAuthClientsLifecycle,+          testOAuthClientsPublicHasNoSecret,+          testOAuthClientsPrivilegeScopeFails,+          testOAuthClientsRevokeUnknownFails+        ]+    )++-- Encryption at rest ---------------------------------------------------------++-- | With a KEK configured, a fresh deployment never writes a plaintext private key — and+-- the key it wrote still signs tokens that verify.+testGeneratesEncryptedWithKek :: TestTree+testGeneratesEncryptedWithKek = testCase "first boot with a KEK stores encrypted private material" $ withDb \pool _ -> do+  kek <- testKek 'a'+  keys <- bootstrapKeys kek ES256 pool+  priv <- storedPrivate pool+  assertBool ("expected an enc:v1: prefix, got " <> Text.unpack (Text.take 12 priv)) (isEncryptedPrivateJwk priv)+  token <- signWith keys.signingKey+  v <- verifyToken keys.verifierJwks cfg token+  assertBool "a token signed by the decrypted key verifies" (isRight v)++-- | Publication is independent of the KEK: the JWKS and the verifier key set come from the+-- public column, so KEK rotation can never break verification of live tokens.+testJwksNeedsNoKek :: TestTree+testJwksNeedsNoKek = testCase "JWKS and verification need no KEK, even for encrypted keys" $ withDb \pool _ -> do+  kek <- testKek 'a'+  keys <- bootstrapKeys kek ES256 pool+  token <- signWith keys.signingKey+  row <- onlyKey pool+  assertBool "the row is encrypted" (isEncryptedPrivateJwk row.privateKeyJwk)+  pub <- liftEither (publicJwkFromStored row)+  v <- verifyToken (JWKSet [pub]) cfg token+  assertBool "a token verifies against public material recovered without the KEK" (isRight v)++-- | Rotating the KEK: after a rewrap the old KEK no longer opens the row and the new one+-- does, while the public material — and therefore every outstanding token — is untouched.+testRewrapRotatesTheKek :: TestTree+testRewrapRotatesTheKek = testCase "keys rewrap moves rows from the old KEK to the new one" $ withDb \pool _ -> do+  oldKek <- testKek 'a'+  newKek <- testKek 'b'+  keys <- bootstrapKeys oldKek ES256 pool+  publicBefore <- storedPublic pool+  token <- signWith keys.signingKey++  keysRewrap oldKek newKek pool++  row <- onlyKey pool+  assertBool "still encrypted" (isEncryptedPrivateJwk row.privateKeyJwk)+  case decryptStoredSigningKey oldKek row of+    Left KeyDecryptFailed -> pure ()+    Left e -> assertFailure ("expected KeyDecryptFailed from the old KEK, got " <> show e)+    Right _ -> assertFailure "the old KEK must no longer decrypt the row"+  jwk <- either (assertFailure . show) pure (decryptStoredSigningKey newKek row)++  storedPublic pool >>= (@?= publicBefore)+  pub <- liftEither (publicJwkFromStored row)+  v <- verifyToken (JWKSet [pub]) cfg token+  assertBool "the pre-rewrap token still verifies" (isRight v)+  newToken <- signWith jwk+  v2 <- verifyToken (JWKSet [pub]) cfg newToken+  assertBool "the rewrapped key still signs" (isRight v2)++-- | A wrong old KEK must abort before the first write: a half-rewrapped table would be+-- readable by neither KEK.+testRewrapWithWrongOldKekModifiesNothing :: TestTree+testRewrapWithWrongOldKekModifiesNothing = testCase "keys rewrap with a wrong old KEK modifies no rows" $ withDb \pool _ -> do+  realKek <- testKek 'a'+  wrongKek <- testKek 'c'+  newKek <- testKek 'b'+  _ <- bootstrapKeys realKek ES256 pool+  before <- storedPrivate pool++  -- 'keysRewrap' aborts via exitFailure, which surfaces here as an ExitCode exception.+  outcome <- try (keysRewrap wrongKek newKek pool)+  case outcome of+    Left (_ :: ExitCode) -> pure ()+    Right () -> assertFailure "rewrap with a wrong old KEK must abort"+  after <- storedPrivate pool+  after @?= before+  row <- onlyKey pool+  case decryptStoredSigningKey realKek row of+    Right _ -> pure ()+    Left e -> assertFailure ("the original KEK must still work after an aborted rewrap: " <> show e)++testMigrateEmpty :: TestTree+testMigrateEmpty = testCase "after migration the keys table exists and is empty" $ withDb \pool _ -> do+  keys <- listAllKeys pool+  keys @?= []+  n <- scalarInt pool "SELECT count(*) FROM shomei.shomei_signing_keys"+  n @?= 0++testLifecycleOverlap :: TestTree+testLifecycleOverlap = testCase "generate→activate→(generate→activate auto-retires)→overlap verifies→revoke breaks it" $ withDb \pool _ -> do+  kek <- testKek 'a'+  -- First key: generate then activate.+  keysGenerate kek ES256 pool+  kid1 <- onlyPendingKid pool+  keysActivate pool kid1+  -- Second key: generate then activate; this auto-retires kid1.+  keysGenerate kek ES256 pool+  kid2 <- onlyPendingKid pool+  keysActivate pool kid2++  publishable <- listPublishableSigningKeys pool+  Set.fromList (map (.keyId) publishable) @?= Set.fromList [kid1, kid2]+  statusOf pool kid1 >>= (@?= KeyRetired)+  statusOf pool kid2 >>= (@?= KeyActive)+  scalarInt pool "SELECT count(*) FROM shomei.shomei_signing_keys WHERE status = 'active'" >>= (@?= 1)+  oldAfterActivation <- requireKey pool kid1+  newAfterActivation <- requireKey pool kid2+  assertBool "auto-retirement stamps retired_at" (isJust oldAfterActivation.retiredAt)+  assertBool "activation stamps activated_at" (isJust newAfterActivation.activatedAt)++  -- The database invariant is independent of the CLI: a hand-written second activation+  -- is rejected by the partial unique index and leaves the one active row unchanged.+  execSqlExpectState+    pool+    "23505"+    ("UPDATE shomei.shomei_signing_keys SET status = 'active' WHERE key_id = '" <> kid1 <> "'")+  scalarInt pool "SELECT count(*) FROM shomei.shomei_signing_keys WHERE status = 'active'" >>= (@?= 1)++  -- A token signed by the now-RETIRED kid1 still verifies against the published JWKS.+  retired <- requireKey pool kid1+  jwk1 <- either (assertFailure . show) pure (decryptStoredSigningKey kek retired)+  jwkset <- buildJwks publishable+  token <- signWith jwk1+  v1 <- verifyToken jwkset cfg token+  assertBool "retired-key token verifies during overlap" (isRight v1)++  -- Revoke kid1: it leaves the JWKS and its token stops verifying.+  keysRevoke pool kid1+  revoked <- requireKey pool kid1+  assertBool "revocation stamps revoked_at" (isJust revoked.revokedAt)+  publishable2 <- listPublishableSigningKeys pool+  map (.keyId) publishable2 @?= [kid2]+  jwkset2 <- buildJwks publishable2+  v2 <- verifyToken jwkset2 cfg token+  assertBool "revoked-key token no longer verifies" (not (isRight v2))++-- | The hot-reload contract: after @keys generate@ + @keys activate@ on a *running*+-- server, one 'reloadKeys' makes the new key the signer while the auto-retired one stays+-- published — so tokens minted a moment ago keep verifying. Before this plan the running+-- server never saw the rotation at all.+testReloadPicksUpRotation :: TestTree+testReloadPicksUpRotation = testCase "reloadKeys picks up an activation: new signer, both keys published" $ withDb \pool _ -> do+  kek <- testKek 'a'+  ref <- newIORef =<< bootstrapKeys kek ES256 pool+  kid1 <- signerKid <$> readIORef ref++  keysGenerate kek ES256 pool+  kid2 <- onlyPendingKid pool+  keysActivate pool kid2 -- auto-retires kid1+  reloadKeys kek pool ref+  reloaded <- readIORef ref+  signerKid reloaded @?= kid2+  Set.fromList (Keys.publishedKids reloaded) @?= Set.fromList [kid1, kid2]++  -- The retired key is still trusted by the reloaded verifier, not merely published.+  retired <- requireKey pool kid1+  token <- signWith =<< either (assertFailure . show) pure (decryptStoredSigningKey kek retired)+  v <- verifyToken reloaded.verifierJwks cfg token+  assertBool "retired-key token verifies against the reloaded key set" (isRight v)++-- | A failed reload must never degrade a running server below its last good state: it+-- keeps signing and verifying with the material it already holds. Retiring the only active+-- key is the operator mistake that produces this (there is then nothing to sign with).+testReloadKeepsLastGoodMaterial :: TestTree+testReloadKeepsLastGoodMaterial = testCase "a failed reload keeps the previous key material" $ withDb \pool _ -> do+  kek <- testKek 'a'+  ref <- newIORef =<< bootstrapKeys kek ES256 pool+  before <- readIORef ref++  keysRetire pool (signerKid before)++  reloadKeys kek pool ref+  after <- readIORef ref+  signerKid after @?= signerKid before+  Keys.publishedKids after @?= Keys.publishedKids before++  -- and the stale-but-good material still verifies a token it signs+  token <- signWith after.signingKey+  v <- verifyToken after.verifierJwks cfg token+  assertBool "server still signs and verifies after a failed reload" (isRight v)++-- Sweep ----------------------------------------------------------------------++-- | @shomei-admin sweep@ against a seeded database: the CLI trigger must delete exactly what+-- the server's background sweeper would, and audit events must survive unless the operator+-- explicitly passes @--auth-event-retention-days@.+testSweepCommand :: TestTree+testSweepCommand = testCase "sweep deletes dead rows; audit events need an explicit window" $ withDb \pool connStr -> do+  let env = AdminEnv {config = cfg, pool = pool, connStr = connStr, argon2 = testArgon2Params}+  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', 'sweep@example.com', 'Sweep', 'active', now(), now(), 'sweep@example.com');++    -- One session expired 40 days ago carrying a two-generation rotation family, one live.+    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(), now() + interval '30 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', 'active', now(), now() - interval '40 days', NULL, NULL),+      ('bbbbbbbb-0000-0000-0000-000000000003', 'aaaaaaaa-0000-0000-0000-000000000002', 'h3', NULL,                                   'active', now(), now() + interval '30 days', NULL, NULL);++    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');++    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');++    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');+    """++  report <- runSweepReport env defaultSweepOptions >>= expectSweep+  report.refreshTokensDeleted @?= 2+  report.sessionsDeleted @?= 1+  report.ceremoniesDeleted @?= 1+  report.loginAttemptsDeleted @?= 1+  -- Retention is off by default, so the 400-day-old audit event survives.+  report.authEventsDeleted @?= 0++  scalarInt pool "SELECT count(*) FROM shomei.shomei_sessions" >>= (@?= 1)+  scalarInt pool "SELECT count(*) FROM shomei.shomei_refresh_tokens" >>= (@?= 1)+  scalarInt pool "SELECT count(*) FROM shomei.shomei_auth_events" >>= (@?= 1)++  -- Asking for a window deletes it; a second run finds nothing left.+  let retaining = defaultSweepOptions {optAuthEventRetentionDays = Just 365}+  withWindow <- runSweepReport env retaining >>= expectSweep+  withWindow.authEventsDeleted @?= 1+  scalarInt pool "SELECT count(*) FROM shomei.shomei_auth_events" >>= (@?= 0)++  again <- runSweepReport env retaining >>= expectSweep+  again.authEventsDeleted @?= 0+  where+    expectSweep = either (\e -> assertFailure ("sweep failed: " <> show e)) pure++testUserCreate :: TestTree+testUserCreate = testCase "users create persists a user + credential whose hash verifies" $ withDb \pool connStr -> do+  let env = AdminEnv {config = cfg, pool = pool, connStr = connStr, argon2 = testArgon2Params}+  createUserAction env "alice@example.com" (PlainPassword "correct horse battery staple") (Just "Alice") False+  users <- scalarInt pool "SELECT count(*) FROM shomei.shomei_users WHERE email = 'alice@example.com'"+  creds <- scalarInt pool "SELECT count(*) FROM shomei.shomei_password_credentials"+  users @?= 1+  creds @?= 1++testUserCreateEmailVerified :: TestTree+testUserCreateEmailVerified = testCase "users create --email-verified stamps email_verified_at" $ withDb \pool connStr -> do+  let env = AdminEnv {config = cfg, pool = pool, connStr = connStr, argon2 = testArgon2Params}+  createUserAction env "verified@example.com" (PlainPassword "correct horse battery staple") Nothing True+  verified <- scalarInt pool "SELECT count(*) FROM shomei.shomei_users WHERE email = 'verified@example.com' AND email_verified_at IS NOT NULL"+  verified @?= 1++testUserCreateAppliesPasswordPolicy :: TestTree+testUserCreateAppliesPasswordPolicy = testCase "users create applies config.passwordPolicy" $ withDb \pool connStr -> do+  let policy = cfg.passwordPolicy {minLength = 40}+      env = AdminEnv {config = cfg {passwordPolicy = policy}, pool = pool, connStr = connStr, argon2 = testArgon2Params}+  expectExitFailure+    "users create with a password rejected by the deployment policy"+    (createUserAction env "policy@example.com" (PlainPassword "correct horse battery staple") Nothing False)+  users <- scalarInt pool "SELECT count(*) FROM shomei.shomei_users WHERE email = 'policy@example.com'"+  users @?= 0++testUsageErrorSummary :: TestTree+testUsageErrorSummary = testCase "database errors retain only category and SQLSTATE" do+  summarizeUsageError (Pool.ConnectionUsageError (Hasql.NetworkingConnectionError "password=secret"))+    @?= "could not connect to PostgreSQL"+  summarizeUsageError Pool.AcquisitionTimeoutUsageError+    @?= "timed out acquiring a connection"+  let detailed =+        Pool.SessionUsageError+          ( Hasql.StatementSessionError+              1+              0+              "INSERT INTO keys VALUES ($1) -- secret sql"+              ["encrypted-key-envelope"]+              True+              (Hasql.ServerStatementError (Hasql.ServerError "23505" "secret primary message" Nothing Nothing Nothing))+          )+      summary = summarizeUsageError detailed+  summary @?= "statement failed (SQLSTATE 23505)"+  assertBool "SQL and parameters are absent" (not ("secret" `Text.isInfixOf` summary) && not ("envelope" `Text.isInfixOf` summary))++-- Roles ----------------------------------------------------------------------++-- | The bootstrap path an operator actually runs: declare a role, grant it, read it back,+-- revoke it. Definitions publish no audit event; the grant and the revoke each publish one.+testRolesLifecycle :: TestTree+testRolesLifecycle =+  testCase "roles define/list-defined/grant/list/revoke round-trips and audits the grants" $ withDb \pool connStr -> do+    let env = AdminEnv {config = cfg, pool = pool, connStr = connStr, argon2 = testArgon2Params}+    createUserAction env "alice@example.com" (PlainPassword "correct horse battery staple") Nothing False+    uid <- scalarText pool "SELECT user_id::text FROM shomei.shomei_users WHERE email = 'alice@example.com'"++    -- The registry starts with the migration's seeded 'admin'.+    runRoles env RolesListDefined+    seeded <- scalarInt pool "SELECT count(*) FROM shomei.shomei_roles"+    seeded @?= 1++    runRoles env (RolesDefine "auditor" (Just "read the audit trail"))+    defined <- scalarInt pool "SELECT count(*) FROM shomei.shomei_roles"+    defined @?= 2+    -- Re-defining is idempotent and does not overwrite the description.+    runRoles env (RolesDefine "auditor" (Just "something else"))+    stillTwo <- scalarInt pool "SELECT count(*) FROM shomei.shomei_roles"+    stillTwo @?= 2+    desc <- scalarText pool "SELECT description FROM shomei.shomei_roles WHERE role = 'auditor'"+    desc @?= "read the audit trail"++    -- The CLI accepts a bare UUID as well as the typed id.+    runRoles env (RolesGrant uid "auditor" Nothing)+    granted <- scalarInt pool "SELECT count(*) FROM shomei.shomei_role_grants WHERE role = 'auditor'"+    granted @?= 1+    -- A CLI grant records no acting admin.+    noActor <- scalarInt pool "SELECT count(*) FROM shomei.shomei_role_grants WHERE granted_by IS NULL"+    noActor @?= 1+    -- Re-granting changes nothing and publishes nothing.+    runRoles env (RolesGrant uid "auditor" Nothing)+    stillOne <- scalarInt pool "SELECT count(*) FROM shomei.shomei_role_grants"+    stillOne @?= 1++    runRoles env (RolesList uid)+    runRoles env (RolesRevoke uid "auditor")+    afterRevoke <- scalarInt pool "SELECT count(*) FROM shomei.shomei_role_grants"+    afterRevoke @?= 0+    -- Revoking a grant that is not there is a no-op, not an error, and publishes nothing.+    runRoles env (RolesRevoke uid "auditor")++    -- Exactly one grant and one revoke landed in the audit trail; the two definitions and the+    -- repeated grant/revoke added nothing.+    grantEvents <- scalarInt pool "SELECT count(*) FROM shomei.shomei_auth_events WHERE event_type = 'role_granted'"+    revokeEvents <- scalarInt pool "SELECT count(*) FROM shomei.shomei_auth_events WHERE event_type = 'role_revoked'"+    grantEvents @?= 1+    revokeEvents @?= 1++-- | @users create@ drives the same 'Shomei.Session.Authentication.Workflow.signup' the HTTP route does, so a+-- CLI-created user must receive the configured default roles — audited, with no acting admin.+-- (Regression: 'Shomei.Admin.Env.loadAdminEnv' builds its own 'ShomeiConfig' rather than running+-- the server's loader, so it once ignored @SHOMEI_DEFAULT_ROLES@ entirely.)+testUserCreateAppliesDefaultRoles :: TestTree+testUserCreateAppliesDefaultRoles =+  testCase "users create applies config.defaultRoles, audited with no actor" $ withDb \pool connStr -> do+    let cfgWithDefaults = cfg {defaultRoles = Set.singleton (Role "member")}+        env = AdminEnv {config = cfgWithDefaults, pool = pool, connStr = connStr, argon2 = testArgon2Params}+        registryEnv = AdminEnv {config = cfg, pool = pool, connStr = connStr, argon2 = testArgon2Params}+    runRoles registryEnv (RolesDefine "member" Nothing)+    createUserAction env "alice@example.com" (PlainPassword "correct horse battery staple") Nothing False+    granted <-+      scalarInt+        pool+        """+        SELECT count(*) FROM shomei.shomei_role_grants g+        JOIN shomei.shomei_users u USING (user_id)+        WHERE u.email = 'alice@example.com' AND g.role = 'member' AND g.granted_by IS NULL+        """+    granted @?= 1+    events <- scalarInt pool "SELECT count(*) FROM shomei.shomei_auth_events WHERE event_type = 'role_granted'"+    events @?= 1++-- | The CLI has no boot-time validation, so it checks the registry itself: a default role that+-- was never defined aborts before any row is written, rather than surfacing a raw FK violation.+testUserCreateRefusesUndefinedDefaultRoles :: TestTree+testUserCreateRefusesUndefinedDefaultRoles =+  testCase "users create refuses an undefined default role and writes nothing" $ withDb \pool connStr -> do+    let env =+          AdminEnv+            { config = cfg {defaultRoles = Set.singleton (Role "nosuchrole")},+              pool = pool,+              connStr = connStr,+              argon2 = testArgon2Params+            }+    expectExitFailure+      "users create with an undefined default role"+      (createUserAction env "alice@example.com" (PlainPassword "correct horse battery staple") Nothing False)+    users <- scalarInt pool "SELECT count(*) FROM shomei.shomei_users"+    users @?= 0++-- | The typo guard: @roles grant --role adminn@ must fail loudly rather than mint a role no+-- gate will ever check. This is the failure mode the role registry exists to close.+testRolesGrantOfUndefinedRoleFails :: TestTree+testRolesGrantOfUndefinedRoleFails =+  testCase "roles grant of an undefined role exits nonzero and writes nothing" $ withDb \pool connStr -> do+    let env = AdminEnv {config = cfg, pool = pool, connStr = connStr, argon2 = testArgon2Params}+    createUserAction env "alice@example.com" (PlainPassword "correct horse battery staple") Nothing False+    uid <- scalarText pool "SELECT user_id::text FROM shomei.shomei_users WHERE email = 'alice@example.com'"+    expectExitFailure "grant of an undefined role" (runRoles env (RolesGrant uid "adminn" Nothing))+    grants <- scalarInt pool "SELECT count(*) FROM shomei.shomei_role_grants"+    grants @?= 0++-- | A grant naming a user that does not exist fails before touching the grant table.+testRolesGrantToUnknownUserFails :: TestTree+testRolesGrantToUnknownUserFails =+  testCase "roles grant to an unknown user exits nonzero and writes nothing" $ withDb \pool connStr -> do+    let env = AdminEnv {config = cfg, pool = pool, connStr = connStr, argon2 = testArgon2Params}+    expectExitFailure+      "grant to an unknown user"+      (runRoles env (RolesGrant "11111111-1111-1111-1111-111111111111" "admin" Nothing))+    grants <- scalarInt pool "SELECT count(*) FROM shomei.shomei_role_grants"+    grants @?= 0++-- | EP-9 permission wiring over the CLI: allow attaches a row, show renders (smoke), disallow+-- removes it, and allow on an undefined role exits nonzero without writing.+testRolesPermissionWiring :: TestTree+testRolesPermissionWiring =+  testCase "roles allow/show/disallow round-trip; allow on an undefined role exits nonzero" $ withDb \pool connStr -> do+    let env = AdminEnv {config = cfg, pool = pool, connStr = connStr, argon2 = testArgon2Params}+    runRoles env (RolesDefine "support" (Just "support staff"))+    runRoles env (RolesAllow "support" "tickets:write")+    afterAllow <- scalarInt pool "SELECT count(*) FROM shomei.shomei_role_permissions WHERE role = 'support' AND permission = 'tickets:write'"+    afterAllow @?= 1+    -- Idempotent: a second allow adds no row.+    runRoles env (RolesAllow "support" "tickets:write")+    stillOne <- scalarInt pool "SELECT count(*) FROM shomei.shomei_role_permissions WHERE role = 'support'"+    stillOne @?= 1+    -- show is a read; assert it runs without error (its output goes to stdout).+    runRoles env (RolesShow "support")+    runRoles env (RolesDisallow "support" "tickets:write")+    afterDisallow <- scalarInt pool "SELECT count(*) FROM shomei.shomei_role_permissions WHERE role = 'support'"+    afterDisallow @?= 0+    -- Wiring publishes no audit event.+    permEvents <- scalarInt pool "SELECT count(*) FROM shomei.shomei_auth_events WHERE event_type IN ('permission_allowed','permission_disallowed')"+    permEvents @?= 0+    -- Allow on an undefined role is a loud failure that writes nothing.+    expectExitFailure "allow on an undefined role" (runRoles env (RolesAllow "nosuchrole" "x:y"))+    none <- scalarInt pool "SELECT count(*) FROM shomei.shomei_role_permissions WHERE role = 'nosuchrole'"+    none @?= 0++-- | @roles grant --expires-in 1h@ lands a grant whose @expires_at@ is about an hour out, and the+-- @role_granted@ audit payload carries that same expiry (passive expiry: the audit trail is the+-- only record of the window).+testRolesGrantWithExpiry :: TestTree+testRolesGrantWithExpiry =+  testCase "roles grant --expires-in stamps the grant row and the audit payload with the window" $ withDb \pool connStr -> do+    let env = AdminEnv {config = cfg, pool = pool, connStr = connStr, argon2 = testArgon2Params}+    runRoles env (RolesDefine "support" (Just "support staff"))+    createUserAction env "alice@example.com" (PlainPassword "correct horse battery staple") Nothing False+    uid <- scalarText pool "SELECT user_id::text FROM shomei.shomei_users WHERE email = 'alice@example.com'"+    runRoles env (RolesGrant uid "support" (Just (ExpiresIn 3600)))+    -- The grant row's expiry is ~1h out (allow a wide window for clock/setup slack).+    secs <- scalarInt pool "SELECT EXTRACT(EPOCH FROM (expires_at - now()))::bigint FROM shomei.shomei_role_grants WHERE role = 'support'"+    assertBool ("expected ~3600s out, got " <> show secs) (secs > 3000 && secs <= 3600)+    -- The audit payload carries an expiresAt (non-null); pre-EP-9 grants carried none.+    withExpiry <- scalarInt pool "SELECT count(*) FROM shomei.shomei_auth_events WHERE event_type = 'role_granted' AND payload ? 'expiresAt' AND payload->>'expiresAt' IS NOT NULL"+    withExpiry @?= 1++-- | Parser-level: @--expires-in@ and @--expires-at@ are mutually exclusive, so supplying both is a+-- parse failure rather than a silently-ignored flag.+testRolesGrantBothExpiryFlagsFailsToParse :: TestTree+testRolesGrantBothExpiryFlagsFailsToParse =+  testCase "roles grant with both --expires-in and --expires-at fails to parse" $+    case execParserPure defaultPrefs (info rolesParser mempty) argv of+      Success _ -> assertFailure "expected supplying both expiry flags to fail parsing"+      _ -> pure ()+  where+    argv =+      [ "grant",+        "--user",+        "user_01ABC",+        "--role",+        "support",+        "--expires-in",+        "4h",+        "--expires-at",+        "2026-07-11T21:00:00Z"+      ]++testAuditQuery :: TestTree+testAuditQuery = testCase "audit reader returns published events; type filter + count work" $ withDb \pool _ -> do+  uid <- genUserId+  sid <- genSessionId+  let filters = AuditFilters Nothing Nothing [] Nothing Nothing 50 True+  typed <- toQuery filters {fUser = Just (idText uid), fSession = Just (idText sid)}+  legacy <- toQuery filters {fUser = Just (UUID.toText (userIdToUUID uid)), fSession = Just (UUID.toText (sessionIdToUUID sid))}+  typed.queryUserId @?= legacy.queryUserId+  typed.querySessionId @?= legacy.querySessionId+  typed.queryUserId @?= Just (userIdToUUID uid)+  typed.querySessionId @?= Just (sessionIdToUUID sid)++  t <- getCurrentTime+  -- Seed two events through the real PostgreSQL publisher.+  okR+    =<< runPublish+      pool+      ( do+          publishAuthEvent (Event.LoginFailed (Event.LoginFailedData Nothing Nothing t))+          publishAuthEvent (Event.LoginSucceeded (Event.LoginSucceededData uid sid (addUTCTime 1 t)))+      )+  -- Read them back through the CLI's reader stack (newest-first).+  allEvents <- okR =<< runAuditReader pool (queryAuthEvents emptyAuditQuery)+  map (.storedEventType) allEvents @?= ["login_succeeded", "login_failed"]+  filtered <- okR =<< runAuditReader pool (queryAuthEvents typed)+  length filtered @?= 1+  case map toJsonObject filtered of+    [Aeson.Object row] -> do+      KeyMap.lookup "userId" row @?= Just (Aeson.String (idText uid))+      KeyMap.lookup "sessionId" row @?= Just (Aeson.String (idText sid))+    _ -> assertFailure "expected one canonical audit object"+  -- Type filter narrows to the failed login only.+  failed <- okR =<< runAuditReader pool (queryAuthEvents emptyAuditQuery {queryEventTypes = ["login_failed"]})+  map (.storedEventType) failed @?= ["login_failed"]+  -- Count matches the total.+  n <- okR =<< runAuditReader pool (countAuthEvents emptyAuditQuery)+  n @?= 2++-- | Run the audit-event publisher over the pool (test-only seeding helper).+runPublish ::+  Pool ->+  Eff '[AuthEventPublisher, Database, Error AuthError, IOE] a ->+  IO (Either AuthError a)+runPublish pool =+  runEff+    . runErrorNoCallStack+    . runDatabasePool pool+    . runAuthEventPublisherPostgres++okR :: (Show e) => Either e a -> IO a+okR = either (assertFailure . show) pure++-- Helpers --------------------------------------------------------------------++onlyPendingKid :: Pool -> IO Text+onlyPendingKid pool = do+  keys <- listAllKeys pool+  case filter (\k -> k.status == KeyPending) keys of+    [k] -> pure k.keyId+    ks -> assertFailure ("expected exactly one pending key, got " <> show (length ks))++requireKey :: Pool -> Text -> IO StoredSigningKey+requireKey pool kid = do+  keys <- listAllKeys pool+  maybe (assertFailure ("no key " <> show kid)) pure (find (\k -> k.keyId == kid) keys)++statusOf :: Pool -> Text -> IO SigningKeyStatus+statusOf pool kid = (.status) <$> requireKey pool kid++-- | The @kid@ of the key that currently signs.+signerKid :: Keys.LoadedKeys -> Text+signerKid ks = keyKid ks.signingKey++-- | A deterministic 32-byte KEK, distinct per character.+testKek :: Char -> IO KeyEncryptionKey+testKek c =+  either+    (assertFailure . Text.unpack)+    pure+    (keyEncryptionKeyFromBase64 (TE.decodeUtf8 (convertToBase Base64 (BS8.replicate 32 c))))++-- | The exactly-one key row the encryption tests seed.+onlyKey :: Pool -> IO StoredSigningKey+onlyKey pool =+  listAllKeys pool >>= \case+    [k] -> pure k+    ks -> assertFailure ("expected exactly one signing key, got " <> show (length ks))++-- | Read the raw column, bypassing every conversion — the tests assert on stored bytes.+storedPrivate :: Pool -> IO Text+storedPrivate pool = scalarText pool "SELECT private_key_jwk FROM shomei.shomei_signing_keys"++storedPublic :: Pool -> IO Text+storedPublic pool = scalarText pool "SELECT public_key_jwk FROM shomei.shomei_signing_keys"++scalarText :: Pool -> Text -> IO Text+scalarText 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 (D.column (D.nonNullable D.text)))++buildJwks :: [StoredSigningKey] -> IO JWKSet+buildJwks stored = do+  jwks <- traverse (liftEither . publicJwkFromStored) stored+  pure (JWKSet jwks)++signWith :: JWK -> IO Text+signWith jwk = do+  uid <- genUserId+  sid <- genSessionId+  t <- getCurrentTime+  let claims =+        AuthClaims+          { subject = uid,+            sessionId = sid,+            issuer = cfg.issuer,+            audience = cfg.audience,+            issuedAt = t,+            expiresAt = addUTCTime 900 t,+            authTime = t,+            scopes = Set.empty,+            roles = Set.empty,+            permissions = Set.empty,+            actor = Nothing,+            extraClaims = mempty+          }+  r <- signAccessToken jwk claims+  case r of+    Right (AccessToken tok) -> pure tok+    Left e -> assertFailure ("signing failed: " <> show e)++liftEither :: (Show e) => Either e a -> IO a+liftEither = either (assertFailure . show) pure++isRight :: Either a b -> Bool+isRight = either (const False) (const True)++-- Service accounts (MasterPlan 7 EP-4) --------------------------------------++-- | These drive the CLI's *action* functions rather than 'runServiceAccounts', because the+-- generated secret is printed exactly once and never re-readable. Capturing the process's stdout+-- to recover it is not an option: tasty runs these cases in parallel, and @hDuplicateTo@ on the+-- global 'stdout' is process-wide, so two capturing cases interleave and read each other's+-- output. (Observed: the same suite reporting "All 22 tests passed" on one run and+-- "2 out of 22 tests failed" on the next.) The actions return what they did; the printing+-- wrapper is a one-liner over them.+adminEnv :: Pool -> Text -> AdminEnv+adminEnv pool connStr = AdminEnv {config = cfg, pool = pool, connStr = connStr, argon2 = testArgon2Params}++saClientId' :: ServiceAccount -> Text+saClientId' ServiceAccount {clientId} = clientId++-- | Run the real @client_credentials@ workflow against PostgreSQL, exactly as @\/oauth\/token@+-- does, with a fake signer (this suite is not testing JWT signing).+runGrant ::+  Pool ->+  ClientCredentialsGrant ->+  IO (Either AuthError (Either AuthError GrantedToken))+runGrant pool grant =+  runEff+    . runErrorNoCallStack+    . runDatabasePool pool+    . runClockIO+    . runAuthEventPublisherPostgres+    . runTokenSignerFakeAdmin+    . runSessionStorePostgres+    . runServiceAccountStorePostgres+    . runUserStorePostgres+    $ grantClientCredentials cfg grant++runTokenSignerFakeAdmin :: Eff (TokenSigner : es) a -> Eff es a+runTokenSignerFakeAdmin = interpret_ \case+  SignAccessToken _ -> pure (AccessToken "admin-test-token")+  SignIdToken _ -> pure (IdToken "admin-test-id-token")++grantWith :: Pool -> Text -> Text -> Maybe (Set Scope) -> IO (Either AuthError GrantedToken)+grantWith pool cid secret scopes = do+  outcome <- runGrant pool ClientCredentialsGrant {clientId = cid, clientSecret = secret, requestedScopes = scopes}+  either (\e -> assertFailure ("infrastructure error: " <> show e)) pure outcome++-- | create → the account exists, is active, owns a backing user row, and the secret it returned+-- authenticates through the real grant workflow. Only the digest is stored.+testServiceAccountsLifecycle :: TestTree+testServiceAccountsLifecycle =+  testCase "service-accounts create: yields a working secret, stores only its digest" $ withDb \pool connStr -> do+    let env = adminEnv pool connStr+    (account, secret) <- createAction env "rei connector" ["kawa:ingest", "signal:raise"]+    let cid = saClientId' account++    n <- scalarInt pool "SELECT count(*) FROM shomei.shomei_service_accounts WHERE status = 'active'"+    n @?= 1+    backing <-+      scalarInt+        pool+        ("SELECT count(*) FROM shomei.shomei_users u JOIN shomei.shomei_service_accounts s ON s.user_id = u.user_id WHERE u.login_id = '" <> cid <> "'")+    assertEqual "the account owns a backing user row keyed by its client id" 1 backing++    -- The plaintext secret is nowhere in the database; only its SHA-256 hex digest is.+    plaintext <- scalarInt pool ("SELECT count(*) FROM shomei.shomei_service_accounts WHERE secret_hash = '" <> secret <> "'")+    assertEqual "the plaintext secret is never stored" 0 plaintext+    digest <- scalarInt pool ("SELECT count(*) FROM shomei.shomei_service_accounts WHERE secret_hash = '" <> sha256Hex secret <> "'")+    assertEqual "the stored hash is sha256Hex of the returned secret" 1 digest++    -- And it authenticates: an omitted scope grants the whole allow-list.+    granted <- grantWith pool cid secret Nothing+    case granted of+      Left e -> assertFailure ("expected the generated secret to authenticate, got " <> show e)+      Right g -> g.grantedScopes @?= Set.fromList [Scope "kawa:ingest", Scope "signal:raise"]++    -- A wrong secret does not.+    wrong <- grantWith pool cid "not-the-secret" Nothing+    fmap (const ()) wrong @?= Left OAuthClientInvalid++    created <- scalarInt pool "SELECT count(*) FROM shomei.shomei_auth_events WHERE event_type = 'service_account_created'"+    created @?= 1+    withUser <- scalarInt pool "SELECT count(*) FROM shomei.shomei_auth_events WHERE event_type = 'service_account_created' AND user_id IS NOT NULL"+    assertEqual "the lifecycle event files under the backing user" 1 withUser++testServiceAccountsPrivilegeScopeAllowed :: TestTree+testServiceAccountsPrivilegeScopeAllowed =+  testCase "service-accounts create allows a privilege scope as the account's own authority" $ withDb \pool connStr -> do+    let env = adminEnv pool connStr+    (account, secret) <- createAction env "support operator" ["impersonate:user"]+    granted <- grantWith pool (saClientId' account) secret Nothing+    case granted of+      Left err -> assertFailure ("the intended service-account holder was refused: " <> show err)+      Right token -> token.grantedScopes @?= Set.singleton (Scope "impersonate:user")++-- | rotate-secret invalidates the old secret immediately (single-secret model, no overlap);+-- revoke refuses every subsequent token while keeping the row.+testServiceAccountsRotateAndRevoke :: TestTree+testServiceAccountsRotateAndRevoke =+  testCase "service-accounts rotate-secret then revoke: old secret dies at once, revoked account refuses all" $ withDb \pool connStr -> do+    let env = adminEnv pool connStr+    (account, oldSecret) <- createAction env "rei connector" ["kawa:ingest"]+    let cid = saClientId' account++    (_, newSecret) <- rotateSecretAction env cid+    assertBool "rotation produces a different secret" (newSecret /= oldSecret)++    old <- grantWith pool cid oldSecret Nothing+    fmap (const ()) old @?= Left OAuthClientInvalid+    new <- grantWith pool cid newSecret Nothing+    case new of+      Left e -> assertFailure ("expected the rotated secret to authenticate, got " <> show e)+      Right g -> g.grantedScopes @?= Set.singleton (Scope "kawa:ingest")++    -- rotated_at is stamped, status is untouched.+    stillActive <- scalarInt pool "SELECT count(*) FROM shomei.shomei_service_accounts WHERE status = 'active' AND rotated_at IS NOT NULL"+    stillActive @?= 1++    _ <- revokeAction env cid+    revoked <- grantWith pool cid newSecret Nothing+    fmap (const ()) revoked @?= Left OAuthClientInvalid++    -- The row survives revocation, so the audit trail and the refusal both still resolve it.+    rows <- scalarInt pool ("SELECT count(*) FROM shomei.shomei_service_accounts WHERE client_id = '" <> cid <> "' AND status = 'revoked' AND revoked_at IS NOT NULL")+    rows @?= 1+    events <- scalarInt pool "SELECT count(*) FROM shomei.shomei_auth_events WHERE event_type IN ('service_account_secret_rotated', 'service_account_revoked')"+    events @?= 2++    -- list reports it, still exactly one row.+    accounts <- listAction env+    map saClientId' accounts @?= [cid]++-- | A typo in the client id aborts rather than silently updating zero rows.+testServiceAccountsUnknownClientIdFails :: TestTree+testServiceAccountsUnknownClientIdFails =+  testCase "service-accounts rotate-secret/revoke on an unknown client id abort" $ withDb \pool connStr -> do+    let env = adminEnv pool connStr+    expectExitFailure "rotate-secret of an unknown client" (void (rotateSecretAction env "svcacct_nope"))+    expectExitFailure "revoke of an unknown client" (void (revokeAction env "svcacct_nope"))++-- shomei-admin oauth-clients (EP-5) -----------------------------------------++ocClientId' :: OAuthClient -> Text+ocClientId' OAuthClient {clientId} = clientId++ocStatus' :: OAuthClient -> OAuthClientStatus+ocStatus' OAuthClient {status} = status++ocDisplayName' :: OAuthClient -> Text+ocDisplayName' OAuthClient {displayName} = displayName++-- | create → the client exists, is active, stores only the digest of the once-printed secret,+-- and owns NO backing user row (unlike a service account, it is never a token subject).+-- Then list sees it, and revoke keeps the row while flipping its status.+testOAuthClientsLifecycle :: TestTree+testOAuthClientsLifecycle =+  testCase "oauth-clients create/list/revoke: digest-only secret, no backing user, row survives revocation" $ withDb \pool connStr -> do+    let env = adminEnv pool connStr+    (client, mSecret) <-+      OAuthClients.createAction+        env+        "grafana"+        ConfidentialClient+        ["https://grafana.example.com/callback"]+        ["openid", "profile"]+    secret <- maybe (assertFailure "a confidential client must be issued a secret") pure mSecret+    let cid = ocClientId' client++    ocStatus' client @?= OAuthClientActive+    n <- scalarInt pool "SELECT count(*) FROM shomei.shomei_oauth_clients WHERE status = 'active'"+    n @?= 1++    -- The plaintext secret is nowhere in the database; only its SHA-256 hex digest is.+    plaintext <- scalarInt pool ("SELECT count(*) FROM shomei.shomei_oauth_clients WHERE secret_hash = '" <> secret <> "'")+    assertEqual "the plaintext secret is never stored" 0 plaintext+    digest <- scalarInt pool ("SELECT count(*) FROM shomei.shomei_oauth_clients WHERE secret_hash = '" <> sha256Hex secret <> "'")+    assertEqual "the stored hash is sha256Hex of the returned secret" 1 digest++    -- An OAuth client is not a principal: no shomei_users row is provisioned for it.+    backing <- scalarInt pool ("SELECT count(*) FROM shomei.shomei_users WHERE login_id = '" <> cid <> "'")+    assertEqual "an oauth client gets no backing user row" 0 backing++    listed <- OAuthClients.listAction env+    map ocDisplayName' listed @?= ["grafana"]++    created <- scalarInt pool "SELECT count(*) FROM shomei.shomei_auth_events WHERE event_type = 'oauth_client_created'"+    created @?= 1+    -- The client is not a user, so the audit row files under no user.+    withUser <- scalarInt pool "SELECT count(*) FROM shomei.shomei_auth_events WHERE event_type = 'oauth_client_created' AND user_id IS NOT NULL"+    assertEqual "an oauth client lifecycle event names no user" 0 withUser++    _ <- OAuthClients.revokeAction env cid+    revoked <- scalarInt pool ("SELECT count(*) FROM shomei.shomei_oauth_clients WHERE client_id = '" <> cid <> "' AND status = 'revoked' AND revoked_at IS NOT NULL")+    assertEqual "revocation flips status, stamps revoked_at, and keeps the row" 1 revoked+    revokedEvents <- scalarInt pool "SELECT count(*) FROM shomei.shomei_auth_events WHERE event_type = 'oauth_client_revoked'"+    revokedEvents @?= 1++-- | A public client is issued no secret at all — not one that is stored and never checked. PKCE+-- is what binds its authorize request to its token request.+testOAuthClientsPublicHasNoSecret :: TestTree+testOAuthClientsPublicHasNoSecret =+  testCase "oauth-clients create --type public: no secret is generated or stored" $ withDb \pool connStr -> do+    let env = adminEnv pool connStr+    (client, mSecret) <-+      OAuthClients.createAction env "spa" PublicClient ["https://spa.example.com/cb"] ["openid"]+    assertEqual "a public client is issued no secret" Nothing mSecret+    nulls <-+      scalarInt+        pool+        ("SELECT count(*) FROM shomei.shomei_oauth_clients WHERE client_id = '" <> ocClientId' client <> "' AND secret_hash IS NULL AND client_type = 'public'")+    assertEqual "its secret_hash is a real NULL" 1 nulls++testOAuthClientsPrivilegeScopeFails :: TestTree+testOAuthClientsPrivilegeScopeFails =+  testCase "oauth-clients create refuses a privilege scope without inserting a row" $ withDb \pool connStr -> do+    let env = adminEnv pool connStr+    expectExitFailure+      "registering shomei:admin on an OAuth client"+      ( void+          ( OAuthClients.createAction+              env+              "privilege escalation client"+              ConfidentialClient+              ["https://client.example.com/callback"]+              ["openid", "shomei:admin"]+          )+      )+    rows <- scalarInt pool "SELECT count(*) FROM shomei.shomei_oauth_clients"+    rows @?= 0++-- | Revoking an unknown client_id exits nonzero rather than silently updating zero rows.+testOAuthClientsRevokeUnknownFails :: TestTree+testOAuthClientsRevokeUnknownFails =+  testCase "oauth-clients revoke of an unknown client_id exits nonzero and writes nothing" $ withDb \pool connStr -> do+    let env = adminEnv pool connStr+    expectExitFailure "revoke unknown" (void (OAuthClients.revokeAction env "oauthclient_does_not_exist"))+    events <- scalarInt pool "SELECT count(*) FROM shomei.shomei_auth_events WHERE event_type = 'oauth_client_revoked'"+    events @?= 0++testKeyWriteRollback :: TestTree+testKeyWriteRollback = testCase "key activation and rewrap roll back every write on an injected later failure" $ withDb \pool _ -> do+  oldKek <- testKek 'a'+  newKek <- testKek 'b'+  keysGenerate oldKek ES256 pool+  first <- onlyPendingKid pool+  keysActivate pool first+  keysGenerate oldKek ES256 pool+  second <- onlyPendingKid pool+  before <- listAllKeys pool+  execSql pool "CREATE FUNCTION shomei.reject_activation() RETURNS trigger LANGUAGE plpgsql AS $$ BEGIN IF NEW.status='active' THEN RAISE EXCEPTION 'injected activation failure' USING ERRCODE='23514'; END IF; RETURN NEW; END $$; CREATE TRIGGER reject_activation BEFORE UPDATE ON shomei.shomei_signing_keys FOR EACH ROW EXECUTE FUNCTION shomei.reject_activation()"+  expectExitFailure "activation write rollback" (keysActivate pool second)+  statusOf pool first >>= (@?= KeyActive)+  statusOf pool second >>= (@?= KeyPending)+  afterActivation <- listAllKeys pool+  map (\key -> (key.keyId, key.status, key.activatedAt, key.retiredAt)) afterActivation @?= map (\key -> (key.keyId, key.status, key.activatedAt, key.retiredAt)) before+  execSql pool "DROP TRIGGER reject_activation ON shomei.shomei_signing_keys; CREATE SEQUENCE shomei.rewrap_writes; CREATE FUNCTION shomei.reject_second_rewrap() RETURNS trigger LANGUAGE plpgsql AS $$ BEGIN IF nextval('shomei.rewrap_writes')=2 THEN RAISE EXCEPTION 'injected rewrap failure' USING ERRCODE='23514'; END IF; RETURN NEW; END $$; CREATE TRIGGER reject_second_rewrap BEFORE UPDATE OF private_key_jwk ON shomei.shomei_signing_keys FOR EACH ROW EXECUTE FUNCTION shomei.reject_second_rewrap()"+  expectExitFailure "second rewrap write rollback" (keysRewrap oldKek newKek pool)+  scalarInt pool "SELECT last_value FROM shomei.rewrap_writes" >>= (@?= 2)+  after <- listAllKeys pool+  map (.privateKeyJwk) after @?= map (.privateKeyJwk) before+  forM_ after \key -> do+    assertBool "old KEK still decrypts every original row" (isRight (decryptStoredSigningKey oldKek key))+    assertBool "new KEK cannot decrypt a partially committed row" (not (isRight (decryptStoredSigningKey newKek key)))++testMultipleActiveFailClosed :: TestTree+testMultipleActiveFailClosed = testCase "key material loader rejects multiple active keys even after index bypass" $ withDb \pool _ -> do+  kek <- testKek 'a'+  keysGenerate kek ES256 pool+  first <- onlyPendingKid pool+  keysActivate pool first+  keysGenerate kek ES256 pool+  second <- onlyPendingKid pool+  execSql pool ("DROP INDEX shomei.shomei_signing_keys_one_active; UPDATE shomei.shomei_signing_keys SET status='active',activated_at=now() WHERE key_id='" <> second <> "'")+  loaded <- Keys.loadKeyMaterial kek pool+  case loaded of+    Left reason -> assertBool "diagnostic names the invariant" ("multiple active signing keys" `Text.isInfixOf` reason)+    Right _ -> assertFailure "ambiguous signer was accepted"
+ test/Main.hs view
@@ -0,0 +1,16 @@+module Main (main) where++import Shomei.Server.E2ESpec qualified as E2ESpec+import Shomei.Server.MiddlewareSpec qualified as MiddlewareSpec+import Shomei.Server.NotifySpec qualified as NotifySpec+import Shomei.Server.RuntimeSpec qualified as RuntimeSpec+import Shomei.Server.SupervisorSpec qualified as SupervisorSpec+import Test.Tasty (defaultMain, testGroup)++main :: IO ()+main =+  defaultMain+    ( testGroup+        "shomei-server"+        [RuntimeSpec.tests, NotifySpec.tests, SupervisorSpec.tests, MiddlewareSpec.tests, E2ESpec.tests]+    )
+ test/Shomei/Server/ConfigSpec.hs view
@@ -0,0 +1,868 @@+-- | Tests for EP-5's Dhall + environment configuration loader. Writes a small Dhall file to a+-- temp path, loads it through 'loadConfig' (which renders it via @dhall-to-json@ and decodes the+-- result), asserts the parsed values win over the built-in defaults, and then proves an+-- environment variable overrides the file value (twelve-factor precedence). Using a temp file+-- avoids any dependency on the test's working directory.+module Main (main) where++import Control.Exception (try)+import Data.Aeson (Value (Object), eitherDecodeStrict', encode, toJSON)+import Data.Aeson.KeyMap qualified as KeyMap+import Data.ByteString.Lazy.Char8 qualified as LBS8+import Data.List (isInfixOf)+import Data.Set qualified as Set+import Data.Text qualified as Text+import Data.Text.Encoding qualified as Text+import Shomei.Account.Password.Domain (PasswordPolicy (..))+import Shomei.Account.Password.Hash.Postgres (Argon2Params (..))+import Shomei.Authorization.Claims.Domain (Issuer (..))+import Shomei.Config (CookieConfig (..), MachineTokenConfig (..), MfaConfig (..), NotifierConfig (..), NotifierTransport (..), RateLimitConfig (..), ShomeiConfig (..), SigningKeyConfig (..), SmtpConfig (..), SmtpTlsMode (..), WebAuthnConfig (..), WebhookConfig (..))+import Shomei.Notify (NotifierSecrets (..), smtpPasswordText, webhookSecretBytes)+import Shomei.Server.Config (FileConfig, ServerSettings (..), SweepSettings (..), loadConfig, loadConfigFromEnv, loadCoreConfig, loadNotifierSecretsFromEnv)+import Shomei.Server.Keys (loadKekFromEnv)+import System.Directory (makeAbsolute)+import System.Environment (setEnv, unsetEnv)+import System.IO.Error (isUserError)+import System.Process (readProcess)+import Test.Tasty (TestTree, defaultMain)+import Test.Tasty.HUnit (Assertion, assertBool, assertFailure, testCase, (@?=))++configPath :: FilePath+configPath = "/tmp/shomei-config-test.dhall"++schemaProbePath :: FilePath+schemaProbePath = "/tmp/shomei-schema-probe.dhall"++-- A partial config (FileConfig's fields are all optional, so absent keys fall back to defaults).+dhallContents :: String+dhallContents =+  "{ issuer = \"shomei-prod\""+    <> ", databaseUrl = \"host=fromfile dbname=shomei\""+    <> ", port = 8080"+    <> ", bindHost = \"127.0.0.1\""+    <> ", maxConnections = 32"+    <> ", slowClientTimeoutSeconds = 12"+    <> ", dbPoolSize = 25"+    <> ", dbPoolAcquisitionTimeoutMs = 2500"+    <> ", dbStatementTimeoutMs = 5000"+    <> ", notifierQueueSize = 12"+    <> ", maxFailedLoginsPerAccount = 7"+    <> ", metricsEnabled = False"+    <> ", keyRefreshIntervalSeconds = 15"+    <> ", allowedClockSkewSeconds = 20"+    <> ", passwordMinLength = 16"+    <> ", passwordRejectCommon = False"+    <> ", webauthnRpId = \"auth.fromfile.test\""+    <> ", webauthnOrigins = [ \"https://auth.fromfile.test\" ]"+    <> ", webauthnUserVerification = \"required\""+    <> ", mfaRequireSecondFactor = False"+    <> ", machineTokenTtlSeconds = 120"+    <> " }"++main :: IO ()+main = do+  writeFile configPath dhallContents+  defaultMain testLoadAndOverride++-- | With neither Dhall file nor pool env vars, the pool knobs reproduce the values that were+-- hardcoded before they became configuration.+poolDefaults :: Assertion+poolDefaults = do+  unsetEnv "SHOMEI_CONFIG"+  unsetEnv "SHOMEI_DB_POOL_SIZE"+  unsetEnv "SHOMEI_DB_POOL_ACQUISITION_TIMEOUT_MS"+  unsetEnv "SHOMEI_DB_STATEMENT_TIMEOUT_MS"+  unsetEnv "SHOMEI_NOTIFIER_QUEUE_SIZE"+  setEnv "PG_CONNECTION_STRING" "host=localhost dbname=shomei"+  (_, settings) <- loadConfigFromEnv+  settings.serverBindHost @?= "*4"+  settings.serverMaxConnections @?= 1024+  settings.serverSlowClientTimeoutSeconds @?= 30+  settings.serverDbPoolSize @?= 10+  settings.serverDbPoolAcquisitionTimeoutMs @?= 10000+  settings.serverDbStatementTimeoutMs @?= 30000+  settings.serverDbTransactionMaxAttempts @?= 3+  settings.serverDbTransactionDeadlineMs @?= 5000+  settings.serverNotifierQueueSize @?= 1024+  unsetEnv "PG_CONNECTION_STRING"++-- | A zero-size pool deadlocks every request and a zero acquisition timeout fails every+-- checkout, so the loader refuses to start rather than booting a server that cannot serve.+poolRejectsNonPositive :: Assertion+poolRejectsNonPositive = do+  unsetEnv "SHOMEI_CONFIG"+  setEnv "PG_CONNECTION_STRING" "host=localhost dbname=shomei"+  setEnv "SHOMEI_DB_POOL_SIZE" "0"+  sizeResult <- try loadConfigFromEnv+  expectUserErrorNaming "SHOMEI_DB_POOL_SIZE" sizeResult+  unsetEnv "SHOMEI_DB_POOL_SIZE"+  setEnv "SHOMEI_DB_POOL_ACQUISITION_TIMEOUT_MS" "-1"+  timeoutResult <- try loadConfigFromEnv+  expectUserErrorNaming "SHOMEI_DB_POOL_ACQUISITION_TIMEOUT_MS" timeoutResult+  unsetEnv "SHOMEI_DB_POOL_ACQUISITION_TIMEOUT_MS"+  setEnv "SHOMEI_DB_STATEMENT_TIMEOUT_MS" "-1"+  statementTimeoutResult <- try loadConfigFromEnv+  expectUserErrorNaming "SHOMEI_DB_STATEMENT_TIMEOUT_MS" statementTimeoutResult+  unsetEnv "SHOMEI_DB_STATEMENT_TIMEOUT_MS"+  setEnv "SHOMEI_NOTIFIER_QUEUE_SIZE" "0"+  notifierQueueResult <- try loadConfigFromEnv+  expectUserErrorNaming "SHOMEI_NOTIFIER_QUEUE_SIZE" notifierQueueResult+  unsetEnv "SHOMEI_NOTIFIER_QUEUE_SIZE"+  mapM_+    ( \key -> do+        setEnv key "0"+        invalid <- try loadConfigFromEnv+        expectUserErrorNaming key invalid+        unsetEnv key+    )+    ["SHOMEI_DB_TRANSACTION_MAX_ATTEMPTS", "SHOMEI_DB_TRANSACTION_DEADLINE_MS", "SHOMEI_MAX_CONNECTIONS", "SHOMEI_SLOW_CLIENT_TIMEOUT_SECONDS"]+  setEnv "SHOMEI_DB_TRANSACTION_MAX_ATTEMPTS" "2"+  setEnv "SHOMEI_DB_TRANSACTION_DEADLINE_MS" "250"+  (_, bounded) <- loadConfigFromEnv+  bounded.serverDbTransactionMaxAttempts @?= 2+  bounded.serverDbTransactionDeadlineMs @?= 250+  unsetEnv "SHOMEI_DB_TRANSACTION_MAX_ATTEMPTS"+  unsetEnv "SHOMEI_DB_TRANSACTION_DEADLINE_MS"+  unsetEnv "PG_CONNECTION_STRING"++sweepEnvVars :: [String]+sweepEnvVars =+  [ "SHOMEI_SWEEP_ENABLED",+    "SHOMEI_SWEEP_INTERVAL_SECONDS",+    "SHOMEI_SWEEP_BATCH_SIZE",+    "SHOMEI_SWEEP_DEAD_SESSION_GRACE_DAYS",+    "SHOMEI_SWEEP_ONE_TIME_TOKEN_GRACE_DAYS",+    "SHOMEI_SWEEP_CEREMONY_GRACE_MINUTES",+    "SHOMEI_LOGIN_ATTEMPT_RETENTION_DAYS",+    "SHOMEI_AUTH_EVENT_RETENTION_DAYS"+  ]++-- | With no file and no env, the sweeper is on, hourly, and retains the audit trail forever.+sweepDefaults :: Assertion+sweepDefaults = do+  unsetEnv "SHOMEI_CONFIG"+  mapM_ unsetEnv sweepEnvVars+  setEnv "PG_CONNECTION_STRING" "host=localhost dbname=shomei"+  (_, settings) <- loadConfigFromEnv+  let sweep = settings.serverSweep+  sweep.sweepEnabled @?= True+  sweep.sweepIntervalSeconds @?= 3600+  sweep.sweepBatchSize @?= 1000+  sweep.sweepDeadSessionGraceDays @?= 30+  sweep.sweepOneTimeTokenGraceDays @?= 7+  sweep.sweepCeremonyGraceMinutes @?= 60+  sweep.sweepLoginAttemptRetentionDays @?= 90+  -- The one conservative default: never delete the compliance record on your own initiative.+  sweep.sweepAuthEventRetentionDays @?= Nothing+  unsetEnv "PG_CONNECTION_STRING"++-- | Every sweep knob is settable from the environment, and a non-positive audit-retention+-- window means "retain forever" rather than "delete everything" — the failure mode of getting+-- that backwards is unrecoverable.+sweepEnvOverrides :: Assertion+sweepEnvOverrides = do+  unsetEnv "SHOMEI_CONFIG"+  setEnv "PG_CONNECTION_STRING" "host=localhost dbname=shomei"+  setEnv "SHOMEI_SWEEP_ENABLED" "false"+  setEnv "SHOMEI_SWEEP_INTERVAL_SECONDS" "900"+  setEnv "SHOMEI_SWEEP_BATCH_SIZE" "250"+  setEnv "SHOMEI_SWEEP_DEAD_SESSION_GRACE_DAYS" "0"+  setEnv "SHOMEI_LOGIN_ATTEMPT_RETENTION_DAYS" "30"+  setEnv "SHOMEI_AUTH_EVENT_RETENTION_DAYS" "365"+  (_, settings) <- loadConfigFromEnv+  let sweep = settings.serverSweep+  sweep.sweepEnabled @?= False+  sweep.sweepIntervalSeconds @?= 900+  sweep.sweepBatchSize @?= 250+  -- A zero grace period is legal: sweep a session the moment it expires.+  sweep.sweepDeadSessionGraceDays @?= 0+  sweep.sweepLoginAttemptRetentionDays @?= 30+  sweep.sweepAuthEventRetentionDays @?= Just 365++  -- Zero (or negative) turns audit deletion back off.+  setEnv "SHOMEI_AUTH_EVENT_RETENTION_DAYS" "0"+  (_, offSettings) <- loadConfigFromEnv+  offSettings.serverSweep.sweepAuthEventRetentionDays @?= Nothing++  mapM_ unsetEnv sweepEnvVars+  unsetEnv "PG_CONNECTION_STRING"++-- | A zero interval would spin the sweeper thread and a zero batch size would make it delete+-- nothing forever, so the loader refuses both. @sweepEnabled = false@ is the off-switch.+sweepRejectsNonPositive :: Assertion+sweepRejectsNonPositive = do+  unsetEnv "SHOMEI_CONFIG"+  setEnv "PG_CONNECTION_STRING" "host=localhost dbname=shomei"+  setEnv "SHOMEI_SWEEP_INTERVAL_SECONDS" "0"+  intervalResult <- try loadConfigFromEnv+  expectUserErrorNaming "SHOMEI_SWEEP_INTERVAL_SECONDS" intervalResult+  unsetEnv "SHOMEI_SWEEP_INTERVAL_SECONDS"++  setEnv "SHOMEI_SWEEP_BATCH_SIZE" "0"+  batchResult <- try loadConfigFromEnv+  expectUserErrorNaming "SHOMEI_SWEEP_BATCH_SIZE" batchResult+  unsetEnv "SHOMEI_SWEEP_BATCH_SIZE"++  -- A negative grace period would sweep rows that have not expired yet.+  setEnv "SHOMEI_SWEEP_CEREMONY_GRACE_MINUTES" "-1"+  graceResult <- try loadConfigFromEnv+  expectUserErrorNaming "SHOMEI_SWEEP_CEREMONY_GRACE_MINUTES" graceResult+  unsetEnv "SHOMEI_SWEEP_CEREMONY_GRACE_MINUTES"+  unsetEnv "PG_CONNECTION_STRING"++-- | Argon2 defaults, env overrides, and the refusal of non-positive costs.+argon2Settings :: Assertion+argon2Settings = do+  unsetEnv "SHOMEI_CONFIG"+  mapM_ unsetEnv argon2EnvVars+  setEnv "PG_CONNECTION_STRING" "host=localhost dbname=shomei"++  (_, defaults) <- loadConfigFromEnv+  defaults.serverArgon2.memoryKiB @?= 65536+  defaults.serverArgon2.iterations @?= 3+  defaults.serverArgon2.parallelism @?= 1+  defaults.serverHashingMaxConcurrency @?= 2++  setEnv "SHOMEI_ARGON2_MEMORY_KIB" "32768"+  setEnv "SHOMEI_ARGON2_ITERATIONS" "4"+  setEnv "SHOMEI_HASHING_MAX_CONCURRENCY" "4"+  (_, overridden) <- loadConfigFromEnv+  overridden.serverArgon2.memoryKiB @?= 32768+  overridden.serverArgon2.iterations @?= 4+  overridden.serverArgon2.parallelism @?= 1+  overridden.serverHashingMaxConcurrency @?= 4+  mapM_ unsetEnv argon2EnvVars++  setEnv "SHOMEI_ARGON2_MEMORY_KIB" "64"+  setEnv "SHOMEI_ARGON2_PARALLELISM" "16"+  hardFloorResult <- try loadConfigFromEnv+  expectUserErrorNaming "SHOMEI_ARGON2_MEMORY_KIB" hardFloorResult++  setEnv "SHOMEI_ARGON2_MEMORY_KIB" "128"+  (_, boundary) <- loadConfigFromEnv+  boundary.serverArgon2 @?= Argon2Params 128 3 16+  mapM_ unsetEnv argon2EnvVars++  -- crypton would reject these deep inside a login; the loader names the variable instead.+  -- A zero permit count would block every login forever.+  setEnv "SHOMEI_ARGON2_MEMORY_KIB" "0"+  memResult <- try loadConfigFromEnv+  expectUserErrorNaming "SHOMEI_ARGON2_MEMORY_KIB" memResult+  unsetEnv "SHOMEI_ARGON2_MEMORY_KIB"++  setEnv "SHOMEI_HASHING_MAX_CONCURRENCY" "0"+  concResult <- try loadConfigFromEnv+  expectUserErrorNaming "SHOMEI_HASHING_MAX_CONCURRENCY" concResult+  mapM_ unsetEnv argon2EnvVars+  unsetEnv "PG_CONNECTION_STRING"++argon2EnvVars :: [String]+argon2EnvVars =+  [ "SHOMEI_ARGON2_MEMORY_KIB",+    "SHOMEI_ARGON2_ITERATIONS",+    "SHOMEI_ARGON2_PARALLELISM",+    "SHOMEI_HASHING_MAX_CONCURRENCY"+  ]++-- | Misspelled keys, enum typos, and an empty origin set are deployment errors, not requests to+-- silently keep a default. The email-verification policy is available from the environment too.+strictConfigurationSettings :: Assertion+strictConfigurationSettings = do+  setEnv "PG_CONNECTION_STRING" "host=localhost dbname=shomei"+  setEnv "SHOMEI_CONFIG" configPath++  writeFile configPath "{ cookieSecue = False }"+  unknownKey <- try loadConfig+  expectUserErrorNaming "invalid SHOMEI_CONFIG" unknownKey++  writeFile configPath "{ webauthnAttestation = \"nope\" }"+  badAttestation <- try loadConfig+  expectUserErrorNaming "webauthnAttestation" badAttestation++  writeFile configPath "{ webauthnOrigins = ([] : List Text) }"+  emptyFileOrigins <- try loadConfig+  expectUserErrorNaming "webauthnOrigins" emptyFileOrigins++  unsetEnv "SHOMEI_CONFIG"+  setEnv "SHOMEI_WEBAUTHN_ORIGINS" ","+  emptyEnvOrigins <- try loadConfigFromEnv+  expectUserErrorNaming "SHOMEI_WEBAUTHN_ORIGINS" emptyEnvOrigins+  unsetEnv "SHOMEI_WEBAUTHN_ORIGINS"++  setEnv "SHOMEI_EMAIL_VERIFICATION_REQUIRED" "true"+  (emailRequired, _) <- loadConfigFromEnv+  emailRequired.notifierConfig.emailVerificationRequired @?= True+  unsetEnv "SHOMEI_EMAIL_VERIFICATION_REQUIRED"++  writeFile configPath dhallContents+  unsetEnv "PG_CONNECTION_STRING"++-- | Render the schema's completed default while preserving nulls, then compare its key set to+-- the all-'Nothing' JSON representation of 'FileConfig'. This also asks Dhall to check that the+-- shipped default still has exactly the exported 'Type'.+dhallSchemaMatchesFileConfig :: Assertion+dhallSchemaMatchesFileConfig = do+  schema <- makeAbsolute "../config/shomei-types.dhall"+  writeFile schemaProbePath ("(" <> schema <> ")::{=}")+  rendered <- readProcess "dhall-to-json" ["--preserve-null", "--file", schemaProbePath] ""+  dhallKeys <-+    either assertFailure (pure . KeyMap.keys) $+      (eitherDecodeStrict' (Text.encodeUtf8 (Text.pack rendered)) :: Either String (KeyMap.KeyMap Value))+  blank <- either assertFailure pure (eitherDecodeStrict' "{}" :: Either String FileConfig)+  loaderKeys <- case toJSON blank of+    Object fields -> pure (KeyMap.keys fields)+    _ -> assertFailure "FileConfig did not encode as an object"+  Set.fromList dhallKeys @?= Set.fromList loaderKeys++-- | Assert a config load failed with a 'userError' whose message names the offending variable.+expectUserErrorNaming :: String -> Either IOError a -> Assertion+expectUserErrorNaming name = \case+  Left e ->+    assertBool+      ("expected a userError naming " <> name <> ", got: " <> show e)+      (isUserError e && Text.isInfixOf (Text.pack name) (Text.pack (show e)))+  Right _ -> assertFailure (name <> " out of range should have failed the config load")++testLoadAndOverride :: TestTree+testLoadAndOverride = testCase "Dhall file is loaded and env vars override it" do+  setEnv "SHOMEI_CONFIG" configPath+  setEnv "PG_CONNECTION_STRING" "host=fromenv dbname=shomei"+  unsetEnv "SHOMEI_PORT"+  unsetEnv "SHOMEI_BIND_HOST"+  unsetEnv "SHOMEI_MAX_CONNECTIONS"+  unsetEnv "SHOMEI_SLOW_CLIENT_TIMEOUT_SECONDS"+  unsetEnv "SHOMEI_ISSUER"+  unsetEnv "SHOMEI_WEBAUTHN_RP_ID"+  unsetEnv "SHOMEI_MFA_REQUIRE_SECOND_FACTOR"+  unsetEnv "SHOMEI_MACHINE_TOKEN_TTL"+  unsetEnv "SHOMEI_KEY_REFRESH_INTERVAL"+  unsetEnv "SHOMEI_ALLOWED_CLOCK_SKEW_SECONDS"+  unsetEnv "SHOMEI_NOTIFIER_LOG_SECRETS"+  unsetEnv "SHOMEI_DB_POOL_SIZE"+  unsetEnv "SHOMEI_DB_POOL_ACQUISITION_TIMEOUT_MS"+  unsetEnv "SHOMEI_DB_STATEMENT_TIMEOUT_MS"+  unsetEnv "SHOMEI_NOTIFIER_QUEUE_SIZE"+  (cfg, settings) <- loadConfig+  -- File values beat the defaults (default maxFailedLoginsPerAccount is 5, metrics default True):+  settings.serverPort @?= 8080+  settings.serverBindHost @?= "127.0.0.1"+  settings.serverMaxConnections @?= 32+  settings.serverSlowClientTimeoutSeconds @?= 12+  -- The pool knobs load from the file (defaults are 10 / 10000):+  settings.serverDbPoolSize @?= 25+  settings.serverDbPoolAcquisitionTimeoutMs @?= 2500+  settings.serverDbStatementTimeoutMs @?= 5000+  settings.serverNotifierQueueSize @?= 12+  cfg.rateLimitConfig.maxFailedLoginsPerAccount @?= 7+  -- The signing-key refresh interval loads from the file (default is 60):+  cfg.signingKeyConfig.refreshIntervalSeconds @?= 15+  cfg.signingKeyConfig.allowedClockSkewSeconds @?= 20+  -- Raw one-time tokens are never logged unless the env flag opts in (there is deliberately+  -- no Dhall field for it):+  cfg.notifierConfig.logRawTokens @?= False+  -- File values beat the default password policy (default minLength is 12, rejectCommon True):+  cfg.passwordPolicy.minLength @?= 16+  cfg.passwordPolicy.rejectCommonPasswords @?= False+  -- PG_CONNECTION_STRING (env) overrides the file's databaseUrl:+  settings.serverConnStr @?= "host=fromenv dbname=shomei"+  -- WebAuthn and MFA fields load from their respective Dhall settings.+  -- WebAuthnConfig is read via record destructuring, not value.field dot syntax (HasField is+  -- unreliable for it under DuplicateRecordFields — MasterPlan 3, EP-1 discovery).+  let WebAuthnConfig {rpId = fileRpId, origins = fileOrigins} = webauthnConfig cfg+  fileRpId @?= "auth.fromfile.test"+  fileOrigins @?= ["https://auth.fromfile.test"]+  cfg.mfaConfig.requireSecondFactor @?= False+  cfg.machineTokenConfig.machineTokenTTL @?= 120+  -- An env var overrides the file's port:+  setEnv "SHOMEI_PORT" "9999"+  setEnv "SHOMEI_BIND_HOST" "::1"+  setEnv "SHOMEI_MAX_CONNECTIONS" "64"+  setEnv "SHOMEI_SLOW_CLIENT_TIMEOUT_SECONDS" "8"+  -- and the file's pool knobs (file says 25 / 2500):+  setEnv "SHOMEI_DB_POOL_SIZE" "33"+  setEnv "SHOMEI_DB_POOL_ACQUISITION_TIMEOUT_MS" "2000"+  setEnv "SHOMEI_DB_STATEMENT_TIMEOUT_MS" "7000"+  setEnv "SHOMEI_NOTIFIER_QUEUE_SIZE" "24"+  -- Concept-specific env vars override the file (twelve-factor precedence):+  setEnv "SHOMEI_WEBAUTHN_RP_ID" "auth.fromenv.test"+  setEnv "SHOMEI_MFA_REQUIRE_SECOND_FACTOR" "true"+  setEnv "SHOMEI_MACHINE_TOKEN_TTL" "60"+  (cfg2, settings2) <- loadConfig+  settings2.serverPort @?= 9999+  settings2.serverBindHost @?= "::1"+  settings2.serverMaxConnections @?= 64+  settings2.serverSlowClientTimeoutSeconds @?= 8+  settings2.serverDbPoolSize @?= 33+  settings2.serverDbPoolAcquisitionTimeoutMs @?= 2000+  settings2.serverDbStatementTimeoutMs @?= 7000+  settings2.serverNotifierQueueSize @?= 24+  let WebAuthnConfig {rpId = envRpId} = webauthnConfig cfg2+  envRpId @?= "auth.fromenv.test"+  cfg2.mfaConfig.requireSecondFactor @?= True+  cfg2.machineTokenConfig.machineTokenTTL @?= 60+  -- An env var overrides the file's password min length (file says 16):+  setEnv "SHOMEI_PASSWORD_MIN_LENGTH" "20"+  -- and the file's signing-key refresh interval (file says 15); 0 disables the reload:+  setEnv "SHOMEI_KEY_REFRESH_INTERVAL" "0"+  setEnv "SHOMEI_ALLOWED_CLOCK_SKEW_SECONDS" "45"+  -- SHOMEI_NOTIFIER_LOG_SECRETS is env-only; it is the sole way to turn raw-token logging on:+  setEnv "SHOMEI_NOTIFIER_LOG_SECRETS" "true"+  (cfg3, _) <- loadConfig+  cfg3.passwordPolicy.minLength @?= 20+  cfg3.signingKeyConfig.refreshIntervalSeconds @?= 0+  cfg3.signingKeyConfig.allowedClockSkewSeconds @?= 45+  cfg3.notifierConfig.logRawTokens @?= True+  unsetEnv "SHOMEI_NOTIFIER_LOG_SECRETS"+  unsetEnv "SHOMEI_KEY_REFRESH_INTERVAL"+  unsetEnv "SHOMEI_ALLOWED_CLOCK_SKEW_SECONDS"+  unsetEnv "SHOMEI_PASSWORD_MIN_LENGTH"+  unsetEnv "SHOMEI_CONFIG"+  unsetEnv "SHOMEI_PORT"+  unsetEnv "SHOMEI_BIND_HOST"+  unsetEnv "SHOMEI_MAX_CONNECTIONS"+  unsetEnv "SHOMEI_SLOW_CLIENT_TIMEOUT_SECONDS"+  unsetEnv "SHOMEI_DB_POOL_SIZE"+  unsetEnv "SHOMEI_DB_POOL_ACQUISITION_TIMEOUT_MS"+  unsetEnv "SHOMEI_DB_STATEMENT_TIMEOUT_MS"+  unsetEnv "SHOMEI_NOTIFIER_QUEUE_SIZE"+  unsetEnv "PG_CONNECTION_STRING"+  unsetEnv "SHOMEI_WEBAUTHN_RP_ID"+  unsetEnv "SHOMEI_MFA_REQUIRE_SECOND_FACTOR"+  unsetEnv "SHOMEI_MACHINE_TOKEN_TTL"+  -- Run inline rather than as sibling tasty test cases: each of these mutates process-wide+  -- environment variables, and tasty runs the members of a test group in parallel.+  poolDefaults+  poolRejectsNonPositive+  sweepDefaults+  sweepEnvOverrides+  sweepRejectsNonPositive+  argon2Settings+  strictConfigurationSettings+  dhallSchemaMatchesFileConfig+  coreLoaderNeedsNoConnectionString+  verifierSettings+  rateLimitAndCookieEdgeSettings+  notifierDefaults+  notifierSmtpDhallAndEnv+  passkeyQuotaSettings+  sessionQuotaSettings+  actorCompatibilitySettings++  notifierWebhookEnv+  notifierSmtpMissingHostFails+  notifierSmtpUsernameWithoutPasswordFails+  notifierWebhookMissingSecretFails+  notifierSecretsAreStrippedAndConfigIsSecretFree+  notifierInsecureTransportFlags+  kekIsRequired++passkeyQuotaSettings :: Assertion+passkeyQuotaSettings = do+  unsetEnv "SHOMEI_CONFIG"+  unsetEnv "SHOMEI_MAX_PASSKEYS_PER_USER"+  setEnv "PG_CONNECTION_STRING" "host=localhost dbname=shomei"+  (defaults, _) <- loadConfigFromEnv+  defaults.maxPasskeysPerUser @?= 20+  setEnv "SHOMEI_MAX_PASSKEYS_PER_USER" "1"+  (limited, _) <- loadConfigFromEnv+  limited.maxPasskeysPerUser @?= 1+  setEnv "SHOMEI_MAX_PASSKEYS_PER_USER" "101"+  bad <- try loadConfigFromEnv+  expectUserErrorNaming "SHOMEI_MAX_PASSKEYS_PER_USER" bad+  unsetEnv "SHOMEI_MAX_PASSKEYS_PER_USER"++-- | Administrative workflows consume the deployment's core policy without pretending to be a+-- listening server or requiring the server's PostgreSQL variable.+coreLoaderNeedsNoConnectionString :: Assertion+coreLoaderNeedsNoConnectionString = do+  setEnv "SHOMEI_CONFIG" configPath+  unsetEnv "PG_CONNECTION_STRING"+  cfg <- loadCoreConfig+  cfg.passwordPolicy.minLength @?= 16+  cfg.passwordPolicy.rejectCommonPasswords @?= False+  unsetEnv "SHOMEI_CONFIG"++-- | The verifier skew has a safe default, supports env override, and rejects+-- negative values. Issuer and audience are validated as RFC 7519 StringOrURI+-- values before the signer can reach jose's partial IsString conversion.+verifierSettings :: Assertion+verifierSettings = do+  unsetEnv "SHOMEI_CONFIG"+  unsetEnv "SHOMEI_ALLOWED_CLOCK_SKEW_SECONDS"+  unsetEnv "SHOMEI_ISSUER"+  unsetEnv "SHOMEI_AUDIENCE"+  setEnv "PG_CONNECTION_STRING" "host=localhost dbname=shomei"++  (defaults, _) <- loadConfigFromEnv+  defaults.signingKeyConfig.allowedClockSkewSeconds @?= 30++  setEnv "SHOMEI_ALLOWED_CLOCK_SKEW_SECONDS" "45"+  (overridden, _) <- loadConfigFromEnv+  overridden.signingKeyConfig.allowedClockSkewSeconds @?= 45++  setEnv "SHOMEI_ALLOWED_CLOCK_SKEW_SECONDS" "-1"+  negativeSkew <- try loadConfigFromEnv+  expectUserErrorNaming "SHOMEI_ALLOWED_CLOCK_SKEW_SECONDS" negativeSkew+  unsetEnv "SHOMEI_ALLOWED_CLOCK_SKEW_SECONDS"++  -- RFC 3986 permits a scheme with a rootless path, so this is a valid URI.+  setEnv "SHOMEI_ISSUER" "shomei:prod"+  (schemeIssuer, _) <- loadConfigFromEnv+  let Issuer schemeIssuerText = schemeIssuer.issuer+  schemeIssuerText @?= "shomei:prod"++  setEnv "SHOMEI_ISSUER" "https://bad host"+  invalidIssuer <- try loadConfigFromEnv+  expectUserErrorNaming "SHOMEI_ISSUER" invalidIssuer+  unsetEnv "SHOMEI_ISSUER"++  setEnv "SHOMEI_AUDIENCE" "https://bad audience"+  invalidAudience <- try loadConfigFromEnv+  expectUserErrorNaming "SHOMEI_AUDIENCE" invalidAudience++  unsetEnv "SHOMEI_AUDIENCE"+  unsetEnv "PG_CONNECTION_STRING"++rateLimitEnvVars :: [String]+rateLimitEnvVars =+  [ "SHOMEI_RATE_LIMIT_ENABLED",+    "SHOMEI_MAX_FAILED_LOGINS_PER_ACCOUNT",+    "SHOMEI_MAX_FAILED_LOGINS_PER_IP",+    "SHOMEI_PER_IP_REQUESTS_PER_MINUTE",+    "SHOMEI_PER_IP_BURST",+    "SHOMEI_LOCKOUT_WINDOW_SECONDS",+    "SHOMEI_LOCKOUT_DURATION_SECONDS"+  ]++-- | The complete abuse-policy surface is configurable, invalid zero bounds fail closed,+-- and browser origins are canonical before exact CSRF comparison and warning generation.+rateLimitAndCookieEdgeSettings :: Assertion+rateLimitAndCookieEdgeSettings = do+  unsetEnv "SHOMEI_CONFIG"+  mapM_ unsetEnv rateLimitEnvVars+  unsetEnv "SHOMEI_TOKEN_TRANSPORT"+  unsetEnv "SHOMEI_CSRF_ALLOWED_ORIGINS"+  setEnv "PG_CONNECTION_STRING" "host=localhost dbname=shomei"++  setEnv "SHOMEI_RATE_LIMIT_ENABLED" "false"+  setEnv "SHOMEI_MAX_FAILED_LOGINS_PER_ACCOUNT" "7"+  setEnv "SHOMEI_MAX_FAILED_LOGINS_PER_IP" "23"+  setEnv "SHOMEI_PER_IP_REQUESTS_PER_MINUTE" "71"+  setEnv "SHOMEI_PER_IP_BURST" "11"+  setEnv "SHOMEI_LOCKOUT_WINDOW_SECONDS" "601"+  setEnv "SHOMEI_LOCKOUT_DURATION_SECONDS" "902"+  (configured, _) <- loadConfigFromEnv+  let rate = configured.rateLimitConfig+  rate.rateLimitEnabled @?= False+  rate.maxFailedLoginsPerAccount @?= 7+  rate.maxFailedLoginsPerIp @?= 23+  rate.perIpRequestsPerMinute @?= 71+  rate.perIpBurst @?= 11+  rate.lockoutWindow @?= 601+  rate.lockoutDuration @?= 902++  setEnv "SHOMEI_PER_IP_BURST" "0"+  zeroBurst <- try loadConfigFromEnv+  expectUserErrorNaming "SHOMEI_PER_IP_BURST" zeroBurst+  mapM_ unsetEnv rateLimitEnvVars++  setEnv "SHOMEI_CSRF_ALLOWED_ORIGINS" "HTTPS://App.Example.com/"+  (normalized, _) <- loadConfigFromEnv+  normalized.cookieConfig.allowedOrigins @?= ["https://app.example.com"]+  setEnv "SHOMEI_CSRF_ALLOWED_ORIGINS" "https://app.example.com/login"+  invalidOrigin <- try loadConfigFromEnv+  expectUserErrorNaming "must be scheme://host[:port] with no path" invalidOrigin++  unsetEnv "SHOMEI_CSRF_ALLOWED_ORIGINS"+  setEnv "SHOMEI_TOKEN_TRANSPORT" "cookie"+  (_, defaultWarningSettings) <- loadConfigFromEnv+  defaultWarningSettings.serverWarnings+    @?= ["cookie transport is on with the development default csrfAllowedOrigins = [http://localhost:8080]; browsers on any other origin get 403 csrf_rejected — set SHOMEI_CSRF_ALLOWED_ORIGINS"]++  setEnv "SHOMEI_CSRF_ALLOWED_ORIGINS" "https://app.example.com"+  (_, productionSettings) <- loadConfigFromEnv+  productionSettings.serverWarnings @?= []++  unsetEnv "SHOMEI_TOKEN_TRANSPORT"+  unsetEnv "SHOMEI_CSRF_ALLOWED_ORIGINS"+  unsetEnv "PG_CONNECTION_STRING"++kekIsRequired :: Assertion+kekIsRequired = do+  unsetEnv "SHOMEI_KEY_ENCRYPTION_KEY"+  missing <- try loadKekFromEnv+  expectUserErrorNaming "SHOMEI_KEY_ENCRYPTION_KEY" missing+  setEnv "SHOMEI_KEY_ENCRYPTION_KEY" "not-base64"+  malformed <- try loadKekFromEnv+  expectUserErrorNaming "SHOMEI_KEY_ENCRYPTION_KEY" malformed+  setEnv "SHOMEI_KEY_ENCRYPTION_KEY" "AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA="+  _ <- loadKekFromEnv+  unsetEnv "SHOMEI_KEY_ENCRYPTION_KEY"++-- EP-8 notifier transport ------------------------------------------------------++notifierEnvVars :: [String]+notifierEnvVars =+  [ "SHOMEI_NOTIFIER_TRANSPORT",+    "SHOMEI_NOTIFIER_ALSO_LOG",+    "SHOMEI_SMTP_HOST",+    "SHOMEI_SMTP_PORT",+    "SHOMEI_SMTP_TLS_MODE",+    "SHOMEI_SMTP_USERNAME",+    "SHOMEI_SMTP_PASSWORD",+    "SHOMEI_SMTP_FROM",+    "SHOMEI_SMTP_TIMEOUT",+    "SHOMEI_WEBHOOK_URL",+    "SHOMEI_WEBHOOK_SECRET",+    "SHOMEI_WEBHOOK_TIMEOUT",+    "SHOMEI_WEBHOOK_MAX_ATTEMPTS",+    "SHOMEI_WEBHOOK_ALLOW_INSECURE",+    "SHOMEI_SMTP_ALLOW_PLAINTEXT_AUTH",+    "SHOMEI_NOTIFIER_QUEUE_SIZE"+  ]++-- | With no config and no env, the notifier is the log sender and both sub-configs are absent.+notifierDefaults :: Assertion+notifierDefaults = do+  unsetEnv "SHOMEI_CONFIG"+  mapM_ unsetEnv notifierEnvVars+  setEnv "PG_CONNECTION_STRING" "host=localhost dbname=shomei"+  (cfg, _) <- loadConfigFromEnv+  let nc = cfg.notifierConfig+  nc.notifierTransport @?= LogNotifier+  nc.smtpConfig @?= Nothing+  nc.webhookConfig @?= Nothing+  nc.alsoLogNotifications @?= False+  unsetEnv "PG_CONNECTION_STRING"++smtpConfigPath :: FilePath+smtpConfigPath = "/tmp/shomei-config-smtp-test.dhall"++-- | The SMTP transport loads from the Dhall file, while the relay password enters the separate+-- runtime-only secret value.+notifierSmtpDhallAndEnv :: Assertion+notifierSmtpDhallAndEnv = do+  mapM_ unsetEnv notifierEnvVars+  writeFile+    smtpConfigPath+    ( "{ databaseUrl = \"host=fromfile dbname=shomei\""+        <> ", notifierTransport = \"smtp\""+        <> ", smtpHost = \"email-smtp.us-east-1.amazonaws.com\""+        <> ", smtpPort = 587"+        <> ", smtpTlsMode = \"starttls\""+        <> ", smtpUsername = \"AKIAEXAMPLE\""+        <> ", smtpFromAddress = \"auth@example.com\""+        <> ", smtpTimeoutSeconds = 20"+        <> ", publicBaseUrl = \"https://auth.example.com\""+        <> " }"+    )+  setEnv "SHOMEI_CONFIG" smtpConfigPath+  setEnv "PG_CONNECTION_STRING" "host=localhost dbname=shomei"+  setEnv "SHOMEI_SMTP_PASSWORD" "smtp-secret-from-env"+  -- publicBaseUrl is set in the Dhall file; the env var overrides it (twelve-factor).+  setEnv "SHOMEI_PUBLIC_BASE_URL" "https://auth.env.example.com"+  (cfg, _) <- loadConfig+  let nc = cfg.notifierConfig+  nc.notifierTransport @?= SmtpNotifier+  nc.publicBaseUrl @?= "https://auth.env.example.com"+  case nc.smtpConfig of+    Just (SmtpConfig {host = h, port = p, tlsMode = tls, username = u, fromAddress = fromA, timeoutSeconds = to}) -> do+      h @?= "email-smtp.us-east-1.amazonaws.com"+      p @?= 587+      tls @?= SmtpStartTls+      u @?= Just "AKIAEXAMPLE"+      fromA @?= "auth@example.com"+      to @?= 20+    Nothing -> assertFailure "expected smtpConfig to be populated for transport=smtp"+  secrets <- loadNotifierSecretsFromEnv cfg+  fmap smtpPasswordText secrets.smtpPassword @?= Just "smtp-secret-from-env"+  unsetEnv "SHOMEI_SMTP_PASSWORD"+  unsetEnv "SHOMEI_PUBLIC_BASE_URL"+  unsetEnv "SHOMEI_CONFIG"+  unsetEnv "PG_CONNECTION_STRING"++-- | The webhook transport can be configured entirely from the environment, with its secret+-- held separately from the printable config.+notifierWebhookEnv :: Assertion+notifierWebhookEnv = do+  unsetEnv "SHOMEI_CONFIG"+  mapM_ unsetEnv notifierEnvVars+  setEnv "PG_CONNECTION_STRING" "host=localhost dbname=shomei"+  setEnv "SHOMEI_NOTIFIER_TRANSPORT" "webhook"+  setEnv "SHOMEI_WEBHOOK_URL" "https://hooks.example.com/shomei"+  setEnv "SHOMEI_WEBHOOK_SECRET" "webhook-secret"+  setEnv "SHOMEI_WEBHOOK_MAX_ATTEMPTS" "5"+  setEnv "SHOMEI_NOTIFIER_ALSO_LOG" "true"+  (cfg, _) <- loadConfigFromEnv+  let nc = cfg.notifierConfig+  nc.notifierTransport @?= WebhookNotifier+  nc.alsoLogNotifications @?= True+  case nc.webhookConfig of+    Just (WebhookConfig {url = u, maxAttempts = ma}) -> do+      u @?= "https://hooks.example.com/shomei"+      ma @?= 5+    Nothing -> assertFailure "expected webhookConfig to be populated for transport=webhook"+  secrets <- loadNotifierSecretsFromEnv cfg+  fmap webhookSecretBytes secrets.webhookSecret @?= Just "webhook-secret"+  mapM_ unsetEnv notifierEnvVars+  unsetEnv "PG_CONNECTION_STRING"++-- | Selecting smtp without a host fails the boot, naming the missing variable.+notifierSmtpMissingHostFails :: Assertion+notifierSmtpMissingHostFails = do+  unsetEnv "SHOMEI_CONFIG"+  mapM_ unsetEnv notifierEnvVars+  setEnv "PG_CONNECTION_STRING" "host=localhost dbname=shomei"+  setEnv "SHOMEI_NOTIFIER_TRANSPORT" "smtp"+  setEnv "SHOMEI_SMTP_FROM" "auth@example.com"+  result <- try loadConfigFromEnv+  expectUserErrorNaming "SHOMEI_SMTP_HOST" result+  mapM_ unsetEnv notifierEnvVars+  unsetEnv "PG_CONNECTION_STRING"++-- | An SMTP username with no password (or vice versa) is refused: it is neither a valid+-- authenticated relay nor a valid lab sink.+notifierSmtpUsernameWithoutPasswordFails :: Assertion+notifierSmtpUsernameWithoutPasswordFails = do+  unsetEnv "SHOMEI_CONFIG"+  mapM_ unsetEnv notifierEnvVars+  setEnv "PG_CONNECTION_STRING" "host=localhost dbname=shomei"+  setEnv "SHOMEI_NOTIFIER_TRANSPORT" "smtp"+  setEnv "SHOMEI_SMTP_HOST" "smtp.example.com"+  setEnv "SHOMEI_SMTP_FROM" "auth@example.com"+  setEnv "SHOMEI_SMTP_USERNAME" "relay-user"+  (cfg, _) <- loadConfigFromEnv+  result <- try (loadNotifierSecretsFromEnv cfg)+  expectUserErrorNaming "SHOMEI_SMTP_PASSWORD" result+  mapM_ unsetEnv notifierEnvVars+  unsetEnv "PG_CONNECTION_STRING"++-- | Selecting webhook without a signing secret fails the boot, naming the missing variable.+notifierWebhookMissingSecretFails :: Assertion+notifierWebhookMissingSecretFails = do+  unsetEnv "SHOMEI_CONFIG"+  mapM_ unsetEnv notifierEnvVars+  setEnv "PG_CONNECTION_STRING" "host=localhost dbname=shomei"+  setEnv "SHOMEI_NOTIFIER_TRANSPORT" "webhook"+  setEnv "SHOMEI_WEBHOOK_URL" "https://hooks.example.com/shomei"+  (cfg, _) <- loadConfigFromEnv+  result <- try (loadNotifierSecretsFromEnv cfg)+  expectUserErrorNaming "SHOMEI_WEBHOOK_SECRET" result+  mapM_ unsetEnv notifierEnvVars+  unsetEnv "PG_CONNECTION_STRING"++notifierSecretsAreStrippedAndConfigIsSecretFree :: Assertion+notifierSecretsAreStrippedAndConfigIsSecretFree = do+  unsetEnv "SHOMEI_CONFIG"+  mapM_ unsetEnv notifierEnvVars+  setEnv "PG_CONNECTION_STRING" "  host=localhost dbname=shomei  "+  setEnv "SHOMEI_NOTIFIER_TRANSPORT" "webhook"+  setEnv "SHOMEI_WEBHOOK_URL" "  https://hooks.example.com/shomei  "+  setEnv "SHOMEI_WEBHOOK_SECRET" "  webhook-secret\n"+  setEnv "SHOMEI_SMTP_PASSWORD" "  smtp-secret\n"+  (cfg, settings) <- loadConfigFromEnv+  settings.serverConnStr @?= "host=localhost dbname=shomei"+  secrets <- loadNotifierSecretsFromEnv cfg+  fmap webhookSecretBytes secrets.webhookSecret @?= Just "webhook-secret"+  fmap smtpPasswordText secrets.smtpPassword @?= Just "smtp-secret"+  let notifier = cfg.notifierConfig+      fullConfig =+        cfg+          { notifierConfig =+              notifier+                { smtpConfig =+                    Just+                      SmtpConfig+                        { host = "smtp.example.com",+                          port = 587,+                          tlsMode = SmtpStartTls,+                          username = Just "relay-user",+                          fromAddress = "auth@example.com",+                          timeoutSeconds = 10+                        }+                }+          }+      encoded = LBS8.unpack (encode fullConfig)+  assertBool "ShomeiConfig JSON must not have an SMTP password field" (not ("\"password\":" `isInfixOf` encoded))+  assertBool "ShomeiConfig JSON must not have a webhook secret field" (not ("\"secret\":" `isInfixOf` encoded))+  mapM_ unsetEnv notifierEnvVars+  unsetEnv "PG_CONNECTION_STRING"++notifierInsecureTransportFlags :: Assertion+notifierInsecureTransportFlags = do+  unsetEnv "SHOMEI_CONFIG"+  mapM_ unsetEnv notifierEnvVars+  setEnv "PG_CONNECTION_STRING" "host=localhost dbname=shomei"+  setEnv "SHOMEI_NOTIFIER_TRANSPORT" "webhook"+  setEnv "SHOMEI_WEBHOOK_URL" "http://127.0.0.1:9999/hook"+  setEnv "SHOMEI_WEBHOOK_SECRET" "secret"+  insecureWebhook <- try loadConfigFromEnv+  expectUserErrorNaming "SHOMEI_WEBHOOK_ALLOW_INSECURE" insecureWebhook+  setEnv "SHOMEI_WEBHOOK_ALLOW_INSECURE" "true"+  (webhookCfg, _) <- loadConfigFromEnv+  _ <- loadNotifierSecretsFromEnv webhookCfg+  setEnv "SHOMEI_WEBHOOK_URL" "http://hooks.example.com/hook?secret=hidden"+  (_, httpSettings) <- loadConfigFromEnv+  assertBool "non-loopback HTTP lab receiver warns" ("webhookUrl uses HTTP under SHOMEI_WEBHOOK_ALLOW_INSECURE; one-time links travel in the clear; lab receivers only" `elem` httpSettings.serverWarnings)+  assertBool "warning contains no URL secrets" (not (any (Text.isInfixOf "hidden") httpSettings.serverWarnings))++  mapM_ unsetEnv notifierEnvVars+  setEnv "SHOMEI_NOTIFIER_TRANSPORT" "smtp"+  setEnv "SHOMEI_SMTP_HOST" "smtp.example.com"+  setEnv "SHOMEI_SMTP_FROM" "auth@example.com"+  setEnv "SHOMEI_SMTP_TLS_MODE" "plain"+  setEnv "SHOMEI_SMTP_USERNAME" "relay-user"+  setEnv "SHOMEI_SMTP_PASSWORD" "relay-password"+  plaintextAuth <- try loadConfigFromEnv+  expectUserErrorNaming "SHOMEI_SMTP_ALLOW_PLAINTEXT_AUTH" plaintextAuth+  setEnv "SHOMEI_SMTP_ALLOW_PLAINTEXT_AUTH" "true"+  (smtpCfg, smtpSettings) <- loadConfigFromEnv+  assertBool "plaintext credentials warn under the explicit lab override" ("smtpTlsMode=plain sends mail and SMTP credentials in the clear; explicit lab override" `elem` smtpSettings.serverWarnings)+  _ <- loadNotifierSecretsFromEnv smtpCfg++  unsetEnv "SHOMEI_SMTP_USERNAME"+  unsetEnv "SHOMEI_SMTP_PASSWORD"+  unsetEnv "SHOMEI_SMTP_ALLOW_PLAINTEXT_AUTH"+  (_, warningSettings) <- loadConfigFromEnv+  assertBool+    "unauthenticated plaintext SMTP warns"+    ("smtpTlsMode=plain sends mail in the clear; lab sinks only" `elem` warningSettings.serverWarnings)+  mapM_ unsetEnv notifierEnvVars+  unsetEnv "PG_CONNECTION_STRING"++actorCompatibilitySettings :: Assertion+actorCompatibilitySettings = do+  unsetEnv "SHOMEI_CONFIG"+  unsetEnv "SHOMEI_LEGACY_ACTOR_UNTIL_UNIX"+  unsetEnv "SHOMEI_EMIT_LEGACY_ACTOR"+  setEnv "PG_CONNECTION_STRING" "host=localhost dbname=shomei"+  (defaults, _) <- loadConfigFromEnv+  defaults.signingKeyConfig.legacyActorUntilUnix @?= Nothing+  defaults.signingKeyConfig.emitLegacyActor @?= False+  setEnv "SHOMEI_EMIT_LEGACY_ACTOR" "true"+  missing <- try loadConfigFromEnv+  expectUserErrorNaming "SHOMEI_LEGACY_ACTOR_UNTIL_UNIX" missing+  setEnv "SHOMEI_LEGACY_ACTOR_UNTIL_UNIX" "2000000000"+  (compatible, _) <- loadConfigFromEnv+  compatible.signingKeyConfig.legacyActorUntilUnix @?= Just 2000000000+  compatible.signingKeyConfig.emitLegacyActor @?= True+  setEnv "SHOMEI_LEGACY_ACTOR_UNTIL_UNIX" "0"+  invalid <- try loadConfigFromEnv+  expectUserErrorNaming "SHOMEI_LEGACY_ACTOR_UNTIL_UNIX" invalid+  unsetEnv "SHOMEI_LEGACY_ACTOR_UNTIL_UNIX"+  unsetEnv "SHOMEI_EMIT_LEGACY_ACTOR"++sessionQuotaSettings :: Assertion+sessionQuotaSettings = do+  setEnv "PG_CONNECTION_STRING" "host=localhost dbname=shomei"+  unsetEnv "SHOMEI_CONFIG"+  unsetEnv "SHOMEI_MAX_ACTIVE_NON_INTERACTIVE_SESSIONS"+  (defaults, _) <- loadConfigFromEnv+  defaults.maxActiveNonInteractiveSessions @?= 1000+  setEnv "SHOMEI_MAX_ACTIVE_NON_INTERACTIVE_SESSIONS" "1"+  (limited, _) <- loadConfigFromEnv+  limited.maxActiveNonInteractiveSessions @?= 1+  setEnv "SHOMEI_MAX_ACTIVE_NON_INTERACTIVE_SESSIONS" "0"+  bad <- try loadConfigFromEnv+  expectUserErrorNaming "SHOMEI_MAX_ACTIVE_NON_INTERACTIVE_SESSIONS" bad+  unsetEnv "SHOMEI_MAX_ACTIVE_NON_INTERACTIVE_SESSIONS"
+ test/Shomei/Server/E2ESpec.hs view
@@ -0,0 +1,997 @@+-- | End-to-end test for the standalone server: a fresh ephemeral PostgreSQL database+-- (via @shomei-migrations:test-support@), the real server in-process through warp's+-- 'testWithApplication', driven over HTTP with @http-client@. Asserts the full lifecycle —+-- signup, login, me (with and without a token), refresh rotation, refresh-token reuse+-- detection (HTTP 401 plus the persisted session revocation and reuse event), logout, the+-- public JWKS document, and health — i.e. the vertical slice actually behaves against real+-- PostgreSQL and real ES256 signing.+module Shomei.Server.E2ESpec (tests) where++import Control.Concurrent (threadDelay)+import Control.Concurrent.MVar (MVar, modifyMVar_, newMVar, readMVar)+import Control.Monad (forM_)+import Data.Aeson (Value (Array, Bool, Object, String), decode, encode, object, (.=))+import Data.Aeson qualified as Aeson+import Data.Aeson.Key qualified as K+import Data.Aeson.KeyMap qualified as KM+import Data.ByteString qualified as BS+import Data.ByteString.Base64.URL qualified as B64U+import Data.ByteString.Lazy qualified as LBS+import Data.Foldable (toList)+import Data.IORef (newIORef)+import Data.Int (Int64)+import Data.Maybe (isJust, listToMaybe)+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.Encoding qualified as Text+import Data.Time (addUTCTime, getCurrentTime)+import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)+import Effectful (runEff)+import Effectful.Error.Static (runErrorNoCallStack)+import GHC.Clock (getMonotonicTime)+import Hasql.Decoders qualified as D+import Hasql.Encoders qualified as E+import Hasql.Session qualified as Session+import Hasql.Statement (Statement, preparable)+import Network.HTTP.Client+  ( Manager,+    RequestBody (RequestBodyLBS),+    applyBasicAuth,+    defaultManagerSettings,+    httpLbs,+    method,+    newManager,+    parseRequest,+    redirectCount,+    requestBody,+    requestHeaders,+    responseBody,+    responseHeaders,+    responseStatus,+    urlEncodedBody,+  )+import Network.HTTP.Types (Header, status200, statusCode)+import Network.Wai qualified as Wai+import Network.Wai.Handler.Warp (testWithApplication)+import Servant.Health (ProbeCheck, ProbeVerdict (Healthy))+import Shomei.Account.LoginId.Domain (mkLoginId)+import Shomei.Account.Password.Hash.Postgres (Argon2Params (..), newHashingLimiter)+import Shomei.Account.User.Domain (NewUser (..), User (..))+import Shomei.Account.User.Postgres (runUserStorePostgres)+import Shomei.Account.User.Store (createUser)+import Shomei.Authorization.Claims.Domain (Audience (..), AuthClaims (..), Issuer (..), Scope (..))+import Shomei.Config (NotifierConfig (..), NotifierTransport (..), OAuthConfig (..), ShomeiConfig (..), SigningKeyConfig (..), TotpConfig (..), WebhookConfig (..), defaultShomeiConfig)+import Shomei.Error (AuthError)+import Shomei.Id (SessionId, UserId, genOAuthClientId, genServiceAccountDbId, idText)+import Shomei.Mfa.Totp.Algorithm (base32ToSecret, totpCode, totpCounter)+import Shomei.Mfa.Totp.Postgres (TotpEncryptionKey, totpEncryptionKeyFromBytes)+import Shomei.Migrations.TestSupport (withShomeiMigratedDatabase)+import Shomei.Notify (NotifierSecrets (..), WebhookSecret (..), noNotifierSecrets, webhookSignature)+import Shomei.Notify.Queue (newNotifierQueue)+import Shomei.OAuth.Client.Domain (ClientType (..), NewOAuthClient (..))+import Shomei.OAuth.Client.Postgres (runOAuthClientStorePostgres)+import Shomei.OAuth.Client.Store (createOAuthClient)+import Shomei.OAuth.TokenGrant.Workflow (pkceChallengeFor)+import Shomei.Persistence.Database.Postgres (defaultTransactionRetryPolicy, runDatabasePool)+import Shomei.Persistence.Pool.Postgres (Pool, acquirePool)+import Shomei.Persistence.Pool.Postgres qualified as Pool+import Shomei.Server.App (Env (..))+import Shomei.Server.Boot (NotifierWorker (..), application, installNotifierWorker)+import Shomei.Server.Config (defaultDbStatementTimeoutMs)+import Shomei.Server.Keys (LoadedKeys (..), bootstrapKeys)+import Shomei.ServiceAccount.Domain (NewServiceAccount (..))+import Shomei.ServiceAccount.Postgres (runServiceAccountStorePostgres)+import Shomei.ServiceAccount.Secret (sha256Hex)+import Shomei.ServiceAccount.Store (createServiceAccount)+import Shomei.Session.Domain (NewSession (..), Session (..), SessionKind (InteractiveSession))+import Shomei.Session.Postgres (runSessionStorePostgres)+import Shomei.Session.Store (createSession)+import Shomei.Session.Token.Domain (AccessToken (..))+import Shomei.SigningKey.Domain (SigningAlgorithm (ES256))+import Shomei.SigningKey.Protection.Jwt (KeyEncryptionKey, keyEncryptionKeyFromBase64)+import Shomei.SigningKey.Sign.Jwt (signAccessToken)+import Shomei.SigningKey.Verify.Jwt (verifyToken)+import Shomei.Time.Postgres (runClockIO)+import Shomei.Time.Store (now)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))++e2eKek :: KeyEncryptionKey+e2eKek =+  either (error . Text.unpack) id $+    keyEncryptionKeyFromBase64 "AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA="++tests :: TestTree+tests =+  testGroup+    "auth lifecycle over HTTP against PostgreSQL"+    [ testCase "signup → login → me(±token) → refresh → reuse-detect → logout → jwks → health" $+        withShomeiMigratedDatabase \connStr -> do+          pool <- acquirePool 4 10 defaultDbStatementTimeoutMs connStr+          keysRef <- newIORef =<< bootstrapKeys e2eKek ES256 pool+          envMgr <- newManager defaultManagerSettings+          limiter <- newHashingLimiter 2+          notifierQueue <- newNotifierQueue 64+          let cfg = defaultShomeiConfig (Issuer "shomei") (Audience "shomei-clients")+              env = Env {envPool = pool, envDbRetryPolicy = defaultTransactionRetryPolicy, envConfig = cfg, envKeys = keysRef, envKek = e2eKek, envHttpManager = envMgr, envNotifierSecrets = noNotifierSecrets, envNotifierQueue = notifierQueue, envArgon2Params = testArgon2Params, envHashingLimiter = limiter, envTotpKey = e2eTotpKey}+          testWithApplication (pure (application env healthyProbe healthyProbe)) (scenario pool),+      testCase "EP-4: service account → POST /oauth/token → the token authenticates and is audited" $+        withShomeiMigratedDatabase \connStr -> do+          pool <- acquirePool 4 10 defaultDbStatementTimeoutMs connStr+          keysRef <- newIORef =<< bootstrapKeys e2eKek ES256 pool+          envMgr <- newManager defaultManagerSettings+          limiter <- newHashingLimiter 2+          notifierQueue <- newNotifierQueue 64+          let cfg = defaultShomeiConfig (Issuer "shomei") (Audience "shomei-clients")+              env = Env {envPool = pool, envDbRetryPolicy = defaultTransactionRetryPolicy, envConfig = cfg, envKeys = keysRef, envKek = e2eKek, envHttpManager = envMgr, envNotifierSecrets = noNotifierSecrets, envNotifierQueue = notifierQueue, envArgon2Params = testArgon2Params, envHashingLimiter = limiter, envTotpKey = e2eTotpKey}+          clientId <- seedServiceAccount pool+          testWithApplication (pure (application env healthyProbe healthyProbe)) (oauthScenario pool clientId),+      testCase "EP-5: authorize → exchange (PKCE) → verify id_token vs JWKS → userinfo → introspect → revoke → introspect" $+        withShomeiMigratedDatabase \connStr -> do+          pool <- acquirePool 4 10 defaultDbStatementTimeoutMs connStr+          keysRef <- newIORef =<< bootstrapKeys e2eKek ES256 pool+          envMgr <- newManager defaultManagerSettings+          limiter <- newHashingLimiter 2+          notifierQueue <- newNotifierQueue 64+          -- OIDC needs an http(s) issuer (it doubles as the endpoint base URL) and the provider on.+          let baseCfg = defaultShomeiConfig (Issuer "http://localhost") (Audience "shomei-clients")+              cfg = baseCfg {oauthConfig = baseCfg.oauthConfig {oidcEnabled = True}}+              env = Env {envPool = pool, envDbRetryPolicy = defaultTransactionRetryPolicy, envConfig = cfg, envKeys = keysRef, envKek = e2eKek, envHttpManager = envMgr, envNotifierSecrets = noNotifierSecrets, envNotifierQueue = notifierQueue, envArgon2Params = testArgon2Params, envHashingLimiter = limiter, envTotpKey = e2eTotpKey}+          clientId <- seedOAuthClient pool+          testWithApplication (pure (application env healthyProbe healthyProbe)) (oidcScenario clientId),+      testCase "EP-6: token-exchange (on-behalf-of + impersonation) → verified vs JWKS → audited" $+        forM_ [False, True] \legacy -> withShomeiMigratedDatabase \connStr -> do+          pool <- acquirePool 4 10 defaultDbStatementTimeoutMs connStr+          keys <- bootstrapKeys e2eKek ES256 pool+          keysRef <- newIORef keys+          envMgr <- newManager defaultManagerSettings+          limiter <- newHashingLimiter 2+          notifierQueue <- newNotifierQueue 64+          windowNow <- getCurrentTime+          let baseCfg = defaultShomeiConfig (Issuer "shomei") (Audience "shomei-clients")+              cfg = baseCfg {signingKeyConfig = baseCfg.signingKeyConfig {emitLegacyActor = legacy, legacyActorUntilUnix = Just (ceiling (utcTimeToPOSIXSeconds (addUTCTime 7200 windowNow)))}}+              env = Env {envPool = pool, envDbRetryPolicy = defaultTransactionRetryPolicy, envConfig = cfg, envKeys = keysRef, envKek = e2eKek, envHttpManager = envMgr, envNotifierSecrets = noNotifierSecrets, envNotifierQueue = notifierQueue, envArgon2Params = testArgon2Params, envHashingLimiter = limiter, envTotpKey = e2eTotpKey}+          clientId <- seedExchangeServiceAccount pool+          -- The operator token must verify against the server's own key material, so it is signed+          -- with the active signing key (scope granting is host-side; here the host is the test).+          -- The operator must be a real user row: a delegated session's actor_user_id is a foreign+          -- key into shomei_users.+          (opUid, opSid) <- seedOperatorPrincipal pool+          t <- getCurrentTime+          let opClaims =+                AuthClaims+                  { subject = opUid,+                    sessionId = opSid,+                    issuer = cfg.issuer,+                    audience = cfg.audience,+                    issuedAt = t,+                    expiresAt = addUTCTime 900 t,+                    authTime = t,+                    scopes = Set.singleton (Scope "impersonate:user"),+                    roles = Set.empty,+                    permissions = Set.empty,+                    actor = Nothing,+                    extraClaims = mempty+                  }+          AccessToken opTok <- either (assertFailure . ("could not sign the operator token: " <>) . show) pure =<< signAccessToken keys.signingKey opClaims+          testWithApplication (pure (application env healthyProbe healthyProbe)) (exchangeScenario cfg pool clientId opTok),+      testCase "EP-7: enroll TOTP → verify → login(mfa) → complete → recovery codes → audited" $+        withShomeiMigratedDatabase \connStr -> do+          pool <- acquirePool 4 10 defaultDbStatementTimeoutMs connStr+          keysRef <- newIORef =<< bootstrapKeys e2eKek ES256 pool+          envMgr <- newManager defaultManagerSettings+          limiter <- newHashingLimiter 2+          notifierQueue <- newNotifierQueue 64+          let baseCfg = defaultShomeiConfig (Issuer "shomei") (Audience "shomei-clients")+              cfg = baseCfg {totpConfig = baseCfg.totpConfig {totpEnabled = True}}+              env = Env {envPool = pool, envDbRetryPolicy = defaultTransactionRetryPolicy, envConfig = cfg, envKeys = keysRef, envKek = e2eKek, envHttpManager = envMgr, envNotifierSecrets = noNotifierSecrets, envNotifierQueue = notifierQueue, envArgon2Params = testArgon2Params, envHashingLimiter = limiter, envTotpKey = e2eTotpKey}+          testWithApplication (pure (application env healthyProbe healthyProbe)) (totpScenario pool),+      testCase "EP-8: webhook transport delivers a signed verification payload whose token is live" $+        withShomeiMigratedDatabase \connStr -> do+          pool <- acquirePool 4 10 defaultDbStatementTimeoutMs connStr+          keysRef <- newIORef =<< bootstrapKeys e2eKek ES256 pool+          envMgr <- newManager defaultManagerSettings+          limiter <- newHashingLimiter 2+          notifierQueue <- newNotifierQueue 64+          captured <- newMVar []+          let whSecret = "e2e-webhook-secret" :: Text+              stubApp rq respond = do+                b <- LBS.toStrict <$> Wai.strictRequestBody rq+                modifyMVar_ captured (pure . (<> [(Wai.requestHeaders rq, b)]))+                respond (Wai.responseLBS status200 [] "")+          -- The stub receiver and notifier worker must be up before the app accepts requests.+          testWithApplication (pure stubApp) \stubPort -> do+            let baseCfg = defaultShomeiConfig (Issuer "shomei") (Audience "shomei-clients")+                nc0 = baseCfg.notifierConfig+                webhookCfg =+                  WebhookConfig+                    { url = Text.pack ("http://127.0.0.1:" <> show stubPort <> "/hook"),+                      timeoutSeconds = 5,+                      maxAttempts = 1+                    }+                cfg = baseCfg {notifierConfig = nc0 {notifierTransport = WebhookNotifier, webhookConfig = Just webhookCfg}}+                secrets = NotifierSecrets {smtpPassword = Nothing, webhookSecret = Just (WebhookSecret whSecret)}+                env = Env {envPool = pool, envDbRetryPolicy = defaultTransactionRetryPolicy, envConfig = cfg, envKeys = keysRef, envKek = e2eKek, envHttpManager = envMgr, envNotifierSecrets = secrets, envNotifierQueue = notifierQueue, envArgon2Params = testArgon2Params, envHashingLimiter = limiter, envTotpKey = e2eTotpKey}+            worker <- installNotifierWorker env+            testWithApplication (pure (application env healthyProbe healthyProbe)) (webhookScenario captured whSecret)+            drainNotifierWorker worker 10,+      testCase "E2E: password-reset/request answers 202 in under a second while the receiver sleeps 3 s" $+        withShomeiMigratedDatabase \connStr -> do+          pool <- acquirePool 4 10 defaultDbStatementTimeoutMs connStr+          keysRef <- newIORef =<< bootstrapKeys e2eKek ES256 pool+          envMgr <- newManager defaultManagerSettings+          limiter <- newHashingLimiter 2+          notifierQueue <- newNotifierQueue 64+          captured <- newMVar []+          let whSecret = "slow-webhook-secret" :: Text+              stubApp rq respond = do+                b <- LBS.toStrict <$> Wai.strictRequestBody rq+                threadDelay 3_000_000+                modifyMVar_ captured (pure . (<> [(Wai.requestHeaders rq, b)]))+                respond (Wai.responseLBS status200 [] "")+          testWithApplication (pure stubApp) \stubPort -> do+            let baseCfg = defaultShomeiConfig (Issuer "shomei") (Audience "shomei-clients")+                nc0 = baseCfg.notifierConfig+                webhookCfg =+                  WebhookConfig+                    { url = Text.pack ("http://127.0.0.1:" <> show stubPort <> "/hook"),+                      timeoutSeconds = 5,+                      maxAttempts = 1+                    }+                cfg = baseCfg {notifierConfig = nc0 {notifierTransport = WebhookNotifier, webhookConfig = Just webhookCfg}}+                secrets = NotifierSecrets {smtpPassword = Nothing, webhookSecret = Just (WebhookSecret whSecret)}+                env = Env {envPool = pool, envDbRetryPolicy = defaultTransactionRetryPolicy, envConfig = cfg, envKeys = keysRef, envKek = e2eKek, envHttpManager = envMgr, envNotifierSecrets = secrets, envNotifierQueue = notifierQueue, envArgon2Params = testArgon2Params, envHashingLimiter = limiter, envTotpKey = e2eTotpKey}+            worker <- installNotifierWorker env+            testWithApplication (pure (application env healthyProbe healthyProbe)) (slowWebhookScenario captured)+            drainNotifierWorker worker 10+    ]++healthyProbe :: ProbeCheck+healthyProbe = pure Healthy++-- | EP-8 against the real server: a signup + verify-email request delivered over the webhook+-- transport produces one signed @email_verification_requested@ POST whose token, replayed at+-- @\/v1\/auth\/verify-email\/confirm@, verifies the email — proving the delivered token is live.+webhookScenario :: MVar [([Header], BS.ByteString)] -> Text -> Int -> IO ()+webhookScenario captured whSecret port = do+  mgr <- newManager defaultManagerSettings+  let email = "webhook-user@example.com" :: Text+      pw = "correct horse battery staple" :: Text+  (sStatus, _) <- postJSON mgr port "/v1/auth/signup" (object ["loginId" .= email, "email" .= email, "password" .= pw, "displayName" .= ("" :: Text)])+  sStatus @?= 201+  (reqStatus, _) <- postJSON mgr port "/v1/auth/verify-email/request" (object ["email" .= email])+  reqStatus @?= 202+  reqs <- awaitNotifications captured 1 100+  case reqs of+    [(hdrs, body)] -> do+      lookup "X-Shomei-Notification-Type" hdrs @?= Just "email_verification_requested"+      lookup "Content-Type" hdrs @?= Just "application/json"+      timestamp <- must "timestamp header" (lookup "X-Shomei-Timestamp" hdrs)+      -- The signature covers the receiver-visible timestamp and exact bytes delivered.+      lookup "X-Shomei-Signature" hdrs @?= Just (webhookSignature (Text.encodeUtf8 whSecret) timestamp body)+      token <- must "token in webhook payload" (decode (LBS.fromStrict body) >>= dig ["token"] >>= asText)+      -- the delivered token is the live one: it confirms the email.+      (cStatus, _) <- postJSON mgr port "/v1/auth/verify-email/confirm" (object ["token" .= token])+      cStatus @?= 200+    _ -> assertFailure ("expected exactly one webhook delivery, got " <> show (length reqs))++awaitNotifications :: MVar [a] -> Int -> Int -> IO [a]+awaitNotifications captured expected attempts = go attempts+  where+    go remaining = do+      values <- readMVar captured+      if length values >= expected || remaining <= 0+        then pure values+        else threadDelay 100_000 >> go (remaining - 1)++slowWebhookScenario :: MVar [([Header], BS.ByteString)] -> Int -> IO ()+slowWebhookScenario captured port = do+  mgr <- newManager defaultManagerSettings+  let email = "slow-webhook-user@example.com" :: Text+      pw = "correct horse battery staple" :: Text+  (signupStatus, _) <-+    postJSON mgr port "/v1/auth/signup" (object ["loginId" .= email, "email" .= email, "password" .= pw, "displayName" .= ("" :: Text)])+  signupStatus @?= 201+  (verifyStatus, _) <- postJSON mgr port "/v1/auth/verify-email/request" (object ["email" .= email])+  verifyStatus @?= 202+  -- Let the setup notification finish so the timed reset starts with an idle worker.+  firstDeliveries <- awaitNotifications captured 1 100+  length firstDeliveries @?= 1++  started <- getMonotonicTime+  (resetStatus, _) <- postJSON mgr port "/v1/auth/password-reset/request" (object ["email" .= email])+  elapsed <- subtract started <$> getMonotonicTime+  resetStatus @?= 202+  assertBool ("request waited on the three-second receiver: " <> show elapsed <> "s") (elapsed < 1.0)+  deliveries <- awaitNotifications captured 2 100+  length deliveries @?= 2++-- | A fixed 32-byte AES-256-GCM key for the E2E TOTP secrets. Its value is irrelevant to the+-- test; it only has to round-trip encrypt→decrypt through 'Shomei.Mfa.Totp.Postgres'.+e2eTotpKey :: TotpEncryptionKey+e2eTotpKey = either (error . Text.unpack) id (totpEncryptionKeyFromBytes (BS.replicate 32 9))++-- | The secret the seeded OAuth client authenticates with; only its digest reaches the row.+oidcClientSecret :: Text+oidcClientSecret = "e2e-oauth-client-secret"++oidcRedirectUri :: Text+oidcRedirectUri = "http://localhost:9999/callback"++-- | Insert a confidential OAuth client through the PostgreSQL interpreter, as+-- @shomei-admin oauth-clients create@ does. Returns its @client_id@.+seedOAuthClient :: Pool -> IO Text+seedOAuthClient pool = do+  outcome <-+    runEff+      . runErrorNoCallStack @AuthError+      . runDatabasePool pool+      . runClockIO+      . runOAuthClientStorePostgres+      $ do+        ocid <- genOAuthClientId+        let cid = idText ocid+        ts <- now+        _ <-+          createOAuthClient+            NewOAuthClient+              { oauthClientId = ocid,+                clientId = cid,+                secretHash = Just (sha256Hex oidcClientSecret),+                clientType = ConfidentialClient,+                displayName = "e2e rp",+                redirectUris = [oidcRedirectUri],+                allowedScopes = Set.fromList [Scope "openid", Scope "profile"],+                createdAt = ts+              }+        pure cid+  either (assertFailure . ("could not seed the oauth client: " <>) . show) pure outcome++-- | The full OIDC transcript from this plan's Purpose, against real PostgreSQL and real ES256.+oidcScenario :: Text -> Int -> IO ()+oidcScenario clientId port = do+  mgr <- newManager defaultManagerSettings++  -- A user to authenticate the authorize request.+  (sStatus, sBody) <- postJSON mgr port "/v1/auth/signup" (object ["loginId" .= ("oidc-user" :: Text), "password" .= ("correct horse battery staple" :: Text), "displayName" .= ("" :: Text)])+  sStatus @?= 201+  sresp <- must "signup body" sBody+  userToken <- must "signup accessToken" (dig ["token", "accessToken"] sresp >>= asText)++  let verifier = "an-e2e-pkce-code-verifier-of-more-than-forty-three-chars" :: Text+      challenge = pkceChallengeFor verifier+      basic = Just (clientId, oidcClientSecret)++  -- authorize with the user's bearer token → 302 carrying a single-use code.+  authResp <-+    getNoRedirect+      mgr+      port+      ( "/oauth/authorize?response_type=code&client_id="+          <> Text.unpack clientId+          <> "&redirect_uri="+          <> escape oidcRedirectUri+          <> "&scope=openid%20profile&state=xyz&nonce=n-0S6&code_challenge="+          <> Text.unpack challenge+          <> "&code_challenge_method=S256"+      )+      (bearer userToken)+  let (authStatus, authHdrs, _) = authResp+  authStatus @?= 302+  loc <- must "Location" (lookup "Location" authHdrs >>= (Just . Text.decodeUtf8))+  code <- must "code in redirect" (paramFrom "code" loc)++  -- exchange with the PKCE verifier → all three tokens.+  (xStatus, _, xBody) <- postForm mgr port "/oauth/token" basic [("grant_type", "authorization_code"), ("code", Text.encodeUtf8 code), ("redirect_uri", Text.encodeUtf8 oidcRedirectUri), ("code_verifier", Text.encodeUtf8 verifier)]+  xStatus @?= 200+  xresp <- must "token body" xBody+  access <- must "access_token" (dig ["access_token"] xresp >>= asText)+  refresh <- must "refresh_token" (dig ["refresh_token"] xresp >>= asText)+  idToken <- must "id_token" (dig ["id_token"] xresp >>= asText)++  -- the id_token's signing key is published, its aud is the client, its nonce echoes.+  (jStatus, jBody) <- getJSON mgr port "/.well-known/jwks.json" []+  jStatus @?= 200+  jwks <- must "jwks body" jBody+  assertBool "the id_token's kid is in the served JWKS" (maybe False (`elem` jwksKids jwks) (jwtHeaderKid idToken))+  idPayload <- must "id_token payload" (jwtPayload idToken)+  (dig ["aud"] idPayload >>= asText) @?= Just clientId+  (dig ["nonce"] idPayload >>= asText) @?= Just "n-0S6"++  -- userinfo: same sub as the id_token.+  (uStatus, uBody) <- getJSON mgr port "/oauth/userinfo" (bearer access)+  uStatus @?= 200+  uresp <- must "userinfo body" uBody+  (dig ["sub"] uresp >>= asText) @?= (dig ["sub"] idPayload >>= asText)++  -- introspect the access token → active.+  (iStatus, _, iBody) <- postForm mgr port "/oauth/introspect" basic [("token", Text.encodeUtf8 access)]+  iStatus @?= 200+  iresp <- must "introspect body" iBody+  dig ["active"] iresp @?= Just (jsonBool True)++  -- revoke the refresh token → 200.+  (rStatus, _, _) <- postForm mgr port "/oauth/revoke" basic [("token", Text.encodeUtf8 refresh), ("token_type_hint", "refresh_token")]+  rStatus @?= 200++  -- introspect again → inactive (the session is gone, and introspection is session-aware).+  (i2Status, _, i2Body) <- postForm mgr port "/oauth/introspect" basic [("token", Text.encodeUtf8 access)]+  i2Status @?= 200+  i2resp <- must "introspect body 2" i2Body+  dig ["active"] i2resp @?= Just (jsonBool False)++-- | The @Location@ query parameter named @k@, percent-decoded enough for our fixed values.+paramFrom :: Text -> Text -> Maybe Text+paramFrom k loc = do+  let (_, query) = Text.breakOn "?" loc+  listToMaybe [v | pair <- Text.splitOn "&" (Text.drop 1 query), let (n, rest) = Text.breakOn "=" pair, n == k, let v = Text.drop 1 rest]++-- | GET without following redirects, so a 302 is the response under test.+getNoRedirect :: Manager -> Int -> String -> [Header] -> IO (Int, [Header], Maybe Value)+getNoRedirect mgr port path hdrs = do+  req0 <- parseRequest ("http://127.0.0.1:" <> show port <> path)+  let req = req0 {method = "GET", requestHeaders = hdrs, redirectCount = 0}+  resp <- httpLbs req mgr+  pure (statusCode (responseStatus resp), responseHeaders resp, decode (responseBody resp))++-- | A JWT's payload segment as JSON (unverified; the kid/JWKS check above is the signature proof).+jwtPayload :: Text -> Maybe Value+jwtPayload token = do+  seg <- case Text.splitOn "." token of (_ : p : _) -> Just p; _ -> Nothing+  raw <- either (const Nothing) Just (B64U.decodeBase64UnpaddedUntyped (Text.encodeUtf8 seg))+  decode (LBS.fromStrict raw)++-- | Minimal percent-encoding for the fixed redirect URI in the authorize query string.+escape :: Text -> String+escape = concatMap enc . Text.unpack+  where+    enc ':' = "%3A"+    enc '/' = "%2F"+    enc c = [c]++jsonBool :: Bool -> Value+jsonBool = Aeson.Bool++-- | The secret the seeded service account authenticates with. Only its digest reaches the row.+oauthSecret :: Text+oauthSecret = "e2e-service-secret"++-- | Insert a service account and its backing user straight through the PostgreSQL interpreters,+-- as @shomei-admin service-accounts create@ does. Returns its @client_id@.+seedServiceAccount :: Pool -> IO Text+seedServiceAccount pool = do+  outcome <-+    runEff+      . runErrorNoCallStack @AuthError+      . runDatabasePool pool+      . runClockIO+      . runServiceAccountStorePostgres+      . runUserStorePostgres+      $ do+        said <- genServiceAccountDbId+        let cid = idText said+        ts <- now+        loginId <- either (const (error "bad login id")) pure (mkLoginId cid)+        User {userId = backingUserId} <- createUser NewUser {loginId, email = Nothing, displayName = Just "e2e connector"}+        _ <-+          createServiceAccount+            NewServiceAccount+              { serviceAccountId = said,+                clientId = cid,+                userId = backingUserId,+                secretHash = sha256Hex oauthSecret,+                displayName = "e2e connector",+                allowedScopes = Set.singleton (Scope "kawa:ingest"),+                createdAt = ts+              }+        pure cid+  either (assertFailure . ("could not seed the service account: " <>) . show) pure outcome++-- | The whole EP-4 promise, against the real stack: a stock OAuth2 request mints a token that the+-- server's own verifier accepts, whose signing key is published, and whose issuance is audited.+oauthScenario :: Pool -> Text -> Int -> IO ()+oauthScenario pool clientId port = do+  mgr <- newManager defaultManagerSettings++  -- (a) A textbook client_credentials request with client_secret_basic.+  (tStatus, tHdrs, tBody) <- postForm mgr port "/oauth/token" (Just (clientId, oauthSecret)) [("grant_type", "client_credentials"), ("scope", "kawa:ingest")]+  tStatus @?= 200+  -- RFC 6749 §5.1: a token response must never be cached.+  lookup "Cache-Control" tHdrs @?= Just "no-store"+  tresp <- must "token body" tBody+  (dig ["token_type"] tresp >>= asText) @?= Just "Bearer"+  (dig ["scope"] tresp >>= asText) @?= Just "kawa:ingest"+  access <- must "access_token" (dig ["access_token"] tresp >>= asText)++  -- (b) The minted token is a real Shōmei token: the server's own auth handler accepts it on an+  -- ordinary authenticated route, and resolves it to the account's backing user.+  (meStatus, meBody) <- getJSON mgr port "/v1/auth/me" (bearer access)+  meStatus @?= 200+  meresp <- must "me body" meBody+  (dig ["displayName"] meresp >>= asText) @?= Just "e2e connector"++  -- (c) Its signing key is the one published at the JWKS endpoint, so any downstream verifier+  -- that fetches /.well-known/jwks.json can check this token offline.+  (jStatus, jBody) <- getJSON mgr port "/.well-known/jwks.json" []+  jStatus @?= 200+  jwks <- must "jwks body" jBody+  let tokenKid = jwtHeaderKid access+  assertBool "the token's kid is published in the JWKS document" (maybe False (`elem` jwksKids jwks) tokenKid)++  -- (d) A wrong secret is an RFC 6749 object, not a problem document.+  (bStatus, bHdrs, bBody) <- postForm mgr port "/oauth/token" (Just (clientId, "wrong")) [("grant_type", "client_credentials")]+  bStatus @?= 401+  assertBool+    "OAuth errors use application/json"+    (maybe False ("application/json" `BS.isPrefixOf`) (lookup "Content-Type" bHdrs))+  lookup "WWW-Authenticate" bHdrs @?= Just "Basic realm=\"shomei\""+  berr <- must "error body" bBody+  (dig ["error"] berr >>= asText) @?= Just "invalid_client"++  -- (e) The successful issuance is audited; the failure mints nothing.+  issued <- scalarInt pool "SELECT count(*) FROM shomei.shomei_auth_events WHERE event_type = 'service_token_issued'"+  issued @?= 1+  sessions <- scalarInt pool "SELECT count(*) FROM shomei.shomei_sessions"+  sessions @?= 1+  -- A client_credentials session is refresh-less: the credential cannot outlive its TTL.+  refreshes <- scalarInt pool "SELECT count(*) FROM shomei.shomei_refresh_tokens"+  refreshes @?= 0++-- | The secret the EP-6 exchange service account authenticates with.+exchangeSecret :: Text+exchangeSecret = "e2e-exchange-secret"++-- | Create the operator and its live interactive session directly through the PostgreSQL ports.+-- The scoped token is hand-signed by the host, but its principal and session are both real.+seedOperatorPrincipal :: Pool -> IO (UserId, SessionId)+seedOperatorPrincipal pool = do+  outcome <-+    runEff+      . runErrorNoCallStack @AuthError+      . runDatabasePool pool+      . runClockIO+      . runSessionStorePostgres+      . runUserStorePostgres+      $ do+        loginId <- either (const (error "bad login id")) pure (mkLoginId "e2e-operator")+        User {userId} <- createUser NewUser {loginId, email = Nothing, displayName = Just "e2e operator"}+        ts <- now+        session <-+          createSession+            NewSession+              { userId,+                createdAt = ts,+                expiresAt = addUTCTime 3600 ts,+                actor = Nothing,+                oauthClientId = Nothing,+                kind = InteractiveSession,+                grantedScopes = Set.empty,+                authenticatedAt = ts,+                remembered = False+              }+        pure (userId, session.sessionId)+  either (assertFailure . ("could not seed the operator user: " <>) . show) pure outcome++-- | Seed a service account holding both @kawa:ingest@ and the @token-exchange:subject@ gate scope,+-- so it can drive the RFC 8693 on-behalf-of grant. Returns its @client_id@.+seedExchangeServiceAccount :: Pool -> IO Text+seedExchangeServiceAccount pool = do+  outcome <-+    runEff+      . runErrorNoCallStack @AuthError+      . runDatabasePool pool+      . runClockIO+      . runServiceAccountStorePostgres+      . runUserStorePostgres+      $ do+        said <- genServiceAccountDbId+        let cid = idText said+        ts <- now+        loginId <- either (const (error "bad login id")) pure (mkLoginId cid)+        User {userId = backingUserId} <- createUser NewUser {loginId, email = Nothing, displayName = Just "e2e exchange svc"}+        _ <-+          createServiceAccount+            NewServiceAccount+              { serviceAccountId = said,+                clientId = cid,+                userId = backingUserId,+                secretHash = sha256Hex exchangeSecret,+                displayName = "e2e exchange svc",+                allowedScopes = Set.fromList [Scope "kawa:ingest", Scope "token-exchange:subject"],+                createdAt = ts+              }+        pure cid+  either (assertFailure . ("could not seed the exchange service account: " <>) . show) pure outcome++-- | The RFC 8693 token-exchange promise against the real stack: both modes mint a delegated token+-- the server's own verifier and JWKS accept, and both write their audit event with subject + actor.+exchangeScenario :: ShomeiConfig -> Pool -> Text -> Text -> Int -> IO ()+exchangeScenario cfg pool clientId opTok port = do+  mgr <- newManager defaultManagerSettings+  let teGrant = ("grant_type", "urn:ietf:params:oauth:grant-type:token-exchange")+      userIdType = "urn:shomei:params:oauth:token-type:user-id"+      accessType = "urn:ietf:params:oauth:token-type:access_token"+      accessTypeText = "urn:ietf:params:oauth:token-type:access_token" :: Text+      enc = Text.encodeUtf8+      pw = "correct horse battery staple" :: Text+      signup loginId = do+        (s, b) <- postJSON mgr port "/v1/auth/signup" (object ["loginId" .= loginId, "password" .= pw, "displayName" .= ("" :: Text)])+        s @?= 201+        resp <- must (loginId <> " signup body") b+        tok <- must (loginId <> " accessToken") (dig ["token", "accessToken"] resp >>= asText)+        uid <- must (loginId <> " userId") (dig ["user", "userId"] resp >>= asText)+        pure (tok, uid)++  (subjectAccess, subjectId) <- signup "exchange-subject"+  (_, targetId) <- signup "exchange-target"++  -- ===== Service on-behalf-of =====+  (obStatus, obHdrs, obBody) <-+    postForm mgr port "/oauth/token" (Just (clientId, exchangeSecret)) [teGrant, ("subject_token", enc subjectAccess), ("subject_token_type", accessType), ("scope", "kawa:ingest")]+  obStatus @?= 200+  lookup "Cache-Control" obHdrs @?= Just "no-store"+  obResp <- must "on-behalf body" obBody+  (dig ["scope"] obResp >>= asText) @?= Just "kawa:ingest"+  (dig ["issued_token_type"] obResp >>= asText) @?= Just accessTypeText+  obAccess <- must "on-behalf access_token" (dig ["access_token"] obResp >>= asText)++  -- The delegated token is signed by the published key: a downstream verifier checks it offline.+  (jStatus, jBody) <- getJSON mgr port "/.well-known/jwks.json" []+  jStatus @?= 200+  jwks <- must "jwks body" jBody+  assertBool "the on-behalf token's kid is published" (maybe False (`elem` jwksKids jwks) (jwtHeaderKid obAccess))++  publicKeys <- case Aeson.fromJSON jwks of+    Aeson.Success value -> pure value+    Aeson.Error err -> assertFailure err+  verified <- either (assertFailure . show) pure =<< verifyToken publicKeys cfg obAccess+  idText verified.subject @?= subjectId+  assertBool "standalone verifier preserves the delegated actor" (isJust verified.actor)++  -- Introspection verifies the JWT server-side and reports sub (the user), the scope, and act (the+  -- service) — sub/act/scopes asserted against a real verify, not a hand decode.+  (iStatus, _, iBody) <- postForm mgr port "/oauth/introspect" (Just (clientId, exchangeSecret)) [("token", enc obAccess)]+  iStatus @?= 200+  intro <- must "on-behalf introspect body" iBody+  dig ["active"] intro @?= Just (Bool True)+  (dig ["sub"] intro >>= asText) @?= Just subjectId+  (dig ["scope"] intro >>= asText) @?= Just "kawa:ingest"+  assertBool "on-behalf token carries an act member" (isJust (dig ["act", "sub"] intro >>= asText))++  actorId <- must "introspected actor" (dig ["act", "sub"] intro >>= asText)+  payload <- must "delegated JWT payload" (jwtPayload obAccess)+  dig ["act"] payload+    @?= Just+      ( if cfg.signingKeyConfig.emitLegacyActor+          then String actorId+          else object ["sub" .= actorId]+      )++  -- ===== Impersonation =====+  (impStatus, _, impBody) <-+    postForm mgr port "/oauth/token" Nothing [teGrant, ("subject_token", enc targetId), ("subject_token_type", userIdType), ("actor_token", enc opTok), ("actor_token_type", accessType), ("reason", "e2e ticket")]+  impStatus @?= 200+  impResp <- must "impersonation body" impBody+  (dig ["issued_token_type"] impResp >>= asText) @?= Just accessTypeText+  impAccess <- must "impersonation access_token" (dig ["access_token"] impResp >>= asText)+  (impIStatus, _, impIBody) <- postForm mgr port "/oauth/introspect" (Just (clientId, exchangeSecret)) [("token", enc impAccess)]+  impIStatus @?= 200+  impIntro <- must "impersonation introspect body" impIBody+  (dig ["sub"] impIntro >>= asText) @?= Just targetId+  assertBool "impersonation token carries an act member" (isJust (dig ["act", "sub"] impIntro >>= asText))++  -- ===== Audit: both events written, each carrying subject and actor ids =====+  onBehalf <-+    scalarInt pool "SELECT count(*) FROM shomei.shomei_auth_events WHERE event_type = 'service_on_behalf_issued' AND payload->>'subjectUserId' IS NOT NULL AND payload->>'actorUserId' IS NOT NULL"+  onBehalf @?= 1+  impStarted <-+    scalarInt pool "SELECT count(*) FROM shomei.shomei_auth_events WHERE event_type = 'impersonation_started' AND payload->>'subjectUserId' IS NOT NULL AND payload->>'actorUserId' IS NOT NULL"+  impStarted @?= 1++-- | The @kid@ from a JWT's header, without verifying anything.+jwtHeaderKid :: Text -> Maybe Text+jwtHeaderKid token = do+  seg <- listToMaybe (Text.splitOn "." token)+  raw <- either (const Nothing) Just (B64U.decodeBase64UnpaddedUntyped (Text.encodeUtf8 seg))+  val <- decode (LBS.fromStrict raw)+  dig ["kid"] val >>= asText++jwksKids :: Value -> [Text]+jwksKids v = case dig ["keys"] v of+  Just (Array ks) -> [k | Object o <- toList ks, Just (String k) <- [KM.lookup "kid" o]]+  _ -> []++-- | EP-7's Purpose transcript against real PostgreSQL and real ES256: enroll TOTP, activate it,+-- log in and complete the challenge with a fresh code, then complete a second login with a+-- recovery code and watch the count drop — with the whole flow recorded in the audit trail.+--+-- The wall clock is real here, so a confirmed code cannot be replayed at the same time-step+-- counter. The completion presents the NEXT counter's code, which the ±1 acceptance window+-- accepts whether or not the clock has ticked into the next step, and which is strictly greater+-- than the confirming counter — so the test never has to wait 30 seconds.+totpScenario :: Pool -> Int -> IO ()+totpScenario pool port = do+  mgr <- newManager defaultManagerSettings+  let loginId = "totp-e2e-user" :: Text+      pw = "correct horse battery staple totp" :: Text+      login = postJSON mgr port "/v1/auth/login" (object ["loginId" .= loginId, "password" .= pw])++  (sStatus, sBody) <- postJSON mgr port "/v1/auth/signup" (object ["loginId" .= loginId, "password" .= pw, "displayName" .= ("" :: Text)])+  sStatus @?= 201+  access <- must "signup accessToken" (sBody >>= dig ["token", "accessToken"] >>= asText)++  -- enroll: the secret is shown once.+  (enStatus, enBody) <- postAuthNoBody mgr port "/v1/auth/totp/enroll" (bearer access)+  enStatus @?= 200+  secretB32 <- must "enroll secret" (enBody >>= dig ["secret"] >>= asText)+  secret <- either (assertFailure . ("bad base32 secret: " <>)) pure (base32ToSecret secretB32)++  -- activate with the current code.+  t <- getCurrentTime+  let c = totpCounter t+  (vStatus, _) <- postJSONAuth mgr port "/v1/auth/totp/verify" (bearer access) (object ["code" .= totpCode 6 secret c])+  vStatus @?= 200++  -- login now challenges for the TOTP factor; complete with the next counter's code.+  (mStatus, mBody) <- login+  mStatus @?= 200+  (mBody >>= dig ["status"] >>= asText) @?= Just "mfa_required"+  methods <- must "methods" (mBody >>= dig ["methods"] >>= asTextArray)+  assertBool "totp advertised in methods" ("totp" `elem` methods)+  cid <- must "ceremonyId" (mBody >>= dig ["ceremonyId"] >>= asText)+  (cStatus, cBody) <-+    postJSON+      mgr+      port+      "/v1/auth/mfa/complete"+      (object ["ceremonyId" .= cid, "proof" .= object ["type" .= ("totp" :: Text), "code" .= totpCode 6 secret (c + 1)]])+  cStatus @?= 200+  mfaAccess <- must "mfa accessToken" (cBody >>= dig ["accessToken"] >>= asText)+  -- the MFA-issued token verifies against the running server's key material.+  (meStatus, _) <- getJSON mgr port "/v1/auth/me" (bearer mfaAccess)+  meStatus @?= 200++  -- generate recovery codes, complete another login with one, and watch the count drop to nine.+  (gStatus, gBody) <- postAuthNoBody mgr port "/v1/auth/recovery-codes" (bearer mfaAccess)+  gStatus @?= 200+  codes <- must "recovery codes" (gBody >>= dig ["codes"] >>= asTextArray)+  length codes @?= 10+  (m2Status, m2Body) <- login+  m2Status @?= 200+  cid2 <- must "cid2" (m2Body >>= dig ["ceremonyId"] >>= asText)+  (rcStatus, rcBody) <-+    postJSON+      mgr+      port+      "/v1/auth/mfa/complete"+      (object ["ceremonyId" .= cid2, "proof" .= object ["type" .= ("recovery_code" :: Text), "code" .= head codes]])+  rcStatus @?= 200+  rcAccess <- must "recovery accessToken" (rcBody >>= dig ["accessToken"] >>= asText)+  (cntStatus, cntBody) <- getJSON mgr port "/v1/auth/recovery-codes" (bearer rcAccess)+  cntStatus @?= 200+  (cntBody >>= dig ["remaining"] >>= asInt) @?= Just 9++  -- the whole flow is recorded against real PostgreSQL, and the secret sits encrypted at rest.+  scalarInt pool "SELECT count(*) FROM shomei.shomei_auth_events WHERE event_type = 'totp_enrolled'" >>= (@?= 1)+  scalarInt pool "SELECT count(*) FROM shomei.shomei_auth_events WHERE event_type = 'recovery_codes_generated'" >>= (@?= 1)+  scalarInt pool "SELECT count(*) FROM shomei.shomei_auth_events WHERE event_type = 'recovery_code_used'" >>= (@?= 1)+  scalarInt pool "SELECT count(*) FROM shomei.shomei_auth_events WHERE event_type = 'mfa_succeeded'" >>= (@?= 2)+  scalarInt pool "SELECT count(*) FROM shomei.shomei_totp_credentials WHERE confirmed_at IS NOT NULL" >>= (@?= 1)++scenario :: Pool -> Int -> IO ()+scenario pool port = do+  mgr <- newManager defaultManagerSettings++  -- (a) signup: 201 with a token pair and an active user.+  (sStatus, sBody) <- postJSON mgr port "/v1/auth/signup" signupBody+  sStatus @?= 201+  sresp <- must "signup body" sBody+  (dig ["user", "email"] sresp >>= asText) @?= Just email+  (dig ["user", "status"] sresp >>= asText) @?= Just "active"+  signupRefresh <- must "signup refreshToken" (dig ["token", "refreshToken"] sresp >>= asText)++  -- (b) login: a fresh token pair.+  (lStatus, lBody) <- postJSON mgr port "/v1/auth/login" loginBody+  lStatus @?= 200+  lresp <- must "login body" lBody+  loginAccess <- must "login accessToken" (dig ["token", "accessToken"] lresp >>= asText)+  -- A login without "remember" is not remembered, and neither is its refresh.+  dig ["token", "remembered"] lresp @?= Just (Bool False)+  loginRefresh <- must "login refreshToken" (dig ["token", "refreshToken"] lresp >>= asText)+  (lrStatus, lrBody) <- postJSON mgr port "/v1/auth/refresh" (object ["refreshToken" .= loginRefresh])+  lrStatus @?= 200+  (lrBody >>= dig ["remembered"]) @?= Just (Bool False)++  -- (b') a remembered login: reported on sign-in and on every refresh, with a year-long session.+  (rlStatus, rlBody) <-+    postJSON mgr port "/v1/auth/login" (object ["loginId" .= email, "password" .= password, "remember" .= True])+  rlStatus @?= 200+  rlresp <- must "remembered login body" rlBody+  dig ["token", "remembered"] rlresp @?= Just (Bool True)+  rememberedRefresh <- must "remembered refreshToken" (dig ["token", "refreshToken"] rlresp >>= asText)+  (rrStatus, rrBody) <- postJSON mgr port "/v1/auth/refresh" (object ["refreshToken" .= rememberedRefresh])+  rrStatus @?= 200+  (rrBody >>= dig ["remembered"]) @?= Just (Bool True)+  scalarInt pool "SELECT count(*) FROM shomei.shomei_sessions WHERE remembered AND expires_at - created_at = interval '365 days'"+    >>= (@?= 1)+  scalarInt pool "SELECT count(*) FROM shomei.shomei_sessions WHERE NOT remembered AND expires_at - created_at = interval '30 days'"+    >>= (@?= 2)++  -- (c) me with Bearer → 200; (d) without → 401.+  (meStatus, meBody) <- getJSON mgr port "/v1/auth/me" (bearer loginAccess)+  meStatus @?= 200+  meresp <- must "me body" meBody+  (dig ["email"] meresp >>= asText) @?= Just email+  (noTokStatus, _) <- getJSON mgr port "/v1/auth/me" []+  noTokStatus @?= 401++  -- (e) refresh rotates the signup token.+  (rStatus, rBody) <- postJSON mgr port "/v1/auth/refresh" (object ["refreshToken" .= signupRefresh])+  rStatus @?= 200+  rresp <- must "refresh body" rBody+  rotatedRefresh <- must "rotated refreshToken" (dig ["refreshToken"] rresp >>= asText)+  assertBool "rotated refresh token differs" (rotatedRefresh /= signupRefresh)++  -- (f) replaying the OLD signup refresh token is detected as theft → 401.+  (reuseStatus, _) <- postJSON mgr port "/v1/auth/refresh" (object ["refreshToken" .= signupRefresh])+  reuseStatus @?= 401++  -- reuse must have landed in PostgreSQL: the family's session is revoked and a+  -- reuse event row exists.+  revokedSessions <- scalarInt pool "SELECT count(*) FROM shomei.shomei_sessions WHERE status = 'revoked'"+  assertBool "reuse revoked the signup session" (revokedSessions >= 1)+  reuseEvents <-+    scalarInt+      pool+      "SELECT count(*) FROM shomei.shomei_auth_events WHERE event_type = 'refresh_token_reuse_detected'"+  reuseEvents @?= 1++  -- (g) the rotated token is now dead too (the whole session was revoked).+  (deadStatus, _) <- postJSON mgr port "/v1/auth/refresh" (object ["refreshToken" .= rotatedRefresh])+  deadStatus @?= 401++  -- (h) logout the login session → 204, and again → 204: logout is idempotent, so a retry+  -- after a network blip succeeds instead of reporting session_not_found.+  (logoutStatus, _) <- postJSON mgr port "/v1/auth/logout" (object [])+  -- logout needs a Bearer token; send it as a header-only POST.+  logoutStatus' <- postNoBody mgr port "/v1/auth/logout" (bearer loginAccess)+  logoutStatus @?= 401 -- no token → 401+  logoutStatus' @?= 204+  logoutAgain <- postNoBody mgr port "/v1/auth/logout" (bearer loginAccess)+  logoutAgain @?= 204++  -- (i) JWKS: a public key with a kid and no private "d".+  (jStatus, jBody) <- getJSON mgr port "/.well-known/jwks.json" []+  jStatus @?= 200+  jwks <- must "jwks body" jBody+  assertBool "jwks has keys[].kid" (jwksHasKid jwks)+  assertBool "jwks has no private 'd'" (not (hasKeyDeep "d" jwks))++  -- (j) liveness → 200.+  (hStatus, _) <- getJSON mgr port "/health/live" []+  hStatus @?= 200+  where+    email = "ada@example.com" :: Text+    password = "correct horse battery staple" :: Text+    signupBody = object ["loginId" .= email, "email" .= email, "password" .= password, "displayName" .= ("Ada Lovelace" :: Text)]+    loginBody = object ["loginId" .= email, "password" .= password]++-- HTTP helpers (parseRequest does not throw on non-2xx, so 401/404 come back as responses).++-- | POST an @application\/x-www-form-urlencoded@ body, optionally with @client_secret_basic@.+-- Exposes response headers too, because RFC 6749 puts contract in them (@Cache-Control@,+-- @WWW-Authenticate@).+postForm :: Manager -> Int -> String -> Maybe (Text, Text) -> [(BS.ByteString, BS.ByteString)] -> IO (Int, [Header], Maybe Value)+postForm mgr port path mBasic params = do+  req0 <- parseRequest ("http://127.0.0.1:" <> show port <> path)+  let withBody = urlEncodedBody params req0+      req = maybe withBody (\(c, sec) -> applyBasicAuth (Text.encodeUtf8 c) (Text.encodeUtf8 sec) withBody) mBasic+  resp <- httpLbs req mgr+  pure (statusCode (responseStatus resp), responseHeaders resp, decode (responseBody resp))++postJSON :: Manager -> Int -> String -> Value -> IO (Int, Maybe Value)+postJSON mgr port path body = do+  req0 <- parseRequest ("http://127.0.0.1:" <> show port <> path)+  let req =+        req0+          { method = "POST",+            requestHeaders = [("Content-Type", "application/json")],+            requestBody = RequestBodyLBS (encode body)+          }+  resp <- httpLbs req mgr+  pure (statusCode (responseStatus resp), decode (responseBody resp))++-- | POST with no body, only headers (used for the authenticated logout). Returns status.+postNoBody :: Manager -> Int -> String -> [Header] -> IO Int+postNoBody mgr port path hdrs = do+  req0 <- parseRequest ("http://127.0.0.1:" <> show port <> path)+  let req = req0 {method = "POST", requestHeaders = hdrs}+  resp <- httpLbs req mgr+  pure (statusCode (responseStatus resp))++-- | POST a JSON body with a bearer token (EP-7 TOTP verify).+postJSONAuth :: Manager -> Int -> String -> [Header] -> Value -> IO (Int, Maybe Value)+postJSONAuth mgr port path hdrs body = do+  req0 <- parseRequest ("http://127.0.0.1:" <> show port <> path)+  let req =+        req0+          { method = "POST",+            requestHeaders = ("Content-Type", "application/json") : hdrs,+            requestBody = RequestBodyLBS (encode body)+          }+  resp <- httpLbs req mgr+  pure (statusCode (responseStatus resp), decode (responseBody resp))++-- | POST with a bearer token and no body, returning the response body (EP-7 enroll / generate).+postAuthNoBody :: Manager -> Int -> String -> [Header] -> IO (Int, Maybe Value)+postAuthNoBody mgr port path hdrs = do+  req0 <- parseRequest ("http://127.0.0.1:" <> show port <> path)+  let req = req0 {method = "POST", requestHeaders = hdrs}+  resp <- httpLbs req mgr+  pure (statusCode (responseStatus resp), decode (responseBody resp))++getJSON :: Manager -> Int -> String -> [Header] -> IO (Int, Maybe Value)+getJSON mgr port path hdrs = do+  req0 <- parseRequest ("http://127.0.0.1:" <> show port <> path)+  let req = req0 {method = "GET", requestHeaders = hdrs}+  resp <- httpLbs req mgr+  pure (statusCode (responseStatus resp), decode (responseBody resp))++bearer :: Text -> [Header]+bearer tok = [("Authorization", "Bearer " <> Text.encodeUtf8 tok)]++-- A scalar count(*) query run directly against the pool, for DB-state assertions.+scalarInt :: Pool -> Text -> IO Int+scalarInt pool sql = do+  res <- Pool.use pool (Session.statement () stmt)+  either (assertFailure . ("scalar query failed: " <>) . show) pure res+  where+    stmt :: Statement () Int+    stmt = preparable sql E.noParams (D.singleRow (fromIntegral64 <$> D.column (D.nonNullable D.int8)))+    fromIntegral64 :: Int64 -> Int+    fromIntegral64 = fromIntegral++-- JSON navigation helpers.++must :: String -> Maybe a -> IO a+must label = maybe (assertFailure ("missing: " <> label)) pure++field :: Text -> Value -> Maybe Value+field k (Object o) = KM.lookup (K.fromText k) o+field _ _ = Nothing++dig :: [Text] -> Value -> Maybe Value+dig ks v0 = foldl (\mv k -> mv >>= field k) (Just v0) ks++asText :: Value -> Maybe Text+asText (String t) = Just t+asText _ = Nothing++asTextArray :: Value -> Maybe [Text]+asTextArray (Array xs) = traverse asText (toList xs)+asTextArray _ = Nothing++asInt :: Value -> Maybe Int+asInt (Aeson.Number n) = Just (round n)+asInt _ = Nothing++jwksHasKid :: Value -> Bool+jwksHasKid v = case dig ["keys"] v of+  Just (Array xs) -> case toList xs of+    (k0 : _) -> isJust (field "kid" k0)+    [] -> False+  _ -> False++hasKeyDeep :: Text -> Value -> Bool+hasKeyDeep k = go+  where+    go (Object o) = any (\(kk, vv) -> K.toText kk == k || go vv) (KM.toList o)+    go (Array xs) = any go (toList xs)+    go _ = False++-- | Cheap Argon2 parameters for tests. This suite hashes and verifies real passwords, and the+-- production cost (~100 ms per hash) would dominate its runtime. Hash strength is irrelevant+-- here; only that hashing round-trips.+testArgon2Params :: Argon2Params+testArgon2Params = Argon2Params {memoryKiB = 8192, iterations = 1, parallelism = 1}
+ test/Shomei/Server/MiddlewareSpec.hs view
@@ -0,0 +1,546 @@+-- | Tests for the standalone server's edge middleware. All of them are database-free: the+-- rate limiter takes its clock as an argument, the metrics registry is plain 'IORef's, and the+-- WAI middlewares are just functions we can apply to a 'defaultRequest'.+module Shomei.Server.MiddlewareSpec (tests) where++import Control.Concurrent (forkIO)+import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)+import Control.Exception (AsyncException (ThreadKilled), ErrorCall (..), SomeException, evaluate, throwIO, toException, try)+import Control.Monad (forM, forM_, unless)+import Data.Aeson (Value (Object, String), decode, decodeStrict, (.=))+import Data.Aeson.Key (Key)+import Data.ByteString (ByteString)+import Data.ByteString qualified as BS+import Data.ByteString.Builder (toLazyByteString)+import Data.ByteString.Char8 qualified as BC+import Data.ByteString.Lazy qualified as BL+import Data.ByteString.Lazy.Char8 qualified as BLC+import Data.IORef (atomicModifyIORef', modifyIORef', newIORef, readIORef, writeIORef)+import Data.List (sort)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Word (Word16, Word64, Word8)+import Network.HTTP.Types (hContentType, methodDelete, methodPost, statusCode)+import Network.HTTP.Types.Status (status200)+import Network.Socket (SockAddr (..), tupleToHostAddress, tupleToHostAddress6)+import Network.Wai (Request (..), RequestBodyLength (..), Response, defaultRequest, getRequestBodyChunk, responseHeaders, responseLBS, responseStatus, responseToStream, setRequestBodyChunks)+import Network.Wai.Handler.Warp (InvalidRequest (BadFirstLine, PayloadTooLarge))+import Network.Wai.Internal (ResponseReceived (..))+import Servant.Health.Paths (healthRawPaths)+import Shomei.Account.Password.Hash.Postgres (defaultArgon2Params)+import Shomei.Authorization.Claims.Domain (Audience (..), Issuer (..))+import Shomei.Config (LogFormat (..), RateLimitConfig (..), ShomeiConfig (..), defaultObservabilityConfig, defaultRateLimitConfig, defaultShomeiConfig)+import Shomei.Servant.Api (shomeiThrottledRoutes)+import Shomei.Servant.ClientIp (clientIpText)+import Shomei.Servant.Error (ProblemDetails (..))+import Shomei.Servant.Throttle (PathSegment (Literal), ThrottledRoute (..))+import Shomei.Server.Boot (hostMiddleware)+import Shomei.Server.Config (ProxyProtocolMode (..), ServerSettings (..), SweepSettings (..), defaultSweepSettings)+import Shomei.Server.ExceptionResponse (problemExceptionResponse)+import Shomei.Server.Middleware.BodyLimit (bodyLimitMiddleware)+import Shomei.Server.Middleware.RateLimit (bucketCount, newRateLimiterFor, newRateLimiterWith, takeToken, throttledPath)+import Shomei.Server.Middleware.TrustedProxy (emptyTrustedProxies, parseTrustedProxies, trustedProxyMiddleware)+import Shomei.Server.Observability.Logging (emitLine, renderLogLine, requestLoggingMiddleware, responseLogLevel, serverErrorLine)+import Shomei.Server.Observability.Metrics (exportMetrics, metricsMiddleware, newMetrics)+import System.Directory (getTemporaryDirectory, removeFile)+import System.IO (BufferMode (LineBuffering), hClose, hSetBuffering, openTempFile)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertEqual, testCase, (@?=))++tests :: TestTree+tests =+  testGroup+    "middleware hardening"+    [ testGroup+        "trusted proxies"+        [ testUntrustedPeerIgnoresForwardedFor,+          testTrustedPeerUsesRightmostUntrustedHop,+          testSpoofedForwardedHopIsIgnored,+          testAllTrustedHopsUseOrigin,+          testInvalidTrustedProxyRefused+        ],+      testGroup+        "client ip rendering"+        [ testIpv4Rendering,+          testIpv6Rendering+        ],+      testGroup+        "rate limiter"+        [ testIdleBucketsEvicted,+          testDrainedBucketSurvivesSweep,+          testBucketMapStaysBounded,+          testThrottledPathsAreVersioned+        ],+      testGroup+        "metrics"+        [ testThrowingHandlerLeavesGaugeAtZero,+          testNormalRequestCountedAndGaugeReturnsToZero,+          testHostileMethodsShareTheBoundedSeries+        ],+      testGroup+        "logging"+        [ testCase "request severity distinguishes 5xx, throttle and ordinary authentication failures" do+            map responseLogLevel [200, 401, 403, 429, 500, 503] @?= ["info", "info", "info", "warn", "error", "error"],+          testRenderLogLineIsOneJsonLine,+          testPlainFormatStripsControlCharacters,+          testConcurrentWritersProduceIntactLines,+          testServerErrorLineIsStructured,+          testHealthRequestsSkipLogging+        ],+      testGroup+        "body limit"+        [ testHostMiddlewareOrder,+          testOversizedBodyRejected,+          testKnownSmallBodyPassesThrough,+          testChunkedBodyOverCapRejected,+          testSmallChunkedBodyPassesThrough,+          testEscapedExceptionRendersProblem,+          testWarpInvalidRequestsRenderProblems,+          testAsyncExceptionIsRethrown+        ]+    ]++-- Trusted proxies and canonical client identity --------------------------------++testUntrustedPeerIgnoresForwardedFor :: TestTree+testUntrustedPeerIgnoresForwardedFor = testCase "an untrusted peer's X-Forwarded-For is ignored" do+  actual <- observedClient ["10.0.0.0/8"] (ipv4 198 51 100 9) "203.0.113.7"+  actual @?= "198.51.100.9"++testTrustedPeerUsesRightmostUntrustedHop :: TestTree+testTrustedPeerUsesRightmostUntrustedHop = testCase "a trusted peer yields the rightmost untrusted hop" do+  actual <- observedClient ["10.0.0.0/8"] (ipv4 10 0 0 5) "203.0.113.7, 10.0.0.6"+  actual @?= "203.0.113.7"++testSpoofedForwardedHopIsIgnored :: TestTree+testSpoofedForwardedHopIsIgnored = testCase "a spoofed hop behind a trusted proxy is not the client" do+  actual <- observedClient ["10.0.0.0/8"] (ipv4 10 0 0 5) "1.2.3.4, 203.0.113.7"+  actual @?= "203.0.113.7"++testAllTrustedHopsUseOrigin :: TestTree+testAllTrustedHopsUseOrigin = testCase "every hop trusted falls back to the chain's origin" do+  actual <- observedClient ["10.0.0.0/8"] (ipv4 10 0 0 5) "10.0.0.1, 10.0.0.2"+  actual @?= "10.0.0.1"++testInvalidTrustedProxyRefused :: TestTree+testInvalidTrustedProxyRefused = testCase "an invalid trusted-proxy entry is refused" do+  case parseTrustedProxies ["10.0.0.0/8", "nope"] of+    Left _ -> pure ()+    Right _ -> fail "expected the invalid proxy entry to be rejected"++testIpv4Rendering :: TestTree+testIpv4Rendering = testCase "IPv4 renders as a dotted quad" do+  clientIpText (ipv4 127 0 0 1) @?= "127.0.0.1"++testIpv6Rendering :: TestTree+testIpv6Rendering = testCase "IPv6 renders per RFC 5952" do+  clientIpText (ipv6 (0x2001, 0x0db8, 0, 0, 0, 0, 0, 1)) @?= "2001:db8::1"+  clientIpText (ipv6 (0, 0, 0, 0, 0, 0, 0, 1)) @?= "::1"+  clientIpText (ipv6 (0x2001, 0x0db8, 0, 1, 0, 0, 0, 0)) @?= "2001:db8:0:1::"+  clientIpText (ipv6 (0x2001, 0, 0, 1, 0, 0, 0, 1)) @?= "2001:0:0:1::1"++observedClient :: [Text] -> SockAddr -> ByteString -> IO Text+observedClient proxyRanges peer forwarded = do+  proxies <- either (fail . show) pure (parseTrustedProxies proxyRanges)+  observed <- newIORef ""+  let req =+        defaultRequest+          { remoteHost = peer,+            requestHeaders = [("X-Forwarded-For", forwarded)]+          }+      inner request' respond = writeIORef observed (clientIpText (remoteHost request')) >> respond okResponse+  ResponseReceived <- trustedProxyMiddleware proxies inner req (const (pure ResponseReceived))+  readIORef observed++ipv4 :: Word8 -> Word8 -> Word8 -> Word8 -> SockAddr+ipv4 a b c d = SockAddrInet 4711 (tupleToHostAddress (a, b, c, d))++ipv6 :: (Word16, Word16, Word16, Word16, Word16, Word16, Word16, Word16) -> SockAddr+ipv6 groups = SockAddrInet6 4711 0 (tupleToHostAddress6 groups) 0++-- Rate limiter ---------------------------------------------------------------++-- | A limiter with a 3-token burst refilling at 1 token/second, pruning every @every@ calls.+testLimiterConfig :: RateLimitConfig+testLimiterConfig =+  defaultRateLimitConfig+    { perIpBurst = 3,+      perIpRequestsPerMinute = 60,+      rateLimitEnabled = True+    }++-- | Every bucket touched at @t=0@ has long since refilled by @t=100@, so the sweep that fires+-- on the eighth call drops all of them. The freshly drained bucket that triggered the sweep+-- survives, because it is not full.+testIdleBucketsEvicted :: TestTree+testIdleBucketsEvicted = testCase "idle buckets are evicted after a sweep" do+  rl <- newRateLimiterWith 8 testLimiterConfig+  -- Eight distinct IPs, one call each at t=0. The eighth call triggers a sweep, but at t=0+  -- every bucket holds 2 of its 3 tokens, so nothing is evictable.+  forM_ [1 .. 8 :: Int] \i -> takeToken rl (ipKey i) 0+  before <- bucketCount rl+  assertEqual "no bucket is full at t=0, so the first sweep evicts nothing" 8 before+  -- Eight calls for a ninth IP at t=100. The sweep on the eighth prunes ip1..ip8 (each has+  -- refilled from 2 tokens to well past its 3-token capacity) and keeps ip9 (drained to 0).+  forM_ [1 .. 8 :: Int] \_ -> takeToken rl "ip9" 100+  after <- bucketCount rl+  assertEqual "only the mid-refill bucket survives" 1 after++-- | Eviction must be observationally lossless: a bucket that still owes tokens is never+-- dropped, so a client that has been throttled stays throttled across a sweep.+testDrainedBucketSurvivesSweep :: TestTree+testDrainedBucketSurvivesSweep = testCase "a drained bucket survives a sweep (lossless)" do+  rl <- newRateLimiterWith 8 testLimiterConfig+  -- Drain ipA at t=0: three allowed, the fourth refused.+  allowed <- forM [1 .. 4 :: Int] \_ -> takeToken rl "ipA" 0+  assertEqual "burst of 3, then refusal" [True, True, True, False] allowed+  -- Four more calls (still t=0) push the counter to 8 and fire the sweep.+  forM_ [1 .. 4 :: Int] \_ -> takeToken rl "ipB" 0+  -- If the sweep had dropped ipA, this would be treated as a fresh full bucket and allowed.+  stillRefused <- takeToken rl "ipA" 0+  assertEqual "the drained bucket was not resurrected by the sweep" False stillRefused++-- | The whole point: ten thousand one-shot IPs must not leave ten thousand buckets behind.+testBucketMapStaysBounded :: TestTree+testBucketMapStaysBounded = testCase "10k one-shot IPs leave a bounded map" do+  let every = 8+  rl <- newRateLimiterWith every testLimiterConfig+  -- One call per IP, ten seconds apart, so each bucket is fully refilled by the next sweep.+  forM_ [1 .. 10_000 :: Int] \i -> takeToken rl (ipKey i) (fromIntegral i * 10)+  n <- bucketCount rl+  assertBool+    ("expected at most " <> show (every + 1) <> " buckets, got " <> show n)+    (n <= every + 1)++-- | Pin the API-derived set to the credential proofs documented for operators. Adding or moving a+-- 'RateLimited' marker changes this value automatically and makes the conformance assertion fail+-- until the documentation and threat-model inventory are reviewed together.+testThrottledPathsAreVersioned :: TestTree+testThrottledPathsAreVersioned = testCase "the derived throttled set matches every credential proof" do+  let actual = Set.fromList shomeiThrottledRoutes+      expected =+        Set.fromList+          [ postRoute ["v1", "auth", "login"],+            postRoute ["v1", "auth", "signup"],+            postRoute ["v1", "auth", "refresh"],+            postRoute ["v1", "auth", "mfa", "complete"],+            postRoute ["v1", "auth", "login", "passkey", "begin"],+            postRoute ["v1", "auth", "login", "passkey", "complete"],+            postRoute ["v1", "auth", "password", "change"],+            postRoute ["v1", "auth", "verify-email", "request"],+            postRoute ["v1", "auth", "verify-email", "confirm"],+            postRoute ["v1", "auth", "password-reset", "request"],+            postRoute ["v1", "auth", "password-reset", "confirm"],+            route methodDelete ["v1", "auth", "totp"],+            postRoute ["oauth", "token"]+          ]+  assertEqual "the marker-derived operation set" expected actual+  assertEqual "no derived operation is duplicated" (Set.size actual) (length shomeiThrottledRoutes)+  rl <- newRateLimiterWith 8 testLimiterConfig+  assertBool+    "the unversioned login path is not throttled (it no longer exists)"+    (not (throttledPath rl (request methodPost ["auth", "login"])))+  assertBool+    "authenticated routes are not throttled"+    (not (throttledPath rl (request methodPost ["v1", "auth", "logout"])))+  assertBool+    "GET is not throttled"+    (not (throttledPath rl (request "GET" ["v1", "auth", "login"])))+  where+    route method segments = ThrottledRoute method (Literal <$> segments)+    postRoute = route methodPost+    request method segments = defaultRequest {requestMethod = method, pathInfo = segments}++ipKey :: Int -> ByteString+ipKey i = BC.pack ("ip" <> show i)++-- Metrics --------------------------------------------------------------------++-- | An application that throws instead of responding must still decrement the gauge. Before+-- this fix the decrement lived only in the response continuation, which never ran.+testThrowingHandlerLeavesGaugeAtZero :: TestTree+testThrowingHandlerLeavesGaugeAtZero = testCase "a throwing handler leaves in-flight at 0" do+  m <- newMetrics+  let boomApp _req _respond = throwIO (ErrorCall "boom")+  -- The continuation is never reached, so 'undefined' is safe and keeps the test honest.+  outcome <- try (metricsMiddleware m boomApp defaultRequest (\_ -> undefined))+  case outcome :: Either ErrorCall ResponseReceived of+    Right _ -> fail "expected the exception to propagate through the middleware"+    Left _ -> pure ()+  body <- exportMetrics m+  assertMetricLine "http_requests_in_flight 0" body++-- | The normal path decrements exactly once too — no double-decrement into negative territory.+testNormalRequestCountedAndGaugeReturnsToZero :: TestTree+testNormalRequestCountedAndGaugeReturnsToZero = testCase "a normal request is counted and the gauge returns to 0" do+  m <- newMetrics+  let okApp _req respond = respond (responseLBS status200 [] "ok")+  ResponseReceived <- metricsMiddleware m okApp defaultRequest (\_ -> pure ResponseReceived)+  body <- exportMetrics m+  assertMetricLine "http_requests_in_flight 0" body+  assertMetricLine "http_requests_total{method=\"GET\",status=\"200\"} 1" body++testHostileMethodsShareTheBoundedSeries :: TestTree+testHostileMethodsShareTheBoundedSeries = testCase "a hostile method is labelled other and escaped" do+  m <- newMetrics+  let okApp _req respond = respond (responseLBS status200 [] "ok")+      record method =+        metricsMiddleware m okApp defaultRequest {requestMethod = method} (\_ -> pure ResponseReceived)+  ResponseReceived <- record "EVIL\"}"+  ResponseReceived <- record "BREW"+  body <- exportMetrics m+  assertMetricLine "http_requests_total{method=\"other\",status=\"200\"} 2" body+  assertBool "the hostile method is not emitted as a label value" (not ("EVIL" `BS.isInfixOf` BL.toStrict body))++-- | Assert the exported Prometheus text contains @wanted@ as a whole line.+assertMetricLine :: BL.ByteString -> BL.ByteString -> IO ()+assertMetricLine wanted body =+  assertBool+    ("expected a line " <> show wanted <> " in:\n" <> BLC.unpack body)+    (wanted `elem` BLC.lines body)++-- Logging --------------------------------------------------------------------++-- | Whatever a field value contains, the rendered line is exactly one line, and in JSON format+-- it is exactly one JSON object.+testRenderLogLineIsOneJsonLine :: TestTree+testRenderLogLineIsOneJsonLine = testCase "renderLogLine emits exactly one valid JSON line" do+  let line = renderLogLine LogJson hostileFields+  assertBool "line ends with a newline" ("\n" `BS.isSuffixOf` line)+  assertEqual "exactly one newline, at the end" 1 (BC.count '\n' line)+  case decodeStrict (BS.init line) :: Maybe Value of+    Just (Object _) -> pure ()+    other -> fail ("expected a JSON object, got " <> show other)++-- | The plain format has no encoder to escape a newline for it, so it must filter one out —+-- otherwise a hostile value forges a second log line.+testPlainFormatStripsControlCharacters :: TestTree+testPlainFormatStripsControlCharacters = testCase "the plain format strips control characters" do+  let line = renderLogLine LogPlain hostileFields+  assertBool "line ends with a newline" ("\n" `BS.isSuffixOf` line)+  assertEqual "exactly one newline, at the end" 1 (BC.count '\n' line)+  assertEqual "no embedded quotes survive" 0 (BC.count '"' line)++testHealthRequestsSkipLogging :: TestTree+testHealthRequestsSkipLogging = testCase "health paths bypass request logging" do+  let okApp _req respond = respond (responseLBS status200 [] "ok")+  forM_ healthRawPaths \path -> do+    let request = defaultRequest {rawPathInfo = path}+    ResponseReceived <- requestLoggingMiddleware defaultObservabilityConfig okApp request \response -> do+      lookup "X-Request-Id" (responseHeaders response) @?= Nothing+      pure ResponseReceived+    pure ()++-- | A value carrying the two characters that could break the one-line contract.+hostileFields :: [(Key, Value)]+hostileFields =+  [ "level" .= ("info" :: Text),+    "msg" .= String "line one\nlevel=error msg=\"forged\"",+    "status" .= (200 :: Int)+  ]++-- | Two hundred threads writing five lines each through the real emit path must produce a+-- thousand intact lines: no chunk of one line interleaved into another.+testConcurrentWritersProduceIntactLines :: TestTree+testConcurrentWritersProduceIntactLines = testCase "200 concurrent writers produce 1000 intact lines" do+  let threads = 200 :: Int+      linesPerThread = 5 :: Int+  tmpDir <- getTemporaryDirectory+  (path, h) <- openTempFile tmpDir "shomei-log-concurrency.jsonl"+  hSetBuffering h LineBuffering+  dones <- forM [1 .. threads] \t -> do+    done <- newEmptyMVar+    _ <- forkIO do+      forM_ [1 .. linesPerThread] \s ->+        emitLine h (renderLogLine LogJson ["thread" .= t, "seq" .= s])+      putMVar done ()+    pure done+  forM_ dones takeMVar+  hClose h+  contents <- BS.readFile path+  removeFile path+  let ls = BC.lines contents+  assertEqual "one line per write" (threads * linesPerThread) (length ls)+  decoded <- forM ls \l ->+    case decodeStrict l :: Maybe (Map Text Int) of+      Nothing -> fail ("line did not parse as a JSON object: " <> show l)+      Just obj -> pure (Map.lookup "thread" obj, Map.lookup "seq" obj)+  let expected = sort [(Just t, Just s) | t <- [1 .. threads], s <- [1 .. linesPerThread]]+  assertEqual "every (thread, seq) pair arrived exactly once" expected (sort decoded)++-- | Warp's exception hook must produce the same structured shape as a request line.+testServerErrorLineIsStructured :: TestTree+testServerErrorLineIsStructured = testCase "the warp exception logger renders structured JSON" do+  let req = defaultRequest {requestMethod = "POST", rawPathInfo = "/v1/auth/login"}+      err = toException (ErrorCall "database is on fire")+      line = serverErrorLine (Just req) err+  case decodeStrict (BS.init line) :: Maybe (Map Text Text) of+    Nothing -> fail ("expected a JSON object, got " <> show line)+    Just obj -> do+      Map.lookup "level" obj @?= Just "error"+      Map.lookup "msg" obj @?= Just "unhandled exception"+      Map.lookup "method" obj @?= Just "POST"+      Map.lookup "path" obj @?= Just "/v1/auth/login"+      assertBool "the exception text is carried" (Map.member "error" obj)+  -- Without a request, the method/path fields are simply absent.+  let bare = serverErrorLine Nothing err+  case decodeStrict (BS.init bare) :: Maybe (Map Text Text) of+    Nothing -> fail "expected a JSON object for the request-less case"+    Just obj -> assertBool "no method field without a request" (not (Map.member "method" obj))++-- Body limit -----------------------------------------------------------------++testHostMiddlewareOrder :: TestTree+testHostMiddlewareOrder = testCase "hostMiddleware refuses oversized bodies outside the limiter and throttles inside it" do+  let cfg = defaultShomeiConfig (Issuer "shomei") (Audience "shomei-clients")+      settings =+        ServerSettings+          { serverPort = 0,+            serverBindHost = "127.0.0.1",+            serverMaxConnections = 1024,+            serverSlowClientTimeoutSeconds = 30,+            serverConnStr = "",+            serverTrustedProxies = emptyTrustedProxies,+            serverProxyProtocol = ProxyProtocolOff,+            serverDbPoolSize = 1,+            serverDbPoolAcquisitionTimeoutMs = 1000,+            serverDbStatementTimeoutMs = 1000,+            serverDbTransactionMaxAttempts = 3,+            serverDbTransactionDeadlineMs = 5000,+            serverNotifierQueueSize = 16,+            serverWarnings = [],+            serverSweep = defaultSweepSettings {sweepEnabled = False},+            serverArgon2 = defaultArgon2Params,+            serverHashingMaxConcurrency = 1+          }+      large =+        defaultRequest+          { requestMethod = methodPost,+            pathInfo = ["v1", "auth", "login"],+            requestBodyLength = KnownLength (2 * 1024 * 1024),+            remoteHost = ipv4 203 0 113 9+          }+      small = large {requestBodyLength = KnownLength 16}+      inner _ respond = respond okResponse+  limiter <- newRateLimiterFor shomeiThrottledRoutes cfg.rateLimitConfig+  metrics <- newMetrics+  let app = hostMiddleware cfg settings limiter metrics inner+      run request' = do+        captured <- newIORef (0, [])+        ResponseReceived <- app request' \response -> do+          writeIORef captured (statusCode (responseStatus response), responseHeaders response)+          pure ResponseReceived+        readIORef captured+  forM_ [1 .. 100 :: Int] \_ -> do+    (status, headers) <- run large+    status @?= 413+    assertBool "logging is outermost and adds X-Request-Id" (lookup "X-Request-Id" headers /= Nothing)+  statuses <- forM [1 .. 61 :: Int] \_ -> fst <$> run small+  assertEqual "oversized requests did not spend limiter tokens" (replicate 60 200 <> [429]) statuses++-- | An oversized declared body is refused with 413 and the inner application never runs.+testOversizedBodyRejected :: TestTree+testOversizedBodyRejected = testCase "a 2 MiB Content-Length is rejected with 413" do+  (status, reached) <- runBodyLimit (KnownLength (2 * 1024 * 1024))+  status @?= 413+  assertEqual "the inner application must not be reached" False reached++-- | A body within the cap passes through untouched.+testKnownSmallBodyPassesThrough :: TestTree+testKnownSmallBodyPassesThrough = testCase "a small Content-Length passes through" do+  (status, reached) <- runBodyLimit (KnownLength 512)+  status @?= 200+  assertEqual "the inner application handled it" True reached++-- | A chunked body is metered as the application consumes it. The third chunk crosses the cap,+-- so the inner application cannot send its success response.+testChunkedBodyOverCapRejected :: TestTree+testChunkedBodyOverCapRejected = testCase "a chunked body over the cap is rejected with 413" do+  (status, innerResponded) <- runChunkedBodyLimit (replicate 3 (BS.replicate (512 * 1024) 97))+  status @?= 413+  assertEqual "the inner success response must not run" False innerResponded++-- | Metering is transparent below the cap, including the end-of-stream marker.+testSmallChunkedBodyPassesThrough :: TestTree+testSmallChunkedBodyPassesThrough = testCase "a small chunked body passes through" do+  (status, innerResponded) <- runChunkedBodyLimit (replicate 2 (BS.replicate (4 * 1024) 97))+  status @?= 200+  assertEqual "the inner application handled it" True innerResponded++-- | Warp's last-resort exception response carries the same public envelope as handler failures.+testEscapedExceptionRendersProblem :: TestTree+testEscapedExceptionRendersProblem = testCase "an escaped exception renders a problem document" do+  assertExceptionProblem 500 "internal" (toException (ErrorCall "database is on fire"))++testWarpInvalidRequestsRenderProblems :: TestTree+testWarpInvalidRequestsRenderProblems = testCase "warp invalid requests retain the problem envelope" do+  assertExceptionProblem 413 "payload_too_large" (toException PayloadTooLarge)+  assertExceptionProblem 400 "bad_request" (toException (BadFirstLine "hostile"))++testAsyncExceptionIsRethrown :: TestTree+testAsyncExceptionIsRethrown = testCase "the exception response hook rethrows asynchronous cancellation" do+  outcome <- try (evaluate (problemExceptionResponse (toException ThreadKilled)))+  case outcome :: Either AsyncException Response of+    Left ThreadKilled -> pure ()+    Left other -> fail ("unexpected async exception: " <> show other)+    Right _ -> fail "the asynchronous exception was converted into a response"++-- | Drive 'bodyLimitMiddleware' with a 1 MiB cap over a request declaring @len@, reporting the+-- response status and whether the inner application ran.+runBodyLimit :: RequestBodyLength -> IO (Int, Bool)+runBodyLimit len = do+  reachedRef <- newIORef False+  statusRef <- newIORef (0 :: Int)+  let cap = 1024 * 1024 :: Word64+      req = defaultRequest {requestBodyLength = len}+      innerApp _r respond = writeIORef reachedRef True >> respond okResponse+      capture :: Response -> IO ResponseReceived+      capture res = writeIORef statusRef (statusCode (responseStatus res)) >> pure ResponseReceived+  ResponseReceived <- bodyLimitMiddleware cap innerApp req capture+  (,) <$> readIORef statusRef <*> readIORef reachedRef++-- | Drive an unknown-length body whose chunks are supplied one at a time. The Boolean reports+-- whether the inner application reached its response continuation, not merely whether it began.+runChunkedBodyLimit :: [ByteString] -> IO (Int, Bool)+runChunkedBodyLimit chunks = do+  chunksRef <- newIORef chunks+  innerRespondedRef <- newIORef False+  statusRef <- newIORef (0 :: Int)+  let cap = 1024 * 1024 :: Word64+      nextChunk =+        atomicModifyIORef' chunksRef \case+          [] -> ([], "")+          chunk : rest -> (rest, chunk)+      req = setRequestBodyChunks nextChunk defaultRequest {requestBodyLength = ChunkedBody}+      drain request = do+        chunk <- getRequestBodyChunk request+        unless (BS.null chunk) (drain request)+      innerApp request respond = do+        drain request+        writeIORef innerRespondedRef True+        respond okResponse+      capture res = writeIORef statusRef (statusCode (responseStatus res)) >> pure ResponseReceived+  ResponseReceived <- bodyLimitMiddleware cap innerApp req capture+  (,) <$> readIORef statusRef <*> readIORef innerRespondedRef++collectResponseBody :: Response -> IO BL.ByteString+collectResponseBody response = do+  builderRef <- newIORef mempty+  let (_, _, withBody) = responseToStream response+  withBody \streamBody -> streamBody (\chunk -> modifyIORef' builderRef (<> chunk)) (pure ())+  toLazyByteString <$> readIORef builderRef++assertExceptionProblem :: Int -> Text -> SomeException -> IO ()+assertExceptionProblem expectedStatus expectedCode err = do+  let response = problemExceptionResponse err+  statusCode (responseStatus response) @?= expectedStatus+  lookup hContentType (responseHeaders response) @?= Just "application/problem+json"+  body <- collectResponseBody response+  problem <- maybe (fail ("expected problem JSON, got " <> show body)) pure (decode body :: Maybe ProblemDetails)+  problem.code @?= expectedCode+  problem.status @?= expectedStatus++okResponse :: Response+okResponse = responseLBS status200 [] "ok"
+ test/Shomei/Server/NotifySpec.hs view
@@ -0,0 +1,487 @@+-- | The 'LogNotifier' must not write a usable one-time token to the log. These tests pin+-- both halves of that contract: the default redacted line carries no raw token and no+-- @token=@ URL parameter, and the @logRawTokens@ escape hatch restores the full dev link.+module Shomei.Server.NotifySpec (tests) where++import Control.Concurrent (forkIO, killThread)+import Control.Concurrent.MVar (MVar, modifyMVar_, newMVar, readMVar)+import Control.Exception (AsyncException (ThreadKilled), SomeException, bracket, catch, finally, throwIO, toException, try)+import Control.Monad (forM_, forever)+import Control.Monad.IO.Class (liftIO)+import Data.Aeson (decode)+import Data.ByteString qualified as BS+import Data.ByteString.Lazy qualified as LBS+import Data.Char (toUpper)+import Data.IORef (IORef, atomicModifyIORef', modifyIORef', newIORef, readIORef)+import Data.List (isInfixOf)+import Data.Text qualified as Text+import Data.Text.Encoding qualified as TE+import Data.Time (UTCTime (..), fromGregorian)+import Effectful (Eff, IOE, runEff, (:>))+import Effectful.Dispatch.Dynamic (interpret_)+import Network.HTTP.Client (Manager, defaultManagerSettings, newManager)+import Network.HTTP.Types (RequestHeaders)+import Network.HTTP.Types.Status (mkStatus)+import Network.Socket+import Network.Wai (Application, requestHeaders, responseLBS, strictRequestBody)+import Network.Wai.Handler.Warp (testWithApplication)+import Shomei.Account.Email.Domain (Email, mkEmail)+import Shomei.Account.Notification.Domain (Notification (..))+import Shomei.Account.Notification.Store (sendNotification)+import Shomei.Account.OneTimeToken.Domain (OneTimeToken (..))+import Shomei.Account.Password.Breach.Store (BreachResult (..), checkPasswordBreached, sha1PrefixSuffix)+import Shomei.Account.Password.Domain (PlainPassword (..))+import Shomei.Account.Password.Hash.Postgres (sha256Hex)+import Shomei.Audit.Event.Domain (AuthEvent (NotificationDeliveryFailed), NotificationDeliveryFailedData (..))+import Shomei.Audit.Publisher.Store (AuthEventPublisher (..))+import Shomei.Authorization.Claims.Domain (Audience (..), Issuer (..))+import Shomei.Config (NotifierConfig (..), ShomeiConfig (..), SmtpConfig (..), SmtpTlsMode (..), WebhookConfig (..), defaultShomeiConfig)+import Shomei.Notify+  ( DeliveryReason (..),+    SmtpStage (..),+    WebhookSecret (..),+    classifySmtpFailure,+    renderNotification,+    runNotifierEnqueue,+    runNotifierSmtp,+    runNotifierWebhook,+    webhookSignature,+  )+import Shomei.Notify.Queue qualified as Queue+import Shomei.Server.BreachChecker (runPasswordBreachCheckerWith)+import Shomei.Time.Postgres (runClockIO)+import System.IO (BufferMode (LineBuffering), Handle, IOMode (ReadWriteMode), hClose, hFlush, hGetLine, hIsEOF, hPutStr, hSetBuffering)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))++-- | A token whose text is distinctive enough that a substring check is meaningful.+rawToken :: Text.Text+rawToken = "s3cr3t-one-time-token-do-not-log-me"++tests :: TestTree+tests =+  testGroup+    "Notify"+    [ testCase "HIBP cancellation propagates instead of becoming an unavailable lookup" do+        reports <- newIORef []+        let query _ = throwIO ThreadKilled+            report line = modifyIORef' reports (line :)+        result <- try @AsyncException (runEff . runPasswordBreachCheckerWith query report $ checkPasswordBreached (PlainPassword "cancel-fixture"))+        result @?= Left ThreadKilled+        readIORef reports >>= (@?= []),+      testCase "HIBP dependency failures expose only a bounded reason code" do+        reports <- newIORef []+        let plain = PlainPassword "do-not-log-password"+            (prefix, suffix) = sha1PrefixSuffix plain+            query sent = do+              sent @?= prefix+              throwIO (userError ("https://api.pwnedpasswords.com/range/" <> Text.unpack prefix <> "?secret=hidden " <> Text.unpack suffix <> " do-not-log-password"))+            report line = modifyIORef' reports (line :)+        result <- runEff . runPasswordBreachCheckerWith query report $ checkPasswordBreached plain+        result @?= BreachCheckUnavailable+        lines' <- readIORef reports+        lines' @?= ["[shomei:breach-check] unavailable reason=transport_error"]+        forM_ [prefix, suffix, "do-not-log-password", "hidden", "https://"] \secret ->+          assertBool "no sensitive dependency context in diagnostic" (not (any (Text.isInfixOf secret) lines')),+      testCase "redacts the one-time token by default" do+        email <- testEmail+        let out = render False (PasswordResetRequested email (OneTimeToken rawToken) expires)+        assertBool+          ("raw token must not appear in: " <> out)+          (not (Text.unpack rawToken `isInfixOf` out))+        assertBool+          ("no ?token= URL parameter in: " <> out)+          (not ("?token=" `isInfixOf` out))+        assertBool+          ("hash prefix must appear in: " <> out)+          (("token_sha256=" <> Text.unpack expectedPrefix) `isInfixOf` out)+        assertBool "kind is labelled" ("password_reset" `isInfixOf` out),+      testCase "logs the full link when logRawTokens is set" do+        email <- testEmail+        let out = render True (EmailVerificationRequested email (OneTimeToken rawToken) expires)+        assertBool+          ("full link expected in: " <> out)+          (("/v1/auth/verify-email/confirm?token=" <> Text.unpack rawToken) `isInfixOf` out)+        assertBool "no hash prefix in raw mode" (not ("token_sha256=" `isInfixOf` out)),+      smtpDeliversTest,+      smtpFailureTest,+      smtpDataRejectTest,+      smtpClassifierTest,+      notifierQueueTest,+      webhookDeliversTest,+      webhookRetriesThenSucceeds,+      webhookExhaustsThenAudits,+      webhookResponseBodyNeverAuditedTest,+      webhookTransportFailureRedactsRequestTest+    ]+  where+    expires = fixtureExpiry+    expectedPrefix = Text.take 8 (sha256Hex rawToken)+    render raw n = renderNotification (notifierCfg raw) n+    notifierCfg raw =+      (defaultShomeiConfig (Issuer "shomei") (Audience "shomei-clients")).notifierConfig+        { logRawTokens = raw+        }++testEmail :: IO Email+testEmail = either (\e -> assertFailure ("bad email: " <> show e)) pure (mkEmail "a@example.com")++-- SMTP interpreter (EP-8 M2) --------------------------------------------------++fixtureExpiry :: UTCTime+fixtureExpiry = UTCTime (fromGregorian 2030 7 8) 0++-- | The stock notifier config; only 'publicBaseUrl' (the link base) matters to these tests.+baseNotifierCfg :: NotifierConfig+baseNotifierCfg = (defaultShomeiConfig (Issuer "shomei") (Audience "shomei-clients")).notifierConfig++-- | A plaintext SMTP relay pointed at @127.0.0.1:port@, unauthenticated (lab-sink shape).+plainSmtpConfig :: Int -> SmtpConfig+plainSmtpConfig p =+  SmtpConfig+    { host = "127.0.0.1",+      port = p,+      tlsMode = SmtpPlain,+      username = Nothing,+      fromAddress = "auth@example.com",+      timeoutSeconds = 5+    }++-- | Capture published audit events into an 'IORef', standing in for the PostgreSQL publisher.+runAuthEventCapture :: (IOE :> es) => IORef [AuthEvent] -> Eff (AuthEventPublisher : es) a -> Eff es a+runAuthEventCapture ref = interpret_ \case+  PublishAuthEvent e -> liftIO (modifyIORef' ref (<> [e]))++-- | Run @runNotifierSmtp@ for one notification against the given config, collecting any published+-- audit events. Uses the real IO clock; no HTTP or database is involved.+deliverViaSmtp :: SmtpConfig -> Notification -> IO [AuthEvent]+deliverViaSmtp sc n = do+  events <- newIORef []+  runEff . runClockIO . runAuthEventCapture events . runNotifierSmtp baseNotifierCfg sc Nothing $ sendNotification n+  readIORef events++-- | The delivered message reaches a sink with the right recipient, subject, and confirm link, and+-- a successful send publishes no failure event.+smtpDeliversTest :: TestTree+smtpDeliversTest = testCase "SMTP: delivers the message to a sink with the confirm link" do+  email <- testEmail+  bracket openSink (close . sinkSocket) \sink -> bracket (forkIO (acceptLoop sink)) killThread \_ -> do+    events <- deliverViaSmtp (plainSmtpConfig (sinkPort sink)) (EmailVerificationRequested email (OneTimeToken rawToken) fixtureExpiry)+    transcript <- readMVar (sinkTranscript sink)+    assertBool+      ("RCPT TO for the recipient in: " <> show transcript)+      (any (\l -> "RCPT TO" `isInfixOf` map toUpper l && "a@example.com" `isInfixOf` l) transcript)+    assertBool+      ("subject line in: " <> show transcript)+      (any ("Verify your email address" `isInfixOf`) transcript)+    assertBool+      ("confirm link in: " <> show transcript)+      (any ("/v1/auth/verify-email/confirm?token=" `isInfixOf`) transcript)+    assertBool ("no failure event on success, got: " <> show events) (null events)++-- | A refused connection is fire-and-forget: the interpreter never throws, publishes exactly one+-- redacted 'NotificationDeliveryFailed' event, and that event carries no token.+smtpFailureTest :: TestTree+smtpFailureTest = testCase "SMTP: a refused connection audits a failure and never throws" do+  email <- testEmail+  port <- closedPort+  events <- deliverViaSmtp (plainSmtpConfig port {- unreachable -}) (PasswordResetRequested email (OneTimeToken rawToken) fixtureExpiry)+  case events of+    [NotificationDeliveryFailed d] -> do+      d.channel @?= "smtp"+      d.notificationType @?= "password_reset_requested"+      d.recipient @?= "a@example.com"+      d.errorText @?= "connect_failed"+      assertBool+        ("the token must not appear in the audit error: " <> Text.unpack d.errorText)+        (not (Text.unpack rawToken `isInfixOf` Text.unpack d.errorText))+    _ -> assertFailure ("expected exactly one delivery-failure event, got: " <> show events)++-- | smtp-mail includes the entire rendered message in the exception raised when the relay+-- rejects DATA. Persisting that exception therefore persists the one-time token too.+smtpDataRejectTest :: TestTree+smtpDataRejectTest = testCase "SMTP: a 451 at DATA audits a reason code, never the message" do+  email <- testEmail+  bracket openSink (close . sinkSocket) \sink -> bracket (forkIO (acceptLoopWithDataReply "451 4.7.1 greylisted, try again later\r\n" sink)) killThread \_ -> do+    events <- deliverViaSmtp (plainSmtpConfig (sinkPort sink)) (PasswordResetRequested email (OneTimeToken rawToken) fixtureExpiry)+    case events of+      [NotificationDeliveryFailed d] -> do+        d.errorText @?= "rejected_at_data:451"+        assertBool+          ("the rendered message must not appear in the audit reason: " <> Text.unpack d.errorText)+          (not ("token=" `Text.isInfixOf` unfoldQuotedPrintable d.errorText))+        assertBool+          ("the token must not appear in the audit reason: " <> Text.unpack d.errorText)+          (not (rawToken `Text.isInfixOf` unfoldQuotedPrintable d.errorText))+      _ -> assertFailure ("expected exactly one delivery-failure event, got: " <> show events)++unfoldQuotedPrintable :: Text.Text -> Text.Text+unfoldQuotedPrintable =+  Text.replace "=2E" "."+    . Text.replace "=3D" "="+    . Text.replace "=\\r\\n" ""+    . Text.replace "=\r\n" ""++smtpClassifierTest :: TestTree+smtpClassifierTest = testCase "classifySmtpFailure maps smtp-mail messages to reasons" do+  classifySmtpFailure+    ( toException+        ( userError+            "Unexpected reply to: DATA \"rendered message\", Expected reply code: 250, Got this instead: 451 \"greylisted\""+        )+    )+    @?= RejectedAt AtData 451+  classifySmtpFailure (toException (userError "authentication failed.")) @?= AuthFailed+  classifySmtpFailure (toException (userError "SMTP delivery timed out")) @?= Timeout+  classifySmtpFailure (toException (userError "unclassified SMTP failure")) @?= Unknown++notifierQueueTest :: TestTree+notifierQueueTest = testCase "queue: overflow and shutdown audit without blocking; drain reports remainder" do+  email <- testEmail+  let notification = PasswordResetRequested email (OneTimeToken rawToken) fixtureExpiry+      enqueueThroughPort queue = do+        events <- newIORef []+        runEff . runClockIO . runAuthEventCapture events . runNotifierEnqueue queue "webhook" $ sendNotification notification+        readIORef events++  queue <- Queue.newNotifierQueue 2+  enqueueThroughPort queue >>= (@?= [])+  enqueueThroughPort queue >>= (@?= [])+  fullEvents <- enqueueThroughPort queue+  deliveryReason fullEvents @?= Just "queue_full"+  Queue.closeNotifierQueue queue+  closedEvents <- enqueueThroughPort queue+  deliveryReason closedEvents @?= Just "shutting_down"++  drained <- Queue.newNotifierQueue 1+  Queue.enqueueNotification drained notification >>= (@?= Queue.Enqueued)+  consumer <- forkIO (Queue.withDequeued drained (const (pure ())))+  Queue.closeNotifierQueue drained+  Queue.drainNotifierQueue drained 1 >>= (@?= 0)+  killThread consumer++  undrained <- Queue.newNotifierQueue 1+  Queue.enqueueNotification undrained notification >>= (@?= Queue.Enqueued)+  Queue.closeNotifierQueue undrained+  Queue.drainNotifierQueue undrained 0 >>= (@?= 1)+  where+    deliveryReason = \case+      [NotificationDeliveryFailed d] -> Just d.errorText+      _ -> Nothing++-- A minimal in-process SMTP sink -------------------------------------------------++data Sink = Sink+  { sinkSocket :: !Socket,+    sinkPort :: !Int,+    sinkTranscript :: !(MVar [String])+  }++-- | Bind a listening socket on an ephemeral @127.0.0.1@ port and return it with an empty+-- transcript. The caller forks 'acceptLoop' and closes the socket when done.+openSink :: IO Sink+openSink = do+  let hints = defaultHints {addrFlags = [AI_PASSIVE], addrSocketType = Stream}+  addr <- head <$> getAddrInfo (Just hints) (Just "127.0.0.1") (Just "0")+  sock <- socket (addrFamily addr) Stream defaultProtocol+  setSocketOption sock ReuseAddr 1+  bind sock (addrAddress addr)+  listen sock 5+  p <- socketPort sock+  transcript <- newMVar []+  pure Sink {sinkSocket = sock, sinkPort = fromIntegral p, sinkTranscript = transcript}++-- | A port with nothing listening: bind then immediately release, so a later connect is refused.+closedPort :: IO Int+closedPort = bracket openSink (close . sinkSocket) (pure . sinkPort)++-- | Accept connections and serve each in its own thread, speaking just enough plaintext SMTP.+-- All exceptions are swallowed: when the test kills this thread or closes the listening socket,+-- the resulting @accept@/@threadWait@ error must not print or fail the suite.+acceptLoop :: Sink -> IO ()+acceptLoop = acceptLoopWithDataReply "250 OK queued\r\n"++acceptLoopWithDataReply :: String -> Sink -> IO ()+acceptLoopWithDataReply dataReply sink = loop `catch` \(_ :: SomeException) -> pure ()+  where+    loop = forever do+      (conn, _) <- accept (sinkSocket sink)+      h <- socketToHandle conn ReadWriteMode+      _ <- forkIO ((serveSmtp dataReply (sinkTranscript sink) h `finally` hClose h) `catch` \(_ :: SomeException) -> pure ())+      pure ()++-- | The sink SMTP dialogue: greet, answer EHLO/MAIL/RCPT with 250, DATA with 354 then 250 after+-- the terminating dot, and QUIT with 221. Every command line and DATA body line is recorded.+serveSmtp :: String -> MVar [String] -> Handle -> IO ()+serveSmtp dataReply transcript h = do+  hSetBuffering h LineBuffering+  respond "220 shomei-test-sink ready\r\n"+  loop+  where+    respond s = hPutStr h s >> hFlush h+    record l = modifyMVar_ transcript (pure . (<> [l]))+    loop = do+      eof <- hIsEOF h+      if eof+        then pure ()+        else do+          line <- stripCR <$> hGetLine h+          record line+          case verb line of+            "EHLO" -> respond "250 shomei-test-sink\r\n" >> loop+            "HELO" -> respond "250 shomei-test-sink\r\n" >> loop+            "MAIL" -> respond "250 OK\r\n" >> loop+            "RCPT" -> respond "250 OK\r\n" >> loop+            "DATA" -> respond "354 end with .\r\n" >> readData >> respond dataReply >> loop+            "QUIT" -> respond "221 Bye\r\n"+            _ -> respond "250 OK\r\n" >> loop+    readData = do+      line <- stripCR <$> hGetLine h+      record ("DATA> " <> line)+      if line == "." then pure () else readData+    verb = map toUpper . take 4+    stripCR s = if not (null s) && last s == '\r' then init s else s++-- Webhook interpreter (EP-8 M3) -----------------------------------------------++webhookSecretText :: Text.Text+webhookSecretText = "test-webhook-secret"++webhookConfigFor :: Int -> Int -> WebhookConfig+webhookConfigFor p maxA =+  WebhookConfig+    { url = Text.pack ("http://127.0.0.1:" <> show p <> "/hook"),+      timeoutSeconds = 5,+      maxAttempts = maxA+    }++deliverViaWebhook :: Manager -> WebhookConfig -> Notification -> IO [AuthEvent]+deliverViaWebhook mgr wc n = do+  events <- newIORef []+  runEff . runClockIO . runAuthEventCapture events . runNotifierWebhook mgr wc (WebhookSecret webhookSecretText) $ sendNotification n+  readIORef events++-- | A stub receiver that records every @(headers, raw body)@ it gets and answers the k-th+-- request (1-indexed) with @statusFor k@. The body is fully drained before responding so an+-- attempt count is never miscounted.+webhookStub ::+  IORef Int ->+  (Int -> Int) ->+  MVar [(RequestHeaders, BS.ByteString)] ->+  Application+webhookStub counter statusFor captured req respond = do+  body <- LBS.toStrict <$> strictRequestBody req+  modifyMVar_ captured (pure . (<> [(requestHeaders req, body)]))+  k <- atomicModifyIORef' counter (\c -> (c + 1, c + 1))+  respond (responseLBS (mkStatus (statusFor k) "") [] "")++-- | A single successful POST carries the JSON body, the type header, and a signature that+-- verifies against the shared secret recomputed over the exact bytes received.+webhookDeliversTest :: TestTree+webhookDeliversTest = testCase "webhook: signed JSON POST the receiver can verify" do+  email <- testEmail+  mgr <- newManager defaultManagerSettings+  captured <- newMVar []+  counter <- newIORef 0+  let n = EmailVerificationRequested email (OneTimeToken rawToken) fixtureExpiry+  testWithApplication (pure (webhookStub counter (const 200) captured)) \port -> do+    events <- deliverViaWebhook mgr (webhookConfigFor port 1) n+    reqs <- readMVar captured+    case reqs of+      [(hdrs, body)] -> do+        lookup "Content-Type" hdrs @?= Just "application/json"+        lookup "X-Shomei-Notification-Type" hdrs @?= Just "email_verification_requested"+        decode (LBS.fromStrict body) @?= Just n+        case lookup "X-Shomei-Timestamp" hdrs of+          Nothing -> assertFailure "missing X-Shomei-Timestamp"+          Just timestamp ->+            lookup "X-Shomei-Signature" hdrs @?= Just (webhookSignature (TE.encodeUtf8 webhookSecretText) timestamp body)+      _ -> assertFailure ("expected exactly one delivery, got " <> show (length reqs))+    assertBool ("no failure event on success, got: " <> show events) (null events)++-- | A 5xx is retried; a later success ends the delivery with no failure event.+webhookRetriesThenSucceeds :: TestTree+webhookRetriesThenSucceeds = testCase "webhook: retries a 5xx then succeeds, no failure event" do+  email <- testEmail+  mgr <- newManager defaultManagerSettings+  captured <- newMVar []+  counter <- newIORef 0+  let n = PasswordResetRequested email (OneTimeToken rawToken) fixtureExpiry+      statusFor k = if k <= 1 then 500 else 200+  testWithApplication (pure (webhookStub counter statusFor captured)) \port -> do+    events <- deliverViaWebhook mgr (webhookConfigFor port 2) n+    reqs <- readMVar captured+    length reqs @?= 2+    let timestamps = map (lookup "X-Shomei-Timestamp" . fst) reqs+    assertBool ("each retry must be re-stamped, got: " <> show timestamps) (case timestamps of [Just first, Just second] -> first /= second; _ -> False)+    mapM_+      ( \(headers, body) -> case lookup "X-Shomei-Timestamp" headers of+          Nothing -> assertFailure "retry missing X-Shomei-Timestamp"+          Just timestamp ->+            lookup "X-Shomei-Signature" headers @?= Just (webhookSignature (TE.encodeUtf8 webhookSecretText) timestamp body)+      )+      reqs+    assertBool ("no failure event on eventual success, got: " <> show events) (null events)++-- | A receiver that always 5xxes is attempted exactly @maxAttempts@ times, then a redacted+-- failure event is published — carrying no token.+webhookExhaustsThenAudits :: TestTree+webhookExhaustsThenAudits = testCase "webhook: exhausts attempts then audits a redacted failure" do+  email <- testEmail+  mgr <- newManager defaultManagerSettings+  captured <- newMVar []+  counter <- newIORef 0+  let n = EmailVerificationRequested email (OneTimeToken rawToken) fixtureExpiry+  testWithApplication (pure (webhookStub counter (const 500) captured)) \port -> do+    events <- deliverViaWebhook mgr (webhookConfigFor port 2) n+    reqs <- readMVar captured+    length reqs @?= 2+    case events of+      [NotificationDeliveryFailed d] -> do+        d.channel @?= "webhook"+        d.notificationType @?= "email_verification_requested"+        d.recipient @?= "a@example.com"+        assertBool+          ("the token must not appear in the audit error: " <> Text.unpack d.errorText)+          (not (Text.unpack rawToken `isInfixOf` Text.unpack d.errorText))+      _ -> assertFailure ("expected exactly one delivery-failure event, got: " <> show events)++webhookResponseBodyNeverAuditedTest :: TestTree+webhookResponseBodyNeverAuditedTest = testCase "webhook: a 500 that echoes the body audits only the status" do+  email <- testEmail+  mgr <- newManager defaultManagerSettings+  captured <- newMVar []+  let n = PasswordResetRequested email (OneTimeToken rawToken) fixtureExpiry+      echoingStub req respond = do+        body <- LBS.toStrict <$> strictRequestBody req+        modifyMVar_ captured (pure . (<> [(requestHeaders req, body)]))+        respond (responseLBS (mkStatus 500 "") [] (LBS.fromStrict body))+  testWithApplication (pure echoingStub) \port -> do+    events <- deliverViaWebhook mgr (webhookConfigFor port 1) n+    case events of+      [NotificationDeliveryFailed d] -> do+        d.errorText @?= "http_status:500"+        assertBool+          ("the response body must not appear in the audit reason: " <> Text.unpack d.errorText)+          (not (rawToken `Text.isInfixOf` d.errorText))+      _ -> assertFailure ("expected exactly one delivery-failure event, got: " <> show events)++-- | http-client's Show instance includes the request query string. A transport exception must+-- therefore be classified before it is persisted.+webhookTransportFailureRedactsRequestTest :: TestTree+webhookTransportFailureRedactsRequestTest = testCase "webhook: a transport failure never persists the request" do+  email <- testEmail+  mgr <- newManager defaultManagerSettings+  port <- closedPort+  let wc =+        (webhookConfigFor port 1)+          { url = Text.pack ("http://127.0.0.1:" <> show port <> "/hook?key=url-secret-hunter2")+          }+  events <- deliverViaWebhook mgr wc (PasswordResetRequested email (OneTimeToken rawToken) fixtureExpiry)+  case events of+    [NotificationDeliveryFailed d] -> do+      d.errorText @?= "connect_failed"+      assertBool+        ("the request URL must not appear in the audit reason: " <> Text.unpack d.errorText)+        (not ("hunter2" `Text.isInfixOf` d.errorText))+    _ -> assertFailure ("expected exactly one delivery-failure event, got: " <> show events)
+ test/Shomei/Server/RuntimeSpec.hs view
@@ -0,0 +1,126 @@+module Shomei.Server.RuntimeSpec (tests) where++import Control.Concurrent (threadDelay)+import Control.Exception (IOException, bracket, throwIO, try)+import Control.Monad (forM_)+import Data.ByteString qualified as BS+import Data.IORef (newIORef, readIORef, writeIORef)+import Network.HTTP.Types (status200)+import Network.Socket qualified as Socket+import Network.Socket.ByteString (recv, sendAll)+import Network.Wai (Application, rawPathInfo, responseLBS)+import Network.Wai.Handler.Warp qualified as Warp+import Shomei.Account.Password.Hash.Postgres (defaultArgon2Params)+import Shomei.Authorization.Claims.Domain (Audience (..), Issuer (..))+import Shomei.Config (ObservabilityConfig (..), ShomeiConfig (..), defaultShomeiConfig)+import Shomei.Server.Config (ProxyProtocolMode (..), ServerSettings (..), defaultSweepSettings)+import Shomei.Server.Middleware.TrustedProxy (emptyTrustedProxies)+import Shomei.Server.Runtime (hostWarpSettings)+import System.Timeout (timeout)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))++cfg :: ShomeiConfig+cfg = let c = defaultShomeiConfig (Issuer "test") (Audience "test") in c {observabilityConfig = c.observabilityConfig {gracefulShutdownTimeoutSeconds = 1}}++settings :: ServerSettings+settings =+  ServerSettings+    { serverPort = 0,+      serverBindHost = "127.0.0.1",+      serverMaxConnections = 1,+      serverSlowClientTimeoutSeconds = 1,+      serverConnStr = "",+      serverTrustedProxies = emptyTrustedProxies,+      serverProxyProtocol = ProxyProtocolOff,+      serverDbPoolSize = 1,+      serverDbPoolAcquisitionTimeoutMs = 1000,+      serverDbStatementTimeoutMs = 1000,+      serverDbTransactionMaxAttempts = 3,+      serverDbTransactionDeadlineMs = 5000,+      serverNotifierQueueSize = 16,+      serverWarnings = [],+      serverSweep = defaultSweepSettings,+      serverArgon2 = defaultArgon2Params,+      serverHashingMaxConcurrency = 1+    }++connectTo :: Int -> IO Socket.Socket+connectTo port = do+  sock <- Socket.socket Socket.AF_INET Socket.Stream Socket.defaultProtocol+  Socket.connect sock (Socket.SockAddrInet (fromIntegral port) (Socket.tupleToHostAddress (127, 0, 0, 1)))+  pure sock++request :: Socket.Socket -> BS.ByteString -> IO BS.ByteString+request sock path = do+  sendAll sock ("GET " <> path <> " HTTP/1.1\r\nHost: localhost\r\n\r\n")+  result <- timeout 2000000 (recv sock 4096)+  maybe (assertFailure "socket response exceeded the acceptance deadline") pure result++rejected :: Int -> IO ()+rejected port = bracket (connectTo port) Socket.close \sock -> do+  reply <- try (request sock "/") :: IO (Either IOException BS.ByteString)+  assertBool "surplus connection is closed immediately" (case reply of Left _ -> True; Right bytes -> BS.null bytes)++awaitHealthy :: Int -> IO ()+awaitHealthy port = awaitResponse port "/" "HTTP/1.1 200"++awaitResponse :: Int -> BS.ByteString -> BS.ByteString -> IO ()+awaitResponse port path expected = do+  let attempt = do+        result <- try (bracket (connectTo port) Socket.close (\sock -> request sock path)) :: IO (Either IOException BS.ByteString)+        case result of+          Right bytes | expected `BS.isPrefixOf` bytes -> pure ()+          _ -> threadDelay 10000 >> attempt+  timeout 3000000 attempt >>= (@?= Just ())++app :: Application+app request' respond+  | rawPathInfo request' == "/explode" = throwIO (userError "runtime fixture failure")+  | otherwise = respond (responseLBS status200 [] "ok")++tests :: TestTree+tests =+  testGroup+    "shared Warp runtime sockets"+    [ testCase "admission rejects surplus sockets without leaking permits on rejection, disconnect or handler exception" do+        runtime <- hostWarpSettings cfg settings Warp.defaultSettings+        Warp.withApplicationSettings runtime (pure app) \port -> do+          bracket (connectTo port) Socket.close \first -> do+            bytes <- request first "/"+            assertBool "first connection admitted" ("HTTP/1.1 200" `BS.isPrefixOf` bytes)+            rejected port+            rejected port+          awaitHealthy port+          awaitResponse port "/explode" "HTTP/1.1 500"+          awaitHealthy port,+      testCase "explicit slow-client timeout releases an idle connection and shutdown releases shared capacity" do+        runtime <- hostWarpSettings cfg settings Warp.defaultSettings+        Warp.withApplicationSettings runtime (pure app) \port ->+          bracket (connectTo port) Socket.close \sock -> do+            bytes <- request sock "/"+            assertBool "idle connection first admitted" ("HTTP/1.1 200" `BS.isPrefixOf` bytes)+            rejected port+            let awaitClose = do+                  bytes <- recv sock 4096+                  if BS.null bytes then pure () else awaitClose+            closed <- timeout 5000000 awaitClose+            closed @?= Just ()+            awaitHealthy port+        -- Reuse the same admission state after the first listener shuts down.+        Warp.withApplicationSettings runtime (pure app) awaitHealthy,+      testCase "shutdown with an admitted socket restores permits for a new listener" do+        runtime <- hostWarpSettings cfg settings {serverSlowClientTimeoutSeconds = 30} Warp.defaultSettings+        held <- newIORef Nothing+        Warp.withApplicationSettings runtime (pure app) \port -> do+          sock <- connectTo port+          writeIORef held (Just sock)+          bytes <- request sock "/"+          assertBool "socket remains admitted when listener stops" ("HTTP/1.1 200" `BS.isPrefixOf` bytes)+        readIORef held >>= mapM_ Socket.close+        Warp.withApplicationSettings runtime (pure app) awaitHealthy,+      testCase "invalid direct-library host policies fail before serving" do+        forM_ [settings {serverSlowClientTimeoutSeconds = maxBound}, settings {serverMaxConnections = 0}, settings {serverSlowClientTimeoutSeconds = 0}, settings {serverBindHost = ""}] \bad -> do+          result <- try (hostWarpSettings cfg bad Warp.defaultSettings) :: IO (Either IOException Warp.Settings)+          assertBool "invalid policy rejected" (case result of Left _ -> True; _ -> False)+    ]
+ test/Shomei/Server/SupervisorSpec.hs view
@@ -0,0 +1,114 @@+-- | Tests for the supervised-background-thread idiom ('Shomei.Server.Supervisor').+--+-- The two properties that matter operationally are that a crashing maintenance cycle never+-- takes the server down, and that killing the thread actually kills it. Both are exercised+-- through 'supervisedLoopMicros', which is 'supervisedLoop' with the interval and backoff+-- bounds given in microseconds, so these run in milliseconds rather than the production+-- loop's 5-second-to-5-minute backoff.+module Shomei.Server.SupervisorSpec (tests) where++import Control.Concurrent (forkIO, killThread, newEmptyMVar, putMVar, takeMVar, threadDelay)+import Control.Exception (Exception, SomeException, throwIO, try)+import Control.Monad (when)+import Data.IORef (atomicModifyIORef', newIORef, readIORef)+import Data.Word (Word64)+import GHC.Clock (getMonotonicTimeNSec)+import Shomei.Server.Supervisor (supervisedLoopMicros)+import System.Timeout (timeout)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertFailure, testCase)++tests :: TestTree+tests =+  testGroup+    "supervisor"+    [ testCrashingCycleIsRetried,+      testBackoffIsBounded,+      testAsyncExceptionStopsTheLoop+    ]++data Boom = Boom+  deriving stock (Show)++instance Exception Boom++-- | Run @loop@ on a forked thread until @done@ holds, then kill it. 'False' means @done@ never+-- held within @budgetMicros@.+--+-- Waiting for a /condition/ rather than for a fixed slice of wall clock is what keeps these+-- tests honest under load: a machine running twelve test suites at once gives this thread fewer+-- scheduling slices, and "did N cycles happen in 50 ms?" then answers no for reasons that have+-- nothing to do with the supervisor. The budget is deliberately orders of magnitude larger than+-- any of the delays under test, so it only fires when the loop is genuinely stuck.+runLoopUntil :: Int -> IO Bool -> IO () -> IO Bool+runLoopUntil budgetMicros done loop = do+  tid <- forkIO loop+  reached <- timeout budgetMicros poll+  killThread tid+  pure (reached == Just ())+  where+    poll = do+      finished <- done+      if finished then pure () else threadDelay 500 >> poll++-- | A cycle that throws forever must not escape the loop, and the loop must keep calling it.+-- (Note the crash lines this prints on stderr are the point, not noise.)+testCrashingCycleIsRetried :: TestTree+testCrashingCycleIsRetried = testCase "a crashing cycle is retried, never fatal" do+  calls <- newIORef (0 :: Int)+  let cycleAction = do+        atomicModifyIORef' calls \n -> (n + 1, ())+        throwIO Boom+  -- interval 1ms, backoff 1ms doubling to a 2ms ceiling: three retries need ~5ms of delays.+  retried <- runLoopUntil 10_000_000 ((>= 3) <$> readIORef calls) (supervisedLoopMicros "test" 1_000 1_000 2_000 cycleAction)+  n <- readIORef calls+  assertBool ("expected the loop to retry the crashing cycle, got " <> show n <> " calls") retried++-- | After a clean cycle the backoff resets, so the next crash waits the /initial/ backoff+-- rather than the doubled one it had grown to.+--+-- Measured directly rather than inferred from a call count. Three consecutive crashes grow the+-- backoff to 50 → 100 → 200 ms, so a fourth crash would wait 400 ms. Cycle 4 is clean, which+-- must reset the backoff; cycle 5 crashes, and the gap to cycle 6 is the wait it actually took.+-- With the reset that gap is ~50 ms; without it, ~400 ms. Asserting @< 250 ms@ separates the two+-- by a margin far wider than any scheduling jitter, which is measured in milliseconds.+testBackoffIsBounded :: TestTree+testBackoffIsBounded = testCase "backoff resets after a clean cycle" do+  ticks <- newIORef ([] :: [Word64]) -- reverse-ordered start time of each cycle+  let cycleAction = do+        t <- getMonotonicTimeNSec+        n <- atomicModifyIORef' ticks \ts -> (t : ts, length ts + 1)+        when (n <= 3 || n == 5) (throwIO Boom)+  reached <- runLoopUntil 30_000_000 ((>= 6) . length <$> readIORef ticks) (supervisedLoopMicros "test" 1_000 50_000 5_000_000 cycleAction)+  assertBool "the loop never reached its sixth cycle" reached+  ts <- reverse <$> readIORef ticks+  case ts of+    (_ : _ : _ : _ : fifth : sixth : _) -> do+      let gapMs = fromIntegral (sixth - fifth) / 1e6 :: Double+      assertBool+        ("the backoff did not reset after the clean cycle: waited " <> show gapMs <> "ms, expected ~50ms")+        (gapMs < 250)+    _ -> assertFailure ("expected at least six cycles, got " <> show (length ts))++-- | 'killThread' delivers an asynchronous 'ThreadKilled'. The loop must re-throw it rather+-- than treat it as a failed cycle and retry, otherwise the thread would be unkillable and+-- process shutdown would hang.+testAsyncExceptionStopsTheLoop :: TestTree+testAsyncExceptionStopsTheLoop = testCase "an async exception stops the loop" do+  started <- newEmptyMVar+  stopped <- newEmptyMVar+  let cycleAction = do+        putMVar started ()+        -- Block forever; the only way out is the async exception.+        threadDelay 60_000_000+  tid <- forkIO do+    outcome <- try (supervisedLoopMicros "test" 1_000 1_000 2_000 cycleAction)+    putMVar stopped (outcome :: Either SomeException ())+  takeMVar started+  killThread tid+  -- If the loop swallowed ThreadKilled and looped again, nothing is ever put into `stopped`.+  result <- timeout 2_000_000 (takeMVar stopped)+  case result of+    Nothing -> assertFailure "the loop swallowed the async exception: thread still running"+    Just (Right ()) -> assertFailure "the loop returned normally instead of propagating"+    Just (Left _) -> pure ()