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

{- | @ecluse check-config@: validate the configuration exactly as a boot would and
print the whole resolved posture, without starting anything.

The subcommand runs the same resolution chain the proxy boots through --
'Ecluse.Config.loadConfig', the runtime plan, the admission and pool sizings, the
memory plan, and the mirror-queue selection -- but applies none of it: no socket
opens, no capability count changes, no re-exec, no cloud call. Failures print the
same aggregated reports a boot would log and exit @2@; a valid configuration
prints per-key provenance and every resolver's decision lines and exits @0@, so an
operator (or a CI step) reads exactly what a boot would do before running one.
-}
module Ecluse.CheckConfig (runCheckConfig) where

import Data.Text.IO qualified as TIO
import System.Environment (getEnvironment)
import System.Exit (ExitCode (ExitFailure))

import Ecluse.Boot (applySecretFileIndirection, readConfigDocument)
import Ecluse.Composition (validateComposition)
import Ecluse.Composition.BootError (BootError (MemoryPlanOverrideUnsafe), renderBootError)
import Ecluse.Composition.MemoryPlan (
    MemoryPlan (mpDegradations, mpOverrideViolations, mpQueueMemoryMaxDepth),
 )
import Ecluse.Composition.MirrorQueue (
    MirrorQueuePlan (MemoryBackend, SqsBackend),
    MirrorRuntimePlan (MirrorWith, NoMirroring),
    memoryQueueBootWarning,
    planMirrorRuntime,
 )
import Ecluse.Composition.Plan (resolveMemoryPlanFor)
import Ecluse.Composition.Sizing (
    openFileSoftLimit,
    resolvePrivateConnections,
    resolvePublicConnections,
 )
import Ecluse.Config (
    AppConfig (cfgRuntime),
    Config (configApp),
    RuntimeSettings (rtCores, rtMaxHeapBytes, rtPrivateConnectionsPerHost, rtPublicConnectionsPerHost),
    loadConfig,
    mountCollisionWarnings,
    mountPostureLines,
    renderConfigError,
    resolvedKeyProvenance,
 )
import Ecluse.Config.Ambient (ambientAwsFromEnv)
import Ecluse.Rts (
    appliedRuntimePlan,
    currentRtsPosture,
    readCgroupLimits,
    renderEffectivePosture,
    resolveRuntimePlan,
 )
import Ecluse.Runtime.Queue.Sqs (SqsConfig (sqsQueueUrl, sqsRegion))

-- | Validate, print the resolved posture, and exit: @0@ valid, @2@ refused.
runCheckConfig :: IO ()
runCheckConfig :: IO ()
runCheckConfig = do
    rawEnvVars <- IO [(FilePath, FilePath)]
getEnvironment
    envVars <- applySecretFileIndirection rawEnvVars >>= either refuseWith pure
    docE <- readConfigDocument envVars
    (docBlob, docPath) <- either refuseWith pure docE
    TIO.putStrLn $ case docBlob of
        Just ByteString
_ -> Text
"config document: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
forall a. ToText a => a -> Text
toText FilePath
docPath
        Maybe ByteString
Nothing -> Text
"config document: none at " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
forall a. ToText a => a -> Text
toText FilePath
docPath Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (defaults and environment only)"
    config <- either (refuseWith . renderErrs renderConfigError) pure (loadConfig envVars docBlob)
    -- The pure structural half of the composition (missing adapters, publish
    -- policy): the same validateComposition the boot's composeBindings runs, so a
    -- configuration the proxy would refuse can never validate here.
    case validateComposition config of
        [] -> IO ()
forall (f :: * -> *). Applicative f => f ()
pass
        [BootError]
errs -> Text -> IO ()
forall a. Text -> IO a
refuseWith ((BootError -> Text) -> [BootError] -> Text
forall e. (e -> Text) -> [e] -> Text
renderErrs BootError -> Text
renderBootError [BootError]
errs)
    let env = Config -> AppConfig
configApp Config
config
        runtimeSettings = AppConfig -> RuntimeSettings
