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

{- | The policy rules engine.

A rule set is evaluated against a single 'PackageDetails' snapshot to produce a
'Decision'. The model is __deny by default; the boot order decides__: the configured
rules are arranged once, at boot, into a single total order ('bootOrder') -- highest
precedence first, then rule name ascending -- and evaluation walks that order and
takes the __first decisive result__. A result is decisive iff the rule returned a
decisive verdict ('Allow', 'Deny', or a fail-closed 'CannotVet'), or the harness
resolved a faulted evaluation fail-closed (@'Unavailable' _ 'FailDeny' _@); a
non-decisive verdict ('NoDecision', a fail-open 'CannotVet') or a fail-open fault
(@'Unavailable' _ 'FailNoDecision' _@) is a non-decisive no-op whose reason is
collected, in boot order, for the deny-by-default audit trail. If no rule is decisive
the package is 'BlockedByDefault'.

__A rule is evaluation-agnostic data; how it is evaluated is a separate concern.__ The
closed built-in vocabulary ('Ecluse.Core.Rules.Types.Rule') says /what/ a rule is;
'evalRule' is the single dispatch that says /how/ each built-in rule decides, closing
over the boot-bound capabilities in 'RuleDeps'. The engine's runtime structure is the
'PreparedRule': it pairs a rule's boot-order identity (precedence and name) with the
raw per-version evaluator and an optional 'Resilience' policy. 'prepare' builds one
per configured rule; the pure built-ins carry no 'Resilience' and run directly, while
the effectful CVE rules carry a 'Resilience' (a per-attempt timeout, bounded retry
with backoff, and a per-source 'Ecluse.Core.Breaker.Breaker') applied by the harness
'runEffectfulRule'. The order /is/ the tiebreak: there is no runtime
comparison of results.

The evaluator on a 'PreparedRule' is __not__ reachable from config: 'prepare' only
ever binds 'evalRule' over closed 'Rule' data, so untrusted config can express only
the built-in vocabulary. Supplying an arbitrary evaluator is a code-layer capability
(the engine's own tests today; a rule DSL or plugin later), never a config surface.

'evalRules' may evaluate effectful rules speculatively in parallel, but the result is
always __as-if sequential by boot order__: the winner is the earliest-in-order
decisive rule, never the first to return in wall-clock time, and once the winner is
known every still-running strictly-later evaluation is cancelled. The cheap pure
prefix is evaluated directly, so no IO an earlier decisive result would moot is ever
launched. Evaluation is 'IO'-typed (a rule's evaluator may do IO), so there is no pure
entry point. The rule data types live in "Ecluse.Core.Rules.Types"; the resilience
harness lives in "Ecluse.Core.Rules.Effectful".
-}
module Ecluse.Core.Rules (
    -- * The boot-bound rule capabilities
    RuleDeps (..),

    -- * The built-in rule dispatch
    evalRule,

    -- * The engine's prepared rule
    PreparedRule (..),
    Resilience (..),
    prepare,

    -- * Boot-time ordering
    bootOrder,
    renderBootOrder,

    -- * Evaluation
    evalRules,
    renderDecision,
    renderDuration,
    cveIdsInReason,

    -- * The resilience harness
    runEffectfulRule,
    EffectfulConfig (..),
    defaultEffectfulConfig,
    backoffPolicy,
    Breaker (..),
    newBreaker,
    BreakerReporter (..),
    noBreakerReporter,
    FaultReporter (..),
) where

import Data.Text qualified as T
import Data.Time (NominalDiffTime, diffUTCTime, getCurrentTime, nominalDiffTimeToSeconds)
import UnliftIO (tryAny)
import UnliftIO.Async (Async, async, cancel, uninterruptibleCancel, wait)
import UnliftIO.Exception (bracket)

import Ecluse.Core.Breaker (
    Breaker (..),
    BreakerReporter (..),
    noBreakerReporter,
 )
import Ecluse.Core.Cve (AdvisoryRange (..), CveLookup (..), DbEtag, insideAffectedRange, severityAtLeast)
import Ecluse.Core.Ecosystem (Ecosystem)
import Ecluse.Core.Package
import Ecluse.Core.Rules.Effectful (
    EffectfulConfig (..),
    FaultReporter (..),
    Resilience (..),
    backoffPolicy,
    defaultEffectfulConfig,
    newBreaker,
    runResilient,
 )
import Ecluse.Core.Rules.Types
import Ecluse.Core.Text (displayExceptionT)
import Ecluse.Core.Version (renderVersion)

{- | The boot-bound capabilities a rule's evaluation may consult, injected once at
the composition root and closed into the prepared rules by 'prepare'. This is the
capability counterpart of 'EvalContext': the context carries per-evaluation ambient
__data__ (the clock instant), while these are process-lifetime __capabilities__.

'rdWithCveLookup' is acquisition-bracketed rather than a bare read so its provider
can pin the advisory database generation for exactly one rule evaluation: the
background sync's atomic shadow-swap closes and prunes a superseded artifact only
once no evaluation still holds it. 'Nothing' means no advisory database is loaded
(none configured, or the first sync has not landed); the CVE rule abstains.
-}
data RuleDeps = RuleDeps
    { RuleDeps -> forall a. (Maybe CveLookup -> IO a) -> IO a
rdWithCveLookup :: forall a. (Maybe CveLookup -> IO a) -> IO a
    -- ^ Bracketed access to the current advisory database view, if one is loaded.
    , RuleDeps -> IO (Maybe DbEtag)
rdCurrentAdvisoryEtag :: IO (Maybe DbEtag)
    {- ^ A non-pinning read of the active advisory database's 'DbEtag' for the
    per-request 'EvalContext'. 'Nothing' when none is loaded. Distinct from
    'rdWithCveLookup': it snapshots identity for the audit trail without holding
    a generation open, so it never delays a shadow-swap.
    -}
    , RuleDeps -> BreakerReporter
rdBreakerReporter :: BreakerReporter
    {- ^ The observer effectful rules report their breaker transitions to
    (@ecluse.rule.breaker.state@); 'noBreakerReporter' when unobserved.
    -}
    , RuleDeps -> FaultReporter
rdFaultReporter :: FaultReporter
    {- ^ The observer effectful rules report an exhausted evaluation's fault detail to
    (the rendered query fault or timeout), for the operator diagnostic log;
    'noFaultReporter' when unobserved. It never reaches the client-facing message.
    -}
    }

{- | Evaluate a single built-in rule against a single package version -- the one place
"how a rule decides" lives. The dispatch over the closed 'Rule' data: the pure
constructors reason over the 'PackageDetails' alone and 'pure' their 'RuleVerdict';
'AllowIfRemediatesCve' and 'DenyIfCve' read the advisory database through the
boot-bound 'RuleDeps' and do IO. A rule returns only a __verdict__ -- it never
manufactures an 'Unavailable'; a genuine lookup fault surfaces as an exception, which
the 'Resilience' harness (attached by 'prepare') catches and resolves.

'IO'-typed so the dispatch is uniform across the pure and effectful arms. The pure
arms are total -- a malformed rule or package yields a verdict, never an exception, so
hostile metadata cannot crash the gate.
-}
evalRule :: RuleDeps -> EvalContext -> Rule -> PackageDetails -> IO RuleVerdict
evalRule :: RuleDeps -> EvalContext -> Rule -> PackageDetails -> IO RuleVerdict
evalRule RuleDeps
_ EvalContext
_ (AllowScope Scope
scope) PackageDetails
pd =
    RuleVerdict -> IO RuleVerdict
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RuleVerdict -> IO RuleVerdict) -> RuleVerdict -> IO RuleVerdict
forall a b. (a -> b) -> a -> b
$ case PackageName -> Maybe Scope
pkgNamespace (PackageDetails -> PackageName
pkgName PackageDetails
pd) of
        Just Scope
s
            | Scope
s Scope -> Scope -> Bool
forall a. Eq a => a -> a -> Bool
== Scope
scope ->
                Text -> RuleVerdict
Allow (Text
"scope " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Scope -> Text
renderScope Scope
scope Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is allow-listed")
        Maybe Scope
_ ->
            Text -> RuleVerdict
NoDecision (Text
"scope is not the allow-listed " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Scope -> Text
renderScope Scope
scope)
evalRule RuleDeps
_ EvalContext
ctx (AllowIfOlderThan NominalDiffTime
minAge) PackageDetails
pd =
    RuleVerdict -> IO RuleVerdict
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RuleVerdict -> IO RuleVerdict) -> RuleVerdict -> IO RuleVerdict
forall a b. (a -> b) -> a -> b
$ case PackageDetails -> Maybe UTCTime
pkgPublishedAt PackageDetails
pd of
        Maybe UTCTime
Nothing -> Text -> RuleVerdict
NoDecision Text
"publish time is unknown"
        Just UTCTime
publishedAt ->
            let age :: NominalDiffTime
age = UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime (EvalContext -> UTCTime
ctxNow EvalContext
ctx) UTCTime
publishedAt
             in if NominalDiffTime
age NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
>= NominalDiffTime
minAge
                    then
                        Text -> RuleVerdict
Allow
                            ( Text
"published "
                                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> NominalDiffTime -> Text
renderDuration NominalDiffTime
age
                                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ago (at least "
                                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> NominalDiffTime -> Text
renderDuration NominalDiffTime
minAge
                                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" old)"
                            )
                    else
                        Text -> RuleVerdict
NoDecision
                            ( Text
"published only "
                                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> NominalDiffTime -> Text
renderDuration NominalDiffTime
age
                                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ago, minimum age is "
                                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> NominalDiffTime -> Text
renderDuration NominalDiffTime
minAge
                            )
evalRule RuleDeps
_ EvalContext
_ Rule
DenyInstallTimeExecution PackageDetails
pd =
    RuleVerdict -> IO RuleVerdict
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RuleVerdict -> IO RuleVerdict) -> RuleVerdict -> IO RuleVerdict
forall a b. (a -> b) -> a -> b
$ case PackageDetails -> CodeExecSignal
pkgInstallCode PackageDetails
pd of
        RunsCodeOnInstall Text
how -> Text -> RuleVerdict
Deny (Text
"runs code on install: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
how)
        CodeExecSignal
NoCodeOnInstall -> Text -> RuleVerdict
NoDecision Text
"no install-time code execution"
        CodeExecSignal
CodeExecUnknown -> Text -> RuleVerdict
NoDecision Text
"install-time code execution not yet determined"
evalRule RuleDeps
_ EvalContext
_ (DenyByIdentity Text
ident) PackageDetails
pd =
    RuleVerdict -> IO RuleVerdict
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RuleVerdict -> IO RuleVerdict) -> RuleVerdict -> IO RuleVerdict
forall a b. (a -> b) -> a -> b
$
        if Text -> PackageDetails -> Bool
