{- | Écluse: a supply-chain policy proxy for package registries.

Écluse (package @ecluse@) sits between consumers (developers, CI) and a package
registry, applying a configurable resilience policy before any dependency reaches
a build, without hosting packages itself. The name is French for a canal lock: a
chamber whose gates never open at once. Every dependency is held and cleared
through that controlled passage before it is admitted to a build.

The goal is __resilience, not malware detection__: shrink the blast radius of a
bad publish (a hijacked maintainer account, a race-to-publish, a typosquat)
rather than promise to recognise malice. Écluse is __not a registry__: storage is
delegated to whatever backend the operator runs (AWS CodeArtifact, GCP Artifact
Registry), and Écluse only governs what may be fetched from, and mirrored to,
those backends. npm is the first ecosystem; the domain model is ecosystem-agnostic
so PyPI and RubyGems can follow.

== How a request is cleared

Écluse speaks a registry's native protocol across three read-path registries (the
client's, a /private upstream/ of already-vetted packages, and the /public/
registry), and the two request shapes use them differently:

* A __tarball__ request is gated for that one version: a private-upstream hit is
  streamed unfiltered (already vetted); on a miss, the proxy fetches the
  version's public metadata, evaluates the rules, and either streams it from
  public __and enqueues an asynchronous mirror job__ or returns a denial.
* A __packument__ (metadata) request is a /merge/: the private and public
  upstreams are fetched in parallel, public versions are filtered by the rules
  while private versions are trusted, and the two are combined into one document
  (private wins a version collision, an integrity divergence is flagged as a
  supply-chain signal, and @latest@ is repointed to the newest survivor).

Two properties run through both shapes: the rules engine is __deny by default__ (a
version is admitted only if some rule allows it and none denies it), and
__mirroring is demand-driven__, so only versions actually pulled are mirrored,
never on the request's critical path.

== How the code is organised

Écluse is a __functional core with effects at the edges__: the policy and
protocol logic is pure and trivially testable, and @IO@ is confined to a thin
shell. Swappable backends sit behind /handles/ (records of functions chosen at a
single composition root), so a new cloud or a new ecosystem is an added
implementation behind an existing handle, not a structural change.

The library's vocabulary, roughly from the pure core outward:

* __Domain model__: "Ecluse.Core.Package" (the ecosystem-agnostic package vocabulary
  the rules reason over), "Ecluse.Core.Version" (version identity and per-ecosystem
  ordering), and "Ecluse.Core.Ecosystem" (the ecosystem tag the rest dispatches on).
* __Policy__: "Ecluse.Core.Rules" (deny-by-default evaluation) over the rule types
  in "Ecluse.Core.Rules.Types".
* __Protocol boundary__: "Ecluse.Core.Registry" (the registry-protocol handle),
  "Ecluse.Core.Registry.Npm.Wire" and "Ecluse.Core.Registry.Npm.Project" (the lenient npm
  wire decoders and their projection onto the domain model),
  "Ecluse.Core.Registry.Npm.Route" (the npm path grammar), and "Ecluse.Core.Server.Route"
  (the shared serve-action 'Route' set and the injected route classifier).
* __Cloud handles__: "Ecluse.Core.Credential" (minting the mirror-target write token)
  and "Ecluse.Core.Queue" (the durable mirror-job hand-off to the worker).
* __Mirror worker__: "Ecluse.Core.Worker" (the supervised consume loop that fetches,
  verifies against the job's integrity digest, and publishes an approved artifact).

'run' is the entry point the @ecluse@ executable invokes (see "Main"). It lives
in the library, not in @app\/Main.hs@, so the composition root is a single
importable unit and @app\/Main.hs@ stays a thin shell that only calls it.

== Further reading

@docs\/architecture.md@ is the systems-design index: the vision, the end-to-end
request lifecycle, and a map to the per-concern design documents. @CONTRIBUTING.md@
covers the codebase layout and testing strategy, and @STYLE.md@ the coding and
documentation conventions.
-}
module Ecluse.Proxy (
    runProxy,
    runServer,
    runWorker,
    npmServerConfig,
    mountBindingFor,
    unconfiguredRegistry,
    planCveSync,
    CveSyncHandle (..),
    cveRuleDepsFor,
    cveSyncReady,
    cveSyncScheduleFor,
) where

import Amazonka qualified as AWS
import Data.Map.Strict qualified as Map
import Data.Text qualified as T
import Data.Time (getCurrentTime)
import GHC.Conc (getNumCapabilities)
import Katip (SimpleLogPayload, katipAddNamespace, runKatipContextT)
import Network.HTTP.Client (Manager, newManager)
import Network.HTTP.Client.TLS (tlsManagerSettings)
import System.Directory (createDirectoryIfMissing, listDirectory, removeFile)
import System.FilePath (isExtensionOf, (</>))
import UnliftIO (concurrently_, race_, throwIO)
import UnliftIO.Async (mapConcurrently_)
import UnliftIO.Exception (catchAny)

import Ecluse.Boot
import Ecluse.Composition (
    PublishTarget (ptCredentials, ptEcosystem, ptMirrorUrl),
    connectionPoolSettings,
    initCredentialProviders,
    planMirrorQueue,
    planMounts,
    planPublishTargets,
    renderBootError,
 )
import Ecluse.Composition qualified as Composition
import Ecluse.Config (
    AppConfig (cfgCveDbPollInterval, cfgMaxOsvDbBytes, cfgMounts, cfgOsvDataDir, cfgPort, cfgPrivateConnectionsPerHost, cfgPublicConnectionsPerHost, cfgServeMaxInFlight, cfgShutdownDrainTimeout, cfgVulnerabilityDatabaseBucket),
 )
import Ecluse.Core.Breaker (BreakerReporter)
import Ecluse.Core.Credential (AuthToken (..), currentToken)
import Ecluse.Core.Credential.Refresh (CredentialReporters (CredentialReporters, crBreakerReporter, crRefreshReporter))
import Ecluse.Core.Cve.Slot (CveSlot, newCveSlot, withSlotLookup)
import Ecluse.Core.Cve.Sync (SyncEnv (..), SyncSchedule (SyncSchedule, schedBootBackoff, schedPollDelay), bootBackoffDelays, runCveSync, s3CveFetch)
import Ecluse.Core.Ecosystem (Ecosystem (Npm), ecosystemName, parseEcosystem, prefixFor)
import Ecluse.Core.Osv.Schema (osvDbFileName)
import Ecluse.Core.Queue (MirrorQueue, newEnqueueBuffer)
import Ecluse.Core.Registry (
    ParseError (..),
    RegistryClient (..),
 )
