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

{- | The policy engine denies by default and decides in boot order. One advisory read per package
serves every advisory rule an evaluator reaches, so a request's decisions read one generation.
-}
module Ecluse.Core.Rules (
    -- * The boot-bound rule capabilities
    RuleDeps (..),
    AdvisoryDatabase (..),
    withCveLookup,

    -- * The built-in rule dispatch
    VerdictSource (..),
    AdvisoryAlignment (..),
    verdictSource,
    AdvisoryRows,
    readAdvisories,

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

    -- * Boot-time ordering
    bootOrder,
    renderBootOrder,

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

    -- * Observing the advisory source
    SourceHealth (..),
    SourceReporter (..),
    noSourceReporter,
) where

import Data.Text qualified as T
import Data.Text.Short qualified as TS
import Data.Time (NominalDiffTime, diffUTCTime, getCurrentTime, nominalDiffTimeToSeconds)
import UnliftIO (tryAny)
import UnliftIO.MVar (modifyMVar)

import Ecluse.Core.Breaker (BreakerReporter (..))
import Ecluse.Core.Cve (AdvisoryRange (..), CveLookup (..), MissingScorePolicy (..), PackageAdvisories, affecting, fixedAt, keepAdvisories, packageAdvisories, scoreAtLeast)
import Ecluse.Core.Cve.Types (DbEtag)
import Ecluse.Core.Package
import Ecluse.Core.Rules.Effectful (
    ReadFault (..),
    Resilience (..),
    defaultEffectfulConfig,
    newBreaker,
    runResilient,
 )
import Ecluse.Core.Rules.Freshness (AdvisoryAge (..), AdvisoryFreshness (AdvisoryAging, AdvisoryFresh, AdvisoryStale, AdvisoryUndated))
import Ecluse.Core.Rules.Outage (SourceHealth (..), SourceReporter (..), noSourceReporter)
import Ecluse.Core.Rules.Types
import Ecluse.Core.Text (displayExceptionT, renderIso8601Utc)
import Ecluse.Core.Version (renderVersion)

-- | One ecosystem's boot-bound rule capabilities: its advisory database and the rules' observers.
data RuleDeps = RuleDeps
    { RuleDeps -> AdvisoryDatabase
rdAdvisoryDatabase :: AdvisoryDatabase
    , RuleDeps -> IO (Maybe DbEtag)
rdCurrentAdvisoryEtag :: IO (Maybe DbEtag)
    {- ^ A non-pinning read of the active 'DbEtag'. It holds no generation open, so it never
    delays a shadow-swap.
    -}
    , RuleDeps -> BreakerReporter
rdBreakerReporter :: BreakerReporter
    -- ^ Where advisory rules report breaker transitions, as @ecluse.rule.breaker.state@.
    , RuleDeps -> SourceReporter
rdSourceReporter :: SourceReporter
    {- ^ Where each advisory rule a request reaches reports whether it could consult the source, so
    an outage is observed as a transition rather than once per request.
    -}
    , RuleDeps -> IO AdvisoryFreshness
rdAdvisoryFreshness :: IO AdvisoryFreshness
    {- ^ How old the serving artifact's push is, read again for every package read. The wall
    clock alone ages it, so an unchanged artifact expires in a warm process.
    -}
    }

-- | An ecosystem's advisory database, as configuration fixes it at boot.
data AdvisoryDatabase
    = NoAdvisoryDatabase
    | -- | Bracketed access to the lookup and ETag acquired together, 'Nothing' until a generation loads.
      AdvisoryDatabase (forall a. (Maybe (DbEtag, CveLookup) -> IO a) -> IO a)

-- | Borrow the loaded generation, or 'Nothing' when none is configured or none has loaded yet.
withCveLookup :: RuleDeps -> (Maybe (DbEtag, CveLookup) -> IO a) -> IO a
withCveLookup :: forall a. RuleDeps -> (Maybe (DbEtag, CveLookup) -> IO a) -> IO a
withCveLookup RuleDeps
deps Maybe (DbEtag, CveLookup) -> IO a
use = case RuleDeps -> AdvisoryDatabase
rdAdvisoryDatabase RuleDeps
deps of
    AdvisoryDatabase
NoAdvisoryDatabase -> Maybe (DbEtag, CveLookup) -> IO a
use Maybe (DbEtag, CveLookup)
forall a. Maybe a
Nothing
    AdvisoryDatabase forall a. (Maybe (DbEtag, CveLookup) -> IO a) -> IO a
borrow -> (Maybe (DbEtag, CveLookup) -> IO a) -> IO a
forall a. (Maybe (DbEtag, CveLookup) -> IO a) -> IO a
borrow Maybe (DbEtag, CveLookup) -> IO a
use

-- | One package's advisory rows and the generation that served them, or 'Nothing' while none is loaded.
type AdvisoryRows = Maybe (DbEtag, PackageAdvisories)

{- | Pin a generation and read one package's rows through it, their bounds parsed once for all its
versions. A query fault escapes to the caller.
-}
readAdvisories :: RuleDeps -> PackageName -> IO AdvisoryRows
readAdvisories :: RuleDeps -> PackageName -> IO AdvisoryRows
readAdvisories RuleDeps
deps PackageName
name =
    RuleDeps
-> (Maybe (DbEtag, CveLookup) -> IO AdvisoryRows)
-> IO AdvisoryRows
forall a. RuleDeps -> (Maybe (DbEtag, CveLookup) -> IO a) -> IO a
withCveLookup RuleDeps
deps (((DbEtag, CveLookup) -> IO (DbEtag, PackageAdvisories))
-> Maybe (DbEtag, CveLookup) -> IO AdvisoryRows
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) -> Maybe a -> f (Maybe b)
traverse (\(DbEtag
etag, CveLookup
cve) -> (DbEtag
etag,) (PackageAdvisories -> (DbEtag, PackageAdvisories))
-> ([AdvisoryRange] -> PackageAdvisories)
-> [AdvisoryRange]
-> (DbEtag, PackageAdvisories)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ecosystem -> [AdvisoryRange] -> PackageAdvisories
packageAdvisories (PackageName -> Ecosystem
pkgEcosystem PackageName
name) ([AdvisoryRange] -> (DbEtag, PackageAdvisories))
-> IO [AdvisoryRange] -> IO (DbEtag, PackageAdvisories)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CveLookup -> Text -> IO [AdvisoryRange]
cveAdvisoriesFor CveLookup
cve (ShortText -> Text
TS.toText (PackageName -> ShortText
pkgCanonical PackageName
name))))

-- | Where a built-in rule's verdict comes from.
data VerdictSource
    = -- | One version's evidence and the request context.
      FromEvidence (EvalContext -> RuleEvidence -> RuleVerdict)
    | -- | The package's advisory rows, with how the rule resolves when it cannot read them.
      FromAdvisories AdvisoryAlignment (AdvisoryRows -> RuleEvidence -> RuleVerdict)

