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

{- | The boot's effectful planning phase: take the cleared 'BootPlan' and yield the
'ExecutablePlan' the booting role assembles its runtime from.

Every role plans through here, so a refusal only a live environment can settle is spent at one
gate whatever the role, and holding an 'ExecutablePlan' means nothing downstream refuses to
boot. A listener that fails to bind is a runtime fault for supervision, not a refusal.
@ecluse check-config@ makes no cloud call, so it stops at the 'BootPlan' and never reaches here.
-}
module Ecluse.Composition.Executable (
    ExecutablePlan (epBootPlan, epRoleWiring),
    RoleWiring (..),
    MirrorWiring (mwRole, mwBootWiring, mwCveSync, mwQueue, mwDeferredMetrics),
    PrunerWiring (pwBudget, pwCveSync, pwDeferredMetrics, pwMounts),
    BuildMirrorQueue,
    BuildCredentials,
    planExecutable,
) where

import Data.Time (getCurrentTime)
import Katip (LogEnv)
import Validation (Validation (Failure), eitherToValidation, validationToEither)

import Data.Map.Strict qualified as Map

import Ecluse.Composition (
    BootWiring,
    PublishBudget (PublishBudget, pbBodyBudget, pbMaxRequestBytes),
    ResolveAdapter,
    WiringPorts (WiringPorts, wpBuildCredentials, wpClock, wpReporters, wpResolveAdapter, wpRuleDeps),
    firstPartyName,
    resolveBootWiring,
 )
import Ecluse.Composition.BootError (
    Advisory,
    BootError (AdvisorySyncUnavailable, MirrorQueueUnavailable, PilotWithoutEcosystem, StoreMaintenanceUnavailable),
    StoreMaintenanceReason (PrivateCacheUnavailable),
    refuseOnThrow,
 )
import Ecluse.Composition.Credential (BuildCredentials, CredentialTarget (..), mirrorBackends, noCredentialProviders, providerLabel)
import Ecluse.Composition.Maintenance (
    BudgetPorts (BudgetPorts, bpGateFor, bpNominalPace, bpOverrides),
    BuildUpstreamProbe,
    ClearedBackend (cbUrl),
    StoreBuilds (sbDeleting, sbObserving, sbProbing),
    StorePorts,
    planStoreMaintenance,
    planStoreMaintenanceFor,
    readUpstreamSafety,
 )
import Ecluse.Composition.MemoryPlan (
    MemoryPlan (mpMaxRequestBytes, mpPublishTenant, mpQueueMemoryMaxDepth),
    PublishTenant (ptAggregateBytes),
 )
import Ecluse.Composition.MirrorQueue (
    MirrorQueuePlan,
    MirrorRuntimePlan (MirrorWith, NoMirroring),
 )
import Ecluse.Composition.MirrorRole (mirrorMintPlan)
import Ecluse.Composition.Plan (
    BootPlan (bpLimits, bpMemoryPlan, bpMirrorRuntime, bpRole, bpS3Endpoint, bpValidated),
 )
import Ecluse.Composition.Types (
    BootRole (BootMirrorPipeline, BootStorePreview, BootStorePruner, BootWithoutPipeline),
    MirrorRole (MirrorOnly, ServeAndMirror, ServeOnly),
 )
import Ecluse.Composition.Validate (
    ValidatedPlan (vpMirrorStores, vpMounts, vpPrivateCaches, vpSettings),
    VettedMount (vmAdapter, vmConfig, vmEcosystem, vmMount),
 )
import Ecluse.Config (AppConfig (cfgAdvisories, cfgDredger), DredgerSettings (drgChunkPause, drgChunkSize, drgQuotaOverrides), Mount (mountPolicy), MountConfig (mntFirstParty, mntPrivateUpstream), PrivateEndpoint, StoreTag, mountAdvisoryAge, mountDatabaseRequirement, mountEpssRequirement)
import Ecluse.Core.Clock (waitSeconds)
import Ecluse.Core.Credential.Refresh (CredentialReporters (CredentialReporters, crBreakerReporter, crRefreshReporter))
import Ecluse.Core.Ecosystem (Ecosystem)
import Ecluse.Core.Package (PackageName)
import Ecluse.Core.Queue (MirrorQueue, noMirrorQueue)
import Ecluse.Core.Registry.Adapter (adapterProjectName)
import Ecluse.Core.Registry.Adapter.Capability (ProjectName)
import Ecluse.Core.Registry.Maintenance (StoreFacts (factBackend), StoreObservation (obFacts, obProbeUpstream))
import Ecluse.Core.Registry.Maintenance.Budget (BudgetPort, QuotaScope, RequestGate, newBudgetMeter)
import Ecluse.Core.Registry.Sweep.Pacing (nominalPackagePace)
import Ecluse.Core.Registry.Sweep.Types (SweepCache (..), SweepMount (..), SweepStore, deletingCache, pairedStore, previewCache)
import Ecluse.Core.Rules (PreparedRule, RuleDeps, prepare)
import Ecluse.Core.Rules.Types (PrecededRule (prRule), Rule)
import Ecluse.Core.Security (Limits (maxVersionCount))
import Ecluse.Core.Security.Egress (registryUrlText)
import Ecluse.Core.Server.Admission.Bytes (newByteAdmission)
import Ecluse.Core.Telemetry.Metrics (BreakerSource (CredentialMint, EffectfulRule))
import Ecluse.Core.Telemetry.Span (TracingPort)
import Ecluse.Cve.Sync (AdvisoryNeed (AdvisoryNeed, anDatabase, anEcosystem, anEpss, anMaxAge), CveSyncHandle, cveRuleDepsFor, katipOutageReporter, planCveSync)
import Ecluse.Pilot.Plan (ExportLoopPlan, ExportTarget (ExportTarget, etEcosystem, etEpss), exportLoopPlan)
import Ecluse.Runtime.Telemetry.Reporters (
    DeferredMetrics,
    deferredBreakerReporter,
    deferredRefreshReporter,
    newDeferredMetrics,
 )

