-- SPDX-FileCopyrightText: 2026 Alexandra de Wit
--
-- SPDX-License-Identifier: MIT
{-# LANGUAGE OverloadedStrings #-}

module Ecluse.Config (
    Config (..),
    AppConfig (..),
    ServerSettings (..),
    QueueSettings (..),
    LimitsSettings (..),
    CacheSettings (..),
    IntegritySettings (..),
    EgressSettings (..),
    AdvisoriesSettings (..),
    RuntimeSettings (..),
    ObservabilitySettings (..),
    MountMap,
    Mount (..),
    MountRegistries (..),
    MountMode (..),
    MirroredLegs (..),
    regPrivateUpstream,
    regMirrorTarget,
    MirrorTarget (..),
    MirrorCredential (..),
    MountConfig (..),
    Url (..),
    mkUrl,
    unUrl,
    RulePatch (..),
    RuleEntry (..),
    RulePolicy (..),
    PolicyError (..),
    renderPolicyError,
    emptyPolicy,
    defaultPolicy,
    ConfigError (..),
    renderConfigError,
    loadConfig,
    mountCollisionWarnings,
    mountPostureLines,
    resolvedKeyProvenance,
) where

import Data.Aeson (Result (..), Value (..), encode, fromJSON)
import Data.Aeson.Key qualified as Key
import Data.Aeson.KeyMap qualified as KeyMap
import Data.Aeson.Types (parseEither, withObject, (.!=), (.:?))
import Data.ByteString.Lazy qualified as LBS
import Data.Map.Strict qualified as Map
import Data.Set qualified as Set
import Data.Text qualified as T
import Data.Yaml (decodeEither')

import Ecluse.Config.Aeson ()
import Ecluse.Config.DefaultConfig (defaultConfigBytes)
import Ecluse.Config.MirrorCredential (resolveMirrorCredential)
import Ecluse.Config.Resolve (buildEnvAst, deepMerge, secretLeafKeys)
import Ecluse.Config.Rule
import Ecluse.Config.Types
import Ecluse.Core.Ecosystem (Ecosystem, ecosystemName, parseEcosystem)
import Ecluse.Core.Rules.Types (PrecededRule)
import Ecluse.Core.Security.Egress (RegistryUrl, registryUrlText)

{- HLINT ignore defaultPolicy "Avoid restricted function" -}
defaultPolicy :: RulePolicy
defaultPolicy :: RulePolicy
defaultPolicy =
    case StrictByteString -> Either ParseException Value
forall a. FromJSON a => StrictByteString -> Either ParseException a
decodeEither' StrictByteString
defaultConfigBytes of
        Right Value
ast -> case Value -> Either String RulePatch
parseRulesPatch Value
ast of
            Right RulePatch
globalRules -> ([PolicyError] -> RulePolicy)
-> (RulePolicy -> RulePolicy)
-> Either [PolicyError] RulePolicy
-> RulePolicy
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> RulePolicy
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> RulePolicy)
-> ([PolicyError] -> Text) -> [PolicyError] -> RulePolicy
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PolicyError] -> Text
forall b a. (Show a, IsString b) => a -> b
show) RulePolicy -> RulePolicy
forall a. a -> a
id (RulePolicy -> RulePatch -> Either [PolicyError] RulePolicy
resolvePolicy RulePolicy
emptyPolicy RulePatch
globalRules)
            Left String
e -> Text -> RulePolicy
forall a t. (HasCallStack, IsText t) => t -> a
error (Text
"Invalid default policy JSON: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
e)
        Left ParseException
e -> Text -> RulePolicy
forall a t. (HasCallStack, IsText t) => t -> a
error (Text
"Invalid default policy YAML: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ParseException -> Text
forall b a. (Show a, IsString b) => a -> b
show ParseException
e)

{- | Load the full configuration: defaults, the optional operator document, and the
environment overlay, merged strongest-last, then parsed, activated, and resolved.

A mount is __active__ when the operator overlay (the document or the
@ECLUSE_MOUNTS__*@ environment variables) declares any key under
@mounts.\<ecosystem\>@; the mounts shipped in @config\/default.yaml@ are dormant
per-ecosystem templates until then. The @enabled@ key is itself a declaration, so
@enabled: true@ alone activates a mount against its template public upstream (the
serve-only pure public gate), and @enabled: false@ switches a mount off without
removing its other keys.

Whether an active mount __mirrors__ is derived from its declared endpoints: a
@mirrorTarget@ makes it mirrored (its private upstream is then required, so the
mirror can be read back: 'MountMissingPrivateUpstream'), and an absent one makes it
serve-only (never writing anywhere; a mirror-write setting left behind is refused
per key as 'MirrorSettingWithoutWrite' rather than silently ignored). The boot log
names each mount's resolved posture, so an unintentionally dropped @mirrorTarget@
is visible at start-up.
-}
loadConfig :: [(String, String)] -> Maybe ByteString -> Either [ConfigError] Config
loadConfig :: [(String, String)]
-> Maybe StrictByteString -> Either [ConfigError] Config
loadConfig [(String, String)]
envVars Maybe StrictByteString
mBytes = do
    defaultAst <- Either [ConfigError] Value