-- | How an advisory rule resolves when it cannot read: on an expired push, and on a faulted read.
data AdvisoryAlignment = AdvisoryAlignment
    { AdvisoryAlignment -> FailureAlignment
onExpiredPush :: FailureAlignment
    -- ^ Fixed per rule, since expiry is unavailability configuration cannot waive.
    , AdvisoryAlignment -> FailureAlignment
onFaultedRead :: FailureAlignment
    -- ^ The rule's configured alignment for a timeout, a spent retry budget, or an open breaker.
    }

{- | The single dispatch over the closed vocabulary. A rule that reads a fact nothing supplied
refuses rather than abstaining, so the fold stops at it.
-}
verdictSource :: Rule -> VerdictSource
verdictSource :: Rule -> VerdictSource
verdictSource = \case
    AllowScope Scope
scope -> (EvalContext -> RuleEvidence -> RuleVerdict) -> VerdictSource
FromEvidence ((EvalContext -> RuleEvidence -> RuleVerdict) -> VerdictSource)
-> (EvalContext -> RuleEvidence -> RuleVerdict) -> VerdictSource
forall a b. (a -> b) -> a -> b
$ \EvalContext
_ RuleEvidence
ev -> case PackageName -> Maybe Scope
pkgNamespace (RuleEvidence -> PackageName
evName RuleEvidence
ev) 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)
    AllowIfOlderThan NominalDiffTime
minAge -> (EvalContext -> RuleEvidence -> RuleVerdict) -> VerdictSource
FromEvidence ((EvalContext -> RuleEvidence -> RuleVerdict) -> VerdictSource)
-> (EvalContext -> RuleEvidence -> RuleVerdict) -> VerdictSource
forall a b. (a -> b) -> a -> b
$ \EvalContext
ctx RuleEvidence
ev -> case RuleEvidence -> Fact (Maybe UTCTime)
evPublishedAt RuleEvidence
ev of
        Fact (Maybe UTCTime)
Unread -> Text -> Text -> RuleVerdict
needsFact Text
"AllowIfOlderThan" Text
"the publish time"
        Known Maybe UTCTime
Nothing -> Text -> RuleVerdict
NoDecision Text
"publish time is unknown"
        Known (Just UTCTime
publishedAt) -> NominalDiffTime -> NominalDiffTime -> RuleVerdict
ageVerdict NominalDiffTime
minAge (UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime (EvalContext -> UTCTime
ctxNow EvalContext
ctx) UTCTime
publishedAt)
    Rule
DenyInstallTimeExecution -> (EvalContext -> RuleEvidence -> RuleVerdict) -> VerdictSource
FromEvidence ((EvalContext -> RuleEvidence -> RuleVerdict) -> VerdictSource)
-> (EvalContext -> RuleEvidence -> RuleVerdict) -> VerdictSource
forall a b. (a -> b) -> a -> b
$ \EvalContext
_ RuleEvidence
ev -> case RuleEvidence -> Fact CodeExecSignal
evInstallCode RuleEvidence
ev of
        Fact CodeExecSignal
Unread -> Text -> Text -> RuleVerdict
needsFact Text
"DenyInstallTimeExecution" Text
"the install-time execution signal"
        Known (RunsCodeOnInstall Text
how) -> Maybe DbEtag -> Text -> RuleVerdict
Deny Maybe DbEtag
forall a. Maybe a
Nothing (Text
"runs code on install: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
how)
        Known CodeExecSignal
NoCodeOnInstall -> Text -> RuleVerdict
NoDecision Text
"no install-time code execution"
        Known CodeExecSignal
CodeExecUnknown -> Text -> RuleVerdict
NoDecision Text
"install-time code execution not yet determined"
    DenyByIdentity Text
ident -> (EvalContext -> RuleEvidence -> RuleVerdict) -> VerdictSource
FromEvidence ((EvalContext -> RuleEvidence -> RuleVerdict) -> VerdictSource)
-> (EvalContext -> RuleEvidence -> RuleVerdict) -> VerdictSource
forall a b. (a -> b) -> a -> b
$ \EvalContext
_ RuleEvidence
ev ->
        if Text -> RuleEvidence -> Bool
matchesIdentity Text
ident RuleEvidence
ev
            then Maybe DbEtag -> Text -> RuleVerdict
Deny Maybe DbEtag
forall a. Maybe a
Nothing (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)
    AllowByIdentity Text
ident -> (EvalContext -> RuleEvidence -> RuleVerdict) -> VerdictSource
FromEvidence ((EvalContext -> RuleEvidence -> RuleVerdict) -> VerdictSource)
-> (EvalContext -> RuleEvidence -> RuleVerdict) -> VerdictSource
forall a b. (a -> b) -> a -> b
$ \EvalContext
_ RuleEvidence
ev ->
        if Text -> RuleEvidence -> Bool
matchesIdentity Text
ident RuleEvidence
ev
            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)
    -- Expiry abstains on the remediation allow, so a deny's refusal is what the version meets.
    Rule
AllowIfRemediatesCve -> AdvisoryAlignment
-> (AdvisoryRows -> RuleEvidence -> RuleVerdict) -> VerdictSource
FromAdvisories (FailureAlignment -> FailureAlignment -> AdvisoryAlignment
AdvisoryAlignment FailureAlignment
FailNoDecision FailureAlignment
FailNoDecision) ((AdvisoryRows -> RuleEvidence -> RuleVerdict) -> VerdictSource)
-> (AdvisoryRows -> RuleEvidence -> RuleVerdict) -> VerdictSource
forall a b. (a -> b) -> a -> b
$ \case
        AdvisoryRows
Nothing -> RuleVerdict -> RuleEvidence -> RuleVerdict
forall a b. a -> b -> a
const (Text -> RuleVerdict
NoDecision Text
"no advisory database is loaded")
        Just (DbEtag
_, PackageAdvisories
advisories) -> PackageAdvisories -> RuleEvidence -> RuleVerdict
classifyRanges PackageAdvisories
advisories
    -- A deny's configured alignment governs a faulted read and an unloaded database alike.
    DenyIfCve DenyIfCveParams
params -> AdvisoryAlignment
-> (AdvisoryRows -> RuleEvidence -> RuleVerdict) -> VerdictSource
FromAdvisories (FailureAlignment -> FailureAlignment -> AdvisoryAlignment
AdvisoryAlignment FailureAlignment
FailDeny (DenyIfCveParams -> FailureAlignment
dicOnUnavailable DenyIfCveParams
params)) ((AdvisoryRows -> RuleEvidence -> RuleVerdict) -> VerdictSource)
-> (AdvisoryRows -> RuleEvidence -> RuleVerdict) -> VerdictSource
forall a b. (a -> b) -> a -> b
$ \case
        AdvisoryRows
