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

{- | The composition root's worker bundle construction: the per-ecosystem 'WorkerPolicies' the
mirror worker dispatches every job through.

Only the composition root consumes the adapter registry, so the worker receives plain handles.
Each bundle reuses its mount's __own__ 'PackumentDeps', so ingest cannot diverge from serve.
-}
module Ecluse.Composition.Worker (
    workerPoliciesFor,
    mirrorTransportFor,
) where

import Data.Map.Strict qualified as Map

import Ecluse.Composition (PublishTarget (ptCredentials, ptEcosystem, ptMirrorUrl))
import Ecluse.Core.Credential (mintSecret)
import Ecluse.Core.Ecosystem (Ecosystem, parseEcosystem)
import Ecluse.Core.Registry.Adapter (adapterFor, adapterPublish)
import Ecluse.Core.Registry.Adapter.Capability (AdapterMetadata (metadataNewReads), AdapterPublish (publishCodec))
import Ecluse.Core.Registry.Metadata (fetchVersionDetails)
import Ecluse.Core.Registry.Origin (anonymousOrigin)
import Ecluse.Core.Registry.Publish (
    MirrorPublish,
    MirrorTransport (MirrorTransport, ptLimits, ptManager, ptMintToken),
    newMirrorPublish,
 )
import Ecluse.Core.Security (Limits (maxMirrorArtifactBytes), Origin (UntrustedOrigin), thgPublicHostPort)
import Ecluse.Core.Security.Egress (registryUrlText)
import Ecluse.Core.Server.Cache (Source (Source))
import Ecluse.Core.Server.Context (
    PackumentDeps,
    pdArtifact,
    pdFirstParty,
    pdLimits,
    pdMetadata,
    pdMinIntegrity,
    pdNow,
    pdPublicBaseUrl,
    pdRules,
    pdTarballHostGate,
    tarballHostHonoured,
 )
import Ecluse.Core.Server.Metadata (publicMetadataClient)
import Ecluse.Core.Worker (WorkerPolicies, WorkerPolicy (..))
import Ecluse.Runtime.Env (Env, envManager, envMetadataCache, envMetrics, envPrivateManager, envTelemetry)
import Ecluse.Runtime.Server (MountBinding (bindingPackumentDeps, bindingPrefix))
import Ecluse.Runtime.Telemetry.Instruments (metricsPortOf)
import Ecluse.Runtime.Telemetry.Tracing (tracingPortOf)

{- | Build the worker's per-ecosystem bundles from the served mounts and the resolved publish
targets, keyed by the ecosystem each mount's path prefix names. An absent ecosystem fails closed.
-}
workerPoliciesFor :: Env -> [MountBinding] -> [PublishTarget] -> Int -> WorkerPolicies
workerPoliciesFor :: Env -> [MountBinding] -> [PublishTarget] -> Int -> WorkerPolicies
workerPoliciesFor Env
env [MountBinding]
bindings [PublishTarget]
targets Int
artifactMaxBytes =
    [(Ecosystem, WorkerPolicy)] -> WorkerPolicies
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        [ (Ecosystem
eco, Env -> PackumentDeps -> MirrorPublish -> Int -> WorkerPolicy
workerPolicyFor Env
env PackumentDeps
deps MirrorPublish
publish Int
artifactMaxBytes)
        | MountBinding
binding <- [MountBinding]
bindings
        , let Text
prefixHead :| [Text]
_ = MountBinding -> NonEmpty Text
bindingPrefix MountBinding
binding
        , let deps :: PackumentDeps
deps = MountBinding -> PackumentDeps
bindingPackumentDeps MountBinding
binding
        , Just Ecosystem
eco <- [Text -> Maybe Ecosystem
parseEcosystem Text
prefixHead]
        , Just MirrorPublish
publish <- [Env
-> PackumentDeps
-> Map Ecosystem PublishTarget
-> Ecosystem
-> Maybe MirrorPublish
mirrorPublishFor Env
env PackumentDeps
deps Map Ecosystem PublishTarget
targetsByEcosystem Ecosystem
eco]
        ]
  where
    targetsByEcosystem :: Map Ecosystem PublishTarget
targetsByEcosystem = [(Ecosystem, PublishTarget)] -> Map Ecosystem PublishTarget
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(PublishTarget -> Ecosystem
ptEcosystem PublishTarget
target, PublishTarget
target) | PublishTarget
target <- [PublishTarget]
targets]

{- Marry one ecosystem's mirror write to the shared publish transport. 'Nothing' when it
resolves no publish target or no adapter, so the caller wires no half-publish bundle. -}
mirrorPublishFor :: Env -> PackumentDeps -> Map.Map Ecosystem PublishTarget -> Ecosystem -> Maybe MirrorPublish
mirrorPublishFor :: Env
-> PackumentDeps
-> Map Ecosystem PublishTarget
-> Ecosystem
-> Maybe MirrorPublish
mirrorPublishFor Env
env PackumentDeps
deps Map Ecosystem PublishTarget
targets Ecosystem
eco = do
    target <- Ecosystem -> Map Ecosystem PublishTarget -> Maybe PublishTarget
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Ecosystem
eco Map Ecosystem PublishTarget
targets
    adapter <- adapterFor eco
    publish <- adapterPublish adapter
    pure (newMirrorPublish (mirrorTransportFor env deps target) (ptMirrorUrl target) (publishCodec publish))