parseDefaultAst
    docAst <- parseDocumentAst mBytes
    let overridesAst = Value -> Value -> Value
deepMerge Value
docAst ([(String, String)] -> Value
buildEnvAst [(String, String)]
envVars)
    let merged = Value -> Value -> Value
deepMerge Value
defaultAst Value
overridesAst
    parsed <- parseAppConfig merged
    active <- declaredMounts overridesAst
    let declared = Map Ecosystem MountConfig
-> Set Ecosystem -> Map Ecosystem MountConfig
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys (AppConfig -> Map Ecosystem MountConfig
cfgMounts AppConfig
parsed) Set Ecosystem
active
        -- enabled: false switches a declared mount off; anything else declared serves.
        served = (MountConfig -> Bool)
-> Map Ecosystem MountConfig -> Map Ecosystem MountConfig
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (\MountConfig
mcfg -> MountConfig -> Maybe Bool
mntEnabled MountConfig
mcfg Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False) Map Ecosystem MountConfig
declared
        appConfig = AppConfig
parsed{cfgMounts = served}
    -- Any served mount needs the proxy's own client-facing base URL: served
    -- tarball URLs are rewritten against it, and without one every real install
    -- fails client by client instead of loudly here. Aggregated with the mount
    -- resolution so one load reports both classes at once.
    let publicUrlErrs = [ConfigError
PublicUrlRequired | Bool -> Bool
not (Map Ecosystem MountConfig -> Bool
forall k a. Map k a -> Bool
Map.null Map Ecosystem MountConfig
served), Maybe Url -> Bool
forall a. Maybe a -> Bool
isNothing (ServerSettings -> Maybe Url
srvPublicUrl (AppConfig -> ServerSettings
cfgServer AppConfig
appConfig))]
    globalPolicy <- resolveGlobalPolicy overridesAst
    mounts <- case (publicUrlErrs, resolveMounts globalPolicy appConfig) of
        ([], Either [ConfigError] MountMap
resolved) -> Either [ConfigError] MountMap
resolved
        ([ConfigError]
errs, Either [ConfigError] MountMap
resolved) -> [ConfigError] -> Either [ConfigError] MountMap
forall a b. a -> Either a b
Left ([ConfigError]
errs [ConfigError] -> [ConfigError] -> [ConfigError]
forall a. Semigroup a => a -> a -> a
<> [ConfigError] -> Either [ConfigError] MountMap -> [ConfigError]
forall a b. a -> Either a b -> a
fromLeft [] Either [ConfigError] MountMap
resolved)
    Right (Config appConfig mounts)

{- | The ecosystems the operator overlay declares under @mounts@: the activation
set. Only keys the operator wrote count; the merged defaults never activate a
mount. An unknown ecosystem key is unreachable here (parsing the merged document
has already rejected it) but is still refused totally rather than assumed away.
-}
declaredMounts :: Value -> Either [ConfigError] (Set Ecosystem)
declaredMounts :: Value -> Either [ConfigError] (Set Ecosystem)
declaredMounts Value
overridesAst = [Ecosystem] -> Set Ecosystem
forall a. Ord a => [a] -> Set a
Set.fromList ([Ecosystem] -> Set Ecosystem)
-> Either [ConfigError] [Ecosystem]
-> Either [ConfigError] (Set Ecosystem)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Key -> Either [ConfigError] Ecosystem)
-> [Key] -> Either [ConfigError] [Ecosystem]
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 Key -> Either [ConfigError] Ecosystem
parseKey (Value -> [Key]
mountKeysOf Value
overridesAst)
  where
    parseKey :: Key -> Either [ConfigError] Ecosystem
parseKey Key
k = case Text -> Maybe Ecosystem
parseEcosystem (Key -> Text
Key.toText Key
k) of
        Just Ecosystem