matchesIdentity Text
ident PackageDetails
pd
            then Text -> RuleVerdict
Deny (Text
"identity " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ident Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is revoked by operator")
            else Text -> RuleVerdict
NoDecision (Text
"identity is not the revoked " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ident)
evalRule RuleDeps
_ EvalContext
_ (AllowByIdentity Text
ident) PackageDetails
pd =
    RuleVerdict -> IO RuleVerdict
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RuleVerdict -> IO RuleVerdict) -> RuleVerdict -> IO RuleVerdict
forall a b. (a -> b) -> a -> b
$
        if Text -> PackageDetails -> Bool
matchesIdentity Text
ident PackageDetails
pd
            then Text -> RuleVerdict
Allow (Text
"identity " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ident Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is allow-listed by operator")
            else Text -> RuleVerdict
NoDecision (Text
"identity is not the allow-listed " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ident)
evalRule RuleDeps
deps EvalContext
_ Rule
AllowIfRemediatesCve PackageDetails
pd =
    RuleDeps -> forall a. (Maybe CveLookup -> IO a) -> IO a
rdWithCveLookup RuleDeps
deps ((Maybe CveLookup -> IO RuleVerdict) -> IO RuleVerdict)
-> (Maybe CveLookup -> IO RuleVerdict) -> IO RuleVerdict
forall a b. (a -> b) -> a -> b
$ \case
        Maybe CveLookup
Nothing -> RuleVerdict -> IO RuleVerdict
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> RuleVerdict
NoDecision Text
"no advisory database is loaded")
        Just CveLookup
