-- SPDX-FileCopyrightText: 2026 Alexandra de Wit
--
-- SPDX-License-Identifier: MIT

{- | The shared process-boot bracket for Écluse service roles.

'withBootEnv' applies @*_FILE@ secret indirection, locates the configuration
document under the @ECLUSE_CONFIG@ semantics, validates it, applies the runtime
posture, builds the process logger, and brackets the telemetry substrate. It
hands the resulting 'BootEnv' to role-specific composition roots such as
"Ecluse.Proxy", which build their own service resources only after boot succeeds.
-}
module Ecluse.Boot (
    BootEnv (..),
    applySecretFileIndirection,
    readConfigDocument,
    withBootEnv,
    BootAborted (..),
    orExit,
    logBootWarning,
    logBootInfo,
    logRuleBootOrder,
    buildMirrorQueue,
) where

import Data.ByteString qualified as BS
import Data.List (lookup)
import Data.Text qualified as T
import Data.Text.IO qualified as TIO
import Katip (Environment (Environment), LogEnv, Severity (InfoS, WarningS), logFM, ls)
import Katip.Monadic (runKatipContextT)
import System.Environment (getEnvironment)
import System.IO.Error (ioeGetErrorString, isDoesNotExistError)
import UnliftIO (throwIO, tryIO)

import Ecluse.Composition.MirrorQueue (
    MirrorQueuePlan (MemoryBackend, SqsBackend),
    memoryQueueDropWarning,
    mirrorQueuePlanWarning,
 )
import Ecluse.Config (
    AppConfig (cfgObservability, cfgRuntime),
    Config (configApp),
    ObservabilitySettings (obsLogFormat, obsTelemetry),
    RuntimeSettings (rtCores, rtMaxHeapBytes),
    loadConfig,
    mountCollisionWarnings,
    renderConfigError,
    resolvedKeyProvenance,
 )
import Ecluse.Config.Ambient (AmbientAws, ambientAwsFromEnv)
import Ecluse.Config.Resolve (secretEnvSpellings)
import Ecluse.Core.Queue (MirrorQueue)
import Ecluse.Core.Queue.Memory (defaultMemoryQueueConfig, newBoundedInMemoryQueue)
import Ecluse.Core.Rules (renderBootOrder)
import Ecluse.Core.Security.Egress (mkRegistryUrl)
import Ecluse.Core.Server.Context (PackumentDeps (pdRules))
import Ecluse.Rts (EffectiveRuntimePlan, applyRuntimePosture)
import Ecluse.Runtime.Log (moduleField, newLogEnv)
import Ecluse.Runtime.Queue.Sqs (newSqsQueue)
import Ecluse.Runtime.Server (MountBinding (bindingPackumentDeps, bindingPrefix))
import Ecluse.Runtime.Telemetry (Telemetry, TelemetrySwitch (TelemetryOff, TelemetryOn), withTelemetry)
import Ecluse.Runtime.Telemetry.Resolve (prepareTelemetry)

