{- | Écluse: a supply-chain policy proxy for package registries.

Écluse (package @ecluse@) sits between consumers (developers, CI) and a package
registry, applying a configurable resilience policy before any dependency reaches
a build, without hosting packages itself. The name is French for a canal lock: a
chamber whose gates never open at once. Every dependency is held and cleared
through that controlled passage before it is admitted to a build.

The goal is __resilience, not malware detection__: shrink the blast radius of a
bad publish (a hijacked maintainer account, a race-to-publish, a typosquat)
rather than promise to recognise malice. Écluse is __not a registry__: storage is
delegated to whatever backend the operator runs (AWS CodeArtifact, GCP Artifact
Registry), and Écluse only governs what may be fetched from, and mirrored to,
those backends. npm is the first ecosystem; the domain model is ecosystem-agnostic
so PyPI and RubyGems can follow.

== How a request is cleared

Écluse speaks a registry's native protocol across three read-path registries (the
client's, a /private upstream/ of already-vetted packages, and the /public/
registry), and the two request shapes use them differently:

* A __tarball__ request is gated for that one version: a private-upstream hit is
  streamed unfiltered (already vetted); on a miss, the proxy fetches the
  version's public metadata, evaluates the rules, and either streams it from
  public __and enqueues an asynchronous mirror job__ or returns a denial.
* A __packument__ (metadata) request is a /merge/: the private and public
  upstreams are fetched in parallel, public versions are filtered by the rules
  while private versions are trusted, and the two are combined into one document
  (private wins a version collision, an integrity divergence is flagged as a
  supply-chain signal, and @latest@ is repointed to the newest survivor).

Two properties run through both shapes: the rules engine is __deny by default__ (a
version is admitted only if some rule allows it and none denies it), and
__mirroring is demand-driven__, so only versions actually pulled are mirrored,
never on the request's critical path.

== How the code is organised

Écluse is a __functional core with effects at the edges__: the policy and
protocol logic is pure and trivially testable, and @IO@ is confined to a thin
shell. Swappable backends sit behind /handles/ (records of functions chosen at a
single composition root), so a new cloud or a new ecosystem is an added
implementation behind an existing handle, not a structural change.

The library's vocabulary, roughly from the pure core outward:

* __Domain model__: "Ecluse.Core.Package" (the ecosystem-agnostic package vocabulary
  the rules reason over), "Ecluse.Core.Version" (version identity and per-ecosystem
  ordering), and "Ecluse.Core.Ecosystem" (the ecosystem tag the rest dispatches on).
* __Policy__: "Ecluse.Core.Rules" (deny-by-default evaluation) over the rule types
  in "Ecluse.Core.Rules.Types".
* __Protocol boundary__: "Ecluse.Core.Registry" (the registry-protocol handle),
  "Ecluse.Core.Registry.Npm.Wire" and "Ecluse.Core.Registry.Npm.Project" (the lenient npm
  wire decoders and their projection onto the domain model),
  "Ecluse.Core.Registry.Npm.Route" (the npm path grammar), and "Ecluse.Core.Server.Route"
  (the shared serve-action 'Route' set and the injected route classifier).
* __Cloud handles__: "Ecluse.Core.Credential" (minting the mirror-target write token)
  and "Ecluse.Core.Queue" (the durable mirror-job hand-off to the worker).
* __Mirror worker__: "Ecluse.Core.Worker" (the supervised consume loop that fetches,
  verifies against the job's integrity digest, and publishes an approved artifact).

'run' is the entry point the @ecluse@ executable invokes (see "Main"). It lives
in the library, not in @app\/Main.hs@, so the composition root is a single
importable unit and @app\/Main.hs@ stays a thin shell that only calls it.

== Further reading

@docs\/architecture.md@ is the systems-design index: the vision, the end-to-end
request lifecycle, and a map to the per-concern design documents. @CONTRIBUTING.md@
covers the codebase layout and testing strategy, and @STYLE.md@ the coding and
documentation conventions.
-}
module Ecluse.Boot (
    BootEnv (..),
    withBootEnv,
    BootAborted (..),
    orExit,
    logBootWarning,
    logBootInfo,
    logRuleBootOrder,
    buildMirrorQueue,
) where

import Data.ByteString qualified as BS
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 (isDoesNotExistError)
import UnliftIO (throwIO, tryJust)

import Ecluse.Composition (
    MirrorQueuePlan (MemoryBackend, SqsBackend),
    memoryQueueDropWarning,
    mirrorQueuePlanWarning,
 )
import Ecluse.Config (
    AppConfig (cfgCores, cfgLogFormat, cfgMaxHeapBytes, cfgTelemetry),
    Config (configApp),
    loadConfig,
    renderConfigError,
 )
