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

-- | Decide stored versions from the store's evidence and hand named denials to its execution.
module Ecluse.Core.Registry.Sweep.Package (
    previewPackageGroup,
    sweepPackageGroup,
) where

import Data.Containers.ListUtils (nubOrdOn)
import Data.List (partition)
import Data.Set qualified as Set

import Ecluse.Core.Cve.Types (DbEtag)
import Ecluse.Core.Package (PackageName, renderPackageName)
import Ecluse.Core.Registry.Maintenance (
    StoreFault,
    StoreObservation (obReadManifest),
    StoredVersion (storedPresence, storedVersion),
    VersionOutcome (VersionRefused, VersionRemoved, VersionRemoving, VersionUncertain, VersionUnreached),
    VersionPresence (VersionServed),
    refusalCode,
    refusalDetail,
 )
import Ecluse.Core.Registry.Metadata (Manifest (manifestInfo))
import Ecluse.Core.Registry.Sweep.Deletion (Selection (Selection), deleteGroup)
import Ecluse.Core.Registry.Sweep.Outcome (
    CycleHalt,
    renderGeneration,
    renderStoreFault,
    unreadManifest,
 )
import Ecluse.Core.Registry.Sweep.Types (
    SweepAudit (auditError, auditInfo),
    SweepMount (smConfigured, smEcosystem, smFirstParty, smRuleDeps, smRules, smStore),
    SweepPacing (swpDeletionCap),
    SweepPorts (sweepAdvisoryEtag, sweepAudit, sweepNow, sweepReport),
    SweepReport (reportOpening, reportRemoval),
    SweepState (stIssued),
    SweepStore (ssObserve),
    countingAt,
    locatedPorts,
    record,
    recordGap,
    recordMetric,
    recordTally,
 )
import Ecluse.Core.Rules (RuleDeps (rdAdvisoryFreshness), newEvaluator, renderIneligible)
import Ecluse.Core.Rules.Types (Decision (Blocked), EvalContext, Reason, RuleEvidence, completeEvidence, identityEvidence, mkEvalContext, readsAdvisories, ruleName)
import Ecluse.Core.Server.Metadata (selectVersion)
import Ecluse.Core.Telemetry.Metrics (SweepResult (SweepExamined, SweepGuardSkipped, SweepKept))
import Ecluse.Core.Version (Version, renderVersion)

{- | One version a named decisive deny condemned, with the rule that named it. Its audit line
and its deletion both read this, so neither can credit a rule the other did not.
-}
data Condemned = Condemned
    { Condemned -> Version
cdVersion :: Version
    , Condemned -> Text
cdRule :: Text
    , Condemned -> Maybe DbEtag
cdAdvisoryEtag :: Maybe DbEtag
    , Condemned -> Text
cdReason :: Reason
    }

-- | Evaluate each copy with its own evidence and count each selected version once for the mount.
previewPackageGroup :: SweepPacing -> SweepPorts -> SweepState -> SweepMount -> EvalContext -> PackageName -> [(StoreObservation, [StoredVersion])] -> IO (Maybe CycleHalt)
previewPackageGroup :: SweepPacing
-> SweepPorts
-> SweepState
-> SweepMount
-> EvalContext
-> PackageName
-> [(StoreObservation, [StoredVersion])]
-> IO (Maybe CycleHalt)
previewPackageGroup SweepPacing
pacing SweepPorts
ports SweepState
counters SweepMount
mount EvalContext
ctx PackageName
name [(StoreObservation, [StoredVersion])]
locations = do
    selections <- ((StoreObservation, [StoredVersion]) -> IO [Condemned])
-> [(StoreObservation, [StoredVersion])] -> IO [[Condemned]]
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 (SweepPorts
-> SweepState
-> SweepMount
-> EvalContext
-> PackageName
-> (StoreObservation, [StoredVersion])
-> IO [Condemned]
previewLocation SweepPorts
ports SweepState
counters SweepMount
mount EvalContext
ctx PackageName
name) [(StoreObservation, [StoredVersion])]
locations
    chargePreview pacing ports counters (nubOrdOn (renderVersion . cdVersion) (concat selections))
    pure Nothing