{- | The boot context assembled once at start-up and handed to each subcommand: the
validated configuration, the process logger, and the telemetry handle. 'withBootEnv'
builds it, and the @ecluse@ entry point (see "Ecluse") dispatches the selected
subcommand over it. The heavier serve- and worker-side handles (the HTTP managers,
the mirror queue, the metadata cache) are built later, per subcommand (see
"Ecluse.Proxy").
-}
data BootEnv = BootEnv
    { BootEnv -> AppConfig
beConfig :: AppConfig
    -- ^ The application-level configuration slice the subcommands read.
    , BootEnv -> AmbientAws
beAmbient :: AmbientAws
    {- ^ The ambient AWS SDK environment (region, endpoint overrides), read from
    the process environment beside the config, never through the config AST.
    -}
    , BootEnv -> LogEnv
beLogEnv :: LogEnv
    -- ^ The process structured-logging environment.
    , BootEnv -> Telemetry
beTelemetry :: Telemetry
    -- ^ The telemetry handle, inert unless @ECLUSE_OBSERVABILITY__TELEMETRY@ enabled it.
    , BootEnv -> Config
beConfigFull :: Config
    {- ^ The whole loaded configuration document, for subcommands that need more than
    'beConfig' (the serve path's mount and rule wiring, for one).
    -}
    , BootEnv -> EffectiveRuntimePlan
beRuntimePlan :: EffectiveRuntimePlan
    {- ^ The resolved runtime posture (capabilities and heap ceiling, each with its
    provenance), the datapoint the downstream sizings and the memory plan
    compute from.
    -}
    }

{- | Apply the @*_FILE@ secret indirection: a recognised secret variable may be
supplied as @\<VAR\>_FILE@ naming a file whose contents (one trailing newline
stripped) become the variable's value -- the standard container-secret mount
pattern, so a token never has to enter the environment itself. Only the
secret-typed keys are eligible; any other @*_FILE@ spelling transliterates to an
unknown document key and is rejected by the strict parser as usual. Setting both
a base variable and its @_FILE@ form is a fail-loud conflict (never a silent
precedence choice), and an unreadable file fails the same way; failures
aggregate so one run reports them all. Shared by the boot and @check-config@.
-}
applySecretFileIndirection :: [(String, String)] -> IO (Either Text [(String, String)])
applySecretFileIndirection :: [(String, String)] -> IO (Either Text [(String, String)])
applySecretFileIndirection [(String, String)]
envVars = do
    reads' <- ((String, String) -> IO (Either Text (String, String)))
-> [(String, String)] -> IO [Either Text (String, String)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (String, String) -> IO (Either Text (String, String))
forall {m :: * -> *}.
MonadUnliftIO m =>
(String, String) -> m (Either Text (String, String))
readOne [(String, String)]
fileVars
    let (readErrs, resolved) = partitionEithers reads'
    pure $ case conflicts <> readErrs of
        [] -> [(String, String)] -> Either Text [(String, String)]
forall a b. b -> Either a b
Right (((String, String) -> Bool)
-> [(String, String)] -> [(String, String)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((String, String) -> Bool) -> (String, String) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
isSecretFileVar (String -> Bool)
-> ((String, String) -> String) -> (String, String) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, String) -> String
forall a b. (a, b) -> a
fst) [(String, String)]
envVars [(String, String)] -> [(String, String)] -> [(String, String)]
forall a. Semigroup a => a -> a -> a
<> [(String, String)]
resolved)
        [Text]
errs -> Text -> Either Text [(String, String)]
forall a b. a -> Either a b
Left ([Text] -> Text
T.unlines [Text]
errs)
  where
    fileVars :: [(String, String)]
fileVars = ((String, String) -> Bool)
-> [(String, String)] -> [(String, String)]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> Bool
isSecretFileVar (String -> Bool)
-> ((String, String) -> String) -> (String, String) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, String) -> String
forall a b. (a, b) -> a
fst) [(String, String)]
envVars

    conflicts :: [Text]
conflicts =
        [ String -> Text
T.pack String
base Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" and " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" are both set: supply the secret through exactly one of them"
        | (String
name, String
_) <- [(String, String)]
fileVars
        , let base :: String
base = String -> String
baseVarOf String
name
        , Maybe String -> Bool
forall a. Maybe a -> Bool
isJust (String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
base [(String, String)]
envVars)
        ]

    readOne :: (String, String) -> m (Either Text (String, String))
readOne (String
name, String
path) = do
        outcome <- m ByteString -> m (Either IOException ByteString)
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either IOException a)
tryIO (String -> m ByteString
forall (m :: * -> *). MonadIO m => String -> m ByteString
readFileBS String
path)
        pure $ case outcome of
            Left IOException
err ->
                Text -> Either Text (String, String)
forall a b. a -> Either a b
Left (String -> Text
T.pack String
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" points at " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
path Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", which cannot be read: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (IOException -> String
forall e. Exception e => e -> String
displayException IOException
err))
            Right ByteString
bytes ->
                (String, String) -> Either Text (String, String)