cfgRuntime AppConfig
env
    -- The pure half of the posture chain: resolved exactly as a boot would, never
    -- applied (no capability change, no re-exec). The sizings compute from the
    -- plan a successful application would produce ('appliedRuntimePlan'): the
    -- checker's own process posture says nothing about the boot it is checking.
    rts <- currentRtsPosture
    cgroup <- readCgroupLimits
    fdLimit <- openFileSoftLimit
    -- Backend selection precedes the plan, exactly as a boot orders it: the
    -- queue tenant exists only when the memory backend was selected.
    runtimePlan <-
        either
            (refuseWith . renderErrs renderBootError)
            pure
            (planMirrorRuntime (ambientAwsFromEnv envVars) config)
    let plan = Maybe Int -> Maybe Int -> CgroupLimits -> RtsPosture -> RuntimePlan
resolveRuntimePlan (RuntimeSettings -> Maybe Int
rtCores RuntimeSettings
runtimeSettings) (RuntimeSettings -> Maybe Int
rtMaxHeapBytes RuntimeSettings
runtimeSettings) CgroupLimits
cgroup RtsPosture
rts
        effective = CgroupLimits -> RuntimePlan -> RtsPosture -> EffectiveRuntimePlan
appliedRuntimePlan CgroupLimits
cgroup RuntimePlan
plan RtsPosture
rts
        (_, privateLine) = resolvePrivateConnections (rtPrivateConnectionsPerHost runtimeSettings) fdLimit
        (_, publicLine) = resolvePublicConnections (rtPublicConnectionsPerHost runtimeSettings) fdLimit
        (memoryPlan, memoryPlanLines) = resolveMemoryPlanFor env effective runtimePlan
    traverse_ TIO.putStrLn $
        concat
            [ resolvedKeyProvenance envVars docBlob
            , renderEffectivePosture effective
            , [privateLine, publicLine]
            , memoryPlanLines
            , -- The shed ladder, printed exactly as the boot would warn it: a
              -- degraded-but-coherent plan validates (the plan is made safe by
              -- shrinking); only an explicit override refuses below.
              map ("warning: " <>) (mpDegradations memoryPlan)
            , mirrorRuntimeLines (mpQueueMemoryMaxDepth memoryPlan) runtimePlan
            , mountPostureLines config
            , map ("warning: " <>) (mountCollisionWarnings config)
            ]
    unless (null (mpOverrideViolations memoryPlan)) $
        refuseWith (renderErrs renderBootError [MemoryPlanOverrideUnsafe (mpOverrideViolations memoryPlan)])
    TIO.putStrLn "configuration: valid"
    exitSuccess
  where
    renderErrs :: (e -> Text) -> [e] -> Text
    renderErrs :: forall e. (e -> Text) -> [e] -> Text
renderErrs e -> Text
render = [Text] -> Text
forall t. IsText t "unlines" => [t] -> t
unlines ([Text] -> Text) -> ([e] -> [Text]) -> [e] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (e -> Text) -> [e] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map e -> Text
render

    refuseWith :: Text -> IO a
    refuseWith :: forall a. Text -> IO a
refuseWith Text
message = do
        Handle -> Text -> IO ()
TIO.hPutStrLn Handle
stderr Text
message
        Handle -> Text -> IO ()
TIO.hPutStrLn Handle
stderr Text
"configuration: refused"
        ExitCode -> IO a
forall (m :: * -> *) a. MonadIO m => ExitCode -> m a
exitWith (Int -> ExitCode
ExitFailure Int
2)

    mirrorRuntimeLines :: Int -> MirrorRuntimePlan -> [Text]
    mirrorRuntimeLines :: Int -> MirrorRuntimePlan -> [Text]
mirrorRuntimeLines Int
memoryDepth = \case
        MirrorRuntimePlan
NoMirroring -> [Text
"mirror runtime: disabled (no mount mirrors; no queue is built and no worker starts)"]
        MirrorWith (SqsBackend SqsConfig
sqs) ->
            [Text
"mirror queue: sqs, " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SqsConfig -> Text
sqsQueueUrl SqsConfig
sqs Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (region " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SqsConfig -> Text
sqsRegion SqsConfig
sqs Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"]
        MirrorWith MirrorQueuePlan
MemoryBackend ->
            [ Text
"mirror queue: in-memory (depth " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
memoryDepth Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
            , Text
"warning: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
memoryQueueBootWarning
            ]