cve -> CveLookup -> PackageDetails -> IO RuleVerdict
remediationVerdict CveLookup
cve PackageDetails
pd
evalRule RuleDeps
deps EvalContext
_ (DenyIfCve DenyIfCveParams
params) PackageDetails
pd =
    RuleDeps -> forall a. (Maybe CveLookup -> IO a) -> IO a
rdWithCveLookup RuleDeps
deps ((Maybe CveLookup -> IO RuleVerdict) -> IO RuleVerdict)
-> (Maybe CveLookup -> IO RuleVerdict) -> IO RuleVerdict
forall a b. (a -> b) -> a -> b
$ \case
        Maybe CveLookup
Nothing -> RuleVerdict -> IO RuleVerdict
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DenyIfCveParams -> RuleVerdict
noAdvisoryDbVerdict DenyIfCveParams
params)
        Just CveLookup
cve -> DenyIfCveParams -> CveLookup -> PackageDetails -> IO RuleVerdict
denyVerdict DenyIfCveParams
params CveLookup
cve PackageDetails
pd

{- The deny rule's verdict when no advisory database is loaded: pre-first-sync, a sync
yet to land its first artifact, or the rule enabled with no advisory bucket configured
at all. This is a __deterministic, in-process absence__, so it is a 'CannotVet'
verdict, not a fault: the harness takes it at face value and never retries it or trips
the breaker on it (no in-process retry could load a database). The rule's own alignment
decides what the absence means -- a fail-open rule skips ('CannotVet' 'FailNoDecision',
a no-op), a fail-closed rule refuses the version it cannot vet ('CannotVet' 'FailDeny',
decisive → 'Undecidable', a retryable 503, so readiness gating and the operator's
dashboards surface a misconfiguration loudly). -}
noAdvisoryDbVerdict :: DenyIfCveParams -> RuleVerdict
noAdvisoryDbVerdict :: DenyIfCveParams -> RuleVerdict
noAdvisoryDbVerdict DenyIfCveParams
params = FailureAlignment -> Text -> RuleVerdict
CannotVet (DenyIfCveParams -> FailureAlignment
dicOnUnavailable DenyIfCveParams
params) Text
"DenyIfCve: no advisory database loaded"

{- The deny rule's verdict against a loaded advisory database: deny the version if
any advisory that affects it meets the configured severity threshold, naming the
advisories for the audit trail; otherwise abstain. An unscored advisory clears the
threshold (fail-closed, so npm malware -- unscored -- is denied). -}
denyVerdict :: DenyIfCveParams -> CveLookup -> PackageDetails -> IO RuleVerdict
denyVerdict :: DenyIfCveParams -> CveLookup -> PackageDetails -> IO RuleVerdict
denyVerdict DenyIfCveParams
params CveLookup
cve PackageDetails
pd = do
    ranges <- CveLookup -> Text -> IO [AdvisoryRange]
cveAdvisoriesFor CveLookup
cve Text
name
    let blocking =
            [Text] -> [Text]
forall a. Ord a => [a] -> [a]
ordNub
                [ AdvisoryRange -> Text
arCveId AdvisoryRange
ar
                | AdvisoryRange
ar <- [AdvisoryRange]
ranges
                , Ecosystem -> Text -> AdvisoryRange -> Bool
insideAffectedRange Ecosystem
eco Text
version AdvisoryRange
ar
                , Double -> Maybe Double -> Bool
severityAtLeast (DenyIfCveParams -> Double
dicMinSeverity DenyIfCveParams
params) (AdvisoryRange -> Maybe Double
arSeverity AdvisoryRange
ar)
                ]
    pure $ case blocking of
        [] -> Text -> RuleVerdict
NoDecision Text
"no advisory at or above the severity threshold affects this version"
        [Text]
