{- | 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 it is 'Allow', 'Deny',
or an @'Unavailable' _ 'FailDeny' _@ (a fail-closed uncomputable check); 'NoDecision'
and @'Unavailable' _ 'FailNoDecision' _@ are non-decisive no-ops whose reasons are
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 'AllowIfRemediatesCve' carries 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".
-}
module Ecluse.Core.Rules (
    -- * The boot-bound rule capabilities
    RuleDeps (..),
    inertRuleDeps,

    -- * The built-in rule dispatch
    evalRule,

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

    -- * Boot-time ordering
    bootOrder,
    renderBootOrder,

    -- * Evaluation
    evalRules,
    renderDecision,
    renderDuration,

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

import Control.Retry (
    RetryPolicyM (RetryPolicyM),
    RetryStatus (rsIterNumber),
    retrying,
 )
import Data.Text qualified as T
import Data.Time (NominalDiffTime, UTCTime, diffUTCTime)
import UnliftIO (timeout, tryAny)
import UnliftIO.Async (Async, async, cancel, uninterruptibleCancel, wait)
import UnliftIO.Exception (bracket)

import Ecluse.Core.Breaker (
    Breaker (..),
    BreakerReporter (..),
    admit,
    initialBreaker,
    noBreakerReporter,
    recordFailure,
    recordSuccess,
    reportBreakerChange,
 )
import Ecluse.Core.Cve (AdvisoryRange (..), CveLookup (..), insideAffectedRange)
import Ecluse.Core.Ecosystem (Ecosystem)
import Ecluse.Core.Package
import Ecluse.Core.Rules.Types
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 -> BreakerReporter
rdBreakerReporter :: BreakerReporter
    {- ^ The observer effectful rules report their breaker transitions to
    (@ecluse.rule.breaker.state@); 'noBreakerReporter' when unobserved.
    -}
    }

{- | Rule capabilities with no advisory database and no breaker observer: the
composition value before a CVE sync is configured, and the pure tests' default.
-}
inertRuleDeps :: RuleDeps
inertRuleDeps :: RuleDeps
inertRuleDeps =
    RuleDeps
        { rdWithCveLookup :: forall a. (Maybe CveLookup -> IO a) -> IO a
rdWithCveLookup = \Maybe CveLookup -> IO a
use -> Maybe CveLookup -> IO a
use Maybe CveLookup
forall a. Maybe a
Nothing
        , rdBreakerReporter :: BreakerReporter
rdBreakerReporter = BreakerReporter
noBreakerReporter
        }

{- | 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 result, never
yielding 'Unavailable'; 'AllowIfRemediatesCve' reads the advisory database through
the boot-bound 'RuleDeps' and does IO, relying on its 'Resilience' harness (attached
by 'prepare') to resolve a failing lookup to a fail-open 'Unavailable'.

'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 result, never an exception, so
hostile metadata cannot crash the gate.
-}
evalRule :: RuleDeps -> EvalContext -> Rule -> PackageDetails -> IO RuleResult
evalRule :: RuleDeps -> EvalContext -> Rule -> PackageDetails -> IO RuleResult
evalRule RuleDeps
_ EvalContext
_ (AllowScope Scope
scope) PackageDetails
pd =
    RuleResult -> IO RuleResult
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RuleResult -> IO RuleResult) -> RuleResult -> IO RuleResult
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 -> RuleResult
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 -> RuleResult
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 =
    RuleResult -> IO RuleResult
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RuleResult -> IO RuleResult) -> RuleResult -> IO RuleResult
forall a b. (a -> b) -> a -> b
$ case PackageDetails -> Maybe UTCTime
pkgPublishedAt PackageDetails
pd of
        Maybe UTCTime
Nothing -> Text -> RuleResult
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 -> RuleResult
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 -> RuleResult
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 =
    RuleResult -> IO RuleResult
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RuleResult -> IO RuleResult) -> RuleResult -> IO RuleResult
forall a b. (a -> b) -> a -> b
$ case PackageDetails -> CodeExecSignal
pkgInstallCode PackageDetails
pd of
        RunsCodeOnInstall Text
how -> Text -> RuleResult
Deny (Text
"runs code on install: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
how)
        CodeExecSignal
NoCodeOnInstall -> Text -> RuleResult
NoDecision Text
"no install-time code execution"
        CodeExecSignal
