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

{- | The wiring half of the boot's effectful tier: turn the 'ValidatedPlan' that
"Ecluse.Composition.Plan" resolves and "Ecluse.Composition.Validate" clears into the served
'MountBinding's and the worker's publish targets. Every refusal 'resolveBootWiring' reports needs a
live environment: a writing role mints each mount's mirror-write credential, and every role runs
'Ecluse.Core.Rules.prepare', which allocates per-rule engine state once at boot. That is why this
is 'IO' and why @ecluse check-config@ reaches none of it. 'WiringPorts' carries every capability in,
so a unit test runs the assembly without opening a listener.
-}
module Ecluse.Composition (
    -- * The environment-dependent wiring
    ResolveAdapter,
    WiringPorts (..),
    BootWiring (..),
    resolveBootWiring,

    -- * Boot-time wiring
    planMounts,

    -- * The first-party privilege
    firstPartyName,

    -- * 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 Validation (eitherToValidation, validationToEither)

import Ecluse.Composition.BootError (BootError (..))
import Ecluse.Composition.Credential (
    BuildCredentials,
    CredentialProviders,
    initCredentialProviders,
    initializedEcosystems,
    lookupProvider,
    noCredentialProviders,
 )
import Ecluse.Composition.Endpoints (publicationTargetUrl)
import Ecluse.Composition.MirrorRole (MirrorMintPlan (MintMirrorWrite, SkipMirrorWrite))
import Ecluse.Composition.Validate (
    ValidatedPlan (vpMounts, vpPublications, vpSettings),
    VettedMount (vmAdapter, vmConfig, vmEcosystem, vmMount),
    VettedPublication (vpubFirstParty, vpubStaticToken, vpubTarget),
 )
import Ecluse.Config (
    AppConfig (..),
    EgressSettings (..),
    FirstParty (..),
    IntegritySettings (..),
    MirrorTarget (mtUrl),
    Mount (..),
    MountConfig (..),
    MountIntegrity (..),
    MountRegistries (..),
    ServerSettings (..),
    StoreTag,
    Url,
    regMirrorTarget,
    regPrivateUpstream,
    unUrl,
 )
import Ecluse.Core.Credential (CredentialProvider)
import Ecluse.Core.Credential.Refresh (CredentialReporters)
import Ecluse.Core.Ecosystem (Ecosystem, prefixFor)
import Ecluse.Core.Package (PackageName)
import Ecluse.Core.Registry.Adapter (
    RegistryAdapter,
    adapterArtifact,
    adapterMetadata,
    adapterProjectName,
    adapterPublish,
 )
import Ecluse.Core.Registry.Adapter.Capability (AdapterArtifact (artifactHosts))
import Ecluse.Core.Registry.Npm.Publish (npmPublishAllowed)
import Ecluse.Core.Registry.PyPI.FirstParty (pypiFirstPartyName)
import Ecluse.Core.Rules (RuleDeps, prepare, rdCurrentAdvisoryEtag, rdSourceReporter)
import Ecluse.Core.Rules.Outage (SourceReporter (noteAdmission))
import Ecluse.Core.Security (Limits, maxPublishRequestBytes)
import Ecluse.Core.Security.Egress (RegistryUrl, mkRegistryUrl)
import Ecluse.Core.Server.Admission.Bytes (ByteAdmission)
import Ecluse.Core.Server.Context (MountBinding, PackumentDeps (..), PublishDeps (..))
import Ecluse.Core.Server.Response (HelpMessage, mkHelpMessage)
import Ecluse.Core.Server.Upstream (MirrorServePlan (MirrorOnAdmit, NoMirrorWrite), mountUpstreams)
import Ecluse.Core.Text (stripTrailingSlash)

{- | Resolve an ecosystem's deps to its complete mount, 'Nothing' for an ecosystem this build
ships no adapter for. "Ecluse.Service" holds the one implementation.
-}
type ResolveAdapter = Ecosystem -> PackumentDeps -> Maybe PublishDeps -> Maybe MountBinding

{- | The capabilities the wiring is built through, injected so a unit test runs the boot-time
assembly without opening a listener.
-}
data WiringPorts = WiringPorts
    { WiringPorts -> Ecosystem -> StoreTag -> CredentialReporters
wpReporters :: Ecosystem -> StoreTag -> CredentialReporters
    -- ^ Reporters keyed by the shared credential's canonical ecosystem and store label.
    , WiringPorts -> BuildCredentials
wpBuildCredentials :: BuildCredentials
    -- ^ How this boot builds the mirror-write providers, for the roles that mint them.
    , WiringPorts -> ResolveAdapter
wpResolveAdapter :: ResolveAdapter
    -- ^ The ecosystem-to-binding resolver, 'Nothing' for an ecosystem this build ships no adapter for.
    , WiringPorts -> IO UTCTime
wpClock :: IO UTCTime
    -- ^ The clock every mount's serve path reads.
    , WiringPorts -> Ecosystem -> RuleDeps
wpRuleDeps :: Ecosystem -> RuleDeps
    -- ^ One ecosystem's rule capabilities, including its advisory-database lookup.
    }

{- | What only a live environment settled: the mounts the front door serves, and the publish
targets the worker writes approved artifacts through.
-}
data BootWiring = BootWiring
    { BootWiring -> [MountBinding]
bwBindings :: [MountBinding]
    -- ^ The resolved mounts. A worker-only role builds them for their rules, and serves none.
    , BootWiring -> [PublishTarget]
bwPublishTargets :: [PublishTarget]
    {- ^ One target per mirrored mount, each holding the provider that mints its write token. A
    role that writes nothing plans none.
    -}
    }

{- | Build the boot wiring from the cleared plan, or the refusals only a live environment can
settle. The credential providers stay internal: a mount reaches one through the wiring it produced.
-}
resolveBootWiring :: WiringPorts -> MirrorMintPlan -> Limits -> Maybe PublishBudget -> ValidatedPlan -> IO (Either [BootError] BootWiring)
resolveBootWiring :: WiringPorts
-> MirrorMintPlan
-> Limits
-> Maybe PublishBudget
-> ValidatedPlan
-> IO (Either [BootError] BootWiring)
resolveBootWiring WiringPorts
ports MirrorMintPlan
mintPlan Limits
limits Maybe PublishBudget
publishBudget ValidatedPlan
plan = do
    providersE <- IO (Either [BootError] CredentialProviders)
mintedProviders
    case providersE of
        Left [BootError]
errs -> Either [BootError] BootWiring -> IO (Either [BootError] BootWiring)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([BootError] -> Either [BootError] BootWiring
forall a b. a -> Either a b
Left [BootError]
errs)
        Right CredentialProviders
providers -> do
            bindingsE <- ResolveAdapter
-> IO UTCTime
-> (Ecosystem -> RuleDeps)
-> MirrorMintPlan
-> CredentialProviders
-> Limits
-> Maybe PublishBudget
-> ValidatedPlan
-> IO (Either [BootError] [MountBinding])
planMounts (WiringPorts -> ResolveAdapter
wpResolveAdapter WiringPorts
ports) (WiringPorts -> IO UTCTime
wpClock WiringPorts
ports) (WiringPorts -> Ecosystem -> RuleDeps
wpRuleDeps WiringPorts
ports) MirrorMintPlan
mintPlan CredentialProviders
providers Limits
limits Maybe PublishBudget
publishBudget ValidatedPlan
plan
            -- The serve side and the publish side read the same providers independently, so
            -- 'Validation' reports both rather than the mounts' refusals alone.
            pure . validationToEither $
                BootWiring
                    <$> eitherToValidation bindingsE
                    <*> eitherToValidation (planPublishTargets mintPlan providers plan)
  where
    -- A minting role mints once, eagerly, and before either group above consumes the providers,
    -- so a misconfigured identity fails at boot rather than on the first write.
    mintedProviders :: IO (Either [BootError] CredentialProviders)
    mintedProviders :: IO (Either [BootError] CredentialProviders)
mintedProviders = case MirrorMintPlan
mintPlan of
        MirrorMintPlan
SkipMirrorWrite -> Either [BootError] CredentialProviders
-> IO (Either [BootError] CredentialProviders)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CredentialProviders -> Either [BootError] CredentialProviders
forall a b. b -> Either a b
Right CredentialProviders
noCredentialProviders)
        MirrorMintPlan