ids -> Text -> RuleVerdict
Deny (Text
"affected by " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " [Text]
ids Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (CVSS >= " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Double -> Text
forall b a. (Show a, IsString b) => a -> b
show (DenyIfCveParams -> Double
dicMinSeverity DenyIfCveParams
params) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
  where
    eco :: Ecosystem
eco = PackageName -> Ecosystem
pkgEcosystem (PackageDetails -> PackageName
pkgName PackageDetails
pd)
    name :: Text
name = PackageName -> Text
renderPackageName (PackageDetails -> PackageName
pkgName PackageDetails
pd)
    version :: Text
version = Version -> Text
renderVersion (PackageDetails -> Version
pkgVersion PackageDetails
pd)

{- | Recover the advisory ids a 'DenyIfCve' denial named, from the rendered decision
message the denial audit line carries. The deny reason 'denyVerdict' builds embeds the
ids between @"affected by "@ and @" (CVSS"@; this reads them back so the audit line can
name the CVE without threading a structured field through the pure decision path (the
"Ecluse.Core.Server.Pipeline.Internal" @Metadata@ contract adds audit data at that
layer). A message carrying no such segment (a non-CVE denial) yields @[]@. Kept beside
'denyVerdict' so the two move together; 'Ecluse.Core.RulesSpec' round-trips one against
the other so a reword of either fails the build.
-}
cveIdsInReason :: Text -> [Text]
cveIdsInReason :: Text -> [Text]
cveIdsInReason Text
message
    | Text -> Bool
T.null Text
afterCvss = []
    | Bool
otherwise = (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
T.null) ((Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
T.strip (HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
", " Text
ids))
  where
    -- 'stripPrefix' drops the marker without an O(n) 'Data.Text.length' on it (STAN-0208);
    -- 'Nothing' (the marker absent) leaves an empty body, so 'afterCvss' is empty and the
    -- guard yields @[]@.
    (Text
_, Text
afterAffected) = HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOn Text
"affected by " Text
message
    body :: Text
body = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" (Text -> Text -> Maybe Text
T.stripPrefix Text
"affected by " Text
afterAffected)
    (Text
ids, Text
afterCvss) = HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOn Text
" (CVSS" Text
body

-- The CVE rule's verdict against a loaded advisory database.
remediationVerdict :: CveLookup -> PackageDetails -> IO RuleVerdict
remediationVerdict :: CveLookup -> PackageDetails -> IO RuleVerdict
remediationVerdict CveLookup
cve PackageDetails
pd = do
    fixes <- CveLookup -> Text -> Text -> IO Bool
cveRemediationProbe CveLookup
cve Text
name Text
version
    if not fixes
        then pure (NoDecision "no advisory names this version as its fix")
        else do
            -- The probe hit, so the version is some advisory's exact fixed
            -- bound; fetch the package's ranges once to name what it fixes
            -- and to guard the lane.
            ranges <- cveAdvisoriesFor cve name
            pure (classifyRanges (pkgEcosystem (pkgName pd)) version ranges)
  where
    name :: Text
name = PackageName -> Text
renderPackageName (PackageDetails -> PackageName
pkgName PackageDetails
pd)
    version :: Text
version = Version -> Text
renderVersion (PackageDetails -> Version
pkgVersion PackageDetails
pd)

-- Classify the fetched ranges: a version still inside *any* advisory's affected
-- range (an unfixed one included) must not fast-track; otherwise credit the
-- advisories that name this version as their exact fixed bound.
classifyRanges :: Ecosystem -> Text -> [AdvisoryRange] -> RuleVerdict
classifyRanges :: Ecosystem -> Text -> [AdvisoryRange] -> RuleVerdict
classifyRanges Ecosystem
eco Text
version [AdvisoryRange]
ranges =
    case ([Text]
remediated, [Text]
stillOpen) of
        ([Text]
_, Text
_ : [Text]
_) ->
            Text -> RuleVerdict
NoDecision
                (Text
"fixes " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " [Text]
remediated Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" but is still affected by " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " [Text]
stillOpen)
        ([], []) ->
            -- Unreachable under one acquisition (the probe and the
            -- fetch see the same artifact), kept total.
            Text -> RuleVerdict
NoDecision Text
"no advisory names this version as its fix"
        ([Text]
ids, []) -> Text -> RuleVerdict
Allow (Text
"remediates " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " [Text]
ids)
  where
    remediated :: [Text]
remediated = [Text] -> [Text]
forall a. Ord a => [a] -> [a]
ordNub [AdvisoryRange -> Text
arCveId AdvisoryRange
ar | AdvisoryRange
ar <- [AdvisoryRange]
ranges, AdvisoryRange -> Maybe Text
arFixed AdvisoryRange
ar Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
version]
    stillOpen :: [Text]
stillOpen = [Text] -> [Text]
forall a. Ord a => [a] -> [a]
ordNub [AdvisoryRange -> Text
arCveId AdvisoryRange
ar | AdvisoryRange
ar <- [AdvisoryRange]
ranges, Ecosystem -> Text -> AdvisoryRange -> Bool
insideAffectedRange Ecosystem
eco Text
version AdvisoryRange
ar]

-- The one identity test the by-identity twins share: the exact rendered package
-- name, or the exact package@version.
matchesIdentity :: Text -> PackageDetails -> Bool
matchesIdentity :: Text -> PackageDetails -> Bool
matchesIdentity Text
ident PackageDetails
pd =
    let pkgStr :: Text
pkgStr = PackageName -> Text
renderPackageName (PackageDetails -> PackageName
pkgName PackageDetails
pd)
        pkgAtVer :: Text
pkgAtVer = Text
pkgStr Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"@" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Version -> Text
renderVersion (PackageDetails -> Version
pkgVersion PackageDetails
pd)
     in Text
ident Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
pkgStr Bool -> Bool -> Bool
|| Text
ident Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
pkgAtVer

{- | A rule prepared for the engine to evaluate: its boot-order identity (precedence
and name), an optional 'Resilience' policy, and the raw per-version evaluator the
engine runs. This is the engine's __one__ runtime structure -- and its only injection
point.

For a configured rule 'prepare' builds it: the name from the rule data ('ruleName'),
the evaluator from 'evalRule', and (today) no 'Resilience'. Because the evaluator is a
plain function field -- not a closed 'Rule' -- it is also where an arbitrary evaluator
can be supplied without widening the closed 'Rule' vocabulary: the engine's own tests
build a 'PreparedRule' directly with a fake evaluator (one that throws, hangs, or
returns a chosen 'RuleVerdict') and a chosen name to exercise the resilience harness
and the parallel walk. That escape hatch is a code-layer capability; config only ever
reaches the closed data path through 'prepare', so it cannot supply one.

It declares no allow\/deny "direction": admit vs block is simply what 'prepEval'
returns. With @'prepResilience' = 'Nothing'@ the rule runs directly; with a
'Resilience' it is wrapped by 'runEffectfulRule'.
-}
data PreparedRule = PreparedRule
    { PreparedRule -> Text
prepName :: Text
    -- ^ The stable, human-facing name; the boot-order tiebreak and the credited identity.
    , PreparedRule -> Int
prepPrecedence :: Int
    -- ^ The precedence at which this rule competes; higher wins in the boot order.
    , PreparedRule -> Maybe Resilience
prepResilience :: Maybe Resilience
    -- ^ The resilience policy, or 'Nothing' for a rule run directly.
    , PreparedRule -> EvalContext -> PackageDetails -> IO RuleVerdict
prepEval :: EvalContext -> PackageDetails -> IO RuleVerdict
    {- ^ The rule's raw verdict for one version. For a resilient rule it may perform IO
    that fails or hangs; 'runEffectfulRule' wraps it.
    -}
    }

{- | Prepare a resolved policy ('PrecededRule's) into the engine's runtime rules: each
rule's name comes from its data ('ruleName'), its evaluator from 'evalRule' closed
over the boot-bound 'RuleDeps', and its 'Resilience' from whether the rule needs one.
The pure built-ins carry no 'Resilience' (@'prepResilience' = 'Nothing'@) and run
directly; 'AllowIfRemediatesCve' is prepared with a __fail-open__ 'Resilience'
('FailNoDecision'), so a lookup that fails or hangs abstains -- the version falls back
to the ordinary quarantine -- and never admits on an unconfirmable claim.

'IO'-typed because preparing a resilient rule allocates its per-source breaker
('newBreaker') -- once, at the composition root, shared across evaluations.
-}
prepare :: RuleDeps -> [PrecededRule] -> IO [PreparedRule]
prepare :: RuleDeps -> [PrecededRule] -> IO [PreparedRule]
prepare RuleDeps
deps = (PrecededRule -> IO PreparedRule)
-> [PrecededRule] -> IO [PreparedRule]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (RuleDeps -> PrecededRule -> IO PreparedRule
prepareRule RuleDeps
deps)

-- Prepare one configured rule: attach the fail-open 'Resilience' (allocating its
-- breaker) to the effectful CVE rule; the pure rules run directly.
prepareRule :: RuleDeps -> PrecededRule -> IO PreparedRule
prepareRule :: RuleDeps -> PrecededRule -> IO PreparedRule
prepareRule RuleDeps
deps (PrecededRule Int
prec Rule
rule) = do
    resilience <- RuleDeps -> Rule -> IO (Maybe Resilience)
resilienceFor RuleDeps
deps Rule
rule
    pure
        PreparedRule
            { prepName = ruleName rule
            , prepPrecedence = prec
            , prepResilience = resilience
            , prepEval = \EvalContext
ctx -> RuleDeps -> EvalContext -> Rule -> PackageDetails -> IO RuleVerdict
evalRule RuleDeps
deps EvalContext
ctx Rule
rule
            }

-- The resilience a rule needs: the effectful CVE rule carries the fail-open
-- policy (allocating its per-source breaker); the pure rules carry none.
resilienceFor :: RuleDeps -> Rule -> IO (Maybe Resilience)
resilienceFor :: RuleDeps -> Rule -> IO (Maybe Resilience)
resilienceFor RuleDeps
deps = \case
    Rule
AllowIfRemediatesCve -> FailureAlignment -> IO (Maybe Resilience)
effectful FailureAlignment
FailNoDecision
    -- The deny rule aligns per its config: fail-closed refuses a version it cannot
    -- vet, fail-open skips itself. The same alignment governs a lookup that throws
    -- or times out (here) and a database that is not loaded ('noAdvisoryDbVerdict').
    DenyIfCve DenyIfCveParams
params -> FailureAlignment -> IO (Maybe Resilience)
effectful (DenyIfCveParams -> FailureAlignment
dicOnUnavailable DenyIfCveParams
params)
    Rule
_ -> Maybe Resilience -> IO (Maybe Resilience)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Resilience
forall a. Maybe a
Nothing
  where
    effectful :: FailureAlignment -> IO (Maybe Resilience)
effectful FailureAlignment
alignment = do
        breaker <- IO (TVar Breaker)
newBreaker
        pure $
            Just
                Resilience
                    { resConfig = defaultEffectfulConfig
                    , resAlignment = alignment
                    , resBreaker = breaker
                    , resBreakerReporter = rdBreakerReporter deps
                    , resFaultReporter = rdFaultReporter deps
                    , resClock = getCurrentTime
                    }

{- | Arrange a rule set into the single total order evaluation walks: __highest
precedence first, then rule name ascending__ as the deterministic tiebreak. A pure
function of the rules' precedences and names, independent of the order they were
configured in -- so shuffling the configured set yields the same order and hence the
same 'Decision'. The order /is/ the tiebreak; there is no runtime comparison of
results.
-}
bootOrder :: [PreparedRule] -> [PreparedRule]
bootOrder :: [PreparedRule] -> [PreparedRule]
bootOrder = (PreparedRule -> (Down Int, Text))
-> [PreparedRule] -> [PreparedRule]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (\PreparedRule
r -> Int -> Text -> (Down Int, Text)
bootKey (PreparedRule -> Int
prepPrecedence PreparedRule
r) (PreparedRule -> Text
prepName PreparedRule
r))

-- The single boot-order comparator key: precedence descending (highest first), then
-- name ascending. Both 'bootOrder' and the engine order through this one key, so the
-- tiebreak is expressed exactly once.
bootKey :: Int -> Text -> (Down Int, Text)
bootKey :: Int -> Text -> (Down Int, Text)
bootKey Int
prec Text
name = (Int -> Down Int
forall a. a -> Down a
Down Int
prec, Text
name)

{- | Render the boot order as one diagnostic line per rule, in evaluation order, so
an operator sees at boot exactly how their policy will resolve. Empty for an empty
rule set.
-}
renderBootOrder :: [PreparedRule] -> [Text]
renderBootOrder :: [PreparedRule] -> [Text]
renderBootOrder [PreparedRule]
rules = (Int -> PreparedRule -> Text) -> [Int] -> [PreparedRule] -> [Text]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> PreparedRule -> Text
forall {a}. Show a => a -> PreparedRule -> Text
line [Int
1 :: Int ..] ([PreparedRule] -> [PreparedRule]
bootOrder [PreparedRule]
rules)
  where
    line :: a -> PreparedRule -> Text
line a
i PreparedRule
r =
        Text
"rule "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall b a. (Show a, IsString b) => a -> b
show a
i
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PreparedRule -> Text
prepName PreparedRule
r
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (precedence "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show (PreparedRule -> Int
prepPrecedence PreparedRule
r)
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"

{- | Evaluate a package version against a rule set in 'IO': walk the boot order and
take the __first decisive result__, else 'BlockedByDefault' with every non-decisive
reason gathered in boot order.

The engine evaluates effectful rules speculatively in parallel but the decision is
always __as-if sequential by boot order__ -- the earliest-in-order decisive rule wins,
never the first to return in wall-clock time. A rule with no 'Resilience' is evaluated
directly; a contiguous run of resilient rules is launched concurrently, then awaited
in boot order, and the moment the earliest decisive one is known every still-running
strictly-later evaluation is cancelled. No IO an earlier decisive result would moot is
ever launched, because a resilient run is started only once every rule before it is
known non-decisive.

__Never throws.__ An effectful rule's faults are absorbed by its resilience
harness ('runEffectfulRule'); a direct rule that throws anyway -- an invariant
break, since a direct rule declares no effects -- is absorbed here as a
fail-closed 'Undecidable' naming the rule. Either way one request's evaluation
resolves to a 'Decision', never a serve-path escape.
-}
evalRules :: EvalContext -> [PreparedRule] -> PackageDetails -> IO Decision
evalRules :: EvalContext -> [PreparedRule] -> PackageDetails -> IO Decision
evalRules EvalContext
ctx [PreparedRule]
rules PackageDetails
pd = [PreparedRule] -> [Text] -> IO Decision
step ([PreparedRule] -> [PreparedRule]
bootOrder [PreparedRule]
rules) []
  where
    -- 'reasons' accumulates non-decisive reasons in reverse boot order; the final
    -- deny-by-default list is reversed back into boot order.
    step :: [PreparedRule] -> [Reason] -> IO Decision
    step :: [PreparedRule] -> [Text] -> IO Decision
step [] [Text]
reasons = Decision -> IO Decision
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Text] -> Decision
BlockedByDefault ([Text] -> [Text]
forall a. [a] -> [a]
reverse [Text]
reasons))
    step (PreparedRule
r : [PreparedRule]
rs) [Text]
reasons
        | Maybe Resilience -> Bool
