{- | Shared utilities for the data-plane handler modules.

This module provides the common combinators and shared types used across the packument,
tarball, and publish handlers. It handles edge authentication checks, defines common
HTTP response rendering functions, and declares shared serve rejection values (e.g.,
for integrity floor enforcement).
-}
module Ecluse.Core.Server.Pipeline.Shared (
    recognisedButUnserved,
    edgeTokenMatches,
    edgeUnauthorised,
    serveOverloaded,
    forwardedToken,
    jsonResponse,
    renderedResponse,
    bodiless,
    integrityMissing,
    integrityBelowFloor,
    trustedIntegrityMissing,
    trustedIntegrityBelowFloor,
    hRetryAfter,
) where

import Data.Text qualified as T
import Network.HTTP.Types (HeaderName, ResponseHeaders, Status, hAuthorization, hContentType, status401, status501, status503)
import Network.Wai (Request, Response, requestHeaders, responseHeaders, responseLBS, responseStatus)

import Ecluse.Core.Credential (Secret, mkSecret)
import Ecluse.Core.Server.Response (
    MountRenderer,
    RejectReason (BelowIntegrityFloor, MissingIntegrity),
    Rejection (Rejection),
    RenderedBody (RenderedBody),
    ServeDecision (Reject),
    renderError,
 )

hRetryAfter :: HeaderName
hRetryAfter :: HeaderName
hRetryAfter = HeaderName
"Retry-After"

recognisedButUnserved :: MountRenderer -> Response
recognisedButUnserved :: MountRenderer -> Response
recognisedButUnserved MountRenderer
renderer =
    Status -> ResponseHeaders -> RenderedBody -> Response
renderedResponse Status
status501 [] (MountRenderer -> Maybe HelpMessage -> Text -> RenderedBody
renderError MountRenderer
renderer Maybe HelpMessage
forall a. Maybe a
Nothing Text
"this route is recognised but not yet served by this proxy")

{- | The shared edge gate against a configured inbound token: with none configured the
edge is open; with one configured the request's forwarded bearer must match it exactly.
Deny-by-default: a missing or mismatched bearer is rejected. The match is constant-time:
'Secret' equality compares over the full UTF-8 bytes without a content-dependent early
out, so this gate does not leak the configured token's prefix length through timing.

The packument, tarball, and publish paths all apply the same gate, so it is factored
here rather than duplicated per route. It takes the __already-extracted__ bearer
('forwardedToken') rather than the request, so a handler that also forwards the
credential upstream scans the headers for it once and reuses the one extraction for
both.
-}
edgeTokenMatches :: Maybe Secret -> Maybe Secret -> Bool
edgeTokenMatches :: Maybe Secret -> Maybe Secret -> Bool
edgeTokenMatches Maybe Secret
expected Maybe Secret
forwarded = case Maybe Secret
expected of
    Maybe Secret
Nothing -> Bool
True
    Just Secret
want -> Maybe Secret
forwarded Maybe Secret -> Maybe Secret -> Bool
forall a. Eq a => a -> a -> Bool
== Secret -> Maybe Secret
forall a. a -> Maybe a
Just Secret
want

-- A @401@ for a request that failed edge authentication, before any upstream
-- fetch; the body is shaped by the mount's renderer.
edgeUnauthorised :: MountRenderer -> Response
edgeUnauthorised :: MountRenderer -> Response
edgeUnauthorised MountRenderer
renderer =
    Status -> ResponseHeaders -> RenderedBody -> Response
renderedResponse Status
status401 [] (MountRenderer -> Maybe HelpMessage -> Text -> RenderedBody
renderError MountRenderer
renderer Maybe HelpMessage
forall a. Maybe a
Nothing Text
"authentication required")

{- | An admission refusal: the request found the waiting room full, or waited out
its slot budget ("Ecluse.Core.Server.Admission"). The body follows the matched
mount's error surface and the retry hint is deliberately short: capacity, unlike a
policy denial, can clear as soon as one in-flight metadata operation completes,
and a budget-expiry refusal has already waited one such interval in-process.
-}
serveOverloaded :: MountRenderer -> Response
serveOverloaded :: MountRenderer -> Response
serveOverloaded MountRenderer
renderer =
    Status -> ResponseHeaders -> RenderedBody -> Response
renderedResponse Status
status503 [(HeaderName
hRetryAfter, ByteString
"1")] (MountRenderer -> Maybe HelpMessage -> Text -> RenderedBody
renderError MountRenderer
renderer Maybe HelpMessage
forall a. Maybe a
Nothing Text
"server is busy; retry later")

{- The client's forwarded bearer credential, recovered from the request's
@Authorization: Bearer …@ header. 'Nothing' when no bearer credential is present;
the recovered 'Secret' is what is forwarded to the private upstream and compared
against the edge token. The scheme name is matched case-insensitively (npm sends
@Bearer@), the token taken verbatim after it. -}
forwardedToken :: Request -> Maybe Secret
forwardedToken :: Request -> Maybe Secret
forwardedToken Request
request = do
    (_, raw) <- ((HeaderName, ByteString) -> Bool)