MintMirrorWrite -> BuildCredentials
-> (Ecosystem -> StoreTag -> CredentialReporters)
-> [Mount]
-> IO (Either [BootError] CredentialProviders)
initCredentialProviders (WiringPorts -> BuildCredentials
wpBuildCredentials WiringPorts
ports) (WiringPorts -> Ecosystem -> StoreTag -> CredentialReporters
wpReporters WiringPorts
ports) ((VettedMount -> Mount) -> [VettedMount] -> [Mount]
forall a b. (a -> b) -> [a] -> [b]
map VettedMount -> Mount
vmMount (ValidatedPlan -> [VettedMount]
vpMounts ValidatedPlan
plan))

{- | The publish-side byte discipline: the process-wide aggregate admission and the
per-request cap. It exists exactly when a publication target is configured.
-}
data PublishBudget = PublishBudget
    { PublishBudget -> ByteAdmission
pbBodyBudget :: ByteAdmission
    , PublishBudget -> Int
pbMaxRequestBytes :: Int
    }

{- | Turn the boot's cleared plan into the served 'MountBinding's, or every remaining boot error at
once. The caller injects every capability, so this opens no socket, and the 'Limits' arrive resolved.
-}
planMounts ::
    ResolveAdapter ->
    IO UTCTime ->
    (Ecosystem -> RuleDeps) ->
    MirrorMintPlan ->
    CredentialProviders ->
    Limits ->
    Maybe PublishBudget ->
    ValidatedPlan ->
    IO (Either [BootError] [MountBinding])