CodeExecUnknown -> Text -> RuleResult
NoDecision Text
"install-time code execution not yet determined"
evalRule RuleDeps
_ EvalContext
_ (DenyByIdentity Text
ident) PackageDetails
pd =
    RuleResult -> IO RuleResult
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RuleResult -> IO RuleResult) -> RuleResult -> IO RuleResult
forall a b. (a -> b) -> a -> b
$
        if Text -> PackageDetails -> Bool
matchesIdentity Text
ident PackageDetails
pd
            then Text -> RuleResult
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 -> RuleResult
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 =
    RuleResult -> IO RuleResult
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RuleResult -> IO RuleResult) -> RuleResult -> IO RuleResult
forall a b. (a -> b) -> a -> b
$
        if Text -> PackageDetails -> Bool
matchesIdentity Text
ident PackageDetails
pd
            then Text -> RuleResult
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 -> RuleResult
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 RuleResult) -> IO RuleResult)
-> (Maybe CveLookup -> IO RuleResult) -> IO RuleResult
forall a b. (a -> b) -> a -> b
$ \case
        Maybe CveLookup
Nothing -> RuleResult -> IO RuleResult
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> RuleResult
NoDecision Text
"no advisory database is loaded")
        Just CveLookup
cve -> CveLookup -> PackageDetails -> IO RuleResult
remediationVerdict CveLookup
cve PackageDetails
pd

-- The CVE rule's verdict against a loaded advisory database.
remediationVerdict :: CveLookup -> PackageDetails -> IO RuleResult
remediationVerdict :: CveLookup -> PackageDetails -> IO RuleResult
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] -> RuleResult
classifyRanges :: Ecosystem -> Text -> [AdvisoryRange] -> RuleResult
classifyRanges Ecosystem
eco Text
version [AdvisoryRange]
ranges =
    case ([Text]
remediated, [Text]
stillOpen) of
        ([Text]
_, Text
_ : [Text]
_) ->
            Text -> RuleResult
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 -> RuleResult
NoDecision Text
"no advisory names this version as its fix"
        ([Text]
ids, []) -> Text -> RuleResult
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 'RuleResult') 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 RuleResult
prepEval :: EvalContext -> PackageDetails -> IO RuleResult
    {- ^ The rule's raw verdict for one version. For a resilient rule it may perform IO
    that fails or hangs; 'runEffectfulRule' wraps it.
    -}
    }

{- | The resilience policy wrapped around an effectful rule's IO: the timeout\/retry\/
breaker knobs, the per-source circuit-breaker state, its observer, and the
__failure alignment__ an exhausted evaluation resolves to (fail-closed 'FailDeny' or
fail-open 'FailNoDecision'). The alignment rides on the prepared rule, folding away the
separate failure-policy the two-tier design once carried.
-}
data Resilience = Resilience
    { Resilience -> EffectfulConfig
resConfig :: EffectfulConfig
    -- ^ The per-attempt timeout, retry budget\/backoff, and breaker threshold\/cooldown.
    , Resilience -> FailureAlignment
resAlignment :: FailureAlignment
    -- ^ Whether an exhausted evaluation fails closed ('FailDeny') or open ('FailNoDecision').
    , Resilience -> TVar Breaker
resBreaker :: TVar Breaker
    -- ^ This rule's per-source circuit-breaker state, shared across evaluations.
    , Resilience -> BreakerReporter
resBreakerReporter :: BreakerReporter
    {- ^ The observer this rule's breaker reports its state transitions to
    (@ecluse.rule.breaker.state@). Inert ('Ecluse.Core.Breaker.noBreakerReporter') for an
    unobserved rule; the composition root installs the live one.
    -}
    }