Nothing -> RuleVerdict -> RuleEvidence -> RuleVerdict
forall a b. a -> b -> a
const (Text -> FailureAlignment -> RuleVerdict
noAdvisoryDbVerdict Text
"DenyIfCve" (DenyIfCveParams -> FailureAlignment
dicOnUnavailable DenyIfCveParams
params))
        Just (DbEtag
etag, PackageAdvisories
advisories) -> DbEtag
-> MissingScorePolicy
-> Text
-> Double
-> (AdvisoryRange -> Maybe Double)
-> PackageAdvisories
-> RuleEvidence
-> RuleVerdict
advisoryDenyVerdict DbEtag
etag MissingScorePolicy
DenyMissingScore Text
"CVSS" (DenyIfCveParams -> Double
dicMinCvss DenyIfCveParams
params) AdvisoryRange -> Maybe Double
arSeverity PackageAdvisories
advisories
    DenyIfEpss DenyIfEpssParams
params -> AdvisoryAlignment
-> (AdvisoryRows -> RuleEvidence -> RuleVerdict) -> VerdictSource
FromAdvisories (FailureAlignment -> FailureAlignment -> AdvisoryAlignment
AdvisoryAlignment FailureAlignment
FailDeny (DenyIfEpssParams -> FailureAlignment
dieOnUnavailable DenyIfEpssParams
params)) ((AdvisoryRows -> RuleEvidence -> RuleVerdict) -> VerdictSource)
-> (AdvisoryRows -> RuleEvidence -> RuleVerdict) -> VerdictSource
forall a b. (a -> b) -> a -> b
$ \case
        AdvisoryRows
Nothing -> RuleVerdict -> RuleEvidence -> RuleVerdict
forall a b. a -> b -> a
const (Text -> FailureAlignment -> RuleVerdict
noAdvisoryDbVerdict Text
"DenyIfEpss" (DenyIfEpssParams -> FailureAlignment
dieOnUnavailable DenyIfEpssParams
params))
        Just (DbEtag
etag, PackageAdvisories
advisories) -> DbEtag
-> MissingScorePolicy
-> Text
-> Double
-> (AdvisoryRange -> Maybe Double)
-> PackageAdvisories
-> RuleEvidence
-> RuleVerdict
advisoryDenyVerdict DbEtag
etag MissingScorePolicy
AbstainMissingScore Text
"EPSS" (DenyIfEpssParams -> Double
dieMinEpss DenyIfEpssParams
params) AdvisoryRange -> Maybe Double
arEpss PackageAdvisories
advisories

{- The minimum-age verdict for a version whose publish time the evidence carries. The quarantine
holds a new version until the registry has had time to yank a malicious publish. -}
ageVerdict :: NominalDiffTime -> NominalDiffTime -> RuleVerdict
ageVerdict :: NominalDiffTime -> NominalDiffTime -> RuleVerdict
ageVerdict NominalDiffTime
minAge NominalDiffTime
age
    | NominalDiffTime
age NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
>= NominalDiffTime
minAge =
        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)")
    | Bool
otherwise =
        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)

{- The verdict when the evidence carries no reading of a fact the rule consults. It is fail-closed so
the fold stops here, rather than letting a lower-precedence rule decide past an unresolved one. -}
needsFact :: Text -> Text -> RuleVerdict
needsFact :: Text -> Text -> RuleVerdict
needsFact Text
rule Text
fact = FailureAlignment -> Text -> RuleVerdict
CannotVet FailureAlignment
FailDeny (Text
rule Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fact Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is not available")

{- The verdict when no advisory database is loaded. It is a 'CannotVet' verdict and not a
fault, because no in-process retry could load one, so the harness never retries it. -}
noAdvisoryDbVerdict :: Text -> FailureAlignment -> RuleVerdict
noAdvisoryDbVerdict :: Text -> FailureAlignment -> RuleVerdict
noAdvisoryDbVerdict Text
rule FailureAlignment
alignment = FailureAlignment -> Text -> RuleVerdict
CannotVet FailureAlignment
alignment (Text
rule Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": no advisory database loaded")

-- The score filter and the reason texts no version changes are built once per read.
advisoryDenyVerdict :: DbEtag -> MissingScorePolicy -> Text -> Double -> (AdvisoryRange -> Maybe Double) -> PackageAdvisories -> RuleEvidence -> RuleVerdict
advisoryDenyVerdict :: DbEtag
-> MissingScorePolicy
-> Text
-> Double
-> (AdvisoryRange -> Maybe Double)
-> PackageAdvisories
-> RuleEvidence
-> RuleVerdict
advisoryDenyVerdict DbEtag
etag MissingScorePolicy
missing Text
metric Double
threshold AdvisoryRange -> Maybe Double
scoreOf PackageAdvisories
advisories = \RuleEvidence
ev ->
    case [Text] -> [Text]
forall a. Ord a => [a] -> [a]
ordNub ((AdvisoryRange -> Text) -> [AdvisoryRange] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map AdvisoryRange -> Text
arCveId (PackageAdvisories -> Version -> [AdvisoryRange]
affecting PackageAdvisories
scored (RuleEvidence -> Version
evVersion RuleEvidence
ev))) of
        [] -> RuleVerdict
unaffected
        [Text]
ids -> Maybe DbEtag -> Text -> RuleVerdict
Deny (DbEtag -> Maybe DbEtag
forall a. a -> Maybe a
Just DbEtag
etag) (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
thresholdNote)
  where
    scored :: PackageAdvisories
scored = (AdvisoryRange -> Bool) -> PackageAdvisories -> PackageAdvisories
keepAdvisories (MissingScorePolicy -> Double -> Maybe Double -> Bool
scoreAtLeast MissingScorePolicy
missing Double
threshold (Maybe Double -> Bool)
-> (AdvisoryRange -> Maybe Double) -> AdvisoryRange -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AdvisoryRange -> Maybe Double
scoreOf) PackageAdvisories
advisories
    unaffected :: RuleVerdict
unaffected = Text -> RuleVerdict
NoDecision (Text
"no advisory at or above the " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
metric Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" threshold affects this version")
    thresholdNote :: Text
thresholdNote = Text
" (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
metric Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" >= " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Double -> Text
forall b a. (Show a, IsString b) => a -> b
show Double
threshold Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"

-- | Read the advisory identifiers from a scored denial reason, or return none.
cveIdsInReason :: Text -> [Text]
cveIdsInReason :: Text -> [Text]
cveIdsInReason Text
message
    | Text -> Bool
T.null Text
afterThreshold = []
    | 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).
    -- An absent marker leaves the body empty, so 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
afterThreshold) = HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOn Text
" (" Text
body

