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

{- | Vet store backends, then build the boot role's maintenance or observation capabilities.
The preview observes the declared private cache without constructing a deletion handle. No cleared
type's constructor is exported, so a value a deletion handle builds from exists only where a pass
here issued it.
-}
module Ecluse.Composition.Maintenance (
    -- * The config-decidable half
    ClearedBackend (cbUrl, cbAlphabet, cbFetchManifest),
    ResolveMaintenanceAdapter,
    vetStoreBackends,
    vetPrivateCaches,

    -- * The environment-dependent half
    StorePorts (..),
    BudgetPorts (..),
    storeScope,
    overrideKey,
    resolvedBudget,
    BuildUpstreamProbe,
    StoreBuilds (..),
    storeBuilds,
    buildStoreMaintenance,
    buildStoreObservation,
    buildUpstreamProbe,
    planStoreMaintenance,
    planStoreMaintenanceFor,

    -- * What the private upstream answers about public content
    readUpstreamSafety,
    upstreamFindings,
) where

import Data.Map.Strict qualified as Map
import Data.Text qualified as T
import Network.HTTP.Client (Manager)
import Network.HTTP.Client.TLS (tlsManagerSettings)
import Validation (eitherToValidation, validationToEither)

import Ecluse.Composition.BootError (
    Advisory (PrivateUpstreamUndecided),
    BootError (PrivateUpstreamProbeFailed, PrivateUpstreamUnsafe, StoreMaintenanceUnavailable),
    StoreMaintenanceReason (ClientBuildFailed, DeletionNotPermitted, NoControlPlane, NoProtocolMaintenance, PrivateCacheUnavailable),
    refuseOnThrow,
 )
import Ecluse.Composition.Credential (CredentialProviders, CredentialTarget (..), lookupTargetProvider)
import Ecluse.Composition.Sizing (newPooledManager)
import Ecluse.Composition.Types (RegistryRole (MirrorPreviewer, MirrorPruner, MirrorWriter))
import Ecluse.Composition.Vet (Severity (Ignore, Refuse), Vet, byStoreRole, rule, withRole)
import Ecluse.Config (
    ControlPlane (ControlCodeArtifact, ControlNone, ControlProtocol),
    DeletionConsent (DeletionPermitted, DeletionWithheld),
    MirrorTarget (mtBackend, mtUrl),
    Mount (mountRegistries),
    MountConfig (mntPrivateUpstream),
    MountMap,
    PrivateEndpoint (..),
    QuotaOverride (qoQuotas, qoScope, qoWeights),
    StoreBackend (BackendVerdaccio),
    StoreTag (TagCodeArtifact, TagRegistry, TagVerdaccio),
    Target (tgtTag, tgtUrl),
    regMirrorTarget,
    sbControl,
    sbTag,
    storeTagName,
 )
import Ecluse.Config.Resolve (mountKeyRef)
import Ecluse.Config.Target (resolvePrivateBackend)
import Ecluse.Core.Credential (ClientCredential, CredentialProvider, Secret, bareCredential, mintSecret)
import Ecluse.Core.Ecosystem (Ecosystem)
import Ecluse.Core.Fault (TransportCause (TransportProtocol), transportFault)
import Ecluse.Core.Registry (FetchFault (FetchTransport))
import Ecluse.Core.Registry.Adapter (
    RegistryAdapter,
    adapterMaintenance,
    adapterMetadata,
    adapterPublish,
 )
import Ecluse.Core.Registry.Adapter.Capability (
    AdapterMaintenance (maintenanceAlphabet, maintenanceListing, maintenanceVersionDelete),
    AdapterMetadata (metadataFetchManifest),
    AdapterPublish (publishCodec),
    ManifestFetch,
    StoreListing,
    VersionDelete,
 )
import Ecluse.Core.Registry.Exchange (singleAttemptSettings)
import Ecluse.Core.Registry.Maintenance (
    StoreFacts (factBudget),
    StoreMaintenance (storeFacts),
    StoreManifestRead,
    StoreObservation (obFacts),
    meteredMaintenance,
    meteredObservation,
    storeFaultOfMetadata,
 )
import Ecluse.Core.Registry.Maintenance.Budget (
    QuotaOrigin (QuotaDeclared),
    QuotaScope,
    RequestGate,
    StoreBudget (bgCosts, bgOrigin, bgQuotas, bgScope),
    mkQuotaScope,
 )
import Ecluse.Core.Registry.Maintenance.NameSpace (
    NameAlphabet,
    noNameAlphabet,
 )
import Ecluse.Core.Registry.Maintenance.Protocol (
    ProtocolRead (..),
    ProtocolStore (ProtocolStore, psDelete, psDeleteOrigin, psRead),
    newProtocolMaintenance,
    newProtocolObservation,
 )
import Ecluse.Core.Registry.Maintenance.Upstream (
    UpstreamSafety (Undecidable, Unsafe),
    noUpstreamMechanism,
 )
import Ecluse.Core.Registry.Metadata (MetadataError (MetadataFetch))
import Ecluse.Core.Registry.Origin (OriginClient, originClient)
import Ecluse.Core.Registry.Publish (PublishCodec)
import Ecluse.Core.Registry.Sweep.Pacing (derivedCapacity)
import Ecluse.Core.Security (Limits (maxVersionCount), authorityLabel)
import Ecluse.Core.Security.Egress (RegistryUrl, registryUrlText)
import Ecluse.Core.Telemetry.Span (TracingPort)
import Ecluse.Runtime.Maintenance.CodeArtifact (newCodeArtifactCacheMaintenance, newCodeArtifactCacheObservation, newCodeArtifactMaintenance, newCodeArtifactObservation, newCodeArtifactUpstreamProbe)
import Ecluse.Runtime.Maintenance.CodeArtifact.Decide (CodeArtifactStore)

{- | A store a deleting role's pass cleared, one arm per backend kind. Only 'vetStoreBackends' and
'vetPrivateCaches' issue one, so no store their passes did not clear gets a handle that can delete.
-}
data ClearedBackend = ClearedBackend
    { ClearedBackend -> RegistryUrl
cbUrl :: RegistryUrl
    -- ^ Where the store answers, which is both what a sweep reads and what it deletes from.
    , ClearedBackend -> NameAlphabet
cbAlphabet :: NameAlphabet
    -- ^ The characters a full walk partitions this store's names by.
    , ClearedBackend -> ManifestFetch
cbFetchManifest :: ManifestFetch
    {- ^ The mount ecosystem's own manifest read, which the root leads over the store's endpoint
    rather than over the public upstream.
    -}
    , ClearedBackend -> ClearedControl
cbControl :: ClearedControl
    -- ^ The backend control plane.
    }

-- | The control plane a cleared store offers, one arm per backend kind.
data ClearedControl
    = -- | A CodeArtifact repository, deleted through the vendor's own control plane.
      ClearedCodeArtifact CodeArtifactStore
    | -- | The configured cache permits refill without weakening ordinary mirror classification.
      ClearedCodeArtifactCache CodeArtifactStore
    | -- | A store with no vendor control plane, deleted through the ecosystem protocol.
      ClearedProtocol ClearedProtocolStore

-- | Vetted protocol operations and target-local authentication. An absent token means anonymous reads.
data ClearedProtocolStore = ClearedProtocolStore
    { ClearedProtocolStore -> Maybe Secret
cpsToken :: Maybe Secret
    , ClearedProtocolStore -> StoreTag
cpsTag :: StoreTag
    -- ^ The tag the store was declared under, which names the backend and its consent key.
    , ClearedProtocolStore -> DeletionConsent
cpsConsent :: DeletionConsent
    -- ^ What the operator wrote under that key, which the handle's own verdict reads.
    , ClearedProtocolStore -> Text
cpsConsentKey :: Text
    , ClearedProtocolStore -> StoreListing
cpsListing :: StoreListing
    , ClearedProtocolStore -> VersionDelete
cpsDelete :: VersionDelete
    , ClearedProtocolStore -> PublishCodec
cpsCodec :: PublishCodec
    }

{- | How the pass resolves a mount's ecosystem to the adapter this build ships, injected so a
spec drives the protocol rule over an adapter that fills no maintenance slice.
-}
type ResolveMaintenanceAdapter = Ecosystem -> Maybe RegistryAdapter