planMounts :: ResolveAdapter
-> IO UTCTime
-> (Ecosystem -> RuleDeps)
-> MirrorMintPlan
-> CredentialProviders
-> Limits
-> Maybe PublishBudget
-> ValidatedPlan
-> IO (Either [BootError] [MountBinding])
planMounts ResolveAdapter
resolveAdapter IO UTCTime
clock Ecosystem -> RuleDeps
ruleDepsFor MirrorMintPlan
mintPlan CredentialProviders
providers Limits
limits Maybe PublishBudget
publishBudget ValidatedPlan
plan = do
    bindingResults <- (VettedMount -> IO (Either [BootError] MountBinding))
-> [VettedMount] -> 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 VettedMount -> IO (Either [BootError] MountBinding)
bindingFor (ValidatedPlan -> [VettedMount]
vpMounts ValidatedPlan
plan)
    pure $ case partitionEithers bindingResults of
        ([], [MountBinding]
bindings) -> [MountBinding] -> Either [BootError] [MountBinding]
forall a b. b -> Either a b
Right [MountBinding]
bindings
        ([[BootError]]
errs, [MountBinding]
_) -> [BootError] -> Either [BootError] [MountBinding]
forall a b. a -> Either a b
Left ([[BootError]] -> [BootError]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[BootError]]
errs)
  where
    app :: AppConfig
    app :: AppConfig
app = ValidatedPlan -> AppConfig
vpSettings ValidatedPlan
plan

    ctx :: WiringContext
    ctx :: WiringContext
