-- SPDX-FileCopyrightText: 2026 Alexandra de Wit
--
-- SPDX-License-Identifier: MIT
{-# LANGUAGE TupleSections #-}

{- | The trusted leg of the artifact path: read the private origin under the caller's credential.

An access refusal commits the local error and never relays upstream's body, so a private @401@ or
@403@ cannot be answered from the public registry. Any other miss falls through to the caller.
-}
module Ecluse.Core.Server.Pipeline.Tarball.Private (
    PrivateLeg (..),
    streamPrivateArtifact,
    privateMetadataMiss,
) where

import Network.HTTP.Client qualified as HTTP
import Network.HTTP.Types (status403, statusCode)
import Network.Wai (ResponseReceived)

import Ecluse.Core.Credential (ClientCredential)
import Ecluse.Core.Package (
    Artifact (artFilename, artUrl),
    PackageDetails (pkgArtifacts),
 )
import Ecluse.Core.Registry (isAuthorisationFailure)
import Ecluse.Core.Registry.Adapter.Capability (AdapterArtifact (artifactByFile, artifactByUrl, artifactHosts))
import Ecluse.Core.Registry.Metadata (
    MetadataClient (fetchVersionMetadata),
    MetadataError (
        MetadataAbsent,
        MetadataAuthorisationFailure,
        MetadataBoundExceeded,
        MetadataFetch,
        MetadataHttpFailure,
        MetadataNameMismatch,
        MetadataUndecodable
    ),
    VersionDoc (vdDetails),
    VersionRead (vrVersion),
 )
import Ecluse.Core.Security (
    HostPort,
    Limits (progressFloor),
    Origin (TrustedOrigin),
    artifactAuthorityHonoured,
    hostPortAddress,
    thgEcosystemHosts,
    thgPrivateHostPort,
 )
import Ecluse.Core.Security.Egress (RegistryUrl)
import Ecluse.Core.Server.Context (
    Handler,
    PackumentDeps (..),
    ServeRuntime (..),
    pdPrivateBaseUrl,
    pdTarballHostGate,
    tarballHostHonoured,
 )
import Ecluse.Core.Server.Path (unFilename)
import Ecluse.Core.Server.Pipeline.Origin (
    OriginMiss (MissAbsent, MissUnresolved),
    mountOrigin,
    withPrivateMetadataClient,
 )
import Ecluse.Core.Server.Pipeline.Shared
import Ecluse.Core.Server.Pipeline.Tarball.Relay (
    acceptArtifact,
    relayUnjudged,
    relayUpstreamWhen,
    withMethod,
    withValidators,
 )
import Ecluse.Core.Server.Pipeline.Tarball.Types (ArtifactRequest (..), TarballReplies (..))
import Ecluse.Core.Server.Stream (RelayResponder (RelayResponder))
import Ecluse.Core.Telemetry.Metrics qualified as Metric
import UnliftIO (tryAny)

-- | The private leg's answer: the response it committed, or why it did not answer.
data PrivateLeg received
    = PrivateAnswered Metric.Decision received
    | PrivateMissed OriginMiss

-- | Read the private origin, committing a response or reporting the miss that ends the leg.
streamPrivateArtifact ::
    ArtifactRequest response ->
    Maybe ClientCredential ->
    Handler (PrivateLeg ResponseReceived)
streamPrivateArtifact :: forall response.
ArtifactRequest response
-> Maybe ClientCredential -> Handler (PrivateLeg ResponseReceived)
streamPrivateArtifact ArtifactRequest response
ctx Maybe ClientCredential
token =
    ArtifactRequest response
-> Maybe ClientCredential -> Handler PrivateArtifact
forall response.
ArtifactRequest response
-> Maybe ClientCredential -> Handler PrivateArtifact
privateArtifactRequest ArtifactRequest response
ctx Maybe ClientCredential
token Handler PrivateArtifact
-> (PrivateArtifact -> Handler (PrivateLeg ResponseReceived))
-> Handler (PrivateLeg ResponseReceived)
forall a b. Handler a -> (a -> Handler b) -> Handler b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        PrivateArtifact
PrivateRefused -> Decision -> ResponseReceived -> PrivateLeg ResponseReceived
forall received. Decision -> received -> PrivateLeg received
PrivateAnswered Decision
Metric.Deny (ResponseReceived -> PrivateLeg ResponseReceived)
-> Handler ResponseReceived
-> Handler (PrivateLeg ResponseReceived)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ResponseReceived -> Handler ResponseReceived
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ResponseReceived
refuse
        PrivateMissing OriginMiss
miss -> PrivateLeg ResponseReceived
-> Handler (PrivateLeg ResponseReceived)
forall a. a -> Handler a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OriginMiss -> PrivateLeg ResponseReceived
forall received. OriginMiss -> PrivateLeg received
PrivateMissed OriginMiss
miss)
        -- The relay reports no cause of its own, so a rejected private status and an unreachable
        -- private host are one miss, each keeping today's fall-through.
        PrivateRequest Request