{- | The rule every declared mirror target meets: its resolved backend offers a control plane this
build can sweep. Both store roles refuse a target that fails it, and a writing role ignores it.
-}
vetStoreBackends :: ResolveMaintenanceAdapter -> MountMap -> Vet (Map Ecosystem ClearedBackend)
vetStoreBackends :: ResolveMaintenanceAdapter
-> MountMap -> Vet (Map Ecosystem ClearedBackend)
vetStoreBackends ResolveMaintenanceAdapter
resolveAdapter MountMap
mounts = (RegistryRole -> Vet (Map Ecosystem ClearedBackend))
-> Vet (Map Ecosystem ClearedBackend)
forall a. (RegistryRole -> Vet a) -> Vet a
withRole ((RegistryRole -> Vet (Map Ecosystem ClearedBackend))
 -> Vet (Map Ecosystem ClearedBackend))
-> (RegistryRole -> Vet (Map Ecosystem ClearedBackend))
-> Vet (Map Ecosystem ClearedBackend)
forall a b. (a -> b) -> a -> b
$ \RegistryRole
role ->
    let resolved :: [(Ecosystem, Either StoreMaintenanceReason ClearedBackend)]
resolved = RegistryRole
-> [(Ecosystem, Either StoreMaintenanceReason ClearedBackend)]
resolvedFor RegistryRole
role
     in RegistryRole
-> [(Ecosystem, Either StoreMaintenanceReason ClearedBackend)]
-> Map Ecosystem ClearedBackend
forall {reason} {a}.
RegistryRole -> [(Ecosystem, Either reason a)] -> Map Ecosystem a
clearedFor RegistryRole
role [(Ecosystem, Either StoreMaintenanceReason ClearedBackend)]
resolved Map Ecosystem ClearedBackend
-> Vet () -> Vet (Map Ecosystem ClearedBackend)
forall a b. a -> Vet b -> Vet a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ((Ecosystem, Either StoreMaintenanceReason ClearedBackend)
 -> Vet ())
-> [(Ecosystem, Either StoreMaintenanceReason ClearedBackend)]
-> Vet ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ((RegistryRole -> Severity (Ecosystem, StoreMaintenanceReason))
-> ((Ecosystem, Either StoreMaintenanceReason ClearedBackend)
    -> Maybe (Ecosystem, StoreMaintenanceReason))
-> (Ecosystem, Either StoreMaintenanceReason ClearedBackend)
-> Vet ()
forall finding input.
(RegistryRole -> Severity finding)
-> (input -> Maybe finding) -> input -> Vet ()
rule RegistryRole -> Severity (Ecosystem, StoreMaintenanceReason)
severity (Ecosystem, Either StoreMaintenanceReason ClearedBackend)
-> Maybe (Ecosystem, StoreMaintenanceReason)
forall reason a.
(Ecosystem, Either reason a) -> Maybe (Ecosystem, reason)
unmaintainedOf) [(Ecosystem, Either StoreMaintenanceReason ClearedBackend)]
resolved
  where
    resolvedFor :: RegistryRole
-> [(Ecosystem, Either StoreMaintenanceReason ClearedBackend)]
resolvedFor RegistryRole
role =
        [ (Ecosystem
eco, RegistryRole
-> Maybe RegistryAdapter
-> Ecosystem
-> MirrorTarget
-> Either StoreMaintenanceReason ClearedBackend
sweepableStore RegistryRole
role (ResolveMaintenanceAdapter
resolveAdapter Ecosystem
eco) Ecosystem
eco MirrorTarget
target)
        | (Ecosystem
eco, Mount
mount) <- MountMap -> [(Ecosystem, Mount)]
forall k a. Map k a -> [(k, a)]
Map.toAscList MountMap
mounts
        , Just MirrorTarget
target <- [MountRegistries -> Maybe MirrorTarget
regMirrorTarget (Mount -> MountRegistries
mountRegistries Mount
mount)]
        ]

    severity :: RegistryRole -> Severity (Ecosystem, StoreMaintenanceReason)
severity = Severity (Ecosystem, StoreMaintenanceReason)
-> Severity (Ecosystem, StoreMaintenanceReason)
-> RegistryRole
-> Severity (Ecosystem, StoreMaintenanceReason)
forall finding.
Severity finding
-> Severity finding -> RegistryRole -> Severity finding
byStoreRole (((Ecosystem, StoreMaintenanceReason) -> BootError)
-> Severity (Ecosystem, StoreMaintenanceReason)
forall finding. (finding -> BootError) -> Severity finding
Refuse ((Ecosystem -> StoreMaintenanceReason -> BootError)
-> (Ecosystem, StoreMaintenanceReason) -> BootError
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Ecosystem -> StoreMaintenanceReason -> BootError
StoreMaintenanceUnavailable)) Severity (Ecosystem, StoreMaintenanceReason)
forall finding. Severity finding
Ignore

    clearedFor :: RegistryRole -> [(Ecosystem, Either reason a)] -> Map Ecosystem a
clearedFor RegistryRole
role [(Ecosystem, Either reason a)]
resolved = case RegistryRole
role of
        RegistryRole
MirrorWriter -> Map Ecosystem a
forall k a. Map k a
Map.empty
        RegistryRole
MirrorPruner -> [(Ecosystem, Either reason a)] -> Map Ecosystem a
forall reason a. [(Ecosystem, Either reason a)] -> Map Ecosystem a
clearedOf [(Ecosystem, Either reason a)]
resolved
        RegistryRole
MirrorPreviewer -> [(Ecosystem, Either reason a)] -> Map Ecosystem a
forall reason a. [(Ecosystem, Either reason a)] -> Map Ecosystem a
clearedOf [(Ecosystem, Either reason a)]
resolved

-- | Vet each private cache under its own backend declaration and maintenance authority.
vetPrivateCaches :: ResolveMaintenanceAdapter -> Map Ecosystem MountConfig -> MountMap -> Vet (Map Ecosystem (Maybe StoreBackend, ClearedBackend))
vetPrivateCaches :: ResolveMaintenanceAdapter
-> Map Ecosystem MountConfig
-> MountMap
-> Vet (Map Ecosystem (Maybe StoreBackend, ClearedBackend))
vetPrivateCaches ResolveMaintenanceAdapter
resolveAdapter Map Ecosystem MountConfig
configured MountMap
mounts = (RegistryRole
 -> Vet (Map Ecosystem (Maybe StoreBackend, ClearedBackend)))
-> Vet (Map Ecosystem (Maybe StoreBackend, ClearedBackend))
forall a. (RegistryRole -> Vet a) -> Vet a
withRole ((RegistryRole
  -> Vet (Map Ecosystem (Maybe StoreBackend, ClearedBackend)))
 -> Vet (Map Ecosystem (Maybe StoreBackend, ClearedBackend)))
-> (RegistryRole
    -> Vet (Map Ecosystem (Maybe StoreBackend, ClearedBackend)))
-> Vet (Map Ecosystem (Maybe StoreBackend, ClearedBackend))
forall a b. (a -> b) -> a -> b
$ \case
    RegistryRole
MirrorWriter -> Map Ecosystem (Maybe StoreBackend, ClearedBackend)
-> Vet (Map Ecosystem (Maybe StoreBackend, ClearedBackend))
forall a. a -> Vet a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map Ecosystem (Maybe StoreBackend, ClearedBackend)
forall k a. Map k a
Map.empty
    RegistryRole
MirrorPruner -> RegistryRole
-> Vet (Map Ecosystem (Maybe StoreBackend, ClearedBackend))
clearedFor RegistryRole
MirrorPruner
    RegistryRole
MirrorPreviewer -> RegistryRole
-> Vet (Map Ecosystem (Maybe StoreBackend, ClearedBackend))
clearedFor RegistryRole
MirrorPreviewer
  where
    clearedFor :: RegistryRole
-> Vet (Map Ecosystem (Maybe StoreBackend, ClearedBackend))
clearedFor RegistryRole
role =
        let resolved :: [(Ecosystem,
  Either
    StoreMaintenanceReason (Maybe StoreBackend, ClearedBackend))]
resolved = RegistryRole
-> [(Ecosystem,
     Either
       StoreMaintenanceReason (Maybe StoreBackend, ClearedBackend))]
resolvedFor RegistryRole
role
         in [(Ecosystem,
  Either
    StoreMaintenanceReason (Maybe StoreBackend, ClearedBackend))]
-> Map Ecosystem (Maybe StoreBackend, ClearedBackend)
forall reason a. [(Ecosystem, Either reason a)] -> Map Ecosystem a
clearedOf [(Ecosystem,
  Either
    StoreMaintenanceReason (Maybe StoreBackend, ClearedBackend))]