forall a. Maybe a -> Bool
isNothing (PreparedRule -> Maybe Resilience
prepResilience PreparedRule
r) = do
            -- A direct rule is zero-cost: run it in place. Reaching it means every
            -- earlier rule was non-decisive, so no speculated IO has been mooted.
            evaluated <- IO RuleVerdict -> IO (Either SomeException RuleVerdict)
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny (PreparedRule -> EvalContext -> PackageDetails -> IO RuleVerdict
prepEval PreparedRule
r EvalContext
ctx PackageDetails
pd)
            case evaluated of
                Left SomeException
escape ->
                    -- A direct rule declares no effects, so a throw here is an
                    -- invariant break -- absorbed fail-closed as 'Undecidable'
                    -- (the retryable 503), symmetric with the effectful
                    -- harness's fail-deny 'Unavailable', with the rule named in
                    -- the reason the audit trail carries. Absorbing (rather
                    -- than propagating) keeps the engine's totality claim
                    -- constructive: no rule, however written, can turn one
                    -- request's evaluation into a serve-path escape.
                    Decision -> IO Decision
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Transience -> Text -> Decision
Undecidable (Maybe RetryAfter -> Transience
WillResolve Maybe RetryAfter
forall a. Maybe a
Nothing) (PreparedRule -> Text
prepName PreparedRule
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": the rule threw: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SomeException -> Text
forall e. Exception e => e -> Text
displayExceptionT SomeException
escape))
                Right RuleVerdict
