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

{- | The composition-root wiring: turn a validated 'Config' and the
process-global credential providers into the served 'MountBinding's, failing fast
and __aggregated__ on any boot problem.

This is the __listener-free__ heart of the composition root ("Ecluse" calls it): it
holds no sockets, no network, and no real clock of its own -- the clock and the
ecosystem-to-adapter resolver are injected -- so the boot-time validation is
unit-tested without opening a listener. Its one effect is preparing each mount's rule
set ('Ecluse.Core.Rules.prepare'), which allocates per-rule engine state once at boot
(a breaker for a resilient rule; the built-in rules need none today), so binding
assembly is 'IO'; everything else stays a pure function of the validated config.

The composition root's other concerns live in the sibling modules: the boot-error
vocabulary and rendering in "Ecluse.Composition.BootError", the credential
providers and mirror-target credential selection in
"Ecluse.Composition.Credential", the mirror-queue backend selection in
"Ecluse.Composition.MirrorQueue", and the config-derived runtime sizings in
"Ecluse.Composition.Sizing".

== Fail-fast at boot

Three boot failures are aggregated into one report so a single run shows every
problem: a rule policy that does not resolve ('PolicyBootError', surfaced by
'Ecluse.Config.loadConfig'), a configured mount whose ecosystem has no adapter
wired ('MissingAdapter'), and a mount with no initialised mirror-write provider
('UnresolvedCredential'). A bad configuration is thus a loud, immediate startup
failure, never a quietly mis-enforced or half-wired state (see
@docs\/architecture\/configuration.md@ → "Validation").
-}
module Ecluse.Composition (
    -- * Boot-time wiring
    planMounts,
    composeBindings,
    validateComposition,

    -- * Publish-side wiring
    PublishBudget (..),
    PublishTarget (..),
    planPublishTargets,
) where

import Data.Map.Strict qualified as Map
import Data.Set qualified as Set
import Data.Text qualified as T
import Data.Time (UTCTime)

import Ecluse.Composition.BootError (BootError (..))
import Ecluse.Composition.Credential (CredentialProviders, initializedEcosystems, lookupProvider)
import Ecluse.Config (
    AppConfig (..),
    Config (..),
    EgressSettings (..),
    IntegritySettings (..),
    MirrorTarget (mtUrl),
    Mount (..),
    MountConfig (..),
    MountRegistries (..),
    ServerSettings (..),
    Url,
    regMirrorTarget,
    regPrivateUpstream,
    unUrl,
 )
import Ecluse.Core.Credential (CredentialProvider, Secret)
import Ecluse.Core.Ecosystem (Ecosystem, prefixFor)
import Ecluse.Core.Registry.Adapter (
    RegistryAdapter,
    adapterArtifact,
    adapterFor,
    adapterMetadata,
    adapterPublish,
    artifactByFile,
    artifactByUrl,
    artifactHosts,
    metadataAssemble,
    metadataNewClient,
    metadataSerialise,
    publishCanonicaliseName,
    publishDeclaredNames,
    publishRelay,
 )
import Ecluse.Core.Rules (RuleDeps, prepare, rdCurrentAdvisoryEtag)
import Ecluse.Core.Security (Limits, tarballHostGate)
import Ecluse.Core.Security.Egress (mkRegistryUrl, registryUrlText)
import Ecluse.Core.Server.Admission.Bytes (ByteAdmission)
import Ecluse.Core.Server.Context (MirrorServePlan (MirrorOnAdmit, NoMirrorWrite), MountBinding, PackumentDeps (..), PublishDeps (..))
import Ecluse.Core.Server.Response (HelpMessage, mkHelpMessage)