eco -> Ecosystem -> Either [ConfigError] Ecosystem
forall a b. b -> Either a b
Right Ecosystem
eco
        Maybe Ecosystem
Nothing -> [ConfigError] -> Either [ConfigError] Ecosystem
forall a b. a -> Either a b
Left [Text -> ConfigError
ParseError (Text
"Invalid ecosystem: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Key -> Text
Key.toText Key
k)]

mountKeysOf :: Value -> [Key.Key]
mountKeysOf :: Value -> [Key]
mountKeysOf (Object Object
o) = case Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup Key
"mounts" Object
o of
    Just (Object Object
mounts) -> Object -> [Key]
forall v. KeyMap v -> [Key]
KeyMap.keys Object
mounts
    Maybe Value
_ -> []
mountKeysOf Value
_ = []

parseDefaultAst :: Either [ConfigError] Value
parseDefaultAst :: Either [ConfigError] Value
parseDefaultAst = case StrictByteString -> Either ParseException Value
forall a. FromJSON a => StrictByteString -> Either ParseException a
decodeEither' StrictByteString
defaultConfigBytes of
    Right Value
ast -> Value -> Either [ConfigError] Value
forall a b. b -> Either a b
Right Value
ast
    Left ParseException
err -> [ConfigError] -> Either [ConfigError] Value
forall a b. a -> Either a b
Left [Text -> ConfigError
ParseError (Text
"config/default.yaml is invalid YAML: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (ParseException -> String
forall b a. (Show a, IsString b) => a -> b
show ParseException
err))]

parseDocumentAst :: Maybe ByteString -> Either [ConfigError] Value
parseDocumentAst :: Maybe StrictByteString -> Either [ConfigError] Value
parseDocumentAst = \case
    Maybe StrictByteString
Nothing -> Value -> Either [ConfigError] Value
forall a b. b -> Either a b
Right (Object -> Value
Object Object
forall a. Monoid a => a
mempty)
    Just StrictByteString
bytes -> case StrictByteString -> Either ParseException Value
forall a. FromJSON a => StrictByteString -> Either ParseException a
decodeEither' StrictByteString
bytes of
        Right Value
ast -> Value -> Either [ConfigError] Value
forall a b. b -> Either a b
Right Value
ast
        Left ParseException
err -> [ConfigError] -> Either [ConfigError] Value
forall a b. a -> Either a b
Left [Text -> ConfigError
ParseError (Text
"the config document is invalid YAML: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (ParseException -> String
forall b a. (Show a, IsString b) => a -> b
show ParseException
err))]

parseAppConfig :: Value -> Either [ConfigError] AppConfig
parseAppConfig :: Value -> Either [ConfigError] AppConfig
parseAppConfig Value
merged = case Value -> Result AppConfig
forall a. FromJSON a => Value -> Result a
fromJSON Value
merged of
    Success AppConfig
appConfig -> AppConfig -> Either [ConfigError] AppConfig
forall a b. b -> Either a b
Right AppConfig
appConfig
    Error String
err -> [ConfigError] -> Either [ConfigError] AppConfig
forall a b. a -> Either a b
Left [Text -> ConfigError
ParseError (Text
"Configuration parse error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
err)]

parseRulesPatch :: Value -> Either String RulePatch
parseRulesPatch :: Value -> Either String RulePatch
parseRulesPatch = (Value -> Parser RulePatch) -> Value -> Either String RulePatch
forall a b. (a -> Parser b) -> a -> Either String b
parseEither (String -> (Object -> Parser RulePatch) -> Value -> Parser RulePatch
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Config" (\Object
obj -> Object
obj Object -> Key -> Parser (Maybe RulePatch)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"rules" Parser (Maybe RulePatch) -> RulePatch -> Parser RulePatch
forall a. Parser (Maybe a) -> a -> Parser a
.!= Map Text RuleEntry -> RulePatch
RulePatch Map Text RuleEntry
forall k a. Map k a
Map.empty))

resolveGlobalPolicy :: Value -> Either [ConfigError] RulePolicy
resolveGlobalPolicy :: Value -> Either [ConfigError] RulePolicy
resolveGlobalPolicy Value
overridesAst = do
    globalRulePatch <- case Value -> Either String RulePatch
parseRulesPatch Value
overridesAst of
        Right RulePatch
r -> RulePatch -> Either [ConfigError] RulePatch
forall a b. b -> Either a b
Right RulePatch
r
        Left String
