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

-- | Configuration loading, mount resolution, and redacted operator diagnostics.
module Ecluse.Config (
    Config (..),
    AppConfig (..),
    ServerSettings (..),
    QueueSettings (..),
    LimitsSettings (..),
    CacheSettings (..),
    IntegritySettings (..),
    EgressSettings (..),
    AdvisoriesSettings (..),
    RuntimeSettings (..),
    ObservabilitySettings (..),
    DredgerSettings (..),
    QuotaOverride (..),
    MountMap,
    Mount (..),
    MountRegistries (..),
    MountMode (..),
    MirroredLegs (..),
    regPrivateUpstream,
    regMirrorTarget,
    MirrorTarget (..),
    StoreTag (..),
    storeTagName,
    Target (..),
    PrivateEndpoint (..),
    DeletionConsent (..),
    MirrorWrite (..),
    MirrorEndpoint (..),
    meTarget,
    PublicationEndpoint (..),
    MintPlan (..),
    ControlPlane (..),
    StoreBackend (..),
    sbTag,
    sbMint,
    sbControl,
    FirstParty (..),
    MountIntegrity (..),
    MountConfig (..),
    Url,
    unUrl,
    QueueTarget (..),
    QueueUrl,
    queueUrlText,
    queueUrlTarget,
    AdvisoryStoreTarget (..),
    AdvisoryStoreUrl,
    advisoryStoreUrlText,
    advisoryStoreTarget,
    advisoryStoreBucket,
    advisoryObjectKey,
    RulePatch (..),
    RuleEntry (..),
    RulePolicy (..),
    PolicyError (..),
    renderPolicyError,
    emptyPolicy,
    defaultPolicy,
    ConfigError (..),
    renderConfigError,
    loadConfig,
    sameRegistry,
    mountPostureLines,
    mountAdvisoryAge,
    mountEpssRequirement,
    mountAdvisoryDenials,
    mountDatabaseRequirement,
    advisoryAgeLines,
    advisoryEpssLines,
    resolvedKeyProvenance,
) where

import Data.Aeson (Value (..), encode, parseJSON)
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.AdvisoryStore (advisoryObjectKey, advisoryStoreBucket)
import Ecluse.Config.Aeson ()
import Ecluse.Config.DefaultConfig (defaultConfigBytes)
import Ecluse.Config.Resolve (buildEnvAst, deepMerge, secretLeafKeys)
import Ecluse.Config.Rule
import Ecluse.Config.Target (resolveStoreBackend, vetPrivateRepository, vetTargetTag)
import Ecluse.Config.Types
import Ecluse.Core.Ecosystem (Ecosystem, ecosystemName, parseEcosystem)
import Ecluse.Core.Osv.Schema (EpssRequirement (EpssOptional, EpssRequired))
import Ecluse.Core.Rules (renderDuration)
import Ecluse.Core.Rules.Freshness (
    AdvisoryAgeBasis (AgeBeforeQuarantine, AgeConfigured, AgeFloor),
    MaxAdvisoryAge (maxAdvisoryAge, maxAdvisoryAgeBasis),
    maxAdvisoryAgeFor,
 )
import Ecluse.Core.Rules.Types (PrecededRule (prRule), Rule (DenyIfEpss), deniesOnAdvisories, readsAdvisories, ruleName)
import Ecluse.Core.Security (HostPort, hostPortAddress)
import Ecluse.Core.Security.Egress (RegistryUrl, registryUrlText)
import Ecluse.Core.Server.Readiness (DatabaseRequirement (DatabaseOptional, DatabaseRequired))
import Ecluse.Core.Text (registryPath, stripTrailingSlash)

-- | The rule policy embedded in the shipped configuration.

{- 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 merged configuration: the defaults, the operator document, then the environment
overlay, strongest-last. A mount is __active__ only where that overlay declares a key under it.
-}
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 appConfig = AppConfig
parsed{cfgMounts = servedMounts active (cfgMounts parsed)}
    globalPolicy <- resolveGlobalPolicy overridesAst
    mounts <- case (publicUrlErrors appConfig, 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)