{- | Validate the environment layer and optional document into the served mount
bindings, or the aggregated boot errors. The composition root's single entry: it
runs 'loadConfig' (whose policy errors become 'PolicyBootError's) and then
'composeBindings', so policy, missing-adapter, and unresolved-credential failures
all surface from one call.

The ecosystem-to-adapter resolver, the wall-clock source, and the rules' boot-bound
capabilities are injected (the composition root supplies @mountBindingFor@,
'Data.Time.getCurrentTime', and each ecosystem's 'RuleDeps'), so this validation
opens no socket. The capabilities are per ecosystem because a mount's rules must
borrow /their/ ecosystem's advisory database, never a neighbour's.
It is 'IO' only because 'composeBindings' 'prepare's each mount's rules (allocating
per-rule engine state once at boot).
-}
planMounts ::
    (Ecosystem -> PackumentDeps -> Maybe PublishDeps -> Maybe MountBinding) ->
    IO UTCTime ->
    (Ecosystem -> RuleDeps) ->
    CredentialProviders ->
    Limits ->
    Maybe PublishBudget ->
    Config ->
    IO (Either [BootError] [MountBinding])
planMounts :: (Ecosystem
 -> PackumentDeps -> Maybe PublishDeps -> Maybe MountBinding)
-> IO UTCTime
-> (Ecosystem -> RuleDeps)
-> CredentialProviders
-> Limits
-> Maybe PublishBudget
-> Config
-> IO (Either [BootError] [MountBinding])
planMounts = (Ecosystem
 -> PackumentDeps -> Maybe PublishDeps -> Maybe MountBinding)
-> IO UTCTime
-> (Ecosystem -> RuleDeps)
-> CredentialProviders
-> Limits
-> Maybe PublishBudget
-> Config
-> IO (Either [BootError] [MountBinding])
composeBindings

{- | The publish-side byte discipline the composition root builds from the memory
plan's publish tenant and hands to every publishing mount: the process-wide
aggregate byte-admission and the per-request cap (the chunked-body weight).
Present exactly when a publication target is configured -- the tenant and the
target derive from the same predicate, so a publishing mount without a budget is
unrepresentable at the root.
-}
data PublishBudget = PublishBudget
    { PublishBudget -> ByteAdmission
pbBodyBudget :: ByteAdmission
    , PublishBudget -> Int
pbMaxRequestBytes :: Int
    }

