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

{- | The Dredger's cycle over every mount's mirror store and the private cache it is paired with.
The two inventories are joined bucket by bucket through "Ecluse.Core.Registry.Sweep.Walk", and a
full walk resumes from the stored bucket cursor.
-}
module Ecluse.Core.Registry.Sweep (
    sweepCycle,
    paceAtCeiling,
    storeBudgets,
    withStoreRetry,
) where

import Data.List (lookup)
import Data.Map.Strict qualified as Map

import Ecluse.Core.Ecosystem (ecosystemName)
import Ecluse.Core.Fault (RetryAfter (RetryAfter))
import Ecluse.Core.Package (PackageName)
import Ecluse.Core.Registry.Maintenance (
    ConsentVerdict (ConsentGranted, ConsentWithheld),
    RetryAdvice (RetryDelayed, RetryFutile, RetryWorthwhile),
    StoreClass (StoreDestroyable, StorePreserved),
    StoreCursor (clearCursor, readCursor, writeCursor),
    StoreFacts (factBackend, factBudget, factNameAlphabet),
    StoreFault (faultRetry),
    StoreObservation (obClassifyStore, obEnumerateVersions, obFacts, obVerifyConsent),
    StoredVersion,
 )
import Ecluse.Core.Registry.Maintenance.Budget (
    BudgetPort (budgetClose, budgetOpen, budgetPaced),
    CycleCost (ccRequests, ccWorkSeconds),
    StoreBudget (bgScope),
    narrowestBudget,
    renderQuotaScope,
    renderRequestTally,
 )
import Ecluse.Core.Registry.Maintenance.NameSpace (
    NameAlphabet,
    NamePrefix,
    renderNamePrefix,
 )
import Ecluse.Core.Registry.Sweep.Candidates (CandidateSet, candidateSet, inCandidates)
import Ecluse.Core.Registry.Sweep.Group (boundedVersions, collectGroupBucket, groupAlphabet)
import Ecluse.Core.Registry.Sweep.Outcome (
    CycleHalt (HaltBucketUnsplittable, HaltConsentWithheld, HaltStoreFault, HaltStorePreserved),
    CycleOutcome (CycleOutcome, outcomeEvidence, outcomeHalt, outcomePrerequisites, outcomeTally),
    PrerequisiteStatus (PrerequisiteMet, PrerequisiteUnmet, PrerequisiteUnread),
    TargetPrerequisites (TargetPrerequisites, tpBackend, tpClassification, tpConsent, tpEcosystem),
    evidenceComplete,
    prerequisitesMet,
    renderCycleHalt,
    renderEvidenceGaps,
    renderPrerequisites,
    renderStoreFault,
    renderTally,
    storeSubject,
    unloadedGeneration,
 )
import Ecluse.Core.Registry.Sweep.Pacing (PaceDecision (pdPace, pdScope), decidePace, renderPaceDecision)
import Ecluse.Core.Registry.Sweep.Package (previewPackageGroup, sweepPackageGroup)
import Ecluse.Core.Registry.Sweep.Types (
    SweepAudit (auditError, auditInfo, auditWarn),
    SweepExecution (SweepCounts, SweepRemoves),
    SweepMount (smConfigured, smEcosystem, smProjectName, smRuleDeps, smStore),
    SweepPacing (swpChunkPause, swpChunkSize, swpShape),
    SweepPorts (sweepAudit, sweepBudget, sweepDelay, sweepNow),
    SweepShape (SweepEverything),
    SweepState,
    SweepStore (ssExecute, ssObserve, ssVersionLimit),
    countingAt,
    newSweepState,
    privateStore,
    recordGap,
    recordPrerequisites,
    stChunkProgress,
    stEvidence,
    stPrerequisites,
    stTally,
    walkMarkerOf,
 )
import Ecluse.Core.Registry.Sweep.Walk (
    BucketNames (BucketFaulted, BucketOverflowed, BucketRead, BucketUnsplittable),
    resumeAfter,
    walkBuckets,
 )
import Ecluse.Core.Rules (withCveLookup)
import Ecluse.Core.Rules.Types (EvalContext, mkEvalContext, readsAdvisories)

{- | Run one cycle: every mount's store in turn. A halt ends the whole cycle, because every reason
for one is a fact about the deployment rather than about one package.
-}
sweepCycle :: SweepPacing -> SweepPorts -> [SweepMount] -> IO CycleOutcome
sweepCycle :: SweepPacing -> SweepPorts -> [SweepMount] -> IO CycleOutcome
sweepCycle SweepPacing
pacing SweepPorts
ports [SweepMount]
mounts = do
    BudgetPort -> IO ()
budgetOpen (SweepPorts -> BudgetPort
sweepBudget SweepPorts
ports)
    counters <- IO SweepState
newSweepState
    halt <- stepUntilHalt (sweepMount pacing ports counters) mounts
    outcome <-
        CycleOutcome halt
            <$> readIORef (stTally counters)
            <*> (reverse <$> readIORef (stPrerequisites counters))
            <*> readIORef (stEvidence counters)
    reportCycle ports outcome
    paceNextCycle pacing ports mounts outcome
    pure outcome

{- | Hold every scope to its ceiling before any cycle has measured one. A Dredger whose every
cycle halts never reaches the measured decision, so this is where its rate comes from.
-}
paceAtCeiling :: SweepPacing -> SweepPorts -> [SweepMount] -> IO ()
paceAtCeiling :: SweepPacing -> SweepPorts -> [SweepMount] -> IO ()
paceAtCeiling SweepPacing
pacing SweepPorts
ports [SweepMount]
mounts =
    BudgetPort -> Map QuotaScope CyclePace -> IO ()
budgetPaced (SweepPorts -> BudgetPort
sweepBudget SweepPorts
ports) ([(QuotaScope, CyclePace)] -> Map QuotaScope CyclePace
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(PaceDecision -> QuotaScope
pdScope PaceDecision
decision, PaceDecision -> CyclePace
pdPace PaceDecision
decision) | PaceDecision
decision <- [PaceDecision]
decisions])
  where
    decisions :: [PaceDecision]
decisions = [SweepPacing
-> StoreBudget -> Maybe (RequestTally, Rational) -> PaceDecision
decidePace SweepPacing
pacing StoreBudget
budget Maybe (RequestTally, Rational)
forall a. Maybe a
Nothing | StoreBudget
budget <- [SweepMount] -> [StoreBudget]
storeBudgets [SweepMount]
mounts]