import Ecluse.Core.Registry.Metadata (fetchVersionDetails)
import Ecluse.Core.Registry.Npm (NpmClientConfig (NpmClientConfig, npmBaseUrl, npmLimits, npmManager, npmToken), newNpmPublishClient)
import Ecluse.Core.Registry.Npm.Route qualified as Npm
import Ecluse.Core.Registry.Npm.Serve (npmRenderer)
import Ecluse.Core.Rules (RuleDeps (..))
import Ecluse.Core.Security (defaultLimits)
import Ecluse.Core.Server.Admission (newServeAdmission)
import Ecluse.Core.Server.Cache (Source (Source), newMetadataCache)
import Ecluse.Core.Server.Context (PackumentDeps, PublishDeps, pdLimits, pdNow, pdPublicBaseUrl, pdRules)
import Ecluse.Core.Server.Metadata (ManifestCaching (Cached), newNpmMetadataClient)
import Ecluse.Core.Telemetry.Metrics (BreakerSource (CredentialMint, EffectfulRule), Provider (CodeArtifact), Upstream (Public))
import Ecluse.Core.Worker (WorkerPolicies, WorkerPolicy (..), runWorkerM, workerLoop)
import Ecluse.Env (Env, envDdContext, envLogEnv, envManager, envMetadataCache, envMetrics, envTelemetry, newWorkerHeartbeat, withEnvWithAdmission, workerRuntimeOf)
import Ecluse.Pilot.Export (buildS3Env)
import Ecluse.Server (MountBinding (..), ServerConfig (scCheckReady, scDrainTimeout, scPort), ShutdownDrainTimeout (ShutdownDrainTimeout), mkServerConfig)
import Ecluse.Server qualified as Server
import Ecluse.Telemetry.Correlation (ddPayloadNow)
import Ecluse.Telemetry.Instruments (metricsPortOf)
import Ecluse.Telemetry.Reporters (
    deferredBreakerReporter,
    deferredMirrorEnqueueFailure,
    deferredRefreshReporter,
    installMetrics,
    newDeferredMetrics,
 )
import Ecluse.Telemetry.Tracing (instrumentDataPlaneManagerSettings, tracingPortOf)

{- | Start Écluse: the entry point the @ecluse@ executable runs (see "Main").

Assemble the composition root from configuration. Parse the environment layer and
the optional config document, __validate everything and fail fast at boot__ on any
problem (a malformed env, an unresolved rule policy, a configured mount with no
adapter, a credential reference that does not resolve, or a mirror-queue backend
not built in this binary), aggregating the failures so a single run reports them
all. On success, build the handles (the shared HTTP @Manager@, the config-selected
mirror queue, the metadata cache, the logger, the process-global credential
provider, and the telemetry substrate, off unless @ECLUSE_TELEMETRY@ enables it)
into an 'Env', derive the served mount bindings, then run the server and the mirror
worker __concurrently__ over that single 'Env' ('runServer' and 'runWorker').
Bracketing the 'Env' (and the telemetry providers) for the lifetime of both tears
down their shared resources along every exit path.
-}
runProxy :: BootEnv -> IO ()
runProxy :: BootEnv -> IO ()
runProxy BootEnv
bootEnv = do
    let env :: AppConfig
env = BootEnv -> AppConfig
beConfig BootEnv
bootEnv
    let config :: Config
config = BootEnv -> Config
beConfigFull BootEnv
bootEnv
    let logEnv :: LogEnv
logEnv = BootEnv -> LogEnv
beLogEnv BootEnv
bootEnv
    let telemetry :: Telemetry
telemetry = BootEnv -> Telemetry
beTelemetry BootEnv
bootEnv

    -- The metric instruments do not exist until the telemetry substrate is built, well
    -- below; this deferred handle lets the credential provider (constructed here, at
    -- boot) record through reporters that stay inert until 'installMetrics' makes them
    -- live (in the 'withEnv' body). With telemetry off the eventual instruments are the
    -- no-op-meter ones, so the reporters are inert either way.
    deferredMetrics <- IO DeferredMetrics
newDeferredMetrics
    let credentialReporters =
            CredentialReporters
                { crBreakerReporter :: BreakerReporter
crBreakerReporter = DeferredMetrics -> BreakerSource -> BreakerReporter
deferredBreakerReporter DeferredMetrics
deferredMetrics BreakerSource
CredentialMint
                , crRefreshReporter :: RefreshReporter
crRefreshReporter = DeferredMetrics -> Provider -> RefreshReporter
deferredRefreshReporter DeferredMetrics
deferredMetrics Provider
CodeArtifact
                }
    -- Build the process-global mirror-target write provider(s) selected by config:
    -- the static token, or the CodeArtifact mint (whose inputs are validated and which
    -- mints once eagerly, so a misconfiguration fails loudly here at boot).
    providers <- initCredentialProviders credentialReporters env >>= orExit (T.unlines . map renderBootError)
    -- The advisory-database sync plan: with a bucket configured, every configured
    -- mount ecosystem gets its own slot (the shadow-swap read side), its own
    -- supervised sync task, and its own one-way first-sync readiness flag, each
    -- independent so one ecosystem's missing artifact never holds back
    -- another's. Without a bucket the map is empty: rules abstain and
    -- readiness is ungated.
    cveSyncPlan <- planCveSync env
    let ruleDepsFor = Map Ecosystem CveSyncHandle