{- | Turn a validated 'Config' into the served 'MountBinding's, or the aggregated
boot errors. For each mount, in ecosystem order: its credential reference must
resolve to an initialised provider, and its ecosystem must resolve to an adapter
(through the injected resolver, which the mount's 'PackumentDeps' are built from).
Errors aggregate across every mount. The 'Limits' arrive resolved (the byte cap
from the memory plan, "Ecluse.Composition.MemoryPlan", married to the pinned
structural counts) and are carried onto every mount's deps, so the data plane
reads each metadata body bounded (security.md invariant 4).
-}
composeBindings ::
    (Ecosystem -> PackumentDeps -> Maybe PublishDeps -> Maybe MountBinding) ->
    IO UTCTime ->
    (Ecosystem -> RuleDeps) ->
    CredentialProviders ->
    Limits ->
    Maybe PublishBudget ->
    Config ->
    IO (Either [BootError] [MountBinding])
composeBindings :: (Ecosystem
 -> PackumentDeps -> Maybe PublishDeps -> Maybe MountBinding)
-> IO UTCTime
-> (Ecosystem -> RuleDeps)
-> CredentialProviders
-> Limits
-> Maybe PublishBudget
-> Config
-> IO (Either [BootError] [MountBinding])
composeBindings Ecosystem
-> PackumentDeps -> Maybe PublishDeps -> Maybe MountBinding
resolveAdapter IO UTCTime
clock Ecosystem -> RuleDeps
ruleDepsFor CredentialProviders
providers Limits
limits Maybe PublishBudget
publishBudget Config
config = do
    -- The pure structural refusals (missing adapters, publish policy) come from
    -- 'validateComposition', the same function check-config runs, so the checker
    -- and the boot cannot drift on what is refused.
    let structuralErrs :: [BootError]
structuralErrs = Config -> [BootError]
validateComposition Config
config
        pubDepsMap :: Map Ecosystem (Maybe PublishDeps)
pubDepsMap = (Ecosystem -> MountConfig -> Maybe PublishDeps)
-> Map Ecosystem MountConfig -> Map Ecosystem (Maybe PublishDeps)
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey (\Ecosystem
eco MountConfig
mcfg -> Maybe RegistryAdapter
-> AppConfig
-> MountConfig
-> Limits
-> Maybe PublishBudget
-> Maybe HelpMessage
-> Maybe PublishDeps
publishDepsFor (Ecosystem -> Maybe RegistryAdapter
adapterFor Ecosystem
eco) AppConfig
app MountConfig
mcfg Limits
limits Maybe PublishBudget
publishBudget Maybe HelpMessage
helpMessage) (AppConfig -> Map Ecosystem MountConfig
cfgMounts AppConfig
app)
    -- Each resolved mount paired with its environment-layer 'MountConfig':
    -- 'Ecluse.Config.loadConfig' derives 'configMounts' from 'cfgMounts' entry for
    -- entry, so the two maps share a keyset and the pairing is total.
    let mounts :: [(Mount, MountConfig)]
mounts = Map Ecosystem (Mount, MountConfig) -> [(Mount, MountConfig)]
forall k a. Map k a -> [a]
Map.elems ((Mount -> MountConfig -> (Mount, MountConfig))
-> Map Ecosystem Mount
-> Map Ecosystem MountConfig
-> Map Ecosystem (Mount, MountConfig)
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
Map.intersectionWith (,) (Config -> Map Ecosystem Mount
configMounts Config
config) (AppConfig -> Map Ecosystem MountConfig
cfgMounts AppConfig
app))
    bindingResults <- ((Mount, MountConfig) -> IO (Either [BootError] MountBinding))
-> [(Mount, MountConfig)] -> IO [Either [BootError] MountBinding]
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 (\(Mount
mount, MountConfig
mcfg) -> Maybe PublishDeps
-> Mount -> MountConfig -> IO (Either [BootError] MountBinding)
bindingFor (Maybe (Maybe PublishDeps) -> Maybe PublishDeps
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Ecosystem
-> Map Ecosystem (Maybe PublishDeps) -> Maybe (Maybe PublishDeps)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Mount -> Ecosystem
mountEcosystem Mount
mount) Map Ecosystem (Maybe PublishDeps)
pubDepsMap)) Mount
mount MountConfig
mcfg) [(Mount, MountConfig)]
mounts
    pure $ case (structuralErrs, partitionEithers bindingResults) of
        ([], ([], [MountBinding]
bindings)) -> [MountBinding] -> Either [BootError] [MountBinding]
forall a b. b -> Either a b
Right [MountBinding]
bindings
        ([BootError]
_, ([[BootError]]
errs, [MountBinding]
_)) -> [BootError] -> Either [BootError] [MountBinding]
forall a b. a -> Either a b
Left ([BootError]
structuralErrs [BootError] -> [BootError] -> [BootError]
forall a. Semigroup a => a -> a -> a
<> [[BootError]] -> [BootError]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[BootError]]
errs)
  where
    app :: AppConfig
    app :: AppConfig
app = Config -> AppConfig
configApp Config
config

    -- The operator help message, derived from the environment layer like the
    -- inbound token, so every mount's denials carry it.
    helpMessage :: Maybe HelpMessage
    helpMessage :: Maybe HelpMessage
helpMessage = Text -> HelpMessage
mkHelpMessage (Text -> HelpMessage) -> Maybe Text -> Maybe HelpMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ServerSettings -> Maybe Text
srvHelpMessage (AppConfig -> ServerSettings
cfgServer AppConfig
app)

    {- Resolve one mount to its binding, or the boot errors that block it. Both the
    credential reference and the adapter are checked even when one already failed,
    so a mount missing both reports both in one run rather than one at a time. The
    packument-serve dependencies are projected from the mount ecosystem's registered
    adapter ('adapterFor'), so a mount whose ecosystem has none is the missing-adapter
    error rather than a half-wired mount; the resolved publish dependencies (shared
    across mounts) are passed to the resolver so the binding carries the first-party
    publish wiring. -}
    bindingFor :: Maybe PublishDeps -> Mount -> MountConfig -> IO (Either [BootError] MountBinding)
    bindingFor :: Maybe PublishDeps
-> Mount -> MountConfig -> IO (Either [BootError] MountBinding)
bindingFor Maybe PublishDeps
pubDeps Mount
mount MountConfig
mcfg =
        case Ecosystem -> Maybe RegistryAdapter