forall a b. b -> Either a b
Right (String -> String
baseVarOf String
name, Text -> String
T.unpack ((Char -> Bool) -> Text -> Text
T.dropWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n') (ByteString -> Text
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 ByteString
bytes)))

    isSecretFileVar :: String -> Bool
isSecretFileVar String
name =
        let spelling :: Text
spelling = String -> Text
T.pack String
name
         in Text
"ECLUSE_" Text -> Text -> Bool
`T.isPrefixOf` Text
spelling Bool -> Bool -> Bool
&& (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> Text -> Bool
`T.isSuffixOf` Text
spelling) [Text]
secretFileSuffixes

    -- Total even though the callers only pass matched names: an unmatched name
    -- passes through rather than inventing a partial strip.
    baseVarOf :: String -> String
baseVarOf String
name = String -> (Text -> String) -> Maybe Text -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
name Text -> String
T.unpack (Text -> Text -> Maybe Text
T.stripSuffix Text
"_FILE" (String -> Text
T.pack String
name))

    -- The secret-typed keys, by their env-spelling tails; anything else keeps the
    -- strict no-secrets-in-config posture with no file-shaped side door.
    secretFileSuffixes :: [Text]
    secretFileSuffixes :: [Text]
secretFileSuffixes = (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_FILE") [Text]
secretEnvSpellings

{- | Locate and read the config document per the @ECLUSE_CONFIG@ semantics: the
bytes when a document exists (plus the path consulted), no bytes at an absent
default path (env + defaults alone boot a proxy), and a fail-loud message for an
explicit @ECLUSE_CONFIG@ that resolves to nothing -- a misconfiguration must never
silently boot without the document the operator pointed at. Any other read
failure (a permission error, a directory path) is a typed refusal too, naming the
path and the error but never the file contents. Shared by the boot
('withBootEnv') and @check-config@ ("Ecluse.CheckConfig"), so the two cannot
drift on the override semantics.
-}
readConfigDocument :: [(String, String)] -> IO (Either Text (Maybe ByteString, FilePath))
readConfigDocument :: [(String, String)] -> IO (Either Text (Maybe ByteString, String))
readConfigDocument [(String, String)]
envVars = do
    let explicitPath :: Maybe String
explicitPath = String -> Maybe String
nonBlankPath (String -> Maybe String) -> Maybe String -> Maybe String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"ECLUSE_CONFIG" [(String, String)]
envVars
        docPath :: String
docPath = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
defaultConfigPath Maybe String
explicitPath
    mDocBlob <- IO ByteString -> IO (Either IOException ByteString)
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either IOException a)
tryIO (String -> IO ByteString
BS.readFile String
docPath)
    pure $ case mDocBlob of
        Right ByteString
bytes -> (Maybe ByteString, String)
-> Either Text (Maybe ByteString, String)
forall a b. b -> Either a b
Right (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
bytes, String
docPath)
        Left IOException
err
            | IOException -> Bool
isDoesNotExistError IOException
err ->
                case Maybe String
explicitPath of
                    Maybe String
Nothing -> (Maybe ByteString, String)
-> Either Text (Maybe ByteString, String)
forall a b. b -> Either a b
Right (Maybe ByteString
forall a. Maybe a
Nothing, String
docPath)
                    Just String
path ->
                        Text -> Either Text (Maybe ByteString, String)
forall a b. a -> Either a b
Left
                            ( Text
"ECLUSE_CONFIG points at "
                                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
path
                                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", but no config document exists there; fix the path, or unset ECLUSE_CONFIG to use "
                                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
defaultConfigPath
                            )
            | Bool
otherwise ->
                Text -> Either Text (Maybe ByteString, String)
forall a b. a -> Either a b
Left
                    ( Text
"config document at "
                        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
docPath
                        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" cannot be read: "
                        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (IOException -> String
ioeGetErrorString IOException
err)
                    )

-- The shipped default; ECLUSE_CONFIG (non-blank) relocates it.
defaultConfigPath :: FilePath
defaultConfigPath :: String
defaultConfigPath = String
"/etc/ecluse/config.yaml"