-- A version still inside any advisory's affected range, an unfixed one included, must not fast-track.
classifyRanges :: PackageAdvisories -> RuleEvidence -> RuleVerdict
classifyRanges :: PackageAdvisories -> RuleEvidence -> RuleVerdict
classifyRanges PackageAdvisories
advisories RuleEvidence
ev =
    case ([Text]
remediated, [Text]
stillOpen) of
        ([], [Text]
_) -> 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)
        ([Text]
ids, [Text]
open) ->
            Text -> RuleVerdict
NoDecision (Text
"fixes " 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
" but is still affected by " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " [Text]
open)
  where
    remediated :: [Text]
remediated = [Text] -> [Text]
forall a. Ord a => [a] -> [a]
ordNub ((AdvisoryRange -> Text) -> [AdvisoryRange] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map AdvisoryRange -> Text
arCveId (PackageAdvisories -> Version -> [AdvisoryRange]
fixedAt PackageAdvisories
advisories (RuleEvidence -> Version
evVersion RuleEvidence
ev)))
    stillOpen :: [Text]
stillOpen = [Text] -> [Text]
forall a. Ord a => [a] -> [a]
ordNub ((AdvisoryRange -> Text) -> [AdvisoryRange] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map AdvisoryRange -> Text
arCveId (PackageAdvisories -> Version -> [AdvisoryRange]
affecting PackageAdvisories
advisories (RuleEvidence -> Version
evVersion RuleEvidence
ev)))

-- The one identity test the by-identity twins share: the exact rendered package
-- name, or the exact package@version.
matchesIdentity :: Text -> RuleEvidence -> Bool
matchesIdentity :: Text -> RuleEvidence -> Bool
matchesIdentity Text
ident RuleEvidence
ev =
    let pkgStr :: Text
pkgStr = PackageName -> Text
renderPackageName (RuleEvidence -> PackageName
evName RuleEvidence
ev)
        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 (RuleEvidence -> Version
evVersion RuleEvidence
ev)
     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

-- | Config obtains evaluators only through 'prepare', never from arbitrary code.
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 -> RuleEval
prepEval :: RuleEval
    -- ^ How the rule reaches the versions an evaluator decides.
    }

-- | How a prepared rule reaches the versions an evaluator decides.
data RuleEval
    = -- | Each version's verdict on its own. A throw refuses admission.
      PerVersion (EvalContext -> RuleEvidence -> IO RuleVerdict)
    | -- | A verdict for each version from the evaluator's one advisory read of the package.
      PerPackage PackageRead

{- | An advisory rule: how to make the evaluator's shared read when this rule reaches it first, and
how the rule decides from that read.
-}
data PackageRead = PackageRead
    { PackageRead -> IO AdvisoryFreshness
prFreshness :: IO AdvisoryFreshness
    -- ^ The push-age reading, taken ahead of the breaker.
    , PackageRead -> Maybe Resilience
prResilience :: Maybe Resilience
    -- ^ The policy around the read, or 'Nothing' where no database is configured and the read does no IO.
    , PackageRead -> PackageName -> IO AdvisoryRows
prRows :: PackageName -> IO AdvisoryRows
    -- ^ The package's rows in one pinned generation.
    , PackageRead -> AdvisoryAlignment
prAlignment :: AdvisoryAlignment
    -- ^ How this rule resolves an ineligible push and a faulted read.
    , PackageRead -> AdvisoryRows -> RuleEvidence -> RuleVerdict
prVerdict :: AdvisoryRows -> RuleEvidence -> RuleVerdict
    -- ^ This rule's verdict for each version, from the rows.
    , PackageRead -> SourceReporter
prReporter :: SourceReporter
    -- ^ Where this rule reports whether the read let it consult the source.
    }

-- | The resilience policy a prepared rule's package read runs under, if any.
prepResilience :: PreparedRule -> Maybe Resilience
prepResilience :: PreparedRule -> Maybe Resilience
prepResilience PreparedRule
rule = case PreparedRule -> RuleEval
prepEval PreparedRule
rule of
    PerVersion EvalContext -> RuleEvidence -> IO RuleVerdict
_ -> Maybe Resilience
forall a. Maybe a
Nothing
    PerPackage PackageRead
packageRead -> PackageRead -> Maybe Resilience
prResilience PackageRead
packageRead

{- | Allocate each advisory rule's breaker once. With no advisory database configured, an advisory
rule's read does no IO and returns the rule's fixed verdict, so it runs without resilience.
-}
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)

prepareRule :: RuleDeps -> PrecededRule -> IO PreparedRule
prepareRule :: RuleDeps -> PrecededRule -> IO PreparedRule
prepareRule RuleDeps
deps (PrecededRule Int
prec Rule
rule) = do
    eval <- case Rule -> VerdictSource
verdictSource Rule
rule of
        FromEvidence EvalContext -> RuleEvidence -> RuleVerdict
verdict -> RuleEval -> IO RuleEval
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((EvalContext -> RuleEvidence -> IO RuleVerdict) -> RuleEval
PerVersion (\EvalContext
ctx -> RuleVerdict -> IO RuleVerdict
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RuleVerdict -> IO RuleVerdict)
-> (RuleEvidence -> RuleVerdict) -> RuleEvidence -> IO RuleVerdict
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EvalContext -> RuleEvidence -> RuleVerdict
verdict EvalContext
ctx))
        FromAdvisories AdvisoryAlignment
alignment AdvisoryRows -> RuleEvidence -> RuleVerdict
verdict -> PackageRead -> RuleEval
PerPackage (PackageRead -> RuleEval) -> IO PackageRead -> IO RuleEval
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RuleDeps
-> AdvisoryAlignment
-> (AdvisoryRows -> RuleEvidence -> RuleVerdict)
-> IO PackageRead
advisoryRead RuleDeps
deps AdvisoryAlignment
alignment AdvisoryRows -> RuleEvidence -> RuleVerdict
verdict
    pure PreparedRule{prepName = ruleName rule, prepPrecedence = prec, prepEval = eval}

advisoryRead :: RuleDeps -> AdvisoryAlignment -> (AdvisoryRows -> RuleEvidence -> RuleVerdict) -> IO PackageRead
advisoryRead :: RuleDeps
-> AdvisoryAlignment
-> (AdvisoryRows -> RuleEvidence -> RuleVerdict)
-> IO PackageRead
advisoryRead RuleDeps
deps AdvisoryAlignment
alignment AdvisoryRows -> RuleEvidence -> RuleVerdict
verdict = do
    resilience <- case RuleDeps -> AdvisoryDatabase
rdAdvisoryDatabase RuleDeps
deps of
        AdvisoryDatabase
NoAdvisoryDatabase -> 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
        AdvisoryDatabase forall a. (Maybe (DbEtag, CveLookup) -> IO a) -> IO a