previewLocation :: SweepPorts -> SweepState -> SweepMount -> EvalContext -> PackageName -> (StoreObservation, [StoredVersion]) -> IO [Condemned]
previewLocation :: SweepPorts
-> SweepState
-> SweepMount
-> EvalContext
-> PackageName
-> (StoreObservation, [StoredVersion])
-> IO [Condemned]
previewLocation SweepPorts
ports SweepState
counters SweepMount
mount EvalContext
ctx PackageName
name (StoreObservation
store, [StoredVersion]
versions) = do
    selected <-
        Bool
-> SweepPorts
-> SweepState
-> SweepMount
-> EvalContext
-> PackageName
-> [StoredVersion]
-> IO [Condemned]
selectPackage Bool
True SweepPorts
located SweepState
counters SweepMount
locatedMount EvalContext
ctx PackageName
name [StoredVersion]
versions
            IO [Condemned] -> ([Condemned] -> IO [Condemned]) -> IO [Condemned]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= SweepPorts
-> SweepState
-> SweepMount
-> PackageName
-> [Condemned]
-> IO [Condemned]
stillEligible SweepPorts
located SweepState
counters SweepMount
locatedMount PackageName
name
    traverse_ (announce located name) selected
    traverse_ (const (recordMetric located (reportRemoval (sweepReport ports)))) selected
    announceKept located name (stillServed versions selected)
    pure selected
  where
    locatedMount :: SweepMount
locatedMount = SweepMount
mount{smStore = countingAt (smStore mount) store}
    located :: SweepPorts
located = SweepMount -> StoreObservation -> SweepPorts -> SweepPorts
locatedPorts SweepMount
mount StoreObservation
store SweepPorts
ports

-- The served versions a preview leaves behind, which it reports one line each.
stillServed :: [StoredVersion] -> [Condemned] -> [Version]
stillServed :: [StoredVersion] -> [Condemned] -> [Version]
stillServed [StoredVersion]
stored [Condemned]
selected =
    [ StoredVersion -> Version
storedVersion StoredVersion
version
    | StoredVersion
version <- [StoredVersion]
stored
    , StoredVersion -> VersionPresence
storedPresence StoredVersion
version VersionPresence -> VersionPresence -> Bool
forall a. Eq a => a -> a -> Bool
== VersionPresence
VersionServed
    , Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.notMember (Version -> Text
renderVersion (StoredVersion -> Version
storedVersion StoredVersion
version)) Set Text
condemnedKeys
    ]
  where
    condemnedKeys :: Set Text
condemnedKeys = [Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList ((Condemned -> Text) -> [Condemned] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Version -> Text
renderVersion (Version -> Text) -> (Condemned -> Version) -> Condemned -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Condemned -> Version
cdVersion) [Condemned]
selected)

{- A preview charges the cap once per distinct version, however many of the mount's stores hold it,
and counts past the cap rather than halting, so the closing tally names the full reach. -}
chargePreview :: SweepPacing -> SweepPorts -> SweepState -> [Condemned] -> IO ()
chargePreview :: SweepPacing -> SweepPorts -> SweepState -> [Condemned] -> IO ()
chargePreview SweepPacing
pacing SweepPorts
ports SweepState
counters [Condemned]
logical = do
    issued <- IORef Int -> IO Int
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef (SweepState -> IORef Int
stIssued SweepState
counters)
    let reached = Int
issued Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Condemned] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Condemned]
logical
        cap = SweepPacing -> Int
swpDeletionCap SweepPacing
pacing
        etag = Condemned -> Maybe DbEtag