err -> [ConfigError] -> Either [ConfigError] RulePatch
forall a b. a -> Either a b
Left [Text -> ConfigError
ParseError (Text
"Rules parse error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
err)]
    first (pure . PolicyErrors) (resolvePolicy defaultPolicy globalRulePatch)

{- | Resolve every active mount into its served 'Mount', aggregating failures so
one load reports each incomplete mount rather than only the first. The mode is
derived from the declared endpoints: a @mirrorTarget@ makes the mount mirrored
(private upstream required), an absent one makes it serve-only.
-}
resolveMounts :: RulePolicy -> AppConfig -> Either [ConfigError] MountMap
resolveMounts :: RulePolicy -> AppConfig -> Either [ConfigError] MountMap
resolveMounts RulePolicy
globalPolicy AppConfig
appConfig =
    case [Either [ConfigError] (Ecosystem, Mount)]
-> ([[ConfigError]], [(Ecosystem, Mount)])
forall a b. [Either a b] -> ([a], [b])
partitionEithers (((Ecosystem, MountConfig)
 -> Either [ConfigError] (Ecosystem, Mount))
-> [(Ecosystem, MountConfig)]
-> [Either [ConfigError] (Ecosystem, Mount)]
forall a b. (a -> b) -> [a] -> [b]
map (Ecosystem, MountConfig) -> Either [ConfigError] (Ecosystem, Mount)
resolveOne (Map Ecosystem MountConfig -> [(Ecosystem, MountConfig)]
forall k a. Map k a -> [(k, a)]
Map.toAscList (AppConfig -> Map Ecosystem MountConfig
cfgMounts AppConfig
appConfig))) of
        ([], [(Ecosystem, Mount)]
mounts) -> MountMap -> Either [ConfigError] MountMap
forall a b. b -> Either a b
Right ([(Ecosystem, Mount)] -> MountMap
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Ecosystem, Mount)]
mounts)
        ([[ConfigError]]
errs, [(Ecosystem, Mount)]
_) -> [ConfigError] -> Either [ConfigError] MountMap
forall a b. a -> Either a b
Left ([[ConfigError]] -> [ConfigError]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[ConfigError]]
errs)
  where
    resolveOne :: (Ecosystem, MountConfig) -> Either [ConfigError] (Ecosystem, Mount)
resolveOne (Ecosystem
eco, MountConfig
mcfg) = case (MountConfig -> Maybe RegistryUrl
mntMirrorTarget MountConfig
mcfg, MountConfig -> Maybe RegistryUrl
mntPrivateUpstream MountConfig
mcfg) of
        (Just RegistryUrl
mirrorTarget, Just RegistryUrl
privateUpstream) ->
            (Ecosystem
eco,) (Mount -> (Ecosystem, Mount))
-> Either [ConfigError] Mount
-> Either [ConfigError] (Ecosystem, Mount)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RulePolicy
-> Ecosystem
-> RegistryUrl
-> RegistryUrl
-> MountConfig
-> Either [ConfigError] Mount
resolveMirrored RulePolicy
globalPolicy Ecosystem
eco RegistryUrl
privateUpstream RegistryUrl
mirrorTarget MountConfig
mcfg
        -- A mirrored mount must be able to read its mirror back.
        (Just RegistryUrl
_, Maybe RegistryUrl
Nothing) -> [ConfigError] -> Either [ConfigError] (Ecosystem, Mount)
forall a b. a -> Either a b
Left [Ecosystem -> ConfigError
MountMissingPrivateUpstream Ecosystem
eco]
        (Maybe RegistryUrl
Nothing, Maybe RegistryUrl
mPrivate) -> case MountConfig -> [Text]
forall {a}. IsString a => MountConfig -> [a]
writeOnlySettings MountConfig
mcfg of
            [] -> (Ecosystem
eco,) (Mount -> (Ecosystem, Mount))
-> Either [ConfigError] Mount
-> Either [ConfigError] (Ecosystem, Mount)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RulePolicy
-> Ecosystem
-> Maybe RegistryUrl
-> MountConfig
-> Either [ConfigError] Mount
resolveServeOnly RulePolicy
globalPolicy Ecosystem
eco Maybe RegistryUrl
mPrivate MountConfig
mcfg
            -- A write credential or token duration on a mount that never writes
            -- signals a misunderstanding; refuse each offending key rather than
            -- silently ignoring it.
            [Text]