{- | 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 RuleResult
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 -> do
        breaker <- IO (TVar Breaker)
newBreaker
        pure $
            Just
                Resilience
                    { resConfig = defaultEffectfulConfig
                    , resAlignment = FailNoDecision
                    , resBreaker = breaker
                    , resBreakerReporter = rdBreakerReporter deps
                    }
    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

{- | 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.
-}
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.
            res <- PreparedRule -> EvalContext -> PackageDetails -> IO RuleResult
prepEval PreparedRule
r EvalContext
ctx PackageDetails
pd
            case decisive (prepName r) 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 (RuleResult -> Text
reasonOf RuleResult
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 RuleResult]
-> ([Async RuleResult] -> IO ())
-> ([Async RuleResult] -> 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 RuleResult))
-> [PreparedRule] -> IO [Async RuleResult]
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 RuleResult -> IO (Async RuleResult)
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async (EvalContext -> PreparedRule -> PackageDetails -> IO RuleResult
runEffectfulRule EvalContext
ctx PreparedRule
r PackageDetails
pd)) [PreparedRule]
block)
        ((Async RuleResult -> IO ()) -> [Async RuleResult] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Async RuleResult -> IO ()
forall (m :: * -> *) a. MonadIO m => Async a -> m ()
uninterruptibleCancel)
        (\[Async RuleResult]
asyncs -> [(PreparedRule, Async RuleResult)]
-> [Text] -> IO (Either Decision [Text])
awaitInOrder ([PreparedRule]
-> [Async RuleResult] -> [(PreparedRule, Async RuleResult)]
forall a b. [a] -> [b] -> [(a, b)]
zip [PreparedRule]
block [Async RuleResult]
asyncs) [])

-- Await a launched block's evaluations in boot order; a decisive winner cancels
-- every strictly-later one.
awaitInOrder :: [(PreparedRule, Async RuleResult)] -> [Reason] -> IO (Either Decision [Reason])
awaitInOrder :: [(PreparedRule, Async RuleResult)]
-> [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 RuleResult
a) : [(PreparedRule, Async RuleResult)]
rest) [Text]
reasons = do
    res <- Async RuleResult -> IO RuleResult
forall (m :: * -> *) a. MonadIO m => Async a -> m a
wait Async RuleResult
a
    case decisive (prepName r) res of
        Just Decision
d -> do
            ((PreparedRule, Async RuleResult) -> IO ())
-> [(PreparedRule, Async RuleResult)] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Async RuleResult -> IO ()
forall (m :: * -> *) a. MonadIO m => Async a -> m ()
cancel (Async RuleResult -> IO ())
-> ((PreparedRule, Async RuleResult) -> Async RuleResult)
-> (PreparedRule, Async RuleResult)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PreparedRule, Async RuleResult) -> Async RuleResult
forall a b. (a, b) -> b
snd) [(PreparedRule, Async RuleResult)]
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 RuleResult)]
-> [Text] -> IO (Either Decision [Text])
awaitInOrder [(PreparedRule, Async RuleResult)]
rest (RuleResult -> Text
reasonOf RuleResult
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).
decisive :: Text -> RuleResult -> Maybe Decision
decisive :: Text -> RuleResult -> Maybe Decision
decisive Text
name = \case
    Allow Text
reason -> Decision -> Maybe Decision
forall a. a -> Maybe a
Just (Text -> Text -> Decision
Admitted Text
name Text
reason)
    Deny Text
reason -> Decision -> Maybe Decision
forall a. a -> Maybe a
Just (Text -> Text -> Decision
Blocked Text
name Text
reason)
    Unavailable Transience
transience FailureAlignment
FailDeny Text
reason -> Decision -> Maybe Decision
forall a. a -> Maybe a
Just (Transience -> Text -> Decision
Undecidable Transience
transience Text
reason)
    NoDecision Text
_ -> Maybe Decision
forall a. Maybe a
Nothing
    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 :: RuleResult -> Reason
reasonOf :: RuleResult -> Text
reasonOf = \case
    Allow Text
reason -> Text
reason
    Deny Text
reason -> Text
reason
    NoDecision Text
reason -> Text
reason
    Unavailable Transience
_ FailureAlignment
_ Text
reason -> Text
reason

{- | Run one prepared rule through its resilience policy. A rule with no 'Resilience'
(@'prepResilience' = 'Nothing'@) runs directly. A resilient rule's IO runs under its
circuit-breaker gate, a per-attempt timeout, and bounded retry with backoff: a clean
verdict ('Allow'\/'Deny'\/'NoDecision') resets the breaker and is returned; an
exhausted rule (timeout, exception, the breaker open, or the rule self-reporting
'Unavailable' on every attempt) advances the breaker and resolves to @'Unavailable'
transience alignment reason@ -- the alignment from the rule's 'Resilience' (fail-closed
or fail-open), the transience from the last failing attempt.