cdAdvisoryEtag (Condemned -> Maybe DbEtag) -> Maybe Condemned -> Maybe DbEtag
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Condemned] -> Maybe Condemned
forall a. [a] -> Maybe a
listToMaybe (Int -> [Condemned] -> [Condemned]
forall a. Int -> [a] -> [a]
drop (Int
cap Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
issued Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [Condemned]
logical)
    writeIORef (stIssued counters) reached
    when (issued < cap && reached >= cap) (announceCap ports cap reached etag)
    traverse_ (const (recordTally counters (reportRemoval (sweepReport ports)))) logical

-- | The grouped executor reuses the complete evaluator with fresh context for every backend batch.
sweepPackageGroup :: SweepPacing -> SweepPorts -> SweepState -> SweepMount -> PackageName -> [(SweepStore, [StoredVersion])] -> IO (Maybe CycleHalt)
sweepPackageGroup :: SweepPacing
-> SweepPorts
-> SweepState
-> SweepMount
-> PackageName
-> [(SweepStore, [StoredVersion])]
-> IO (Maybe CycleHalt)
sweepPackageGroup SweepPacing
pacing SweepPorts
ports SweepState
counters SweepMount
mount PackageName
name =
    SweepPacing
-> SweepPorts
-> SweepState
-> SweepMount
-> PackageName
-> SelectStored
-> ReportOutcome
-> [(SweepStore, [StoredVersion])]
-> IO (Maybe CycleHalt)
deleteGroup SweepPacing
pacing SweepPorts
ports SweepState
counters SweepMount
mount PackageName
name SelectStored
select (\SweepPorts
located -> SweepPorts
-> SweepState -> PackageName -> (Version, VersionOutcome) -> IO ()
recordOutcome SweepPorts
located SweepState
counters PackageName
name)
  where
    select :: SelectStored
select Bool
counting SweepMount
located [StoredVersion]
stored = do
        ctx <- IO UTCTime -> IO (Maybe DbEtag) -> IO EvalContext
mkEvalContext (SweepPorts -> IO UTCTime
sweepNow SweepPorts
ports) (SweepPorts -> Ecosystem -> IO (Maybe DbEtag)
sweepAdvisoryEtag SweepPorts
ports (SweepMount -> Ecosystem
smEcosystem SweepMount
mount))
        let store = SweepStore -> StoreObservation
ssObserve (SweepMount -> SweepStore
smStore SweepMount
located)
            targetPorts = SweepMount -> StoreObservation -> SweepPorts -> SweepPorts
locatedPorts SweepMount
mount StoreObservation
store SweepPorts
ports
        selected <- selectPackage counting targetPorts counters located ctx name stored >>= stillEligible targetPorts counters located name
        pure [Selection (cdVersion item) (condemnationMessage ports name item) (cdAdvisoryEtag item) | item <- selected]

selectPackage :: Bool -> SweepPorts -> SweepState -> SweepMount -> EvalContext -> PackageName -> [StoredVersion] -> IO [Condemned]
selectPackage :: Bool
-> SweepPorts
-> SweepState
-> SweepMount
-> EvalContext
-> PackageName
-> [StoredVersion]
-> IO [Condemned]
selectPackage Bool
counting SweepPorts
ports SweepState
counters SweepMount
mount EvalContext
ctx PackageName
name [StoredVersion]
stored
    | SweepMount -> PackageName -> Bool
smFirstParty SweepMount
mount PackageName
name = [] [Condemned] -> IO () -> IO [Condemned]
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
counting ((Version -> IO ()) -> [Version] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (IO () -> Version -> IO ()
forall a b. a -> b -> a
const (SweepPorts -> SweepState -> SweepResult -> IO ()
record SweepPorts
ports SweepState
counters SweepResult
SweepGuardSkipped)) [Version]
served)
    | [Version] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Version]
served = [Condemned] -> IO [Condemned]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    | Bool
otherwise =
        StoreObservation -> StoreManifestRead
obReadManifest (SweepStore -> StoreObservation
ssObserve (SweepMount -> SweepStore
smStore SweepMount
mount)) PackageName
name IO (Either StoreFault Manifest)
-> (Either StoreFault Manifest -> IO [Condemned]) -> IO [Condemned]
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 StoreFault
fault -> do
                SweepState -> EvidenceGaps -> IO ()
recordGap SweepState
counters EvidenceGaps
unreadManifest
                SweepPorts -> PackageName -> [Version] -> StoreFault -> IO ()
announceUnread SweepPorts
ports PackageName
name [Version]
served StoreFault
fault
                (Version -> RuleEvidence) -> IO [Condemned]
decideAll (PackageName -> Version -> RuleEvidence
identityEvidence PackageName
name)
            Right Manifest
manifest -> (Version -> RuleEvidence) -> IO [Condemned]
decideAll (PackageName -> Manifest -> Version -> RuleEvidence
evidenceIn PackageName
name Manifest
manifest)
  where
    served :: [Version]