{- | The boot's post-gating artefact: the cleared plan, and the wiring only a live environment
could settle. 'planExecutable' is its one producer, so a role cannot assemble an unvetted one.
-}
data ExecutablePlan = ExecutablePlan
    { ExecutablePlan -> BootPlan
epBootPlan :: BootPlan
    -- ^ The config-decidable plan every decision below was planned against.
    , ExecutablePlan -> RoleWiring
epRoleWiring :: RoleWiring
    -- ^ What the booting role's own arm of this phase settled.
    }

{- | What each role's arm settled. A role starts from its own arm, so wiring one role's boot
planned cannot reach another role's runtime.
-}
data RoleWiring
    = -- | @ecluse proxy@, @ecluse proxy --no-worker@ and @ecluse mirror@.
      MirrorPipelineWiring MirrorWiring
    | -- | @ecluse dredger@: the stores it sweeps, and what decides for each of them.
      StorePrunerWiring PrunerWiring
    | -- | @ecluse pilot@: the export loop the advisory settings and the vetted mounts name.
      PilotWiring ExportLoopPlan

-- | What a mirror-pipeline role's arm settled, and all "Ecluse.Service" assembles its runtime from.
data MirrorWiring = MirrorWiring
    { MirrorWiring -> MirrorRole
mwRole :: MirrorRole
    -- ^ The pipeline half the plan vetted, so the severities it cleared and the runtime agree.
    , MirrorWiring -> BootWiring
mwBootWiring :: BootWiring
    -- ^ The mounts the front door serves, and the publish targets the worker writes through.
    , MirrorWiring -> Map Ecosystem CveSyncHandle
mwCveSync :: Map Ecosystem CveSyncHandle
    -- ^ One advisory-sync handle per mount ecosystem, empty where no advisory store is configured.
    , MirrorWiring -> MirrorQueue
mwQueue :: MirrorQueue
    -- ^ The mirror-queue backend the plan selected, inert where no mount mirrors.
    , MirrorWiring -> DeferredMetrics
mwDeferredMetrics :: DeferredMetrics
    {- ^ The metric handle the credential providers and the rule breakers already record through.
    The assembly makes those recordings live once the instruments exist.
    -}
    }

{- | What the store pruner's arm settled: one sweepable mount per cleared store, and the advisory
sync the sweep's rules read. "Ecluse.Dredger" assembles the whole role from it.
-}
data PrunerWiring = PrunerWiring
    { PrunerWiring -> [SweepMount]
pwMounts :: [SweepMount]
    {- ^ One entry per store the pass cleared, carrying its maintenance handle, its own prepared
    rule set, and the shared first-party predicate its belt reads.
    -}
    , PrunerWiring -> Map Ecosystem CveSyncHandle
pwCveSync :: Map Ecosystem CveSyncHandle
    -- ^ One advisory-sync handle per mount ecosystem, empty where no advisory store is configured.
    , PrunerWiring -> DeferredMetrics
pwDeferredMetrics :: DeferredMetrics
    {- ^ The metric handle the credential providers and the sweep's rule breakers already record
    through. The role makes those recordings live once the instruments exist.
    -}
    , PrunerWiring -> BudgetPort
pwBudget :: BudgetPort
    {- ^ The cycle's end of the request budget every store handle above was built against, so the
    sweep reads what a cycle cost and installs the next one's rate.
    -}
    }

{- | How a boot builds the selected mirror-queue backend. Injected, as the adapter resolver is,
so a spec can drive this phase's refusals without reaching a cloud.
-}
type BuildMirrorQueue = LogEnv -> Int -> MirrorQueuePlan -> IO MirrorQueue

{- How the booting role builds one store's halves as the sweep holds them. Both Dredger roles plan
through the one arm below and differ only in which of 'StoreBuilds' they ran. -}
type BuildSweepCache = StorePorts -> Limits -> ClearedBackend -> IO SweepCache

{- | Plan the runtime the cleared plan's role starts, or report every refusal only a live
environment can settle. Each role has one arm here, and a refusal is spent once for all of them.
-}
planExecutable ::
    LogEnv ->
    TracingPort ->
    ResolveAdapter ->
    BuildMirrorQueue ->
    BuildCredentials ->
    StoreBuilds ->
    BootPlan ->
    IO ([Advisory], Either [BootError] ExecutablePlan)
planExecutable :: LogEnv
-> TracingPort
-> ResolveAdapter
-> BuildMirrorQueue
-> BuildCredentials
-> StoreBuilds
-> BootPlan
-> IO ([Advisory], Either [BootError] ExecutablePlan)
planExecutable LogEnv
logEnv TracingPort
tracing ResolveAdapter
resolveAdapter BuildMirrorQueue
buildQueue BuildCredentials
buildCredentials StoreBuilds
builds BootPlan
bootPlan = case BootPlan -> BootRole
bpRole BootPlan
bootPlan of
    BootMirrorPipeline MirrorRole
role -> do
        (advisories, probed) <- BuildUpstreamProbe
-> MirrorRole -> BootPlan -> IO ([Advisory], Either [BootError] ())
probeServedUpstreams (StoreBuilds -> BuildUpstreamProbe
sbProbing StoreBuilds
builds) MirrorRole
role BootPlan
bootPlan
        wiring <- planMirrorWiring logEnv resolveAdapter buildQueue buildCredentials role bootPlan
        pure (advisories, accumulate probed (executablePlan . MirrorPipelineWiring <$> wiring))
    BootRole
BootStorePruner -> BuildSweepCache
-> IO ([Advisory], Either [BootError] ExecutablePlan)
prunerArm ((StorePorts -> Limits -> ClearedBackend -> IO StoreMaintenance)
-> BuildSweepCache
forall {f :: * -> *} {t} {t} {t}.
Functor f =>
(t -> t -> t -> f StoreMaintenance) -> t -> t -> t -> f SweepCache
deleting (StoreBuilds
-> StorePorts -> Limits -> ClearedBackend -> IO StoreMaintenance
sbDeleting StoreBuilds
builds))
    BootRole
