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

{- | Integrity admission, metric projections, and the denial audit trail that the packument
and tarball handlers share and their specs reach directly. Importing this module opts out of
the stability promise of the public hub, "Ecluse.Core.Server.Pipeline".

The @module@ field on every line emitted here is 'pipelineInternalModule', a fixed operator
filter key rather than the source module path.
-}
module Ecluse.Core.Server.Pipeline.Internal (
    -- * The operator log-filter key
    pipelineInternalModule,

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

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

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

    -- * Denial audit trail (structured log)
    VersionVerdict (..),
    Metadata (..),
    DenialAudit (..),
    denialAuditPayload,
    logDenials,
    logSkippedChecks,
    logSkippedChecksOnce,
) 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.Types (DbEtag (..))
import Ecluse.Core.Package (
    PackageDetails (pkgArtifacts),
    PackageInfo (infoDistTags, infoVersions),
    PackageName,
    renderPackageName,
 )
import Ecluse.Core.Package.Integrity (
    IntegrityFloor,
    VersionIntegrity (BelowFloor, MeetsFloor, NoIntegrity),
    partitionByFloor,
 )
import Ecluse.Core.Rules (PreparedRule, cveIdsInReason, prepResilience)
import Ecluse.Core.Rules.Outage (AdmissionIdentity (AdmissionIdentity))
import Ecluse.Core.Rules.Types (
    Decision (Admitted, Blocked, BlockedByDefault, Undecidable),
    SkippedCheck (SkippedUnavailable, Unreached),
 )
import Ecluse.Core.Server.Response (
    PackumentStatus (PackumentBadGateway, PackumentForbidden, PackumentOk, PackumentServerError, PackumentUnavailable),
    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@ field every line in this family carries. It is held stable as this value
rather than the source module path, so an operator's saved filter keeps matching.
-}
pipelineInternalModule :: Text
pipelineInternalModule :: Text
pipelineInternalModule = Text
"Ecluse.Server.Pipeline.Internal"

{- | Keep each version's artifacts whose strongest digest meets the integrity floor, per artifact,
so a version drops only when no file of it survives and the listing matches the download gate.
-}
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 = admissible
        , infoDistTags = Map.filter ((`Map.member` admissible) . renderVersion) (infoDistTags info)
        }
    , [ServeDecision]
refusals
    )
  where
    -- One walk of an up-to-100k-version map yields the surviving versions and both refusal
    -- buckets. The partitioned map is that large too.
    partitioned :: Map Text (Either VersionIntegrity PackageDetails)
    partitioned :: Map Text (Either VersionIntegrity PackageDetails)
partitioned = (PackageDetails -> Either VersionIntegrity PackageDetails)
-> Map Text PackageDetails
-> Map Text (Either VersionIntegrity PackageDetails)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map PackageDetails -> Either VersionIntegrity PackageDetails
admitArtifacts (PackageInfo -> Map Text PackageDetails
infoVersions PackageInfo
info)

    admitArtifacts :: PackageDetails -> Either VersionIntegrity PackageDetails
admitArtifacts PackageDetails
details =
        (\NonEmpty Artifact
survivors -> PackageDetails
details{pkgArtifacts = survivors}) (NonEmpty Artifact -> PackageDetails)
-> Either VersionIntegrity (NonEmpty Artifact)
-> Either VersionIntegrity PackageDetails
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> floor
-> NonEmpty Artifact -> Either VersionIntegrity (NonEmpty Artifact)
forall floor.
IntegrityFloor floor =>
floor
-> NonEmpty Artifact -> Either VersionIntegrity (NonEmpty Artifact)
partitionByFloor floor
floorSpec (PackageDetails -> NonEmpty Artifact
pkgArtifacts PackageDetails
details)

    admissible :: Map Text PackageDetails
    admissible :: Map Text PackageDetails