resolved
                Map Ecosystem (Maybe StoreBackend, ClearedBackend)
-> Vet ()
-> Vet (Map Ecosystem (Maybe StoreBackend, ClearedBackend))
forall a b. a -> Vet b -> Vet a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ((Ecosystem,
  Either StoreMaintenanceReason (Maybe StoreBackend, ClearedBackend))
 -> Vet ())
-> [(Ecosystem,
     Either
       StoreMaintenanceReason (Maybe StoreBackend, ClearedBackend))]
-> Vet ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ((RegistryRole -> Severity (Ecosystem, StoreMaintenanceReason))
-> ((Ecosystem,
     Either StoreMaintenanceReason (Maybe StoreBackend, ClearedBackend))
    -> Maybe (Ecosystem, StoreMaintenanceReason))
-> (Ecosystem,
    Either StoreMaintenanceReason (Maybe StoreBackend, ClearedBackend))
-> Vet ()
forall finding input.
(RegistryRole -> Severity finding)
-> (input -> Maybe finding) -> input -> Vet ()
rule (Severity (Ecosystem, StoreMaintenanceReason)
-> RegistryRole -> Severity (Ecosystem, StoreMaintenanceReason)
forall a b. a -> b -> a
const (((Ecosystem, StoreMaintenanceReason) -> BootError)
-> Severity (Ecosystem, StoreMaintenanceReason)
forall finding. (finding -> BootError) -> Severity finding
Refuse ((Ecosystem -> StoreMaintenanceReason -> BootError)
-> (Ecosystem, StoreMaintenanceReason) -> BootError
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Ecosystem -> StoreMaintenanceReason -> BootError
StoreMaintenanceUnavailable))) (Ecosystem,
 Either StoreMaintenanceReason (Maybe StoreBackend, ClearedBackend))
-> Maybe (Ecosystem, StoreMaintenanceReason)
forall reason a.
(Ecosystem, Either reason a) -> Maybe (Ecosystem, reason)
unmaintainedOf) [(Ecosystem,
  Either
    StoreMaintenanceReason (Maybe StoreBackend, ClearedBackend))]
resolved
    resolvedFor :: RegistryRole
-> [(Ecosystem,
     Either
       StoreMaintenanceReason (Maybe StoreBackend, ClearedBackend))]
resolvedFor RegistryRole
role =
        [ (Ecosystem
eco, RegistryRole
-> Ecosystem
-> PrivateEndpoint
-> Either
     StoreMaintenanceReason (Maybe StoreBackend, ClearedBackend)
resolve RegistryRole
role Ecosystem
eco PrivateEndpoint
endpoint)
        | (Ecosystem
eco, Mount
mount) <- MountMap -> [(Ecosystem, Mount)]
forall k a. Map k a -> [(k, a)]
Map.toAscList MountMap
mounts
        , Maybe MirrorTarget -> Bool
forall a. Maybe a -> Bool
isJust (MountRegistries -> Maybe MirrorTarget
regMirrorTarget (Mount -> MountRegistries
mountRegistries Mount
mount))
        , Just MountConfig
config <- [Ecosystem -> Map Ecosystem MountConfig -> Maybe MountConfig
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Ecosystem
eco Map Ecosystem MountConfig
configured]
        , Just PrivateEndpoint
endpoint <- [MountConfig -> Maybe PrivateEndpoint
mntPrivateUpstream MountConfig
config]
        ]
    resolve :: RegistryRole
-> Ecosystem
-> PrivateEndpoint
-> Either
     StoreMaintenanceReason (Maybe StoreBackend, ClearedBackend)
resolve RegistryRole
role Ecosystem
eco PrivateEndpoint
endpoint = case Target -> StoreTag
tgtTag Target
target of
        StoreTag
TagCodeArtifact -> do
            (backend, store) <- (ConfigError -> StoreMaintenanceReason)
-> Either ConfigError (StoreBackend, CodeArtifactStore)
-> Either StoreMaintenanceReason (StoreBackend, CodeArtifactStore)
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Text -> StoreMaintenanceReason
PrivateCacheUnavailable (Text -> StoreMaintenanceReason)
-> (ConfigError -> Text) -> ConfigError -> StoreMaintenanceReason
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConfigError -> Text
forall b a. (Show a, IsString b) => a -> b
show) (Ecosystem
-> Target -> Either ConfigError (StoreBackend, CodeArtifactStore)
resolvePrivateBackend Ecosystem
eco Target
target)
            pure (Just backend, clearedBackend (tgtUrl target) adapter (ClearedCodeArtifactCache store))
        StoreTag
TagRegistry -> StoreMaintenanceReason
-> Either
     StoreMaintenanceReason (Maybe StoreBackend, ClearedBackend)
forall a b. a -> Either a b
Left (Text -> StoreMaintenanceReason
PrivateCacheUnavailable Text
"registry has no inventory control plane")
        StoreTag
TagVerdaccio -> do
            Bool
-> Either StoreMaintenanceReason ()
-> Either StoreMaintenanceReason ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RegistryRole -> Bool
refusesWithoutConsent RegistryRole
role Bool -> Bool -> Bool
&& PrivateEndpoint -> DeletionConsent
preConsent PrivateEndpoint
endpoint DeletionConsent -> DeletionConsent -> Bool
forall a. Eq a => a -> a -> Bool
== DeletionConsent
DeletionWithheld) (Either StoreMaintenanceReason ()
 -> Either StoreMaintenanceReason ())
-> Either StoreMaintenanceReason ()
-> Either StoreMaintenanceReason ()
forall a b. (a -> b) -> a -> b
$
                StoreMaintenanceReason -> Either StoreMaintenanceReason ()