nonBlankPath :: FilePath -> Maybe FilePath
nonBlankPath :: String -> Maybe String
nonBlankPath String
p = if Text -> Bool
T.null (Text -> Text
T.strip (String -> Text
T.pack String
p)) then Maybe String
forall a. Maybe a
Nothing else String -> Maybe String
forall a. a -> Maybe a
Just String
p

{- | Assemble the 'BootEnv' and run @action@ within it: load and validate the
configuration (failing fast on any error), apply the runtime posture, build the
logger, and bracket the telemetry substrate for the action's lifetime.
-}
withBootEnv :: (BootEnv -> IO ()) -> IO ()
withBootEnv :: (BootEnv -> IO ()) -> IO ()
withBootEnv BootEnv -> IO ()
action = do
    rawEnvVars <- IO [(String, String)]
getEnvironment
    envVars <- applySecretFileIndirection rawEnvVars >>= orExit id
    let ambient = [(String, String)] -> AmbientAws
ambientAwsFromEnv [(String, String)]
envVars
    (docBlob, docPath) <- readConfigDocument envVars >>= orExit id
    config <- orExit (T.unlines . map renderConfigError) (loadConfig envVars docBlob)
    let env = Config -> AppConfig
configApp Config
config
        observability = AppConfig -> ObservabilitySettings
cfgObservability AppConfig
env
        runtimeSettings = AppConfig -> RuntimeSettings
cfgRuntime AppConfig
env
    logEnv <- newLogEnv (obsLogFormat observability) (Environment "production")
    -- Resolve and apply the runtime posture before anything else spins up: this may
    -- exec the binary in place (same PID; see Ecluse.Rts) to enforce a heap
    -- ceiling, so nothing stateful must precede it beyond config and the logger.
    runtimePlan <-
        applyRuntimePosture (logBootInfo logEnv) (logBootWarning logEnv) (rtCores runtimeSettings) (rtMaxHeapBytes runtimeSettings)
    logBootInfo logEnv $ case docBlob of
        Just ByteString
_ -> Text
"Config document: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
docPath
        Maybe ByteString
Nothing -> Text
"Config document: none at " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
docPath Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (defaults and environment only)"
    -- The resolved configuration, one provenance line per key (secrets redacted),
    -- so the effective posture and where each value came from read straight from
    -- the boot log.
    traverse_ (logBootInfo logEnv) (resolvedKeyProvenance envVars docBlob)
    traverse_ (logBootWarning logEnv) (mountCollisionWarnings config)
    prepareTelemetryBoot (obsTelemetry observability) logEnv
    withTelemetry (obsTelemetry observability) logEnv $ \Telemetry
telemetry ->
        BootEnv -> IO ()
action
            BootEnv
                { beConfig :: AppConfig
beConfig = AppConfig
env
                , beAmbient :: AmbientAws
beAmbient = AmbientAws
ambient
                , beLogEnv :: LogEnv
beLogEnv = LogEnv
logEnv
                , beTelemetry :: Telemetry
beTelemetry = Telemetry
telemetry
                , beConfigFull :: Config
beConfigFull = Config
config
                , beRuntimePlan :: EffectiveRuntimePlan
beRuntimePlan = EffectiveRuntimePlan
runtimePlan
                }

{- Build the config-selected mirror queue from its plan and the memory plan's queue
depth: the durable AWS SQS backend, or the bounded in-memory backend. The depth is a
memory tenant, so it is allocated after the backend selection and parametrises only
this build (the SQS arm never spends it). The in-memory arm first emits the loud boot
warning ('mirrorQueuePlanWarning' -- it is non-durable / best-effort) through the
composition-root logger, then constructs the bounded queue with a drop callback that
logs each rate-limited cap-overflow drop at a warning. (A drop /metric/ hooks in
alongside the log once the @ecluse.mirror.*@ catalogue lands.) -}
buildMirrorQueue :: LogEnv -> Int -> MirrorQueuePlan -> IO MirrorQueue
buildMirrorQueue :: LogEnv -> Int -> MirrorQueuePlan -> IO MirrorQueue
buildMirrorQueue LogEnv
logEnv Int
memoryDepth MirrorQueuePlan
plan = do
    Maybe Text -> (Text -> IO ()) -> IO ()