{- Pace the next cycle from what this one measured. A halted cycle read part of the store, so its
counts are discarded rather than allowed to replace a complete sample's pace. -}
paceNextCycle :: SweepPacing -> SweepPorts -> [SweepMount] -> CycleOutcome -> IO ()
paceNextCycle :: SweepPacing -> SweepPorts -> [SweepMount] -> CycleOutcome -> IO ()
paceNextCycle SweepPacing
pacing SweepPorts
ports [SweepMount]
mounts CycleOutcome
outcome = do
    cost <- BudgetPort -> IO CycleCost
budgetClose (SweepPorts -> BudgetPort
sweepBudget SweepPorts
ports)
    unless (isJust (outcomeHalt outcome)) $ do
        traverse_ (auditInfo (sweepAudit ports) . renderMeasured) (Map.toAscList (ccRequests cost))
        let decisions = [SweepPacing
-> StoreBudget -> Maybe (RequestTally, Rational) -> PaceDecision
decidePace SweepPacing
pacing StoreBudget
budget (CycleCost -> StoreBudget -> Maybe (RequestTally, Rational)
sampleOf CycleCost
cost StoreBudget
budget) | StoreBudget
budget <- [SweepMount] -> [StoreBudget]
storeBudgets [SweepMount]
mounts]
        traverse_ (traverse_ (auditWarn (sweepAudit ports)) . renderPaceDecision pacing) decisions
        budgetPaced (sweepBudget ports) (Map.fromList [(pdScope decision, pdPace decision) | decision <- decisions])
  where
    sampleOf :: CycleCost -> StoreBudget -> Maybe (RequestTally, Rational)
sampleOf CycleCost
cost StoreBudget
budget = (,CycleCost -> Rational
ccWorkSeconds CycleCost
cost) (RequestTally -> (RequestTally, Rational))
-> Maybe RequestTally -> Maybe (RequestTally, Rational)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QuotaScope -> Map QuotaScope RequestTally -> Maybe RequestTally
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (StoreBudget -> QuotaScope
bgScope StoreBudget
budget) (CycleCost -> Map QuotaScope RequestTally
ccRequests CycleCost
cost)
    renderMeasured :: (QuotaScope, RequestTally) -> Text
renderMeasured (QuotaScope
scope, RequestTally
tally) =
        Text
"this cycle asked " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> QuotaScope -> Text
renderQuotaScope QuotaScope
scope Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> RequestTally -> Text
renderRequestTally RequestTally
tally

{- | Each distinct capacity pool the cycle's stores share. Two stores that landed in one pool are
paced by the narrower of what each claims, never by whichever the fold read last.
-}
storeBudgets :: [SweepMount] -> [StoreBudget]
storeBudgets :: [SweepMount] -> [StoreBudget]
storeBudgets [SweepMount]
mounts =
    Map QuotaScope StoreBudget -> [StoreBudget]
forall k a. Map k a -> [a]
Map.elems ((StoreBudget -> StoreBudget -> StoreBudget)
-> [(QuotaScope, StoreBudget)] -> Map QuotaScope StoreBudget
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith StoreBudget -> StoreBudget -> StoreBudget
narrowestBudget [(StoreBudget -> QuotaScope
bgScope StoreBudget
budget, StoreBudget
budget) | SweepMount
mount <- [SweepMount]
mounts, StoreBudget
budget <- SweepMount -> [StoreBudget]
budgetsOf SweepMount
mount])
  where
    budgetsOf :: SweepMount -> [StoreBudget]
budgetsOf SweepMount
mount =
        [ StoreFacts -> StoreBudget
factBudget (StoreObservation -> StoreFacts
obFacts (SweepStore -> StoreObservation
ssObserve SweepStore
store))
        | SweepStore
store <- [SweepMount -> SweepStore
smStore SweepMount
mount, SweepStore -> SweepStore
privateStore (SweepMount -> SweepStore
smStore SweepMount
mount)]
        ]

{- What a real sweep of each target still needs, above the counts, then what the cycle did and what
it could not read. The two never merge: a complete count is not a permission to delete. -}
reportCycle :: SweepPorts -> CycleOutcome -> IO ()
reportCycle :: SweepPorts -> CycleOutcome -> IO ()
reportCycle SweepPorts
ports CycleOutcome
outcome = do
    (TargetPrerequisites -> IO ()) -> [TargetPrerequisites] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (SweepPorts -> TargetPrerequisites -> IO ()
announcePrerequisites SweepPorts
ports) (CycleOutcome -> [TargetPrerequisites]
outcomePrerequisites CycleOutcome
outcome)
    case CycleOutcome -> Maybe CycleHalt
outcomeHalt CycleOutcome
outcome of
        Maybe CycleHalt
Nothing -> SweepAudit -> Text -> IO ()
auditInfo (SweepPorts -> SweepAudit
sweepAudit SweepPorts
ports) (Text
"mirror sweep cycle complete: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
closing)
        Just CycleHalt
reason ->
            SweepAudit -> Text -> IO ()
auditError (SweepPorts -> SweepAudit
sweepAudit SweepPorts
ports) (Text
"mirror sweep cycle halted: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CycleHalt -> Text
renderCycleHalt CycleHalt
reason Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"; " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
closing)
  where
    gaps :: EvidenceGaps
gaps = CycleOutcome -> EvidenceGaps
outcomeEvidence CycleOutcome
outcome
    closing :: Text
closing
        | EvidenceGaps -> Bool
evidenceComplete EvidenceGaps
gaps = SweepTally -> Text
renderTally (CycleOutcome -> SweepTally
outcomeTally CycleOutcome
outcome)
        | Bool
otherwise = SweepTally -> Text
renderTally (CycleOutcome -> SweepTally
outcomeTally CycleOutcome
outcome) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"; counted from partial evidence: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> EvidenceGaps -> Text
renderEvidenceGaps EvidenceGaps
gaps

-- A target a real sweep would stop on warns. One it would pass reports as routine.
announcePrerequisites :: SweepPorts -> TargetPrerequisites -> IO ()
announcePrerequisites :: SweepPorts -> TargetPrerequisites -> IO ()
announcePrerequisites SweepPorts
ports TargetPrerequisites
target =
    SweepAudit -> Text -> IO ()
severity (SweepPorts -> SweepAudit
sweepAudit SweepPorts
ports) (TargetPrerequisites -> Text
renderPrerequisites TargetPrerequisites
target)
  where
    severity :: SweepAudit -> Text -> IO ()
severity = if TargetPrerequisites -> Bool
prerequisitesMet TargetPrerequisites
target then SweepAudit -> Text -> IO ()
auditInfo else SweepAudit -> Text -> IO ()
auditWarn

{- Walk the steps until one halts. The mounts, the buckets, and the packages of a chunk all fold
this way, so a halt ends the cycle from wherever it is raised. -}
stepUntilHalt :: (a -> IO (Maybe CycleHalt)) -> [a] -> IO (Maybe CycleHalt)
stepUntilHalt :: forall a.
(a -> IO (Maybe CycleHalt)) -> [a] -> IO (Maybe CycleHalt)
stepUntilHalt a -> IO (Maybe CycleHalt)
step = [a] -> IO (Maybe CycleHalt)
go
  where
    go :: [a] -> IO (Maybe CycleHalt)
go [] = Maybe CycleHalt -> IO (Maybe CycleHalt)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe CycleHalt
forall a. Maybe a
Nothing
    go (a
x : [a]
xs) = a -> IO (Maybe CycleHalt)
step a
x IO (Maybe CycleHalt)
-> (Maybe CycleHalt -> IO (Maybe CycleHalt))
-> IO (Maybe CycleHalt)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO (Maybe CycleHalt)
-> (CycleHalt -> IO (Maybe CycleHalt))
-> Maybe CycleHalt
-> IO (Maybe CycleHalt)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([a] -> IO (Maybe CycleHalt)
go [a]
xs) (Maybe CycleHalt -> IO (Maybe CycleHalt)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe CycleHalt -> IO (Maybe CycleHalt))
-> (CycleHalt -> Maybe CycleHalt)
-> CycleHalt
-> IO (Maybe CycleHalt)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CycleHalt -> Maybe CycleHalt
forall a. a -> Maybe a
Just)