-> BreakerReporter -> Ecosystem -> RuleDeps
cveRuleDepsFor Map Ecosystem CveSyncHandle
cveSyncPlan (DeferredMetrics -> BreakerSource -> BreakerReporter
deferredBreakerReporter DeferredMetrics
deferredMetrics BreakerSource
EffectfulRule)
    bindings <- planMounts mountBindingFor getCurrentTime ruleDepsFor providers config >>= orExit (T.unlines . map renderBootError)
    publishTargets <- orExit (T.unlines . map renderBootError) (planPublishTargets providers config)
    -- Select the mirror-queue backend from config (the GCP arm is a fail-loud
    -- "not built" boot error, never a silent fall-through); the resulting plan is
    -- handed to the one queue-construction site below.
    queuePlan <- orExit (T.unlines . map renderBootError) (planMirrorQueue env)
    -- The effective admission capacity: explicit config, else computed from the
    -- post-runtime-posture capability count, logged with its provenance beside the
    -- runtime lines. This bounds metadata materialisation only; the private manager's
    -- pool is sized independently below, since a trusted tarball hit streams outside
    -- admission (see 'Composition.resolvePrivateConnections' and issue #634).
    capabilities <- getNumCapabilities
    let (serveMaxInFlight, admissionLine) = Composition.resolveServeAdmission (cfgServeMaxInFlight env) capabilities
    logBootInfo logEnv admissionLine
    serveAdmission <- newServeAdmission serveMaxInFlight
    -- The private-upstream connection pool: an explicit override, else computed from the
    -- process file-descriptor limit (the pool's real ceiling, since each pooled
    -- connection is one descriptor). Sized for the un-admitted private-hit streaming
    -- fan-out, not the admission capacity.
    fdLimit <- Composition.openFileSoftLimit
    let (privateConnections, privateConnectionsLine) = Composition.resolvePrivateConnections (cfgPrivateConnectionsPerHost env) fdLimit
    logBootInfo logEnv privateConnectionsLine
    -- The public pool: an explicit override, else computed from the same
    -- file-descriptor datapoint at half the private share. The onboarding
    -- fail-over's artifact streams and the worker's back-fill fetches ride this
    -- manager without coalescing, so its retention must cover that transient
    -- fan-out, not only the admission-bounded metadata misses.
    let (publicConnections, publicConnectionsLine) = Composition.resolvePublicConnections (cfgPublicConnectionsPerHost env) fdLimit
    logBootInfo logEnv publicConnectionsLine
    let serverConfig =
            ([MountBinding] -> ServerConfig
mkServerConfig [MountBinding]
bindings)
                { scPort = cfgPort env
                , scDrainTimeout = ShutdownDrainTimeout (cfgShutdownDrainTimeout env)
                , scCheckReady = cveSyncReady cveSyncPlan
                }
    -- Log each mount's resolved rule boot order so an operator sees at start-up exactly
    -- how their policy will resolve (highest precedence first, then name).
    logRuleBootOrder logEnv bindings
    -- The config-selected mirror queue, built once here (the single constructor
    -- call) from the validated plan: the durable AWS SQS backend, or the bounded
    -- in-memory backend -- which first emits a loud boot warning (it is
    -- non-durable / best-effort) and logs each rate-limited cap-overflow drop.
    backendQueue <- buildMirrorQueue logEnv queuePlan
    -- Decouple the serve path from the backend's own enqueue latency: what Env
    -- captures is the buffered hand-off (an STM write), and the drain loop below --
    -- raced against the services -- delivers to the backend (an SQS round trip on
    -- that backend) off the request path, where it would otherwise hold the served
    -- connection's turn.
    (queue, drainEnqueueBuffer) <-
        bufferedMirrorHandOff (logBootWarning logEnv) (deferredMirrorEnqueueFailure deferredMetrics) backendQueue
    metadataCache <- newMetadataCache (Composition.cacheConfigFor env)
    heartbeat <- newWorkerHeartbeat

    -- Two data-plane managers, one per origin. Both are the standard validating TLS
    -- manager: registry egress is https-only by construction (a non-https endpoint
    -- fails closed at boot), and certificate validation authenticates the dialled
    -- host, so a rebound or internal address cannot present a CA-trusted certificate
    -- for the requested name (the SSRF / resolve-to-internal class is closed by
    -- certificate validation). The split is retained
    -- because the two origins differ in credential handling (the public reads are
    -- anonymous; the private reads forward the client's credential) and in the
    -- @dist.tarball@ host gate's trust. Both are built inside the telemetry bracket so
    -- that, with telemetry enabled, each carries the http-client instrumentation
    -- (child spans + W3C context propagation) hung off the substrate's installed
    -- providers; with it off the instrumentation step is the identity.
    publicSettings <- instrumentDataPlaneManagerSettings telemetry tlsManagerSettings
    privateSettings <- instrumentDataPlaneManagerSettings telemetry tlsManagerSettings
    manager <- newManager (connectionPoolSettings publicConnections publicSettings)
    privateManager <- newManager (connectionPoolSettings privateConnections privateSettings)
    -- The mirror worker's publish-side registry client, resolved per ecosystem from
    -- the configured mirror target and its write credential. It writes to the
    -- operator-configured, trusted mirror target, so it uses the trusted private
    -- manager (the private origin's credential-forwarding path).
    publishClient <- resolvePublishClient privateManager publishTargets
    withEnvWithAdmission serveAdmission publishClient queue manager privateManager metadataCache logEnv telemetry heartbeat $ \Env
builtEnv -> do
        -- The instruments now exist (built in 'withEnv' from the telemetry handle);
        -- install them so the credential provider's deferred reporters go live for
        -- the rest of the run. They are the no-op-meter instruments when telemetry
        -- is off, so this is inert in that posture.
        DeferredMetrics -> Metrics -> IO ()
installMetrics DeferredMetrics
deferredMetrics (Env -> Metrics
envMetrics Env
builtEnv)
        -- The enqueue-buffer drain loop and the advisory sync tasks never return,
        -- so they are raced against the services: when the services finish
        -- (shutdown), the race cancels them. A dropped buffered job is the queue's
        -- safe loss (re-enqueued on the next demand), and a cancelled sync simply
        -- resumes from the remote artifact on next boot, so neither holds up
        -- shutdown. Each sync task runs its boot burst immediately, so a healthy
        -- deployment is rules-engine complete within seconds of boot.
        let syncTasks :: [IO ()]
syncTasks = Env -> SyncSchedule -> Map Ecosystem CveSyncHandle -> [IO ()]
cveSyncTasks Env
builtEnv (AppConfig -> SyncSchedule
cveSyncScheduleFor AppConfig
env) Map Ecosystem CveSyncHandle
cveSyncPlan
        IO () -> IO () -> IO ()
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m ()
race_
            (ServerConfig -> WorkerPolicies -> Env -> IO ()
runServices ServerConfig
serverConfig (Env -> [MountBinding] -> WorkerPolicies
workerPoliciesFor Env
builtEnv [MountBinding]
bindings) Env
builtEnv)
            (IO () -> IO () -> IO ()
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m ()
concurrently_ IO ()
drainEnqueueBuffer ((IO () -> IO ()) -> [IO ()] -> IO ()
forall (m :: * -> *) (f :: * -> *) a b.
(MonadUnliftIO m, Foldable f) =>
(a -> m b) -> f a -> m ()
mapConcurrently_ IO () -> IO ()
forall a. a -> a
id [IO ()]
syncTasks))

{- The buffered hand-off in front of the mirror queue's backend. Drops and delivery
failures are logged rate-limited ('enqueueReportWorthy') and each counts an enqueue
failure; both are safe, since a lost job is re-enqueued on the next demand for its
artifact. -}
bufferedMirrorHandOff :: (Text -> IO ()) -> IO () -> MirrorQueue -> IO (MirrorQueue, IO ())
bufferedMirrorHandOff :: (Text -> IO ()) -> IO () -> MirrorQueue -> IO (MirrorQueue, IO ())
bufferedMirrorHandOff Text -> IO ()
warn IO ()
countEnqueueFailure =
    Int
-> (Int -> IO ())
-> (Int -> Text -> IO ())
-> MirrorQueue
-> IO (MirrorQueue, IO ())
newEnqueueBuffer
        Int
Composition.mirrorEnqueueBufferDepth
        ( \Int
drops -> do
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int -> Bool
enqueueReportWorthy Int
drops) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                Text -> IO ()
warn (Text
"mirror enqueue buffer full: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
drops Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" job(s) dropped so far; each is re-enqueued on the next demand for its artifact")
            IO ()
countEnqueueFailure
        )
        ( \Int
failures Text
detail -> do
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int -> Bool
enqueueReportWorthy Int
failures) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                Text -> IO ()
warn (Text
"mirror enqueue delivery failed (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
failures Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" so far): " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
detail)
            IO ()
countEnqueueFailure
        )

{- Report-worthy event counts for the enqueue-buffer warnings: the first, then every
'Composition.mirrorEnqueueReportInterval'-th, mirroring the bounded memory queue's
rate-limited drop reporting. The metric alongside counts every event; only the log
line is rate-limited. -}
enqueueReportWorthy :: Int -> Bool
enqueueReportWorthy :: Int -> Bool
enqueueReportWorthy Int
n = Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
|| Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
Composition.mirrorEnqueueReportInterval Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0

-- One advisory sync task per configured ecosystem: each runs under the boot log's
-- "cve-sync" namespace and flips its ecosystem's one-way readiness flag once its
-- first sync lands.
cveSyncTasks :: Env -> SyncSchedule -> Map.Map Ecosystem CveSyncHandle -> [IO ()]
cveSyncTasks :: Env -> SyncSchedule -> Map Ecosystem CveSyncHandle -> [IO ()]
cveSyncTasks Env
builtEnv SyncSchedule
schedule Map Ecosystem CveSyncHandle
plan =
    [ LogEnv
-> SimpleLogPayload -> Namespace -> KatipContextT IO () -> IO ()
forall c (m :: * -> *) a.
LogItem c =>
LogEnv -> c -> Namespace -> KatipContextT m a -> m a
runKatipContextT (Env -> LogEnv
envLogEnv Env
builtEnv) (SimpleLogPayload
forall a. Monoid a => a
mempty :: SimpleLogPayload) Namespace
"cve-sync" (KatipContextT IO () -> IO ()) -> KatipContextT IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        SyncEnv -> SyncSchedule -> IO () -> KatipContextT IO ()
forall (m :: * -> *).
(MonadUnliftIO m, KatipContext m) =>
SyncEnv -> SyncSchedule -> IO () -> m ()
runCveSync (CveSyncHandle -> SyncEnv
csEnv CveSyncHandle
handle) SyncSchedule
schedule (STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (CveSyncHandle -> TVar Bool
csReady CveSyncHandle
handle) Bool
True))
    | CveSyncHandle
handle <- Map Ecosystem CveSyncHandle -> [CveSyncHandle]
forall k a. Map k a -> [a]
Map.elems Map Ecosystem CveSyncHandle
plan
    ]