-- enabled: false switches a declared mount off. Anything else declared serves.
servedMounts :: Set Ecosystem -> Map Ecosystem MountConfig -> Map Ecosystem MountConfig
servedMounts :: Set Ecosystem
-> Map Ecosystem MountConfig -> Map Ecosystem MountConfig
servedMounts Set Ecosystem
active Map Ecosystem MountConfig
declared =
    (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
-> Set Ecosystem -> Map Ecosystem MountConfig
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys Map Ecosystem MountConfig
declared Set Ecosystem
active)

-- The proxy rewrites served tarball URLs against its own public base URL. Without one, every
-- install fails client by client instead of loudly at boot.
publicUrlErrors :: AppConfig -> [ConfigError]
publicUrlErrors :: AppConfig -> [ConfigError]
publicUrlErrors AppConfig
appConfig =
    [ ConfigError
PublicUrlRequired
    | Bool -> Bool
not (Map Ecosystem MountConfig -> Bool
forall k a. Map k a -> Bool
Map.null (AppConfig -> Map Ecosystem MountConfig
cfgMounts AppConfig
appConfig))
    , Maybe Url -> Bool
forall a. Maybe a -> Bool
isNothing (ServerSettings -> Maybe Url
srvPublicUrl (AppConfig -> ServerSettings
cfgServer AppConfig
appConfig))
    ]

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 -> Parser AppConfig) -> Value -> Either String AppConfig
forall a b. (a -> Parser b) -> a -> Either String b
parseEither Value -> Parser AppConfig
forall a. FromJSON a => Value -> Parser a
parseJSON Value
merged of
    Right AppConfig
appConfig -> AppConfig -> Either [ConfigError] AppConfig
forall a b. b -> Either a b
Right AppConfig
appConfig
    Left 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)

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 [Either ConfigError ()] -> [ConfigError]
forall a b. [Either a b] -> [a]
lefts (Ecosystem -> MountConfig -> [Either ConfigError ()]
declarationErrors Ecosystem
eco 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 -> MountConfig -> Either [ConfigError] Mount
resolveMode RulePolicy
globalPolicy Ecosystem
eco MountConfig
mcfg
        [ConfigError]
tagErrs -> [ConfigError] -> Either [ConfigError] (Ecosystem, Mount)
forall a b. a -> Either a b
Left [ConfigError]
tagErrs

{- Every endpoint checked against the tag it was declared under, and the private upstream checked
once more for the repository the boot addresses its aggregation question to. -}
declarationErrors :: Ecosystem -> MountConfig -> [Either ConfigError ()]
declarationErrors :: Ecosystem -> MountConfig -> [Either ConfigError ()]
declarationErrors Ecosystem
eco MountConfig
mcfg =
    ((Text, Target) -> Either ConfigError ())
-> [(Text, Target)] -> [Either ConfigError ()]
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> Target -> Either ConfigError ())
-> (Text, Target) -> Either ConfigError ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Ecosystem -> Text -> Target -> Either ConfigError ()
vetTargetTag Ecosystem
eco)) (MountConfig -> [(Text, Target)]
readAndPublishTargets MountConfig
mcfg)
        [Either ConfigError ()]
-> [Either ConfigError ()] -> [Either ConfigError ()]
forall a. Semigroup a => a -> a -> a
<> [Ecosystem -> Target -> Either ConfigError ()
vetPrivateRepository Ecosystem
eco (PrivateEndpoint -> Target
preTarget PrivateEndpoint
endpoint) | Just PrivateEndpoint
endpoint <- [MountConfig -> Maybe PrivateEndpoint
mntPrivateUpstream MountConfig
mcfg]]

{- Each read or publish endpoint a mount declares, with the key it is written under. The mirror
target is absent because 'resolveStoreBackend' vets it while resolving its backend. -}
readAndPublishTargets :: MountConfig -> [(Text, Target)]
readAndPublishTargets :: MountConfig -> [(Text, Target)]
readAndPublishTargets MountConfig
mcfg =
    [(Text
"privateUpstream", PrivateEndpoint -> Target
preTarget PrivateEndpoint
target) | Just PrivateEndpoint
target <- [MountConfig -> Maybe PrivateEndpoint
mntPrivateUpstream MountConfig
mcfg]]
        [(Text, Target)] -> [(Text, Target)] -> [(Text, Target)]