{- | The shared mirror-write transport for one mount. The presence probe reads under the mount's
own 'pdLimits': a larger mirror packument would overrun the default and defeat duplicate suppression.
-}
mirrorTransportFor :: Env -> PackumentDeps -> PublishTarget -> MirrorTransport
mirrorTransportFor :: Env -> PackumentDeps -> PublishTarget -> MirrorTransport
mirrorTransportFor Env
env PackumentDeps
deps PublishTarget
target =
    MirrorTransport
        { ptManager :: Manager
ptManager = Env -> Manager
envPrivateManager Env
env
        , ptMintToken :: IO (Maybe Secret)
ptMintToken = Secret -> Maybe Secret
forall a. a -> Maybe a
Just (Secret -> Maybe Secret) -> IO Secret -> IO (Maybe Secret)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CredentialProvider -> IO Secret
mintSecret (PublishTarget -> CredentialProvider
ptCredentials PublishTarget
target)
        , ptLimits :: Limits
ptLimits = PackumentDeps -> Limits
pdLimits PackumentDeps
deps
        }

{- Build one mount's worker bundle. The metadata client is anonymous, so no client credential reaches
the public origin, pdTarballHostGate owns the artifact host gate, and the no-op logs defer to the worker's per-job log. -}
workerPolicyFor :: Env -> PackumentDeps -> MirrorPublish -> Int -> WorkerPolicy
workerPolicyFor :: Env -> PackumentDeps -> MirrorPublish -> Int -> WorkerPolicy
workerPolicyFor Env
env PackumentDeps
deps MirrorPublish
publish Int
artifactMaxBytes =
    WorkerPolicy
        { -- The mount's own first-party predicate, so the worker refuses a name the
          -- deployment owns exactly as the serve and publish paths do.
          wpFirstParty :: PackageName -> Bool
wpFirstParty = PackumentDeps -> PackageName -> Bool
pdFirstParty PackumentDeps
deps
        , wpResolveVersion :: PackageName -> Version -> IO VersionEvaluation
wpResolveVersion = MetadataClient -> PackageName -> Version -> IO VersionEvaluation
fetchVersionDetails MetadataClient
client
        , wpRules :: [PreparedRule]
wpRules = PackumentDeps -> [PreparedRule]
pdRules PackumentDeps
deps
        , wpMinIntegrity :: MinIntegrity
wpMinIntegrity = PackumentDeps -> MinIntegrity
pdMinIntegrity PackumentDeps
deps
        , wpArtifactHostHonoured :: Maybe HostPort -> Bool
wpArtifactHostHonoured =
            -- The same host gate the serve path applies before its public artifact fetch, closed
            -- against the public upstream authority.
            Origin -> PackumentDeps -> Maybe HostPort -> Maybe HostPort -> Bool
tarballHostHonoured Origin
UntrustedOrigin PackumentDeps
deps (TarballHostGate -> Maybe HostPort
thgPublicHostPort (PackumentDeps -> TarballHostGate
pdTarballHostGate PackumentDeps
deps))
        , -- The mount's own artifact capability, the adapter record the serve deps
          -- carry, so the worker fetches a job's bytes exactly as the serve path would.
          wpArtifact :: AdapterArtifact
wpArtifact = PackumentDeps -> AdapterArtifact
pdArtifact PackumentDeps
deps
        , wpPublish :: MirrorPublish
wpPublish = MirrorPublish
publish
        , wpArtifactLimits :: Limits
wpArtifactLimits = (PackumentDeps -> Limits
pdLimits PackumentDeps
deps){maxMirrorArtifactBytes = artifactMaxBytes}
        , wpNow :: IO UTCTime
wpNow = PackumentDeps -> IO UTCTime
pdNow PackumentDeps
deps
        }
  where
    client :: MetadataClient
client =
        MetadataCache -> Source -> MetadataReads Public -> MetadataClient
publicMetadataClient (Env -> MetadataCache
envMetadataCache Env
env) (Text -> Source
Source (RegistryUrl -> Text
registryUrlText RegistryUrl
publicBaseUrl)) (MetadataReads Public -> MetadataClient)
-> MetadataReads Public -> MetadataClient
forall a b. (a -> b) -> a -> b
$
            AdapterMetadata
-> forall posture.
   TracingPort
   -> MetricsPort
   -> (PackageName -> MetadataError -> IO ())
   -> (PackageName -> [InvalidEntry] -> IO ())
   -> (PackageName -> IO ())
   -> OriginFor posture
   -> MetadataReads posture
metadataNewReads
                (PackumentDeps -> AdapterMetadata
pdMetadata PackumentDeps
deps)
                (Telemetry -> TracingPort
tracingPortOf (Env -> Telemetry
envTelemetry Env
env))
                (Metrics -> MetricsPort
metricsPortOf (Env -> Metrics
envMetrics Env
env))
                (\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 ())
                OriginFor Public
publicOrigin

    publicBaseUrl :: RegistryUrl
publicBaseUrl = PackumentDeps -> RegistryUrl
pdPublicBaseUrl PackumentDeps
deps

    publicOrigin :: OriginFor Public
publicOrigin = Limits -> Manager -> RegistryUrl -> OriginFor Public
anonymousOrigin (PackumentDeps -> Limits
pdLimits PackumentDeps
deps) (Env -> Manager
envManager Env
env) RegistryUrl
publicBaseUrl