firstHalt :: [IO (Maybe CycleHalt)] -> IO (Maybe CycleHalt)
firstHalt :: [IO (Maybe CycleHalt)] -> IO (Maybe CycleHalt)
firstHalt = (IO (Maybe CycleHalt) -> IO (Maybe CycleHalt))
-> [IO (Maybe CycleHalt)] -> IO (Maybe CycleHalt)
forall a.
(a -> IO (Maybe CycleHalt)) -> [a] -> IO (Maybe CycleHalt)
stepUntilHalt IO (Maybe CycleHalt) -> IO (Maybe CycleHalt)
forall a. a -> a
id

{- One mount: its two standing permissions, then a walk over it. Both are read at every cycle
start, because an operator revokes either and a store can be recreated as a different kind. -}
sweepMount :: SweepPacing -> SweepPorts -> SweepState -> SweepMount -> IO (Maybe CycleHalt)
sweepMount :: SweepPacing
-> SweepPorts -> SweepState -> SweepMount -> IO (Maybe CycleHalt)
sweepMount SweepPacing
pacing SweepPorts
ports SweepState
counters SweepMount
mount = case SweepStore -> SweepExecution
ssExecute (SweepMount -> SweepStore
smStore SweepMount
mount) of
    SweepRemoves StoreDeletion
_ -> [IO (Maybe CycleHalt)] -> IO (Maybe CycleHalt)
firstHalt ((SweepMount -> IO (Maybe CycleHalt))
-> [SweepMount] -> [IO (Maybe CycleHalt)]
forall a b. (a -> b) -> [a] -> [b]
map (SweepPacing -> SweepPorts -> SweepMount -> IO (Maybe CycleHalt)
clearedToDelete SweepPacing
pacing SweepPorts
ports) [SweepMount]
targets [IO (Maybe CycleHalt)]
-> [IO (Maybe CycleHalt)] -> [IO (Maybe CycleHalt)]
forall a. Semigroup a => a -> a -> a
<> [IO (Maybe CycleHalt)
walk])
    SweepExecution
SweepCounts -> do
        (SweepMount -> IO ()) -> [SweepMount] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (SweepPacing -> SweepPorts -> SweepState -> SweepMount -> IO ()
notePrerequisites SweepPacing
pacing SweepPorts
ports SweepState
counters) [SweepMount]
targets
        IO (Maybe CycleHalt)
walk
  where
    targets :: [SweepMount]
targets = [SweepMount
mount, SweepMount -> SweepMount
atPrivateCache SweepMount
mount]
    walk :: IO (Maybe CycleHalt)
walk = SweepPacing
-> SweepPorts -> SweepState -> SweepMount -> IO (Maybe CycleHalt)
walkStore SweepPacing
pacing SweepPorts
ports SweepState
counters SweepMount
mount

-- The same mount seen at its private cache, whose permissions and inventory are its own.
atPrivateCache :: SweepMount -> SweepMount
atPrivateCache :: SweepMount -> SweepMount
atPrivateCache SweepMount
mount = SweepMount
mount{smStore = privateStore (smStore mount)}

{- The two standing permissions a delete needs: the operator's own marker, and whether deleting
from this store destroys anything. Both halts name the backend that raised them. -}
clearedToDelete :: SweepPacing -> SweepPorts -> SweepMount -> IO (Maybe CycleHalt)
clearedToDelete :: SweepPacing -> SweepPorts -> SweepMount -> IO (Maybe CycleHalt)
clearedToDelete SweepPacing
pacing SweepPorts
ports SweepMount
mount = do
    consent <- SweepPacing
-> SweepPorts
-> SweepMount
-> IO (Either StoreFault ConsentVerdict)
-> IO (Either CycleHalt ConsentVerdict)
forall a.
SweepPacing
-> SweepPorts
-> SweepMount
-> IO (Either StoreFault a)
-> IO (Either CycleHalt a)
withStoreRetry SweepPacing
pacing SweepPorts
ports SweepMount
mount (StoreObservation -> IO (Either StoreFault ConsentVerdict)
obVerifyConsent (SweepMount -> StoreObservation
observed SweepMount
mount))
    classified <- withStoreRetry pacing ports mount (obClassifyStore (observed mount))
    pure $ case (consent, classified) of
        (Left CycleHalt
halt, Either CycleHalt StoreClass
_) -> CycleHalt -> Maybe CycleHalt
forall a. a -> Maybe a
Just CycleHalt
halt
        (Either CycleHalt ConsentVerdict
_, Left CycleHalt
halt) -> CycleHalt -> Maybe CycleHalt
forall a. a -> Maybe a
Just CycleHalt
halt
        (Right (ConsentWithheld Text
descriptor), Either CycleHalt StoreClass
_) -> CycleHalt -> Maybe CycleHalt
forall a. a -> Maybe a
Just (Ecosystem -> Text -> Text -> CycleHalt
HaltConsentWithheld Ecosystem
eco Text
backend Text
descriptor)
        (Either CycleHalt ConsentVerdict
_, Right (StorePreserved Text
why)) -> CycleHalt -> Maybe CycleHalt
forall a. a -> Maybe a
Just (Ecosystem -> Text -> Text -> CycleHalt
HaltStorePreserved Ecosystem
eco Text
backend Text
why)
        (Right ConsentVerdict
ConsentGranted, Right StoreClass
StoreDestroyable) -> Maybe CycleHalt
forall a. Maybe a
Nothing
  where
    eco :: Ecosystem
eco = SweepMount -> Ecosystem
smEcosystem SweepMount
mount
    backend :: Text
backend = SweepMount -> Text
backendOf SweepMount
mount

{- The same two reads, kept as findings. A preview stops for neither, so a permission it could not
read is a finding as well rather than an end to the enumeration. -}
notePrerequisites :: SweepPacing -> SweepPorts -> SweepState -> SweepMount -> IO ()
notePrerequisites :: SweepPacing -> SweepPorts -> SweepState -> SweepMount -> IO ()
notePrerequisites SweepPacing
pacing SweepPorts
ports SweepState
counters SweepMount
mount = do
    consent <- SweepPacing
-> SweepPorts
-> SweepMount
-> IO (Either StoreFault ConsentVerdict)
-> IO (Either CycleHalt ConsentVerdict)
forall a.
SweepPacing
-> SweepPorts
-> SweepMount
-> IO (Either StoreFault a)
-> IO (Either CycleHalt a)
withStoreRetry SweepPacing
pacing SweepPorts
ports SweepMount
mount (StoreObservation -> IO (Either StoreFault ConsentVerdict)
obVerifyConsent (SweepMount -> StoreObservation
observed SweepMount
mount))
    classified <- withStoreRetry pacing ports mount (obClassifyStore (observed mount))
    recordPrerequisites
        counters
        TargetPrerequisites
            { tpEcosystem = smEcosystem mount
            , tpBackend = backendOf mount
            , tpConsent = either unreadable consentStatus consent
            , tpClassification = either unreadable classStatus classified
            }
  where
    unreadable :: CycleHalt -> PrerequisiteStatus