BootStorePreview -> BuildSweepCache
-> IO ([Advisory], Either [BootError] ExecutablePlan)
prunerArm ((StorePorts -> Limits -> ClearedBackend -> IO StoreObservation)
-> BuildSweepCache
forall {f :: * -> *} {t} {t} {t}.
Functor f =>
(t -> t -> t -> f StoreObservation) -> t -> t -> t -> f SweepCache
previewing (StoreBuilds
-> StorePorts -> Limits -> ClearedBackend -> IO StoreObservation
sbObserving StoreBuilds
builds))
    BootRole
BootWithoutPipeline -> ([Advisory], Either [BootError] ExecutablePlan)
-> IO ([Advisory], Either [BootError] ExecutablePlan)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], RoleWiring -> ExecutablePlan
executablePlan (RoleWiring -> ExecutablePlan)
-> (ExportLoopPlan -> RoleWiring)
-> ExportLoopPlan
-> ExecutablePlan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExportLoopPlan -> RoleWiring
PilotWiring (ExportLoopPlan -> ExecutablePlan)
-> Either [BootError] ExportLoopPlan
-> Either [BootError] ExecutablePlan
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ValidatedPlan -> Either [BootError] ExportLoopPlan
pilotExportPlan (BootPlan -> ValidatedPlan
bpValidated BootPlan
bootPlan))
  where
    executablePlan :: RoleWiring -> ExecutablePlan
executablePlan RoleWiring
wiring = ExecutablePlan{epBootPlan :: BootPlan
epBootPlan = BootPlan
bootPlan, epRoleWiring :: RoleWiring
epRoleWiring = RoleWiring
wiring}

    prunerArm :: BuildSweepCache
-> IO ([Advisory], Either [BootError] ExecutablePlan)
prunerArm BuildSweepCache
build =
        (Either [BootError] PrunerWiring
 -> Either [BootError] ExecutablePlan)
-> ([Advisory], Either [BootError] PrunerWiring)
-> ([Advisory], Either [BootError] ExecutablePlan)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((PrunerWiring -> ExecutablePlan)
-> Either [BootError] PrunerWiring
-> Either [BootError] ExecutablePlan
forall a b.
(a -> b) -> Either [BootError] a -> Either [BootError] b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (RoleWiring -> ExecutablePlan
executablePlan (RoleWiring -> ExecutablePlan)
-> (PrunerWiring -> RoleWiring) -> PrunerWiring -> ExecutablePlan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrunerWiring -> RoleWiring
StorePrunerWiring))
            (([Advisory], Either [BootError] PrunerWiring)
 -> ([Advisory], Either [BootError] ExecutablePlan))
-> IO ([Advisory], Either [BootError] PrunerWiring)
-> IO ([Advisory], Either [BootError] ExecutablePlan)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LogEnv
-> TracingPort
-> BuildCredentials
-> BuildSweepCache
-> BootPlan
-> IO ([Advisory], Either [BootError] PrunerWiring)
planPrunerWiring LogEnv
logEnv TracingPort
tracing BuildCredentials
buildCredentials BuildSweepCache
build BootPlan
bootPlan

    deleting :: (t -> t -> t -> f StoreMaintenance) -> t -> t -> t -> f SweepCache
deleting t -> t -> t -> f StoreMaintenance
build t
ports t
limits t
cleared = StoreMaintenance -> SweepCache
deletingCache (StoreMaintenance -> SweepCache)
-> f StoreMaintenance -> f SweepCache
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t -> t -> t -> f StoreMaintenance
build t
ports t
limits t
cleared
    previewing :: (t -> t -> t -> f StoreObservation) -> t -> t -> t -> f SweepCache
previewing t -> t -> t -> f StoreObservation
build t
ports t
limits t
cleared = StoreObservation -> SweepCache
previewCache (StoreObservation -> SweepCache)
-> f StoreObservation -> f SweepCache
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t -> t -> t -> f StoreObservation
build t
ports t
limits t
cleared

-- The probe's refusals join the arm's own, so one launch reports every one of them.
accumulate :: Either [BootError] () -> Either [BootError] a -> Either [BootError] a
accumulate :: forall a.
Either [BootError] ()
-> Either [BootError] a -> Either [BootError] a
accumulate Either [BootError] ()
probed Either [BootError] a
outcome = Validation [BootError] a -> Either [BootError] a
forall e a. Validation e a -> Either e a
validationToEither (Either [BootError] a -> Validation [BootError] a
forall e a. Either e a -> Validation e a
eitherToValidation Either [BootError] a
outcome Validation [BootError] a
-> Validation [BootError] () -> Validation [BootError] a
forall a b.
Validation [BootError] a
-> Validation [BootError] b -> Validation [BootError] a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Either [BootError] () -> Validation [BootError] ()
forall e a. Either e a -> Validation e a
eitherToValidation Either [BootError] ()
probed)

{- The proxy serves private content from every mount's private upstream, so it asks each backend
whether public content can reach a client through it. The worker reads no private upstream. -}
probeServedUpstreams :: BuildUpstreamProbe -> MirrorRole -> BootPlan -> IO ([Advisory], Either [BootError] ())
probeServedUpstreams :: BuildUpstreamProbe
-> MirrorRole -> BootPlan -> IO ([Advisory], Either [BootError] ())
probeServedUpstreams BuildUpstreamProbe
buildProbe MirrorRole
role BootPlan
bootPlan
    | MirrorRole -> Bool
servesClients MirrorRole
role = [(Ecosystem, IO UpstreamSafety)]
-> IO ([Advisory], Either [BootError] ())
readUpstreamSafety [(Ecosystem
eco, BuildUpstreamProbe
buildProbe Ecosystem
eco PrivateEndpoint
endpoint) | (Ecosystem
eco, PrivateEndpoint
endpoint) <- BootPlan -> [(Ecosystem, PrivateEndpoint)]
privateUpstreams BootPlan
bootPlan]
    | Bool
otherwise = ([Advisory], Either [BootError] ())
-> IO ([Advisory], Either [BootError] ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], () -> Either [BootError] ()
forall a b. b -> Either a b
Right ())

-- Which halves of the mirror pipeline answer a client from the private upstream.
servesClients :: MirrorRole -> Bool
servesClients :: MirrorRole -> Bool
servesClients = \case
    MirrorRole