admissible = (Either VersionIntegrity PackageDetails -> Maybe PackageDetails)
-> Map Text (Either VersionIntegrity PackageDetails)
-> Map Text PackageDetails
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe Either VersionIntegrity PackageDetails -> Maybe PackageDetails
forall l r. Either l r -> Maybe r
rightToMaybe Map Text (Either VersionIntegrity PackageDetails)
partitioned

    -- 'Map.foldr' visits keys in ascending order and each arm prepends, so the below-floor
    -- refusals precede the missing-integrity ones, 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) = (Either VersionIntegrity PackageDetails
 -> ([ServeDecision], [ServeDecision])
 -> ([ServeDecision], [ServeDecision]))
-> ([ServeDecision], [ServeDecision])
-> Map Text (Either VersionIntegrity PackageDetails)
-> ([ServeDecision], [ServeDecision])
forall a b k. (a -> b -> b) -> b -> Map k a -> b
Map.foldr Either VersionIntegrity PackageDetails
-> ([ServeDecision], [ServeDecision])
-> ([ServeDecision], [ServeDecision])
forall {b}.
Either VersionIntegrity b
-> ([ServeDecision], [ServeDecision])
-> ([ServeDecision], [ServeDecision])
bucket ([], []) Map Text (Either VersionIntegrity PackageDetails)
partitioned
        bucket :: Either VersionIntegrity b
-> ([ServeDecision], [ServeDecision])
-> ([ServeDecision], [ServeDecision])
bucket (Left VersionIntegrity
BelowFloor) ([ServeDecision]
b, [ServeDecision]
m) = (ServeDecision
belowFloorRefusal ServeDecision -> [ServeDecision] -> [ServeDecision]
forall a. a -> [a] -> [a]
: [ServeDecision]
b, [ServeDecision]
m)
        bucket (Left VersionIntegrity
NoIntegrity) ([ServeDecision]
b, [ServeDecision]
m) = ([ServeDecision]
b, ServeDecision
missingRefusal ServeDecision -> [ServeDecision] -> [ServeDecision]
forall a. a -> [a] -> [a]
: [ServeDecision]
m)
        -- 'partitionByFloor' never reports 'MeetsFloor' as a refusal, and a 'Right' is a survivor.
        bucket (Left VersionIntegrity
MeetsFloor) ([ServeDecision], [ServeDecision])
acc = ([ServeDecision], [ServeDecision])
acc
        bucket (Right b
_) ([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.
-}
packumentServeDecision :: [ServeDecision] -> Metric.Decision
packumentServeDecision :: [ServeDecision] -> Decision
packumentServeDecision = PackumentStatus -> Decision
statusServeDecision (PackumentStatus -> Decision)
-> ([ServeDecision] -> PackumentStatus)
-> [ServeDecision]
-> Decision
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ServeDecision] -> PackumentStatus
packumentStatus

{- | 'packumentServeDecision' over an already-folded status, so the no-survivors path pays for
one traversal of the decision list rather than two.
-}
statusServeDecision :: PackumentStatus -> Metric.Decision
statusServeDecision :: PackumentStatus -> Decision
statusServeDecision = \case
    PackumentStatus
PackumentOk -> Decision
Metric.Admit
    PackumentStatus
PackumentForbidden -> Decision
Metric.Deny
    PackumentUnavailable Maybe RetryAfter
_ -> Decision
Metric.Unavailable
    PackumentStatus
PackumentBadGateway -> Decision
Metric.Unavailable
    PackumentStatus
PackumentServerError -> Decision
Metric.Unavailable

-- | Classify a single artifact-path serve decision into the bounded metric decision.
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: effectful when any prepared rule reads
through a resilience policy.
-}
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.
-}
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.
-}
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 'Undecidable' among a packument's per-version decisions, the signal that an
effectful rule could not consult its source.
-}
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)
        Admitted{} -> IO ()
forall (f :: * -> *). Applicative f => f ()
pass
        Blocked{} -> IO ()
forall (f :: * -> *). Applicative f => f ()
pass
        BlockedByDefault{} -> IO ()
forall (f :: * -> *). Applicative f => f ()
pass

