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

{- | Shared authentication, admission shedding, and refusal handling.
Route handlers keep their own response formats while sharing these policy decisions.
-}
module Ecluse.Core.Server.Pipeline.Shared (
    -- * Edge authentication
    edgeTokenMatches,
    forwardedCredential,
    unauthorisedMessage,
    privateAuthorisationRefusal,

    -- * Admission shed
    withMetadataAdmission,
    shedStatus,
    shedMessage,
    hRetryAfter,
    shedRetryAfter,
    retryAfterHeaders,

    -- * First-party refusals
    firstPartyRule,

    -- * Integrity-floor rejections
    integrityMissing,
    integrityBelowFloor,
    trustedIntegrityMissing,
    trustedIntegrityBelowFloor,
) where

import Network.HTTP.Types (Header, HeaderName, ResponseHeaders, Status, status503)
import Network.Wai (Request, requestHeaders)
import UnliftIO (MonadUnliftIO)

import Ecluse.Core.Credential (ClientCredential (credSecret), Secret)
import Ecluse.Core.Registry.Request (credentialRecover)
import Ecluse.Core.Server.Admission (withServeAdmission)
import Ecluse.Core.Server.Admission.Meter (MemoryTicket, withMemoryEntry)
import Ecluse.Core.Server.Admission.Weighted (admissionWaitMicros)
import Ecluse.Core.Server.Context (MountBinding (bindingCredential), ServeRuntime (srAdmission, srMemoryMeter, srMetrics))
import Ecluse.Core.Server.Response (
    HelpMessage,
    Refusal,
    RejectReason (BelowIntegrityFloor, MissingIntegrity),
    Rejection (Rejection),
    RetryAfter (RetryAfter),
    RuleName (RuleName),
    ServeDecision (Reject),
    mkRefusal,
 )
import Ecluse.Core.Telemetry.Metrics qualified as Metric
import Ecluse.Core.Telemetry.Record (MetricsPort (mpServeDecision))

-- | The fixed refusal shared by private metadata and artifact access failures.
privateAuthorisationRefusal :: Maybe HelpMessage -> Refusal
privateAuthorisationRefusal :: Maybe HelpMessage -> Refusal
privateAuthorisationRefusal Maybe HelpMessage
help = Maybe HelpMessage -> Text -> Refusal
mkRefusal Maybe HelpMessage
help Text
"the private upstream refused access, so public content cannot replace it"

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

-- | Use 503 to report server admission capacity, without implying a client rate limit.
shedStatus :: Status
shedStatus :: Status
shedStatus = Status
status503

-- | The shed retry delay, rounded down to whole seconds from 'admissionWaitMicros'.
shedRetryAfter :: Header
shedRetryAfter :: Header
shedRetryAfter = (HeaderName
hRetryAfter, Int -> ByteString
forall b a. (Show a, IsString b) => a -> b
show (Int
admissionWaitMicros Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
1_000_000))

-- | The body every read-path shed answers with, so the three handlers say one thing.
shedMessage :: Text
shedMessage :: Text
shedMessage = Text
"server is busy; retry later"

-- | Emit Retry-After only when a decision supplies a delay.
retryAfterHeaders :: Maybe RetryAfter -> ResponseHeaders
retryAfterHeaders :: Maybe RetryAfter -> ResponseHeaders
retryAfterHeaders = ResponseHeaders
-> (RetryAfter -> ResponseHeaders)
-> Maybe RetryAfter
-> ResponseHeaders
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\(RetryAfter Int
secs) -> [(HeaderName
hRetryAfter, Int -> ByteString
forall b a. (Show a, IsString b) => a -> b
show Int
secs)])

{- | Run metadata work behind the memory gate and then the CPU gate, and answer its result after both
release. A shed at either gate answers with @shed@, counted once.
-}
withMetadataAdmission :: (MonadUnliftIO m) => ServeRuntime -> m received -> (MemoryTicket -> m a) -> (a -> m received) -> m received
withMetadataAdmission :: forall (m :: * -> *) received a.
MonadUnliftIO m =>
ServeRuntime
-> m received
-> (MemoryTicket -> m a)
-> (a -> m received)
-> m received
withMetadataAdmission ServeRuntime
runtime m received
shed MemoryTicket -> m a
gated a -> m received
answer =
    m (Maybe a)