unreadable = Text -> PrerequisiteStatus
PrerequisiteUnread (Text -> PrerequisiteStatus)
-> (CycleHalt -> Text) -> CycleHalt -> PrerequisiteStatus
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CycleHalt -> Text
renderCycleHalt

    consentStatus :: ConsentVerdict -> PrerequisiteStatus
consentStatus = \case
        ConsentVerdict
ConsentGranted -> PrerequisiteStatus
PrerequisiteMet
        ConsentWithheld Text
descriptor -> Text -> PrerequisiteStatus
PrerequisiteUnmet Text
descriptor

    classStatus :: StoreClass -> PrerequisiteStatus
classStatus = \case
        StoreClass
StoreDestroyable -> PrerequisiteStatus
PrerequisiteMet
        StorePreserved Text
why -> Text -> PrerequisiteStatus
PrerequisiteUnmet Text
why

{- Walk this mount's two stores as one inventory, in the shape the configuration selected. A
full walk is a superset of a candidate cycle, so nothing runs beside it. -}
walkStore :: SweepPacing -> SweepPorts -> SweepState -> SweepMount -> IO (Maybe CycleHalt)
walkStore :: SweepPacing
-> SweepPorts -> SweepState -> SweepMount -> IO (Maybe CycleHalt)
walkStore SweepPacing
pacing SweepPorts
ports SweepState
counters SweepMount
mount = do
    SweepPorts -> SweepState -> SweepMount -> IO ()
reportAdvisoryHalf SweepPorts
ports SweepState
counters SweepMount
mount
    SweepPacing
-> SweepPorts
-> SweepState
-> SweepMount
-> SweepStore
-> IO (Maybe CycleHalt)
walkGroup SweepPacing
pacing SweepPorts
ports SweepState
counters SweepMount
mount (SweepStore -> SweepStore
privateStore (SweepMount -> SweepStore
smStore SweepMount
mount))

{- What every step of one mount's paired walk closes over: the two stores, the pacing and ports
the steps run under, and the name a halt reports both backends under. -}
data GroupWalk = GroupWalk
    { GroupWalk -> SweepPacing
gwPacing :: SweepPacing
    , GroupWalk -> SweepPorts
gwPorts :: SweepPorts
    , GroupWalk -> SweepState
gwCounters :: SweepState
    , GroupWalk -> SweepMount
gwMount :: SweepMount
    , GroupWalk -> SweepStore
gwCache :: SweepStore
    , GroupWalk -> Text
gwCombined :: Text
    }

walkGroup :: SweepPacing -> SweepPorts -> SweepState -> SweepMount -> SweepStore -> IO (Maybe CycleHalt)
walkGroup :: SweepPacing
-> SweepPorts
-> SweepState
-> SweepMount
-> SweepStore
-> IO (Maybe CycleHalt)
walkGroup SweepPacing
pacing SweepPorts
ports SweepState
counters SweepMount
mount SweepStore
cache = do
    resume <- if Bool
resumable then SweepPacing
-> SweepPorts
-> SweepMount
-> IO (Either CycleHalt (Maybe NamePrefix))
readWalkCursor SweepPacing
pacing SweepPorts
ports SweepMount
mount else Either CycleHalt (Maybe NamePrefix)
-> IO (Either CycleHalt (Maybe NamePrefix))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe NamePrefix -> Either CycleHalt (Maybe NamePrefix)
forall a b. b -> Either a b
Right Maybe NamePrefix
forall a. Maybe a
Nothing)
    case resume of
        Left CycleHalt
halt -> Maybe CycleHalt -> IO (Maybe CycleHalt)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CycleHalt -> Maybe CycleHalt
forall a. a -> Maybe a
Just CycleHalt
halt)
        Right Maybe NamePrefix
cursor -> Maybe NamePrefix -> [NamePrefix] -> IO (Maybe CycleHalt)
go Maybe NamePrefix
cursor (Maybe NamePrefix -> [NamePrefix] -> [NamePrefix]
resumeAfter Maybe NamePrefix
cursor (NameAlphabet -> [NamePrefix]
walkBuckets NameAlphabet
alphabet))
  where
    walk :: GroupWalk
walk =
        GroupWalk
            { gwPacing :: SweepPacing
gwPacing = SweepPacing
pacing
            , gwPorts :: SweepPorts
gwPorts = SweepPorts
ports
            , gwCounters :: SweepState
gwCounters = SweepState
counters
            , gwMount :: SweepMount
gwMount = SweepMount
mount
            , gwCache :: SweepStore
gwCache = SweepStore
cache
            , gwCombined :: Text
gwCombined = SweepMount -> Text
backendOf SweepMount
mount Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" and " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> StoreFacts -> Text
factBackend (StoreObservation -> StoreFacts
obFacts (SweepStore -> StoreObservation
ssObserve SweepStore
cache)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (combined inventory)"
            }
    alphabet :: NameAlphabet
alphabet = StoreObservation -> StoreObservation -> NameAlphabet
groupAlphabet (SweepMount -> StoreObservation
observed SweepMount
mount) (SweepStore -> StoreObservation
ssObserve SweepStore
cache)
    resumable :: Bool
resumable = SweepPacing -> SweepShape
swpShape SweepPacing
pacing SweepShape -> SweepShape -> Bool
forall a. Eq a => a -> a -> Bool
== SweepShape
SweepEverything Bool -> Bool -> Bool
&& NameAlphabet
alphabet NameAlphabet -> NameAlphabet -> Bool
forall a. Eq a => a -> a -> Bool
== SweepMount -> NameAlphabet
alphabetOf SweepMount
mount
    marker :: (StoreCursor -> IO (Either StoreFault ())) -> IO (Maybe CycleHalt)
marker StoreCursor -> IO (Either StoreFault ())
action = if Bool
resumable then SweepPacing
-> SweepPorts
-> SweepMount
-> (StoreCursor -> IO (Either StoreFault ()))
-> IO (Maybe CycleHalt)
onCursor SweepPacing
pacing SweepPorts
ports SweepMount
mount StoreCursor -> IO (Either StoreFault ())
action else Maybe CycleHalt -> IO (Maybe CycleHalt)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe CycleHalt
forall a. Maybe a
Nothing
    go :: Maybe NamePrefix -> [NamePrefix] -> IO (Maybe CycleHalt)
go Maybe NamePrefix
_ [] = (StoreCursor -> IO (Either StoreFault ())) -> IO (Maybe CycleHalt)
marker StoreCursor -> IO (Either StoreFault ())
clearCursor
    go Maybe NamePrefix
resume (NamePrefix
prefix : [NamePrefix]
rest) =
        NameAlphabet
-> NamePrefix
-> StoreObservation
-> StoreObservation
-> IO
     (BucketNames (StoreObservation, StoreFault) (PackageName, [Bool]))
collectGroupBucket NameAlphabet
alphabet NamePrefix
prefix (SweepMount -> StoreObservation
observed SweepMount
mount) (SweepStore -> StoreObservation
ssObserve SweepStore
cache) IO
  (BucketNames (StoreObservation, StoreFault) (PackageName, [Bool]))
-> (BucketNames
      (StoreObservation, StoreFault) (PackageName, [Bool])
    -> IO (Maybe CycleHalt))
-> IO (Maybe CycleHalt)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            BucketFaulted (StoreObservation
store, StoreFault
fault) -> Maybe CycleHalt -> IO (Maybe CycleHalt)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CycleHalt -> Maybe CycleHalt
forall a. a -> Maybe a
Just (SweepMount -> StoreFault -> CycleHalt
storeHalt (SweepMount -> StoreObservation -> SweepMount
locatedMount SweepMount
mount StoreObservation
store) StoreFault
fault))
            BucketNames (StoreObservation, StoreFault) (PackageName, [Bool])