adapterFor Ecosystem
eco of
            -- No adapter for this ecosystem: there is nothing to build deps from, and
            -- no mount to bind. 'validateComposition' already reported the missing
            -- adapter; only the credential reference is still this mount's to check.
            Maybe RegistryAdapter
Nothing -> Either [BootError] MountBinding
-> IO (Either [BootError] MountBinding)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([BootError] -> Either [BootError] MountBinding
forall a b. a -> Either a b
Left (Maybe BootError -> [BootError]
forall a. Maybe a -> [a]
maybeToList (CredentialProviders -> Mount -> Maybe BootError
credentialError CredentialProviders
providers Mount
mount)))
            Just RegistryAdapter
adapter -> do
                deps <- RegistryAdapter -> Mount -> MountConfig -> IO PackumentDeps
packumentDepsFor RegistryAdapter
adapter Mount
mount MountConfig
mcfg
                pure $ case (credentialError providers mount, resolveAdapter eco deps pubDeps) of
                    (Maybe BootError
Nothing, Just MountBinding
binding) -> MountBinding -> Either [BootError] MountBinding
forall a b. b -> Either a b
Right MountBinding
binding
                    (Maybe BootError
mCredErr, Maybe MountBinding
mBinding) ->
                        [BootError] -> Either [BootError] MountBinding
forall a b. a -> Either a b
Left (Maybe BootError -> [BootError]
forall a. Maybe a -> [a]
maybeToList Maybe BootError
mCredErr [BootError] -> [BootError] -> [BootError]
forall a. Semigroup a => a -> a -> a
<> [Ecosystem -> BootError
MissingAdapter Ecosystem
eco | Maybe MountBinding -> Bool
forall a. Maybe a -> Bool
isNothing Maybe MountBinding
mBinding])
      where
        eco :: Ecosystem
eco = Mount -> Ecosystem
mountEcosystem Mount
mount

    {- Build a mount's 'PackumentDeps' from its ecosystem's registered adapter, its
    registries, resolved rules, the inbound edge token, the injected clock, and the
    operator help message. The ecosystem-shaped fields (the metadata client
    constructor, the artifact request builders, the packument assembly) are the
    adapter's capability fields carried over unchanged; everything else is the
    mount's configuration. The mount's externally-visible base URL drives the
    @dist.tarball@ rewrite: an __absolute__ URL under @ECLUSE_SERVER__PUBLIC_URL@
    (@{public}\/npm\/{pkg}\/-\/{file}@) when one is configured, so an @npm@ client
    fetches the artifact back through the proxy on the gated path; otherwise the
    relative prefix path (@\/npm@), retained for compatibility -- but note @npm@
    cannot consume a relative @dist.tarball@ (it reads a leading slash as a @file:@
    path), so a real install path must set @ECLUSE_SERVER__PUBLIC_URL@ (see @mountBaseUrl@
    and @docs\/architecture\/web-layer.md@ → "Multi-ecosystem mounts"). -}
    packumentDepsFor :: RegistryAdapter -> Mount -> MountConfig -> IO PackumentDeps
    packumentDepsFor :: RegistryAdapter -> Mount -> MountConfig -> IO PackumentDeps
packumentDepsFor RegistryAdapter
adapter Mount
mount MountConfig
mcfg = do
        -- Prepare the resolved policy into the engine's runtime rules, closing the
        -- injected 'RuleDeps' into them; an effectful rule (AllowIfRemediatesCve)
        -- gets its resilience policy and breaker allocated here, once per mount.
        -- The same RuleDeps' non-pinning advisory-ETag reader is bridged onto the
        -- deps below, since the serve gate is where the per-request EvalContext is built.
        let ruleDeps :: RuleDeps
ruleDeps = Ecosystem -> RuleDeps
ruleDepsFor (Mount -> Ecosystem
mountEcosystem Mount
mount)
        prepared <- RuleDeps -> [PrecededRule] -> IO [PreparedRule]
prepare RuleDeps
ruleDeps (Mount -> [PrecededRule]
mountPolicy Mount
mount)
        let regs = Mount -> MountRegistries
