diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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 + `.` 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. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2026 Nadeem Bitar + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/app/Admin.hs b/app/Admin.hs new file mode 100644 --- /dev/null +++ b/app/Admin.hs @@ -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) diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -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 diff --git a/app/Shomei/Admin/Audit.hs b/app/Shomei/Admin/Audit.hs new file mode 100644 --- /dev/null +++ b/app/Shomei/Admin/Audit.hs @@ -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 \ [filters] -- shortcut for --user +-- shomei-admin audit session \ [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 diff --git a/app/Shomei/Admin/Env.hs b/app/Shomei/Admin/Env.hs new file mode 100644 --- /dev/null +++ b/app/Shomei/Admin/Env.hs @@ -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")) diff --git a/app/Shomei/Admin/Keys.hs b/app/Shomei/Admin/Keys.hs new file mode 100644 --- /dev/null +++ b/app/Shomei/Admin/Keys.hs @@ -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))) diff --git a/app/Shomei/Admin/OAuthClients.hs b/app/Shomei/Admin/OAuthClients.hs new file mode 100644 --- /dev/null +++ b/app/Shomei/Admin/OAuthClients.hs @@ -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 \ +-- @ +-- +-- 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 diff --git a/app/Shomei/Admin/Roles.hs b/app/Shomei/Admin/Roles.hs new file mode 100644 --- /dev/null +++ b/app/Shomei/Admin/Roles.hs @@ -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 \ [--description TEXT] +-- shomei-admin roles list-defined +-- shomei-admin roles allow \ \ +-- shomei-admin roles disallow \ \ +-- shomei-admin roles show \ +-- shomei-admin roles grant --user \ --role NAME [--expires-in \ | --expires-at \] +-- shomei-admin roles revoke --user \ --role NAME +-- shomei-admin roles list --user \ +-- @ +-- +-- 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 \(s|m|h|d)@: relative to the CLI's clock at run time. + ExpiresIn NominalDiffTime + | -- | @--expires-at \@: 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 (s|m|h|d), e.g. 4h")) + <|> (ExpiresAt <$> option iso8601Reader (long "expires-at" <> metavar "ISO8601" <> help "Grant expiry as an ISO8601 UTC instant")) + +-- | @(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 (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 diff --git a/app/Shomei/Admin/ServiceAccounts.hs b/app/Shomei/Admin/ServiceAccounts.hs new file mode 100644 --- /dev/null +++ b/app/Shomei/Admin/ServiceAccounts.hs @@ -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 \ +-- shomei-admin service-accounts revoke \ +-- 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 diff --git a/app/Shomei/Admin/Sweep.hs b/app/Shomei/Admin/Sweep.hs new file mode 100644 --- /dev/null +++ b/app/Shomei/Admin/Sweep.hs @@ -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 diff --git a/app/Shomei/Admin/Users.hs b/app/Shomei/Admin/Users.hs new file mode 100644 --- /dev/null +++ b/app/Shomei/Admin/Users.hs @@ -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 )" + ) + +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 diff --git a/review-load/Main.hs b/review-load/Main.hs new file mode 100644 --- /dev/null +++ b/review-load/Main.hs @@ -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 diff --git a/shomei-server.cabal b/shomei-server.cabal new file mode 100644 --- /dev/null +++ b/shomei-server.cabal @@ -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, diff --git a/src/Shomei/Health/Server.hs b/src/Shomei/Health/Server.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Health/Server.hs @@ -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) diff --git a/src/Shomei/Notify.hs b/src/Shomei/Notify.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Notify.hs @@ -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)) "" + +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=" <> 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=@. +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 @.@ under the shared secret. +webhookSignature :: ByteString -> ByteString -> ByteString -> ByteString +webhookSignature secret timestamp body = + "sha256=" + <> convertToBase + Base16 + (hmacGetDigest (hmac secret (timestamp <> "." <> body) :: HMAC SHA256)) diff --git a/src/Shomei/Notify/Queue.hs b/src/Shomei/Notify/Queue.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Notify/Queue.hs @@ -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 diff --git a/src/Shomei/Server/App.hs b/src/Shomei/Server/App.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Server/App.hs @@ -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 diff --git a/src/Shomei/Server/Boot.hs b/src/Shomei/Server/Boot.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Server/Boot.hs @@ -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 + [] -> "" + 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) diff --git a/src/Shomei/Server/BreachChecker.hs b/src/Shomei/Server/BreachChecker.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Server/BreachChecker.hs @@ -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))) diff --git a/src/Shomei/Server/Config.hs b/src/Shomei/Server/Config.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Server/Config.hs @@ -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)) diff --git a/src/Shomei/Server/DatabaseError.hs b/src/Shomei/Server/DatabaseError.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Server/DatabaseError.hs @@ -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" diff --git a/src/Shomei/Server/ExceptionResponse.hs b/src/Shomei/Server/ExceptionResponse.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Server/ExceptionResponse.hs @@ -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 diff --git a/src/Shomei/Server/Keys.hs b/src/Shomei/Server/Keys.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Server/Keys.hs @@ -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 diff --git a/src/Shomei/Server/Middleware/BodyLimit.hs b/src/Shomei/Server/Middleware/BodyLimit.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Server/Middleware/BodyLimit.hs @@ -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 diff --git a/src/Shomei/Server/Middleware/RateLimit.hs b/src/Shomei/Server/Middleware/RateLimit.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Server/Middleware/RateLimit.hs @@ -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 diff --git a/src/Shomei/Server/Middleware/TrustedProxy.hs b/src/Shomei/Server/Middleware/TrustedProxy.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Server/Middleware/TrustedProxy.hs @@ -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)} diff --git a/src/Shomei/Server/Observability/Logging.hs b/src/Shomei/Server/Observability/Logging.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Server/Observability/Logging.hs @@ -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_@. 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" diff --git a/src/Shomei/Server/Observability/Metrics.hs b/src/Shomei/Server/Observability/Metrics.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Server/Observability/Metrics.hs @@ -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 diff --git a/src/Shomei/Server/Runtime.hs b/src/Shomei/Server/Runtime.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Server/Runtime.hs @@ -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 diff --git a/src/Shomei/Server/Supervisor.hs b/src/Shomei/Server/Supervisor.hs new file mode 100644 --- /dev/null +++ b/src/Shomei/Server/Supervisor.hs @@ -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") diff --git a/test-health/Main.hs b/test-health/Main.hs new file mode 100644 --- /dev/null +++ b/test-health/Main.hs @@ -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 diff --git a/test/Admin/Main.hs b/test/Admin/Main.hs new file mode 100644 --- /dev/null +++ b/test/Admin/Main.hs @@ -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" diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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] + ) diff --git a/test/Shomei/Server/ConfigSpec.hs b/test/Shomei/Server/ConfigSpec.hs new file mode 100644 --- /dev/null +++ b/test/Shomei/Server/ConfigSpec.hs @@ -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" diff --git a/test/Shomei/Server/E2ESpec.hs b/test/Shomei/Server/E2ESpec.hs new file mode 100644 --- /dev/null +++ b/test/Shomei/Server/E2ESpec.hs @@ -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} diff --git a/test/Shomei/Server/MiddlewareSpec.hs b/test/Shomei/Server/MiddlewareSpec.hs new file mode 100644 --- /dev/null +++ b/test/Shomei/Server/MiddlewareSpec.hs @@ -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" diff --git a/test/Shomei/Server/NotifySpec.hs b/test/Shomei/Server/NotifySpec.hs new file mode 100644 --- /dev/null +++ b/test/Shomei/Server/NotifySpec.hs @@ -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) diff --git a/test/Shomei/Server/RuntimeSpec.hs b/test/Shomei/Server/RuntimeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Shomei/Server/RuntimeSpec.hs @@ -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) + ] diff --git a/test/Shomei/Server/SupervisorSpec.hs b/test/Shomei/Server/SupervisorSpec.hs new file mode 100644 --- /dev/null +++ b/test/Shomei/Server/SupervisorSpec.hs @@ -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 ()