verdict -> do
                    let res :: RuleEvaluation
res = RuleVerdict -> RuleEvaluation
Decided RuleVerdict
verdict
                    case Text -> RuleEvaluation -> Maybe Decision
decisive (PreparedRule -> Text
prepName PreparedRule
r) RuleEvaluation
res of
                        Just Decision
d -> Decision -> IO Decision
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Decision
d
                        Maybe Decision
Nothing -> [PreparedRule] -> [Text] -> IO Decision
step [PreparedRule]
rs (RuleEvaluation -> Text
reasonOf RuleEvaluation
res Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
reasons)
        | Bool
otherwise =
            -- A maximal contiguous block of resilient rules: launch it concurrently
            -- and resolve it in boot order. Stopping the block at the next direct rule
            -- keeps the "no mooted IO" guarantee -- a later direct rule is evaluated, and
            -- may decide, before any resilient rule beyond it is launched.
            let ([PreparedRule]
block, [PreparedRule]
rest) = (PreparedRule -> Bool)
-> [PreparedRule] -> ([PreparedRule], [PreparedRule])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (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
r PreparedRule -> [PreparedRule] -> [PreparedRule]
forall a. a -> [a] -> [a]
: [PreparedRule]
rs)
             in EvalContext
-> PackageDetails -> [PreparedRule] -> IO (Either Decision [Text])
evalBlock EvalContext
ctx PackageDetails
pd [PreparedRule]
block IO (Either Decision [Text])
-> (Either Decision [Text] -> IO Decision) -> IO Decision
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                    Left Decision
d -> Decision -> IO Decision
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Decision
d
                    Right [Text]