The breaker timing reads the 'EvalContext' clock, so it is deterministic under test.
Total -- it never throws; a rule failure becomes a result.
-}
runEffectfulRule :: EvalContext -> PreparedRule -> PackageDetails -> IO RuleResult
runEffectfulRule :: EvalContext -> PreparedRule -> PackageDetails -> IO RuleResult
runEffectfulRule EvalContext
ctx PreparedRule
rule PackageDetails
pd = case PreparedRule -> Maybe Resilience
prepResilience PreparedRule
rule of
    Maybe Resilience
Nothing -> PreparedRule -> EvalContext -> PackageDetails -> IO RuleResult
prepEval PreparedRule
rule EvalContext
ctx PackageDetails
pd
    Just Resilience
res -> do
        let now :: UTCTime
now = EvalContext -> UTCTime
ctxNow EvalContext
ctx
        admitted <- Resilience -> UTCTime -> IO Bool
admitProbe Resilience
res UTCTime
now
        if not admitted
            then -- Breaker open and still cooling down: fast-fail without running the
            -- rule's IO, the cheap path a sustained outage stays on. An open breaker
            -- is an infrastructural outage, so it is transient.
                pure (exhausted res (prepName rule) (transientCause (resConfig res)) "the rule source circuit breaker is open")
            else do
                result <- attemptWithRetry res (prepEval rule ctx) pd
                settleOutcome res (prepName rule) now result

{- Settle a finished retry run against the breaker: a clean verdict resets the
breaker and is returned; an exhausted run advances the breaker and resolves to
the rule's aligned 'Unavailable'. -}
settleOutcome :: Resilience -> Text -> UTCTime -> Either Transience RuleResult -> IO RuleResult
settleOutcome :: Resilience
-> Text -> UTCTime -> Either Transience RuleResult -> IO RuleResult
settleOutcome Resilience
res Text
name UTCTime
now = \case
    Right RuleResult
outcome -> do
        Resilience -> (Breaker -> Breaker) -> IO ()
commitBreaker Resilience
res Breaker -> Breaker
recordSuccess
        RuleResult -> IO RuleResult
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RuleResult
outcome
    Left Transience
transience -> do
        Resilience -> (Breaker -> Breaker) -> IO ()
commitBreaker Resilience
res (EffectfulConfig -> UTCTime -> Breaker -> Breaker
tripOnFailure (Resilience -> EffectfulConfig
resConfig Resilience
res) UTCTime
now)
        RuleResult -> IO RuleResult
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Resilience -> Text -> Transience -> Text -> RuleResult
exhausted Resilience
res Text
name Transience
transience Text
"the rule could not be evaluated")

{- Attempt the rule's IO under the per-attempt timeout, retrying with backoff until
the retry budget is spent. 'Right' a clean verdict on success; 'Left' the 'Transience'
of the last failing attempt when every attempt failed (an exception, a timeout, or
the rule yielding its own 'Unavailable'). 'retrying' returns the final value the
action produced, so the surfaced transience is the last attempt's: a permanent
('WontResolve') self-report on that attempt is honoured through to the serve mapping,
while any other failure stays transient. A rule that returns
'Allow'\/'Deny'\/'NoDecision' is taken at face value and not retried. -}
attemptWithRetry :: Resilience -> (PackageDetails -> IO RuleResult) -> PackageDetails -> IO (Either Transience RuleResult)
attemptWithRetry :: Resilience
-> (PackageDetails -> IO RuleResult)
-> PackageDetails
-> IO (Either Transience RuleResult)
attemptWithRetry Resilience
res PackageDetails -> IO RuleResult
evalAt PackageDetails
pd =
    RetryPolicyM IO
-> (RetryStatus -> Either Transience RuleResult -> IO Bool)
-> (RetryStatus -> IO (Either Transience RuleResult))
-> IO (Either Transience RuleResult)
forall (m :: * -> *) b.
MonadIO m =>
RetryPolicyM m
-> (RetryStatus -> b -> m Bool) -> (RetryStatus -> m b) -> m b
retrying ([Int] -> RetryPolicyM IO
backoffPolicy (EffectfulConfig -> [Int]
ecBackoff (Resilience -> EffectfulConfig
resConfig Resilience
res))) RetryStatus -> Either Transience RuleResult -> IO Bool
forall {f :: * -> *} {p} {a} {b}.
Applicative f =>
p -> Either a b -> f Bool
shouldRetry (\RetryStatus
_ -> Resilience
-> (PackageDetails -> IO RuleResult)
-> PackageDetails
-> IO (Either Transience RuleResult)
attemptOnce Resilience
res PackageDetails -> IO RuleResult
evalAt PackageDetails
pd)
  where
    shouldRetry :: p -> Either a b -> f Bool