forall a b. a -> Either a b
Left (Text -> StoreMaintenanceReason
PrivateCacheUnavailable (Text
descriptor Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is not set"))
            Bool
-> Either StoreMaintenanceReason ()
-> Either StoreMaintenanceReason ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RegistryRole
role RegistryRole -> RegistryRole -> Bool
forall a. Eq a => a -> a -> Bool
== RegistryRole
MirrorPruner Bool -> Bool -> Bool
&& Maybe Secret -> Bool
forall a. Maybe a -> Bool
isNothing (PrivateEndpoint -> Maybe Secret
preToken PrivateEndpoint
endpoint)) (Either StoreMaintenanceReason ()
 -> Either StoreMaintenanceReason ())
-> Either StoreMaintenanceReason ()
-> Either StoreMaintenanceReason ()
forall a b. (a -> b) -> a -> b
$
                StoreMaintenanceReason -> Either StoreMaintenanceReason ()
forall a b. a -> Either a b
Left (Text -> StoreMaintenanceReason
PrivateCacheUnavailable (Ecosystem -> Text -> Text
mountKeyRef Ecosystem
eco Text
"privateUpstream.verdaccio.token" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is not set"))
            store <- Maybe RegistryAdapter
-> StoreTag
-> Maybe Secret
-> DeletionConsent
-> Text
-> Either StoreMaintenanceReason ClearedProtocolStore
protocolStoreFor Maybe RegistryAdapter
adapter StoreTag
TagVerdaccio (PrivateEndpoint -> Maybe Secret
preToken PrivateEndpoint
endpoint) (PrivateEndpoint -> DeletionConsent
preConsent PrivateEndpoint
endpoint) Text
descriptor
            pure (fmap (`BackendVerdaccio` preConsent endpoint) (preToken endpoint), clearedBackend (tgtUrl target) adapter (ClearedProtocol store))
      where
        target :: Target
target = PrivateEndpoint -> Target
preTarget PrivateEndpoint
endpoint
        adapter :: Maybe RegistryAdapter
adapter = ResolveMaintenanceAdapter
resolveAdapter Ecosystem
eco
        descriptor :: Text
descriptor = Ecosystem -> Text -> Text
mountKeyRef Ecosystem
eco Text
"privateUpstream.verdaccio.permitDeletion"

-- A resolved entry that failed, named by the ecosystem that declared it.
unmaintainedOf :: (Ecosystem, Either reason a) -> Maybe (Ecosystem, reason)
unmaintainedOf :: forall reason a.
(Ecosystem, Either reason a) -> Maybe (Ecosystem, reason)
unmaintainedOf (Ecosystem
eco, Either reason a
outcome) = (Ecosystem
eco,) (reason -> (Ecosystem, reason))
-> Maybe reason -> Maybe (Ecosystem, reason)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either reason a -> Maybe reason
forall l r. Either l r -> Maybe l
leftToMaybe Either reason a
outcome

-- A refused pass yields no plan, so a target the rule refused never reaches this map.
clearedOf :: [(Ecosystem, Either reason a)] -> Map Ecosystem a
clearedOf :: forall reason a. [(Ecosystem, Either reason a)] -> Map Ecosystem a
clearedOf [(Ecosystem, Either reason a)]
resolved = [(Ecosystem, a)] -> Map Ecosystem a
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Ecosystem
eco, a
backend) | (Ecosystem
eco, Right a
backend) <- [(Ecosystem, Either reason a)]
resolved]

{- Whether this role's boot needs the operator's own deletion key in hand. A preview reads the
store and changes nothing, so the key is a finding it reports rather than one it refuses on. -}
refusesWithoutConsent :: RegistryRole -> Bool
refusesWithoutConsent :: RegistryRole -> Bool
refusesWithoutConsent = \case
    RegistryRole
MirrorWriter -> Bool
False
    RegistryRole
MirrorPruner -> Bool
True
    RegistryRole
MirrorPreviewer -> Bool
False

-- The store a resolved backend lets the Dredger reach, or why this build reaches none.
sweepableStore :: RegistryRole -> Maybe RegistryAdapter -> Ecosystem -> MirrorTarget -> Either StoreMaintenanceReason ClearedBackend
sweepableStore :: RegistryRole
-> Maybe RegistryAdapter
-> Ecosystem
-> MirrorTarget
-> Either StoreMaintenanceReason ClearedBackend
sweepableStore RegistryRole
role Maybe RegistryAdapter
mAdapter Ecosystem
eco MirrorTarget
target = RegistryUrl
-> Maybe RegistryAdapter -> ClearedControl -> ClearedBackend
clearedBackend (MirrorTarget -> RegistryUrl
mtUrl MirrorTarget
target) Maybe RegistryAdapter
mAdapter (ClearedControl -> ClearedBackend)
-> Either StoreMaintenanceReason ClearedControl
-> Either StoreMaintenanceReason ClearedBackend
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either StoreMaintenanceReason ClearedControl
control
  where
    backend :: StoreBackend
backend = MirrorTarget -> StoreBackend
mtBackend MirrorTarget
target
    control :: Either StoreMaintenanceReason ClearedControl
control = case StoreBackend -> ControlPlane
sbControl StoreBackend
backend of
        ControlCodeArtifact CodeArtifactStore
store -> ClearedControl -> Either StoreMaintenanceReason ClearedControl
forall a b. b -> Either a b
Right (CodeArtifactStore -> ClearedControl
ClearedCodeArtifact CodeArtifactStore
store)
        ControlPlane
ControlNone -> StoreMaintenanceReason
-> Either StoreMaintenanceReason ClearedControl
forall a b. a -> Either a b
Left (StoreTag -> StoreMaintenanceReason
NoControlPlane (StoreBackend -> StoreTag
sbTag StoreBackend
backend))
        ControlProtocol Secret
token DeletionConsent
consent -> do
            Bool
-> Either StoreMaintenanceReason ()
-> Either StoreMaintenanceReason ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DeletionConsent
consent DeletionConsent -> DeletionConsent -> Bool
forall a. Eq a => a -> a -> Bool
== DeletionConsent
DeletionWithheld Bool -> Bool -> Bool
&& RegistryRole -> Bool
refusesWithoutConsent RegistryRole
role) (StoreMaintenanceReason -> Either StoreMaintenanceReason ()
forall a b. a -> Either a b
Left (StoreTag -> StoreMaintenanceReason
DeletionNotPermitted (StoreBackend -> StoreTag
sbTag StoreBackend
backend)))
            ClearedProtocolStore -> ClearedControl
ClearedProtocol (ClearedProtocolStore -> ClearedControl)
-> Either StoreMaintenanceReason ClearedProtocolStore
-> Either StoreMaintenanceReason ClearedControl
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe RegistryAdapter
-> StoreTag
-> Maybe Secret
-> DeletionConsent
-> Text
-> Either StoreMaintenanceReason ClearedProtocolStore
protocolStoreFor Maybe RegistryAdapter
mAdapter (StoreBackend -> StoreTag
sbTag StoreBackend
backend) (Secret -> Maybe Secret
forall a. a -> Maybe a
Just Secret
token) DeletionConsent
consent (Ecosystem -> StoreTag -> Text
consentDescriptor Ecosystem
eco (StoreBackend -> StoreTag
sbTag StoreBackend
backend))

clearedBackend :: RegistryUrl -> Maybe RegistryAdapter -> ClearedControl -> ClearedBackend
clearedBackend :: RegistryUrl
-> Maybe RegistryAdapter -> ClearedControl -> ClearedBackend
clearedBackend RegistryUrl
url Maybe RegistryAdapter
adapter ClearedControl
control =
    ClearedBackend
        { cbUrl :: RegistryUrl
cbUrl = RegistryUrl
url
        , cbAlphabet :: NameAlphabet
cbAlphabet = NameAlphabet
-> (RegistryAdapter -> NameAlphabet)
-> Maybe RegistryAdapter
-> NameAlphabet
forall b a. b -> (a -> b) -> Maybe a -> b
maybe NameAlphabet
noNameAlphabet (AdapterMaintenance -> NameAlphabet
maintenanceAlphabet (AdapterMaintenance -> NameAlphabet)
-> (RegistryAdapter -> AdapterMaintenance)
-> RegistryAdapter
-> NameAlphabet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RegistryAdapter -> AdapterMaintenance
adapterMaintenance) Maybe RegistryAdapter
adapter
        , cbFetchManifest :: ManifestFetch
cbFetchManifest = ManifestFetch
-> (RegistryAdapter -> ManifestFetch)
-> Maybe RegistryAdapter
-> ManifestFetch
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ManifestFetch
absentManifestRead (AdapterMetadata -> ManifestFetch
metadataFetchManifest (AdapterMetadata -> ManifestFetch)
-> (RegistryAdapter -> AdapterMetadata)
-> RegistryAdapter
-> ManifestFetch
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RegistryAdapter -> AdapterMetadata
adapterMetadata) Maybe RegistryAdapter
adapter
        , cbControl :: ClearedControl
cbControl = ClearedControl
control
        }

protocolStoreFor :: Maybe RegistryAdapter -> StoreTag -> Maybe Secret -> DeletionConsent -> Text -> Either StoreMaintenanceReason ClearedProtocolStore
protocolStoreFor :: Maybe RegistryAdapter
-> StoreTag
-> Maybe Secret
-> DeletionConsent
-> Text
-> Either StoreMaintenanceReason ClearedProtocolStore
protocolStoreFor Maybe RegistryAdapter
mAdapter StoreTag
tag Maybe Secret
token DeletionConsent
consent Text
descriptor = do
    adapter <- StoreMaintenanceReason
-> Maybe RegistryAdapter
-> Either StoreMaintenanceReason RegistryAdapter
forall l r. l -> Maybe r -> Either l r
maybeToRight StoreMaintenanceReason
NoProtocolMaintenance Maybe RegistryAdapter
mAdapter
    listing <- maybeToRight NoProtocolMaintenance (maintenanceListing (adapterMaintenance adapter))
    delete <- maybeToRight NoProtocolMaintenance (maintenanceVersionDelete (adapterMaintenance adapter))
    publish <- maybeToRight NoProtocolMaintenance (adapterPublish adapter)
    pure
        ClearedProtocolStore
            { cpsToken = token
            , cpsTag = tag
            , cpsConsent = consent
            , cpsConsentKey = descriptor
            , cpsListing = listing
            , cpsDelete = delete
            , cpsCodec = publishCodec publish
            }

-- The read a store cleared without an adapter would make, which no boot reaches.
absentManifestRead :: ManifestFetch
absentManifestRead :: ManifestFetch
absentManifestRead TracingPort
_ OriginClient
_ PackageName
_ =
    Either MetadataError Manifest -> IO (Either MetadataError Manifest)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MetadataError -> Either MetadataError Manifest
forall a b. a -> Either a b
Left (FetchFault -> MetadataError
MetadataFetch (TransportFault -> FetchFault
FetchTransport (TransportCause -> Text -> TransportFault
transportFault TransportCause
TransportProtocol Text
absentAdapterDetail))))

absentAdapterDetail :: Text
absentAdapterDetail :: Text
absentAdapterDetail = Text
"this build serves the mount's ecosystem no metadata read"