ctx =
        WiringContext
            { wcApp :: AppConfig
wcApp = AppConfig
app
            , wcLimits :: Limits
wcLimits = Limits
limits
            , wcClock :: IO UTCTime
wcClock = IO UTCTime
clock
            , wcRuleDeps :: Ecosystem -> RuleDeps
wcRuleDeps = Ecosystem -> RuleDeps
ruleDepsFor
            , wcPublishBudget :: Maybe PublishBudget
wcPublishBudget = Maybe PublishBudget
publishBudget
            , -- Derived from the environment layer like the inbound token, and resolved once, so
              -- every mount's denials carry the same message.
              wcHelp :: Maybe HelpMessage
wcHelp = 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)
            }

    {- The plan cleared the adapter, so only the credential reference and the injected resolver
    are still this mount's to check, and it reports both in one run. -}
    bindingFor :: VettedMount -> IO (Either [BootError] MountBinding)
    bindingFor :: VettedMount -> IO (Either [BootError] MountBinding)
bindingFor VettedMount
vetted = do
        deps <- WiringContext
-> RegistryAdapter -> Mount -> MountConfig -> IO PackumentDeps
packumentDepsFor WiringContext
ctx (VettedMount -> RegistryAdapter
vmAdapter VettedMount
vetted) (VettedMount -> Mount
vmMount VettedMount
vetted) (VettedMount -> MountConfig
vmConfig VettedMount
vetted)
        pure $ case (credentialError mintPlan providers (vmMount vetted), resolveAdapter eco deps (mountPublishDeps ctx plan vetted)) 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 = VettedMount -> Ecosystem
vmEcosystem VettedMount
vetted

{- The deployment-wide inputs every mount's deps are built from. Each is resolved once for the
whole pass, so two mounts cannot be wired against different values of one of them. -}
data WiringContext = WiringContext
    { WiringContext -> AppConfig
wcApp :: AppConfig
    , WiringContext -> Limits
wcLimits :: Limits
    , WiringContext -> IO UTCTime
wcClock :: IO UTCTime
    , WiringContext -> Ecosystem -> RuleDeps
wcRuleDeps :: Ecosystem -> RuleDeps
    , WiringContext -> Maybe PublishBudget
wcPublishBudget :: Maybe PublishBudget
    , WiringContext -> Maybe HelpMessage
wcHelp :: Maybe HelpMessage
    }

-- A mount the pass cleared no publication for leaves @PUT \/{pkg}@ answering @405@.
mountPublishDeps :: WiringContext -> ValidatedPlan -> VettedMount -> Maybe PublishDeps
mountPublishDeps :: WiringContext -> ValidatedPlan -> VettedMount -> Maybe PublishDeps
mountPublishDeps WiringContext
ctx ValidatedPlan
plan VettedMount
vetted =
    Ecosystem
-> Map Ecosystem VettedPublication -> Maybe VettedPublication
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (VettedMount -> Ecosystem
vmEcosystem VettedMount
vetted) (ValidatedPlan -> Map Ecosystem VettedPublication
vpPublications ValidatedPlan
plan)
        Maybe VettedPublication
-> (VettedPublication -> Maybe PublishDeps) -> Maybe PublishDeps
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= RegistryAdapter
-> AppConfig
-> Limits
-> Maybe PublishBudget
-> Maybe HelpMessage
-> VettedPublication
-> Maybe PublishDeps
publishDepsFor (VettedMount -> RegistryAdapter
vmAdapter VettedMount
vetted) (WiringContext -> AppConfig
wcApp WiringContext
ctx) (WiringContext -> Limits
wcLimits WiringContext
ctx) (WiringContext -> Maybe PublishBudget
wcPublishBudget WiringContext
ctx) (WiringContext -> Maybe HelpMessage
wcHelp WiringContext
ctx)

-- The ecosystem-shaped fields are the adapter's own records, carried whole, and the rest is the
-- mount's configuration. @pdMountBaseUrl@ owns the @dist.tarball@ base.
packumentDepsFor :: WiringContext -> RegistryAdapter -> Mount -> MountConfig -> IO PackumentDeps
packumentDepsFor :: WiringContext
-> RegistryAdapter -> Mount -> MountConfig -> IO PackumentDeps
packumentDepsFor WiringContext
ctx RegistryAdapter
adapter Mount
mount MountConfig
mcfg = do
    -- 'prepare' allocates an effectful rule's resilience policy and breaker once per mount.
    -- 'pdAdvisoryEtag' reads the current ETag through those same 'RuleDeps', so no generation is pinned at boot.
    let ruleDeps :: RuleDeps
ruleDeps = WiringContext -> Ecosystem -> RuleDeps
wcRuleDeps WiringContext
ctx (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
        app = WiringContext -> AppConfig
wcApp WiringContext
ctx
    pure
        PackumentDeps
            { pdUpstreams =
                mountUpstreams
                    (artifactHosts (adapterArtifact adapter))
                    (regPrivateUpstream regs)
                    (regPublicUpstream regs)
                    (maybe NoMirrorWrite (MirrorOnAdmit . mtUrl) (regMirrorTarget regs))
            , -- Deny by default: a mount that declares no namespaces owns no first-party name.
              pdFirstParty = maybe (const False) firstPartyName (mntFirstParty mcfg)
            , pdMountBaseUrl = mountBaseUrl (srvPublicUrl (cfgServer app)) (mountEcosystem mount)
            , pdRules = prepared
            , -- Operator ranges extending the fixed internal-range block on the @dist.tarball@ host
              -- gate. One list for every mount: internal ranges are a deployment-wide fact.
              pdAdditionalBlockedRanges = egrAdditionalBlockedRanges (cfgEgress app)
            , pdLimits = wcLimits ctx
            , pdInboundToken = srvAuthToken (cfgServer app)
            , pdNow = wcClock ctx
            , pdAdvisoryEtag = rdCurrentAdvisoryEtag ruleDeps
            , pdNoteAdmission = noteAdmission (rdSourceReporter ruleDeps)
            , pdHelp = wcHelp ctx
            , pdMinIntegrity = intMinPublic (cfgIntegrity app)
            , -- Refined per mount, so a legacy registry's loosening below the global default
              -- never leaks onto a neighbouring mount.
              pdMinTrustedIntegrity = fromMaybe (intMinTrusted (cfgIntegrity app)) (miMinTrusted (mntIntegrity mcfg))
            , pdMetadata = adapterMetadata adapter
            , pdArtifact = adapterArtifact adapter
            , pdEgressUrl = mkRegistryUrl
            }

-- A role that mints nothing references nothing, and a mount with no mirror target never writes,
-- so neither can fail here.
credentialError :: MirrorMintPlan -> CredentialProviders -> Mount -> Maybe BootError
credentialError :: MirrorMintPlan -> CredentialProviders -> Mount -> Maybe BootError
credentialError MirrorMintPlan
mintPlan CredentialProviders
providers Mount
mount = case (MirrorMintPlan
mintPlan, MountRegistries -> Maybe MirrorTarget
regMirrorTarget (Mount -> MountRegistries
mountRegistries Mount
mount)) of
    (MirrorMintPlan
SkipMirrorWrite, Maybe MirrorTarget
_) -> Maybe BootError
forall a. Maybe a
Nothing
    (MirrorMintPlan
MintMirrorWrite, Maybe MirrorTarget
Nothing) -> Maybe BootError
forall a. Maybe a
Nothing
    (MirrorMintPlan
MintMirrorWrite, 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))

-- Absolute under ECLUSE_SERVER__PUBLIC_URL when set, otherwise the relative prefix path.
-- A real install path must set it: an npm client reads a leading slash as a @file:@ path.
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 -> Text -> Text
stripTrailingSlash (Url -> Text
unUrl Url
public) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Ecosystem -> Text
mountBasePath Ecosystem
eco

-- The relative path a client's registry endpoint maps onto (npm becomes /npm).
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))