blockReasons -> [PreparedRule] -> [Text] -> IO Decision
step [PreparedRule]
rest ([Text] -> [Text]
forall a. [a] -> [a]
reverse [Text]
blockReasons [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
reasons)

-- Launch a contiguous resilient block concurrently, then await in boot order:
-- 'Left' the earliest decisive winner (with every strictly-later evaluation
-- cancelled), or 'Right' the block's non-decisive reasons in boot order. 'bracket'
-- guarantees every launched evaluation is cancelled on any exit.
evalBlock :: EvalContext -> PackageDetails -> [PreparedRule] -> IO (Either Decision [Reason])
evalBlock :: EvalContext
-> PackageDetails -> [PreparedRule] -> IO (Either Decision [Text])
evalBlock EvalContext
ctx PackageDetails
pd [PreparedRule]
block =
    IO [Async RuleEvaluation]
-> ([Async RuleEvaluation] -> IO ())
-> ([Async RuleEvaluation] -> IO (Either Decision [Text]))
-> IO (Either Decision [Text])
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket
        ((PreparedRule -> IO (Async RuleEvaluation))
-> [PreparedRule] -> IO [Async RuleEvaluation]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (\PreparedRule
r -> IO RuleEvaluation -> IO (Async RuleEvaluation)
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async (EvalContext -> PreparedRule -> PackageDetails -> IO RuleEvaluation
runEffectfulRule EvalContext
ctx PreparedRule
r PackageDetails
pd)) [PreparedRule]
block)
        ((Async RuleEvaluation -> IO ()) -> [Async RuleEvaluation] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Async RuleEvaluation -> IO ()
forall (m :: * -> *) a. MonadIO m => Async a -> m ()
uninterruptibleCancel)
        (\[Async RuleEvaluation]
asyncs -> [(PreparedRule, Async RuleEvaluation)]
-> [Text] -> IO (Either Decision [Text])
awaitInOrder ([PreparedRule]
-> [Async RuleEvaluation] -> [(PreparedRule, Async RuleEvaluation)]
forall a b. [a] -> [b] -> [(a, b)]
zip [PreparedRule]
block [Async RuleEvaluation]
asyncs) [])

-- Await a launched block's evaluations in boot order; a decisive winner cancels
-- every strictly-later one.
awaitInOrder :: [(PreparedRule, Async RuleEvaluation)] -> [Reason] -> IO (Either Decision [Reason])
awaitInOrder :: [(PreparedRule, Async RuleEvaluation)]
-> [Text] -> IO (Either Decision [Text])
awaitInOrder [] [Text]
reasons = Either Decision [Text] -> IO (Either Decision [Text])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Text] -> Either Decision [Text]
forall a b. b -> Either a b
Right ([Text] -> [Text]
forall a. [a] -> [a]
reverse [Text]
reasons))
awaitInOrder ((PreparedRule
r, Async RuleEvaluation
a) : [(PreparedRule, Async RuleEvaluation)]
rest) [Text]
reasons = do
    res <- Async RuleEvaluation -> IO RuleEvaluation
forall (m :: * -> *) a. MonadIO m => Async a -> m a
wait Async RuleEvaluation
a
    case decisive (prepName r) res of
        Just Decision
d -> do
            ((PreparedRule, Async RuleEvaluation) -> IO ())
-> [(PreparedRule, Async RuleEvaluation)] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Async RuleEvaluation -> IO ()
forall (m :: * -> *) a. MonadIO m => Async a -> m ()
cancel (Async RuleEvaluation -> IO ())
-> ((PreparedRule, Async RuleEvaluation) -> Async RuleEvaluation)
-> (PreparedRule, Async RuleEvaluation)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PreparedRule, Async RuleEvaluation) -> Async RuleEvaluation
forall a b. (a, b) -> b
snd) [(PreparedRule, Async RuleEvaluation)]
rest
            Either Decision [Text] -> IO (Either Decision [Text])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Decision -> Either Decision [Text]
forall a b. a -> Either a b
Left Decision
d)
        Maybe Decision
Nothing -> [(PreparedRule, Async RuleEvaluation)]
-> [Text] -> IO (Either Decision [Text])
awaitInOrder [(PreparedRule, Async RuleEvaluation)]
rest (RuleEvaluation -> Text
reasonOf RuleEvaluation
res Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
reasons)

-- Map a rule result to the 'Decision' it credits if decisive, or 'Nothing' if it is a
-- no-op (the only runtime classification -- there is no comparison of competing
-- results, the boot order having already settled who wins). A deterministic
-- 'CannotVet' and a harness 'Unavailable' fault credit the same 'Undecidable'; the
-- 'CannotVet' carries no transience of its own, so it is a plain retryable 503.
decisive :: Text -> RuleEvaluation -> Maybe Decision
decisive :: Text -> RuleEvaluation -> Maybe Decision
decisive Text
name = \case
    Decided (Allow Text
reason) -> Decision -> Maybe Decision
forall a. a -> Maybe a
Just (Text -> Text -> Decision
Admitted Text
name Text
reason)
    Decided (Deny Text
reason) -> Decision -> Maybe Decision
forall a. a -> Maybe a
Just (Text -> Text -> Decision
Blocked Text
name Text
reason)
    Decided (NoDecision Text
_) -> Maybe Decision
forall a. Maybe a
Nothing
    Decided (CannotVet FailureAlignment
FailDeny Text
reason) -> Decision -> Maybe Decision
forall a. a -> Maybe a
Just (Transience -> Text -> Decision
Undecidable (Maybe RetryAfter -> Transience
WillResolve Maybe RetryAfter
forall a. Maybe a
Nothing) Text
reason)
    Decided (CannotVet FailureAlignment
FailNoDecision Text
_) -> Maybe Decision
forall a. Maybe a
Nothing
    Unavailable Transience
transience FailureAlignment
FailDeny Text
reason -> Decision -> Maybe Decision
forall a. a -> Maybe a
Just (Transience -> Text -> Decision
Undecidable Transience
transience Text
reason)
    Unavailable Transience
_ FailureAlignment
FailNoDecision Text
_ -> Maybe Decision
forall a. Maybe a
Nothing

-- The audit reason carried by any result, gathered for the deny-by-default trail.
reasonOf :: RuleEvaluation -> Reason
reasonOf :: RuleEvaluation -> Text
reasonOf (Unavailable Transience
_ FailureAlignment
_ Text
reason) = Text
reason
reasonOf (Decided RuleVerdict
verdict) = case RuleVerdict
verdict of
    Allow Text
reason -> Text
reason
    Deny Text
reason -> Text
reason
    NoDecision Text
reason -> Text
reason
    CannotVet FailureAlignment
_ Text
reason -> Text
reason