shouldRetry p
_ = Bool -> f Bool
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> f Bool) -> (Either a b -> Bool) -> Either a b -> f Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either a b -> Bool
forall a b. Either a b -> Bool
isLeft

{- | An 'ecBackoff' schedule compiled to a "Control.Retry" policy: the retry at
iteration n waits the n-th delay (microseconds) before it, and the policy stops
(yields 'Nothing') once the schedule is exhausted -- so the list's length is the retry
budget. @[]@ admits no retry (a single attempt); @[a, b]@ admits up to two. Inspect
the resulting delays without sleeping with 'Control.Retry.simulatePolicy'.
-}
backoffPolicy :: [Int] -> RetryPolicyM IO
backoffPolicy :: [Int] -> RetryPolicyM IO
backoffPolicy [Int]
backoffs = (RetryStatus -> IO (Maybe Int)) -> RetryPolicyM IO
forall (m :: * -> *).
(RetryStatus -> m (Maybe Int)) -> RetryPolicyM m
RetryPolicyM (\RetryStatus
rs -> Maybe Int -> IO (Maybe Int)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Int]
backoffs [Int] -> Int -> Maybe Int
forall a. [a] -> Int -> Maybe a
!!? RetryStatus -> Int
rsIterNumber RetryStatus
rs))

{- One attempt: run the rule's IO under the timeout, catching any exception. 'Right'
a clean verdict; 'Left' the 'Transience' to surface should the retry budget be
exhausted on this attempt. A timeout, an exception, or a rule reporting its own
transient unavailability is 'WillResolve' (an infrastructural outage the configured
'RetryAfter' applies to); a rule reporting its own /permanent/ ('WontResolve')
unavailability keeps that distinction so an internal\/parse fault is not later
dressed up as retryable. Either way a self-reported 'Unavailable' still counts as a
failed attempt -- the harness retries and trips the breaker rather than trusting a
single self-report -- only the transience it carries on exhaustion differs. -}
attemptOnce :: Resilience -> (PackageDetails -> IO RuleResult) -> PackageDetails -> IO (Either Transience RuleResult)
attemptOnce :: Resilience
-> (PackageDetails -> IO RuleResult)
-> PackageDetails
-> IO (Either Transience RuleResult)
attemptOnce Resilience
res PackageDetails -> IO RuleResult
evalAt PackageDetails
pd = do
    result <- IO (Maybe RuleResult)
-> IO (Either SomeException (Maybe RuleResult))
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny (Int -> IO RuleResult -> IO (Maybe RuleResult)
forall (m :: * -> *) a.
MonadUnliftIO m =>
Int -> m a -> m (Maybe a)
timeout (EffectfulConfig -> Int
ecTimeout (Resilience -> EffectfulConfig
resConfig Resilience
res)) (PackageDetails -> IO RuleResult
evalAt PackageDetails
pd))
    pure $ case result of
        Left SomeException
_ -> Transience -> Either Transience RuleResult
forall a b. a -> Either a b
Left Transience
transient -- the rule's IO threw
        Right Maybe RuleResult
Nothing -> Transience -> Either Transience RuleResult
forall a b. a -> Either a b
Left Transience
transient -- the attempt timed out
        Right (Just (Unavailable Transience
WontResolve FailureAlignment
_ Text
_)) -> Transience -> Either Transience RuleResult
forall a b. a -> Either a b
Left Transience
WontResolve -- a permanent self-report, honoured
        Right (Just (Unavailable (WillResolve Maybe RetryAfter
_) FailureAlignment
_ Text
_)) -> Transience -> Either Transience RuleResult
forall a b. a -> Either a b
Left Transience
transient -- a transient self-report
        Right (Just RuleResult
clean) -> RuleResult -> Either Transience RuleResult
forall a b. b -> Either a b
Right RuleResult
clean
  where
    transient :: Transience
transient = EffectfulConfig -> Transience
transientCause (Resilience -> EffectfulConfig
resConfig Resilience
res)