{- | Build the first-party publish dependencies from a cleared publication. 'Nothing' without a
publish budget, which the memory plan allocates exactly when some mount publishes.
-}
publishDepsFor :: RegistryAdapter -> AppConfig -> Limits -> Maybe PublishBudget -> Maybe HelpMessage -> VettedPublication -> Maybe PublishDeps
publishDepsFor :: RegistryAdapter
-> AppConfig
-> Limits
-> Maybe PublishBudget
-> Maybe HelpMessage
-> VettedPublication
-> Maybe PublishDeps
publishDepsFor RegistryAdapter
adapter AppConfig
app Limits
limits Maybe PublishBudget
publishBudget Maybe HelpMessage
helpMessage VettedPublication
publication = do
    budget <- Maybe PublishBudget
publishBudget
    -- An ecosystem this build writes nothing for carries no publish capability, so the mount's
    -- publish route stays opt-out and answers its documented refusal.
    publish <- adapterPublish adapter
    pure
        PublishDeps
            { pubTargetUrl = publicationTargetUrl (vpubTarget publication)
            , pubAllowed = firstPartyName (vpubFirstParty publication)
            , pubStaticToken = vpubStaticToken publication
            , pubInboundToken = srvAuthToken (cfgServer app)
            , pubLimits = limits{maxPublishRequestBytes = pbMaxRequestBytes budget}
            , pubBodyBudget = pbBodyBudget budget
            , pubHelp = helpMessage
            , pubProjectName = adapterProjectName adapter
            , pubAdapter = publish
            }