offending -> [ConfigError] -> Either [ConfigError] (Ecosystem, Mount)
forall a b. a -> Either a b
Left ((Text -> ConfigError) -> [Text] -> [ConfigError]
forall a b. (a -> b) -> [a] -> [b]
map (Ecosystem -> Text -> ConfigError
MirrorSettingWithoutWrite Ecosystem
eco) [Text]
offending)

    writeOnlySettings :: MountConfig -> [a]
writeOnlySettings MountConfig
mcfg =
        [a
"mirrorTargetToken" | Maybe Secret -> Bool
forall a. Maybe a -> Bool
isJust (MountConfig -> Maybe Secret
mntMirrorTargetToken MountConfig
mcfg)]
            [a] -> [a] -> [a]
forall a. Semigroup a => a -> a -> a
<> [a
"mirrorCodeArtifactTokenDuration" | Maybe Natural -> Bool
forall a. Maybe a -> Bool
isJust (MountConfig -> Maybe Natural
mntMirrorCodeArtifactTokenDuration MountConfig
mcfg)]

{- | Project a mirrored mount, whose private upstream and mirror target the caller
has already established (see 'resolveMounts'), onto its served form. The
mirror-write credential is derived from the mirror-target URL here
('resolveMirrorCredential'), so the resolved 'MirrorTarget' pairs an endpoint only
with the credential that endpoint dictates.
-}
resolveMirrored :: RulePolicy -> Ecosystem -> RegistryUrl -> RegistryUrl -> MountConfig -> Either [ConfigError] Mount
resolveMirrored :: RulePolicy
-> Ecosystem
-> RegistryUrl
-> RegistryUrl
-> MountConfig
-> Either [ConfigError] Mount
resolveMirrored RulePolicy
globalPolicy Ecosystem
eco RegistryUrl
privateUpstream RegistryUrl
mirrorTarget MountConfig
mcfg = do
    policy <- RulePolicy -> MountConfig -> Either [ConfigError] RulePolicy
resolveMountPolicy RulePolicy
globalPolicy MountConfig
mcfg
    credential <-
        first (: []) $
            resolveMirrorCredential eco mirrorTarget (mntMirrorTargetToken mcfg) (mntMirrorCodeArtifactTokenDuration mcfg)
    Right $
        mountOf eco mcfg policy $
            Mirrored
                MirroredLegs
                    { mlPrivateUpstream = privateUpstream
                    , mlMirrorTarget =
                        MirrorTarget
                            { mtUrl = mirrorTarget
                            , mtCredential = credential
                            }
                    }

{- | Project a serve-only mount (no mirror write; the private upstream optional,
absent on the pure public gate) onto its served form.
-}
resolveServeOnly :: RulePolicy -> Ecosystem -> Maybe RegistryUrl -> MountConfig -> Either [ConfigError] Mount
resolveServeOnly :: RulePolicy
-> Ecosystem
-> Maybe RegistryUrl
-> MountConfig
-> Either [ConfigError] Mount
resolveServeOnly RulePolicy
globalPolicy Ecosystem
eco Maybe RegistryUrl
mPrivate MountConfig
mcfg = do
    policy <- RulePolicy -> MountConfig -> Either [ConfigError] RulePolicy
resolveMountPolicy RulePolicy
globalPolicy MountConfig
mcfg
    Right (mountOf eco mcfg policy (ServeOnly mPrivate))

resolveMountPolicy :: RulePolicy -> MountConfig -> Either [ConfigError] RulePolicy
resolveMountPolicy :: RulePolicy -> MountConfig -> Either [ConfigError] RulePolicy
resolveMountPolicy RulePolicy
globalPolicy MountConfig
mcfg =
    ([PolicyError] -> [ConfigError])
-> Either [PolicyError] RulePolicy
-> Either [ConfigError] RulePolicy
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (\[PolicyError]
errs -> [[PolicyError] -> ConfigError
PolicyErrors [PolicyError]
errs]) (RulePolicy -> RulePatch -> Either [PolicyError] RulePolicy
resolvePolicy RulePolicy
globalPolicy (MountConfig -> RulePatch
mntAdditionalRules MountConfig
mcfg))

mountOf :: Ecosystem -> MountConfig -> RulePolicy -> MountMode -> Mount
mountOf :: Ecosystem -> MountConfig -> RulePolicy -> MountMode -> Mount
mountOf Ecosystem
eco MountConfig
mcfg RulePolicy
policy MountMode
mode =
    Mount
        { mountEcosystem :: Ecosystem
mountEcosystem = Ecosystem
eco
        , mountRegistries :: MountRegistries
mountRegistries =
            MountRegistries
                { regPublicUpstream :: RegistryUrl
regPublicUpstream = MountConfig -> RegistryUrl
mntPublicUpstream MountConfig
mcfg
                , regMode :: MountMode
regMode = MountMode
mode
                }
        , mountPolicy :: [PrecededRule]
mountPolicy = RulePolicy -> [PrecededRule]
rulesOf RulePolicy
policy
        }