_ -> Resilience -> Maybe Resilience
forall a. a -> Maybe a
Just (Resilience -> Maybe Resilience)
-> IO Resilience -> IO (Maybe Resilience)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RuleDeps -> IO Resilience
newResilience RuleDeps
deps
    pure
        PackageRead
            { prFreshness = rdAdvisoryFreshness deps
            , prResilience = resilience
            , prRows = readAdvisories deps
            , prAlignment = alignment
            , prVerdict = verdict
            , prReporter = rdSourceReporter deps
            }

newResilience :: RuleDeps -> IO Resilience
newResilience :: RuleDeps -> IO Resilience
newResilience RuleDeps
deps = do
    breaker <- IO (TVar Breaker)
newBreaker
    pure
        Resilience
            { resConfig = defaultEffectfulConfig
            , resBreaker = breaker
            , resBreakerReporter = rdBreakerReporter deps
            , resClock = getCurrentTime
            }

-- | Sort by descending precedence, then ascending rule name, independently of configuration order.
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))

-- Both 'bootOrder' and the engine order through this one key, so the tiebreak lives in
-- exactly one place.
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 line per rule, in evaluation order, so an operator sees
at boot how their policy will resolve.
-}
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
")"

{- | An evaluator for one request's versions, in boot order. Its advisory rules must come from one
'prepare', since the first reached reads the package once for them all. A throw refuses.
-}
newEvaluator :: EvalContext -> [PreparedRule] -> IO (RuleEvidence -> IO Decision)
newEvaluator :: EvalContext -> [PreparedRule] -> IO (RuleEvidence -> IO Decision)
newEvaluator EvalContext
ctx [PreparedRule]
rules = do
    shared <- IO (PackageCell (Either Text AdvisoryRead))
forall a. IO (PackageCell a)
newPackageCell
    bound <- traverse (\PreparedRule
rule -> (PreparedRule
rule,) (VersionEval -> (PreparedRule, VersionEval))
-> IO VersionEval -> IO (PreparedRule, VersionEval)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EvalContext
-> PackageCell (Either Text AdvisoryRead)
-> PreparedRule
-> IO VersionEval
bindRule EvalContext
ctx PackageCell (Either Text AdvisoryRead)
shared PreparedRule
rule) (bootOrder rules)
    pure (\RuleEvidence
ev -> RuleEvidence
-> [(PreparedRule, VersionEval)] -> [Passed] -> IO Decision
stepRules RuleEvidence
ev [(PreparedRule, VersionEval)]
bound [])

-- | Decide one version through a fresh 'newEvaluator'.
evalRules :: EvalContext -> [PreparedRule] -> RuleEvidence -> IO Decision
evalRules :: EvalContext -> [PreparedRule] -> RuleEvidence -> IO Decision
evalRules EvalContext
ctx [PreparedRule]
rules RuleEvidence
ev = EvalContext -> [PreparedRule] -> IO (RuleEvidence -> IO Decision)
newEvaluator EvalContext
ctx [PreparedRule]
rules IO (RuleEvidence -> IO Decision)
-> ((RuleEvidence -> IO Decision) -> 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
>>= ((RuleEvidence -> IO Decision) -> RuleEvidence -> IO Decision
forall a b. (a -> b) -> a -> b
$ RuleEvidence
ev)

-- One rule as an evaluator runs it for each version: its evaluation, or what it threw.
type VersionEval = RuleEvidence -> IO (Either Text RuleEvaluation)

bindRule :: EvalContext -> PackageCell (Either Text AdvisoryRead) -> PreparedRule -> IO VersionEval
bindRule :: EvalContext
-> PackageCell (Either Text AdvisoryRead)
-> PreparedRule
-> IO VersionEval
bindRule EvalContext
ctx PackageCell (Either Text AdvisoryRead)
shared PreparedRule
rule = case PreparedRule -> RuleEval
prepEval PreparedRule
rule of
    PerVersion EvalContext -> RuleEvidence -> IO RuleVerdict
eval -> VersionEval -> IO VersionEval
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IO RuleEvaluation -> IO (Either Text RuleEvaluation)
forall a. IO a -> IO (Either Text a)
caught (IO RuleEvaluation -> IO (Either Text RuleEvaluation))
-> (RuleEvidence -> IO RuleEvaluation) -> VersionEval
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RuleVerdict -> RuleEvaluation)
-> IO RuleVerdict -> IO RuleEvaluation
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RuleVerdict -> RuleEvaluation
Decided (IO RuleVerdict -> IO RuleEvaluation)
-> (RuleEvidence -> IO RuleVerdict)
-> RuleEvidence
-> IO RuleEvaluation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EvalContext -> RuleEvidence -> IO RuleVerdict
eval EvalContext
ctx)
    PerPackage PackageRead
packageRead -> do
        own <- IO (PackageCell (Either Text (RuleEvidence -> RuleEvaluation)))
forall a. IO (PackageCell a)
newPackageCell
        pure $ \RuleEvidence
ev -> ((RuleEvidence -> RuleEvaluation) -> RuleEvaluation)
-> Either Text (RuleEvidence -> RuleEvaluation)
-> Either Text RuleEvaluation
forall a b. (a -> b) -> Either Text a -> Either Text b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((RuleEvidence -> RuleEvaluation) -> RuleEvidence -> RuleEvaluation
forall a b. (a -> b) -> a -> b
$ RuleEvidence
ev) (Either Text (RuleEvidence -> RuleEvaluation)
 -> Either Text RuleEvaluation)
-> IO (Either Text (RuleEvidence -> RuleEvaluation))
-> IO (Either Text RuleEvaluation)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PackageCell (Either Text (RuleEvidence -> RuleEvaluation))
-> PackageName
-> IO (Either Text (RuleEvidence -> RuleEvaluation))
-> IO (Either Text (RuleEvidence -> RuleEvaluation))
forall a. PackageCell a -> PackageName -> IO a -> IO a
heldFor PackageCell (Either Text (RuleEvidence -> RuleEvaluation))
own (RuleEvidence -> PackageName
evName RuleEvidence
ev) (Text
-> PackageRead
-> PackageCell (Either Text AdvisoryRead)
-> RuleEvidence
-> IO (Either Text (RuleEvidence -> RuleEvaluation))
decideFromRead (PreparedRule -> Text
prepName PreparedRule
rule) PackageRead
packageRead PackageCell (Either Text AdvisoryRead)
shared RuleEvidence
ev)