{- | Whether a name belongs to a namespace this deployment owns. Each arm derives the one predicate every
consumer of the privilege reads, so none can disagree about which names are privileged.
-}
firstPartyName :: FirstParty -> PackageName -> Bool
firstPartyName :: FirstParty -> PackageName -> Bool
firstPartyName = \case
    FirstPartyNpmScopes NonEmpty Scope
scopes -> [Scope] -> PackageName -> Bool
npmPublishAllowed (NonEmpty Scope -> [Scope]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty Scope
scopes)
    FirstPartyPyPI NonEmpty PyPIFirstParty
entries -> NonEmpty PyPIFirstParty -> PackageName -> Bool
pypiFirstPartyName NonEmpty PyPIFirstParty
entries

{- | One ecosystem's resolved publish target: the endpoint the worker writes approved
artifacts to, and the provider that mints its bearer token. Resolved once, not per request.
-}
data PublishTarget = PublishTarget
    { PublishTarget -> Ecosystem
ptEcosystem :: Ecosystem
    -- ^ The ecosystem this publish target serves.
    , PublishTarget -> RegistryUrl
ptMirrorUrl :: RegistryUrl
    -- ^ The mirror-target endpoint the worker publishes approved artifacts to.
    , PublishTarget -> CredentialProvider
ptCredentials :: CredentialProvider
    -- ^ The provider minting the mirror-target write token.
    }

{- | Resolve each cleared mount to its publish target, or the aggregated boot errors. A role that
mints no write credential plans no target, because nothing in its process writes.
-}
planPublishTargets ::
    MirrorMintPlan ->
    CredentialProviders ->
    ValidatedPlan ->
    Either [BootError] [PublishTarget]
planPublishTargets :: MirrorMintPlan
-> CredentialProviders
-> ValidatedPlan
-> Either [BootError] [PublishTarget]
planPublishTargets MirrorMintPlan
mintPlan CredentialProviders
providers ValidatedPlan
plan = case MirrorMintPlan
mintPlan of
    MirrorMintPlan
SkipMirrorWrite -> [PublishTarget] -> Either [BootError] [PublishTarget]
forall a b. b -> Either a b
Right []
    MirrorMintPlan
MintMirrorWrite ->
        case [Either [BootError] PublishTarget]
-> ([[BootError]], [PublishTarget])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ((VettedMount -> Maybe (Either [BootError] PublishTarget))
-> [VettedMount] -> [Either [BootError] PublishTarget]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (CredentialProviders
-> Mount -> Maybe (Either [BootError] PublishTarget)
publishTargetFor CredentialProviders
providers (Mount -> Maybe (Either [BootError] PublishTarget))
-> (VettedMount -> Mount)
-> VettedMount
-> Maybe (Either [BootError] PublishTarget)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VettedMount -> Mount
vmMount) (ValidatedPlan -> [VettedMount]
vpMounts ValidatedPlan
plan)) 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)

-- 'Nothing' for a serve-only mount, which writes nothing and has no target. A
-- mirrored mount without an initialised provider is the unresolved-credential error.
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 :: RegistryUrl
ptMirrorUrl = 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)]