rulesOf :: RulePolicy -> [PrecededRule]
rulesOf :: RulePolicy -> [PrecededRule]
rulesOf = Map Text PrecededRule -> [PrecededRule]
forall k a. Map k a -> [a]
Map.elems (Map Text PrecededRule -> [PrecededRule])
-> (RulePolicy -> Map Text PrecededRule)
-> RulePolicy
-> [PrecededRule]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RulePolicy -> Map Text PrecededRule
policyRules

{- | Boot-time advisory: one warning per pair of an active mount's resolved
registry endpoints that point at the same registry. Each collapse is supported by
the proxy (declaring the mirror target equal to the private upstream is a valid
arrangement), but a distinct registry per endpoint is the recommended posture, so
every collision is surfaced once at boot. A publication target equal to the private
upstream is the documented publish arrangement and is not warned. Comparison is
textual on the validated URL, insensitive to trailing slashes.
-}
mountCollisionWarnings :: Config -> [Text]
mountCollisionWarnings :: Config -> [Text]
mountCollisionWarnings Config
config =
    ((Ecosystem, Mount) -> [Text]) -> [(Ecosystem, Mount)] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (AppConfig -> (Ecosystem, Mount) -> [Text]
mountCollisions (Config -> AppConfig
configApp Config
config)) (MountMap -> [(Ecosystem, Mount)]
forall k a. Map k a -> [(k, a)]
Map.toAscList (Config -> MountMap
configMounts Config
config))

mountCollisions :: AppConfig -> (Ecosystem, Mount) -> [Text]
mountCollisions :: AppConfig -> (Ecosystem, Mount) -> [Text]
mountCollisions AppConfig
app (Ecosystem
eco, Mount
mount) = ((Text, RegistryUrl, Text, Maybe RegistryUrl) -> Maybe Text)
-> [(Text, RegistryUrl, Text, Maybe RegistryUrl)] -> [Text]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Ecosystem
-> (Text, RegistryUrl, Text, Maybe RegistryUrl) -> Maybe Text
collisionWarning Ecosystem
eco) [(Text, RegistryUrl, Text, Maybe RegistryUrl)]
pairs
  where
    regs :: MountRegistries
regs = Mount -> MountRegistries
mountRegistries Mount
mount
    mirror :: Maybe RegistryUrl
mirror = MirrorTarget -> RegistryUrl
mtUrl (MirrorTarget -> RegistryUrl)
-> Maybe MirrorTarget -> Maybe RegistryUrl
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MountRegistries -> Maybe MirrorTarget
regMirrorTarget MountRegistries
regs
    private :: Maybe RegistryUrl
private = MountRegistries -> Maybe RegistryUrl
regPrivateUpstream MountRegistries
regs
    publication :: Maybe RegistryUrl
publication = Ecosystem -> Map Ecosystem MountConfig -> Maybe MountConfig
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Ecosystem
eco (AppConfig -> Map Ecosystem MountConfig
cfgMounts AppConfig
app) Maybe MountConfig
-> (MountConfig -> Maybe RegistryUrl) -> Maybe RegistryUrl
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MountConfig -> Maybe RegistryUrl
mntPublicationTarget
    -- A serve-only mount has no mirror rows (and the pure gate no private row):
    -- absent endpoints cannot collide.
    pairs :: [(Text, RegistryUrl, Text, Maybe RegistryUrl)]
pairs =
        [(Text
"mirrorTarget", RegistryUrl
m, Text
"privateUpstream", Maybe RegistryUrl
private) | Just RegistryUrl
m <- [Maybe RegistryUrl
mirror]]
            [(Text, RegistryUrl, Text, Maybe RegistryUrl)]
-> [(Text, RegistryUrl, Text, Maybe RegistryUrl)]
-> [(Text, RegistryUrl, Text, Maybe RegistryUrl)]
forall a. Semigroup a => a -> a -> a
<> [(Text
"mirrorTarget", RegistryUrl
m, Text
"publicUpstream", RegistryUrl -> Maybe RegistryUrl
forall a. a -> Maybe a
Just (MountRegistries -> RegistryUrl
regPublicUpstream MountRegistries
regs)) | Just RegistryUrl
m <- [Maybe RegistryUrl
mirror]]
            [(Text, RegistryUrl, Text, Maybe RegistryUrl)]