BucketUnsplittable -> Maybe CycleHalt -> IO (Maybe CycleHalt)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CycleHalt -> Maybe CycleHalt
forall a. a -> Maybe a
Just (Ecosystem -> Text -> Text -> CycleHalt
HaltBucketUnsplittable (SweepMount -> Ecosystem
smEcosystem SweepMount
mount) (GroupWalk -> Text
gwCombined GroupWalk
walk) (NamePrefix -> Text
renderNamePrefix NamePrefix
prefix)))
            BucketOverflowed NonEmpty NamePrefix
narrower -> Maybe NamePrefix -> [NamePrefix] -> IO (Maybe CycleHalt)
go Maybe NamePrefix
resume (Maybe NamePrefix -> [NamePrefix] -> [NamePrefix]
resumeAfter Maybe NamePrefix
resume (NonEmpty NamePrefix -> [NamePrefix]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty NamePrefix
narrower) [NamePrefix] -> [NamePrefix] -> [NamePrefix]
forall a. Semigroup a => a -> a -> a
<> [NamePrefix]
rest)
            BucketRead [(PackageName, [Bool])]
names ->
                SweepPorts
-> SweepMount
-> (CandidateSet -> EvalContext -> IO (Maybe CycleHalt))
-> IO (Maybe CycleHalt)
forall a.
SweepPorts
-> SweepMount -> (CandidateSet -> EvalContext -> IO a) -> IO a
withCandidates
                    SweepPorts
ports
                    SweepMount
mount
                    ( \CandidateSet
candidates EvalContext
ctx ->
                        ((PackageName, [Bool]) -> IO (Maybe CycleHalt))
-> [(PackageName, [Bool])] -> IO (Maybe CycleHalt)
forall a.
(a -> IO (Maybe CycleHalt)) -> [a] -> IO (Maybe CycleHalt)
stepUntilHalt (GroupWalk
-> EvalContext -> (PackageName, [Bool]) -> IO (Maybe CycleHalt)
sweepOneName GroupWalk
walk EvalContext
ctx) (((PackageName, [Bool]) -> Bool)
-> [(PackageName, [Bool])] -> [(PackageName, [Bool])]
forall a. (a -> Bool) -> [a] -> [a]
filter (CandidateSet -> PackageName -> Bool
wanted CandidateSet
candidates (PackageName -> Bool)
-> ((PackageName, [Bool]) -> PackageName)
-> (PackageName, [Bool])
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageName, [Bool]) -> PackageName
forall a b. (a, b) -> a
fst) [(PackageName, [Bool])]
names)
                    )
                    IO (Maybe CycleHalt)
-> (Maybe CycleHalt -> IO (Maybe CycleHalt))
-> IO (Maybe CycleHalt)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO (Maybe CycleHalt)
-> (CycleHalt -> IO (Maybe CycleHalt))
-> Maybe CycleHalt
-> IO (Maybe CycleHalt)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ((StoreCursor -> IO (Either StoreFault ())) -> IO (Maybe CycleHalt)
marker (StoreCursor -> NamePrefix -> IO (Either StoreFault ())
`writeCursor` NamePrefix
prefix) IO (Maybe CycleHalt)
-> (Maybe CycleHalt -> IO (Maybe CycleHalt))
-> IO (Maybe CycleHalt)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO (Maybe CycleHalt)
-> (CycleHalt -> IO (Maybe CycleHalt))
-> Maybe CycleHalt
-> IO (Maybe CycleHalt)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe NamePrefix -> [NamePrefix] -> IO (Maybe CycleHalt)
go Maybe NamePrefix
resume [NamePrefix]
rest) (Maybe CycleHalt -> IO (Maybe CycleHalt)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe CycleHalt -> IO (Maybe CycleHalt))
-> (CycleHalt -> Maybe CycleHalt)
-> CycleHalt
-> IO (Maybe CycleHalt)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CycleHalt -> Maybe CycleHalt
forall a. a -> Maybe a
Just)) (Maybe CycleHalt -> IO (Maybe CycleHalt)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe CycleHalt -> IO (Maybe CycleHalt))
-> (CycleHalt -> Maybe CycleHalt)
-> CycleHalt
-> IO (Maybe CycleHalt)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CycleHalt -> Maybe CycleHalt
forall a. a -> Maybe a
Just)
    wanted :: CandidateSet -> PackageName -> Bool
wanted CandidateSet
candidates PackageName
name = SweepPacing -> SweepShape
swpShape SweepPacing
pacing SweepShape -> SweepShape -> Bool
forall a. Eq a => a -> a -> Bool
== SweepShape
SweepEverything Bool -> Bool -> Bool
|| CandidateSet -> PackageName -> Bool
inCandidates CandidateSet
candidates PackageName
name

{- One name of a bucket: the chunk pause falls here, before the enumeration reads, so a pause
never lands between the two locations of a single name. -}
sweepOneName :: GroupWalk -> EvalContext -> (PackageName, [Bool]) -> IO (Maybe CycleHalt)
sweepOneName :: GroupWalk
-> EvalContext -> (PackageName, [Bool]) -> IO (Maybe CycleHalt)
sweepOneName GroupWalk
walk EvalContext
ctx (PackageName
name, [Bool]
slots) = do
    SweepPacing -> SweepPorts -> SweepState -> IO ()
paceName (GroupWalk -> SweepPacing
gwPacing GroupWalk
walk) (GroupWalk -> SweepPorts
gwPorts GroupWalk
walk) (GroupWalk -> SweepState
gwCounters GroupWalk
walk)
    GroupWalk
-> PackageName
-> [Bool]
-> IO (Either CycleHalt [(SweepStore, [StoredVersion])])
readGroupVersions GroupWalk
walk PackageName
name [Bool]
slots IO (Either CycleHalt [(SweepStore, [StoredVersion])])
-> (Either CycleHalt [(SweepStore, [StoredVersion])]
    -> IO (Maybe CycleHalt))