{- | Run one prepared rule through its resilience policy. A rule with no 'Resilience'
(@'prepResilience' = 'Nothing'@) runs directly, its verdict wrapped 'Decided'. A
resilient rule's IO runs under its circuit-breaker gate, a per-attempt timeout, and
bounded retry with backoff: any 'RuleVerdict' the rule returns -- a deterministic
'CannotVet' included -- resets the breaker and is returned 'Decided', taken at face
value and never retried; only a __fault__ the harness observes (a timeout, an
exception, or the breaker already open) advances the breaker and resolves to
@'Unavailable' transience alignment reason@, the alignment from the rule's 'Resilience'
(fail-closed or fail-open).

The breaker timing reads the injected resilience clock ('resClock'), read fresh at each
breaker decision, so it is deterministic under test and independent of the request
snapshot 'ctxNow' the age rules hold constant. Reading it again after the retry run means
a tripped breaker's cooldown starts when the failure commits, not when the run began.
Total -- it never throws; a rule failure becomes a result.
-}
runEffectfulRule :: EvalContext -> PreparedRule -> PackageDetails -> IO RuleEvaluation
runEffectfulRule :: EvalContext -> PreparedRule -> PackageDetails -> IO RuleEvaluation
runEffectfulRule EvalContext
ctx PreparedRule
rule PackageDetails
pd = case PreparedRule -> Maybe Resilience
prepResilience PreparedRule
rule of
    Maybe Resilience
Nothing -> RuleVerdict -> RuleEvaluation
Decided (RuleVerdict -> RuleEvaluation)
-> IO RuleVerdict -> IO RuleEvaluation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PreparedRule -> EvalContext -> PackageDetails -> IO RuleVerdict
prepEval PreparedRule
rule EvalContext
ctx PackageDetails
pd
    Just Resilience
res -> Resilience
-> Text
-> (PackageDetails -> IO RuleVerdict)
-> PackageDetails
-> IO RuleEvaluation
runResilient Resilience
res (PreparedRule -> Text
prepName PreparedRule
rule) (PreparedRule -> EvalContext -> PackageDetails -> IO RuleVerdict
prepEval PreparedRule
rule EvalContext
ctx) PackageDetails
pd

{- | A human-readable summary of a decision, suitable for logs and the denial
response body.
-}
renderDecision :: PackageDetails -> Decision -> Text
renderDecision :: PackageDetails -> Decision -> Text
renderDecision PackageDetails
pd Decision
decision =
    let subject :: Text
subject = PackageName -> Text
renderPackageName (PackageDetails -> PackageName
pkgName PackageDetails
pd) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"@" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Version -> Text
renderVersion (PackageDetails -> Version
pkgVersion PackageDetails
pd)
     in case Decision
decision of
            Admitted Text
name Text
reason ->
                Text
subject Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" was approved by " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
reason
            Blocked Text
name Text
reason ->
                Text
subject Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" was denied by " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
reason
            BlockedByDefault [Text]
reasons ->
                Text
subject
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" was denied (no rule allowed it)"
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> if [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
reasons
                        then Text
""
                        else Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
"; " [Text]
reasons
            Undecidable Transience
_ Text
reason ->
                Text
subject Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" could not be evaluated: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
reason

{- | Render a duration as an approximate, human-friendly string for a decision
message: its two most-significant non-zero units, so a value just short of a
threshold reads differently from the threshold itself (@89s@ is @"1 minute 29
seconds"@, not the bare @"1 minute"@ a @90s@ minimum also rendered to). A long
duration stays compact, since its lesser units are zero and dropped. Always
non-negative.

>>> renderDuration 604800
"7 days"

>>> renderDuration 90
"1 minute 30 seconds"
-}
renderDuration :: NominalDiffTime -> Text
renderDuration :: NominalDiffTime -> Text
renderDuration NominalDiffTime
d = case Int -> [(Text, Integer)] -> [(Text, Integer)]
forall a. Int -> [a] -> [a]
take Int
2 (Integer -> [(Text, Integer)]
durationComponents Integer
secs) of
    [] -> Text
"0 seconds"
    [(Text, Integer)]
parts -> [Text] -> Text
T.unwords (((Text, Integer) -> Text) -> [(Text, Integer)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Integer) -> Text
renderDurationPart [(Text, Integer)]
parts)
  where
    secs :: Integer
secs = Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
max Integer
0 (Pico -> Integer
forall b. Integral b => Pico -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (NominalDiffTime -> Pico
nominalDiffTimeToSeconds NominalDiffTime
d)) :: Integer

{- | The unit ladder 'durationComponents' decomposes a second count against, the
largest unit first. @second@ (size 1) is the floor, so any remainder is fully
consumed and the smallest component is always whole seconds.
-}
durationLadder :: [(Text, Integer)]
durationLadder :: [(Text, Integer)]
durationLadder =
    [ (Text
"day", Integer
86400)
    , (Text
"hour", Integer
3600)
    , (Text
"minute", Integer
60)
    , (Text
"second", Integer
1)
    ]

{- | The non-zero @(unit, count)@ components of a non-negative second count, the
largest unit first: @90@ is @[("minute", 1), ("second", 30)]@, and @604800@ is
@[("day", 7)]@ (a single component, its lesser units being zero). 'renderDuration'
keeps the two most significant.
-}
durationComponents :: Integer -> [(Text, Integer)]
durationComponents :: Integer -> [(Text, Integer)]
durationComponents = [(Text, Integer)] -> Integer -> [(Text, Integer)]
forall {t} {a}. Integral t => [(a, t)] -> t -> [(a, t)]
go [(Text, Integer)]
durationLadder
  where
    go :: [(a, t)] -> t -> [(a, t)]
go [] t
_ = []
    go ((a
unit, t
size) : [(a, t)]
rest) t
r =
        let (t
q, t
r') = t
r t -> t -> (t, t)
forall a. Integral a => a -> a -> (a, a)
`divMod` t
size
         in [(a
unit, t
q) | t
q t -> t -> Bool
forall a. Ord a => a -> a -> Bool
> t
0] [(a, t)] -> [(a, t)] -> [(a, t)]
forall a. Semigroup a => a -> a -> a
<> [(a, t)] -> t -> [(a, t)]
go [(a, t)]
rest t
r'

-- Render one @(unit, count)@ component, pluralising the unit (@1 minute@, @30 seconds@).
renderDurationPart :: (Text, Integer) -> Text
renderDurationPart :: (Text, Integer) -> Text
renderDurationPart (Text
unit, Integer
n) = Integer -> Text
forall b a. (Show a, IsString b) => a -> b
show Integer
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
unit Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (if Integer
n Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
1 then Text
"" else Text
"s")