ServeAndMirror -> Bool
True
    MirrorRole
ServeOnly -> Bool
True
    MirrorRole
MirrorOnly -> Bool
False

-- Each vetted mount's private upstream, in ascending ecosystem order, absent where none is declared.
privateUpstreams :: BootPlan -> [(Ecosystem, PrivateEndpoint)]
privateUpstreams :: BootPlan -> [(Ecosystem, PrivateEndpoint)]
privateUpstreams BootPlan
bootPlan =
    [ (VettedMount -> Ecosystem
vmEcosystem VettedMount
vetted, PrivateEndpoint
endpoint)
    | VettedMount
vetted <- ValidatedPlan -> [VettedMount]
vpMounts (BootPlan -> ValidatedPlan
bpValidated BootPlan
bootPlan)
    , Just PrivateEndpoint
endpoint <- [MountConfig -> Maybe PrivateEndpoint
mntPrivateUpstream (VettedMount -> MountConfig
vmConfig VettedMount
vetted)]
    ]

{- Both store roles ask the private handles they hold, rather than building a second client for
each, and both read the answer the way a serving role does. -}
probeHeldCaches :: Map Ecosystem SweepCache -> IO ([Advisory], Either [BootError] ())
probeHeldCaches :: Map Ecosystem SweepCache -> IO ([Advisory], Either [BootError] ())
probeHeldCaches Map Ecosystem SweepCache
caches =
    [(Ecosystem, IO UpstreamSafety)]
-> IO ([Advisory], Either [BootError] ())
readUpstreamSafety [(Ecosystem
eco, StoreObservation -> IO UpstreamSafety
obProbeUpstream (SweepCache -> StoreObservation
scObserve SweepCache
cache)) | (Ecosystem
eco, SweepCache
cache) <- Map Ecosystem SweepCache -> [(Ecosystem, SweepCache)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map Ecosystem SweepCache
caches]

{- The store roles' shared arm: the advisory sync their rules read, the credential their stores
answer to, and one store per cleared target. All three refusable steps accumulate. -}
planPrunerWiring :: LogEnv -> TracingPort -> BuildCredentials -> BuildSweepCache -> BootPlan -> IO ([Advisory], Either [BootError] PrunerWiring)
planPrunerWiring :: LogEnv
-> TracingPort
-> BuildCredentials
-> BuildSweepCache
-> BootPlan
-> IO ([Advisory], Either [BootError] PrunerWiring)
planPrunerWiring LogEnv
logEnv TracingPort
tracing BuildCredentials
buildCredentials BuildSweepCache
buildStore BootPlan
bootPlan = do
    deferredMetrics <- IO UTCTime -> IO DeferredMetrics
newDeferredMetrics IO UTCTime
getCurrentTime
    cveSync <- planAdvisorySync logEnv bootPlan
    credentials <- buildCredentials (credentialReportersOver deferredMetrics) credentialBackends
    -- 'waitSeconds' keeps the sub-second part: every pace this budget produces is well under one.
    (budgetPort, gateFor) <- newBudgetMeter waitSeconds
    let budget = DredgerSettings -> (QuotaScope -> RequestGate) -> BudgetPorts
budgetPortsFor DredgerSettings
dredger QuotaScope -> RequestGate
gateFor
    stores <-
        planStoreMaintenance
            buildStore
            tracing
            budget
            (fromRight noCredentialProviders credentials)
            (bpLimits bootPlan)
            (vpMirrorStores validated)
    caches <-
        planStoreMaintenanceFor
            PrivateCacheCredential
            buildStore
            tracing
            budget
            (fromRight noCredentialProviders credentials)
            (bpLimits bootPlan)
            (Map.map snd (vpPrivateCaches validated))
    -- A refused sync leaves the rules abstaining, so the policies below still prepare and still
    -- report. The accumulation then discards them along with the sync.
    let ruleDepsFor =
            Map Ecosystem CveSyncHandle
-> BreakerReporter
-> (Ecosystem -> OutageReport -> IO ())
-> Ecosystem
-> RuleDeps
cveRuleDepsFor
                (Map Ecosystem CveSyncHandle
-> Either [BootError] (Map Ecosystem CveSyncHandle)
-> Map Ecosystem CveSyncHandle
forall b a. b -> Either a b -> b
fromRight Map Ecosystem CveSyncHandle
forall a. Monoid a => a
mempty Either [BootError] (Map Ecosystem CveSyncHandle)
cveSync)
                (DeferredMetrics -> BreakerSource -> BreakerReporter
deferredBreakerReporter DeferredMetrics
deferredMetrics BreakerSource
EffectfulRule)
                (LogEnv -> Ecosystem -> OutageReport -> IO ()
katipOutageReporter LogEnv
logEnv)
        heldCaches = Map Ecosystem SweepCache
-> Either [BootError] (Map Ecosystem SweepCache)
-> Map Ecosystem SweepCache
forall b a. b -> Either a b -> b
fromRight Map Ecosystem SweepCache
forall a. Monoid a => a
mempty Either [BootError] (Map Ecosystem SweepCache)
caches
    policies <- Map.fromList <$> traverse (sweepPolicyFor ruleDepsFor) (vpMounts validated)
    (advisories, probed) <- probeHeldCaches heldCaches
    pure . (advisories,) . validationToEither $
        prunerWiringFrom deferredMetrics budgetPort policies
            <$> eitherToValidation cveSync
            <* eitherToValidation credentials
            <*> eitherToValidation (stores >>= pairStoresWithCaches validated (bpLimits bootPlan) heldCaches)
            <* eitherToValidation caches
            <* eitherToValidation probed
  where
    validated :: ValidatedPlan
validated = BootPlan -> ValidatedPlan
bpValidated BootPlan
bootPlan
    dredger :: DredgerSettings
dredger = AppConfig -> DredgerSettings
cfgDredger (ValidatedPlan -> AppConfig
vpSettings ValidatedPlan
validated)
    prunerMounts :: [Mount]
prunerMounts = (VettedMount -> Mount) -> [VettedMount] -> [Mount]
forall a b. (a -> b) -> [a] -> [b]
map VettedMount -> Mount
vmMount (ValidatedPlan -> [VettedMount]
vpMounts ValidatedPlan
validated)
    credentialBackends :: [((Ecosystem, CredentialTarget), StoreBackend)]
credentialBackends =
        [((Ecosystem
eco, CredentialTarget
MirrorCredential), StoreBackend
backend) | (Ecosystem
eco, StoreBackend
backend) <- [Mount] -> [(Ecosystem, StoreBackend)]
mirrorBackends [Mount]
prunerMounts]
            [((Ecosystem, CredentialTarget), StoreBackend)]
-> [((Ecosystem, CredentialTarget), StoreBackend)]
-> [((Ecosystem, CredentialTarget), StoreBackend)]
forall a. Semigroup a => a -> a -> a
<> [((Ecosystem
eco, CredentialTarget
PrivateCacheCredential), StoreBackend
backend) | (Ecosystem
eco, (Just StoreBackend
backend, ClearedBackend
_)) <- Map Ecosystem (Maybe StoreBackend, ClearedBackend)
-> [(Ecosystem, (Maybe StoreBackend, ClearedBackend))]
forall k a. Map k a -> [(k, a)]
Map.toAscList (ValidatedPlan -> Map Ecosystem (Maybe StoreBackend, ClearedBackend)
vpPrivateCaches ValidatedPlan
validated)]

-- What a sweep's requests are counted and paced through, over the pace its chunk size and pause imply.
budgetPortsFor :: DredgerSettings -> (QuotaScope -> RequestGate) -> BudgetPorts
budgetPortsFor :: DredgerSettings -> (QuotaScope -> RequestGate) -> BudgetPorts
budgetPortsFor DredgerSettings
dredger QuotaScope -> RequestGate
gateFor =
    BudgetPorts
        { bpGateFor :: QuotaScope -> RequestGate
bpGateFor = QuotaScope -> RequestGate
gateFor
        , bpOverrides :: Map Text QuotaOverride
bpOverrides = DredgerSettings -> Map Text QuotaOverride
drgQuotaOverrides DredgerSettings
dredger
        , bpNominalPace :: Rational
bpNominalPace = Int -> NominalDiffTime -> Rational
nominalPackagePace (DredgerSettings -> Int
drgChunkSize DredgerSettings
dredger) (DredgerSettings -> NominalDiffTime
drgChunkPause DredgerSettings
dredger)
        }

{- Every mirror store beside the cache it is swept with, under the bound they share. A mirrored
mount is vetted with its private cache, so a store with none here is a refusal, not a lone sweep. -}
pairStoresWithCaches ::
    ValidatedPlan ->
    Limits ->
    Map Ecosystem SweepCache ->
    Map Ecosystem SweepCache ->
    Either [BootError] (Map Ecosystem SweepStore)
pairStoresWithCaches :: ValidatedPlan
-> Limits
-> Map Ecosystem SweepCache
-> Map Ecosystem SweepCache
-> Either [BootError] (Map Ecosystem SweepStore)
pairStoresWithCaches ValidatedPlan
validated Limits
limits Map Ecosystem SweepCache
caches =
    Validation [BootError] (Map Ecosystem SweepStore)
-> Either [BootError] (Map Ecosystem SweepStore)
forall e a. Validation e a -> Either e a
validationToEither (Validation [BootError] (Map Ecosystem SweepStore)
 -> Either [BootError] (Map Ecosystem SweepStore))
-> (Map Ecosystem SweepCache
    -> Validation [BootError] (Map Ecosystem SweepStore))
-> Map Ecosystem SweepCache
-> Either [BootError] (Map Ecosystem SweepStore)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ecosystem -> SweepCache -> Validation [BootError] SweepStore)
-> Map Ecosystem SweepCache
-> Validation [BootError] (Map Ecosystem SweepStore)
forall (t :: * -> *) k a b.
Applicative t =>
(k -> a -> t b) -> Map k a -> t (Map k b)
Map.traverseWithKey Ecosystem -> SweepCache -> Validation [BootError] SweepStore
pairOne
  where
    pairOne :: Ecosystem -> SweepCache -> Validation [BootError] SweepStore
