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

{- | Serve artifacts from the private origin or an admitted public fallback.

Private access refusals stop the fallback, and other private misses keep the first-party
restriction. @GET@ and @HEAD@ share policy. The private leg lives in
"Ecluse.Core.Server.Pipeline.Tarball.Private", the gated public leg in
"Ecluse.Core.Server.Pipeline.Tarball.Public", and this module and the public leg render refusals
through "Ecluse.Core.Server.Pipeline.Tarball.Refusal".
-}
module Ecluse.Core.Server.Pipeline.Tarball (
    tarballAction,
    serveTarball,
    headTarball,
) where

import Network.HTTP.Types (Method, status401, status500)
import Network.Wai (Request, ResponseReceived, requestHeaders)

import Ecluse.Core.Credential (ClientCredential)
import Ecluse.Core.Package (PackageName)
import Ecluse.Core.Server.Conditional (forwardValidators)
import Ecluse.Core.Server.Context (
    Handler,
    MountBinding (bindingPackumentDeps),
    PackumentDeps (..),
    ResponseAction (RunPipeline),
    ServeRuntime (..),
    ctxMount,
    ctxRuntime,
 )
import Ecluse.Core.Server.Path (Filename)
import Ecluse.Core.Server.Pipeline.Internal (recordDenials, serveDecisionClass)
import Ecluse.Core.Server.Pipeline.Origin (OriginMiss)
import Ecluse.Core.Server.Pipeline.Shared
import Ecluse.Core.Server.Pipeline.Tarball.Private (
    PrivateLeg (PrivateAnswered, PrivateMissed),
    streamPrivateArtifact,
 )
import Ecluse.Core.Server.Pipeline.Tarball.Public (servePublicArtifact)
import Ecluse.Core.Server.Pipeline.Tarball.Refusal (artifactError, firstPartyMissRefusal)
import Ecluse.Core.Server.Pipeline.Tarball.Relay (ArtifactServe (ServeFull, ServeHead))
import Ecluse.Core.Server.Pipeline.Tarball.Types (ArtifactRequest (..), TarballReplies (..))
import Ecluse.Core.Server.Response (mkRefusal)
import Ecluse.Core.Server.Route (isHead)
import Ecluse.Core.Telemetry.Record (MetricsPort (..))
import Ecluse.Core.Version (Version)

{- | The action a read route names for an artifact coordinate. A @HEAD@ runs the same policy as
@GET@ without pumping upstream bytes.
-}
tarballAction ::
    TarballReplies response ->
    Method ->
    PackageName ->
    Version ->
    Filename ->
    ResponseAction response
tarballAction :: forall response.
TarballReplies response
-> Method
-> PackageName
-> Version
-> Filename
-> ResponseAction response
tarballAction TarballReplies response
replies Method
method PackageName
name Version
version Filename
filename
    | Method -> Bool
isHead Method
method = response
-> (Request
    -> (response -> IO ResponseReceived) -> Handler ResponseReceived)
-> ResponseAction response
forall response.
response
-> (Request
    -> (response -> IO ResponseReceived) -> Handler ResponseReceived)
-> ResponseAction response
RunPipeline response
perimeterFallback (TarballReplies response
-> PackageName
-> Version
-> Filename
-> Request
-> (response -> IO ResponseReceived)
-> Handler ResponseReceived
forall response.
TarballReplies response
-> PackageName
-> Version
-> Filename
-> Request
-> (response -> IO ResponseReceived)
-> Handler ResponseReceived
headTarball TarballReplies response
replies PackageName
name Version
version Filename
filename)
    | Bool
otherwise = response
-> (Request
    -> (response -> IO ResponseReceived) -> Handler ResponseReceived)
-> ResponseAction response
forall response.
response
-> (Request
    -> (response -> IO ResponseReceived) -> Handler ResponseReceived)
-> ResponseAction response
RunPipeline response
perimeterFallback (TarballReplies response
-> PackageName
-> Version
-> Filename
-> Request
-> (response -> IO ResponseReceived)
-> Handler ResponseReceived
forall response.
TarballReplies response
-> PackageName
-> Version
-> Filename
-> Request
-> (response -> IO ResponseReceived)
-> Handler ResponseReceived
serveTarball TarballReplies response
replies PackageName
name Version
version Filename
filename)
  where
    perimeterFallback :: response