-> IO (Maybe CycleHalt)
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 CycleHalt
halt -> Maybe CycleHalt -> IO (Maybe CycleHalt)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CycleHalt -> Maybe CycleHalt
forall a. a -> Maybe a
Just CycleHalt
halt)
        Right [(SweepStore, [StoredVersion])]
versions -> case Int
-> [(SweepStore, [StoredVersion])]
-> Either StoreFault [(SweepStore, [StoredVersion])]
forall a.
Int
-> [(a, [StoredVersion])]
-> Either StoreFault [(a, [StoredVersion])]
boundedVersions (SweepStore -> Int
ssVersionLimit (SweepMount -> SweepStore
smStore (GroupWalk -> SweepMount
gwMount GroupWalk
walk))) [(SweepStore, [StoredVersion])]
versions of
            Left StoreFault
fault ->
                Maybe CycleHalt -> IO (Maybe CycleHalt)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CycleHalt -> Maybe CycleHalt
forall a. a -> Maybe a
Just (Ecosystem -> Text -> Text -> CycleHalt
HaltStoreFault (SweepMount -> Ecosystem
smEcosystem (GroupWalk -> SweepMount
gwMount GroupWalk
walk)) (GroupWalk -> Text
gwCombined GroupWalk
walk) (StoreFault -> Text
renderStoreFault StoreFault
fault)))
            Right [(SweepStore, [StoredVersion])]
bounded -> GroupWalk
-> EvalContext
-> PackageName
-> [(SweepStore, [StoredVersion])]
-> IO (Maybe CycleHalt)
groupOutcome GroupWalk
walk EvalContext
ctx PackageName
name [(SweepStore, [StoredVersion])]
bounded

-- What each of a name's locations holds, in slot order. The first store fault halts the cycle.
readGroupVersions :: GroupWalk -> PackageName -> [Bool] -> IO (Either CycleHalt [(SweepStore, [StoredVersion])])
readGroupVersions :: GroupWalk
-> PackageName
-> [Bool]
-> IO (Either CycleHalt [(SweepStore, [StoredVersion])])
readGroupVersions GroupWalk
walk PackageName
name [Bool]
slots = [Either CycleHalt (SweepStore, [StoredVersion])]
-> Either CycleHalt [(SweepStore, [StoredVersion])]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([Either CycleHalt (SweepStore, [StoredVersion])]
 -> Either CycleHalt [(SweepStore, [StoredVersion])])
-> IO [Either CycleHalt (SweepStore, [StoredVersion])]
-> IO (Either CycleHalt [(SweepStore, [StoredVersion])])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (SweepStore -> IO (Either CycleHalt (SweepStore, [StoredVersion])))
-> [SweepStore]
-> IO [Either CycleHalt (SweepStore, [StoredVersion])]
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 SweepStore -> IO (Either CycleHalt (SweepStore, [StoredVersion]))
readOne [SweepStore]
locations
  where
    locations :: [SweepStore]
locations = (Bool -> SweepStore) -> [Bool] -> [SweepStore]
forall a b. (a -> b) -> [a] -> [b]
map (\Bool
slot -> if Bool
slot then GroupWalk -> SweepStore
gwCache GroupWalk
walk else SweepMount -> SweepStore
smStore (GroupWalk -> SweepMount
gwMount GroupWalk
walk)) [Bool]
slots
    readOne :: SweepStore -> IO (Either CycleHalt (SweepStore, [StoredVersion]))
readOne SweepStore
store =
        ([StoredVersion] -> (SweepStore, [StoredVersion]))
-> Either CycleHalt [StoredVersion]
-> Either CycleHalt (SweepStore, [StoredVersion])
forall a b. (a -> b) -> Either CycleHalt a -> Either CycleHalt b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SweepStore
store,)
            (Either CycleHalt [StoredVersion]
 -> Either CycleHalt (SweepStore, [StoredVersion]))