{- | The rules' boot-bound capabilities for one mount ecosystem: the CVE
lookup borrows through that ecosystem's own slot when the sync plan carries
one, and abstains otherwise, so a mount's rules can never read a neighbouring
ecosystem's advisory database.
-}
cveRuleDepsFor :: Map.Map Ecosystem CveSyncHandle -> BreakerReporter -> Ecosystem -> RuleDeps
cveRuleDepsFor :: Map Ecosystem CveSyncHandle
-> BreakerReporter -> Ecosystem -> RuleDeps
cveRuleDepsFor Map Ecosystem CveSyncHandle
plan BreakerReporter
reporter Ecosystem
eco =
    RuleDeps
        { rdWithCveLookup :: forall a. (Maybe CveLookup -> IO a) -> IO a
rdWithCveLookup = ((Maybe CveLookup -> IO a) -> IO a)
-> (CveSyncHandle -> (Maybe CveLookup -> IO a) -> IO a)
-> Maybe CveSyncHandle
-> (Maybe CveLookup -> IO a)
-> IO a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (\Maybe CveLookup -> IO a
use -> Maybe CveLookup -> IO a
use Maybe CveLookup
forall a. Maybe a
Nothing) (CveSlot -> (Maybe CveLookup -> IO a) -> IO a
forall a. CveSlot -> (Maybe CveLookup -> IO a) -> IO a
withSlotLookup (CveSlot -> (Maybe CveLookup -> IO a) -> IO a)
-> (CveSyncHandle -> CveSlot)
-> CveSyncHandle
-> (Maybe CveLookup -> IO a)
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CveSyncHandle -> CveSlot
csSlot) (Ecosystem -> Map Ecosystem CveSyncHandle -> Maybe CveSyncHandle
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Ecosystem
eco Map Ecosystem CveSyncHandle
plan)
        , rdBreakerReporter :: BreakerReporter
rdBreakerReporter = BreakerReporter
reporter
        }