req ->
            IO (PrivateLeg ResponseReceived)
-> Handler (PrivateLeg ResponseReceived)
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (PrivateLeg ResponseReceived)
 -> Handler (PrivateLeg ResponseReceived))
-> IO (PrivateLeg ResponseReceived)
-> Handler (PrivateLeg ResponseReceived)
forall a b. (a -> b) -> a -> b
$
                PrivateLeg ResponseReceived
-> (((), (Decision, ResponseReceived))
    -> PrivateLeg ResponseReceived)
-> Maybe ((), (Decision, ResponseReceived))
-> PrivateLeg ResponseReceived
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (OriginMiss -> PrivateLeg ResponseReceived
forall received. OriginMiss -> PrivateLeg received
PrivateMissed OriginMiss
MissAbsent) ((Decision -> ResponseReceived -> PrivateLeg ResponseReceived)
-> (Decision, ResponseReceived) -> PrivateLeg ResponseReceived
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Decision -> ResponseReceived -> PrivateLeg ResponseReceived
forall received. Decision -> received -> PrivateLeg received
PrivateAnswered ((Decision, ResponseReceived) -> PrivateLeg ResponseReceived)
-> (((), (Decision, ResponseReceived))
    -> (Decision, ResponseReceived))
-> ((), (Decision, ResponseReceived))
-> PrivateLeg ResponseReceived
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((), (Decision, ResponseReceived)) -> (Decision, ResponseReceived)
forall a b. (a, b) -> b
snd)
                    (Maybe ((), (Decision, ResponseReceived))
 -> PrivateLeg ResponseReceived)
-> IO (Maybe ((), (Decision, ResponseReceived)))
-> IO (PrivateLeg ResponseReceived)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ArtifactServe
-> Manager
-> ProgressFloor
-> Request
-> (Status -> Bool)
-> (Status -> ResponseHeaders -> IO (Status, ResponseHeaders, ()))
-> RelayResponder (Decision, ResponseReceived)
-> IO (Maybe ((), (Decision, ResponseReceived)))
forall verdict response.
ArtifactServe
-> Manager
-> ProgressFloor
-> Request
-> (Status -> Bool)
-> (Status
    -> ResponseHeaders -> IO (Status, ResponseHeaders, verdict))
-> RelayResponder response
-> IO (Maybe (verdict, response))
relayUpstreamWhen (ArtifactRequest response -> ArtifactServe
forall response. ArtifactRequest response -> ArtifactServe
arMode ArtifactRequest response
ctx) (ServeRuntime -> Manager
srPrivateManager (ArtifactRequest response -> ServeRuntime
forall response. ArtifactRequest response -> ServeRuntime
arRuntime ArtifactRequest response
ctx)) (Limits -> ProgressFloor
progressFloor (PackumentDeps -> Limits
pdLimits (ArtifactRequest response -> PackumentDeps
forall response. ArtifactRequest response -> PackumentDeps
arDeps ArtifactRequest response
ctx))) (Request -> Request
shaped Request
req) Status -> Bool
acceptPrivate Status -> ResponseHeaders -> IO (Status, ResponseHeaders, ())
relayUnjudged RelayResponder (Decision, ResponseReceived)
privateResponder
  where
    replies :: TarballReplies response
replies = ArtifactRequest response -> TarballReplies response
forall response.
ArtifactRequest response -> TarballReplies response
arReplies ArtifactRequest response
ctx
    respond :: response -> IO ResponseReceived
respond = ArtifactRequest response -> response -> IO ResponseReceived
forall response.
ArtifactRequest response -> response -> IO ResponseReceived
arRespond ArtifactRequest response
ctx

    shaped :: Request -> Request