-> IO (Either CycleHalt [StoredVersion])
-> IO (Either CycleHalt (SweepStore, [StoredVersion]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SweepPacing
-> SweepPorts
-> SweepMount
-> IO (Either StoreFault [StoredVersion])
-> IO (Either CycleHalt [StoredVersion])
forall a.
SweepPacing
-> SweepPorts
-> SweepMount
-> IO (Either StoreFault a)
-> IO (Either CycleHalt a)
withStoreRetry
                (GroupWalk -> SweepPacing
gwPacing GroupWalk
walk)
                (GroupWalk -> SweepPorts
gwPorts GroupWalk
walk)
                (SweepMount -> StoreObservation -> SweepMount
locatedMount (GroupWalk -> SweepMount
gwMount GroupWalk
walk) (SweepStore -> StoreObservation
ssObserve SweepStore
store))
                (StoreObservation
-> PackageName -> IO (Either StoreFault [StoredVersion])
obEnumerateVersions (SweepStore -> StoreObservation
ssObserve SweepStore
store) PackageName
name)

-- Count or remove one name's joined inventory, as the mount's execution mode decides.
groupOutcome :: GroupWalk -> EvalContext -> PackageName -> [(SweepStore, [StoredVersion])] -> IO (Maybe CycleHalt)
groupOutcome :: GroupWalk
-> EvalContext
-> PackageName
-> [(SweepStore, [StoredVersion])]
-> IO (Maybe CycleHalt)
groupOutcome GroupWalk
walk EvalContext
ctx PackageName
name [(SweepStore, [StoredVersion])]
bounded = case SweepStore -> SweepExecution
ssExecute (SweepMount -> SweepStore
smStore SweepMount
mount) of
    SweepExecution
SweepCounts -> SweepPacing
-> SweepPorts
-> SweepState
-> SweepMount
-> EvalContext
-> PackageName
-> [(StoreObservation, [StoredVersion])]
-> IO (Maybe CycleHalt)
previewPackageGroup SweepPacing
pacing SweepPorts
ports SweepState
counters SweepMount
mount EvalContext
ctx PackageName
name (((SweepStore, [StoredVersion])
 -> (StoreObservation, [StoredVersion]))
-> [(SweepStore, [StoredVersion])]
-> [(StoreObservation, [StoredVersion])]
forall a b. (a -> b) -> [a] -> [b]
map ((SweepStore -> StoreObservation)
-> (SweepStore, [StoredVersion])
-> (StoreObservation, [StoredVersion])
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first SweepStore -> StoreObservation
ssObserve) [(SweepStore, [StoredVersion])]
bounded)
    SweepRemoves StoreDeletion
_ ->
        SweepPacing
-> SweepPorts
-> SweepState
-> SweepMount
-> PackageName
-> [(SweepStore, [StoredVersion])]
-> IO (Maybe CycleHalt)
sweepPackageGroup SweepPacing
pacing SweepPorts
ports SweepState
counters SweepMount
mount PackageName
name [(SweepMount -> SweepStore
smStore SweepMount
mount, SweepStore -> [StoredVersion]
held (SweepMount -> SweepStore
smStore SweepMount
mount)), (GroupWalk -> SweepStore
gwCache GroupWalk
walk, SweepStore -> [StoredVersion]
held (GroupWalk -> SweepStore
gwCache GroupWalk
walk))]
  where
    pacing :: SweepPacing
pacing = GroupWalk -> SweepPacing
gwPacing GroupWalk
walk
    ports :: SweepPorts
ports = GroupWalk -> SweepPorts
gwPorts GroupWalk
walk
    counters :: SweepState
counters = GroupWalk -> SweepState
gwCounters GroupWalk
walk
    mount :: SweepMount
mount = GroupWalk -> SweepMount
gwMount GroupWalk
walk
    -- Read with `lookup`, so two stores under one backend name both take the first one's
    -- inventory. A Map would take the last instead, which is a different set of versions.
    held :: SweepStore -> [StoredVersion]
held SweepStore
store = [StoredVersion] -> Maybe [StoredVersion] -> [StoredVersion]
forall a. a -> Maybe a -> a
fromMaybe [] (Text -> [(Text, [StoredVersion])] -> Maybe [StoredVersion]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (SweepStore -> Text
backendName SweepStore
store) [(SweepStore -> Text
backendName SweepStore
located, [StoredVersion]
versions) | (SweepStore
located, [StoredVersion]
versions) <- [(SweepStore, [StoredVersion])]
bounded])
    backendName :: SweepStore -> Text
backendName = StoreFacts -> Text
factBackend (StoreFacts -> Text)
-> (SweepStore -> StoreFacts) -> SweepStore -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StoreObservation -> StoreFacts
obFacts (StoreObservation -> StoreFacts)
-> (SweepStore -> StoreObservation) -> SweepStore -> StoreFacts
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SweepStore -> StoreObservation
ssObserve

locatedMount :: SweepMount -> StoreObservation -> SweepMount
locatedMount :: SweepMount -> StoreObservation -> SweepMount
locatedMount SweepMount
mount StoreObservation
store = SweepMount
mount{smStore = countingAt (smStore mount) store}

{- One bucket's candidates under a pinned lookup. Later rule evaluations acquire their own lookups.
A generation swapped mid-bucket defers a name it newly covers by one cycle. -}
withCandidates :: SweepPorts -> SweepMount -> (CandidateSet -> EvalContext -> IO a) -> IO a
withCandidates :: forall a.
SweepPorts
-> SweepMount -> (CandidateSet -> EvalContext -> IO a) -> IO a
withCandidates SweepPorts
ports SweepMount
mount CandidateSet -> EvalContext -> IO a
act =
    RuleDeps -> (Maybe (DbEtag, CveLookup) -> IO a) -> IO a
forall a. RuleDeps -> (Maybe (DbEtag, CveLookup) -> IO a) -> IO a
withCveLookup (SweepMount -> RuleDeps
smRuleDeps SweepMount
mount) ((Maybe (DbEtag, CveLookup) -> IO a) -> IO a)
-> (Maybe (DbEtag, CveLookup) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Maybe (DbEtag, CveLookup)
mLookup -> do
        candidates <- ProjectName -> [Rule] -> Maybe CveLookup -> IO CandidateSet
candidateSet (SweepMount -> ProjectName
smProjectName SweepMount
mount) (SweepMount -> [Rule]
smConfigured SweepMount
mount) ((DbEtag, CveLookup) -> CveLookup
forall a b. (a, b) -> b
snd ((DbEtag, CveLookup) -> CveLookup)
-> Maybe (DbEtag, CveLookup) -> Maybe CveLookup
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (DbEtag, CveLookup)
mLookup)
        ctx <- mkEvalContext (sweepNow ports) (pure (fst <$> mLookup))
        act candidates ctx

{- Say once per mount whose rules read advisories and no generation is loaded. Only the identity
half then sweeps, so that rule set decided on less than it names, which is the gap recorded here. -}
reportAdvisoryHalf :: SweepPorts -> SweepState -> SweepMount -> IO ()
reportAdvisoryHalf :: SweepPorts -> SweepState -> SweepMount -> IO ()
reportAdvisoryHalf SweepPorts
ports SweepState
counters SweepMount
mount =
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Rule -> Bool) -> [Rule] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Rule -> Bool
readsAdvisories (SweepMount -> [Rule]
smConfigured SweepMount
mount)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        RuleDeps -> (Maybe (DbEtag, CveLookup) -> IO ()) -> IO ()
forall a. RuleDeps -> (Maybe (DbEtag, CveLookup) -> IO a) -> IO a
withCveLookup (SweepMount -> RuleDeps
smRuleDeps SweepMount
mount) ((Maybe (DbEtag, CveLookup) -> IO ()) -> IO ())
-> (Maybe (DbEtag, CveLookup) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Maybe (DbEtag, CveLookup)
mLookup ->
            Maybe (DbEtag, CveLookup) -> IO () -> IO ()
forall (f :: * -> *) a. Applicative f => Maybe a -> f () -> f ()
whenNothing_ Maybe (DbEtag, CveLookup)
mLookup (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                SweepState -> EvidenceGaps -> IO ()
recordGap SweepState
counters EvidenceGaps
unloadedGeneration
                SweepAudit -> Text -> IO ()
auditError
                    (SweepPorts -> SweepAudit
sweepAudit SweepPorts
ports)
                    ( Text
"no advisory database generation is loaded for the "
                        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Ecosystem -> Text
ecosystemName (SweepMount -> Ecosystem
smEcosystem SweepMount
mount)
                        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" mount, so this cycle sweeps only the names an identity deny pins"
                    )

paceName :: SweepPacing -> SweepPorts -> SweepState -> IO ()
paceName :: SweepPacing -> SweepPorts -> SweepState -> IO ()
paceName SweepPacing
pacing SweepPorts
ports SweepState
counters = do
    progress <- IORef Int -> IO Int
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef (SweepState -> IORef Int
stChunkProgress SweepState
counters)
    when (progress >= max 1 (swpChunkSize pacing)) $ do
        sweepDelay ports (swpChunkPause pacing)
        writeIORef (stChunkProgress counters) 0
    modifyIORef' (stChunkProgress counters) (+ 1)

{- The bucket the last run of this walk completed. A store with nowhere to keep one resumes from
the first bucket every cycle, which is a value here rather than a branch. -}
readWalkCursor :: SweepPacing -> SweepPorts -> SweepMount -> IO (Either CycleHalt (Maybe NamePrefix))
readWalkCursor :: SweepPacing
-> SweepPorts
-> SweepMount
-> IO (Either CycleHalt (Maybe NamePrefix))
readWalkCursor SweepPacing
pacing SweepPorts
ports SweepMount
mount = case SweepStore -> Maybe StoreCursor
walkMarkerOf (SweepMount -> SweepStore
smStore SweepMount
mount) of
    Maybe StoreCursor
Nothing -> Either CycleHalt (Maybe NamePrefix)
-> IO (Either CycleHalt (Maybe NamePrefix))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe NamePrefix -> Either CycleHalt (Maybe NamePrefix)
forall a b. b -> Either a b
Right Maybe NamePrefix
forall a. Maybe a
Nothing)
    Just StoreCursor
cursor -> SweepPacing
-> SweepPorts
-> SweepMount
-> IO (Either StoreFault (Maybe NamePrefix))
-> IO (Either CycleHalt (Maybe NamePrefix))
forall a.
SweepPacing
-> SweepPorts
-> SweepMount
-> IO (Either StoreFault a)
-> IO (Either CycleHalt a)
withStoreRetry SweepPacing
pacing SweepPorts
ports SweepMount
mount (StoreCursor -> IO (Either StoreFault (Maybe NamePrefix))
readCursor StoreCursor
cursor)

{- Run one cursor write, where this run holds a cursor to write. A store with nowhere to keep one
records nothing, and a preview holds none at all. -}
onCursor :: SweepPacing -> SweepPorts -> SweepMount -> (StoreCursor -> IO (Either StoreFault ())) -> IO (Maybe CycleHalt)
onCursor :: SweepPacing
-> SweepPorts
-> SweepMount
-> (StoreCursor -> IO (Either StoreFault ()))
-> IO (Maybe CycleHalt)
onCursor SweepPacing
pacing SweepPorts
ports SweepMount
mount StoreCursor -> IO (Either StoreFault ())
write =
    IO (Maybe CycleHalt)
-> (StoreCursor -> IO (Maybe CycleHalt))
-> Maybe StoreCursor
-> IO (Maybe CycleHalt)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe CycleHalt -> IO (Maybe CycleHalt)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe CycleHalt
forall a. Maybe a
Nothing) StoreCursor -> IO (Maybe CycleHalt)
recorded (SweepStore -> Maybe StoreCursor
walkMarkerOf (SweepMount -> SweepStore
smStore SweepMount
mount))
  where
    recorded :: StoreCursor -> IO (Maybe CycleHalt)
recorded StoreCursor
cursor = Either CycleHalt () -> Maybe CycleHalt
forall l r. Either l r -> Maybe l
leftToMaybe (Either CycleHalt () -> Maybe CycleHalt)
-> IO (Either CycleHalt ()) -> IO (Maybe CycleHalt)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SweepPacing
-> SweepPorts
-> SweepMount
-> IO (Either StoreFault ())
-> IO (Either CycleHalt ())
forall a.
SweepPacing
-> SweepPorts
-> SweepMount
-> IO (Either StoreFault a)
-> IO (Either CycleHalt a)
withStoreRetry SweepPacing
pacing SweepPorts
ports SweepMount
mount (StoreCursor -> IO (Either StoreFault ())
write StoreCursor
cursor)

storeHalt :: SweepMount -> StoreFault -> CycleHalt
storeHalt :: SweepMount -> StoreFault -> CycleHalt
storeHalt SweepMount
mount StoreFault
fault = Ecosystem -> Text -> Text -> CycleHalt
HaltStoreFault (SweepMount -> Ecosystem
smEcosystem SweepMount
mount) (SweepMount -> Text
backendOf SweepMount
mount) (StoreFault -> Text
renderStoreFault StoreFault
fault)

observed :: SweepMount -> StoreObservation
observed :: SweepMount -> StoreObservation
observed = SweepStore -> StoreObservation
ssObserve (SweepStore -> StoreObservation)
-> (SweepMount -> SweepStore) -> SweepMount -> StoreObservation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SweepMount -> SweepStore
smStore

backendOf :: SweepMount -> Text
backendOf :: SweepMount -> Text
backendOf = StoreFacts -> Text
factBackend (StoreFacts -> Text)
-> (SweepMount -> StoreFacts) -> SweepMount -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StoreObservation -> StoreFacts
obFacts (StoreObservation -> StoreFacts)
-> (SweepMount -> StoreObservation) -> SweepMount -> StoreFacts
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SweepMount -> StoreObservation
observed

alphabetOf :: SweepMount -> NameAlphabet
alphabetOf :: SweepMount -> NameAlphabet
alphabetOf = StoreFacts -> NameAlphabet
factNameAlphabet (StoreFacts -> NameAlphabet)
-> (SweepMount -> StoreFacts) -> SweepMount -> NameAlphabet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StoreObservation -> StoreFacts
obFacts (StoreObservation -> StoreFacts)
-> (SweepMount -> StoreObservation) -> SweepMount -> StoreFacts
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SweepMount -> StoreObservation
observed

{- | One store call, retried once after the wait its own fault advises. A fault that survives that
wait halts the cycle, which the next cycle re-attempts after the cycle pause.
-}
withStoreRetry :: SweepPacing -> SweepPorts -> SweepMount -> IO (Either StoreFault a) -> IO (Either CycleHalt a)
withStoreRetry :: forall a.
SweepPacing
-> SweepPorts
-> SweepMount
-> IO (Either StoreFault a)
-> IO (Either CycleHalt a)
withStoreRetry SweepPacing
pacing SweepPorts
ports SweepMount
mount IO (Either StoreFault a)
call =
    IO (Either StoreFault a)
call IO (Either StoreFault a)
-> (Either StoreFault a -> IO (Either CycleHalt a))
-> IO (Either CycleHalt a)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Right a
answered -> Either CycleHalt a -> IO (Either CycleHalt a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Either CycleHalt a
forall a b. b -> Either a b
Right a
answered)
        Left StoreFault
fault -> case StoreFault -> RetryAdvice
faultRetry StoreFault
fault of
            RetryAdvice
RetryFutile -> Either CycleHalt a -> IO (Either CycleHalt a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CycleHalt -> Either CycleHalt a
forall a b. a -> Either a b
Left (SweepMount -> StoreFault -> CycleHalt
storeHalt SweepMount
mount StoreFault
fault))
            RetryAdvice
RetryWorthwhile -> NominalDiffTime -> StoreFault -> IO (Either CycleHalt a)
again (SweepPacing -> NominalDiffTime
swpChunkPause SweepPacing
pacing) StoreFault
fault
            RetryDelayed (RetryAfter Int
seconds) -> NominalDiffTime -> StoreFault -> IO (Either CycleHalt a)
again (Int -> NominalDiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
seconds) StoreFault
fault
  where
    -- A retry that clears leaves the cycle running, so it warns rather than reporting a fault the
    -- operator has to act on. Only the halt after a failed retry is an error.
    again :: NominalDiffTime -> StoreFault -> IO (Either CycleHalt a)
again NominalDiffTime
delay StoreFault
fault = do
        SweepAudit -> Text -> IO ()
auditWarn
            (SweepPorts -> SweepAudit
sweepAudit SweepPorts
ports)
            ( Text
"retrying a call against "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Ecosystem -> Text -> Text
storeSubject (SweepMount -> Ecosystem
smEcosystem SweepMount
mount) (SweepMount -> Text
backendOf SweepMount
mount)
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" after "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> StoreFault -> Text
renderStoreFault StoreFault
fault
            )
        SweepPorts -> NominalDiffTime -> IO ()
sweepDelay SweepPorts
ports NominalDiffTime
delay
        (StoreFault -> CycleHalt)
-> Either StoreFault a -> Either CycleHalt 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 (SweepMount -> StoreFault -> CycleHalt
storeHalt SweepMount
mount) (Either StoreFault a -> Either CycleHalt a)
-> IO (Either StoreFault a) -> IO (Either CycleHalt a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Either StoreFault a)
call