shomei-server-0.3.0.0: src/Shomei/Server/Config.hs
-- | 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))