-- | Per-target tracing and authentication, resolved before the store handles are built.
data StorePorts = StorePorts
    { StorePorts -> TracingPort
spTracing :: TracingPort
    -- ^ The tracing port the manifest read is bracketed by.
    , StorePorts -> Maybe CredentialProvider
spCredential :: Maybe CredentialProvider
    -- ^ The credential for this exact target. An anonymous protocol observation holds none.
    , StorePorts -> BudgetPorts
spBudget :: BudgetPorts
    -- ^ What this store's requests are counted and paced through.
    }

{- | What the boot knows about request capacity before any store is built: the gate for each
capacity pool, and what the operator declared about those pools.
-}
data BudgetPorts = BudgetPorts
    { BudgetPorts -> QuotaScope -> RequestGate
bpGateFor :: QuotaScope -> RequestGate
    , BudgetPorts -> Map Text QuotaOverride
bpOverrides :: Map Text QuotaOverride
    , BudgetPorts -> Rational
bpNominalPace :: Rational
    -- ^ The sweep's own package pace, which a backend publishing no quota is taken to run at.
    }

{- | How a boot builds one store's maintenance handle, under the response bound the plan resolved.
Injected, as the queue builder is, so a spec drives the pruner's arm without an AWS identity.
-}
type BuildStoreMaintenance = StorePorts -> Limits -> ClearedBackend -> IO StoreMaintenance

{- | How a boot builds the observing calls for a cleared store, under the same bound. Nothing it
builds can delete, write a marker, or publish.
-}
type BuildStoreObservation = StorePorts -> Limits -> ClearedBackend -> IO StoreObservation

{- | The builds a boot chooses between: one per Dredger authority, and the serving role's probe.
The role picks its own, so a preview's boot never runs the build that holds a delete.
-}
data StoreBuilds = StoreBuilds
    { StoreBuilds -> BuildStoreMaintenance
sbDeleting :: BuildStoreMaintenance
    , StoreBuilds -> BuildStoreObservation
sbObserving :: BuildStoreObservation
    , StoreBuilds -> BuildUpstreamProbe
sbProbing :: BuildUpstreamProbe
    }

-- | The shipped builds.
storeBuilds :: StoreBuilds
storeBuilds :: StoreBuilds
storeBuilds =
    StoreBuilds
        { sbDeleting :: BuildStoreMaintenance
sbDeleting = BuildStoreMaintenance
buildStoreMaintenance
        , sbObserving :: BuildStoreObservation
sbObserving = BuildStoreObservation
buildStoreObservation
        , sbProbing :: BuildUpstreamProbe
sbProbing = BuildUpstreamProbe
buildUpstreamProbe
        }

{- | How a boot builds the probe for one mount's private upstream. Injected, as the store builds
are, so a spec drives what a boot does with an answer without an AWS identity.
-}
type BuildUpstreamProbe = Ecosystem -> PrivateEndpoint -> IO UpstreamSafety

{- | The shipped build. It asks the backend the mount declared, over the role's own ambient
identity, so no caller's credential reaches the call.
-}
buildUpstreamProbe :: BuildUpstreamProbe
buildUpstreamProbe :: BuildUpstreamProbe
buildUpstreamProbe Ecosystem
eco PrivateEndpoint
endpoint = case Target -> StoreTag
tgtTag Target
target of
    -- 'vetPrivateRepository' refuses an endpoint addressing no repository, so this resolution
    -- fails only for a value no loaded configuration carries, and there is nothing to ask about.
    StoreTag
TagCodeArtifact -> (ConfigError -> IO UpstreamSafety)
-> ((StoreBackend, CodeArtifactStore) -> IO UpstreamSafety)
-> Either ConfigError (StoreBackend, CodeArtifactStore)
-> IO UpstreamSafety
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (IO UpstreamSafety -> ConfigError -> IO UpstreamSafety
forall a b. a -> b -> a
const IO UpstreamSafety
forall (m :: * -> *). Applicative m => m UpstreamSafety
noUpstreamMechanism) (CodeArtifactStore -> IO UpstreamSafety
newCodeArtifactUpstreamProbe (CodeArtifactStore -> IO UpstreamSafety)
-> ((StoreBackend, CodeArtifactStore) -> CodeArtifactStore)
-> (StoreBackend, CodeArtifactStore)
-> IO UpstreamSafety
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StoreBackend, CodeArtifactStore) -> CodeArtifactStore
forall a b. (a, b) -> b
snd) (Ecosystem
-> Target -> Either ConfigError (StoreBackend, CodeArtifactStore)
resolvePrivateBackend Ecosystem
eco Target
target)
    StoreTag
TagRegistry -> IO UpstreamSafety
forall (m :: * -> *). Applicative m => m UpstreamSafety
noUpstreamMechanism
    StoreTag
TagVerdaccio -> IO UpstreamSafety
forall (m :: * -> *). Applicative m => m UpstreamSafety
noUpstreamMechanism
  where
    target :: Target
target = PrivateEndpoint -> Target
preTarget PrivateEndpoint
endpoint

{- | Read every probe's answer. A backend reads its own identity and its own faults into an
answer, so a throw that reaches here refuses the mount rather than passing for an open question.
-}
readUpstreamSafety :: [(Ecosystem, IO UpstreamSafety)] -> IO ([Advisory], Either [BootError] ())
readUpstreamSafety :: [(Ecosystem, IO UpstreamSafety)]
-> IO ([Advisory], Either [BootError] ())
readUpstreamSafety [(Ecosystem, IO UpstreamSafety)]
probes = ([[BootError]], [(Ecosystem, UpstreamSafety)])
-> ([Advisory], Either [BootError] ())
forall {t :: * -> *}.
Foldable t =>
(t [BootError], [(Ecosystem, UpstreamSafety)])
-> ([Advisory], Either [BootError] ())
settled (([[BootError]], [(Ecosystem, UpstreamSafety)])
 -> ([Advisory], Either [BootError] ()))
-> ([Either [BootError] (Ecosystem, UpstreamSafety)]
    -> ([[BootError]], [(Ecosystem, UpstreamSafety)]))
-> [Either [BootError] (Ecosystem, UpstreamSafety)]
-> ([Advisory], Either [BootError] ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either [BootError] (Ecosystem, UpstreamSafety)]
-> ([[BootError]], [(Ecosystem, UpstreamSafety)])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either [BootError] (Ecosystem, UpstreamSafety)]
 -> ([Advisory], Either [BootError] ()))
-> IO [Either [BootError] (Ecosystem, UpstreamSafety)]
-> IO ([Advisory], Either [BootError] ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Ecosystem, IO UpstreamSafety)
 -> IO (Either [BootError] (Ecosystem, UpstreamSafety)))
-> [(Ecosystem, IO UpstreamSafety)]
-> IO [Either [BootError] (Ecosystem, UpstreamSafety)]
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 (Ecosystem, IO UpstreamSafety)
-> IO (Either [BootError] (Ecosystem, UpstreamSafety))
forall {a}.
(Ecosystem, IO a) -> IO (Either [BootError] (Ecosystem, a))
answer [(Ecosystem, IO UpstreamSafety)]
probes
  where
    answer :: (Ecosystem, IO a) -> IO (Either [BootError] (Ecosystem, a))