forall a. Semigroup a => a -> a -> a
<> [(Text
"publicationTarget", PublicationEndpoint -> Target
peTarget PublicationEndpoint
endpoint) | Just PublicationEndpoint
endpoint <- [MountConfig -> Maybe PublicationEndpoint
mntPublicationTarget MountConfig
mcfg]]

-- A declared mirror target makes the mount mirrored, which then needs its private upstream.
resolveMode :: RulePolicy -> Ecosystem -> MountConfig -> Either [ConfigError] Mount
resolveMode :: RulePolicy
-> Ecosystem -> MountConfig -> Either [ConfigError] Mount
resolveMode RulePolicy
globalPolicy Ecosystem
eco MountConfig
mcfg = case (MountConfig -> Maybe MirrorEndpoint
mntMirrorTarget MountConfig
mcfg, MountConfig -> Maybe PrivateEndpoint
mntPrivateUpstream MountConfig
mcfg) of
    (Just MirrorEndpoint
mirrorTarget, Just PrivateEndpoint
privateUpstream) ->
        RulePolicy
-> Ecosystem
-> Target
-> MirrorEndpoint
-> MountConfig
-> Either [ConfigError] Mount
resolveMirrored RulePolicy
globalPolicy Ecosystem
eco (PrivateEndpoint -> Target
preTarget PrivateEndpoint
privateUpstream) MirrorEndpoint
mirrorTarget MountConfig
mcfg
    (Just MirrorEndpoint
_, Maybe PrivateEndpoint
Nothing) -> [ConfigError] -> Either [ConfigError] Mount
forall a b. a -> Either a b
Left [Ecosystem -> ConfigError
MountMissingPrivateUpstream Ecosystem
eco]
    (Maybe MirrorEndpoint
Nothing, Maybe PrivateEndpoint
mPrivate) -> RulePolicy
-> Ecosystem
-> Maybe Target
-> MountConfig
-> Either [ConfigError] Mount
resolveServeOnly RulePolicy
globalPolicy Ecosystem
eco (PrivateEndpoint -> Target
preTarget (PrivateEndpoint -> Target)
-> Maybe PrivateEndpoint -> Maybe Target
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe PrivateEndpoint
mPrivate) MountConfig
mcfg

resolveMirrored :: RulePolicy -> Ecosystem -> Target -> MirrorEndpoint -> MountConfig -> Either [ConfigError] Mount
resolveMirrored :: RulePolicy
-> Ecosystem
-> Target
-> MirrorEndpoint
-> MountConfig
-> Either [ConfigError] Mount
resolveMirrored RulePolicy
globalPolicy Ecosystem
eco Target
privateUpstream MirrorEndpoint
mirrorTarget MountConfig
mcfg = do
    policy <- RulePolicy -> MountConfig -> Either [ConfigError] RulePolicy
resolveMountPolicy RulePolicy
globalPolicy MountConfig
mcfg
    backend <- first (: []) (resolveStoreBackend eco mirrorTarget)
    Right $
        mountOf eco mcfg policy $
            Mirrored
                MirroredLegs
                    { mlPrivateUpstream = tgtUrl privateUpstream
                    , mlMirrorTarget =
                        MirrorTarget
                            { mtUrl = meUrl mirrorTarget
                            , mtBackend = backend
                            }
                    }

resolveServeOnly :: RulePolicy -> Ecosystem -> Maybe Target -> MountConfig -> Either [ConfigError] Mount
resolveServeOnly :: RulePolicy
-> Ecosystem
-> Maybe Target
-> MountConfig
-> Either [ConfigError] Mount
resolveServeOnly RulePolicy
globalPolicy Ecosystem
eco Maybe Target
mPrivate MountConfig
mcfg = do
    policy <- RulePolicy -> MountConfig -> Either [ConfigError] RulePolicy