forall (f :: * -> *) a.
Applicative f =>
Maybe a -> (a -> f ()) -> f ()
whenJust (MirrorQueuePlan -> Maybe Text
mirrorQueuePlanWarning MirrorQueuePlan
plan) (LogEnv -> Text -> IO ()
logBootWarning LogEnv
logEnv)
    case MirrorQueuePlan
plan of
        SqsBackend SqsConfig
sqsConfig -> LogEnv
-> (Text -> Either Text RegistryUrl) -> SqsConfig -> IO MirrorQueue
newSqsQueue LogEnv
logEnv Text -> Either Text RegistryUrl
mkRegistryUrl SqsConfig
sqsConfig
        MirrorQueuePlan
MemoryBackend ->
            MemoryQueueConfig -> (Int -> IO ()) -> IO MirrorQueue
newBoundedInMemoryQueue (Int -> MemoryQueueConfig
defaultMemoryQueueConfig Int
memoryDepth) (LogEnv -> Text -> IO ()
logBootWarning LogEnv
logEnv (Text -> IO ()) -> (Int -> Text) -> Int -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text
memoryQueueDropWarning)

{- Log one line at 'WarningS' through the composition-root 'LogEnv', tagged with this
module -- the plain-'IO' katip path the boot phase uses (it holds no @Handler@ reader),
the same shape "Ecluse.Runtime.Telemetry.Resolve" and "Ecluse.Core.Server.Pipeline.Internal" use. -}
logBootWarning :: LogEnv -> Text -> IO ()
logBootWarning :: LogEnv -> Text -> IO ()
logBootWarning LogEnv
logEnv Text
message =
    LogEnv
-> SimpleLogPayload -> Namespace -> KatipContextT IO () -> IO ()
forall c (m :: * -> *) a.
LogItem c =>
LogEnv -> c -> Namespace -> KatipContextT m a -> m a
runKatipContextT LogEnv
logEnv (Text -> SimpleLogPayload
moduleField Text
"Ecluse") Namespace
forall a. Monoid a => a
mempty (Severity -> LogStr -> KatipContextT IO ()
forall (m :: * -> *).
(Applicative m, KatipContext m) =>
Severity -> LogStr -> m ()
logFM Severity
WarningS (Text -> LogStr
forall a. StringConv a Text => a -> LogStr
ls Text
message))

{- Log one line at 'InfoS' through the composition-root 'LogEnv', the same plain-'IO'
katip path 'logBootWarning' uses, for non-warning boot diagnostics. -}
logBootInfo :: LogEnv -> Text -> IO ()
logBootInfo :: LogEnv -> Text -> IO ()
logBootInfo LogEnv
logEnv Text
message =
    LogEnv
-> SimpleLogPayload -> Namespace -> KatipContextT IO () -> IO ()
forall c (m :: * -> *) a.
LogItem c =>
LogEnv -> c -> Namespace -> KatipContextT m a -> m a
runKatipContextT LogEnv
logEnv (Text -> SimpleLogPayload
moduleField Text
"Ecluse") Namespace
forall a. Monoid a => a
mempty (Severity -> LogStr -> KatipContextT IO ()
forall (m :: * -> *).
(Applicative m, KatipContext m) =>
Severity -> LogStr -> m ()
logFM Severity
InfoS (Text -> LogStr
forall a. StringConv a Text => a -> LogStr
ls Text
message))

{- Log every wired mount's resolved rule boot order ('renderBootOrder' -- the single
total order evaluation walks), one line per rule, so an operator can read the
effective policy resolution straight from the start-up log. A mount with no packument
deps (the unserved stub) contributes nothing. -}
logRuleBootOrder :: LogEnv -> [MountBinding] -> IO ()
logRuleBootOrder :: LogEnv -> [MountBinding] -> IO ()
logRuleBootOrder LogEnv
logEnv = (MountBinding -> IO ()) -> [MountBinding] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ MountBinding -> IO ()
logMount
  where
    logMount :: MountBinding -> IO ()