shaped = ResponseHeaders -> Request -> Request
withValidators (ArtifactRequest response -> ResponseHeaders
forall response. ArtifactRequest response -> ResponseHeaders
arValidators ArtifactRequest response
ctx) (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArtifactServe -> Request -> Request
withMethod (ArtifactRequest response -> ArtifactServe
forall response. ArtifactRequest response -> ArtifactServe
arMode ArtifactRequest response
ctx)
    refuse :: IO ResponseReceived
refuse = response -> IO ResponseReceived
respond (TarballReplies response
-> Status -> ResponseHeaders -> Refusal -> response
forall response.
TarballReplies response
-> Status -> ResponseHeaders -> Refusal -> response
tarballError TarballReplies response
replies Status
status403 [] (Maybe HelpMessage -> Refusal
privateAuthorisationRefusal (PackumentDeps -> Maybe HelpMessage
pdHelp (ArtifactRequest response -> PackumentDeps
forall response. ArtifactRequest response -> PackumentDeps
arDeps ArtifactRequest response
ctx))))
    acceptPrivate :: Status -> Bool
acceptPrivate Status
status = Status -> Bool
acceptArtifact Status
status Bool -> Bool -> Bool
|| Int -> Bool
isAuthorisationFailure (Status -> Int
statusCode Status
status)

    privateResponder :: RelayResponder (Decision, ResponseReceived)
privateResponder =
        (Status
 -> ResponseHeaders
 -> StreamingBody
 -> IO (Decision, ResponseReceived))
-> (Status -> ResponseHeaders -> IO (Decision, ResponseReceived))
-> RelayResponder (Decision, ResponseReceived)
forall response.
(Status -> ResponseHeaders -> StreamingBody -> IO response)
-> (Status -> ResponseHeaders -> IO response)
-> RelayResponder response
RelayResponder
            (\Status
status ResponseHeaders
headers StreamingBody
body -> Status -> IO ResponseReceived -> IO (Decision, ResponseReceived)
answerPrivate Status
status (response -> IO ResponseReceived
respond (TarballReplies response
-> Status -> ResponseHeaders -> StreamingBody -> response
forall response.
TarballReplies response
-> Status -> ResponseHeaders -> StreamingBody -> response
tarballStream TarballReplies response
replies Status
status ResponseHeaders
headers StreamingBody
body)))
            (\Status
status ResponseHeaders
headers -> Status -> IO ResponseReceived -> IO (Decision, ResponseReceived)
answerPrivate Status
status (response -> IO ResponseReceived
respond (TarballReplies response -> Status -> ResponseHeaders -> response
forall response.
TarballReplies response -> Status -> ResponseHeaders -> response
tarballEmpty TarballReplies response
replies Status
status ResponseHeaders
headers)))

    answerPrivate :: Status -> IO ResponseReceived -> IO (Decision, ResponseReceived)
answerPrivate Status
status IO ResponseReceived
admitted
        | Int -> Bool
isAuthorisationFailure (Status -> Int
statusCode Status
status) = (Decision
Metric.Deny,) (ResponseReceived -> (Decision, ResponseReceived))
-> IO ResponseReceived -> IO (Decision, ResponseReceived)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ResponseReceived
refuse
        | Bool
otherwise = (Decision
Metric.Admit,) (ResponseReceived -> (Decision, ResponseReceived))
-> IO ResponseReceived -> IO (Decision, ResponseReceived)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ResponseReceived
admitted

-- The private leg's outcome before any relay: a request to make, an explicit refusal, or a miss.
data PrivateArtifact
    = PrivateRequest HTTP.Request
    | PrivateRefused
    | PrivateMissing OriginMiss

privateArtifactRequest :: ArtifactRequest response -> Maybe ClientCredential -> Handler PrivateArtifact
privateArtifactRequest :: forall response.
ArtifactRequest response
-> Maybe ClientCredential -> Handler PrivateArtifact
privateArtifactRequest ArtifactRequest response
ctx Maybe ClientCredential
token = case PackumentDeps -> Maybe RegistryUrl
pdPrivateBaseUrl PackumentDeps
deps of
    -- An unconfigured leg and a refused host settle the request here: neither changes on a retry.
    Maybe RegistryUrl
Nothing -> PrivateArtifact -> Handler PrivateArtifact
forall a. a -> Handler a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OriginMiss -> PrivateArtifact
PrivateMissing OriginMiss
MissAbsent)
    Just RegistryUrl
privateBase
        | Bool -> Bool
not (Origin -> PackumentDeps -> Maybe HostPort -> Maybe HostPort -> Bool
tarballHostHonoured Origin
TrustedOrigin PackumentDeps
deps Maybe HostPort
privateHostPort Maybe HostPort
privateHostPort) -> PrivateArtifact -> Handler PrivateArtifact
forall a. a -> Handler a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OriginMiss -> PrivateArtifact
PrivateMissing OriginMiss
MissAbsent)
        | [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (AdapterArtifact -> [Text]
artifactHosts (PackumentDeps -> AdapterArtifact
pdArtifact PackumentDeps
deps)) -> PrivateArtifact -> Handler PrivateArtifact
forall a. a -> Handler a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RegistryUrl -> PrivateArtifact
byConventionalPath RegistryUrl
privateBase)
        | Bool