{- | A per-version serve outcome that keeps the version alongside its decision, so a denial's
audit line can name the version it refused.
-}
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 at
the audit boundary, never on the pure 'Ecluse.Core.Rules.Types.Decision'.
-}
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. The advisory 'DbEtag' is the one active at emit,
which a shadow swap during the request can make differ from the one the decision read.
-}
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 =
    PackageName -> Text -> Maybe DbEtag -> SimpleLogPayload
versionAuditPayload (DenialAudit -> PackageName
daPackage DenialAudit
da) (DenialAudit -> Text
daVersion DenialAudit
da) (DenialAudit -> Maybe DbEtag
daAdvisoryEtag 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
<> 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 fields every per-version audit line carries, so the denial and the skipped-check lines
-- are queried by the same names.
versionAuditPayload :: PackageName -> Text -> Maybe DbEtag -> SimpleLogPayload
versionAuditPayload :: PackageName -> Text -> Maybe DbEtag -> SimpleLogPayload
versionAuditPayload PackageName
pkg Text
version Maybe DbEtag
etag =
    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
pkg)
        SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"version" Text
version
        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) Maybe DbEtag
etag

{- | The advisory ids a denial named, recovered from its rendered message into a comma-joined
@cve@ field. A non-CVE denial yields none, so the line carries no field.
-}
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__. 'recordDenials' counts the
same denials as metrics.
-}
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))

{- | 'logSkippedChecks' once per admission identity (package, version, skipped rule set) for the
life of the advisory source's outage, so a public serve that admits again repeats no line.
-}
logSkippedChecksOnce :: (KatipContext m) => (AdmissionIdentity -> IO Bool) -> PackageName -> Text -> Maybe DbEtag -> [SkippedCheck] -> m ()
logSkippedChecksOnce :: forall (m :: * -> *).
KatipContext m =>
(AdmissionIdentity -> IO Bool)
-> PackageName -> Text -> Maybe DbEtag -> [SkippedCheck] -> m ()
logSkippedChecksOnce AdmissionIdentity -> IO Bool
note PackageName
pkg Text
version Maybe DbEtag
etag [SkippedCheck]
skipped =
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Set Text -> Bool
forall a. Set a -> Bool
Set.null Set Text
rules) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        logIt <- IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (AdmissionIdentity -> IO Bool
note (Text -> Text -> Set Text -> AdmissionIdentity
AdmissionIdentity (PackageName -> Text
renderPackageName PackageName
pkg) Text
version Set Text
rules))
        when logIt (logSkippedChecks pkg version etag skipped)
  where
    rules :: Set Text
rules = [Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList [Text
rule | SkippedUnavailable Text
rule Text
_ <- [SkippedCheck]
skipped]

{- | Emit one audit line per check the admission skipped for unavailability. An unreached check
gets no line, and a trusted serve runs no rules, so it never reaches here.
-}
logSkippedChecks :: (KatipContext m) => PackageName -> Text -> Maybe DbEtag -> [SkippedCheck] -> m ()
logSkippedChecks :: forall (m :: * -> *).
KatipContext m =>
PackageName -> Text -> Maybe DbEtag -> [SkippedCheck] -> m ()
logSkippedChecks PackageName
pkg Text
version Maybe DbEtag
etag = (SkippedCheck -> m ()) -> [SkippedCheck] -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ SkippedCheck -> m ()
logOne
  where
    logOne :: SkippedCheck -> m ()
logOne = \case
        Unreached Text
_ -> m ()
forall (f :: * -> *). Applicative f => f ()
pass
        SkippedUnavailable Text
rule Text
cause ->
            SimpleLogPayload -> m () -> m ()
forall i (m :: * -> *) a.
(LogItem i, KatipContext m) =>
i -> m a -> m a
katipAddContext (PackageName -> Text -> Maybe DbEtag -> SimpleLogPayload
versionAuditPayload PackageName
pkg Text
version Maybe DbEtag
etag SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"rule" Text
rule SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"cause" Text
cause) (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
"admitted with a check skipped for unavailability" :: Text))