answer (Ecosystem
eco, IO a
probe) = (a -> (Ecosystem, a))
-> Either [BootError] a -> Either [BootError] (Ecosystem, a)
forall a b.
(a -> b) -> Either [BootError] a -> Either [BootError] b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Ecosystem
eco,) (Either [BootError] a -> Either [BootError] (Ecosystem, a))
-> IO (Either [BootError] a)
-> IO (Either [BootError] (Ecosystem, a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> BootError) -> IO a -> IO (Either [BootError] a)
forall a. (Text -> BootError) -> IO a -> IO (Either [BootError] a)
refuseOnThrow (Ecosystem -> Text -> BootError
PrivateUpstreamProbeFailed Ecosystem
eco) IO a
probe

    settled :: (t [BootError], [(Ecosystem, UpstreamSafety)])
-> ([Advisory], Either [BootError] ())
settled (t [BootError]
thrown, [(Ecosystem, UpstreamSafety)]
answers) =
        let ([Advisory]
advisories, Either [BootError] ()
refused) = [(Ecosystem, UpstreamSafety)]
-> ([Advisory], Either [BootError] ())
upstreamFindings [(Ecosystem, UpstreamSafety)]
answers
         in ([Advisory]
advisories, [BootError] -> Either [BootError] ()
refusals (t [BootError] -> [BootError]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat t [BootError]
thrown [BootError] -> [BootError] -> [BootError]
forall a. Semigroup a => a -> a -> a
<> [BootError] -> Either [BootError] () -> [BootError]
forall a b. a -> Either a b -> a
fromLeft [] Either [BootError] ()
refused))

{- | What a boot does about the answers it read: an unsafe repository refuses the role, an open
question advises, and a safe one says nothing.
-}
upstreamFindings :: [(Ecosystem, UpstreamSafety)] -> ([Advisory], Either [BootError] ())
upstreamFindings :: [(Ecosystem, UpstreamSafety)]
-> ([Advisory], Either [BootError] ())
upstreamFindings [(Ecosystem, UpstreamSafety)]
answers = ([Advisory]
advisories, [BootError] -> Either [BootError] ()
refusals [BootError]
unsafeMounts)
  where
    advisories :: [Advisory]
advisories = [Ecosystem -> UndecidabilityReason -> Advisory
PrivateUpstreamUndecided Ecosystem
eco UndecidabilityReason
reason | (Ecosystem
eco, Undecidable UndecidabilityReason
reason) <- [(Ecosystem, UpstreamSafety)]
answers]
    unsafeMounts :: [BootError]
unsafeMounts = [Ecosystem -> UnsafeReason -> BootError
PrivateUpstreamUnsafe Ecosystem
eco UnsafeReason
reason | (Ecosystem
eco, Unsafe UnsafeReason
reason) <- [(Ecosystem, UpstreamSafety)]
answers]

-- Nothing found is nothing refused, which is what lets a whole pass report at once.
refusals :: [BootError] -> Either [BootError] ()
refusals :: [BootError] -> Either [BootError] ()
refusals [BootError]
found = if [BootError] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [BootError]
found then () -> Either [BootError] ()
forall a b. b -> Either a b
Right () else [BootError] -> Either [BootError] ()
forall a b. a -> Either a b
Left [BootError]
found

{- | The live handle for a cleared store. CodeArtifact discovers its credentials the standard AWS
way, and both arms read and dial over one manager of the store's own.
-}
buildStoreMaintenance :: BuildStoreMaintenance
buildStoreMaintenance :: BuildStoreMaintenance
buildStoreMaintenance StorePorts
ports Limits
limits ClearedBackend
cleared = StorePorts
-> ClearedBackend -> StoreMaintenance -> StoreMaintenance
budgeted StorePorts
ports ClearedBackend
cleared (StoreMaintenance -> StoreMaintenance)
-> IO StoreMaintenance -> IO StoreMaintenance
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO StoreMaintenance
built
  where
    built :: IO StoreMaintenance
built = do
        (readManifest, manager) <- StorePorts
-> Limits -> ClearedBackend -> IO (StoreManifestRead, Manager)
storeAccess StorePorts
ports Limits
limits ClearedBackend
cleared
        case cbControl cleared of
            ClearedCodeArtifact CodeArtifactStore
store -> Int
-> NameAlphabet
-> StoreManifestRead
-> CodeArtifactStore
-> IO StoreMaintenance
newCodeArtifactMaintenance (Limits -> Int
maxVersionCount Limits
limits) (ClearedBackend -> NameAlphabet
cbAlphabet ClearedBackend
cleared) StoreManifestRead
readManifest CodeArtifactStore
store
            ClearedCodeArtifactCache CodeArtifactStore
store -> Int
-> NameAlphabet
-> StoreManifestRead
-> CodeArtifactStore
-> IO StoreMaintenance
newCodeArtifactCacheMaintenance (Limits -> Int
maxVersionCount Limits
limits) (ClearedBackend -> NameAlphabet
cbAlphabet ClearedBackend
cleared) StoreManifestRead
readManifest CodeArtifactStore
store
            ClearedProtocol ClearedProtocolStore
store -> do
                deletionManager <- Int -> ManagerSettings -> IO Manager
newPooledManager Int
storeConnections (ManagerSettings -> ManagerSettings
singleAttemptSettings ManagerSettings
tlsManagerSettings)
                pure (newProtocolMaintenance (protocolStore limits cleared store readManifest manager deletionManager))

{- The handle under this store's resolved capacity, with every request it makes counted and paced.
The capacity resolves first, because the pool it names is the pool the gate meters in. -}
budgeted :: StorePorts -> ClearedBackend -> StoreMaintenance -> StoreMaintenance
budgeted :: StorePorts
-> ClearedBackend -> StoreMaintenance -> StoreMaintenance
budgeted StorePorts
ports ClearedBackend
cleared StoreMaintenance
handle =
    (RequestGate -> StoreMaintenance -> StoreMaintenance
meteredMaintenance (StorePorts -> StoreFacts -> RequestGate
gateOver StorePorts
ports StoreFacts
facts) StoreMaintenance
handle){storeFacts = facts}
  where
    facts :: StoreFacts
facts = StorePorts -> ClearedBackend -> StoreFacts -> StoreFacts
resolvedFacts StorePorts
ports ClearedBackend
cleared (StoreMaintenance -> StoreFacts
storeFacts StoreMaintenance
handle)

{- | The observing calls for a cleared store, built from the backend's own read capability rather
than from a handle with its writes taken away.
-}
buildStoreObservation :: BuildStoreObservation
buildStoreObservation :: BuildStoreObservation
buildStoreObservation StorePorts
ports Limits
limits ClearedBackend
cleared = StoreObservation -> StoreObservation
observed (StoreObservation -> StoreObservation)
-> IO StoreObservation -> IO StoreObservation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO StoreObservation
built
  where
    observed :: StoreObservation -> StoreObservation
observed StoreObservation
handle =
        let facts :: StoreFacts
facts = StorePorts -> ClearedBackend -> StoreFacts -> StoreFacts
resolvedFacts StorePorts
ports ClearedBackend
cleared (StoreObservation -> StoreFacts
obFacts StoreObservation
handle)
         in (RequestGate -> StoreObservation -> StoreObservation
meteredObservation (StorePorts -> StoreFacts -> RequestGate
gateOver StorePorts
ports StoreFacts
facts) StoreObservation
handle){obFacts = facts}
    built :: IO StoreObservation
built = do
        (readManifest, manager) <- StorePorts
-> Limits -> ClearedBackend -> IO (StoreManifestRead, Manager)
storeAccess StorePorts
ports Limits
limits ClearedBackend
cleared
        case cbControl cleared of
            ClearedCodeArtifact CodeArtifactStore
store -> Int
-> NameAlphabet
-> StoreManifestRead
-> CodeArtifactStore
-> IO StoreObservation
newCodeArtifactObservation (Limits -> Int
maxVersionCount Limits
limits) (ClearedBackend -> NameAlphabet
cbAlphabet ClearedBackend
cleared) StoreManifestRead
readManifest CodeArtifactStore
store
            ClearedCodeArtifactCache CodeArtifactStore
store -> Int
-> NameAlphabet
-> StoreManifestRead
-> CodeArtifactStore
-> IO StoreObservation
newCodeArtifactCacheObservation (Limits -> Int
maxVersionCount Limits
limits) (ClearedBackend -> NameAlphabet
cbAlphabet ClearedBackend
cleared) StoreManifestRead
readManifest CodeArtifactStore
store
            ClearedProtocol ClearedProtocolStore
store ->
                StoreObservation -> IO StoreObservation
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ProtocolRead -> StoreObservation
newProtocolObservation (Limits
-> ClearedBackend
-> ClearedProtocolStore
-> StoreManifestRead
-> Manager
-> ProtocolRead
protocolRead Limits
limits ClearedBackend
cleared ClearedProtocolStore
store StoreManifestRead
readManifest Manager
manager))

resolvedFacts :: StorePorts -> ClearedBackend -> StoreFacts -> StoreFacts
resolvedFacts :: StorePorts -> ClearedBackend -> StoreFacts -> StoreFacts
resolvedFacts StorePorts
ports ClearedBackend
cleared StoreFacts
facts =
    StoreFacts
facts{factBudget = resolvedBudget (spBudget ports) (cbUrl cleared) (factBudget facts)}

-- The gate for the pool this store's resolved capacity landed in.
gateOver :: StorePorts -> StoreFacts -> RequestGate
gateOver :: StorePorts -> StoreFacts -> RequestGate
gateOver StorePorts
ports StoreFacts
facts = BudgetPorts -> QuotaScope -> RequestGate
bpGateFor (StorePorts -> BudgetPorts
spBudget StorePorts
ports) (StoreBudget -> QuotaScope
bgScope (StoreFacts -> StoreBudget
factBudget StoreFacts
facts))

