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

{- | Internal guts of the serve pipeline ("Ecluse.Core.Server.Pipeline"), exposed for
tests without widening that module's two-handler public API -- the @.Internal@ convention,
as "Ecluse.Core.Credential.Refresh.Internal" uses. Importing it opts out of the public
module's stability promise.

It holds the operator-facing warning helpers for the bad-upstream and misconfiguration
conditions the response-bound guards leave silent -- an upstream whose body does not
decode into a usable packument ('logDecodeFailure'), one whose packument self-reports a
name for a /different/ package ('logNameMismatch'), a mount whose configured base URL
cannot be formed into a request ('logUpstreamUnformable'), and an upstream the transport
could not reach ('logUpstreamUnreachable') -- each surfaced at a 'WarningS' through the
ambient @katip@ context before the contribution degrades. The conditions themselves are
classified on the serve path as a typed
'Ecluse.Core.Registry.Metadata.MetadataError'; this module only renders their warning
lines. Alongside them sit the pure integrity-floor admission and the metric-label
projections the serve path records.
-}
module Ecluse.Core.Server.Pipeline.Internal (
    logDecodeFailure,
    logNameMismatch,
    logUpstreamUnformable,
    logUpstreamUnreachable,

    -- * Integrity-floor admission (pure)
    admitByIntegrity,

    -- * Metric-label projections (pure)
    packumentServeDecision,
    serveDecisionClass,
    denialLabels,
    evalTier,
    transienceCause,

    -- * Metric emits (off a serve outcome)
    recordDenials,
    recordEffectfulFailures,

    -- * Denial audit trail (structured log)
    VersionVerdict (..),
    Metadata (..),
    DenialAudit (..),
    denialAuditPayload,
    logDenials,
) where

import Data.Map.Strict qualified as Map
import Data.Set qualified as Set
import Data.Text qualified as T
import Katip (KatipContext, Severity (WarningS), SimpleLogPayload, katipAddContext, logFM, ls, sl)

import Ecluse.Core.Cve (DbEtag (..))
import Ecluse.Core.Fault (TransportFault (tfCause, tfDetail))
import Ecluse.Core.Package (
    PackageDetails (pkgArtifacts),
    PackageInfo (infoDistTags, infoVersions),
    PackageName,
    renderPackageName,
 )
import Ecluse.Core.Package.Integrity (
    IntegrityFloor,
    VersionIntegrity (BelowFloor, MeetsFloor, NoIntegrity),
    classifyArtifacts,
 )
import Ecluse.Core.Registry (UrlFormationError)
import Ecluse.Core.Rules (PreparedRule (prepResilience), cveIdsInReason)
import Ecluse.Core.Rules.Types (Decision (Undecidable))
import Ecluse.Core.Server.Response (
    PackumentStatus (PackumentForbidden, PackumentOk),
    RejectReason (BelowIntegrityFloor, ByPolicy, MissingIntegrity, Unavailable, UpstreamInvalid),
    Rejection (Rejection),
    RuleName (RuleName),
    ServeDecision (Admit, Reject),
    Transience (WillResolve, WontResolve),
    packumentStatus,
 )
import Ecluse.Core.Telemetry.Metrics qualified as Metric
import Ecluse.Core.Telemetry.Record (MetricsPort, mpRuleDenial, mpRuleEffectfulFailure)
import Ecluse.Core.Version (renderVersion)

-- The @module@ tag this module's warnings carry. It is the operator-facing log
-- filter key, not the source module path, so it is held stable across the move into
-- ecluse-core: an operator's saved filter on this value keeps matching, and the only
-- change to these lines is the trace-correlation @dd@ object the ambient context adds.
pipelineInternalModule :: Text
pipelineInternalModule :: Text
pipelineInternalModule = Text
"Ecluse.Server.Pipeline.Internal"