import Ecluse.Core.Queue (MirrorQueue, newBoundedInMemoryQueue)
import Ecluse.Core.Queue.Sqs (newSqsQueue)
import Ecluse.Core.Rules (renderBootOrder)
import Ecluse.Core.Server.Context (PackumentDeps (pdRules))
import Ecluse.Log (moduleField, newLogEnv)
import Ecluse.Runtime (applyRuntimePosture)
import Ecluse.Server (MountBinding (bindingPackumentDeps, bindingPrefix))
import Ecluse.Telemetry (Telemetry, TelemetrySwitch (TelemetryOff, TelemetryOn), withTelemetry)
import Ecluse.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 -> LogEnv
beLogEnv :: LogEnv
    -- ^ The process structured-logging environment.
    , BootEnv -> Telemetry
beTelemetry :: Telemetry
    -- ^ The telemetry handle, inert unless @ECLUSE_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).
    -}
    }

{- | 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
    envVars <- IO [(String, String)]
getEnvironment
    mDocBlob <- tryJust (guard . isDoesNotExistError) (BS.readFile "/etc/ecluse/config.yaml")
    let docBlob = (() -> Maybe ByteString)
-> (ByteString -> Maybe ByteString)
-> Either () ByteString
-> Maybe ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe ByteString -> () -> Maybe ByteString
forall a b. a -> b -> a
const Maybe ByteString
forall a. Maybe a
Nothing) ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just Either () ByteString
mDocBlob
    config <- orExit (T.unlines . map renderConfigError) (loadConfig envVars docBlob)
    let env = Config -> AppConfig
configApp Config
config
    logEnv <- newLogEnv (cfgLogFormat env) (Environment "production")
    -- Resolve and apply the runtime posture before anything else spins up: this may
    -- exec the binary in place (same PID; see Ecluse.Runtime) to enforce a heap
    -- ceiling, so nothing stateful must precede it beyond config and the logger.
    applyRuntimePosture (logBootInfo logEnv) (logBootWarning logEnv) (cfgCores env) (cfgMaxHeapBytes env)
    logBootInfo logEnv ("Loaded configuration: " <> show config)
    prepareTelemetryBoot (cfgTelemetry env) logEnv
    withTelemetry (cfgTelemetry env) logEnv $ \Telemetry
telemetry ->
        BootEnv -> IO ()
action
            BootEnv
                { beConfig :: AppConfig
beConfig = AppConfig
env
                , beLogEnv :: LogEnv
beLogEnv = LogEnv
logEnv
                , beTelemetry :: Telemetry
beTelemetry = Telemetry
telemetry
                , beConfigFull :: Config
beConfigFull = Config
config
                }

{- Build the config-selected mirror queue from its plan: the durable AWS SQS backend,
or the bounded in-memory backend. 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 -> MirrorQueuePlan -> IO MirrorQueue
buildMirrorQueue :: LogEnv -> MirrorQueuePlan -> IO MirrorQueue
buildMirrorQueue LogEnv
logEnv 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 -> SqsConfig -> IO MirrorQueue
newSqsQueue SqsConfig
sqsConfig
        MemoryBackend MemoryQueueConfig
memoryConfig ->
            MemoryQueueConfig -> (Int -> IO ()) -> IO MirrorQueue
newBoundedInMemoryQueue MemoryQueueConfig
memoryConfig (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.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 = Maybe PackumentDeps -> (PackumentDeps -> IO ()) -> IO ()
forall (f :: * -> *) a.
Applicative f =>
Maybe a -> (a -> f ()) -> f ()
whenJust (MountBinding -> Maybe PackumentDeps
bindingPackumentDeps MountBinding
binding) ((PackumentDeps -> IO ()) -> IO ())
-> (PackumentDeps -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \PackumentDeps
deps -> do
        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))

{- The process-global mirror-write credential provider stored in 'Env' for the
worker, selected by the configured provider backend
('Ecluse.Config.'): the static token or the
CodeArtifact mint. In the common case there is a single provider; the no-backend
placeholder only holds the slot when the selected provider was not built -- a mount
that references it has already failed the boot-time credential check by this point,
so the worker (the slot's only consumer) never reaches the placeholder. -}

{- | 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 -> ShowS
[BootAborted] -> ShowS
BootAborted -> String
(Int -> BootAborted -> ShowS)
-> (BootAborted -> String)
-> ([BootAborted] -> ShowS)
-> Show BootAborted
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BootAborted -> ShowS
showsPrec :: Int -> BootAborted -> ShowS
$cshow :: BootAborted -> String
show :: BootAborted -> String
$cshowList :: [BootAborted] -> ShowS
showList :: [BootAborted] -> ShowS
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.Telemetry.Resolve.prepareTelemetry"). A no-op
when telemetry is off, so an unset @ECLUSE_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