pairOne Ecosystem
eco SweepCache
mirror =
        Validation [BootError] SweepStore
-> (SweepStore -> Validation [BootError] SweepStore)
-> Maybe SweepStore
-> Validation [BootError] SweepStore
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([BootError] -> Validation [BootError] SweepStore
forall e a. e -> Validation e a
Failure [Ecosystem -> BootError
unpaired Ecosystem
eco]) SweepStore -> Validation [BootError] SweepStore
forall a. a -> Validation [BootError] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe SweepStore -> Validation [BootError] SweepStore)
-> Maybe SweepStore -> Validation [BootError] SweepStore
forall a b. (a -> b) -> a -> b
$ do
            cache <- Ecosystem -> Map Ecosystem SweepCache -> Maybe SweepCache
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Ecosystem
eco Map Ecosystem SweepCache
caches
            clearedCache <- snd <$> Map.lookup eco (vpPrivateCaches validated)
            clearedMirror <- Map.lookup eco (vpMirrorStores validated)
            pure $
                pairedStore
                    (maxVersionCount limits)
                    (labelCache "mirrorTarget" clearedMirror mirror)
                    (labelCache "privateUpstream" clearedCache cache)

    unpaired :: Ecosystem -> BootError
unpaired Ecosystem
eco = Ecosystem -> StoreMaintenanceReason -> BootError
StoreMaintenanceUnavailable Ecosystem
eco (Text -> StoreMaintenanceReason
PrivateCacheUnavailable Text
"no private cache was cleared to sweep beside this mirror target")

labelCache :: Text -> ClearedBackend -> SweepCache -> SweepCache
labelCache :: Text -> ClearedBackend -> SweepCache -> SweepCache
labelCache Text
role ClearedBackend
backend SweepCache
cache = SweepCache
cache{scObserve = labelObservation role backend (scObserve cache)}