caught :: IO a -> IO (Either Text a)
caught :: forall a. IO a -> IO (Either Text a)
caught = (Either SomeException a -> Either Text a)
-> IO (Either SomeException a) -> IO (Either Text a)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((SomeException -> Text) -> Either SomeException a -> Either Text a
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first SomeException -> Text
forall e. Exception e => e -> Text
displayExceptionT) (IO (Either SomeException a) -> IO (Either Text a))
-> (IO a -> IO (Either SomeException a))
-> IO a
-> IO (Either Text a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> IO (Either SomeException a)
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny

-- A result held for the last package decided. Another package computes its own, never borrowing it.
newtype PackageCell a = PackageCell (MVar (Maybe (PackageName, a)))

newPackageCell :: IO (PackageCell a)
newPackageCell :: forall a. IO (PackageCell a)
newPackageCell = MVar (Maybe (PackageName, a)) -> PackageCell a
forall a. MVar (Maybe (PackageName, a)) -> PackageCell a
PackageCell (MVar (Maybe (PackageName, a)) -> PackageCell a)
-> IO (MVar (Maybe (PackageName, a))) -> IO (PackageCell a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (PackageName, a) -> IO (MVar (Maybe (PackageName, a)))
forall (m :: * -> *) a. MonadIO m => a -> m (MVar a)
newMVar Maybe (PackageName, a)
forall a. Maybe a
Nothing

heldFor :: PackageCell a -> PackageName -> IO a -> IO a
heldFor :: forall a. PackageCell a -> PackageName -> IO a -> IO a
heldFor (PackageCell MVar (Maybe (PackageName, a))
held) PackageName
package IO a
compute =
    MVar (Maybe (PackageName, a))
-> (Maybe (PackageName, a) -> IO (Maybe (PackageName, a), a))
-> IO a
forall (m :: * -> *) a b.
MonadUnliftIO m =>
MVar a -> (a -> m (a, b)) -> m b
modifyMVar MVar (Maybe (PackageName, a))
held ((Maybe (PackageName, a) -> IO (Maybe (PackageName, a), a))
 -> IO a)
-> (Maybe (PackageName, a) -> IO (Maybe (PackageName, a), a))
-> IO a
forall a b. (a -> b) -> a -> b
$ \case
        Just (PackageName
known, a
value) | PackageName
known PackageName -> PackageName -> Bool
forall a. Eq a => a -> a -> Bool
== PackageName
package -> (Maybe (PackageName, a), a) -> IO (Maybe (PackageName, a), a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((PackageName, a) -> Maybe (PackageName, a)
forall a. a -> Maybe a
Just (PackageName
known, a
value), a
value)
        Maybe (PackageName, a)
_ -> (\a
value -> ((PackageName, a) -> Maybe (PackageName, a)
forall a. a -> Maybe a
Just (PackageName
package, a
value), a
value)) (a -> (Maybe (PackageName, a), a))
-> IO a -> IO (Maybe (PackageName, a), a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a
compute

-- The evaluator's one advisory read of a package: its rows, or why it has none.
data AdvisoryRead
    = RowsRead AdvisoryRows
    | PushIneligible Text
    | ReadGivenUp ReadFault

{- One rule's evaluation of every version from the shared read, made by this rule if it is the first
reached. The rule reports once per package whether the read let it consult the source. -}
decideFromRead :: Text -> PackageRead -> PackageCell (Either Text AdvisoryRead) -> RuleEvidence -> IO (Either Text (RuleEvidence -> RuleEvaluation))
decideFromRead :: Text
-> PackageRead
-> PackageCell (Either Text AdvisoryRead)
-> RuleEvidence
-> IO (Either Text (RuleEvidence -> RuleEvaluation))
decideFromRead Text
name PackageRead
packageRead PackageCell (Either Text AdvisoryRead)
shared RuleEvidence
reaching =
    PackageCell (Either Text AdvisoryRead)
-> PackageName
-> IO (Either Text AdvisoryRead)
-> IO (Either Text AdvisoryRead)
forall a. PackageCell a -> PackageName -> IO a -> IO a
heldFor PackageCell (Either Text AdvisoryRead)
shared PackageName
package (IO AdvisoryRead -> IO (Either Text AdvisoryRead)
forall a. IO a -> IO (Either Text a)
caught (PackageRead -> PackageName -> IO AdvisoryRead
readShared PackageRead
packageRead PackageName
package)) IO (Either Text AdvisoryRead)
-> (Either Text AdvisoryRead
    -> IO (Either Text (RuleEvidence -> RuleEvaluation)))
-> IO (Either Text (RuleEvidence -> RuleEvaluation))
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 Text
escape -> Either Text (RuleEvidence -> RuleEvaluation)
-> IO (Either Text (RuleEvidence -> RuleEvaluation))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Either Text (RuleEvidence -> RuleEvaluation)
forall a b. a -> Either a b
Left Text
escape)
        Right AdvisoryRead
advisory ->
            IO (RuleEvidence -> RuleEvaluation)
-> IO (Either Text (RuleEvidence -> RuleEvaluation))
forall a. IO a -> IO (Either Text a)
caught (Text
-> PackageRead -> AdvisoryRead -> RuleEvidence -> RuleEvaluation
resolveRead Text
name PackageRead
packageRead AdvisoryRead
advisory (RuleEvidence -> RuleEvaluation)
-> IO () -> IO (RuleEvidence -> RuleEvaluation)
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ SourceReporter -> SourceHealth -> IO ()
reportSource (PackageRead -> SourceReporter
prReporter PackageRead
packageRead) (Text -> PackageRead -> AdvisoryRead -> RuleEvidence -> SourceHealth
readHealth Text
name PackageRead
packageRead AdvisoryRead
advisory RuleEvidence
reaching))
  where
    package :: PackageName
package = RuleEvidence -> PackageName
evName RuleEvidence
reaching

{- The push-age gate, then the rows under the reading rule's resilience. The gate runs ahead of
breaker admission, which an open breaker would otherwise skip past. -}
readShared :: PackageRead -> PackageName -> IO AdvisoryRead
readShared :: PackageRead -> PackageName -> IO AdvisoryRead
readShared PackageRead
packageRead PackageName
package =
    PackageRead -> IO AdvisoryFreshness
prFreshness PackageRead
packageRead IO AdvisoryFreshness
-> (AdvisoryFreshness -> IO AdvisoryRead) -> IO AdvisoryRead
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \AdvisoryFreshness
freshness -> case AdvisoryFreshness -> Maybe Text
renderIneligible AdvisoryFreshness
freshness of
        Just Text
why -> AdvisoryRead -> IO AdvisoryRead
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> AdvisoryRead
PushIneligible Text
why)
        Maybe Text
Nothing -> case PackageRead -> Maybe Resilience
prResilience PackageRead
packageRead of
            Maybe Resilience
Nothing -> AdvisoryRows -> AdvisoryRead
RowsRead (AdvisoryRows -> AdvisoryRead)
-> IO AdvisoryRows -> IO AdvisoryRead
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PackageRead -> PackageName -> IO AdvisoryRows
prRows PackageRead
packageRead PackageName
package
            Just Resilience
res -> (ReadFault -> AdvisoryRead)
-> (AdvisoryRows -> AdvisoryRead)
-> Either ReadFault AdvisoryRows
-> AdvisoryRead
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ReadFault -> AdvisoryRead
ReadGivenUp AdvisoryRows -> AdvisoryRead
RowsRead (Either ReadFault AdvisoryRows -> AdvisoryRead)
-> IO (Either ReadFault AdvisoryRows) -> IO AdvisoryRead
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Resilience -> IO AdvisoryRows -> IO (Either ReadFault AdvisoryRows)
forall a. Resilience -> IO a -> IO (Either ReadFault a)
runResilient Resilience
res (PackageRead -> PackageName -> IO AdvisoryRows
prRows PackageRead
packageRead PackageName
package)

-- One rule's evaluation of each version, under its own alignments. A fault resolves all alike.
resolveRead :: Text -> PackageRead -> AdvisoryRead -> RuleEvidence -> RuleEvaluation
resolveRead :: Text
-> PackageRead -> AdvisoryRead -> RuleEvidence -> RuleEvaluation
resolveRead Text
name PackageRead
packageRead = \case
    RowsRead AdvisoryRows
rows -> RuleVerdict -> RuleEvaluation
Decided (RuleVerdict -> RuleEvaluation)
-> (RuleEvidence -> RuleVerdict) -> RuleEvidence -> RuleEvaluation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageRead -> AdvisoryRows -> RuleEvidence -> RuleVerdict
prVerdict PackageRead
packageRead AdvisoryRows
rows
    PushIneligible Text
why -> RuleEvaluation -> RuleEvidence -> RuleEvaluation
forall a b. a -> b -> a
const (RuleVerdict -> RuleEvaluation
Decided (FailureAlignment -> Text -> RuleVerdict
CannotVet (AdvisoryAlignment -> FailureAlignment
onExpiredPush AdvisoryAlignment
alignment) (Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
why)))
    ReadGivenUp ReadFault
fault -> RuleEvaluation -> RuleEvidence -> RuleEvaluation
forall a b. a -> b -> a
const (Transience -> FailureAlignment -> Text -> RuleEvaluation
Unavailable (ReadFault -> Transience
rfTransience ReadFault
fault) (AdvisoryAlignment -> FailureAlignment
onFaultedRead AdvisoryAlignment
alignment) (Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ReadFault -> Text
rfReason ReadFault
fault))
  where
    alignment :: AdvisoryAlignment
alignment = PackageRead -> AdvisoryAlignment
prAlignment PackageRead
packageRead

-- Whether the read let one rule consult the source: only a rule that could not vet says it did not.
readHealth :: Text -> PackageRead -> AdvisoryRead -> RuleEvidence -> SourceHealth
readHealth :: Text -> PackageRead -> AdvisoryRead -> RuleEvidence -> SourceHealth
readHealth Text
name PackageRead
packageRead AdvisoryRead
advisory RuleEvidence
reaching = case AdvisoryRead
advisory of
    RowsRead AdvisoryRows
rows -> case PackageRead -> AdvisoryRows -> RuleEvidence -> RuleVerdict
prVerdict PackageRead
packageRead AdvisoryRows
rows RuleEvidence
reaching of
        CannotVet FailureAlignment
_ Text
reason -> Text -> Text -> SourceHealth
SourceUnavailable Text
name (Text -> Text -> Text
bareCause Text
name Text
reason)
        Allow Text
_ -> Text -> SourceHealth
SourceAnswered Text
name
        Deny Maybe DbEtag
_ Text
_ -> Text -> SourceHealth
SourceAnswered Text
name
        NoDecision Text
_ -> Text -> SourceHealth
SourceAnswered Text
name
    PushIneligible Text
why -> Text -> Text -> SourceHealth
SourceUnavailable Text
name Text
why
    ReadGivenUp ReadFault
fault -> Text -> Text -> SourceHealth
SourceUnavailable Text
name (ReadFault -> Text
rfDetail ReadFault
fault)

-- 'passed' holds each non-decisive evaluation in reverse boot order. The deny-by-default trail
-- and an admission's skipped-check evidence both read it back.
stepRules :: RuleEvidence -> [(PreparedRule, VersionEval)] -> [Passed] -> IO Decision
stepRules :: RuleEvidence
-> [(PreparedRule, VersionEval)] -> [Passed] -> IO Decision
stepRules RuleEvidence
_ [] [Passed]
passed = Decision -> IO Decision
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Text] -> Decision
BlockedByDefault ((Passed -> Text) -> [Passed] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Passed -> Text
passedReason ([Passed] -> [Passed]
forall a. [a] -> [a]
reverse [Passed]
passed)))
stepRules RuleEvidence
ev ((PreparedRule
rule, VersionEval
eval) : [(PreparedRule, VersionEval)]
rest) [Passed]
passed =
    VersionEval