resolveMountPolicy RulePolicy
globalPolicy MountConfig
mcfg
    Right (mountOf eco mcfg policy (ServeOnly (tgtUrl <$> 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

{- | Whether two configured endpoints name the same registry. The authority folds to lower case
with its default port applied, and the path is compared exactly past a trailing slash.
-}
sameRegistry :: RegistryUrl -> RegistryUrl -> Bool
sameRegistry :: RegistryUrl -> RegistryUrl -> Bool
sameRegistry RegistryUrl
a RegistryUrl
b = RegistryUrl -> (Maybe HostPort, Text)
registryKey RegistryUrl
a (Maybe HostPort, Text) -> (Maybe HostPort, Text) -> Bool
forall a. Eq a => a -> a -> Bool
== RegistryUrl -> (Maybe HostPort, Text)
registryKey RegistryUrl
b

{- The key two endpoints are equal on. A boot refusal gates permanent deletion on it, so the
authority folds the way DNS and TLS resolve it, and two unreadable ones count as one store. -}
registryKey :: RegistryUrl -> (Maybe HostPort, Text)
registryKey :: RegistryUrl -> (Maybe HostPort, Text)
registryKey RegistryUrl
url = (Text -> Maybe HostPort
hostPortAddress Text
raw, Text -> Text
stripTrailingSlash (Text -> Text
registryPath Text
raw))
  where
    raw :: Text
raw = RegistryUrl -> Text
registryUrlText RegistryUrl
url

{- | One line per resolved leaf of the merged configuration: the dotted path, the redacted value,
and its layer. Empty when a layer fails to parse, and a boot-computed key has no leaf to report.
-}
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)))

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 :: [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

-- Secret-typed keys are redacted: 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))

-- | Mount modes followed by the live-environment limits of @check-config@, shared with boot.
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 [(Ecosystem, Mount)]
mounts [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> ((Ecosystem, Mount) -> Maybe Text)
-> [(Ecosystem, Mount)] -> [Text]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Ecosystem, Mount) -> Maybe Text
maintenanceClientLine [(Ecosystem, Mount)]
mounts [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> ((Ecosystem, Mount) -> Maybe Text)
-> [(Ecosystem, Mount)] -> [Text]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Ecosystem, Mount) -> Maybe Text
upstreamProbeLine [(Ecosystem, Mount)]
mounts
  where
    mounts :: [(Ecosystem, Mount)]
mounts = MountMap -> [(Ecosystem, Mount)]
forall k a. Map k a -> [(k, a)]
Map.toAscList (Config -> MountMap
configMounts Config
config)

{- Asking a backend what its private upstream aggregates is a call against the live control plane,
which a checker makes none of. -}
upstreamProbeLine :: (Ecosystem, Mount) -> Maybe Text
upstreamProbeLine :: (Ecosystem, Mount) -> Maybe Text
upstreamProbeLine (Ecosystem
eco, Mount
mount) =
    Text
notice Text -> Maybe RegistryUrl -> Maybe Text
forall a b. a -> Maybe b -> Maybe a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ MountRegistries -> Maybe RegistryUrl
regPrivateUpstream (Mount -> MountRegistries
mountRegistries Mount
mount)
  where
    notice :: Text
notice =
        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
"\": the private upstream is asked at boot whether it, or a repository in its upstream chain, connects to a public registry. check-config does not make that call."

maintenanceClientLine :: (Ecosystem, Mount) -> Maybe Text
maintenanceClientLine :: (Ecosystem, Mount) -> Maybe Text
maintenanceClientLine (Ecosystem
eco, Mount
mount) = do
    target <- MountRegistries -> Maybe MirrorTarget
regMirrorTarget (Mount -> MountRegistries
mountRegistries Mount
mount)
    case sbControl (mtBackend target) of
        ControlPlane
ControlNone -> Maybe Text
forall a. Maybe a
Nothing
        ControlCodeArtifact{} -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
notice
        ControlProtocol{} -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
notice
  where
    notice :: Text
notice =
        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
"\": the store maintenance client is built at boot against the live environment. check-config does not attempt this build."

{- | One mount's effective maximum advisory push age, derived from that mount's own rules. An
explicit @advisories.maxAgeSeconds@ overrides the derivation on every mount.
-}
mountAdvisoryAge :: AdvisoriesSettings -> Mount -> MaxAdvisoryAge
mountAdvisoryAge :: AdvisoriesSettings -> Mount -> MaxAdvisoryAge
mountAdvisoryAge AdvisoriesSettings
advisories = Maybe NominalDiffTime -> [Rule] -> MaxAdvisoryAge
maxAdvisoryAgeFor (AdvisoriesSettings -> Maybe NominalDiffTime
advMaxAgeSeconds AdvisoriesSettings
advisories) ([Rule] -> MaxAdvisoryAge)
-> (Mount -> [Rule]) -> Mount -> MaxAdvisoryAge
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mount -> [Rule]
mountRulesOf