otherwise -> ArtifactRequest response
-> Maybe ClientCredential
-> RegistryUrl
-> Maybe HostPort
-> Handler PrivateArtifact
forall response.
ArtifactRequest response
-> Maybe ClientCredential
-> RegistryUrl
-> Maybe HostPort
-> Handler PrivateArtifact
byIndexedLocation ArtifactRequest response
ctx Maybe ClientCredential
token RegistryUrl
privateBase Maybe HostPort
privateHostPort
  where
    deps :: PackumentDeps
deps = ArtifactRequest response -> PackumentDeps
forall response. ArtifactRequest response -> PackumentDeps
arDeps ArtifactRequest response
ctx

    -- The precomputed private authority. A conventionally-built URL is on the private base, so
    -- the gate stays applied and trivially satisfied without re-parsing the URL.
    privateHostPort :: Maybe HostPort
privateHostPort = TarballHostGate -> Maybe HostPort
thgPrivateHostPort (PackumentDeps -> TarballHostGate
pdTarballHostGate PackumentDeps
deps)

    byConventionalPath :: RegistryUrl -> PrivateArtifact
byConventionalPath RegistryUrl
privateBase =
        (UrlFormationError -> PrivateArtifact)
-> (Request -> PrivateArtifact)
-> Either UrlFormationError Request
-> PrivateArtifact
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (PrivateArtifact -> UrlFormationError -> PrivateArtifact
forall a b. a -> b -> a
const (OriginMiss -> PrivateArtifact
PrivateMissing OriginMiss
MissAbsent)) Request -> PrivateArtifact
PrivateRequest (Either UrlFormationError Request -> PrivateArtifact)
-> Either UrlFormationError Request -> PrivateArtifact
forall a b. (a -> b) -> a -> b
$
            AdapterArtifact
-> OriginClient
-> PackageName
-> Text
-> Either UrlFormationError Request
artifactByFile (PackumentDeps -> AdapterArtifact
pdArtifact PackumentDeps
deps) (PackumentDeps
-> Manager -> RegistryUrl -> Maybe ClientCredential -> OriginClient
mountOrigin PackumentDeps
deps (ServeRuntime -> Manager
srPrivateManager (ArtifactRequest response -> ServeRuntime
forall response. ArtifactRequest response -> ServeRuntime
arRuntime ArtifactRequest response
ctx)) RegistryUrl
privateBase Maybe ClientCredential
token) (ArtifactRequest response -> PackageName
forall response. ArtifactRequest response -> PackageName
arPackage ArtifactRequest response
ctx) (Filename -> Text
unFilename (ArtifactRequest response -> Filename
forall response. ArtifactRequest response -> Filename
arFile ArtifactRequest response
ctx))

{- The location is gated from the same definition the download gate reads, and the credential
rides only when the target is the private upstream itself. -}
byIndexedLocation :: ArtifactRequest response -> Maybe ClientCredential -> RegistryUrl -> Maybe HostPort -> Handler PrivateArtifact
byIndexedLocation :: forall response.
ArtifactRequest response
-> Maybe ClientCredential
-> RegistryUrl
-> Maybe HostPort
-> Handler PrivateArtifact
byIndexedLocation ArtifactRequest response
ctx Maybe ClientCredential
token RegistryUrl
privateBase Maybe HostPort
privateHostPort = do
    resolved <- Handler (Either MetadataError VersionRead)
-> Handler
     (Either SomeException (Either MetadataError VersionRead))
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny (ServeRuntime
-> PackumentDeps
-> RegistryUrl
-> Maybe ClientCredential
-> (MetadataClient -> IO (Either MetadataError VersionRead))
-> Handler (Either MetadataError VersionRead)
forall a.
ServeRuntime
-> PackumentDeps
-> RegistryUrl
-> Maybe ClientCredential
-> (MetadataClient -> IO a)
-> Handler a
withPrivateMetadataClient (ArtifactRequest response -> ServeRuntime
forall response. ArtifactRequest response -> ServeRuntime
arRuntime ArtifactRequest response
ctx) PackumentDeps
deps RegistryUrl
privateBase Maybe ClientCredential
token (\MetadataClient
client -> MetadataClient
-> PackageName -> Version -> IO (Either MetadataError VersionRead)
fetchVersionMetadata MetadataClient
client (ArtifactRequest response -> PackageName
forall response. ArtifactRequest response -> PackageName
arPackage ArtifactRequest response
ctx) (ArtifactRequest response -> Version
forall response. ArtifactRequest response -> Version
arVersion ArtifactRequest response
ctx)))
    pure $ case resolved of
        Left SomeException