eval RuleEvidence
ev IO (Either Text RuleEvaluation)
-> (Either Text RuleEvaluation -> 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
        -- An evaluation that throws breaks its contract and must refuse admission.
        Left Text
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
rule Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": the rule threw: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
escape))
        Right RuleEvaluation
res -> case Text -> RuleEvaluation -> Maybe Decision
decisive (PreparedRule -> Text
prepName PreparedRule
rule) RuleEvaluation
res of
            Just Decision
d -> Decision -> IO Decision
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Passed] -> [PreparedRule] -> Decision -> Decision
withEvidence [Passed]
passed (((PreparedRule, VersionEval) -> PreparedRule)
-> [(PreparedRule, VersionEval)] -> [PreparedRule]
forall a b. (a -> b) -> [a] -> [b]
map (PreparedRule, VersionEval) -> PreparedRule
forall a b. (a, b) -> a
fst [(PreparedRule, VersionEval)]
rest) Decision
d)
            Maybe Decision
Nothing -> RuleEvidence
-> [(PreparedRule, VersionEval)] -> [Passed] -> IO Decision
stepRules RuleEvidence
ev [(PreparedRule, VersionEval)]
rest (Text -> RuleEvaluation -> Passed
Passed (PreparedRule -> Text
prepName PreparedRule
rule) RuleEvaluation
res Passed -> [Passed] -> [Passed]
forall a. a -> [a] -> [a]
: [Passed]
passed)

-- One non-decisive evaluation as the fold keeps it, so the trail and the evidence read one record.
data Passed = Passed Text RuleEvaluation

passedReason :: Passed -> Reason
passedReason :: Passed -> Text
passedReason (Passed Text
_ RuleEvaluation
res) = RuleEvaluation -> Text
reasonOf RuleEvaluation
res

-- The evidence a fail-open inability leaves. A fail-closed one is decisive, so it never passes.
skippedOf :: Passed -> Maybe SkippedCheck
skippedOf :: Passed -> Maybe SkippedCheck
skippedOf (Passed Text
name RuleEvaluation
res) = case RuleEvaluation
res of
    Decided (CannotVet FailureAlignment
alignment Text
reason) -> FailureAlignment -> Text -> Maybe SkippedCheck
skipped FailureAlignment
alignment Text
reason
    Unavailable Transience