logMount MountBinding
binding = do
        let deps :: PackumentDeps
deps = MountBinding -> PackumentDeps
bindingPackumentDeps MountBinding
binding
        let label :: Text
label = Text -> [Text] -> Text
T.intercalate Text
"/" (NonEmpty Text -> [Text]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (MountBinding -> NonEmpty Text
bindingPrefix MountBinding
binding))
        LogEnv -> Text -> IO ()
logBootInfo LogEnv
logEnv (Text
"rule boot order for mount " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
label Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":")
        (Text -> IO ()) -> [Text] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (LogEnv -> Text -> IO ()
logBootInfo LogEnv
logEnv) ([PreparedRule] -> [Text]
renderBootOrder (PackumentDeps -> [PreparedRule]
pdRules PackumentDeps
deps))

{- | Raised to abort start-up after a boot phase has reported its aggregated
failure to stderr. A distinct type -- rather than a bare 'exitFailure' -- so the
abort is observable in a test without the process actually exiting; uncaught, it
propagates to 'main' and the runtime exits non-zero, the operator-facing fail-fast.
-}
data BootAborted = BootAborted
    deriving stock (BootAborted -> BootAborted -> Bool
(BootAborted -> BootAborted -> Bool)
-> (BootAborted -> BootAborted -> Bool) -> Eq BootAborted
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BootAborted -> BootAborted -> Bool
== :: BootAborted -> BootAborted -> Bool
$c/= :: BootAborted -> BootAborted -> Bool
/= :: BootAborted -> BootAborted -> Bool
Eq, Int -> BootAborted -> String -> String
[BootAborted] -> String -> String
BootAborted -> String
(Int -> BootAborted -> String -> String)
-> (BootAborted -> String)
-> ([BootAborted] -> String -> String)
-> Show BootAborted
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> BootAborted -> String -> String
showsPrec :: Int -> BootAborted -> String -> String
$cshow :: BootAborted -> String
show :: BootAborted -> String
$cshowList :: [BootAborted] -> String -> String
showList :: [BootAborted] -> String -> String
Show)

instance Exception BootAborted

{- Report the rendered failure to stderr and abort the boot when a phase fails,
otherwise yield its value. The aggregated failure block is written so an operator
sees every problem from a single failed launch, then 'BootAborted' unwinds to
'main'. -}
orExit :: (e -> Text) -> Either e a -> IO a
orExit :: forall e a. (e -> Text) -> Either e a -> IO a
orExit e -> Text
render = \case
    Right a
a -> a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
    Left e
err -> Handle -> Text -> IO ()
TIO.hPutStrLn Handle
stderr (e -> Text
render e
err) IO () -> IO a -> IO a
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> BootAborted -> IO a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO BootAborted
BootAborted

{- Prepare the telemetry substrate before the SDK initialises: when enabled, resolve
the identity, normalise the @OTEL_*@ environment the SDK reads, and install the
throttled export-error handler ("Ecluse.Runtime.Telemetry.Resolve.prepareTelemetry"). A no-op
when telemetry is off, so an unset @ECLUSE_OBSERVABILITY__TELEMETRY@ reads no process environment and
configures nothing. -}
prepareTelemetryBoot :: TelemetrySwitch -> LogEnv -> IO ()
prepareTelemetryBoot :: TelemetrySwitch -> LogEnv -> IO ()
prepareTelemetryBoot TelemetrySwitch
switch LogEnv
logEnv = case TelemetrySwitch
switch of
    TelemetrySwitch
TelemetryOff -> IO ()
forall (f :: * -> *). Applicative f => f ()
pass
    TelemetrySwitch
TelemetryOn -> do
        environment <- IO [(String, String)]
getEnvironment
        prepareTelemetry logEnv environment