mountRegistries Mount
mount
        pure
            PackumentDeps
                { pdPrivateBaseUrl = registryUrlText <$> regPrivateUpstream regs
                , pdPublicBaseUrl = registryUrlText (regPublicUpstream regs)
                , pdMountBaseUrl = mountBaseUrl (srvPublicUrl (cfgServer app)) (mountEcosystem mount)
                , pdMirror = maybe NoMirrorWrite (MirrorOnAdmit . registryUrlText . mtUrl) (regMirrorTarget regs)
                , pdRules = prepared
                , -- The operator-configured ranges extending the fixed internal-range block on
                  -- the dist.tarball host gate; the same list applies to every mount, since which
                  -- internal ranges exist on an operator's network is a deployment-wide fact.
                  pdAdditionalBlockedRanges = egrAdditionalBlockedRanges (cfgEgress app)
                , -- The tarball-host gate's mount-constant inputs (allowlist + private and
                  -- public hosts), extracted once here so the hot artifact path parses no
                  -- URL and rebuilds no host set per request.
                  pdTarballHostGate =
                    tarballHostGate
                        (artifactHosts (adapterArtifact adapter))
                        (registryUrlText <$> regPrivateUpstream regs)
                        (registryUrlText (regPublicUpstream regs))
                        (registryUrlText . mtUrl <$> regMirrorTarget regs)
                , pdLimits = limits
                , pdInboundToken = srvAuthToken (cfgServer app)
                , pdNow = clock
                , pdAdvisoryEtag = rdCurrentAdvisoryEtag ruleDeps
                , pdHelp = helpMessage
                , -- The global public-integrity admission floor, validated at config
                  -- load, carried onto every mount's deps so the public gate refuses
                  -- a below-floor version.
                  pdMinIntegrity = intMinPublic (cfgIntegrity app)
                , -- The trusted-integrity admission floor: the global default
                  -- (SHA-256, loosenable below it), refined per mount so a legacy
                  -- registry's loosening never leaks onto a neighbouring mount.
                  pdMinTrustedIntegrity = fromMaybe (intMinTrusted (cfgIntegrity app)) (mntMinTrustedIntegrity mcfg)
                , -- The cross-upstream divergence policy: the global default
                  -- (warn), refined per mount for the same reason.
                  pdDivergencePolicy = fromMaybe (intDivergencePolicy (cfgIntegrity app)) (mntDivergencePolicy mcfg)
                , pdNewMetadataClient = metadataNewClient (adapterMetadata adapter)
                , pdBuildArtifactRequestByFile = artifactByFile (adapterArtifact adapter)
                , pdBuildArtifactRequestByUrl = artifactByUrl (adapterArtifact adapter)
                , pdAssemble = metadataAssemble (adapterMetadata adapter)
                , pdSerialise = metadataSerialise (adapterMetadata adapter)
                , pdEgressUrl = mkRegistryUrl
                }

-- The credential reference of a mount: an error when a mirrored mount's write
-- backend is not initialised, nothing when it resolves. A serve-only mount never
-- writes, so it references no provider and can never fail here.
credentialError :: CredentialProviders -> Mount -> Maybe BootError
credentialError :: CredentialProviders -> Mount -> Maybe BootError
credentialError CredentialProviders
providers Mount
mount = case MountRegistries -> Maybe MirrorTarget
regMirrorTarget (Mount -> MountRegistries
mountRegistries Mount
mount) of
    Maybe MirrorTarget
Nothing -> Maybe BootError
forall a. Maybe a
Nothing
    Just MirrorTarget
_ ->
        if Mount -> Ecosystem