labelObservation :: Text -> ClearedBackend -> StoreObservation -> StoreObservation
labelObservation :: Text -> ClearedBackend -> StoreObservation -> StoreObservation
labelObservation Text
role ClearedBackend
backend StoreObservation
observation =
    StoreObservation
observation
        { obFacts = (obFacts observation){factBackend = role <> " " <> registryUrlText (cbUrl backend)}
        }

{- What decides for one mount's store: its own rule set, prepared as the serve path prepares its,
and the shared first-party predicate. A mount declaring no namespaces owns none. -}
sweepPolicyFor :: (Ecosystem -> RuleDeps) -> VettedMount -> IO (Ecosystem, SweepPolicy)
sweepPolicyFor :: (Ecosystem -> RuleDeps)
-> VettedMount -> IO (Ecosystem, SweepPolicy)
sweepPolicyFor Ecosystem -> RuleDeps
ruleDepsFor VettedMount
vetted = do
    prepared <- RuleDeps -> [PrecededRule] -> IO [PreparedRule]
prepare RuleDeps
deps [PrecededRule]
configured
    pure (eco, SweepPolicy{spRules = prepared, spConfigured = map prRule configured, spDeps = deps, spProject = project, spFirstParty = firstParty})
  where
    eco :: Ecosystem
eco = VettedMount -> Ecosystem
vmEcosystem VettedMount
vetted
    deps :: RuleDeps
deps = Ecosystem -> RuleDeps
ruleDepsFor Ecosystem
eco
    configured :: [PrecededRule]
configured = Mount -> [PrecededRule]
mountPolicy (VettedMount -> Mount
vmMount VettedMount
vetted)
    project :: ProjectName
project = RegistryAdapter -> ProjectName
adapterProjectName (VettedMount -> RegistryAdapter
vmAdapter VettedMount
vetted)
    firstParty :: PackageName -> Bool
firstParty = (PackageName -> Bool)
-> (FirstParty -> PackageName -> Bool)
-> Maybe FirstParty
-> PackageName
-> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Bool -> PackageName -> Bool
forall a b. a -> b -> a
const Bool
False) FirstParty -> PackageName -> Bool
firstPartyName (MountConfig -> Maybe FirstParty
mntFirstParty (VettedMount -> MountConfig
vmConfig VettedMount
vetted))

{- One mount's half of a sweepable store. The configured rules ride beside the prepared ones,
because a prepared rule no longer carries the identity a deny names. -}
data SweepPolicy = SweepPolicy
    { SweepPolicy -> [PreparedRule]
spRules :: [PreparedRule]
    , SweepPolicy -> [Rule]
spConfigured :: [Rule]
    , SweepPolicy -> RuleDeps
spDeps :: RuleDeps
    , SweepPolicy -> ProjectName
spProject :: ProjectName
    , SweepPolicy -> PackageName -> Bool
spFirstParty :: PackageName -> Bool
    }

{- The artefact the arm yields. The join is on the ecosystem, and only a mount declaring a mirror
target reaches the store map, so a store with no policy cannot arise. -}
prunerWiringFrom ::
    DeferredMetrics ->
    BudgetPort ->
    Map Ecosystem SweepPolicy ->
    Map Ecosystem CveSyncHandle ->
    Map Ecosystem SweepStore ->
    PrunerWiring