-> [(Text, RegistryUrl, Text, Maybe RegistryUrl)]
-> [(Text, RegistryUrl, Text, Maybe RegistryUrl)]
forall a. Semigroup a => a -> a -> a
<> [(Text
"mirrorTarget", RegistryUrl
m, Text
"publicationTarget", Maybe RegistryUrl
publication) | Just RegistryUrl
m <- [Maybe RegistryUrl
mirror]]
            [(Text, RegistryUrl, Text, Maybe RegistryUrl)]
-> [(Text, RegistryUrl, Text, Maybe RegistryUrl)]
-> [(Text, RegistryUrl, Text, Maybe RegistryUrl)]
forall a. Semigroup a => a -> a -> a
<> [(Text
"privateUpstream", RegistryUrl
p, Text
"publicUpstream", RegistryUrl -> Maybe RegistryUrl
forall a. a -> Maybe a
Just (MountRegistries -> RegistryUrl
regPublicUpstream MountRegistries
regs)) | Just RegistryUrl
p <- [Maybe RegistryUrl
private]]

collisionWarning :: Ecosystem -> (Text, RegistryUrl, Text, Maybe RegistryUrl) -> Maybe Text
collisionWarning :: Ecosystem
-> (Text, RegistryUrl, Text, Maybe RegistryUrl) -> Maybe Text
collisionWarning Ecosystem
eco (Text
aName, RegistryUrl
a, Text
bName, Maybe RegistryUrl
mb) = do
    b <- Maybe RegistryUrl
mb
    guard (sameRegistry a b)
    pure
        ( "mount \""
            <> ecosystemName eco
            <> "\": "
            <> aName
            <> " and "
            <> bName
            <> " resolve to the same registry ("
            <> registryUrlText a
            <> "); a distinct registry per endpoint is strongly recommended"
        )

sameRegistry :: RegistryUrl -> RegistryUrl -> Bool
sameRegistry :: RegistryUrl -> RegistryUrl -> Bool
sameRegistry RegistryUrl
a RegistryUrl
b = RegistryUrl -> Text
strip RegistryUrl
a Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== RegistryUrl -> Text
strip RegistryUrl
b
  where
    strip :: RegistryUrl -> Text
strip = (Char -> Bool) -> Text -> Text
T.dropWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/') (Text -> Text) -> (RegistryUrl -> Text) -> RegistryUrl -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RegistryUrl -> Text
registryUrlText

{- | One line per resolved leaf of the merged configuration: the dotted path, the
rendered value (secret-typed keys redacted), and the layer that supplied it
(environment > document > default, mirroring the merge precedence). Derived and
computed values are deliberately absent: they are not configuration, and their
resolvers log their own provenance lines (the runtime posture, the memory plan,
the queue selection). Renders nothing if the layers fail to parse; callers dump
provenance only after a successful 'loadConfig'.
-}
resolvedKeyProvenance :: [(String, String)] -> Maybe ByteString -> [Text]
resolvedKeyProvenance :: [(String, String)] -> Maybe StrictByteString -> [Text]
resolvedKeyProvenance [(String, String)]
envVars Maybe StrictByteString
mBytes = [Text] -> Either [ConfigError] [Text] -> [Text]
forall b a. b -> Either a b -> b
fromRight [] (Either [ConfigError] [Text] -> [Text])
-> Either [ConfigError] [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ do
    defaultAst <- Either [ConfigError] Value
parseDefaultAst
    docAst <- parseDocumentAst mBytes
    let envAst = [(String, String)] -> Value
buildEnvAst [(String, String)]
envVars
        merged = Value -> Value -> Value
deepMerge Value
defaultAst (Value -> Value -> Value
deepMerge Value
docAst Value
envAst)
    pure (map (renderResolvedLeaf envAst docAst) (sortOn fst (leafPaths [] merged)))

-- Every leaf of a config AST with its dotted path (objects recurse; anything
-- else, arrays included, is a leaf).
leafPaths :: [Text] -> Value -> [(Text, Value)]
leafPaths :: [Text] -> Value -> [(Text, Value)]
leafPaths [Text]
path (Object Object
o) =
    ((Key, Value) -> [(Text, Value)])
-> [(Key, Value)] -> [(Text, Value)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Key
k, Value
v) -> [Text] -> Value -> [(Text, Value)]
leafPaths ([Text]
path [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Key -> Text
Key.toText Key
k]) Value
v) (Object -> [(Key, Value)]
forall v. KeyMap v -> [(Key, v)]
KeyMap.toList Object
o)
leafPaths [Text]
path Value
v = [(Text -> [Text] -> Text
T.intercalate Text
"." [Text]
path, Value
v)]