{- | Log a parse failure at 'WarningS' -- the one bad-upstream condition the
response-bound guards leave silent: the upstream answered, but its body did not decode
into the typed view and raw document the serve path needs. Same fail-closed degrade and
the same @module@\/@package@ payload convention as the breach log in
"Ecluse.Core.Server.Pipeline", so an operator sees an undecodable upstream distinctly
rather than as silence. Emitted through the ambient @katip@ context (the request's, so
the line carries its trace-correlation @dd@).
-}
logDecodeFailure :: (KatipContext m) => PackageName -> m ()
logDecodeFailure :: forall (m :: * -> *). KatipContext m => PackageName -> m ()
logDecodeFailure PackageName
name =
    SimpleLogPayload -> m () -> m ()
forall i (m :: * -> *) a.
(LogItem i, KatipContext m) =>
i -> m a -> m a
katipAddContext SimpleLogPayload
payload (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Severity -> LogStr -> m ()
forall (m :: * -> *).
(Applicative m, KatipContext m) =>
Severity -> LogStr -> m ()
logFM Severity
WarningS (Text -> LogStr
forall a. StringConv a Text => a -> LogStr
ls Text
message)
  where
    payload :: SimpleLogPayload
payload = Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"module" Text
pipelineInternalModule SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"package" (PackageName -> Text
renderPackageName PackageName
name)
    message :: Text
    message :: Text
message = Text
"refused an upstream metadata document: it did not decode into a usable packument"

{- | Log an upstream name mismatch at 'WarningS' before the contribution degrades: the
origin answered, but its packument self-reported a name for a different package than
the one requested, so it is dropped as untrusted for this request. The structured
payload carries both names and the origin (its base URL) -- the high-cardinality
identifiers that belong on the log line -- so an operator can tell a misconfigured or
hostile upstream from an ordinary outage. Same fail-closed degrade and payload
convention as 'logDecodeFailure'.
-}
logNameMismatch :: (KatipContext m) => PackageName -> Text -> Text -> m ()
logNameMismatch :: forall (m :: * -> *).
KatipContext m =>
PackageName -> Text -> Text -> m ()
logNameMismatch PackageName
requested Text
origin Text
reported =
    SimpleLogPayload -> m () -> m ()
forall i (m :: * -> *) a.
(LogItem i, KatipContext m) =>
i -> m a -> m a
katipAddContext SimpleLogPayload
payload (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Severity -> LogStr -> m ()
forall (m :: * -> *).
(Applicative m, KatipContext m) =>
Severity -> LogStr -> m ()
logFM Severity
WarningS (Text -> LogStr
forall a. StringConv a Text => a -> LogStr
ls Text
message)
  where
    payload :: SimpleLogPayload
payload =
        Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"module" Text
pipelineInternalModule
            SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"package" (PackageName -> Text
renderPackageName PackageName
requested)
            SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"origin" Text
origin
            SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"upstreamName" Text
reported
    message :: Text
    message :: Text
message = Text
"dropped an upstream contribution: its packument self-reported a name for a different package"

{- | Log an unformable upstream request URL at 'WarningS' before the contribution
degrades: the base URL configured for this origin is empty or could not be parsed into a
request, so no fetch could even be attempted. A __configuration__ fault, surfaced
distinctly from a decode failure or a transient outage (it carries its own
'Ecluse.Core.Registry.Metadata.MetadataUrlUnformable') so an operator sees a misconfigured
mount rather than an upstream that merely appears unreachable. The structured payload
carries the origin and the rendered URL fault; same fail-closed degrade and payload
convention as 'logNameMismatch'.
-}
logUpstreamUnformable :: (KatipContext m) => PackageName -> Text -> UrlFormationError -> m ()
logUpstreamUnformable :: forall (m :: * -> *).
KatipContext m =>
PackageName -> Text -> UrlFormationError -> m ()
logUpstreamUnformable PackageName
name Text
origin UrlFormationError
urlErr =
    SimpleLogPayload -> m () -> m ()
forall i (m :: * -> *) a.
(LogItem i, KatipContext m) =>
i -> m a -> m a
katipAddContext SimpleLogPayload
payload (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Severity -> LogStr -> m ()
forall (m :: * -> *).
(Applicative m, KatipContext m) =>
Severity -> LogStr -> m ()
logFM Severity
WarningS (Text -> LogStr
forall a. StringConv a Text => a -> LogStr
ls Text
message)
  where
    payload :: SimpleLogPayload
payload =
        Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"module" Text
pipelineInternalModule
            SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"package" (PackageName -> Text
renderPackageName PackageName
name)
            SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"origin" Text
origin
            SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"urlError" (UrlFormationError -> Text
forall b a. (Show a, IsString b) => a -> b
show UrlFormationError
urlErr :: Text)
    message :: Text
    message :: Text
message = Text
"refused an upstream metadata fetch: the configured base URL could not be formed into a request"

{- | Log an unreachable upstream at 'WarningS' before the contribution degrades: the
transport failed before a usable body returned (a timeout, a refused connection, a TLS
refusal), so the origin contributes nothing this request. The structured payload
carries the origin, the bounded 'Ecluse.Core.Fault.TransportCause', and the rendered
detail, so an operator can tell an outage apart from a decode failure or a
misconfigured mount; same fail-closed degrade and payload convention as
'logUpstreamUnformable'.
-}
logUpstreamUnreachable :: (KatipContext m) => PackageName -> Text -> TransportFault -> m ()
logUpstreamUnreachable :: forall (m :: * -> *).
KatipContext m =>
PackageName -> Text -> TransportFault -> m ()
logUpstreamUnreachable PackageName
name Text
origin TransportFault
fault =
    SimpleLogPayload -> m () -> m ()
forall i (m :: * -> *) a.
(LogItem i, KatipContext m) =>
i -> m a -> m a
katipAddContext SimpleLogPayload
payload (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Severity -> LogStr -> m ()
forall (m :: * -> *).
(Applicative m, KatipContext m) =>
Severity -> LogStr -> m ()
logFM Severity
WarningS (Text -> LogStr
forall a. StringConv a Text => a -> LogStr
ls Text
message)
  where
    payload :: SimpleLogPayload
payload =
        Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"module" Text
pipelineInternalModule
            SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"package" (PackageName -> Text
renderPackageName PackageName
name)
            SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"origin" Text
origin
            SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"transportCause" (TransportCause -> Text
forall b a. (Show a, IsString b) => a -> b
show (TransportFault -> TransportCause
tfCause TransportFault
fault) :: Text)
            SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"transportDetail" (TransportFault -> Text
tfDetail TransportFault
fault)
    message :: Text
    message :: Text
message = Text
"an upstream metadata fetch could not reach the origin; its contribution degrades this request"

{- | Apply an integrity-floor admission policy to a 'PackageInfo', keeping only the versions
whose strongest digest meets the floor and projecting the rest to refusals. A version
whose digests are all weaker than the floor (or absent) cannot be tied to a
floor-strength tamper-evident fingerprint, so it is dropped from the served listing rather
than served a client could never safely verify. Used by both gates: the public gate
(@gatePublic@) with the hard-floored 'Ecluse.Core.Package.Integrity.MinIntegrity', and the
trusted gate (@admitTrusted@) with the loosenable
'Ecluse.Core.Package.Integrity.MinTrustedIntegrity'. Returns the admissible 'PackageInfo'
(with @dist-tags@ pruned to the kept keys, exactly as @restrictToSurvivors@ prunes for the
rules; each kept version carries its own publish time, so restricting the versions carries
the times with it) and the refusals for the dropped versions: 'BelowIntegrityFloor' for a
too-weak digest, 'MissingIntegrity' for none at all, each feeding the no-survivors
status.
-}
admitByIntegrity ::
    (IntegrityFloor floor) =>
    floor ->
    -- The refusal projected for a present-but-too-weak digest ('BelowFloor') …
    ServeDecision ->
    -- … and for a version carrying no digest at all ('NoIntegrity'); the public and
    -- trusted gates pass their own context-worded decisions.
    ServeDecision ->
    PackageInfo ->
    (PackageInfo, [ServeDecision])
admitByIntegrity :: forall floor.
IntegrityFloor floor =>
floor
-> ServeDecision
-> ServeDecision
-> PackageInfo
-> (PackageInfo, [ServeDecision])
admitByIntegrity floor
floorSpec ServeDecision
belowFloorRefusal ServeDecision
missingRefusal PackageInfo
info =
    ( PackageInfo
info
        { infoVersions = Map.restrictKeys (infoVersions info) admissibleKeys
        , infoDistTags = Map.filter ((`Set.member` admissibleKeys) . renderVersion) (infoDistTags info)
        }
    , [ServeDecision]
refusals
    )
  where
    -- Classify each version against the floor exactly once -- the up-to-100k-version map is
    -- walked a single time, and the admissible keys and both refusal buckets are read off
    -- the resulting class map (itself the size of the version map, not small).
    classified :: Map Text VersionIntegrity
    classified :: Map Text VersionIntegrity
classified = (PackageDetails -> VersionIntegrity)
-> Map Text PackageDetails -> Map Text VersionIntegrity
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (floor -> NonEmpty Artifact -> VersionIntegrity
forall floor.
IntegrityFloor floor =>
floor -> NonEmpty Artifact -> VersionIntegrity
classifyArtifacts floor
floorSpec (NonEmpty Artifact -> VersionIntegrity)
-> (PackageDetails -> NonEmpty Artifact)
-> PackageDetails
-> VersionIntegrity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageDetails -> NonEmpty Artifact
pkgArtifacts) (PackageInfo -> Map Text PackageDetails
infoVersions PackageInfo
info)

    admissibleKeys :: Set Text
    admissibleKeys :: Set Text
admissibleKeys = Map Text VersionIntegrity -> Set Text
forall k a. Map k a -> Set k
Map.keysSet ((VersionIntegrity -> Bool)
-> Map Text VersionIntegrity -> Map Text VersionIntegrity
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (VersionIntegrity -> VersionIntegrity -> Bool
forall a. Eq a => a -> a -> Bool
== VersionIntegrity
MeetsFloor) Map Text VersionIntegrity
classified)

    -- The dropped versions projected to refusals in one pass over the class map: 'Map.foldr'
    -- visits ascending-key order and each arm prepends, so the below-floor refusals precede
    -- the missing-integrity refusals, each in key order.
    refusals :: [ServeDecision]
    refusals :: [ServeDecision]
refusals = [ServeDecision]
below [ServeDecision] -> [ServeDecision] -> [ServeDecision]
forall a. Semigroup a => a -> a -> a
<> [ServeDecision]
missing
      where
        ([ServeDecision]
below, [ServeDecision]
missing) = (VersionIntegrity
 -> ([ServeDecision], [ServeDecision])
 -> ([ServeDecision], [ServeDecision]))
-> ([ServeDecision], [ServeDecision])
-> Map Text VersionIntegrity
-> ([ServeDecision], [ServeDecision])
forall a b k. (a -> b -> b) -> b -> Map k a -> b
Map.foldr VersionIntegrity
-> ([ServeDecision], [ServeDecision])
-> ([ServeDecision], [ServeDecision])
bucket ([], []) Map Text VersionIntegrity
classified
        bucket :: VersionIntegrity
-> ([ServeDecision], [ServeDecision])
-> ([ServeDecision], [ServeDecision])
bucket VersionIntegrity
BelowFloor ([ServeDecision]
b, [ServeDecision]
m) = (ServeDecision
belowFloorRefusal ServeDecision -> [ServeDecision] -> [ServeDecision]
forall a. a -> [a] -> [a]
: [ServeDecision]
b, [ServeDecision]
m)
        bucket VersionIntegrity
NoIntegrity ([ServeDecision]
b, [ServeDecision]
m) = ([ServeDecision]
b, ServeDecision
missingRefusal ServeDecision -> [ServeDecision] -> [ServeDecision]
forall a. a -> [a] -> [a]
: [ServeDecision]
m)
        bucket VersionIntegrity
MeetsFloor ([ServeDecision], [ServeDecision])
acc = ([ServeDecision], [ServeDecision])
acc

{- | Classify a no-survivors packument outcome into the bounded @ecluse.serve.decision@
value: a forbidden set is a denial, any other non-served status a transient
unavailability. (A served set is recorded as an admit at the call site, not here.)
-}
packumentServeDecision :: [ServeDecision] -> Metric.Decision
packumentServeDecision :: [ServeDecision] -> Decision
packumentServeDecision [ServeDecision]
decisions = case [ServeDecision] -> PackumentStatus
packumentStatus [ServeDecision]
decisions of
    PackumentStatus
PackumentForbidden -> Decision
Metric.Deny
    PackumentStatus
PackumentOk -> Decision
Metric.Admit
    PackumentStatus
_ -> Decision
Metric.Unavailable

{- | Classify a single artifact-path serve decision into the bounded metric decision: a
policy or integrity refusal is a denial, an upstream outage or invalid response an
unavailability.
-}
serveDecisionClass :: ServeDecision -> Metric.Decision
serveDecisionClass :: ServeDecision -> Decision
serveDecisionClass = \case
    ServeDecision
Admit -> Decision
Metric.Admit
    Reject (Rejection RejectReason
reason Text
_) -> case RejectReason
reason of
        ByPolicy{} -> Decision
Metric.Deny
        RejectReason
MissingIntegrity -> Decision
Metric.Deny
        RejectReason
BelowIntegrityFloor -> Decision
Metric.Deny
        Unavailable{} -> Decision
Metric.Unavailable
        RejectReason
UpstreamInvalid -> Decision
Metric.Unavailable

{- | Map a reject reason to the @ecluse.rule.denials@ labels: the deciding rule (only a
policy denial names one) and the bounded reason class.
-}
denialLabels :: RejectReason -> (Maybe Text, Metric.ReasonClass)
denialLabels :: RejectReason -> (Maybe Text, ReasonClass)
denialLabels = \case
    ByPolicy (RuleName Text
name) -> (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
name, ReasonClass
Metric.ReasonPolicy)
    RejectReason
MissingIntegrity -> (Maybe Text
forall a. Maybe a
Nothing, ReasonClass
Metric.ReasonMissingIntegrity)
    RejectReason
BelowIntegrityFloor -> (Maybe Text
forall a. Maybe a
Nothing, ReasonClass
Metric.ReasonMissingIntegrity)
    Unavailable Transience
_ -> (Maybe Text
forall a. Maybe a
Nothing, ReasonClass
Metric.ReasonUnavailable)
    RejectReason
UpstreamInvalid -> (Maybe Text
forall a. Maybe a
Nothing, ReasonClass
Metric.ReasonUnavailable)

{- | The rule-evaluation tier a duration is attributed to, from the mount's rule set:
a mount with any __resilient__ (effectful) rule is attributed to the effectful tier;
a purely-pure rule set reduces to the structural tier. The resilience policy a prepared
rule carries -- not a separate list -- is what distinguishes an effectful rule now that
the two tiers are one engine.
-}
evalTier :: [PreparedRule] -> Metric.Tier
evalTier :: [PreparedRule] -> Tier
evalTier [PreparedRule]
rules = if (PreparedRule -> Bool) -> [PreparedRule] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Maybe Resilience -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Resilience -> Bool)
-> (PreparedRule -> Maybe Resilience) -> PreparedRule -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PreparedRule -> Maybe Resilience
prepResilience) [PreparedRule]
rules then Tier
Metric.Effectful else Tier
Metric.Structural

{- | Map an undecidable verdict's transience to the bounded
@ecluse.rule.effectful.failures@ cause: a retryable cause is a connection-class fault (the
source was unreachable now), a permanent one the catch-all other.
-}
transienceCause :: Transience -> Metric.Cause
transienceCause :: Transience -> Cause
transienceCause = \case
    WillResolve Maybe RetryAfter
_ -> Cause
Metric.Connection
    Transience
WontResolve -> Cause
Metric.OtherCause

{- | Record the @ecluse.rule.denials@ counter for each rejected decision, labelled by
the bounded reason class and -- for a policy denial -- the deciding rule name
('denialLabels'). An admit records nothing.
-}
recordDenials :: MetricsPort -> [ServeDecision] -> IO ()
recordDenials :: MetricsPort -> [ServeDecision] -> IO ()
recordDenials MetricsPort
metrics = (ServeDecision -> IO ()) -> [ServeDecision] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ServeDecision -> IO ()
recordOne
  where
    recordOne :: ServeDecision -> IO ()
    recordOne :: ServeDecision -> IO ()
recordOne = \case
        ServeDecision
Admit -> IO ()
forall (f :: * -> *). Applicative f => f ()
pass
        Reject (Rejection RejectReason
reason Text
_) ->
            let (Maybe Text
rule, ReasonClass
reasonClass) = RejectReason -> (Maybe Text, ReasonClass)
denialLabels RejectReason
reason
             in MetricsPort -> Maybe Text -> ReasonClass -> IO ()
mpRuleDenial MetricsPort
metrics Maybe Text
rule ReasonClass
reasonClass

{- | Count each effectful-rule failure among a packument's per-version decisions: an
'Undecidable' is an effectful rule whose source could not be consulted, so it is the
effectful-failure signal, classified to a bounded cause by its transience
('transienceCause'). A decided version (allowed or denied) is not a failure.
-}
recordEffectfulFailures :: MetricsPort -> [Decision] -> IO ()
recordEffectfulFailures :: MetricsPort -> [Decision] -> IO ()
recordEffectfulFailures MetricsPort
metrics = (Decision -> IO ()) -> [Decision] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Decision -> IO ()
recordOne
  where
    recordOne :: Decision -> IO ()
    recordOne :: Decision -> IO ()
recordOne = \case
        Undecidable Transience
transience Text
_ -> MetricsPort -> Cause -> IO ()
mpRuleEffectfulFailure MetricsPort
metrics (Transience -> Cause
transienceCause Transience
transience)
        Decision
_ -> IO ()
forall (f :: * -> *). Applicative f => f ()
pass

{- | A per-version serve outcome that keeps the version (the decision's subject),
so a denial's audit line can name it. 'Ecluse.Core.Server.Pipeline.Packument.gatePublic'
preserves it rather than dropping the version when it projects to 'ServeDecision'.
-}
data VersionVerdict = VersionVerdict
    { VersionVerdict -> Text
vvVersion :: Text
    , VersionVerdict -> ServeDecision
vvDecision :: ServeDecision
    }
    deriving stock (VersionVerdict -> VersionVerdict -> Bool
(VersionVerdict -> VersionVerdict -> Bool)
-> (VersionVerdict -> VersionVerdict -> Bool) -> Eq VersionVerdict
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: VersionVerdict -> VersionVerdict -> Bool
== :: VersionVerdict -> VersionVerdict -> Bool
$c/= :: VersionVerdict -> VersionVerdict -> Bool
/= :: VersionVerdict -> VersionVerdict -> Bool
Eq, Int -> VersionVerdict -> ShowS
[VersionVerdict] -> ShowS
VersionVerdict -> String
(Int -> VersionVerdict -> ShowS)
-> (VersionVerdict -> String)
-> ([VersionVerdict] -> ShowS)
-> Show VersionVerdict
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> VersionVerdict -> ShowS
showsPrec :: Int -> VersionVerdict -> ShowS
$cshow :: VersionVerdict -> String
show :: VersionVerdict -> String
$cshowList :: [VersionVerdict] -> ShowS
showList :: [VersionVerdict] -> ShowS
Show)

{- | An extensible bag of audit fields folded into a denial line's JSON at emit
time. It lives here, at the audit boundary, deliberately __not__ on the pure
'Ecluse.Core.Rules.Types.Decision': the rule engine carries no logging concern,
and new audit data (a CVE id, an EPSS score) is added at this layer without
threading a field through the decision path.
-}
newtype Metadata = Metadata (Map Text Text)
    deriving stock (Metadata -> Metadata -> Bool
(Metadata -> Metadata -> Bool)
-> (Metadata -> Metadata -> Bool) -> Eq Metadata
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Metadata -> Metadata -> Bool
== :: Metadata -> Metadata -> Bool
$c/= :: Metadata -> Metadata -> Bool
/= :: Metadata -> Metadata -> Bool
Eq, Int -> Metadata -> ShowS
[Metadata] -> ShowS
Metadata -> String
(Int -> Metadata -> ShowS)
-> (Metadata -> String) -> ([Metadata] -> ShowS) -> Show Metadata
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Metadata -> ShowS
showsPrec :: Int -> Metadata -> ShowS
$cshow :: Metadata -> String
show :: Metadata -> String
$cshowList :: [Metadata] -> ShowS
showList :: [Metadata] -> ShowS
Show)

instance Semigroup Metadata where
    Metadata Map Text Text
a <> :: Metadata -> Metadata -> Metadata
<> Metadata Map Text Text
b = Map Text Text -> Metadata
Metadata (Map Text Text
a Map Text Text -> Map Text Text -> Map Text Text
forall a. Semigroup a => a -> a -> a
<> Map Text Text
b)

instance Monoid Metadata where
    mempty :: Metadata
mempty = Map Text Text -> Metadata
Metadata Map Text Text
forall k a. Map k a
Map.empty

{- | Everything one denial audit line records: typed and stable. The advisory
'DbEtag' is the database active when the request was admitted (carried on the
'Ecluse.Core.Rules.Types.EvalContext'); it is named as active at emit, never
claimed as the database the decision was evaluated against, since a shadow-swap
may land mid-request.
-}
data DenialAudit = DenialAudit
    { DenialAudit -> PackageName
daPackage :: PackageName
    , DenialAudit -> Text
daVersion :: Text
    , DenialAudit -> Maybe Text
daRule :: Maybe Text
    , DenialAudit -> ReasonClass
daReasonClass :: Metric.ReasonClass
    , DenialAudit -> Maybe DbEtag
daAdvisoryEtag :: Maybe DbEtag
    , DenialAudit -> Metadata
daExtra :: Metadata
    }

-- | Render a 'DenialAudit' to the structured payload katip folds into the line's @data@ object.
denialAuditPayload :: DenialAudit -> SimpleLogPayload
denialAuditPayload :: DenialAudit -> SimpleLogPayload
denialAuditPayload DenialAudit
da =
    Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"module" Text
pipelineInternalModule
        SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"package" (PackageName -> Text
renderPackageName (DenialAudit -> PackageName
daPackage DenialAudit
da))
        SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"version" (DenialAudit -> Text
daVersion DenialAudit
da)
        SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> SimpleLogPayload
-> (Text -> SimpleLogPayload) -> Maybe Text -> SimpleLogPayload
forall b a. b -> (a -> b) -> Maybe a -> b
maybe SimpleLogPayload
forall a. Monoid a => a
mempty (Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"rule") (DenialAudit -> Maybe Text
daRule DenialAudit
da)
        SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"reason_class" (ReasonClass -> Text
forall b a. (Show a, IsString b) => a -> b
show (DenialAudit -> ReasonClass
daReasonClass DenialAudit
da) :: Text)
        SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> SimpleLogPayload
-> (DbEtag -> SimpleLogPayload) -> Maybe DbEtag -> SimpleLogPayload
forall b a. b -> (a -> b) -> Maybe a -> b
maybe SimpleLogPayload
forall a. Monoid a => a
mempty (\(DbEtag Text
e) -> Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"active_advisory_db_etag" Text
e) (DenialAudit -> Maybe DbEtag
daAdvisoryEtag DenialAudit
da)
        SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> Metadata -> SimpleLogPayload
metadataPayload (DenialAudit -> Metadata
daExtra DenialAudit
da)
  where
    metadataPayload :: Metadata -> SimpleLogPayload
metadataPayload (Metadata Map Text Text
m) = (Text -> Text -> SimpleLogPayload -> SimpleLogPayload)
-> SimpleLogPayload -> Map Text Text -> SimpleLogPayload
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey (\Text
k Text
v SimpleLogPayload
acc -> Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
k Text
v SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> SimpleLogPayload
acc) SimpleLogPayload
forall a. Monoid a => a
mempty Map Text Text
m

{- | The advisory ids a denial named, recovered from its rendered message and folded
into the audit line's 'Metadata' as a comma-joined @cve@ field. Empty for a non-CVE
denial, so the field appears only when an advisory drove the refusal. Recovered at this
layer via 'cveIdsInReason' rather than threaded through the pure decision path, per the
'Metadata' contract.
-}
cveMetadata :: Text -> Metadata
cveMetadata :: Text -> Metadata
cveMetadata Text
message = case Text -> [Text]
cveIdsInReason Text
message of
    [] -> Metadata
forall a. Monoid a => a
mempty
    [Text]
ids -> Map Text Text -> Metadata
Metadata (Text -> Text -> Map Text Text
forall k a. k -> a -> Map k a
Map.singleton Text
"cve" (Text -> [Text] -> Text
T.intercalate Text
", " [Text]
ids))

{- | Emit one audit log line per denied version, __denials only__ (an admit logs
nothing). Companion to 'recordDenials', which counts the same denials as metrics.
The 'DbEtag' is the advisory database active at emit (from the request's
'Ecluse.Core.Rules.Types.EvalContext'), so the line answers "which database was
live when this verdict was logged", not "which database produced it".
-}
logDenials :: (KatipContext m) => PackageName -> Maybe DbEtag -> [VersionVerdict] -> m ()
logDenials :: forall (m :: * -> *).
KatipContext m =>
PackageName -> Maybe DbEtag -> [VersionVerdict] -> m ()
logDenials PackageName
pkg Maybe DbEtag
etag = (VersionVerdict -> m ()) -> [VersionVerdict] -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ VersionVerdict -> m ()
forall {f :: * -> *}. KatipContext f => VersionVerdict -> f ()
logOne
  where
    logOne :: VersionVerdict -> f ()
logOne VersionVerdict
vv = case VersionVerdict -> ServeDecision
vvDecision VersionVerdict
vv of
        ServeDecision
Admit -> f ()
forall (f :: * -> *). Applicative f => f ()
pass
        Reject (Rejection RejectReason
reason Text
message) ->
            let (Maybe Text
rule, ReasonClass
reasonClass) = RejectReason -> (Maybe Text, ReasonClass)
denialLabels RejectReason
reason
                audit :: DenialAudit
audit = PackageName
-> Text
-> Maybe Text
-> ReasonClass
-> Maybe DbEtag
-> Metadata
-> DenialAudit
DenialAudit PackageName
pkg (VersionVerdict -> Text
vvVersion VersionVerdict
vv) Maybe Text
rule ReasonClass
reasonClass Maybe DbEtag
etag (Text -> Metadata
cveMetadata Text
message)
             in SimpleLogPayload -> f () -> f ()
forall i (m :: * -> *) a.
(LogItem i, KatipContext m) =>
i -> m a -> m a
katipAddContext (DenialAudit -> SimpleLogPayload
denialAuditPayload DenialAudit
audit) (f () -> f ()) -> f () -> f ()
forall a b. (a -> b) -> a -> b
$
                    Severity -> LogStr -> f ()
forall (m :: * -> *).
(Applicative m, KatipContext m) =>
Severity -> LogStr -> m ()
logFM Severity
WarningS (Text -> LogStr
forall a. StringConv a Text => a -> LogStr
ls (Text
"denied" :: Text))