prunerWiringFrom :: DeferredMetrics
-> BudgetPort
-> Map Ecosystem SweepPolicy
-> Map Ecosystem CveSyncHandle
-> Map Ecosystem SweepStore
-> PrunerWiring
prunerWiringFrom DeferredMetrics
deferredMetrics BudgetPort
budgetPort Map Ecosystem SweepPolicy
policies Map Ecosystem CveSyncHandle
cveSync Map Ecosystem SweepStore
stores =
    PrunerWiring
        { pwMounts :: [SweepMount]
pwMounts =
            [ SweepMount
                { smEcosystem :: Ecosystem
smEcosystem = Ecosystem
eco
                , smStore :: SweepStore
smStore = SweepStore
store
                , smRules :: [PreparedRule]
smRules = SweepPolicy -> [PreparedRule]
spRules SweepPolicy
policy
                , smConfigured :: [Rule]
smConfigured = SweepPolicy -> [Rule]
spConfigured SweepPolicy
policy
                , smRuleDeps :: RuleDeps
smRuleDeps = SweepPolicy -> RuleDeps
spDeps SweepPolicy
policy
                , smProjectName :: ProjectName
smProjectName = SweepPolicy -> ProjectName
spProject SweepPolicy
policy
                , smFirstParty :: PackageName -> Bool
smFirstParty = SweepPolicy -> PackageName -> Bool
spFirstParty SweepPolicy
policy
                }
            | (Ecosystem
eco, SweepStore
store) <- Map Ecosystem SweepStore -> [(Ecosystem, SweepStore)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map Ecosystem SweepStore
stores
            , Just SweepPolicy
policy <- [Ecosystem -> Map Ecosystem SweepPolicy -> Maybe SweepPolicy
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Ecosystem
eco Map Ecosystem SweepPolicy
policies]
            ]
        , pwCveSync :: Map Ecosystem CveSyncHandle
pwCveSync = Map Ecosystem CveSyncHandle
cveSync
        , pwDeferredMetrics :: DeferredMetrics
pwDeferredMetrics = DeferredMetrics
deferredMetrics
        , pwBudget :: BudgetPort
pwBudget = BudgetPort
budgetPort
        }

{- One artifact per vetted mount, under the EPSS requirement 'planAdvisorySync' gives its consumers.
A store with no mount leaves nothing to compile, and a role with no work refuses rather than idles. -}
pilotExportPlan :: ValidatedPlan -> Either [BootError] ExportLoopPlan
pilotExportPlan :: ValidatedPlan -> Either [BootError] ExportLoopPlan
pilotExportPlan ValidatedPlan
validated = [BootError]
-> Maybe ExportLoopPlan -> Either [BootError] ExportLoopPlan
forall l r. l -> Maybe r -> Either l r
maybeToRight [BootError
PilotWithoutEcosystem] (AdvisoriesSettings -> [ExportTarget] -> Maybe ExportLoopPlan
exportLoopPlan AdvisoriesSettings
advisories [ExportTarget]
targets)
  where
    advisories :: AdvisoriesSettings
advisories = AppConfig -> AdvisoriesSettings
cfgAdvisories (ValidatedPlan -> AppConfig
vpSettings ValidatedPlan
validated)
    targets :: [ExportTarget]
targets =
        [ ExportTarget{etEcosystem :: Ecosystem
etEcosystem = VettedMount -> Ecosystem
vmEcosystem VettedMount
vetted, etEpss :: EpssRequirement
etEpss = Mount -> EpssRequirement
mountEpssRequirement (VettedMount -> Mount
vmMount VettedMount
vetted)}
        | VettedMount
vetted <- ValidatedPlan -> [VettedMount]
vpMounts ValidatedPlan
validated
        ]

{- The mirror pipeline's arm: the advisory sync, the queue backend, and the mount wiring. The three
refusable steps accumulate, so one launch reports every one rather than the earliest alone. -}
planMirrorWiring :: LogEnv -> ResolveAdapter -> BuildMirrorQueue -> BuildCredentials -> MirrorRole -> BootPlan -> IO (Either [BootError] MirrorWiring)
planMirrorWiring :: LogEnv
-> ResolveAdapter
-> BuildMirrorQueue
-> BuildCredentials
-> MirrorRole
-> BootPlan
-> IO (Either [BootError] MirrorWiring)
planMirrorWiring LogEnv
logEnv ResolveAdapter
resolveAdapter BuildMirrorQueue
buildQueue BuildCredentials
buildCredentials MirrorRole
role BootPlan
bootPlan = do
    -- The metric instruments do not exist until the assembly builds the telemetry substrate. The
    -- credential providers minted below record through reporters 'installMetrics' makes live.
    deferredMetrics <- IO UTCTime -> IO DeferredMetrics
newDeferredMetrics IO UTCTime
getCurrentTime
    cveSync <- planAdvisorySync logEnv bootPlan
    publishBudget <- planPublishBudget memoryPlan
    queue <- planMirrorQueue buildQueue logEnv (mpQueueMemoryMaxDepth memoryPlan) (bpMirrorRuntime bootPlan)
    -- A refused sync leaves the rules abstaining, so the wiring below still builds and still
    -- reports what it refuses. The accumulation then discards it along with the sync.
    let ruleDeps =
            Map Ecosystem CveSyncHandle
-> BreakerReporter
-> (Ecosystem -> OutageReport -> IO ())
-> Ecosystem
-> RuleDeps
cveRuleDepsFor
                (Map Ecosystem CveSyncHandle
-> Either [BootError] (Map Ecosystem CveSyncHandle)
-> Map Ecosystem CveSyncHandle
forall b a. b -> Either a b -> b
fromRight Map Ecosystem CveSyncHandle
forall a. Monoid a => a
mempty Either [BootError] (Map Ecosystem CveSyncHandle)
cveSync)
                (DeferredMetrics -> BreakerSource -> BreakerReporter
deferredBreakerReporter DeferredMetrics
deferredMetrics BreakerSource
EffectfulRule)
                (LogEnv -> Ecosystem -> OutageReport -> IO ()
katipOutageReporter LogEnv
logEnv)
        ports =
            WiringPorts
                { wpReporters :: Ecosystem -> StoreTag -> CredentialReporters
wpReporters = DeferredMetrics -> Ecosystem -> StoreTag -> CredentialReporters
credentialReportersOver DeferredMetrics
deferredMetrics
                , wpBuildCredentials :: BuildCredentials
wpBuildCredentials = BuildCredentials
buildCredentials
                , wpResolveAdapter :: ResolveAdapter
wpResolveAdapter = ResolveAdapter
resolveAdapter
                , wpClock :: IO UTCTime
wpClock = IO UTCTime
getCurrentTime
                , wpRuleDeps :: Ecosystem -> RuleDeps
wpRuleDeps = Ecosystem -> RuleDeps
ruleDeps
                }
    -- The wiring reads the rule deps and the publish budget above, so it follows them rather than
    -- accumulating with them.
    wiring <- resolveBootWiring ports (mirrorMintPlan role) (bpLimits bootPlan) publishBudget validated
    pure . validationToEither $
        mirrorWiringFrom role deferredMetrics
            <$> eitherToValidation cveSync
            <*> eitherToValidation queue
            <*> eitherToValidation wiring
  where
    validated :: ValidatedPlan
validated = BootPlan -> ValidatedPlan
bpValidated BootPlan
bootPlan
    memoryPlan :: MemoryPlan
memoryPlan = BootPlan -> MemoryPlan
bpMemoryPlan BootPlan
bootPlan

-- The artefact the arm yields once its refusable steps cleared.
mirrorWiringFrom :: MirrorRole -> DeferredMetrics -> Map Ecosystem CveSyncHandle -> MirrorQueue -> BootWiring -> MirrorWiring
mirrorWiringFrom :: MirrorRole
-> DeferredMetrics
-> Map Ecosystem CveSyncHandle
-> MirrorQueue
-> BootWiring
-> MirrorWiring
mirrorWiringFrom MirrorRole
role DeferredMetrics
deferredMetrics Map Ecosystem CveSyncHandle
cveSync MirrorQueue
queue BootWiring
wiring =
    MirrorWiring
        { mwRole :: MirrorRole
mwRole = MirrorRole
role
        , mwBootWiring :: BootWiring
mwBootWiring = BootWiring
wiring
        , mwCveSync :: Map Ecosystem CveSyncHandle
mwCveSync = Map Ecosystem CveSyncHandle
cveSync
        , mwQueue :: MirrorQueue
mwQueue = MirrorQueue
queue
        , mwDeferredMetrics :: DeferredMetrics
mwDeferredMetrics = DeferredMetrics
deferredMetrics
        }

{- It creates the local data directory and discovers the advisory store's credentials, so an
environment that can do neither refuses here rather than at first sync. -}
planAdvisorySync :: LogEnv -> BootPlan -> IO (Either [BootError] (Map Ecosystem CveSyncHandle))
planAdvisorySync :: LogEnv
-> BootPlan
-> IO (Either [BootError] (Map Ecosystem CveSyncHandle))
planAdvisorySync LogEnv
logEnv BootPlan
bootPlan =
    (Text -> BootError)
-> IO (Map Ecosystem CveSyncHandle)
-> IO (Either [BootError] (Map Ecosystem CveSyncHandle))
forall a. (Text -> BootError) -> IO a -> IO (Either [BootError] a)
refuseOnThrow Text -> BootError
AdvisorySyncUnavailable (IO (Map Ecosystem CveSyncHandle)
 -> IO (Either [BootError] (Map Ecosystem CveSyncHandle)))
-> IO (Map Ecosystem CveSyncHandle)
-> IO (Either [BootError] (Map Ecosystem CveSyncHandle))
forall a b. (a -> b) -> a -> b
$
        LogEnv
-> Maybe AwsEndpoint
-> AppConfig
-> [AdvisoryNeed]
-> IO (Map Ecosystem CveSyncHandle)
planCveSync LogEnv
logEnv (BootPlan -> Maybe AwsEndpoint
bpS3Endpoint BootPlan
bootPlan) AppConfig
settings [AdvisoryNeed]
requirements
  where
    validated :: ValidatedPlan
validated = BootPlan -> ValidatedPlan
bpValidated BootPlan
bootPlan
    settings :: AppConfig
settings = ValidatedPlan -> AppConfig
vpSettings ValidatedPlan
validated
    requirements :: [AdvisoryNeed]
requirements =
        [ AdvisoryNeed
            { anEcosystem :: Ecosystem
anEcosystem = VettedMount -> Ecosystem
vmEcosystem VettedMount
vetted
            , anMaxAge :: MaxAdvisoryAge
anMaxAge = AdvisoriesSettings -> Mount -> MaxAdvisoryAge
mountAdvisoryAge (AppConfig -> AdvisoriesSettings
cfgAdvisories AppConfig
settings) Mount
mount
            , anEpss :: EpssRequirement
anEpss = Mount -> EpssRequirement
mountEpssRequirement Mount
mount
            , anDatabase :: DatabaseRequirement
anDatabase = Mount -> DatabaseRequirement
mountDatabaseRequirement Mount
mount
            }
        | VettedMount
vetted <- ValidatedPlan -> [VettedMount]
vpMounts ValidatedPlan
validated
        , let mount :: Mount
mount = VettedMount -> Mount
vmMount VettedMount
vetted
        ]

{- Build the selected queue backend. It dials the provider to read the queue's redrive policy, so
an environment that cannot reach it refuses here rather than failing the running worker. -}
planMirrorQueue :: BuildMirrorQueue -> LogEnv -> Int -> MirrorRuntimePlan -> IO (Either [BootError] MirrorQueue)
planMirrorQueue :: BuildMirrorQueue
-> LogEnv
-> Int
-> MirrorRuntimePlan
-> IO (Either [BootError] MirrorQueue)
planMirrorQueue BuildMirrorQueue
buildQueue LogEnv
logEnv Int
memoryDepth = \case
    -- Under NoMirroring nothing enqueues, so the inert queue is unreachable.
    MirrorRuntimePlan
NoMirroring -> Either [BootError] MirrorQueue
-> IO (Either [BootError] MirrorQueue)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MirrorQueue -> Either [BootError] MirrorQueue
forall a b. b -> Either a b
Right MirrorQueue
noMirrorQueue)
    MirrorWith MirrorQueuePlan