renderResolvedLeaf :: Value -> Value -> (Text, Value) -> Text
renderResolvedLeaf :: Value -> Value -> (Text, Value) -> Text
renderResolvedLeaf Value
envAst Value
docAst (Text
path, Value
v) =
    Text
"config: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
path Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Value -> Text
renderLeafValue Text
path Value
v Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
source Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
  where
    source :: Text
source
        | Value -> Bool
pathPresentIn Value
envAst = Text
"environment"
        | Value -> Bool
pathPresentIn Value
docAst = Text
"document"
        | Bool
otherwise = Text
"default"
    pathPresentIn :: Value -> Bool
pathPresentIn Value
ast = Maybe Value -> Bool
forall a. Maybe a -> Bool
isJust ([Text] -> Value -> Maybe Value
lookupPath (HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"." Text
path) Value
ast)
    lookupPath :: [Text] -> Value -> Maybe Value
lookupPath [] Value
ast = Value -> Maybe Value
forall a. a -> Maybe a
Just Value
ast
    lookupPath (Text
k : [Text]
ks) (Object Object
o) = [Text] -> Value -> Maybe Value
lookupPath [Text]
ks (Value -> Maybe Value) -> Maybe Value -> Maybe Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup (Text -> Key
Key.fromText Text
k) Object
o
    lookupPath [Text]
_ Value
_ = Maybe Value
forall a. Maybe a
Nothing

-- A leaf's rendering, with secret-typed keys redacted rather than shown: the
-- provenance dump must never widen a secret's exposure beyond the layer it
-- arrived on.
renderLeafValue :: Text -> Value -> Text
renderLeafValue :: Text -> Value -> Text
renderLeafValue Text
path Value
v
    | (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> Text -> Bool
`T.isSuffixOf` Text
path) [Text]
secretLeafKeys = Text
"<redacted>"
    | Bool
otherwise = case Value
v of
        String Text
t -> Text
t
        Value
other -> StrictByteString -> Text
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 (LazyByteString -> StrictByteString
LBS.toStrict (Value -> LazyByteString
forall a. ToJSON a => a -> LazyByteString
encode Value
other))

{- | Boot-time posture: one line per served mount naming its derived mode and its
consequence. The mode is derived from the declared endpoints (see 'loadConfig'), so
this is the loud counterpart of that inference: an unintentionally dropped
@mirrorTarget@ shows up here as "serve-only" at the very next boot rather than
silently un-mirroring.
-}
mountPostureLines :: Config -> [Text]
mountPostureLines :: Config -> [Text]
mountPostureLines Config
config = ((Ecosystem, Mount) -> Text) -> [(Ecosystem, Mount)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Ecosystem, Mount) -> Text
postureLine (MountMap -> [(Ecosystem, Mount)]
forall k a. Map k a -> [(k, a)]
Map.toAscList (Config -> MountMap
configMounts Config
config))

postureLine :: (Ecosystem, Mount) -> Text
postureLine :: (Ecosystem, Mount) -> Text
postureLine (Ecosystem
eco, Mount
mount) = case MountRegistries -> MountMode
regMode (Mount -> MountRegistries
mountRegistries Mount
mount) of
    Mirrored MirroredLegs
legs ->
        Text
"mount \""
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Ecosystem -> Text
ecosystemName Ecosystem
eco
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\": mirrored; admitted public artifacts back-fill "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> RegistryUrl -> Text
registryUrlText (MirrorTarget -> RegistryUrl
mtUrl (MirroredLegs -> MirrorTarget
mlMirrorTarget MirroredLegs
legs))
    ServeOnly (Just RegistryUrl
private) ->
        Text
"mount \""
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Ecosystem -> Text
ecosystemName Ecosystem
eco
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\": serve-only (no mirrorTarget declared): merges the private upstream "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> RegistryUrl -> Text
registryUrlText RegistryUrl
private
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" and never mirrors; admitted public artifacts stay on the gated public leg"
    ServeOnly Maybe RegistryUrl
Nothing ->
        Text
"mount \""
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Ecosystem -> Text
ecosystemName Ecosystem
eco
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\": serve-only pure public gate (no private upstream, no mirrorTarget): every artifact streams from the gated public leg and is never mirrored"