served = [StoredVersion -> Version
storedVersion StoredVersion
s | StoredVersion
s <- [StoredVersion]
stored, StoredVersion -> VersionPresence
storedPresence StoredVersion
s VersionPresence -> VersionPresence -> Bool
forall a. Eq a => a -> a -> Bool
== VersionPresence
VersionServed]
    decideAll :: (Version -> RuleEvidence) -> IO [Condemned]
decideAll Version -> RuleEvidence
evidence = do
        decide <- EvalContext -> [PreparedRule] -> IO (RuleEvidence -> IO Decision)
newEvaluator EvalContext
ctx (SweepMount -> [PreparedRule]
smRules SweepMount
mount)
        catMaybes <$> traverse (decideVersion counting ports counters decide evidence) served

{- The manifest's own entry for a version, or identity alone where it projects none. A listing can
name a version the manifest omits, and identity is established either way. -}
evidenceIn :: PackageName -> Manifest -> Version -> RuleEvidence
evidenceIn :: PackageName -> Manifest -> Version -> RuleEvidence
evidenceIn PackageName
name Manifest
manifest Version
version =
    RuleEvidence
-> (PackageDetails -> RuleEvidence)
-> Maybe PackageDetails
-> RuleEvidence
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (PackageName -> Version -> RuleEvidence
identityEvidence PackageName
name Version
version) PackageDetails -> RuleEvidence
completeEvidence (Version -> PackageInfo -> Maybe PackageDetails
selectVersion Version
version (Manifest -> PackageInfo
manifestInfo Manifest
manifest))

{- Decide one version from whatever evidence it has and count it. Only a named decisive deny
condemns, so this reads the engine's decision rather than the wrapper that folds in deny-by-default. -}
decideVersion ::
    Bool ->
    SweepPorts ->
    SweepState ->
    (RuleEvidence -> IO Decision) ->
    (Version -> RuleEvidence) ->
    Version ->
    IO (Maybe Condemned)
decideVersion :: Bool
-> SweepPorts
-> SweepState
-> (RuleEvidence -> IO Decision)
-> (Version -> RuleEvidence)
-> Version
-> IO (Maybe Condemned)
decideVersion Bool
counting SweepPorts
ports SweepState
counters RuleEvidence -> IO Decision
decide Version -> RuleEvidence
evidence Version
version = do
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
counting (SweepPorts -> SweepState -> SweepResult -> IO ()
record SweepPorts
ports SweepState
counters SweepResult
SweepExamined)
    RuleEvidence -> IO Decision
decide (Version -> RuleEvidence
evidence Version
version) IO Decision
-> (Decision -> IO (Maybe Condemned)) -> IO (Maybe Condemned)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Blocked Text
rule Maybe DbEtag
etag Text
reason -> Maybe Condemned -> IO (Maybe Condemned)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Condemned -> Maybe Condemned
forall a. a -> Maybe a
Just Condemned{cdVersion :: Version
cdVersion = Version
version, cdRule :: Text
cdRule = Text
rule, cdAdvisoryEtag :: Maybe DbEtag
cdAdvisoryEtag = Maybe DbEtag
etag, cdReason :: Text
cdReason = Text
reason})
        Decision
_ -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
counting (SweepPorts -> SweepState -> SweepResult -> IO ()
record SweepPorts
ports SweepState
counters SweepResult
SweepKept) IO () -> Maybe Condemned -> IO (Maybe Condemned)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Maybe Condemned
forall a. Maybe a
Nothing

{- The push can stop being eligible evidence between a version's decision and this hand-over,
across a long manifest read or a batch, and a delete is permanent. So it is read again here. -}
stillEligible :: SweepPorts -> SweepState -> SweepMount -> PackageName -> [Condemned] -> IO [Condemned]
stillEligible :: SweepPorts
-> SweepState
-> SweepMount
-> PackageName
-> [Condemned]
-> IO [Condemned]
stillEligible SweepPorts
ports SweepState
counters SweepMount
mount PackageName
name [Condemned]
condemned =
    RuleDeps -> IO AdvisoryFreshness
rdAdvisoryFreshness (SweepMount -> RuleDeps
smRuleDeps SweepMount
mount) IO AdvisoryFreshness
-> (AdvisoryFreshness -> IO [Condemned]) -> IO [Condemned]
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
        Maybe Text
Nothing -> [Condemned] -> IO [Condemned]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Condemned]
condemned
        Just Text