queuePlan -> (Text -> BootError)
-> IO MirrorQueue -> IO (Either [BootError] MirrorQueue)
forall a. (Text -> BootError) -> IO a -> IO (Either [BootError] a)
refuseOnThrow Text -> BootError
MirrorQueueUnavailable (BuildMirrorQueue
buildQueue LogEnv
logEnv Int
memoryDepth MirrorQueuePlan
queuePlan)

{- One process-wide byte aggregate serves every publishing mount. It exists exactly when a
publication target is configured, the same predicate the plan's tenant derives from. -}
planPublishBudget :: MemoryPlan -> IO (Maybe PublishBudget)
planPublishBudget :: MemoryPlan -> IO (Maybe PublishBudget)
planPublishBudget MemoryPlan
memoryPlan =
    Maybe PublishTenant
-> (PublishTenant -> IO PublishBudget) -> IO (Maybe PublishBudget)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (MemoryPlan -> Maybe PublishTenant
mpPublishTenant MemoryPlan
memoryPlan) ((PublishTenant -> IO PublishBudget) -> IO (Maybe PublishBudget))
-> (PublishTenant -> IO PublishBudget) -> IO (Maybe PublishBudget)
forall a b. (a -> b) -> a -> b
$ \PublishTenant
tenant -> do
        bodyBudget <- Int -> IO ByteAdmission
newByteAdmission (PublishTenant -> Int
ptAggregateBytes PublishTenant
tenant)
        pure PublishBudget{pbBodyBudget = bodyBudget, pbMaxRequestBytes = mpMaxRequestBytes memoryPlan}

-- Where a store's mirror-write credential provider records its mint breaker and refresh outcomes.
credentialReportersOver :: DeferredMetrics -> Ecosystem -> StoreTag -> CredentialReporters
credentialReportersOver :: DeferredMetrics -> Ecosystem -> StoreTag -> CredentialReporters
credentialReportersOver DeferredMetrics
deferredMetrics Ecosystem
credentialIdentity StoreTag
tag =
    CredentialReporters
        { crBreakerReporter :: BreakerReporter
crBreakerReporter = DeferredMetrics -> BreakerSource -> BreakerReporter
deferredBreakerReporter DeferredMetrics
deferredMetrics BreakerSource
CredentialMint
        , crRefreshReporter :: RefreshReporter
crRefreshReporter = DeferredMetrics -> Ecosystem -> Provider -> RefreshReporter
deferredRefreshReporter DeferredMetrics
deferredMetrics Ecosystem
credentialIdentity (StoreTag -> Provider
providerLabel StoreTag
tag)
        }