{- | The pool a store falls in when its backend names none of its own: the store's own authority,
so two paths on one host share it.
-}
storeScope :: RegistryUrl -> QuotaScope
storeScope :: RegistryUrl -> QuotaScope
storeScope = Text -> QuotaScope
mkQuotaScope (Text -> QuotaScope)
-> (RegistryUrl -> Text) -> RegistryUrl -> QuotaScope
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
authorityLabel (Text -> Text) -> (RegistryUrl -> Text) -> RegistryUrl -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RegistryUrl -> Text
registryUrlText

{- | The spelling a declared capacity's key and a store URL are compared under, so a trailing
slash or a difference of case cannot miss a match.
-}
overrideKey :: Text -> Text
overrideKey :: Text -> Text
overrideKey = (Char -> Bool) -> Text -> Text
T.dropWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/') (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.toLower (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip

-- What the operator declared about this exact store, where they declared anything.
matchingOverride :: Map Text QuotaOverride -> RegistryUrl -> Maybe QuotaOverride
matchingOverride :: Map Text QuotaOverride -> RegistryUrl -> Maybe QuotaOverride
matchingOverride Map Text QuotaOverride
overrides RegistryUrl
url = Text -> Map Text QuotaOverride -> Maybe QuotaOverride
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Text -> Text
overrideKey (RegistryUrl -> Text
registryUrlText RegistryUrl
url)) Map Text QuotaOverride
keyed
  where
    keyed :: Map Text QuotaOverride
keyed = [(Text, QuotaOverride)] -> Map Text QuotaOverride
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Text -> Text
overrideKey Text
key, QuotaOverride
override) | (Text
key, QuotaOverride
override) <- Map Text QuotaOverride -> [(Text, QuotaOverride)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Text QuotaOverride
overrides]

{- | The store's capacity as this boot resolves it: the backend's own description, the operator's
declaration where there is one, else the pace a backend publishing no quota is derived to run at.
-}
resolvedBudget :: BudgetPorts -> RegistryUrl -> StoreBudget -> StoreBudget
resolvedBudget :: BudgetPorts -> RegistryUrl -> StoreBudget -> StoreBudget
resolvedBudget BudgetPorts
ports RegistryUrl
url StoreBudget
budget =
    -- The derivation runs last and only bites where nothing else declared a quota, so an entry
    -- naming a scope or a weight alone still leaves the store a capacity.
    Rational -> StoreBudget -> StoreBudget
derivedCapacity (BudgetPorts -> Rational
bpNominalPace BudgetPorts
ports) (StoreBudget
-> (QuotaOverride -> StoreBudget)
-> Maybe QuotaOverride
-> StoreBudget
forall b a. b -> (a -> b) -> Maybe a -> b
maybe StoreBudget
located (StoreBudget -> QuotaOverride -> StoreBudget
declared StoreBudget
located) (Map Text QuotaOverride -> RegistryUrl -> Maybe QuotaOverride
matchingOverride (BudgetPorts -> Map Text QuotaOverride
bpOverrides BudgetPorts
ports) RegistryUrl
url))
  where
    -- A backend that names its own pool keeps it. One that names none is pooled by its authority.
    located :: StoreBudget
located
        | StoreBudget -> QuotaScope
bgScope StoreBudget
budget QuotaScope -> QuotaScope -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> QuotaScope
mkQuotaScope Text
"" = StoreBudget
budget{bgScope = storeScope url}
        | Bool
otherwise = StoreBudget
budget

-- A declared capacity wins per dimension, and a declared weight scales that kind's own costs.
declared :: StoreBudget -> QuotaOverride -> StoreBudget
declared :: StoreBudget -> QuotaOverride -> StoreBudget
declared StoreBudget
budget QuotaOverride
override =
    StoreBudget
budget
        { bgScope = maybe (bgScope budget) mkQuotaScope (qoScope override)
        , bgQuotas = Map.union (qoQuotas override) (bgQuotas budget)
        , bgOrigin = if Map.null (qoQuotas override) then bgOrigin budget else QuotaDeclared
        , bgCosts = Map.mapWithKey weighted (bgCosts budget)
        }
  where
    weighted :: RequestKind -> Map k Rational -> Map k Rational
weighted RequestKind
kind Map k Rational
costs = Map k Rational
-> (Rational -> Map k Rational) -> Maybe Rational -> Map k Rational
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Map k Rational
costs (\Rational
weight -> (Rational -> Rational) -> Map k Rational -> Map k Rational
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
weight) Map k Rational
costs) (RequestKind -> Map RequestKind Rational -> Maybe Rational
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup RequestKind
kind (QuotaOverride -> Map RequestKind Rational
qoWeights QuotaOverride
override))

-- One manager of the store's own, and the manifest read that leads over it.
storeAccess :: StorePorts -> Limits -> ClearedBackend -> IO (StoreManifestRead, Manager)
storeAccess :: StorePorts
-> Limits -> ClearedBackend -> IO (StoreManifestRead, Manager)
storeAccess StorePorts
ports Limits
limits ClearedBackend
cleared = do
    manager <- IO Manager
storeManager
    pure (storeManifestRead ports limits cleared manager, manager)

{- One package's metadata as the store serves it, through the ecosystem's own codec. The token is
minted per read, because a store that mints its own hands out a short-lived one. -}
storeManifestRead :: StorePorts -> Limits -> ClearedBackend -> Manager -> StoreManifestRead
storeManifestRead :: StorePorts
-> Limits -> ClearedBackend -> Manager -> StoreManifestRead
storeManifestRead StorePorts
ports Limits
limits ClearedBackend
cleared Manager
manager PackageName
name = do
    token <- (CredentialProvider -> IO Secret)
-> Maybe CredentialProvider -> IO (Maybe Secret)
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) -> Maybe a -> f (Maybe b)
traverse CredentialProvider -> IO Secret
mintSecret (StorePorts -> Maybe CredentialProvider
spCredential StorePorts
ports)
    -- A minted store token carries no username: the store's own control plane, not a caller's.
    first storeFaultOfMetadata
        <$> cbFetchManifest cleared (spTracing ports) (storeOrigin limits cleared manager (bareCredential <$> token)) name

storeOrigin :: Limits -> ClearedBackend -> Manager -> Maybe ClientCredential -> OriginClient
storeOrigin :: Limits
-> ClearedBackend
-> Manager
-> Maybe ClientCredential
-> OriginClient
storeOrigin Limits
limits ClearedBackend
cleared Manager
manager = Limits
-> Manager -> RegistryUrl -> Maybe ClientCredential -> OriginClient
originClient Limits
limits Manager
manager (ClearedBackend -> RegistryUrl
cbUrl ClearedBackend
cleared)

{- No proxy tracing: these calls are not the data plane. Dropping http-client's hidden replay on
a reused connection keeps every attempt one the request budget counted. -}
storeManager :: IO Manager
storeManager :: IO Manager
storeManager = Int -> ManagerSettings -> IO Manager
newPooledManager Int
storeConnections (ManagerSettings -> ManagerSettings
singleAttemptSettings ManagerSettings
tlsManagerSettings)

-- One store, swept package by package, so the pool holds what one in-flight request needs.
storeConnections :: Int
storeConnections :: Int
storeConnections = Int
4

protocolStore :: Limits -> ClearedBackend -> ClearedProtocolStore -> StoreManifestRead -> Manager -> Manager -> ProtocolStore
protocolStore :: Limits
-> ClearedBackend
-> ClearedProtocolStore
-> StoreManifestRead
-> Manager
-> Manager
-> ProtocolStore
protocolStore Limits
limits ClearedBackend
cleared ClearedProtocolStore
store StoreManifestRead
readManifest Manager
manager Manager
deletionManager =
    ProtocolStore
        { psRead :: ProtocolRead
psRead = Limits
-> ClearedBackend
-> ClearedProtocolStore
-> StoreManifestRead
-> Manager
-> ProtocolRead
protocolRead Limits
limits ClearedBackend
cleared ClearedProtocolStore
store StoreManifestRead
readManifest Manager
manager
        , psDeleteOrigin :: OriginClient
psDeleteOrigin = Limits
-> ClearedBackend
-> Manager
-> Maybe ClientCredential
-> OriginClient
storeOrigin Limits
limits ClearedBackend
cleared Manager
deletionManager (Secret -> ClientCredential
bareCredential (Secret -> ClientCredential)
-> Maybe Secret -> Maybe ClientCredential
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ClearedProtocolStore -> Maybe Secret
cpsToken ClearedProtocolStore
store)
        , psDelete :: VersionDelete
psDelete = ClearedProtocolStore -> VersionDelete
cpsDelete ClearedProtocolStore
store
        }