why -> do
            let advisoryRules :: [Text]
advisoryRules = [Rule -> Text
ruleName Rule
r | Rule
r <- SweepMount -> [Rule]
smConfigured SweepMount
mount, Rule -> Bool
readsAdvisories Rule
r]
                ([Condemned]
withheld, [Condemned]
keeping) = (Condemned -> Bool) -> [Condemned] -> ([Condemned], [Condemned])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((Text -> [Text] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` [Text]
advisoryRules) (Text -> Bool) -> (Condemned -> Text) -> Condemned -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Condemned -> Text
cdRule) [Condemned]
condemned
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Condemned] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Condemned]
withheld) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                (Condemned -> IO ()) -> [Condemned] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (IO () -> Condemned -> IO ()
forall a b. a -> b -> a
const (SweepPorts -> SweepState -> SweepResult -> IO ()
record SweepPorts
ports SweepState
counters SweepResult
SweepGuardSkipped)) [Condemned]
withheld
                SweepPorts -> PackageName -> Text -> [Condemned] -> IO ()
announceIneligible SweepPorts
ports PackageName
name Text
why [Condemned]
withheld
            [Condemned] -> IO [Condemned]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Condemned]
keeping

{- The store served no metadata, so each version is decided on the identity the listing carries. The
shared fetch discards the response status, so a package the store no longer serves arrives here too. -}
announceUnread :: SweepPorts -> PackageName -> [Version] -> StoreFault -> IO ()
announceUnread :: SweepPorts -> PackageName -> [Version] -> StoreFault -> IO ()
announceUnread SweepPorts
ports PackageName
name [Version]
served StoreFault
fault =
    SweepAudit -> Text -> IO ()
auditError
        (SweepPorts -> SweepAudit
sweepAudit SweepPorts
ports)
        ( PackageName -> Text
renderPackageName PackageName
name
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": the store served no metadata this cycle, so its "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show ([Version] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Version]
served)
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" versions are decided on identity alone: "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> StoreFault -> Text
renderStoreFault StoreFault
fault
        )

announceKept :: SweepPorts -> PackageName -> [Version] -> IO ()
announceKept :: SweepPorts -> PackageName -> [Version] -> IO ()
announceKept SweepPorts
ports PackageName
name =
    (Version -> IO ()) -> [Version] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_
        ( \Version
version ->
            SweepAudit -> Text -> IO ()
auditInfo
                (SweepPorts -> SweepAudit
sweepAudit SweepPorts
ports)
                (Text
"dry run, keeping " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PackageName -> Text
renderPackageName PackageName
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"@" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Version -> Text
renderVersion Version
version)
        )

-- The versions the unusable evidence spared, so an operator sees what a recovered Pilot would act on.
announceIneligible :: SweepPorts -> PackageName -> Text -> [Condemned] -> IO ()
announceIneligible :: SweepPorts -> PackageName -> Text -> [Condemned] -> IO ()
announceIneligible SweepPorts
ports PackageName
name Text
why [Condemned]
withheld =
    SweepAudit -> Text -> IO ()
auditError
        (SweepPorts -> SweepAudit
sweepAudit SweepPorts
ports)
        ( PackageName -> Text
renderPackageName PackageName
name
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show ([Condemned] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Condemned]
withheld)
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" versions an advisory rule denied stay in the store, because "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
why
        )

-- Where a halting run would have stopped, for a run that carries on past the cap instead.
announceCap :: SweepPorts -> Int -> Int -> Maybe DbEtag -> IO ()
announceCap :: SweepPorts -> Int -> Int -> Maybe DbEtag -> IO ()
announceCap SweepPorts
ports Int
cap Int
reached Maybe DbEtag
etag =
    SweepAudit -> Text -> IO ()
auditInfo (SweepPorts -> SweepAudit
sweepAudit SweepPorts
ports) (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
        Text
"the cycle has handed over "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
reached
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" versions and reached the deletion cap of "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
cap
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" under advisory generation "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Maybe DbEtag -> Text
renderGeneration Maybe DbEtag
etag
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
". This run counts past the cap rather than halting, so its closing tally reports the full reach"

announce :: SweepPorts -> PackageName -> Condemned -> IO ()
announce :: SweepPorts -> PackageName -> Condemned -> IO ()
announce SweepPorts
ports PackageName
name Condemned
condemned = SweepAudit -> Text -> IO ()
auditInfo (SweepPorts -> SweepAudit
sweepAudit SweepPorts
ports) (SweepPorts -> PackageName -> Condemned -> Text
condemnationMessage SweepPorts
ports PackageName
name Condemned
condemned)

{- Every deletion's audit line: the package, the version, the rule that denied it, and the
advisory generation pinned when it was decided. -}
condemnationMessage :: SweepPorts -> PackageName -> Condemned -> Text
condemnationMessage :: SweepPorts -> PackageName -> Condemned -> Text
condemnationMessage SweepPorts
ports PackageName
name Condemned
condemned =
    SweepReport -> Text
reportOpening (SweepPorts -> SweepReport
sweepReport SweepPorts
ports)
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PackageName -> Text
renderPackageName PackageName
name
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"@"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Version -> Text
renderVersion (Condemned -> Version
cdVersion Condemned
condemned)
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": blocked by "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Condemned -> Text
cdRule Condemned
condemned
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ("
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Condemned -> Text
cdReason Condemned
condemned
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"); advisory generation "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Maybe DbEtag -> Text
renderGeneration (Condemned -> Maybe DbEtag
cdAdvisoryEtag Condemned
condemned)

{- What the backend reported for one version. A refusal or an unreached call leaves the version
in the store, so it counts as kept and reports for an operator to follow up. -}
recordOutcome :: SweepPorts -> SweepState -> PackageName -> (Version, VersionOutcome) -> IO ()
recordOutcome :: SweepPorts
-> SweepState -> PackageName -> (Version, VersionOutcome) -> IO ()
recordOutcome SweepPorts
ports SweepState
counters PackageName
name (Version
version, VersionOutcome
outcome) = case VersionOutcome
outcome of
    VersionOutcome
VersionRemoved -> SweepPorts -> SweepState -> SweepResult -> IO ()
record SweepPorts
ports SweepState
counters SweepResult
removal
    VersionRemoving Text
reference -> do
        -- No backend completes a removal later, so the next cycle's listing settles it: a version
        -- still served is decided and deleted again, which is idempotent.
        SweepAudit -> Text -> IO ()
auditInfo (SweepPorts -> SweepAudit
sweepAudit SweepPorts
ports) (Text
subject Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": the backend is removing it under " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
reference)
        SweepPorts -> SweepState -> SweepResult -> IO ()
record SweepPorts
ports SweepState
counters SweepResult
removal
    VersionRefused StoreRefusal
refusal -> do
        SweepAudit -> Text -> IO ()
auditError
            (SweepPorts -> SweepAudit
sweepAudit SweepPorts
ports)
            (Text
subject Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": the backend refused the delete, " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> StoreRefusal -> Text
refusalCode StoreRefusal
refusal Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> StoreRefusal -> Text
refusalDetail StoreRefusal
refusal)
        SweepPorts -> SweepState -> SweepResult -> IO ()
record SweepPorts
ports SweepState
counters SweepResult
SweepKept
    VersionUncertain StoreFault
fault -> do
        SweepAudit -> Text -> IO ()
auditError (SweepPorts -> SweepAudit
sweepAudit SweepPorts
ports) (Text
subject Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": deletion outcome is uncertain: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> StoreFault -> Text
renderStoreFault StoreFault
fault)
        SweepPorts -> SweepState -> SweepResult -> IO ()
record SweepPorts
ports SweepState
counters SweepResult
SweepKept
    VersionUnreached StoreFault
fault -> do
        SweepAudit -> Text -> IO ()
auditError (SweepPorts -> SweepAudit
sweepAudit SweepPorts
ports) (Text
subject Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": the delete did not reach the backend: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> StoreFault -> Text
renderStoreFault StoreFault
fault)
        SweepPorts -> SweepState -> SweepResult -> IO ()
record SweepPorts
ports SweepState
counters SweepResult
SweepKept
  where
    subject :: Text
subject = PackageName -> Text
renderPackageName PackageName
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"@" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Version -> Text
renderVersion Version
version
    removal :: SweepResult
removal = SweepReport -> SweepResult
reportRemoval (SweepPorts -> SweepReport
sweepReport SweepPorts
ports)