Boot.hs

-- | Startup sequence and warp boot for the standalone Shōmei auth service.
--
-- 'main' runs the turnkey startup: load config → run migrations (idempotent) → acquire the
-- hasql pool → bootstrap the signing key → build the 'Env' → serve with warp. 'application'
-- builds the WAI app from the exact 'Shomei.Servant.Server.shomeiRoutes' tree and the
-- @AuthProtect "shomei-jwt"@ 'Context'. EP-5's handlers run in the smaller servant port
-- stack ('Shomei.Servant.Seam.AppEffects'); they are bridged onto this server's larger
-- PostgreSQL stack ('Shomei.Server.App.AppEffects') with @inject@ inside the seam env's
-- runner. Infrastructure failures remain typed through the seam; domain failures flow
-- through the same channel to the right status.
module Shomei.Server.Boot
  ( main,
    application,
    HostBackgroundTasks (..),
    installHostBackgroundTasks,
    hostMiddleware,
    edgeMiddleware,
    buildEnv,
    seamEnv,
    authContext,
    validateOidcIssuer,
    NotifierWorker (..),
    installNotifierWorker,
  )
where

-- 'Context' is hidden from the prelude (it re-exports lens's 'Context'); we mean
-- servant's 'Servant.Context' here.

import Control.Concurrent (forkIO, killThread)
import Data.Aeson ((.=))
import Data.Aeson.Key qualified as Key
import Data.ByteString qualified as BS
import Data.Foldable (traverse_)
import Data.IORef (newIORef, readIORef)
import Data.List.NonEmpty qualified as NonEmpty
import Data.Set qualified as Set
import Data.Text qualified as Text
import Data.Time (DiffTime, picosecondsToDiffTime)
import Database.PostgreSQL.Migrate (MigrationReport (..))
import Effectful (Eff, inject, runEff)
import Effectful.Error.Static (runErrorNoCallStack)
import GHC.Clock (getMonotonicTimeNSec)
import Network.HTTP.Client.TLS (newTlsManager)
import Network.Wai (Application, Middleware, Request)
import Network.Wai.Handler.Warp qualified as Warp
import Servant
  ( Context (EmptyContext, (:.)),
    ErrorFormatters,
    serveWithContext,
  )
import Servant.Health (ProbeCheck)
import Servant.Server.Experimental.Auth (AuthHandler)
import Shomei.Account.Password.Hash.Postgres (Argon2Failure (..), Argon2Params (..), argon2WarningFloor, hashingLimit, newHashingLimiter, sha256Hex, trialArgon2Derivation)
import Shomei.Audit.Publisher.Postgres (runAuthEventPublisherPostgres)
import Shomei.Authorization.Claims.Domain (Issuer (..), Role (..))
import Shomei.Authorization.Role.Postgres (runRoleStorePostgres)
import Shomei.Authorization.Role.Workflow (undefinedDefaultRoles)
import Shomei.Config (OAuthConfig (..), ObservabilityConfig (..), ShomeiConfig (..), SigningKeyConfig (..), TotpConfig (..), configSigningAlgorithm)
import Shomei.Error (AuthError)
import Shomei.Health.Server (buildHealthChecks)
import Shomei.Mfa.Totp.Postgres (TotpEncryptionKey, checkTotpEnvelopeVersions, totpEncryptionKeyFromBase64, totpEncryptionKeyFromBytes)
import Shomei.Migrations (applyShomeiMigrations)
import Shomei.Notify (deliverNotification)
import Shomei.Notify.Queue (closeNotifierQueue, drainNotifierQueue, newNotifierQueue, withDequeued)
import Shomei.Persistence.Database.Postgres (TransactionRetryPolicy (..), runDatabasePoolWith)
import Shomei.Persistence.Maintenance.Postgres (sweepOnce, sweepReportCounts)
import Shomei.Persistence.Pool.Postgres (acquirePool)
import Shomei.Persistence.Pool.Postgres qualified as Pool

-- '(.=)' is hidden from the prelude (it re-exports lens's state-setter of the same name);
-- we mean aeson's JSON pair constructor here.
import Shomei.Prelude hiding (Context, (.=))
import Shomei.Servant.Api (shomeiRoutesApi, shomeiThrottledRoutes)
import Shomei.Servant.Auth (AuthUser, authHandler)
import Shomei.Servant.Error (shomeiErrorFormatters)
import Shomei.Servant.Middleware (problemMiddleware)
import Shomei.Servant.Oidc (isAbsoluteHttpUrl)
import Shomei.Servant.Seam qualified as Seam
import Shomei.Servant.Server (shomeiRoutes)
import Shomei.Server.App (Env (..), runAppIO)
import Shomei.Server.Config (ProxyProtocolMode (..), ServerSettings (..), SweepSettings (..), loadConfig, loadNotifierSecretsFromEnv, toSweepConfig)
import Shomei.Server.Keys (LoadedKeys (..), bootstrapKeys, loadKekFromEnv, reloadKeys)
import Shomei.Server.Middleware.BodyLimit (bodyLimitMiddleware, defaultBodyLimitBytes)
import Shomei.Server.Middleware.RateLimit (RateLimiter, newRateLimiterFor, rateLimitMiddleware)
import Shomei.Server.Middleware.TrustedProxy (TrustedProxies, trustedProxyMiddleware, trustedProxyTexts)
import Shomei.Server.Observability.Logging (requestLoggingMiddleware)
import Shomei.Server.Observability.Metrics (Metrics, metricsEndpointMiddleware, metricsMiddleware, newMetrics)
import Shomei.Server.Runtime (hostWarpSettings)
import Shomei.Server.Supervisor (logJsonLine, supervisedLoop, supervisedLoopMicros)
import Shomei.Session.LoginAttempt.Domain (AccountKey (..))
import Shomei.Time.Postgres (runClockIO)
import System.Environment (lookupEnv)
import System.Exit (exitFailure)
import System.IO (BufferMode (LineBuffering), hPutStrLn, hSetBuffering, stderr, stdout)
import System.Posix.Signals (installHandler, sigHUP, sigINT, sigTERM)
import System.Posix.Signals qualified as Signals

-- | The full turnkey startup sequence.
main :: IO ()
main = do
  -- Line-buffer stdout so each structured JSON log line is flushed immediately (when stdout
  -- is a pipe/file it would otherwise be block-buffered and logs would not appear promptly).
  hSetBuffering stdout LineBuffering
  hSetBuffering stderr LineBuffering
  (cfg, settings) <- loadConfig
  let trustedProxySummary =
        case trustedProxyTexts settings.serverTrustedProxies of
          [] -> "none"
          entries -> Text.intercalate "," entries
      proxyProtocolSummary = case settings.serverProxyProtocol of
        ProxyProtocolOff -> "none"
        ProxyProtocolRequired -> "required"
  hPutStrLn
    stderr
    ( "[shomei] trusted proxies: "
        <> Text.unpack trustedProxySummary
        <> "; proxy protocol: "
        <> proxyProtocolSummary
    )
  traverse_
    (\warning -> hPutStrLn stderr ("[shomei] WARNING: " <> Text.unpack warning))
    settings.serverWarnings
  -- Warn, never refuse: a resource-starved dev box legitimately wants cheap hashing, but an
  -- operator must not weaken password storage without seeing it said out loud.
  traverse_
    (\w -> hPutStrLn stderr ("[shomei] WARNING: " <> Text.unpack w))
    (argon2WarningFloor settings.serverArgon2)
  trialArgon2Derivation settings.serverArgon2 >>= \case
    Right () -> pure ()
    Left (Argon2Failure why) -> do
      hPutStrLn
        stderr
        ( "[shomei] FATAL: the Argon2 implementation rejected the configured parameters (m="
            <> show settings.serverArgon2.memoryKiB
            <> "KiB,t="
            <> show settings.serverArgon2.iterations
            <> ",p="
            <> show settings.serverArgon2.parallelism
            <> "): "
            <> Text.unpack why
        )
      exitFailure
  validateOidcIssuer cfg
  env <- buildEnv cfg settings
  (liveness, readiness) <- buildHealthChecks env
  backgroundTasks <- installHostBackgroundTasks cfg settings env
  rl <- newRateLimiterFor shomeiThrottledRoutes cfg.rateLimitConfig
  metrics <- newMetrics
  let obs = cfg.observabilityConfig
      -- Graceful shutdown: SIGTERM (orchestrator stop) and SIGINT (Ctrl-C) trigger warp's
      -- shutdown action, which stops accepting new connections and waits up to the
      -- configured timeout for in-flight requests to finish. After warp returns we close the
      -- pool and exit 0.
      installShutdown closeSocket = do
        let stop sig = hPutStrLn stderr ("[shomei] received " <> sig <> "; draining in-flight requests") >> closeSocket
        _ <- installHandler sigTERM (Signals.Catch (stop "SIGTERM")) Nothing
        _ <- installHandler sigINT (Signals.Catch (stop "SIGINT")) Nothing
        pure ()
  warpSettings <- hostWarpSettings cfg settings (Warp.setInstallShutdownHandler installShutdown Warp.defaultSettings)
  hPutStrLn stderr ("[shomei] listening on :" <> show settings.serverPort)
  Warp.runSettings warpSettings (hostMiddleware cfg settings rl metrics (application env liveness readiness))
  stopHostBackgroundTasks backgroundTasks obs.gracefulShutdownTimeoutSeconds
  hPutStrLn stderr "[shomei] drain complete; closing connection pools"
  Pool.release env.envPool
  hPutStrLn stderr "[shomei] shutdown complete"

-- | Background services required to give an embedded host the standalone server's runtime
-- guarantees. Call 'stopHostBackgroundTasks' after the host server stops accepting requests;
-- it drains queued notifications within the same bounded shutdown budget and releases the
-- sweeper's isolated pool.
newtype HostBackgroundTasks = HostBackgroundTasks
  { stopHostBackgroundTasks :: Int -> IO ()
  }

-- | Install every process-wide and background service used by the standalone server: validate
-- configured default roles, refresh signing keys periodically and on @SIGHUP@, sweep expired
-- state, and deliver queued notifications. An embedding host calls this once after 'buildEnv'.
installHostBackgroundTasks :: ShomeiConfig -> ServerSettings -> Env -> IO HostBackgroundTasks
installHostBackgroundTasks cfg settings env = do
  validateDefaultRoles cfg env
  installKeyReload cfg env
  releaseSweeper <- installSweeper settings env
  notifierWorker <- installNotifierWorker env
  pure
    HostBackgroundTasks
      { stopHostBackgroundTasks = \timeoutSeconds -> do
          drainNotifierWorker notifierWorker timeoutSeconds
          releaseSweeper
      }

-- | The WAI edge used by the standalone server. Wrap the host's whole application so its own
-- routes receive the same trusted-proxy attribution, request IDs, metrics, body cap, and
-- per-client rate limiting as Shōmei's routes.
hostMiddleware :: ShomeiConfig -> ServerSettings -> RateLimiter -> Metrics -> Middleware
hostMiddleware cfg settings =
  edgeMiddleware cfg.observabilityConfig settings.serverTrustedProxies

-- | The WAI edge every host must install. The trusted-proxy rewrite is outermost so logging,
-- metrics, the limiter, and Servant's 'RemoteHost' all observe the same client address.
edgeMiddleware :: ObservabilityConfig -> TrustedProxies -> RateLimiter -> Metrics -> Middleware
edgeMiddleware obs proxies limiter metrics =
  trustedProxyMiddleware proxies
    . requestLoggingMiddleware obs
    . withMetrics
    . bodyLimitMiddleware defaultBodyLimitBytes
    . rateLimitMiddleware limiter
  where
    withMetrics
      | obs.metricsEnabled = metricsMiddleware metrics . metricsEndpointMiddleware metrics
      | otherwise = id

-- | Refuse to start with the OIDC provider enabled and an issuer that is not an absolute
-- @http(s)@ URL.
--
-- The issuer doubles as the provider's public base URL: every endpoint in the discovery document
-- is derived from it, and ID tokens carry it as @iss@. With the default issuer @"shomei"@ the
-- document would advertise @shomei\/oauth\/token@ — a relative URL no client can fetch — and the
-- failure would surface as an inscrutable error inside someone else's OIDC library. Checked
-- before the pool is acquired, because it needs nothing but config.
validateOidcIssuer :: ShomeiConfig -> IO ()
validateOidcIssuer cfg =
  when (cfg.oauthConfig.oidcEnabled && not (isAbsoluteHttpUrl iss)) do
    hPutStrLn
      stderr
      ( "shomei-server: oidcEnabled is set but issuer is not an absolute http(s) URL: "
          <> show iss
          <> "\nThe OIDC issuer is also the base URL every published endpoint is derived from."
          <> "\nSet SHOMEI_ISSUER (or `issuer` in the config file) to this deployment's public"
          <> " base URL, e.g. https://auth.example.com"
      )
    exitFailure
  where
    iss = case cfg.issuer of Issuer t -> t

-- | Refuse to start when @defaultRoles@ names a role missing from the @shomei_roles@ registry.
--
-- Validating once here rather than on every signup keeps the hot path free of catalog reads and
-- turns a config typo into an immediate, obvious startup failure instead of a stream of 500s on
-- an endpoint nobody is watching. The registry is append-only, so a role validated here cannot
-- later disappear — which is why 'Shomei.Authorization.Role.Workflow.applyDefaultRoles' does not re-check.
--
-- An embedding host that sets @defaultRoles@ should call
-- 'Shomei.Authorization.Role.Workflow.undefinedDefaultRoles' the same way where it assembles its ports.
validateDefaultRoles :: ShomeiConfig -> Env -> IO ()
validateDefaultRoles cfg env = do
  outcome <-
    runEff
      . runErrorNoCallStack @AuthError
      . runDatabasePoolWith env.envDbRetryPolicy env.envPool
      . runRoleStorePostgres
      $ undefinedDefaultRoles cfg
  case outcome of
    Left e -> die ("could not validate defaultRoles against the role registry: " <> show e)
    Right missing
      | Set.null missing -> pure ()
      | otherwise -> do
          let names = Text.intercalate ", " [r | Role r <- Set.toList missing]
              first' = case Set.toList missing of
                Role r : _ -> r
                [] -> "<role>"
          die
            ( "defaultRoles names undefined roles: "
                <> Text.unpack names
                <> "\ndefine them first: shomei-admin roles define "
                <> Text.unpack first'
            )
  where
    die msg = hPutStrLn stderr ("shomei-server: " <> msg) >> exitFailure

-- | Install the two triggers that refresh signing-key material on a running server, so
-- @shomei-admin keys activate@ / @keys revoke@ take effect with no restart: a periodic
-- background reload every @refreshIntervalSeconds@ (0 disables it), and a @SIGHUP@ handler
-- for a deterministic "apply now". Both call 'reloadKeys', which keeps the last good
-- material if a reload fails.
--
-- The periodic reload runs on 'supervisedLoop', the shared supervised-background-thread
-- idiom: a crash is logged and retried with backoff rather than killing the loop, and the
-- thread dies with the process. Note that 'supervisedLoop' runs its first cycle immediately,
-- so a reload happens right after 'bootstrapKeys' — harmless, since 'reloadKeys' is idempotent
-- and keeps the last good material on failure.
installKeyReload :: ShomeiConfig -> Env -> IO ()
installKeyReload cfg env = do
  when (interval > 0) (void (forkIO (supervisedLoop "key-reload" interval reload)))
  void (installHandler sigHUP (Signals.Catch onHup) Nothing)
  where
    interval = cfg.signingKeyConfig.refreshIntervalSeconds
    reload = reloadKeys env.envKek env.envPool env.envKeys
    onHup = hPutStrLn stderr "[shomei] SIGHUP: reloading signing keys" >> reload

-- | Fork the background expired-data sweeper, unless the operator disabled it in favor of
-- scheduling @shomei-admin sweep@ externally. Its one-connection pool is deliberately separate
-- from the request pool, so a long drain never consumes request capacity. The returned cleanup
-- releases that pool during graceful shutdown.
--
-- A 'Left' from 'sweepOnce' means the database was unreachable or a statement failed. That is
-- an ordinary outcome for periodic maintenance, not a crash: it is logged and the loop sleeps
-- a normal interval rather than entering 'supervisedLoop''s backoff, which is reserved for
-- genuine exceptions.
installSweeper :: ServerSettings -> Env -> IO (IO ())
installSweeper settings _env
  | not sweep.sweepEnabled = pure (pure ())
  | otherwise = do
      sweepPool <-
        acquirePool
          1
          (millisToDiffTime settings.serverDbPoolAcquisitionTimeoutMs)
          settings.serverDbStatementTimeoutMs
          settings.serverConnStr
      hPutStrLn
        stderr
        ( "[shomei] sweeper: every "
            <> show sweep.sweepIntervalSeconds
            <> "s, audit retention "
            <> maybe "disabled (retain forever)" (\d -> show d <> " days") sweep.sweepAuthEventRetentionDays
            <> ", on its own connection"
        )
      void (forkIO (supervisedLoop "sweeper" sweep.sweepIntervalSeconds (oneCycle sweepPool)))
      pure (Pool.release sweepPool)
  where
    sweep = settings.serverSweep
    oneCycle sweepPool = do
      -- Wall-clock time decides which rows are expired; a monotonic clock measures how long
      -- the sweep took, so an NTP step cannot produce a negative duration.
      cutoffNow <- getCurrentTime
      startTick <- getMonotonicTimeNSec
      result <- sweepOnce sweepPool (toSweepConfig sweep) cutoffNow
      endTick <- getMonotonicTimeNSec
      logSweepCycle (durationMs startTick endTick) result

    durationMs startTick endTick =
      fromIntegral (endTick - startTick) / 1_000_000 :: Double

    logSweepCycle elapsed = \case
      Left err ->
        logJsonLine
          [ "level" .= ("error" :: Text),
            "msg" .= ("sweep failed" :: Text),
            "task" .= ("sweeper" :: Text),
            "error" .= Text.pack (show err),
            "duration_ms" .= elapsed
          ]
      Right report ->
        logJsonLine
          ( [ "level" .= ("info" :: Text),
              "msg" .= ("sweep" :: Text)
            ]
              <> [Key.fromText table .= deleted | (table, deleted) <- sweepReportCounts report]
              <> ["duration_ms" .= elapsed]
          )

-- | Handle returned by 'installNotifierWorker'. EP-9's embedding assembly lifts the install
-- and drain calls verbatim so an embedding host receives the same delivery guarantees.
newtype NotifierWorker = NotifierWorker
  { drainNotifierWorker :: Int -> IO ()
  }

-- | Run one supervised delivery worker. Closing prevents new enqueue operations, then drain waits
-- within the server's graceful-shutdown budget before cancelling any remaining network call.
installNotifierWorker :: Env -> IO NotifierWorker
installNotifierWorker env = do
  workerThread <-
    forkIO
      ( supervisedLoopMicros
          "notifier"
          0
          (5 * 1_000_000)
          (300 * 1_000_000)
          oneCycle
      )
  pure
    NotifierWorker
      { drainNotifierWorker = \timeoutSeconds -> do
          closeNotifierQueue env.envNotifierQueue
          dropped <- drainNotifierQueue env.envNotifierQueue timeoutSeconds
          logJsonLine
            [ "level" .= (if dropped == 0 then "info" else "warn" :: Text),
              "msg" .= ("notifier drained" :: Text),
              "dropped" .= dropped
            ]
          killThread workerThread
      }
  where
    oneCycle =
      withDequeued env.envNotifierQueue \notification -> do
        result <-
          runEff
            . runErrorNoCallStack @AuthError
            . runDatabasePoolWith env.envDbRetryPolicy env.envPool
            . runClockIO
            . runAuthEventPublisherPostgres
            $ deliverNotification env.envHttpManager env.envNotifierSecrets env.envConfig notification
        case result of
          Right () -> pure ()
          Left err ->
            logJsonLine
              [ "level" .= ("error" :: Text),
                "msg" .= ("notifier delivery audit failed" :: Text),
                "task" .= ("notifier" :: Text),
                "error" .= Text.pack (show err)
              ]

-- | Run the schema migrations (idempotent), acquire the pool, and bootstrap the signing
-- key, yielding the assembled 'Env'. Shared by 'main' and by host applications that embed
-- the Shōmei API (the embedded demo builds its own 'Env' this way). Running
-- @shomei-migrate@ out-of-band is also supported for production.
buildEnv :: ShomeiConfig -> ServerSettings -> IO Env
buildEnv cfg settings = do
  alg <-
    either
      (\why -> hPutStrLn stderr ("[shomei] FATAL: signingKeyConfig.algorithm: " <> Text.unpack why) >> exitFailure)
      pure
      (configSigningAlgorithm cfg)
  applyShomeiMigrations settings.serverConnStr >>= \case
    Left migrationError -> do
      hPutStrLn stderr ("[shomei] FATAL: schema migration failed: " <> show migrationError)
      exitFailure
    Right report ->
      hPutStrLn
        stderr
        ("[shomei] schema migrations applied: " <> show (NonEmpty.length report.results) <> " migrations")
  hPutStrLn
    stderr
    ( "[shomei] db pool: size "
        <> show settings.serverDbPoolSize
        <> ", acquisition timeout "
        <> show settings.serverDbPoolAcquisitionTimeoutMs
        <> "ms, statement timeout "
        <> show settings.serverDbStatementTimeoutMs
        <> "ms"
    )
  pool <-
    acquirePool
      settings.serverDbPoolSize
      (millisToDiffTime settings.serverDbPoolAcquisitionTimeoutMs)
      settings.serverDbStatementTimeoutMs
      settings.serverConnStr
  checkTotpEnvelopeVersions pool >>= \case
    Right (0, 0) -> pure ()
    _ -> do
      Pool.release pool
      hPutStrLn stderr "[shomei] FATAL: TOTP envelope conversion required; stop writers and run shomei-admin totp migrate-envelopes --check, then --offline"
      exitFailure
  kek <- loadKekFromEnv
  totpKey <- loadTotpKeyFromEnv cfg
  notifierSecrets <- loadNotifierSecretsFromEnv cfg
  keys <- bootstrapKeys kek alg pool
  keysRef <- newIORef keys
  mgr <- newTlsManager
  limiter <- newHashingLimiter settings.serverHashingMaxConcurrency
  notifierQueue <- newNotifierQueue settings.serverNotifierQueueSize
  hPutStrLn
    stderr
    ( "[shomei] hashing concurrency "
        <> show (hashingLimit limiter)
        <> ", argon2 m="
        <> show settings.serverArgon2.memoryKiB
        <> "KiB,t="
        <> show settings.serverArgon2.iterations
        <> ",p="
        <> show settings.serverArgon2.parallelism
    )
  pure
    Env
      { envPool = pool,
        envDbRetryPolicy = TransactionRetryPolicy settings.serverDbTransactionMaxAttempts settings.serverDbTransactionDeadlineMs,
        envConfig = cfg,
        envKeys = keysRef,
        envKek = kek,
        envHttpManager = mgr,
        envNotifierSecrets = notifierSecrets,
        envNotifierQueue = notifierQueue,
        envArgon2Params = settings.serverArgon2,
        envHashingLimiter = limiter,
        envTotpKey = totpKey
      }

-- | The AES-256-GCM key that encrypts stored TOTP secrets (EP-7), loaded from
-- @SHOMEI_TOTP_ENCRYPTION_KEY@ (base64 of exactly 32 bytes; generate one with
-- @openssl rand -base64 32@).
--
-- When TOTP is enabled and the variable is absent or malformed, the server refuses to boot with
-- a loud message — an enabled factor whose secrets cannot be encrypted is a silent data-loss
-- trap. When TOTP is disabled the store is unreachable (enrollment is refused), so a valid key is
-- optional; a dummy all-zero key keeps the interpreter-stack shape fixed. A key supplied while
-- disabled is still validated, so a typo is caught before it is switched on.
loadTotpKeyFromEnv :: ShomeiConfig -> IO TotpEncryptionKey
loadTotpKeyFromEnv cfg = do
  raw <- lookupEnv "SHOMEI_TOTP_ENCRYPTION_KEY"
  let enabled = cfg.totpConfig.totpEnabled
  case fmap Text.pack raw of
    Just t | not (Text.null (Text.strip t)) ->
      case totpEncryptionKeyFromBase64 t of
        Right k -> pure k
        Left err -> die ("SHOMEI_TOTP_ENCRYPTION_KEY " <> Text.unpack err)
    _
      | enabled -> die "SHOMEI_TOTP_ENCRYPTION_KEY is required when totpEnabled is set (generate one with: openssl rand -base64 32)"
      | otherwise -> either (die . Text.unpack) pure (totpEncryptionKeyFromBytes (BS.replicate 32 0))
  where
    die msg = hPutStrLn stderr ("[shomei] " <> msg) >> exitFailure

-- | Milliseconds to a 'DiffTime', exactly (a 'DiffTime' counts picoseconds, so this loses
-- nothing). Used for the pool's acquisition timeout, which config carries as an integer count
-- of milliseconds.
millisToDiffTime :: Int -> DiffTime
millisToDiffTime ms = picosecondsToDiffTime (fromIntegral ms * 1_000_000_000)

-- | Build the WAI 'Application': EP-5's server with the @AuthProtect "shomei-jwt"@
-- 'Context'. Authentication is derived from the seam env's port runner and config, so it uses
-- the current verification keys and honors @sessionCheckMode@.
--
-- The served tree is 'shomeiRoutesApi' (EP-3): application routes under @\/v1@, JWKS and the
-- probes at unversioned root paths.
--
-- 'problemMiddleware' converts Servant's one un-formattable failure — the bare @405@ a method
-- mismatch raises below any 'ErrorFormatters' hook — into a problem document, so /every/ error
-- the process emits carries the same envelope.
application :: Env -> ProbeCheck -> ProbeCheck -> Application
application env liveness readiness =
  problemMiddleware (serveWithContext shomeiRoutesApi (authContext senv) (shomeiRoutes senv liveness readiness))
  where
    senv = seamEnv env

-- | The Servant 'Context' carrying the @AuthProtect "shomei-jwt"@ 'AuthHandler' (built from the
-- seam env itself) and the 'ErrorFormatters' that render Servant's own body-parse,
-- url-parse, header-parse, and not-found failures as RFC 9457 problem documents. A host app
-- embedding 'ShomeiAPI' serves with this same context.
authContext :: Seam.Env -> Context '[AuthHandler Request AuthUser, ErrorFormatters]
authContext senv =
  authHandler senv
    :. shomeiErrorFormatters
    :. EmptyContext

-- | Build EP-5's seam 'Seam.Env' from this server's assembly 'Env'. The port runner
-- bridges EP-5's smaller stack onto the PostgreSQL stack with @inject@ while preserving
-- its typed error channel.
seamEnv :: Env -> Seam.Env
seamEnv env =
  Seam.Env
    { Seam.runPorts = runPorts,
      Seam.config = env.envConfig,
      -- The JWKS getter reads swappable key material, so a rotation applied by 'reloadKeys'
      -- takes effect on the next request without rebuilding the WAI application. Token
      -- verification now goes through 'Seam.runPorts'; 'runAppIO' also re-reads these keys.
      Seam.jwksJson = (.jwksBody) <$> readIORef env.envKeys,
      Seam.accountKeyOf = AccountKey . sha256Hex
    }
  where
    runPorts :: forall a. Eff Seam.AppEffects a -> IO (Either AuthError a)
    runPorts act = runAppIO env (inject act)