{- The result an exhausted rule resolves to: @'Unavailable' transience alignment@ --
'WillResolve' for an infrastructural failure (a timeout, an exception, an open
breaker) or a self-reported transient, 'WontResolve' for a self-reported permanent
fault; the alignment is the rule's own (fail-closed 'FailDeny' or fail-open
'FailNoDecision'). The reason is carried for the audit trail. -}
exhausted :: Resilience -> Text -> Transience -> Text -> RuleResult
exhausted :: Resilience -> Text -> Transience -> Text -> RuleResult
exhausted Resilience
res Text
name Transience
transience Text
reason = Transience -> FailureAlignment -> Text -> RuleResult
Unavailable Transience
transience (Resilience -> FailureAlignment
resAlignment Resilience
res) (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)

{- The transient 'Transience' an infrastructural failure (a timeout, an exception, an
open breaker) surfaces: retryable, carrying the rule's configured 'RetryAfter'. -}
transientCause :: EffectfulConfig -> Transience
transientCause :: EffectfulConfig -> Transience
transientCause EffectfulConfig
cfg = Maybe RetryAfter -> Transience
WillResolve (EffectfulConfig -> Maybe RetryAfter
ecRetryAfter EffectfulConfig
cfg)

{- The breaker admission gate: defer the decision to 'Ecluse.Core.Breaker.admit' and
commit the breaker state it returns, reporting any change (a half-open recovery probe).
See 'Ecluse.Core.Breaker.admit' for the admission policy. -}
admitProbe :: Resilience -> UTCTime -> IO Bool
admitProbe :: Resilience -> UTCTime -> IO Bool
admitProbe Resilience
res UTCTime
now = do
    (permitted, old, new) <- STM (Bool, Breaker, Breaker) -> IO (Bool, Breaker, Breaker)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Bool, Breaker, Breaker) -> IO (Bool, Breaker, Breaker))
-> STM (Bool, Breaker, Breaker) -> IO (Bool, Breaker, Breaker)
forall a b. (a -> b) -> a -> b
$ do
        st <- TVar Breaker -> STM Breaker
forall a. TVar a -> STM a
readTVar (Resilience -> TVar Breaker
resBreaker Resilience
res)
        let (p, st') = admit now st
        writeTVar (resBreaker res) st'
        pure (p, st, st')
    reportBreakerChange (resBreakerReporter res) old new
    pure permitted

{- Commit a breaker fold to this rule's breaker and report any observable state change
it makes (a trip, a reset). Reads the breaker before and after in one transaction so the
report reflects exactly the transition committed. -}
commitBreaker :: Resilience -> (Breaker -> Breaker) -> IO ()
commitBreaker :: Resilience -> (Breaker -> Breaker) -> IO ()
commitBreaker Resilience
res Breaker -> Breaker
step = do
    (old, new) <- STM (Breaker, Breaker) -> IO (Breaker, Breaker)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Breaker, Breaker) -> IO (Breaker, Breaker))
-> STM (Breaker, Breaker) -> IO (Breaker, Breaker)
forall a b. (a -> b) -> a -> b
$ do
        st <- TVar Breaker -> STM Breaker
forall a. TVar a -> STM a
readTVar (Resilience -> TVar Breaker
resBreaker Resilience
res)
        let st' = Breaker -> Breaker