-- | Require enrichment when this mount's resolved policy contains an EPSS rule.
mountEpssRequirement :: Mount -> EpssRequirement
mountEpssRequirement :: Mount -> EpssRequirement
mountEpssRequirement = EpssRequirement -> EpssRequirement -> Bool -> EpssRequirement
forall a. a -> a -> Bool -> a
bool EpssRequirement
EpssOptional EpssRequirement
EpssRequired (Bool -> EpssRequirement)
-> (Mount -> Bool) -> Mount -> EpssRequirement
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Rule -> Bool) -> [Rule] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Rule -> Bool
requiresEpss ([Rule] -> Bool) -> (Mount -> [Rule]) -> Mount -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mount -> [Rule]
mountRulesOf
  where
    requiresEpss :: Rule -> Bool
requiresEpss DenyIfEpss{} = Bool
True
    requiresEpss Rule
_ = Bool
False

mountRulesOf :: Mount -> [Rule]
mountRulesOf :: Mount -> [Rule]
mountRulesOf = (PrecededRule -> Rule) -> [PrecededRule] -> [Rule]
forall a b. (a -> b) -> [a] -> [b]
map PrecededRule -> Rule
prRule ([PrecededRule] -> [Rule])
-> (Mount -> [PrecededRule]) -> Mount -> [Rule]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mount -> [PrecededRule]
mountPolicy

{- | The names of this mount's rules that deny on the advisory database, in policy order. A
non-empty list is what makes an advisory store mandatory and the mount's readiness wait for one.
-}
mountAdvisoryDenials :: Mount -> [Text]
mountAdvisoryDenials :: Mount -> [Text]
mountAdvisoryDenials = [Text] -> [Text]
forall a. Ord a => [a] -> [a]
ordNub ([Text] -> [Text]) -> (Mount -> [Text]) -> Mount -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Rule -> Text) -> [Rule] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Rule -> Text
ruleName ([Rule] -> [Text]) -> (Mount -> [Rule]) -> Mount -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Rule -> Bool) -> [Rule] -> [Rule]
forall a. (a -> Bool) -> [a] -> [a]
filter Rule -> Bool
deniesOnAdvisories ([Rule] -> [Rule]) -> (Mount -> [Rule]) -> Mount -> [Rule]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mount -> [Rule]
mountRulesOf

-- | Whether this mount must hold an advisory database before it can serve anything.
mountDatabaseRequirement :: Mount -> DatabaseRequirement
mountDatabaseRequirement :: Mount -> DatabaseRequirement
mountDatabaseRequirement = DatabaseRequirement
-> DatabaseRequirement -> Bool -> DatabaseRequirement
forall a. a -> a -> Bool -> a
bool DatabaseRequirement
DatabaseRequired DatabaseRequirement
DatabaseOptional (Bool -> DatabaseRequirement)
-> (Mount -> Bool) -> Mount -> DatabaseRequirement
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Text] -> Bool) -> (Mount -> [Text]) -> Mount -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mount -> [Text]
mountAdvisoryDenials

{- | The effective maximum push age of every mount whose rules read the advisory database, with
the basis that produced it. With no store configured nothing syncs, so nothing has an age.
-}
advisoryAgeLines :: Config -> [Text]
advisoryAgeLines :: Config -> [Text]
advisoryAgeLines Config
config =
    [ Ecosystem -> MaxAdvisoryAge -> Text
ageLine Ecosystem
eco (AdvisoriesSettings -> Mount -> MaxAdvisoryAge
mountAdvisoryAge AdvisoriesSettings
advisories Mount
mount)
    | Maybe AdvisoryStoreUrl -> Bool
forall a. Maybe a -> Bool
isJust (AdvisoriesSettings -> Maybe AdvisoryStoreUrl
advUrl AdvisoriesSettings
advisories)
    , (Ecosystem
eco, Mount
mount) <- MountMap -> [(Ecosystem, Mount)]
forall k a. Map k a -> [(k, a)]
Map.toAscList (Config -> MountMap
configMounts Config
config)
    , (Rule -> Bool) -> [Rule] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Rule -> Bool
readsAdvisories (Mount -> [Rule]
mountRulesOf Mount
mount)
    ]
  where
    advisories :: AdvisoriesSettings