perimeterFallback = TarballReplies response
-> Status -> ResponseHeaders -> Refusal -> response
forall response.
TarballReplies response
-> Status -> ResponseHeaders -> Refusal -> response
tarballError TarballReplies response
replies Status
status500 [] (Maybe HelpMessage -> Text -> Refusal
mkRefusal Maybe HelpMessage
forall a. Maybe a
Nothing Text
"internal server error")

-- | Serve an artifact with the caller's credential confined to the private origin.
serveTarball ::
    TarballReplies response ->
    PackageName ->
    Version ->
    Filename ->
    Request ->
    (response -> IO ResponseReceived) ->
    Handler ResponseReceived
serveTarball :: forall response.
TarballReplies response
-> PackageName
-> Version
-> Filename
-> Request
-> (response -> IO ResponseReceived)
-> Handler ResponseReceived
serveTarball = ArtifactServe
-> TarballReplies response
-> PackageName
-> Version
-> Filename
-> Request
-> (response -> IO ResponseReceived)
-> Handler ResponseReceived
forall response.
ArtifactServe
-> TarballReplies response
-> PackageName
-> Version
-> Filename
-> Request
-> (response -> IO ResponseReceived)
-> Handler ResponseReceived
tarballWith ArtifactServe
ServeFull

-- | Probe an artifact with HEAD through the same policy as GET, without pumping upstream bytes.
headTarball ::
    TarballReplies response ->
    PackageName ->
    Version ->
    Filename ->
    Request ->
    (response -> IO ResponseReceived) ->
    Handler ResponseReceived
headTarball :: forall response.
TarballReplies response
-> PackageName
-> Version
-> Filename
-> Request
-> (response -> IO ResponseReceived)
-> Handler ResponseReceived
headTarball = ArtifactServe
-> TarballReplies response
-> PackageName
-> Version
-> Filename
-> Request
-> (response -> IO ResponseReceived)
-> Handler ResponseReceived
forall response.
ArtifactServe
-> TarballReplies response
-> PackageName
-> Version
-> Filename
-> Request
-> (response -> IO ResponseReceived)
-> Handler ResponseReceived
tarballWith ArtifactServe
ServeHead

-- Read the mount's dependencies, check the edge token, and serve in the given mode. The mount's
-- ecosystem presentation supplies the credential the private leg may carry.
tarballWith ::
    ArtifactServe ->
    TarballReplies response ->
    PackageName ->
    Version ->
    Filename ->
    Request ->
    (response -> IO ResponseReceived) ->
    Handler ResponseReceived
tarballWith :: forall response.
ArtifactServe
-> TarballReplies response
-> PackageName
-> Version
-> Filename
-> Request
-> (response -> IO ResponseReceived)
-> Handler ResponseReceived
tarballWith ArtifactServe
mode TarballReplies response
replies PackageName
name Version
version Filename
file Request
request response -> IO ResponseReceived
respond = do
    mount <- (RequestCtx -> MountBinding) -> Handler MountBinding
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks RequestCtx -> MountBinding
ctxMount
    rt <- asks ctxRuntime
    let deps = MountBinding -> PackumentDeps
bindingPackumentDeps MountBinding
mount
        token = MountBinding -> Request -> Maybe ClientCredential
forwardedCredential MountBinding
mount Request
request
        ctx =
            ArtifactRequest
                { arMode :: ArtifactServe
arMode = ArtifactServe
mode
                , arReplies :: TarballReplies response
arReplies = TarballReplies response
replies
                , arRuntime :: ServeRuntime
arRuntime = ServeRuntime
rt
                , arDeps :: PackumentDeps
arDeps = PackumentDeps
deps
                , -- Relayed onto both legs' upstream requests so upstream can answer a 304
                  -- for a pass-through body (the conditional-GET contract).
                  arValidators :: ResponseHeaders
arValidators = ResponseHeaders -> ResponseHeaders
forwardValidators (Request -> ResponseHeaders
requestHeaders Request
request)
                , arPackage :: PackageName
arPackage = PackageName
name
                , arVersion :: Version
arVersion = Version
version
                , arFile :: Filename
arFile = Filename
file
                , arRespond :: response -> IO ResponseReceived
arRespond = response -> IO ResponseReceived
respond
                }
    if edgeTokenMatches (pdInboundToken deps) token
        then serveArtifactLegs ctx token
        else liftIO (respond (tarballError replies status401 [] (mkRefusal Nothing unauthorisedMessage)))