protocolRead :: Limits -> ClearedBackend -> ClearedProtocolStore -> StoreManifestRead -> Manager -> ProtocolRead
protocolRead :: Limits
-> ClearedBackend
-> ClearedProtocolStore
-> StoreManifestRead
-> Manager
-> ProtocolRead
protocolRead Limits
limits ClearedBackend
cleared ClearedProtocolStore
store StoreManifestRead
readManifest Manager
manager =
    ProtocolRead
        { prOrigin :: OriginClient
prOrigin = Limits
-> ClearedBackend
-> Manager
-> Maybe ClientCredential
-> OriginClient
storeOrigin Limits
limits ClearedBackend
cleared Manager
manager (Secret -> ClientCredential
bareCredential (Secret -> ClientCredential)
-> Maybe Secret -> Maybe ClientCredential
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ClearedProtocolStore -> Maybe Secret
cpsToken ClearedProtocolStore
store)
        , prReadManifest :: StoreManifestRead
prReadManifest = StoreManifestRead
readManifest
        , prListing :: StoreListing
prListing = ClearedProtocolStore -> StoreListing
cpsListing ClearedProtocolStore
store
        , prCodec :: PublishCodec
prCodec = ClearedProtocolStore -> PublishCodec
cpsCodec ClearedProtocolStore
store
        , prBackendName :: Text
prBackendName = StoreTag -> Text
storeTagName (ClearedProtocolStore -> StoreTag
cpsTag ClearedProtocolStore
store)
        , prPermitDeletion :: Bool
prPermitDeletion = ClearedProtocolStore -> DeletionConsent
cpsConsent ClearedProtocolStore
store DeletionConsent -> DeletionConsent -> Bool
forall a. Eq a => a -> a -> Bool
== DeletionConsent
DeletionPermitted
        , prConsentDescriptor :: Text
prConsentDescriptor = ClearedProtocolStore -> Text
cpsConsentKey ClearedProtocolStore
store
        }

{- The key an operator sets, which the store's own withheld verdict names. The deleting role's
pass refuses a store without it, and its preview reports the verdict instead. -}
consentDescriptor :: Ecosystem -> StoreTag -> Text
consentDescriptor :: Ecosystem -> StoreTag -> Text
consentDescriptor Ecosystem
eco StoreTag
tag =
    Text
"set "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Ecosystem -> Text -> Text
mountKeyRef Ecosystem
eco (Text
"mirrorTarget." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> StoreTag -> Text
storeTagName StoreTag
tag Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".permitDeletion")
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to true: the Dredger deletes nothing from a store that does not carry it"

{- | Build the booting role's own capabilities for each cleared store, or every refusal the live
environment earns. The builds accumulate, so one launch reports every store that cannot be built.
-}
planStoreMaintenance ::
    (StorePorts -> Limits -> ClearedBackend -> IO store) ->
    TracingPort ->
    BudgetPorts ->
    CredentialProviders ->
    Limits ->
    Map Ecosystem ClearedBackend ->
    IO (Either [BootError] (Map Ecosystem store))
planStoreMaintenance :: forall store.
(StorePorts -> Limits -> ClearedBackend -> IO store)
-> TracingPort
-> BudgetPorts
-> CredentialProviders
-> Limits
-> Map Ecosystem ClearedBackend
-> IO (Either [BootError] (Map Ecosystem store))
planStoreMaintenance = CredentialTarget
-> (StorePorts -> Limits -> ClearedBackend -> IO store)
-> TracingPort
-> BudgetPorts
-> CredentialProviders
-> Limits
-> Map Ecosystem ClearedBackend
-> IO (Either [BootError] (Map Ecosystem store))
forall store.
CredentialTarget
-> (StorePorts -> Limits -> ClearedBackend -> IO store)
-> TracingPort
-> BudgetPorts
-> CredentialProviders
-> Limits
-> Map Ecosystem ClearedBackend
-> IO (Either [BootError] (Map Ecosystem store))
planStoreMaintenanceFor CredentialTarget
MirrorCredential

-- | Plan a target slot with its own credentials and accumulate all backend construction refusals.
planStoreMaintenanceFor ::
    CredentialTarget ->
    (StorePorts -> Limits -> ClearedBackend -> IO store) ->
    TracingPort ->
    BudgetPorts ->
    CredentialProviders ->
    Limits ->
    Map Ecosystem ClearedBackend ->
    IO (Either [BootError] (Map Ecosystem store))
planStoreMaintenanceFor :: forall store.
CredentialTarget
-> (StorePorts -> Limits -> ClearedBackend -> IO store)
-> TracingPort
-> BudgetPorts
-> CredentialProviders
-> Limits
-> Map Ecosystem ClearedBackend
-> IO (Either [BootError] (Map Ecosystem store))
planStoreMaintenanceFor CredentialTarget
target StorePorts -> Limits -> ClearedBackend -> IO store
build TracingPort
tracing BudgetPorts
budget CredentialProviders
credentials Limits
limits Map Ecosystem ClearedBackend
backends =
    Validation [BootError] (Map Ecosystem store)
-> Either [BootError] (Map Ecosystem store)
forall e a. Validation e a -> Either e a
validationToEither (Validation [BootError] (Map Ecosystem store)
 -> Either [BootError] (Map Ecosystem store))
-> (Map Ecosystem (Either [BootError] store)
    -> Validation [BootError] (Map Ecosystem store))
-> Map Ecosystem (Either [BootError] store)
-> Either [BootError] (Map Ecosystem store)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either [BootError] store -> Validation [BootError] store)
-> Map Ecosystem (Either [BootError] store)
-> Validation [BootError] (Map Ecosystem store)
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) -> Map Ecosystem a -> f (Map Ecosystem b)
traverse Either [BootError] store -> Validation [BootError] store
forall e a. Either e a -> Validation e a
eitherToValidation (Map Ecosystem (Either [BootError] store)
 -> Either [BootError] (Map Ecosystem store))
-> IO (Map Ecosystem (Either [BootError] store))
-> IO (Either [BootError] (Map Ecosystem store))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Ecosystem -> ClearedBackend -> IO (Either [BootError] store))
-> Map Ecosystem ClearedBackend
-> IO (Map Ecosystem (Either [BootError] store))
forall (t :: * -> *) k a b.
Applicative t =>
(k -> a -> t b) -> Map k a -> t (Map k b)
Map.traverseWithKey Ecosystem -> ClearedBackend -> IO (Either [BootError] store)
planOne Map Ecosystem ClearedBackend
backends
  where
    planOne :: Ecosystem -> ClearedBackend -> IO (Either [BootError] store)
planOne Ecosystem
eco ClearedBackend
backend =
        (Text -> BootError) -> IO store -> IO (Either [BootError] store)
forall a. (Text -> BootError) -> IO a -> IO (Either [BootError] a)
refuseOnThrow (Ecosystem -> StoreMaintenanceReason -> BootError
StoreMaintenanceUnavailable Ecosystem
eco (StoreMaintenanceReason -> BootError)
-> (Text -> StoreMaintenanceReason) -> Text -> BootError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> StoreMaintenanceReason
reason) (StorePorts -> Limits -> ClearedBackend -> IO store
build (Ecosystem -> StorePorts
portsFor Ecosystem
eco) Limits
limits ClearedBackend
backend)
    reason :: Text -> StoreMaintenanceReason
reason = case CredentialTarget
target of
        CredentialTarget
MirrorCredential -> Text -> StoreMaintenanceReason
ClientBuildFailed
        CredentialTarget
PrivateCacheCredential -> Text -> StoreMaintenanceReason
PrivateCacheUnavailable (Text -> StoreMaintenanceReason)
-> (Text -> Text) -> Text -> StoreMaintenanceReason
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"client build failed: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>)
    portsFor :: Ecosystem -> StorePorts
portsFor Ecosystem
eco =
        StorePorts
            { spTracing :: TracingPort
spTracing = TracingPort
tracing
            , spCredential :: Maybe CredentialProvider
spCredential = CredentialTarget
-> Ecosystem -> CredentialProviders -> Maybe CredentialProvider
lookupTargetProvider CredentialTarget
target Ecosystem
eco CredentialProviders
credentials
            , spBudget :: BudgetPorts
spBudget = BudgetPorts
budget
            }