advisories = AppConfig -> AdvisoriesSettings
cfgAdvisories (Config -> AppConfig
configApp Config
config)

ageLine :: Ecosystem -> MaxAdvisoryAge -> Text
ageLine :: Ecosystem -> MaxAdvisoryAge -> Text
ageLine Ecosystem
eco MaxAdvisoryAge
limit =
    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
"\": CVE-based denial refuses on an advisory push older than "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> NominalDiffTime -> Text
renderDuration (MaxAdvisoryAge -> NominalDiffTime
maxAdvisoryAge MaxAdvisoryAge
limit)
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> AdvisoryAgeBasis -> Text
renderBasis (MaxAdvisoryAge -> AdvisoryAgeBasis
maxAdvisoryAgeBasis MaxAdvisoryAge
limit)

{- | Each mount's EPSS requirement, which Pilot and that mount's advisory consumers apply alike.
It is reported with no store too, because @pilot compile@ runs under it without uploading.
-}
advisoryEpssLines :: Config -> [Text]
advisoryEpssLines :: Config -> [Text]
advisoryEpssLines Config
config = [Ecosystem -> EpssRequirement -> Text
epssLine Ecosystem
eco (Mount -> EpssRequirement
mountEpssRequirement Mount
mount) | (Ecosystem
eco, Mount
mount) <- MountMap -> [(Ecosystem, Mount)]
forall k a. Map k a -> [(k, a)]
Map.toAscList (Config -> MountMap
configMounts Config
config)]

epssLine :: Ecosystem -> EpssRequirement -> Text
epssLine :: Ecosystem -> EpssRequirement -> Text
epssLine Ecosystem
eco = \case
    EpssRequirement
EpssRequired -> Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"EPSS enrichment is required, because a DenyIfEpss rule is active. A failed EPSS feed publishes no artifact, and consumers refuse one without enrichment"
    EpssRequirement
EpssOptional -> Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"EPSS enrichment is optional, because no DenyIfEpss rule is active. A failed EPSS feed publishes the OSV data with epss_status=unavailable"
  where
    prefix :: Text
prefix = 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
"\": "

renderBasis :: AdvisoryAgeBasis -> Text
renderBasis :: AdvisoryAgeBasis -> Text
renderBasis = \case
    AdvisoryAgeBasis
AgeConfigured -> Text
"set by advisories.maxAgeSeconds"
    AgeBeforeQuarantine NominalDiffTime
quarantine ->
        Text
"derived a day ahead of this mount's earliest AllowIfOlderThan quarantine of " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> NominalDiffTime -> Text
renderDuration NominalDiffTime
quarantine
    AdvisoryAgeBasis
AgeFloor -> Text
"the shipped floor, which no derivation goes below"

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 the "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> StoreTag -> Text
storeTagName (StoreBackend -> StoreTag
sbTag (MirrorTarget -> StoreBackend
mtBackend (MirroredLegs -> MirrorTarget
mlMirrorTarget MirroredLegs
legs)))
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" store "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> RegistryUrl -> Text
registryUrlText (MirrorTarget -> RegistryUrl
mtUrl (MirroredLegs -> MirrorTarget
mlMirrorTarget MirroredLegs
legs))
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> StoreBackend -> Text
consentClause (MirrorTarget -> StoreBackend
mtBackend (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"

{- The deletion consent a store carries, which the operator declares on the store itself. Only a
Verdaccio store carries one, so the clause is empty everywhere else. -}
consentClause :: StoreBackend -> Text
consentClause :: StoreBackend -> Text
consentClause = \case
    BackendVerdaccio Secret
_ DeletionConsent
DeletionPermitted -> Text
", which permits deletion"
    BackendVerdaccio Secret
_ DeletionConsent
DeletionWithheld -> Text
", which withholds deletion"
    BackendRegistry{} -> Text
""
    BackendCodeArtifact{} -> Text
""