{- | The readiness gate over the sync plan: ready once every configured
ecosystem's advisory database has first-synced. The flags flip one way, so
readiness never flaps on this; an empty plan (no bucket) is vacuously ready.
-}
cveSyncReady :: Map.Map Ecosystem CveSyncHandle -> IO Bool
cveSyncReady :: Map Ecosystem CveSyncHandle -> IO Bool
cveSyncReady Map Ecosystem CveSyncHandle
plan = (CveSyncHandle -> IO Bool) -> [CveSyncHandle] -> IO Bool
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Monad m) =>
(a -> m Bool) -> f a -> m Bool
allM (TVar Bool -> IO Bool
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (TVar Bool -> IO Bool)
-> (CveSyncHandle -> TVar Bool) -> CveSyncHandle -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CveSyncHandle -> TVar Bool
csReady) (Map Ecosystem CveSyncHandle -> [CveSyncHandle]
forall k a. Map k a -> [a]
Map.elems Map Ecosystem CveSyncHandle
plan)

{- | The sync tasks' timing: the shipped boot burst over the configured poll
interval. The microsecond conversion cannot wrap: the config decoder bounds
the interval to @[1, maxBound div 1_000_000]@ seconds.
-}
cveSyncScheduleFor :: AppConfig -> SyncSchedule
cveSyncScheduleFor :: AppConfig -> SyncSchedule
cveSyncScheduleFor AppConfig
env =
    SyncSchedule
        { schedBootBackoff :: [Int]
schedBootBackoff = [Int]
bootBackoffDelays
        , schedPollDelay :: Int
schedPollDelay = NominalDiffTime -> Int
forall b. Integral b => NominalDiffTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (AppConfig -> NominalDiffTime
cfgCveDbPollInterval AppConfig
env) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1_000_000
        }

-- | One configured ecosystem's advisory-sync wiring.
data CveSyncHandle = CveSyncHandle
    { CveSyncHandle -> CveSlot
csSlot :: CveSlot
    -- ^ The slot this ecosystem's mount rules borrow through.
    , CveSyncHandle -> TVar Bool
csReady :: TVar Bool
    -- ^ The one-way first-sync readiness flag.
    , CveSyncHandle -> SyncEnv
csEnv :: SyncEnv
    -- ^ The sync task's environment.
    }

{- | Build the advisory-sync plan from config: nothing without a configured
vulnerability-database bucket; otherwise one 'CveSyncHandle' per configured
mount ecosystem, each against its own stable per-ecosystem object key and
canonical on-disk path under the OSV data dir. Prepares the data dir (created
if missing; stray @.tmp@ downloads from an interrupted run swept) so the sync
tasks start clean. Note the readiness consequence: an operator who mounts an
ecosystem Pilot does not compile has declared an artifact that never arrives,
and the pod honestly never reports ready.
-}
planCveSync :: AppConfig -> IO (Map.Map Ecosystem CveSyncHandle)
planCveSync :: AppConfig -> IO (Map Ecosystem CveSyncHandle)
planCveSync AppConfig
appCfg = case AppConfig -> Maybe Text
cfgVulnerabilityDatabaseBucket AppConfig
appCfg of
    Maybe Text
Nothing -> Map Ecosystem CveSyncHandle -> IO (Map Ecosystem CveSyncHandle)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map Ecosystem CveSyncHandle
forall k a. Map k a
Map.empty
    Just Text
bucket -> do
        let dataDir :: String
dataDir = AppConfig -> String
cfgOsvDataDir AppConfig
appCfg
        Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
dataDir
        String -> IO ()
sweepStaleTemps String
dataDir
        awsEnv <- AppConfig -> IO Env
buildS3Env AppConfig
appCfg
        Map.fromList <$> traverse (cveSyncHandleFor appCfg awsEnv bucket) (Map.keys (cfgMounts appCfg))

-- One ecosystem's sync wiring: a fresh slot and readiness flag, and the sync
-- environment against the ecosystem's stable object key and canonical on-disk
-- path under the OSV data dir.
cveSyncHandleFor :: AppConfig -> AWS.Env -> Text -> Ecosystem -> IO (Ecosystem, CveSyncHandle)
cveSyncHandleFor :: AppConfig
-> Env -> Text -> Ecosystem -> IO (Ecosystem, CveSyncHandle)
cveSyncHandleFor AppConfig
appCfg Env
awsEnv Text
bucket Ecosystem
eco = do
    slot <- IO CveSlot
newCveSlot
    ready <- newTVarIO False
    let key = Text -> String
osvDbFileName (Ecosystem -> Text
ecosystemName Ecosystem
eco)
        syncEnv =
            SyncEnv
                { syncFetch :: CveFetch
syncFetch = Env -> Text -> Text -> Int -> CveFetch
s3CveFetch Env
awsEnv Text
bucket (String -> Text
forall a. ToText a => a -> Text
toText String
key) (AppConfig -> Int
cfgMaxOsvDbBytes AppConfig
appCfg)
                , syncEcosystem :: Ecosystem
syncEcosystem = Ecosystem
eco
                , syncDbPath :: String
syncDbPath = AppConfig -> String
cfgOsvDataDir AppConfig
appCfg String -> String -> String
</> String
key
                , syncSlot :: CveSlot
syncSlot = CveSlot
slot
                }
    pure (eco, CveSyncHandle{csSlot = slot, csReady = ready, csEnv = syncEnv})