-- The private leg first, then the gated public leg on a miss.
serveArtifactLegs :: ArtifactRequest response -> Maybe ClientCredential -> Handler ResponseReceived
serveArtifactLegs :: forall response.
ArtifactRequest response
-> Maybe ClientCredential -> Handler ResponseReceived
serveArtifactLegs ArtifactRequest response
ctx Maybe ClientCredential
token =
    ArtifactRequest response
-> Maybe ClientCredential -> Handler (PrivateLeg ResponseReceived)
forall response.
ArtifactRequest response
-> Maybe ClientCredential -> Handler (PrivateLeg ResponseReceived)
streamPrivateArtifact ArtifactRequest response
ctx Maybe ClientCredential
token Handler (PrivateLeg ResponseReceived)
-> (PrivateLeg ResponseReceived -> Handler ResponseReceived)
-> Handler 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
        PrivateAnswered Decision
decision ResponseReceived
received -> do
            IO () -> Handler ()
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (MetricsPort -> Decision -> IO ()
mpServeDecision (ServeRuntime -> MetricsPort
srMetrics (ArtifactRequest response -> ServeRuntime
forall response. ArtifactRequest response -> ServeRuntime
arRuntime ArtifactRequest response
ctx)) Decision
decision)
            ResponseReceived -> Handler ResponseReceived
forall a. a -> Handler a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ResponseReceived
received
        PrivateMissed OriginMiss
miss
            | PackumentDeps -> PackageName -> Bool
pdFirstParty (ArtifactRequest response -> PackumentDeps
forall response. ArtifactRequest response -> PackumentDeps
arDeps ArtifactRequest response
ctx) (ArtifactRequest response -> PackageName
forall response. ArtifactRequest response -> PackageName
arPackage ArtifactRequest response
ctx) -> ArtifactRequest response -> OriginMiss -> Handler ResponseReceived
forall response.
ArtifactRequest response -> OriginMiss -> Handler ResponseReceived
refuseFirstParty ArtifactRequest response
ctx OriginMiss
miss
            | Bool
otherwise -> ArtifactRequest response -> Handler ResponseReceived
forall response.
ArtifactRequest response -> Handler ResponseReceived
servePublicArtifact ArtifactRequest response
ctx

-- A first-party name has one authority, so its private miss ends the request here rather than
-- falling through to the public leg.
refuseFirstParty :: ArtifactRequest response -> OriginMiss -> Handler ResponseReceived
refuseFirstParty :: forall response.
ArtifactRequest response -> OriginMiss -> Handler ResponseReceived
refuseFirstParty ArtifactRequest response
ctx OriginMiss
miss = do
    let metrics :: MetricsPort
metrics = ServeRuntime -> MetricsPort
srMetrics (ArtifactRequest response -> ServeRuntime
forall response. ArtifactRequest response -> ServeRuntime
arRuntime ArtifactRequest response
ctx)
        decision :: ServeDecision
decision = OriginMiss -> ServeDecision
firstPartyMissRefusal OriginMiss
miss
    IO () -> Handler ()
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (MetricsPort -> Decision -> IO ()
mpServeDecision MetricsPort
metrics (ServeDecision -> Decision
serveDecisionClass ServeDecision
decision))
    IO () -> Handler ()
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (MetricsPort -> [ServeDecision] -> IO ()
recordDenials MetricsPort
metrics [ServeDecision
decision])
    IO ResponseReceived -> Handler ResponseReceived
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ArtifactRequest response -> response -> IO ResponseReceived
forall response.
ArtifactRequest response -> response -> IO ResponseReceived
arRespond ArtifactRequest response
ctx (TarballReplies response
-> PackumentDeps -> ServeDecision -> response
forall response.
TarballReplies response
-> PackumentDeps -> ServeDecision -> response
artifactError (ArtifactRequest response -> TarballReplies response
forall response.
ArtifactRequest response -> TarballReplies response
arReplies ArtifactRequest response
ctx) (ArtifactRequest response -> PackumentDeps
forall response. ArtifactRequest response -> PackumentDeps
arDeps ArtifactRequest response
ctx) ServeDecision
decision))