_ -> OriginMiss -> PrivateArtifact
PrivateMissing OriginMiss
MissUnresolved
        Right (Left MetadataError
err) -> PrivateArtifact
-> (OriginMiss -> PrivateArtifact)
-> Maybe OriginMiss
-> PrivateArtifact
forall b a. b -> (a -> b) -> Maybe a -> b
maybe PrivateArtifact
PrivateRefused OriginMiss -> PrivateArtifact
PrivateMissing (MetadataError -> Maybe OriginMiss
privateMetadataMiss MetadataError
err)
        Right (Right VersionRead
versionRead) -> PrivateArtifact
-> (Request -> PrivateArtifact) -> Maybe Request -> PrivateArtifact
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (OriginMiss -> PrivateArtifact
PrivateMissing OriginMiss
MissAbsent) Request -> PrivateArtifact
PrivateRequest (VersionRead -> Maybe VersionDoc
vrVersion VersionRead
versionRead Maybe VersionDoc -> (VersionDoc -> Maybe Request) -> Maybe Request
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PackageDetails -> Maybe Request
requestForDetails (PackageDetails -> Maybe Request)
-> (VersionDoc -> PackageDetails) -> VersionDoc -> Maybe Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VersionDoc -> PackageDetails
vdDetails)
  where
    deps :: PackumentDeps
deps = ArtifactRequest response -> PackumentDeps
forall response. ArtifactRequest response -> PackumentDeps
arDeps ArtifactRequest response
ctx

    requestForDetails :: PackageDetails -> Maybe Request
requestForDetails PackageDetails
details = do
        artifact <- (Artifact -> Bool) -> NonEmpty Artifact -> Maybe Artifact
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Filename -> Text
unFilename (ArtifactRequest response -> Filename
forall response. ArtifactRequest response -> Filename
arFile ArtifactRequest response
ctx)) (Text -> Bool) -> (Artifact -> Text) -> Artifact -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Artifact -> Text
artFilename) (PackageDetails -> NonEmpty Artifact
pkgArtifacts PackageDetails
details)
        let target = Text -> Maybe HostPort
hostPortAddress (Artifact -> Text
artUrl Artifact
artifact)
        guard (artifactAuthorityHonoured (thgEcosystemHosts (pdTarballHostGate deps)) privateHostPort target)
        let carried = if Maybe HostPort
target Maybe HostPort -> Maybe HostPort -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe HostPort
privateHostPort then Maybe ClientCredential
token else Maybe ClientCredential
forall a. Maybe a
Nothing
        rightToMaybe (artifactByUrl (pdArtifact deps) carried (artUrl artifact))

{- | The miss a private metadata failure leaves the artifact path, or 'Nothing' for an explicit
access refusal. An identity fault settles the request, because this path renders no @502@ for one.
-}
privateMetadataMiss :: MetadataError -> Maybe OriginMiss
privateMetadataMiss :: MetadataError -> Maybe OriginMiss
privateMetadataMiss = \case
    MetadataAuthorisationFailure{} -> Maybe OriginMiss
forall a. Maybe a
Nothing
    MetadataError
MetadataAbsent -> OriginMiss -> Maybe OriginMiss
forall a. a -> Maybe a
Just OriginMiss
MissAbsent
    MetadataNameMismatch{} -> OriginMiss -> Maybe OriginMiss
forall a. a -> Maybe a
Just OriginMiss
MissAbsent
    MetadataHttpFailure{} -> OriginMiss -> Maybe OriginMiss
forall a. a -> Maybe a
Just OriginMiss
MissUnresolved
    MetadataBoundExceeded{} -> OriginMiss -> Maybe OriginMiss
forall a. a -> Maybe a
Just OriginMiss
MissUnresolved
    MetadataFetch{} -> OriginMiss -> Maybe OriginMiss
forall a. a -> Maybe a
Just OriginMiss
MissUnresolved
    MetadataError
MetadataUndecodable -> OriginMiss -> Maybe OriginMiss
forall a. a -> Maybe a
Just OriginMiss
MissUnresolved