-- Sweep stray in-progress downloads an interrupted run left beside the
-- canonical artifacts (relevant to in-pod container restarts, where an
-- emptyDir survives). Best-effort: an unreadable dir is a fresh start.
sweepStaleTemps :: FilePath -> IO ()
sweepStaleTemps :: String -> IO ()
sweepStaleTemps String
dataDir =
    ( do
        entries <- String -> IO [String]
listDirectory String
dataDir
        forM_ [e | e <- entries, "tmp" `isExtensionOf` e] (\String
e -> String -> IO ()
removeFile (String
dataDir String -> String -> String
</> String
e) IO () -> (SomeException -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny` IO () -> SomeException -> IO ()
forall a b. a -> b -> a
const IO ()
forall (f :: * -> *). Applicative f => f ()
pass)
    )
        IO () -> (SomeException -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny` IO () -> SomeException -> IO ()
forall a b. a -> b -> a
const IO ()
forall (f :: * -> *). Applicative f => f ()
pass

{- Run the server and the mirror worker concurrently over one composition-root
'Env', the shape the single-process program uses. The two are independent (each
depends only on the handles in 'Env', not on each other), so splitting into
separate binaries later is two thin entry points calling 'runServer' \/
'runWorker' -- no rearchitecting. The server's settings (its derived mount bindings
and port) are supplied by the composition root and threaded to 'runServer'.
-}
runServices :: ServerConfig -> WorkerPolicies -> Env -> IO ()
runServices :: ServerConfig -> WorkerPolicies -> Env -> IO ()
runServices ServerConfig
serverConfig WorkerPolicies
policies Env
env = IO () -> IO () -> IO ()
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m ()
concurrently_ (ServerConfig -> Env -> IO ()
runServer ServerConfig
serverConfig Env
env) (WorkerPolicies -> Env -> IO ()
runWorker WorkerPolicies
policies Env
env)

{- | Run the proxy's HTTP front door over the composition-root 'Env' with the
config-derived 'ServerConfig'.

This is the npm-aware composition site: 'mountBindingFor' mounts npm -- its path
grammar ("Ecluse.Core.Registry.Npm.Route") and its denial renderer
("Ecluse.Core.Registry.Npm.Serve") -- into the otherwise ecosystem-neutral web layer
('Ecluse.Server.runServer'), so the agnostic server stays closed over the shared
'Ecluse.Core.Server.Route.Route' set and only this one place names an ecosystem.
Splitting the server into its own binary later reuses this same entry.
-}
runServer :: ServerConfig -> Env -> IO ()
runServer :: ServerConfig -> Env -> IO ()
runServer ServerConfig
cfg Env
env = ServerConfig -> IO Application -> IO ()
Server.runWarp ServerConfig
cfg (ServerConfig -> Env -> IO Application
Server.tracedApplication ServerConfig
cfg Env
env)

{- | The fallback server settings: a single npm mount with __no__ packument-serve
or publish dependencies, so the packument route is the recognised-but-unserved @501@
stub and a publish is @405@ (no publication target). Exposed so the composed front
door can be driven directly without binding a socket (e.g. embedded in another @wai@
application, or exercised in tests through 'Ecluse.Server.application') to assert the
routing and the unwired-mount surface; a real launch derives its bindings from
configuration in 'run'.
-}
npmServerConfig :: ServerConfig
npmServerConfig :: ServerConfig
npmServerConfig = [MountBinding] -> ServerConfig
mkServerConfig [Maybe PackumentDeps -> Maybe PublishDeps -> MountBinding
npmMount Maybe PackumentDeps
forall a. Maybe a
Nothing Maybe PublishDeps
forall a. Maybe a
Nothing]

{- | Resolve an 'Ecosystem' to its complete 'MountBinding', or 'Nothing' when that
ecosystem has no adapter wired. The ecosystem selects its path grammar (the
'Ecluse.Core.Server.Route.Classifier') and its denial renderer (the
'Ecluse.Core.Server.Response.MountRenderer'), and its path prefix is __derived__
from it ('prefixFor') rather than configured, so the ecosystem is the single thing
that drives the binding (see @docs\/architecture\/hosting.md@ → "Mounts"). The
composition root supplies the packument-serve dependencies once the per-mount
registry set is resolved; 'Nothing' for them leaves the packument route the
recognised-but-unserved @501@ stub.

npm is the only ecosystem with an adapter; the others have no registry client or
renderer, so they resolve to 'Nothing', a loud miss at the call site rather than a
silently half-wired mount.
-}
mountBindingFor :: Ecosystem -> Maybe PackumentDeps -> Maybe PublishDeps -> Maybe MountBinding
mountBindingFor :: Ecosystem
-> Maybe PackumentDeps -> Maybe PublishDeps -> Maybe MountBinding
mountBindingFor Ecosystem
eco Maybe PackumentDeps
packumentDeps Maybe PublishDeps
publishDeps = case Ecosystem
eco of
    Ecosystem
Npm -> MountBinding -> Maybe MountBinding
forall a. a -> Maybe a
Just (Maybe PackumentDeps -> Maybe PublishDeps -> MountBinding
npmMount Maybe PackumentDeps
packumentDeps Maybe PublishDeps
publishDeps)
    Ecosystem
_ -> Maybe MountBinding
forall a. Maybe a
Nothing

{- The npm mount: npm's complete wiring under its derived @\/npm@ prefix -- its path
grammar and its denial renderer -- taking the packument-serve and first-party publish
dependencies the composition root supplies ('Nothing' packument deps leave the
packument route the recognised-but-unserved @501@ stub; 'Nothing' publish deps leave a
@PUT \/{pkg}@ the @405@ opt-out -- no publication target).
-}
npmMount :: Maybe PackumentDeps -> Maybe PublishDeps -> MountBinding
npmMount :: Maybe PackumentDeps -> Maybe PublishDeps -> MountBinding
npmMount Maybe PackumentDeps
packumentDeps Maybe PublishDeps
publishDeps =
    MountBinding
        { bindingPrefix :: NonEmpty Text
bindingPrefix = Ecosystem -> NonEmpty Text
prefixFor Ecosystem
Npm
        , bindingClassifier :: Classifier
bindingClassifier = Classifier
Npm.classify
        , bindingPackumentDeps :: Maybe PackumentDeps
bindingPackumentDeps = Maybe PackumentDeps
packumentDeps
        , bindingPublishDeps :: Maybe PublishDeps
bindingPublishDeps = Maybe PublishDeps
publishDeps
        , bindingRenderer :: MountRenderer
bindingRenderer = MountRenderer
npmRenderer
        }

{- | Run the supervised mirror worker over the composition-root 'Env' and the
per-ecosystem re-evaluation bundles: the consume → re-evaluate → fetch → verify → publish →
ack loop against the queue, the publish-side registry client, and the credential handle, in
the worker monad ('Ecluse.Core.Worker.WorkerM') over the worker runtime
('Ecluse.Env.workerRuntimeOf'). The bundles carry the same prepared rules and public origin
the serve path gates with, so the worker re-runs current policy against a job before
mirroring it.

This is the composition-root __hoist point__: it resolves the request-independent @dd@
correlation object (the service identity; no span is active at the worker entry) and
installs it as the worker's initial @katip@ context, then discharges the loop to 'IO'
through 'Ecluse.Core.Worker.runWorkerM', the worker analogue of the serve path's
'Ecluse.Core.Server.Context.runHandler' boundary. The loop logic lives in
"Ecluse.Core.Worker"; the single-process program runs this alongside 'runServer'.
-}
runWorker :: WorkerPolicies -> Env -> IO ()
runWorker :: WorkerPolicies -> Env -> IO ()
runWorker WorkerPolicies
policies Env
env = do
    dd <- DdContext -> IO SimpleLogPayload
forall (m :: * -> *). MonadIO m => DdContext -> m SimpleLogPayload
ddPayloadNow (Env -> DdContext
envDdContext Env
env)
    runWorkerM (envLogEnv env) dd (workerRuntimeOf policies env) (katipAddNamespace "worker" workerLoop)

{- | Resolve the worker's per-ecosystem re-evaluation bundles from the served mounts: for
each mount that serves a packument (carries 'PackumentDeps'), a bundle keyed by the
ecosystem its path prefix names. A mount left at the recognised-but-unserved stub
contributes none, and a job for an ecosystem absent here is fail-closed at the worker. The
bundles reuse each mount's __own__ prepared rules, so the serve gate and the ingest
re-evaluation share one prepared rule set (and any per-source breaker state) rather than
preparing a second.
-}
workerPoliciesFor :: Env -> [MountBinding] -> WorkerPolicies
workerPoliciesFor :: Env -> [MountBinding] -> WorkerPolicies
workerPoliciesFor Env
env [MountBinding]
bindings =
    [(Ecosystem, WorkerPolicy)] -> WorkerPolicies
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        [ (Ecosystem
eco, Env -> PackumentDeps -> WorkerPolicy
workerPolicyFor Env
env PackumentDeps
deps)
        | MountBinding
binding <- [MountBinding]
bindings
        , let Text
prefixHead :| [Text]
_ = MountBinding -> NonEmpty Text
bindingPrefix MountBinding
binding
        , Just Ecosystem
eco <- [Text -> Maybe Ecosystem
parseEcosystem Text
prefixHead]
        , Just PackumentDeps
deps <- [MountBinding -> Maybe PackumentDeps
bindingPackumentDeps MountBinding
binding]
        ]

{- Build one mount's worker re-evaluation bundle from its packument-serve dependencies: the
single-version resolver over the guarded public origin through the shared metadata cache
(the same fetch-and-project the serve path runs, so the ingest decision does not diverge
from the serve decision), the mount's prepared rules, and its injected clock. The metadata
client is anonymous (no client credential reaches the public origin) and reuses the guarded
data-plane manager, so the worker's re-fetch inherits the resolved-IP SSRF recheck. Its own
failure and dropped-entry logs are elided (the worker logs its own re-evaluation outcome per
job), while the upstream-fetch metrics still record through the shared instruments. -}
workerPolicyFor :: Env -> PackumentDeps -> WorkerPolicy
workerPolicyFor :: Env -> PackumentDeps -> WorkerPolicy
workerPolicyFor Env
env PackumentDeps
deps =
    WorkerPolicy
        { wpResolveVersion :: PackageName -> Version -> IO VersionEvaluation
wpResolveVersion = MetadataClient -> PackageName -> Version -> IO VersionEvaluation
fetchVersionDetails MetadataClient
client
        , wpRules :: [PreparedRule]
wpRules = PackumentDeps -> [PreparedRule]
pdRules PackumentDeps
deps
        , wpNow :: IO UTCTime
wpNow = PackumentDeps -> IO UTCTime
pdNow PackumentDeps
deps
        }
  where
    client :: MetadataClient
client =
        TracingPort
-> MetricsPort
-> Upstream
-> ManifestCaching
-> (PackageName -> MetadataError -> IO ())
-> (PackageName -> [InvalidEntry] -> IO ())
-> (PackageName -> IO ())
-> NpmClientConfig
-> MetadataClient
newNpmMetadataClient
            (Telemetry -> TracingPort
tracingPortOf (Env -> Telemetry
envTelemetry Env
env))
            (Metrics -> MetricsPort
metricsPortOf (Env -> Metrics
envMetrics Env
env))
            Upstream
Public
            (MetadataCache -> Source -> ManifestCaching
Cached (Env -> MetadataCache
envMetadataCache Env
env) (Text -> Source
Source (PackumentDeps -> Text
pdPublicBaseUrl PackumentDeps
deps)))
            (\PackageName
_ MetadataError
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
            (\PackageName
_ [InvalidEntry]
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
            (\PackageName
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
            NpmClientConfig
                { npmBaseUrl :: Text
npmBaseUrl = PackumentDeps -> Text
pdPublicBaseUrl PackumentDeps
deps
                , npmManager :: Manager
npmManager = Env -> Manager
envManager Env
env
                , npmToken :: Maybe Secret
npmToken = Maybe Secret
forall a. Maybe a
Nothing
                , npmLimits :: Limits
npmLimits = PackumentDeps -> Limits
pdLimits PackumentDeps
deps
                }

{- Build the worker's publish-side registry client from the resolved per-ecosystem
publish targets, over the given (trusted) manager.

The publish client speaks the registry protocol; the only ecosystem with an adapter
is npm, so a target is wired into an npm client pointed at the mirror-target
endpoint. The credential is minted fresh per publish through the provider's
'currentToken'. When no mount is configured there is nothing to publish, so
the slot holds the refusing 'unconfiguredRegistry' placeholder, whose effectful
fields fail loudly if ever called. -}
resolvePublishClient :: Manager -> [PublishTarget] -> IO RegistryClient
resolvePublishClient :: Manager -> [PublishTarget] -> IO RegistryClient
resolvePublishClient Manager
manager [PublishTarget]
targets =
    case (PublishTarget -> Bool) -> [PublishTarget] -> Maybe PublishTarget
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Ecosystem -> Ecosystem -> Bool
forall a. Eq a => a -> a -> Bool
== Ecosystem
Npm) (Ecosystem -> Bool)
-> (PublishTarget -> Ecosystem) -> PublishTarget -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PublishTarget -> Ecosystem
ptEcosystem) [PublishTarget]
targets of
        Maybe PublishTarget
Nothing -> RegistryClient -> IO RegistryClient
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RegistryClient
unconfiguredRegistry
        Just PublishTarget
target -> do
            let mintToken :: IO (Maybe Secret)
mintToken = Secret -> Maybe Secret
forall a. a -> Maybe a
Just (Secret -> Maybe Secret)
-> (AuthToken -> Secret) -> AuthToken -> Maybe Secret
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AuthToken -> Secret
authSecret (AuthToken -> Maybe Secret) -> IO AuthToken -> IO (Maybe Secret)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CredentialProvider -> IO AuthToken
currentToken (PublishTarget -> CredentialProvider
ptCredentials PublishTarget
target)
            NpmClientConfig -> IO (Maybe Secret) -> IO RegistryClient
newNpmPublishClient
                NpmClientConfig
                    { npmBaseUrl :: Text
npmBaseUrl = PublishTarget -> Text
ptMirrorUrl PublishTarget
target
                    , npmManager :: Manager
npmManager = Manager
manager
                    , npmToken :: Maybe Secret
npmToken = Maybe Secret
forall a. Maybe a
Nothing
                    , npmLimits :: Limits
npmLimits = Limits
defaultLimits
                    }
                IO (Maybe Secret)
mintToken

{- | Raised by 'unconfiguredRegistry' when an effectful registry field is called
with no backend wired in: a composition-root misconfiguration. A distinct typed
exception (not a stringly @userError@), so the refusal is observable in a test,
catchable by type, and never mistaken for a configured backend's own failure.
-}
data RegistryUnconfigured = RegistryUnconfigured
    deriving stock (RegistryUnconfigured -> RegistryUnconfigured -> Bool
(RegistryUnconfigured -> RegistryUnconfigured -> Bool)
-> (RegistryUnconfigured -> RegistryUnconfigured -> Bool)
-> Eq RegistryUnconfigured
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RegistryUnconfigured -> RegistryUnconfigured -> Bool
== :: RegistryUnconfigured -> RegistryUnconfigured -> Bool
$c/= :: RegistryUnconfigured -> RegistryUnconfigured -> Bool
/= :: RegistryUnconfigured -> RegistryUnconfigured -> Bool
Eq, Int -> RegistryUnconfigured -> String -> String
[RegistryUnconfigured] -> String -> String
RegistryUnconfigured -> String
(Int -> RegistryUnconfigured -> String -> String)
-> (RegistryUnconfigured -> String)
-> ([RegistryUnconfigured] -> String -> String)
-> Show RegistryUnconfigured
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> RegistryUnconfigured -> String -> String
showsPrec :: Int -> RegistryUnconfigured -> String -> String
$cshow :: RegistryUnconfigured -> String
show :: RegistryUnconfigured -> String
$cshowList :: [RegistryUnconfigured] -> String -> String
showList :: [RegistryUnconfigured] -> String -> String
Show)

instance Exception RegistryUnconfigured

{- | A registry handle with no backend behind it: every effectful field __refuses
loudly__ (a typed 'RegistryUnconfigured') and every pure @parse*@ field returns
'Left', so an unconfigured fetch\/publish or parse fails explicitly rather than
silently returning a fabricated success. It holds the handle slot in the
composition root where a configured backend is selected elsewhere.
-}
unconfiguredRegistry :: RegistryClient
unconfiguredRegistry :: RegistryClient
unconfiguredRegistry =
    RegistryClient
        { fetchMetadata :: PackageName -> IO RegistryResponse
fetchMetadata = IO RegistryResponse -> PackageName -> IO RegistryResponse
forall a b. a -> b -> a
const IO RegistryResponse
forall a. IO a
refuse
        , fetchArtifact :: PackageName -> Version -> IO RegistryResponse
fetchArtifact = \PackageName
_ Version
_ -> IO RegistryResponse
forall a. IO a
refuse
        , publishArtifact :: PackageName
-> Version
-> MirrorArtifact
-> ByteString
-> IO (Either PublishFault ())
publishArtifact = \PackageName
_ Version
_ MirrorArtifact
_ ByteString
_ -> IO (Either PublishFault ())
forall a. IO a
refuse
        , parsePackageInfo :: PackageName -> RegistryResponse -> Either ParseError PackageInfo
parsePackageInfo = \PackageName
_ RegistryResponse
_ -> ParseError -> Either ParseError PackageInfo
forall a b. a -> Either a b
Left ParseError
notConfigured
        , parseVersionDetails :: RegistryResponse -> Version -> Either ParseError PackageDetails
parseVersionDetails = \RegistryResponse
_ Version
_ -> ParseError -> Either ParseError PackageDetails
forall a b. a -> Either a b
Left ParseError
notConfigured
        , parseVersionList :: RegistryResponse -> Either ParseError [Version]
parseVersionList = Either ParseError [Version]
-> RegistryResponse -> Either ParseError [Version]
forall a b. a -> b -> a
const (ParseError -> Either ParseError [Version]
forall a b. a -> Either a b
Left ParseError
notConfigured)
        }
  where
    refuse :: IO a
    refuse :: forall a. IO a
refuse = RegistryUnconfigured -> IO a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO RegistryUnconfigured
RegistryUnconfigured

    notConfigured :: ParseError
    notConfigured :: ParseError
notConfigured = ParseError{parseErrorMessage :: Text
parseErrorMessage = Text
"no registry backend configured"}

{- | A credential handle with no backend behind it: a static, non-expiring empty
secret. It holds the 'CredentialProvider' slot in the composition root until a live
backend is selected, for the mirror-target write and for the private-upstream read
under the @service@ \/ @delegated-cache@ strategies. The default @passthrough@
strategy needs no read credential at all (reads forward the caller's own token), so
this empty placeholder is harmless on the serve path there. See
@docs\/architecture\/access-model.md@.
-}