_ FailureAlignment
alignment Text
reason -> FailureAlignment -> Text -> Maybe SkippedCheck
skipped FailureAlignment
alignment Text
reason
    Decided RuleVerdict
_ -> Maybe SkippedCheck
forall a. Maybe a
Nothing
  where
    skipped :: FailureAlignment -> Text -> Maybe SkippedCheck
skipped FailureAlignment
FailNoDecision Text
reason = SkippedCheck -> Maybe SkippedCheck
forall a. a -> Maybe a
Just (Text -> Text -> SkippedCheck
SkippedUnavailable Text
name (Text -> Text -> Text
bareCause Text
name Text
reason))
    skipped FailureAlignment
FailDeny Text
_ = Maybe SkippedCheck
forall a. Maybe a
Nothing

-- Only an admission carries evidence: the checks that could not vet ahead of it, in boot order,
-- then the ones it pre-empted.
withEvidence :: [Passed] -> [PreparedRule] -> Decision -> Decision
withEvidence :: [Passed] -> [PreparedRule] -> Decision -> Decision
withEvidence [Passed]
passed [PreparedRule]
unreached = \case
    Admitted Text
name Text
reason [SkippedCheck]
_ -> Text -> Text -> [SkippedCheck] -> Decision
Admitted Text
name Text
reason ([SkippedCheck] -> [SkippedCheck]
forall a. [a] -> [a]
reverse ((Passed -> Maybe SkippedCheck) -> [Passed] -> [SkippedCheck]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Passed -> Maybe SkippedCheck
skippedOf [Passed]
passed) [SkippedCheck] -> [SkippedCheck] -> [SkippedCheck]
forall a. Semigroup a => a -> a -> a
<> (PreparedRule -> SkippedCheck) -> [PreparedRule] -> [SkippedCheck]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> SkippedCheck
Unreached (Text -> SkippedCheck)
-> (PreparedRule -> Text) -> PreparedRule -> SkippedCheck
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PreparedRule -> Text
prepName) [PreparedRule]
unreached)
    Decision
other -> Decision
other

-- A verdict's reason names its rule for the audit trail. A record that names the rule in its own
-- field carries the cause alone.
bareCause :: Text -> Reason -> Reason
bareCause :: Text -> Text -> Text
bareCause Text
name Text
reason = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
reason (Text -> Text -> Maybe Text
T.stripPrefix (Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": ") Text
reason)

-- 'CannotVet' has no transience evidence, so it produces a plain retryable refusal. An admission's
-- evidence is attached by the fold, which alone knows what it passed and pre-empted.
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 -> [SkippedCheck] -> Decision
Admitted Text
name Text
reason [])
    Decided (Deny Maybe DbEtag
etag Text
reason) -> Decision -> Maybe Decision
forall a. a -> Maybe a
Just (Text -> Maybe DbEtag -> Text -> Decision
Blocked Text
name Maybe DbEtag
etag 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 Maybe DbEtag
_ Text
reason -> Text
reason
    NoDecision Text
reason -> Text
reason
    CannotVet FailureAlignment
_ Text
reason -> Text
reason

{- | Why a push is not eligible evidence, or 'Nothing' while it is. A serving generation the store
gave no publication time for reads as unverified, because its age cannot be established.
-}
renderIneligible :: AdvisoryFreshness -> Maybe Text
renderIneligible :: AdvisoryFreshness -> Maybe Text
renderIneligible = \case
    AdvisoryFreshness
AdvisoryFresh -> Maybe Text
forall a. Maybe a
Nothing
    AdvisoryAging{} -> Maybe Text
forall a. Maybe a
Nothing
    AdvisoryStale AdvisoryAge
observed -> Text -> Maybe Text
forall a. a -> Maybe a
Just (AdvisoryAge -> Text
renderExpiredPush AdvisoryAge
observed)
    AdvisoryFreshness
AdvisoryUndated -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"the object store reported no publication time for the serving advisory artifact"

-- An expired push: its age, the maximum it passed, and when it landed, so an operator can
-- tell an update outage from a maximum set too short.
renderExpiredPush :: AdvisoryAge -> Text
renderExpiredPush :: AdvisoryAge -> Text
renderExpiredPush AdvisoryAge
observed =
    Text
"the advisory push is "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> NominalDiffTime -> Text
renderDuration (AdvisoryAge -> NominalDiffTime
advisoryAge AdvisoryAge
observed)
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" old, past the maximum of "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> NominalDiffTime -> Text
renderDuration (AdvisoryAge -> NominalDiffTime
advisoryMaxAge AdvisoryAge
observed)
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (pushed at "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> UTCTime -> Text
renderIso8601Utc (AdvisoryAge -> UTCTime
advisoryPushedAt AdvisoryAge
observed)
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"

{- | A human-readable summary of a decision, suitable for logs and the denial
response body.
-}
renderDecision :: RuleEvidence -> Decision -> Text
renderDecision :: RuleEvidence -> Decision -> Text
renderDecision RuleEvidence
ev Decision
decision =
    let subject :: Text
subject = PackageName -> Text
renderPackageName (RuleEvidence -> PackageName
evName RuleEvidence
ev) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"@" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Version -> Text
renderVersion (RuleEvidence -> Version
evVersion RuleEvidence
ev)
     in case Decision
decision of
            Admitted Text
name Text
reason [SkippedCheck]
skipped ->
                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 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [SkippedCheck] -> Text
renderSkippedChecks [SkippedCheck]
skipped
            Blocked Text
name Maybe DbEtag
_ 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

-- The evidence as a parenthetical, so an admission's line never reads as if every check passed.
renderSkippedChecks :: [SkippedCheck] -> Text
renderSkippedChecks :: [SkippedCheck] -> Text
renderSkippedChecks [] = Text
""
renderSkippedChecks [SkippedCheck]
checks = Text
" (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
"; " ((SkippedCheck -> Text) -> [SkippedCheck] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map SkippedCheck -> Text
render [SkippedCheck]
checks) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
  where
    render :: SkippedCheck -> Text
render = \case
        SkippedUnavailable Text
rule Text
cause -> Text
"skipped for unavailability: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
rule Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
cause Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
        Unreached Text
rule -> Text
"not reached: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
rule

-- | Keep two non-zero units to distinguish near-threshold durations. Negative values render as zero.
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

durationLadder :: [(Text, Integer)]
durationLadder :: [(Text, Integer)]
durationLadder =
    [ (Text
"day", Integer
86400)
    , (Text
"hour", Integer
3600)
    , (Text
"minute", Integer
60)
    , (Text
"second", Integer
1)
    ]

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