step Breaker
st
        writeTVar (resBreaker res) st'
        pure (st, st')
    reportBreakerChange (resBreakerReporter res) old new

{- Advance the breaker on a failed evaluation per this rule's configured threshold
and cooldown ('Ecluse.Core.Breaker.recordFailure'). -}
tripOnFailure :: EffectfulConfig -> UTCTime -> Breaker -> Breaker
tripOnFailure :: EffectfulConfig -> UTCTime -> Breaker -> Breaker
tripOnFailure EffectfulConfig
cfg = Int -> NominalDiffTime -> UTCTime -> Breaker -> Breaker
recordFailure (EffectfulConfig -> Int
ecBreakerThreshold EffectfulConfig
cfg) (EffectfulConfig -> NominalDiffTime
ecBreakerCooldown EffectfulConfig
cfg)

{- | The resilience knobs around an effectful rule's IO: a per-attempt timeout,
how many retries to make on failure with the backoff before each, and the breaker
threshold and cooldown. The breaker clock is the 'EvalContext'.
-}
data EffectfulConfig = EffectfulConfig
    { EffectfulConfig -> Int
ecTimeout :: Int
    {- ^ The per-attempt timeout in microseconds. An attempt that does not return
    within it is treated as a failure (a transient, retryable cause).
    -}
    , EffectfulConfig -> [Int]
ecBackoff :: [Int]
    {- ^ The backoff delays in microseconds, one per retry, applied __before__ the
    corresponding retry attempt. Its length is the retry budget: @[]@ means the
    single initial attempt only, @[100, 200]@ means up to two retries after it.
    -}
    , EffectfulConfig -> Int
ecBreakerThreshold :: Int
    -- ^ Consecutive exhausted-rule failures that trip the breaker.
    , EffectfulConfig -> NominalDiffTime
ecBreakerCooldown :: NominalDiffTime
    {- ^ How long the breaker stays open (fast-failing the rule) before a single
    half-open probe is allowed to test recovery.
    -}
    , EffectfulConfig -> Maybe RetryAfter
ecRetryAfter :: Maybe RetryAfter
    {- ^ The @Retry-After@ delay to suggest to a client when this rule's
    unavailability surfaces on a concrete-artifact request; 'Nothing' suggests none.
    -}
    }

{- | Sensible defaults for the resilience knobs: a 2-second per-attempt timeout, two
retries at 100ms then 250ms, and a breaker tripping after 5 consecutive failures and
cooling for 30 seconds. The caller supplies the rule's IO; the knobs are policy with
these defaults.
-}
defaultEffectfulConfig :: EffectfulConfig
defaultEffectfulConfig :: EffectfulConfig
defaultEffectfulConfig =
    EffectfulConfig
        { ecTimeout :: Int
ecTimeout = Int
2_000_000
        , ecBackoff :: [Int]
ecBackoff = [Int
100_000, Int
250_000]
        , ecBreakerThreshold :: Int
ecBreakerThreshold = Int
5
        , ecBreakerCooldown :: NominalDiffTime
ecBreakerCooldown = NominalDiffTime
30
        , ecRetryAfter :: Maybe RetryAfter
ecRetryAfter = Maybe RetryAfter
forall a. Maybe a
Nothing
        }

-- | A fresh, healthy breaker (no failures recorded) in a new 'TVar'.
newBreaker :: IO (TVar Breaker)
newBreaker :: IO (TVar Breaker)
newBreaker = Breaker -> IO (TVar Breaker)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Breaker
initialBreaker

{- | 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 use in
decision messages. Always non-negative.

>>> renderDuration 604800
"7 days"

>>> renderDuration 90
"1 minute"
-}
renderDuration :: NominalDiffTime -> Text
renderDuration :: NominalDiffTime -> Text
renderDuration NominalDiffTime
d =
    let secs :: Integer
secs = Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
max Integer
0 (Double -> Integer
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (NominalDiffTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac NominalDiffTime
d :: Double)) :: Integer
     in [(Text, Integer)] -> Integer -> Text
forall {t} {t}.
(Semigroup t, Show t, IsString t, Integral t) =>
[(t, t)] -> t -> t
pick [(Text, Integer)]
units Integer
secs
  where
    units :: [(Text, Integer)]
    units :: [(Text, Integer)]
units =
        [ (Text
"day", Integer
86400)
        , (Text
"hour", Integer
3600)
        , (Text
"minute", Integer
60)
        ]
    pick :: [(t, t)] -> t -> t
pick [] t
secs = t -> t -> t
forall {a} {a}.
(Semigroup a, Show a, IsString a, Eq a, Num a) =>
a -> a -> a
plural t
secs t
"second"
    pick ((t
unit, t
size) : [(t, t)]
rest) t
secs
        | t
secs t -> t -> Bool
forall a. Ord a => a -> a -> Bool
>= t
size = t -> t -> t
forall {a} {a}.
(Semigroup a, Show a, IsString a, Eq a, Num a) =>
a -> a -> a
plural (t
secs t -> t -> t
forall a. Integral a => a -> a -> a
`div` t
size) t
unit
        | Bool
otherwise = [(t, t)] -> t -> t
pick [(t, t)]
rest t
secs
    plural :: a -> a -> a
plural a
n a
unit = a -> a
forall b a. (Show a, IsString b) => a -> b
show a
n a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
" " a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
unit a -> a -> a
forall a. Semigroup a => a -> a -> a
<> (if a
n a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
1 then a
"" else a
"s")