admitted m (Maybe a) -> (Maybe a -> m received) -> m received
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just a
result -> a -> m received
answer a
result
        Maybe a
Nothing -> do
            IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (MetricsPort -> Decision -> IO ()
mpServeDecision MetricsPort
metrics Decision
Metric.Unavailable)
            m received
shed
  where
    metrics :: MetricsPort
metrics = ServeRuntime -> MetricsPort
srMetrics ServeRuntime
runtime
    admitted :: m (Maybe a)
admitted = (Maybe (Maybe a) -> Maybe a) -> m (Maybe (Maybe a)) -> m (Maybe a)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe (Maybe a) -> Maybe a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (m (Maybe (Maybe a)) -> m (Maybe a))
-> ((MemoryTicket -> m (Maybe a)) -> m (Maybe (Maybe a)))
-> (MemoryTicket -> m (Maybe a))
-> m (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MetricsPort
-> MemoryMeter
-> (MemoryTicket -> m (Maybe a))
-> m (Maybe (Maybe a))
forall (m :: * -> *) a.
MonadUnliftIO m =>
MetricsPort -> MemoryMeter -> (MemoryTicket -> m a) -> m (Maybe a)
withMemoryEntry MetricsPort
metrics (ServeRuntime -> MemoryMeter
srMemoryMeter ServeRuntime
runtime) ((MemoryTicket -> m (Maybe a)) -> m (Maybe a))
-> (MemoryTicket -> m (Maybe a)) -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ \MemoryTicket
ticket ->
        MetricsPort -> ServeAdmission -> m a -> m (Maybe a)
forall (m :: * -> *) a.
MonadUnliftIO m =>
MetricsPort -> ServeAdmission -> m a -> m (Maybe a)
withServeAdmission MetricsPort
metrics (ServeRuntime -> ServeAdmission
srAdmission ServeRuntime
runtime) (MemoryTicket -> m a
gated MemoryTicket
ticket)

-- | Match the configured inbound secret without content-dependent early exit. An unconfigured edge is open.
edgeTokenMatches :: Maybe Secret -> Maybe ClientCredential -> Bool
edgeTokenMatches :: Maybe Secret -> Maybe ClientCredential -> Bool
edgeTokenMatches Maybe Secret
expected Maybe ClientCredential
forwarded = case Maybe Secret
expected of
    Maybe Secret
Nothing -> Bool
True
    Just Secret
want -> (ClientCredential -> Secret)
-> Maybe ClientCredential -> Maybe Secret
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ClientCredential -> Secret
credSecret Maybe ClientCredential
forwarded Maybe Secret -> Maybe Secret -> Bool
forall a. Eq a => a -> a -> Bool
== Secret -> Maybe Secret
forall a. a -> Maybe a
Just Secret
want

-- | Report edge authentication failure without disclosing either token.
unauthorisedMessage :: Text
unauthorisedMessage :: Text
unauthorisedMessage = Text
"authentication required"

forwardedCredential :: MountBinding -> Request -> Maybe ClientCredential
forwardedCredential :: MountBinding -> Request -> Maybe ClientCredential
forwardedCredential MountBinding
mount = CredentialMapping -> ResponseHeaders -> Maybe ClientCredential
credentialRecover (MountBinding -> CredentialMapping
bindingCredential MountBinding
mount) (ResponseHeaders -> Maybe ClientCredential)
-> (Request -> ResponseHeaders)
-> Request
-> Maybe ClientCredential
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> ResponseHeaders
requestHeaders

{- | The rule a first-party refusal names, so the read pipelines label one denial series rather
than two spellings of the same refusal.
-}
firstPartyRule :: RuleName
firstPartyRule :: RuleName
firstPartyRule = Text -> RuleName
RuleName Text
"first-party"

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")

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")

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")

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")