mountEcosystem Mount
mount Ecosystem -> Set Ecosystem -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` CredentialProviders -> Set Ecosystem
initializedEcosystems CredentialProviders
providers
            then Maybe BootError
forall a. Maybe a
Nothing
            else BootError -> Maybe BootError
forall a. a -> Maybe a
Just (Ecosystem -> BootError
UnresolvedCredential (Mount -> Ecosystem
mountEcosystem Mount
mount))

-- A mount's externally-visible base URL for the dist.tarball rewrite. Absolute
-- under ECLUSE_SERVER__PUBLIC_URL when set (so a served tarball is a full URL an npm
-- client can fetch); otherwise the relative prefix path, retained for
-- compatibility. A trailing slash on the configured URL is dropped so the join
-- with the leading-slash mount path yields exactly one separator.
mountBaseUrl :: Maybe Url -> Ecosystem -> Text
mountBaseUrl :: Maybe Url -> Ecosystem -> Text
mountBaseUrl Maybe Url
publicUrl Ecosystem
eco =
    case Maybe Url
publicUrl of
        Maybe Url
Nothing -> Ecosystem -> Text
mountBasePath Ecosystem
eco
        Just Url
public -> (Char -> Bool) -> Text -> Text
T.dropWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/') (Url -> Text
unUrl Url
public) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Ecosystem -> Text
mountBasePath Ecosystem
eco

-- The mount's externally-visible base path, derived from its ecosystem prefix
-- (@npm@ → @\/npm@): a leading slash and the prefix segments joined, so it is the
-- relative path a client's registry endpoint maps onto.
mountBasePath :: Ecosystem -> Text
mountBasePath :: Ecosystem -> Text
mountBasePath Ecosystem
eco = Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
"/" (NonEmpty Text -> [Text]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Ecosystem -> NonEmpty Text
prefixFor Ecosystem
eco))

{- | The pure structural validation a boot enforces beyond 'Ecluse.Config.loadConfig',
shared with @ecluse check-config@ so the checker can never pass a configuration the
proxy refuses: a served mount whose ecosystem has no registered adapter
('MissingAdapter'), and the publish policy of every configured publication target
('PublishAllowMissing', 'PublishStaticCredentialNeedsEdge'). Pure and
side-effect-free: no provider is initialised and no credential minted -- the
mirrored-mount credential expectations are already structural on 'Config' itself
(each mirrored mount carries the credential 'Ecluse.Config.loadConfig' derived from
its target). Only the provider-initialisation check ('UnresolvedCredential') stays
with 'composeBindings', which consumes this same function for everything else.
-}
validateComposition :: Config -> [BootError]
validateComposition :: Config -> [BootError]
validateComposition Config
config = [BootError]
missingAdapters [BootError] -> [BootError] -> [BootError]
forall a. Semigroup a => a -> a -> a
<> [BootError]
publishPolicyErrors
  where
    app :: AppConfig
app = Config -> AppConfig
configApp Config
config
    missingAdapters :: [BootError]
missingAdapters =
        [Ecosystem -> BootError
MissingAdapter Ecosystem
eco | Ecosystem
eco <- Map Ecosystem Mount -> [Ecosystem]
forall k a. Map k a -> [k]
Map.keys (Config -> Map Ecosystem Mount
configMounts Config
config), Maybe RegistryAdapter -> Bool
forall a. Maybe a -> Bool
isNothing (Ecosystem -> Maybe RegistryAdapter
adapterFor Ecosystem
eco)]
    publishPolicyErrors :: [BootError]
publishPolicyErrors =
        [[BootError]] -> [BootError]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ Ecosystem -> MountConfig -> Maybe Secret -> [BootError]
publishBootErrors Ecosystem
eco MountConfig
mcfg (ServerSettings -> Maybe Secret
srvAuthToken (AppConfig -> ServerSettings
cfgServer AppConfig
app))
            | (Ecosystem
eco, MountConfig
mcfg) <- Map Ecosystem MountConfig -> [(Ecosystem, MountConfig)]
forall k a. Map k a -> [(k, a)]
Map.toAscList (AppConfig -> Map Ecosystem MountConfig
cfgMounts AppConfig
app)
            , Maybe RegistryUrl -> Bool
forall a. Maybe a -> Bool
isJust (MountConfig -> Maybe RegistryUrl
mntPublicationTarget MountConfig
mcfg)
            ]

{- | Build the first-party publish dependencies from the environment layer, shared
across the (single-ecosystem) mounts: 'Nothing' when no publication target is
configured (the publish path is off -- a @PUT \/{pkg}@ is then @405@) or when the
ecosystem has no adapter (the boot fails on the missing adapter regardless). The
publish policy itself is 'validateComposition''s to refuse; construction here
assumes it and is only consumed on an error-free compose. The target's URL, the
scopes, and the static fallback credential are the publish env layer; the response
bounds ('Limits') and help message are shared with the read paths and passed in;
the relay, the name canonicaliser, and the declared-name extractor are the
ecosystem's own capability, projected from its registered adapter.
-}
publishDepsFor :: Maybe RegistryAdapter -> AppConfig -> MountConfig -> Limits -> Maybe PublishBudget -> Maybe HelpMessage -> Maybe PublishDeps
publishDepsFor :: Maybe RegistryAdapter
-> AppConfig
-> MountConfig
-> Limits
-> Maybe PublishBudget
-> Maybe HelpMessage
-> Maybe PublishDeps
publishDepsFor Maybe RegistryAdapter
mAdapter AppConfig
app MountConfig
mcfg Limits
limits Maybe PublishBudget
publishBudget Maybe HelpMessage
helpMessage = do
    url <- MountConfig -> Maybe RegistryUrl
mntPublicationTarget MountConfig
mcfg
    adapter <- mAdapter
    budget <- publishBudget
    pure
        PublishDeps
            { pubTargetUrl = registryUrlText url
            , pubScopes = mntPublishAllow mcfg
            , pubStaticToken = mntPublicationTargetToken mcfg
            , pubInboundToken = inboundToken
            , pubLimits = limits
            , pubBodyBudget = pbBodyBudget budget
            , pubMaxRequestBytes = pbMaxRequestBytes budget
            , pubHelp = helpMessage
            , pubRelayPublish = publishRelay (adapterPublish adapter)
            , pubCanonicaliseName = publishCanonicaliseName (adapterPublish adapter)
            , pubDeclaredNames = publishDeclaredNames (adapterPublish adapter)
            }
  where
    inboundToken :: Maybe Secret
    inboundToken :: Maybe Secret
inboundToken = ServerSettings -> Maybe Secret
srvAuthToken (AppConfig -> ServerSettings
cfgServer AppConfig
app)

-- The accumulated fail-loud publish boot errors for a configured publication
-- target: a missing publish-scope allow-list, and a static publish credential
-- without a verifiable inbound edge, reported together.
publishBootErrors :: Ecosystem -> MountConfig -> Maybe Secret -> [BootError]
publishBootErrors :: Ecosystem -> MountConfig -> Maybe Secret -> [BootError]
publishBootErrors Ecosystem
eco MountConfig
mcfg Maybe Secret
inboundToken = [Maybe BootError] -> [BootError]
forall a. [Maybe a] -> [a]
catMaybes [Maybe BootError
scopesError, Maybe BootError
edgeError]
  where
    scopesError, edgeError :: Maybe BootError
    scopesError :: Maybe BootError
scopesError
        | [Scope] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (MountConfig -> [Scope]
mntPublishAllow MountConfig
mcfg) = BootError -> Maybe BootError
forall a. a -> Maybe a
Just (Ecosystem -> BootError
PublishAllowMissing Ecosystem
eco)
        | Bool
otherwise = Maybe BootError
forall a. Maybe a
Nothing
    edgeError :: Maybe BootError
edgeError
        | Maybe Secret -> Bool
forall a. Maybe a -> Bool
isJust (MountConfig -> Maybe Secret
mntPublicationTargetToken MountConfig
mcfg) Bool -> Bool -> Bool
&& Maybe Secret -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Secret
inboundToken = BootError -> Maybe BootError
forall a. a -> Maybe a
Just (Ecosystem -> BootError
PublishStaticCredentialNeedsEdge Ecosystem
eco)
        | Bool
otherwise = Maybe BootError
forall a. Maybe a
Nothing

{- | One ecosystem's resolved __publish__ target: the mirror-target endpoint the
mirror worker writes approved artifacts to, paired with the credential provider
that mints its bearer token.

This is the publish side of the per-ecosystem composition (the serve side is the
mount's 'PackumentDeps'). The worker's single consumer builds a registry-protocol
client from these -- the endpoint as its base URL, the provider's token as its
bearer -- so the publish client is resolved here at the composition root rather than
re-derived per request.
-}
data PublishTarget = PublishTarget
    { PublishTarget -> Ecosystem
ptEcosystem :: Ecosystem
    -- ^ The ecosystem this publish target serves.
    , PublishTarget -> Text
ptMirrorUrl :: Text
    -- ^ The mirror-target endpoint approved artifacts are published to.
    , PublishTarget -> CredentialProvider
ptCredentials :: CredentialProvider
    -- ^ The provider minting the mirror-target write token.
    }

{- | Resolve each configured mount to its publish target, or the aggregated boot
errors. The publish side of 'planMounts': it validates the same config and resolves
each mount's mirror-target endpoint and write credential, so the worker's publish
client can be built at the composition root.

An unresolved credential reference is the same fail-loud boot error 'composeBindings'
reports for the serve side, so the two surfaces never disagree on what is wired.
-}
planPublishTargets ::
    CredentialProviders ->
    Config ->
    Either [BootError] [PublishTarget]
planPublishTargets :: CredentialProviders -> Config -> Either [BootError] [PublishTarget]
planPublishTargets = CredentialProviders -> Config -> Either [BootError] [PublishTarget]
composePublishTargets

-- Resolve every mirrored mount's publish target from a validated config,
-- aggregating an unresolved-credential error per mount (the same check
-- 'composeBindings' applies). A serve-only mount publishes nothing and
-- contributes no target.
composePublishTargets ::
    CredentialProviders ->
    Config ->
    Either [BootError] [PublishTarget]
composePublishTargets :: CredentialProviders -> Config -> Either [BootError] [PublishTarget]
composePublishTargets CredentialProviders
providers Config
config =
    case [Either [BootError] PublishTarget]
-> ([[BootError]], [PublishTarget])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ((Mount -> Maybe (Either [BootError] PublishTarget))
-> [Mount] -> [Either [BootError] PublishTarget]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (CredentialProviders
-> Mount -> Maybe (Either [BootError] PublishTarget)
publishTargetFor CredentialProviders
providers) (Map Ecosystem Mount -> [Mount]
forall k a. Map k a -> [a]
Map.elems (Config -> Map Ecosystem Mount
configMounts Config
config))) of
        ([], [PublishTarget]
targets) -> [PublishTarget] -> Either [BootError] [PublishTarget]
forall a b. b -> Either a b
Right [PublishTarget]
targets
        ([[BootError]]
errs, [PublishTarget]
_) -> [BootError] -> Either [BootError] [PublishTarget]
forall a b. a -> Either a b
Left ([[BootError]] -> [BootError]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[BootError]]
errs)

-- One mirrored mount's publish target: its mirror-target endpoint paired with the
-- initialised write provider, or the same unresolved-credential boot error the
-- serve side reports. 'Nothing' for a serve-only mount (no write, no target).
publishTargetFor :: CredentialProviders -> Mount -> Maybe (Either [BootError] PublishTarget)
publishTargetFor :: CredentialProviders
-> Mount -> Maybe (Either [BootError] PublishTarget)
publishTargetFor CredentialProviders
providers Mount
mount = do
    target <- MountRegistries -> Maybe MirrorTarget
regMirrorTarget (Mount -> MountRegistries
mountRegistries Mount
mount)
    pure $ case lookupProvider (mountEcosystem mount) providers of
        Just CredentialProvider
provider ->
            PublishTarget -> Either [BootError] PublishTarget
forall a b. b -> Either a b
Right
                PublishTarget
                    { ptEcosystem :: Ecosystem
ptEcosystem = Mount -> Ecosystem
mountEcosystem Mount
mount
                    , ptMirrorUrl :: Text
ptMirrorUrl = RegistryUrl -> Text
registryUrlText (MirrorTarget -> RegistryUrl
mtUrl MirrorTarget
target)
                    , ptCredentials :: CredentialProvider
ptCredentials = CredentialProvider
provider
                    }
        Maybe CredentialProvider
Nothing ->
            [BootError] -> Either [BootError] PublishTarget
forall a b. a -> Either a b
Left [Ecosystem -> BootError
UnresolvedCredential (Mount -> Ecosystem
mountEcosystem Mount
mount)]