-> ResponseHeaders -> Maybe (HeaderName, ByteString)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
hAuthorization) (HeaderName -> Bool)
-> ((HeaderName, ByteString) -> HeaderName)
-> (HeaderName, ByteString)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HeaderName, ByteString) -> HeaderName
forall a b. (a, b) -> a
fst) (Request -> ResponseHeaders
requestHeaders Request
request)
    let value = ByteString -> Text
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 ByteString
raw
        (scheme, rest) = T.break (== ' ') value
    guard (T.toLower scheme == "bearer")
    let token = (Char -> Bool) -> Text -> Text
T.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') Text
rest
    guard (not (T.null token))
    pure (mkSecret token)

-- A JSON response with the given status, extra headers, and body. Used for the
-- served packument document itself, which is npm JSON.
jsonResponse :: Status -> ResponseHeaders -> LByteString -> Response
jsonResponse :: Status -> ResponseHeaders -> ByteString -> Response
jsonResponse Status
status ResponseHeaders
extra =
    Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
status ((HeaderName
hContentType, ByteString
"application/json") (HeaderName, ByteString) -> ResponseHeaders -> ResponseHeaders
forall a. a -> [a] -> [a]
: ResponseHeaders
extra)

-- A response built from a renderer's 'RenderedBody': its content type, then any
-- extra headers, then the rendered bytes.
renderedResponse :: Status -> ResponseHeaders -> RenderedBody -> Response
renderedResponse :: Status -> ResponseHeaders -> RenderedBody -> Response
renderedResponse Status
status ResponseHeaders
extra (RenderedBody ByteString
contentType ByteString
body) =
    Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
status ((HeaderName
hContentType, ByteString
contentType) (HeaderName, ByteString) -> ResponseHeaders -> ResponseHeaders
forall a. a -> [a] -> [a]
: ResponseHeaders
extra) ByteString
body

-- Strip a response's body while keeping its status and headers -- the bodiless form a
-- HEAD reply takes on every branch (HTTP semantics: a HEAD carries no message body).
-- The headers a GET would carry (notably any relayed @Content-Length@) are preserved.
bodiless :: Response -> Response
bodiless :: Response -> Response
bodiless Response
response = Status -> ResponseHeaders -> ByteString -> Response
responseLBS (Response -> Status
responseStatus Response
response) (Response -> ResponseHeaders
responseHeaders Response
response) ByteString
""

{- A __public__ version refused by the integrity-presence admission policy: its selected
artifact carries no integrity digest of any kind, so it cannot be tied to a
tamper-evident fingerprint. A deliberate deny-by-default policy refusal ('MissingIntegrity',
rendered @403@), not a rule denial and not a retryable outage. The trusted (private) path
uses 'trustedIntegrityMissing' instead, worded for its own context. -}
integrityMissing :: ServeDecision
integrityMissing :: ServeDecision
integrityMissing =
    Rejection -> ServeDecision
Reject (RejectReason -> Text -> Rejection
Rejection RejectReason
MissingIntegrity Text
"this version carries no integrity digest and cannot be served from a public upstream")

{- A __public__ version refused by the integrity-floor admission policy: its selected
artifact carries an integrity digest, but the strongest one is weaker than the configured
minimum algorithm, so its bytes cannot be tied to a collision-resistant fingerprint. A
deliberate deny-by-default policy refusal ('BelowIntegrityFloor', rendered @403@),
distinct from 'integrityMissing' so the audit trail says which. The trusted (private) path
uses 'trustedIntegrityBelowFloor' instead. -}
integrityBelowFloor :: ServeDecision
integrityBelowFloor :: ServeDecision
integrityBelowFloor =
    Rejection -> ServeDecision
Reject (RejectReason -> Text -> Rejection
Rejection RejectReason
BelowIntegrityFloor Text
"this version's integrity digest is weaker than the configured minimum and cannot be served from a public upstream")

{- A __trusted__ (private) version dropped by the trusted integrity floor for carrying no
integrity digest at all. The same 'MissingIntegrity' @403@ as the public refusal, but
worded for the private path; it surfaces only in the no-survivors body when no version
(private or public) is admissible. -}
trustedIntegrityMissing :: ServeDecision
trustedIntegrityMissing :: ServeDecision
trustedIntegrityMissing =
    Rejection -> ServeDecision
Reject (RejectReason -> Text -> Rejection
Rejection RejectReason
MissingIntegrity Text
"this private version carries no integrity digest and was not served")

{- A __trusted__ (private) version dropped by the trusted integrity floor: its strongest
digest is weaker than the configured trusted minimum (which an operator may loosen below
SHA-256). The same 'BelowIntegrityFloor' @403@ as the public refusal, worded for the
private path. -}
trustedIntegrityBelowFloor :: ServeDecision
trustedIntegrityBelowFloor :: ServeDecision
trustedIntegrityBelowFloor =
    Rejection -> ServeDecision
Reject (RejectReason -> Text -> Rejection
Rejection RejectReason
BelowIntegrityFloor Text
"this private version's integrity digest is weaker than the configured trusted minimum and was not served")