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

{- | Grouped deletion over backend-owned batches. Every attempt rechecks current policy and
local inventory, and associated targets share one logical charge before their first attempt.
-}
module Ecluse.Core.Registry.Sweep.Deletion (deleteGroup, Selection (..)) where

import Data.Map.Strict qualified as Map
import Data.Set qualified as Set
import Data.Text qualified as T

import Ecluse.Core.Cve.Types (DbEtag)
import Ecluse.Core.Fault (RetryAfter (RetryAfter))
import Ecluse.Core.Package (PackageName)
import Ecluse.Core.Registry.Maintenance
import Ecluse.Core.Registry.Sweep.Group (boundedVersions)
import Ecluse.Core.Registry.Sweep.Outcome (CycleHalt (HaltDeletionCap, HaltStoreFault), renderStoreFault)
import Ecluse.Core.Registry.Sweep.Types
import Ecluse.Core.Telemetry.Metrics (SweepResult (SweepGuardSkipped), SweepTarget (SweepMirror))
import Ecluse.Core.Version (Version, renderVersion)

-- | A current named denial carries the generation credited when the logical cap fills.
data Selection = Selection
    { Selection -> Version
selVersion :: Version
    , Selection -> Text
selMessage :: Text
    , Selection -> Maybe DbEtag
selGeneration :: Maybe DbEtag
    }

type SelectStored = Bool -> SweepMount -> [StoredVersion] -> IO [Selection]

type ReportOutcome = SweepPorts -> (Version, VersionOutcome) -> IO ()

data DeletionRun = DeletionRun
    { DeletionRun -> SweepPacing
runPacing :: SweepPacing
    , DeletionRun -> SweepPorts
runPorts :: SweepPorts
    , DeletionRun -> SweepState
runCounters :: SweepState
    , DeletionRun -> SweepMount
runMount :: SweepMount
    , DeletionRun -> PackageName
runName :: PackageName
    , DeletionRun -> SelectStored
runSelect :: SelectStored
    , DeletionRun -> [SweepStore]
runStores :: [SweepStore]
    , DeletionRun -> IORef (Set Text)
runCharged :: IORef (Set Text)
    , DeletionRun -> IORef (Maybe DbEtag)
runCapGeneration :: IORef (Maybe DbEtag)
    , DeletionRun -> IORef (Maybe CycleHalt)
runHalt :: IORef (Maybe CycleHalt)
    }

-- | Reassess each target independently and finish charged cache work before returning a cap halt.
deleteGroup ::
    SweepPacing ->
    SweepPorts ->
    SweepState ->
    SweepMount ->
    PackageName ->
    SelectStored ->
    ReportOutcome ->
    [(SweepStore, [StoredVersion])] ->
    IO (Maybe CycleHalt)
deleteGroup :: 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 ReportOutcome
report [(SweepStore, [StoredVersion])]
locations = do
    run <- SweepPacing
-> SweepPorts
-> SweepState
-> SweepMount
-> PackageName
-> SelectStored
-> [SweepStore]
-> IORef (Set Text)
-> IORef (Maybe DbEtag)
-> IORef (Maybe CycleHalt)
-> DeletionRun
DeletionRun SweepPacing
pacing SweepPorts
ports SweepState
counters SweepMount
mount PackageName
name SelectStored
select (((SweepStore, [StoredVersion]) -> SweepStore)
-> [(SweepStore, [StoredVersion])] -> [SweepStore]
forall a b. (a -> b) -> [a] -> [b]
map (SweepStore, [StoredVersion]) -> SweepStore
forall a b. (a, b) -> a
fst [(SweepStore, [StoredVersion])]
locations) (IORef (Set Text)
 -> IORef (Maybe DbEtag) -> IORef (Maybe CycleHalt) -> DeletionRun)
-> IO (IORef (Set Text))
-> IO
     (IORef (Maybe DbEtag) -> IORef (Maybe CycleHalt) -> DeletionRun)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set Text -> IO (IORef (Set Text))
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef Set Text
forall a. Set a
Set.empty IO (IORef (Maybe DbEtag) -> IORef (Maybe CycleHalt) -> DeletionRun)
-> IO (IORef (Maybe DbEtag))
-> IO (IORef (Maybe CycleHalt) -> DeletionRun)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe DbEtag -> IO (IORef (Maybe DbEtag))
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef Maybe DbEtag
forall a. Maybe a
Nothing IO (IORef (Maybe CycleHalt) -> DeletionRun)
-> IO (IORef (Maybe CycleHalt)) -> IO DeletionRun
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe CycleHalt -> IO (IORef (Maybe CycleHalt))
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef Maybe CycleHalt
forall a. Maybe a
Nothing
    traverse_ (deleteLocation run report) locations
    issued <- readIORef (stIssued counters)
    halt <- readIORef (runHalt run)
    generation <- readIORef (runCapGeneration run)
    pure (if issued >= swpDeletionCap pacing then Just (HaltDeletionCap (swpDeletionCap pacing) issued generation) else halt)

deleteLocation :: DeletionRun -> ReportOutcome -> (SweepStore, [StoredVersion]) -> IO ()
deleteLocation :: DeletionRun
-> ReportOutcome -> (SweepStore, [StoredVersion]) -> IO ()
deleteLocation DeletionRun
run ReportOutcome
report (SweepStore
store, [StoredVersion]
initial) = case SweepStore -> SweepExecution
ssExecute SweepStore
store of
    SweepExecution
SweepCounts -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    SweepRemoves StoreDeletion
deletion -> do
        selected <- DeletionRun -> SelectStored
runSelect DeletionRun
run Bool
True (DeletionRun -> SweepStore -> SweepMount
atStore DeletionRun
run SweepStore
store) [StoredVersion]
initial
        let checks = (DeletePhase -> [Version] -> IO (Either StoreFault [Version]))
-> (StoreFault -> IO Bool) -> DeleteGuard
DeleteGuard (DeletionRun
-> SweepStore
-> DeletePhase
-> [Version]
-> IO (Either StoreFault [Version])
checkBatch DeletionRun
run SweepStore
store) (DeletionRun -> SweepStore -> StoreFault -> IO Bool
retryDelete DeletionRun
run SweepStore
store)
        offered <- withinAllowance run store (map selVersion selected)
        outcomes <- dlDeleteVersions deletion checks (runName run) offered
        traverse_ (report (labelled run store)) outcomes
        confirm run store (mapMaybe confirmationVersion outcomes)

confirmationVersion :: (Version, VersionOutcome) -> Maybe Version
confirmationVersion :: (Version, VersionOutcome) -> Maybe Version
confirmationVersion (Version
version, VersionOutcome
outcome) = case VersionOutcome
outcome of
    VersionOutcome
VersionRemoved -> Version -> Maybe Version
forall a. a -> Maybe a
Just Version
version
    VersionUncertain StoreFault
_ -> Version -> Maybe Version
forall a. a -> Maybe a
Just Version
version
    VersionRemoving Text
_ -> Maybe Version
forall a. Maybe a
Nothing
    VersionRefused StoreRefusal
_ -> Maybe Version
forall a. Maybe a
Nothing
    VersionUnreached StoreFault
_ -> Maybe Version
forall a. Maybe a
Nothing

checkBatch :: DeletionRun -> SweepStore -> DeletePhase -> [Version] -> IO (Either StoreFault [Version])
checkBatch :: DeletionRun
-> SweepStore
-> DeletePhase
-> [Version]
-> IO (Either StoreFault [Version])
checkBatch DeletionRun
run SweepStore
store DeletePhase
phase [Version]
proposed = DeletionRun
-> SweepStore
-> (Map Text [StoredVersion] -> IO (Either StoreFault [Version]))
-> IO (Either StoreFault [Version])
forall a.
DeletionRun
-> SweepStore
-> (Map Text [StoredVersion] -> IO (Either StoreFault a))
-> IO (Either StoreFault a)
withCurrentPermission DeletionRun
run SweepStore
store (DeletionRun
-> SweepStore
-> DeletePhase
-> [Version]
-> Map Text [StoredVersion]
-> IO (Either StoreFault [Version])
assessBatch DeletionRun
run SweepStore
store DeletePhase
phase [Version]
proposed)

{- Read the group's inventory and the store's standing permissions, refusing on either fault. The
inventory the continuation receives is the one this read produced, never an earlier one. -}
withCurrentPermission ::
    DeletionRun ->
    SweepStore ->
    (Map Text [StoredVersion] -> IO (Either StoreFault a)) ->
    IO (Either StoreFault a)
withCurrentPermission :: forall a.
DeletionRun
-> SweepStore
-> (Map Text [StoredVersion] -> IO (Either StoreFault a))
-> IO (Either StoreFault a)
withCurrentPermission DeletionRun
run SweepStore
store Map Text [StoredVersion] -> IO (Either StoreFault a)
continue =
    DeletionRun
-> IO (Either (Text, StoreFault) (Map Text [StoredVersion]))
currentGroup DeletionRun
run IO (Either (Text, StoreFault) (Map Text [StoredVersion]))
-> (Either (Text, StoreFault) (Map Text [StoredVersion])
    -> IO (Either StoreFault a))
-> IO (Either StoreFault 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
        Left (Text
target, StoreFault
fault) -> DeletionRun -> Text -> StoreFault -> IO (Either StoreFault a)
forall a.
DeletionRun -> Text -> StoreFault -> IO (Either StoreFault a)
refuse DeletionRun
run Text
target StoreFault
fault
        Right Map Text [StoredVersion]
inventories ->
            SweepStore -> IO (Either StoreFault ())
permission SweepStore
store IO (Either StoreFault ())
-> (Either StoreFault () -> IO (Either StoreFault a))
-> IO (Either StoreFault 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
                Left StoreFault
fault -> DeletionRun -> Text -> StoreFault -> IO (Either StoreFault a)
forall a.
DeletionRun -> Text -> StoreFault -> IO (Either StoreFault a)
refuse DeletionRun
run (SweepStore -> Text
backend SweepStore
store) StoreFault
fault
                Right () -> Map Text [StoredVersion] -> IO (Either StoreFault a)
continue Map Text [StoredVersion]
inventories

{- The second read is deliberate: a decision and a permission taken before the batch was proposed
say nothing about the store now, and a delete is permanent. -}
assessBatch :: DeletionRun -> SweepStore -> DeletePhase -> [Version] -> Map Text [StoredVersion] -> IO (Either StoreFault [Version])
assessBatch :: DeletionRun
-> SweepStore
-> DeletePhase
-> [Version]
-> Map Text [StoredVersion]
-> IO (Either StoreFault [Version])
assessBatch DeletionRun
run SweepStore
store DeletePhase
phase [Version]
proposed Map Text [StoredVersion]
inventories = do
    decisions <- DeletionRun -> SelectStored
runSelect DeletionRun
run Bool
False (DeletionRun -> SweepStore -> SweepMount
atStore DeletionRun
run SweepStore
store) [StoredVersion]
before
    denied <-
        if atSource
            then pure Nothing
            else Just . map selVersion <$> runSelect run False (atStore run source) sourceBefore
    withCurrentPermission run store $ \Map Text [StoredVersion]
checked -> do
        let sourceView :: Maybe SourceView
sourceView = (\[Version]
names -> [Version] -> [StoredVersion] -> [StoredVersion] -> SourceView
SourceView [Version]
names [StoredVersion]
sourceBefore (SweepStore -> Map Text [StoredVersion] -> [StoredVersion]
inventory SweepStore
source Map Text [StoredVersion]
checked)) ([Version] -> SourceView) -> Maybe [Version] -> Maybe SourceView
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [Version]
denied
            allowed :: [Version]
allowed = (Version -> Bool) -> [Version] -> [Version]
forall a. (a -> Bool) -> [a] -> [a]
filter ([Version]
-> [StoredVersion]
-> [StoredVersion]
-> Maybe SourceView
-> Version
-> Bool
admissible ((Selection -> Version) -> [Selection] -> [Version]
forall a b. (a -> b) -> [a] -> [b]
map Selection -> Version
selVersion [Selection]
decisions) [StoredVersion]
before (SweepStore -> Map Text [StoredVersion] -> [StoredVersion]
inventory SweepStore
store Map Text [StoredVersion]
checked) Maybe SourceView
sourceView) [Version]
proposed
        DeletionRun
-> SweepStore
-> DeletePhase
-> [Selection]
-> [Version]
-> IO (Either StoreFault [Version])
admitReassessed DeletionRun
run SweepStore
store DeletePhase
phase [Selection]
decisions [Version]
allowed
  where
    before :: [StoredVersion]
before = SweepStore -> Map Text [StoredVersion] -> [StoredVersion]
inventory SweepStore
store Map Text [StoredVersion]
inventories
    source :: SweepStore
source = SweepMount -> SweepStore
smStore (DeletionRun -> SweepMount
runMount DeletionRun
run)
    sourceBefore :: [StoredVersion]
sourceBefore = SweepStore -> Map Text [StoredVersion] -> [StoredVersion]
inventory SweepStore
source Map Text [StoredVersion]
inventories
    atSource :: Bool
atSource = DeletionRun -> SweepStore -> Bool
isSource DeletionRun
run SweepStore
store

-- The source store's own view of the batch, held only where the store being assessed is a cache.
data SourceView = SourceView
    { SourceView -> [Version]
svDenied :: [Version]
    , SourceView -> [StoredVersion]
svBefore :: [StoredVersion]
    , SourceView -> [StoredVersion]
svAfter :: [StoredVersion]
    }

-- A proposed version stands only while every store that decided it still reads as it did.
admissible :: [Version] -> [StoredVersion] -> [StoredVersion] -> Maybe SourceView -> Version -> Bool
admissible :: [Version]
-> [StoredVersion]
-> [StoredVersion]
-> Maybe SourceView
-> Version
-> Bool
admissible [Version]
decided [StoredVersion]
before [StoredVersion]
after Maybe SourceView
source Version
version =
    Version
version Version -> [Version] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` [Version]
decided
        Bool -> Bool -> Bool
&& Version -> [StoredVersion] -> [StoredVersion] -> Bool
unchanged Version
version [StoredVersion]
before [StoredVersion]
after
        Bool -> Bool -> Bool
&& (SourceView -> Bool) -> Maybe SourceView -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Version -> SourceView -> Bool
admittedAtSource Version
version) Maybe SourceView
source

admittedAtSource :: Version -> SourceView -> Bool
admittedAtSource :: Version -> SourceView -> Bool
admittedAtSource Version
version SourceView
view =
    Version
version Version -> [Version] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`notElem` SourceView -> [Version]
svDenied SourceView
view Bool -> Bool -> Bool
&& Version -> [StoredVersion] -> Maybe StoredVersion
entry Version
version (SourceView -> [StoredVersion]
svBefore SourceView
view) Maybe StoredVersion -> Maybe StoredVersion -> Bool
forall a. Eq a => a -> a -> Bool
== Version -> [StoredVersion] -> Maybe StoredVersion
entry Version
version (SourceView -> [StoredVersion]
svAfter SourceView
view)

-- Only the pre-delete phase charges the cap and announces, so a retry's recheck does neither twice.
admitReassessed :: DeletionRun -> SweepStore -> DeletePhase -> [Selection] -> [Version] -> IO (Either StoreFault [Version])
admitReassessed :: DeletionRun
-> SweepStore
-> DeletePhase
-> [Selection]
-> [Version]
-> IO (Either StoreFault [Version])
admitReassessed DeletionRun
run SweepStore
store DeletePhase
phase [Selection]
decisions [Version]
allowed = do
    admitted <- if DeletePhase
phase DeletePhase -> DeletePhase -> Bool
forall a. Eq a => a -> a -> Bool
== DeletePhase
BeforeDelete then DeletionRun -> SweepStore -> [Selection] -> IO [Version]
charge DeletionRun
run SweepStore
store ((Selection -> Bool) -> [Selection] -> [Selection]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Version -> [Version] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` [Version]
allowed) (Version -> Bool) -> (Selection -> Version) -> Selection -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Selection -> Version
selVersion) [Selection]
decisions) else [Version] -> IO [Version]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Version]
allowed
    when (phase == BeforeDelete) $
        traverse_ (auditInfo (sweepAudit (labelled run store)) . selMessage) (filter ((`elem` admitted) . selVersion) decisions)
    pure (Right admitted)

currentGroup :: DeletionRun -> IO (Either (Text, StoreFault) (Map Text [StoredVersion]))
currentGroup :: DeletionRun
-> IO (Either (Text, StoreFault) (Map Text [StoredVersion]))
currentGroup DeletionRun
run = do
    inventories <- (SweepStore
 -> IO (Either (Text, StoreFault) (SweepStore, [StoredVersion])))
-> [SweepStore]
-> IO [Either (Text, StoreFault) (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 (Text, StoreFault) (SweepStore, [StoredVersion]))
readOne (DeletionRun -> [SweepStore]
runStores DeletionRun
run)
    pure $ do
        readable <- sequence inventories
        bounded <- first (combined,) (boundedVersions (ssVersionLimit (smStore (runMount run))) readable)
        pure (Map.fromList [(backend store, versions) | (store, versions) <- bounded])
  where
    readOne :: SweepStore
-> IO (Either (Text, StoreFault) (SweepStore, [StoredVersion]))
readOne SweepStore
store = (StoreFault -> (Text, StoreFault))
-> Either StoreFault (SweepStore, [StoredVersion])
-> Either (Text, StoreFault) (SweepStore, [StoredVersion])
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 (SweepStore -> Text
backend SweepStore
store,) (Either StoreFault (SweepStore, [StoredVersion])
 -> Either (Text, StoreFault) (SweepStore, [StoredVersion]))
-> (Either StoreFault [StoredVersion]
    -> Either StoreFault (SweepStore, [StoredVersion]))
-> Either StoreFault [StoredVersion]
-> Either (Text, StoreFault) (SweepStore, [StoredVersion])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([StoredVersion] -> (SweepStore, [StoredVersion]))
-> Either StoreFault [StoredVersion]
-> Either StoreFault (SweepStore, [StoredVersion])
forall a b. (a -> b) -> Either StoreFault a -> Either StoreFault b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SweepStore
store,) (Either StoreFault [StoredVersion]
 -> Either (Text, StoreFault) (SweepStore, [StoredVersion]))
-> IO (Either StoreFault [StoredVersion])
-> IO (Either (Text, StoreFault) (SweepStore, [StoredVersion]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StoreObservation
-> PackageName -> IO (Either StoreFault [StoredVersion])
obEnumerateVersions (SweepStore -> StoreObservation
ssObserve SweepStore
store) (DeletionRun -> PackageName
runName DeletionRun
run)
    combined :: Text
combined = Text -> [Text] -> Text
T.intercalate Text
" and " ((SweepStore -> Text) -> [SweepStore] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map SweepStore -> Text
backend (DeletionRun -> [SweepStore]
runStores DeletionRun
run)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (combined inventory)"

permission :: SweepStore -> IO (Either StoreFault ())
permission :: SweepStore -> IO (Either StoreFault ())
permission SweepStore
store = do
    consent <- StoreObservation -> IO (Either StoreFault ConsentVerdict)
obVerifyConsent (SweepStore -> StoreObservation
ssObserve SweepStore
store)
    classified <- obClassifyStore (ssObserve store)
    pure $ do
        marker <- consent
        case marker of
            ConsentWithheld Text
descriptor -> StoreFault -> Either StoreFault ()
forall a b. a -> Either a b
Left (Text -> StoreFault
protocolFault Text
descriptor)
            ConsentVerdict
ConsentGranted -> () -> Either StoreFault ()
forall a. a -> Either StoreFault a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        kind <- classified
        case kind of
            StorePreserved Text
why -> StoreFault -> Either StoreFault ()
forall a b. a -> Either a b
Left (Text -> StoreFault
protocolFault Text
why)
            StoreClass
StoreDestroyable -> () -> Either StoreFault ()
forall a. a -> Either StoreFault a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- What a remaining allowance covers, out of the versions one attempt selected.
data Allowance = Allowance
    { Allowance -> [Version]
alwFresh :: [Version]
    -- ^ Versions this attempt is the first to charge for.
    , Allowance -> [Version]
alwPermitted :: [Version]
    , Allowance -> [Version]
alwWithheld :: [Version]
    }

{- An already-charged version passes whatever the allowance is, because the charge was taken before
its first attempt and a reassessment must not spend the cap on it twice. -}
splitByAllowance :: Int -> Set Text -> [Version] -> Allowance
splitByAllowance :: Int -> Set Text -> [Version] -> Allowance
splitByAllowance Int
allowance Set Text
charged [Version]
selected =
    Allowance{alwFresh :: [Version]
alwFresh = [Version]
fresh, alwPermitted :: [Version]
alwPermitted = [Version]
permitted, alwWithheld :: [Version]
alwWithheld = (Version -> Bool) -> [Version] -> [Version]
forall a. (a -> Bool) -> [a] -> [a]
filter (Version -> [Version] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`notElem` [Version]
permitted) [Version]
selected}
  where
    held :: Version -> Bool
held Version
version = Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member (Version -> Text
renderVersion Version
version) Set Text
charged
    fresh :: [Version]
fresh = Int -> [Version] -> [Version]
forall a. Int -> [a] -> [a]
take Int
allowance ((Version -> Bool) -> [Version] -> [Version]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Version -> Bool) -> Version -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> Bool
held) [Version]
selected)
    permitted :: [Version]
permitted = (Version -> Bool) -> [Version] -> [Version]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Version
version -> Version -> Bool
held Version
version Bool -> Bool -> Bool
|| Version
version Version -> [Version] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` [Version]
fresh) [Version]
selected

-- A latched halt charges nothing further, and no cycle hands over more than its own cap.
remainingAllowance :: DeletionRun -> Maybe CycleHalt -> Int -> Int
remainingAllowance :: DeletionRun -> Maybe CycleHalt -> Int -> Int
remainingAllowance DeletionRun
run Maybe CycleHalt
halt Int
issued
    | Maybe CycleHalt -> Bool
forall a. Maybe a -> Bool
isJust Maybe CycleHalt
halt = Int
0
    | Bool
otherwise = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (SweepPacing -> Int
swpDeletionCap (DeletionRun -> SweepPacing
runPacing DeletionRun
run) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
issued)

withinAllowance :: DeletionRun -> SweepStore -> [Version] -> IO [Version]
withinAllowance :: DeletionRun -> SweepStore -> [Version] -> IO [Version]
withinAllowance DeletionRun
run SweepStore
store [Version]
selected = do
    charged <- IORef (Set Text) -> IO (Set Text)
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef (DeletionRun -> IORef (Set Text)
runCharged DeletionRun
run)
    issued <- readIORef (stIssued (runCounters run))
    halt <- readIORef (runHalt run)
    let split = Int -> Set Text -> [Version] -> Allowance
splitByAllowance (DeletionRun -> Maybe CycleHalt -> Int -> Int
remainingAllowance DeletionRun
run Maybe CycleHalt
halt Int
issued) Set Text
charged [Version]
selected
    countWithheld run store (alwWithheld split)
    pure (alwPermitted split)

charge :: DeletionRun -> SweepStore -> [Selection] -> IO [Version]
charge :: DeletionRun -> SweepStore -> [Selection] -> IO [Version]
charge DeletionRun
run SweepStore
store [Selection]
selections = do
    let selected :: [Version]
selected = (Selection -> Version) -> [Selection] -> [Version]
forall a b. (a -> b) -> [a] -> [b]
map Selection -> Version
selVersion [Selection]
selections
    halted <- IORef (Maybe CycleHalt) -> IO (Maybe CycleHalt)
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef (DeletionRun -> IORef (Maybe CycleHalt)
runHalt DeletionRun
run)
    held <- readIORef (runCharged run)
    issued <- readIORef (stIssued (runCounters run))
    let split = Int -> Set Text -> [Version] -> Allowance
splitByAllowance (DeletionRun -> Maybe CycleHalt -> Int -> Int
remainingAllowance DeletionRun
run Maybe CycleHalt
halted Int
issued) Set Text
held [Version]
selected
        admitted = Allowance -> [Version]
alwFresh Allowance
split
    modifyIORef' (runCharged run) (<> Set.fromList (map renderVersion admitted))
    modifyIORef' (stIssued (runCounters run)) (+ length admitted)
    when (issued < cap && issued + length admitted >= cap) $
        writeIORef (runCapGeneration run) (generationOf selections admitted)
    countWithheld run store (alwWithheld split)
    pure (alwPermitted split)
  where
    cap :: Int
cap = SweepPacing -> Int
swpDeletionCap (DeletionRun -> SweepPacing
runPacing DeletionRun
run)

-- The generation the cap is credited to is the one the charge that filled it was decided under.
generationOf :: [Selection] -> [Version] -> Maybe DbEtag
generationOf :: [Selection] -> [Version] -> Maybe DbEtag
generationOf [Selection]
selections [Version]
admitted =
    [Version] -> Maybe Version
forall a. [a] -> Maybe a
listToMaybe ([Version] -> [Version]
forall a. [a] -> [a]
reverse [Version]
admitted) Maybe Version -> (Version -> Maybe DbEtag) -> Maybe DbEtag
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Version
version -> Selection -> Maybe DbEtag
selGeneration (Selection -> Maybe DbEtag) -> Maybe Selection -> Maybe DbEtag
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Selection -> Bool) -> [Selection] -> Maybe Selection
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
== Version
version) (Version -> Bool) -> (Selection -> Version) -> Selection -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Selection -> Version
selVersion) [Selection]
selections

countWithheld :: DeletionRun -> SweepStore -> [Version] -> IO ()
countWithheld :: DeletionRun -> SweepStore -> [Version] -> IO ()
countWithheld DeletionRun
run SweepStore
store =
    (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 (DeletionRun -> SweepStore -> SweepPorts
labelled DeletionRun
run SweepStore
store) (DeletionRun -> SweepState
runCounters DeletionRun
run) SweepResult
SweepGuardSkipped))

refuse :: DeletionRun -> Text -> StoreFault -> IO (Either StoreFault a)
refuse :: forall a.
DeletionRun -> Text -> StoreFault -> IO (Either StoreFault a)
refuse DeletionRun
run Text
target StoreFault
fault = do
    IORef (Maybe CycleHalt) -> Maybe CycleHalt -> IO ()
forall (m :: * -> *) a. MonadIO m => IORef a -> a -> m ()
writeIORef (DeletionRun -> IORef (Maybe CycleHalt)
runHalt DeletionRun
run) (CycleHalt -> Maybe CycleHalt
forall a. a -> Maybe a
Just (Ecosystem -> Text -> Text -> CycleHalt
HaltStoreFault (SweepMount -> Ecosystem
smEcosystem (DeletionRun -> SweepMount
runMount DeletionRun
run)) Text
target (StoreFault -> Text
renderStoreFault StoreFault
fault)))
    Either StoreFault a -> IO (Either StoreFault a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StoreFault -> Either StoreFault a
forall a b. a -> Either a b
Left StoreFault
fault)

retryDelete :: DeletionRun -> SweepStore -> StoreFault -> IO Bool
retryDelete :: DeletionRun -> SweepStore -> StoreFault -> IO Bool
retryDelete DeletionRun
run SweepStore
store StoreFault
fault = case StoreFault -> RetryAdvice
faultRetry StoreFault
fault of
    RetryAdvice
RetryFutile -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    RetryAdvice
RetryWorthwhile -> NominalDiffTime -> IO Bool
pause (SweepPacing -> NominalDiffTime
swpChunkPause (DeletionRun -> SweepPacing
runPacing DeletionRun
run))
    RetryDelayed (RetryAfter Int
seconds) -> NominalDiffTime -> IO Bool
pause (Int -> NominalDiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
seconds)
  where
    pause :: NominalDiffTime -> IO Bool
pause NominalDiffTime
delay = do
        SweepAudit -> Text -> IO ()
auditWarn (SweepPorts -> SweepAudit
sweepAudit (DeletionRun -> SweepStore -> SweepPorts
labelled DeletionRun
run SweepStore
store)) (Text
"reassessing an uncertain deletion after " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> StoreFault -> Text
renderStoreFault StoreFault
fault)
        SweepPorts -> NominalDiffTime -> IO ()
sweepDelay (DeletionRun -> SweepPorts
runPorts DeletionRun
run) NominalDiffTime
delay
        Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True

confirm :: DeletionRun -> SweepStore -> [Version] -> IO ()
confirm :: DeletionRun -> SweepStore -> [Version] -> IO ()
confirm DeletionRun
run SweepStore
store [Version]
versions =
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Version] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Version]
versions) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        DeletionRun
-> IO (Either (Text, StoreFault) (Map Text [StoredVersion]))
currentGroup DeletionRun
run IO (Either (Text, StoreFault) (Map Text [StoredVersion]))
-> (Either (Text, StoreFault) (Map Text [StoredVersion]) -> IO ())
-> IO ()
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
target, StoreFault
fault) -> IO (Either StoreFault (ZonkAny 1)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (DeletionRun
-> Text -> StoreFault -> IO (Either StoreFault (ZonkAny 1))
forall a.
DeletionRun -> Text -> StoreFault -> IO (Either StoreFault a)
refuse DeletionRun
run Text
target StoreFault
fault)
            Right Map Text [StoredVersion]
inventories -> DeletionRun -> SweepStore -> [Version] -> [StoredVersion] -> IO ()
reportResidual DeletionRun
run SweepStore
store [Version]
versions (SweepStore -> Map Text [StoredVersion] -> [StoredVersion]
inventory SweepStore
store Map Text [StoredVersion]
inventories)

-- A version the backend accepted a delete for, still served and still denied, halts the cycle.
reportResidual :: DeletionRun -> SweepStore -> [Version] -> [StoredVersion] -> IO ()
reportResidual :: DeletionRun -> SweepStore -> [Version] -> [StoredVersion] -> IO ()
reportResidual DeletionRun
run SweepStore
store [Version]
versions [StoredVersion]
actual = do
    denied <- (Selection -> Version) -> [Selection] -> [Version]
forall a b. (a -> b) -> [a] -> [b]
map Selection -> Version
selVersion ([Selection] -> [Version]) -> IO [Selection] -> IO [Version]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DeletionRun -> SelectStored
runSelect DeletionRun
run Bool
False (DeletionRun -> SweepStore -> SweepMount
atStore DeletionRun
run SweepStore
store) [StoredVersion]
actual
    let residual =
            [ StoredVersion -> Version
storedVersion StoredVersion
item
            | StoredVersion
item <- [StoredVersion]
actual
            , StoredVersion -> VersionPresence
storedPresence StoredVersion
item VersionPresence -> VersionPresence -> Bool
forall a. Eq a => a -> a -> Bool
== VersionPresence
VersionServed
            , StoredVersion -> Version
storedVersion StoredVersion
item Version -> [Version] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` [Version]
versions
            , StoredVersion -> Version
storedVersion StoredVersion
item Version -> [Version] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` [Version]
denied
            ]
    unless (null residual) $ do
        let detail = Text
"cleanup remains incomplete for versions " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall b a. (Show a, IsString b) => a -> b
show ((Version -> Text) -> [Version] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Version -> Text
renderVersion [Version]
residual)
        auditError (sweepAudit (labelled run store)) detail
        void (refuse run (backend store) (protocolFault detail))

atStore :: DeletionRun -> SweepStore -> SweepMount
atStore :: DeletionRun -> SweepStore -> SweepMount
atStore DeletionRun
run SweepStore
store = (DeletionRun -> SweepMount
runMount DeletionRun
run){smStore = store}

backend :: SweepStore -> Text
backend :: SweepStore -> Text
backend = 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

isSource :: DeletionRun -> SweepStore -> Bool
isSource :: DeletionRun -> SweepStore -> Bool
isSource DeletionRun
run SweepStore
store = SweepMount -> StoreObservation -> SweepTarget
sweepTargetOf (DeletionRun -> SweepMount
runMount DeletionRun
run) (SweepStore -> StoreObservation
ssObserve SweepStore
store) SweepTarget -> SweepTarget -> Bool
forall a. Eq a => a -> a -> Bool
== SweepTarget
SweepMirror

inventory :: SweepStore -> Map Text [StoredVersion] -> [StoredVersion]
inventory :: SweepStore -> Map Text [StoredVersion] -> [StoredVersion]
inventory SweepStore
store = [StoredVersion]
-> Text -> Map Text [StoredVersion] -> [StoredVersion]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] (SweepStore -> Text
backend SweepStore
store)

entry :: Version -> [StoredVersion] -> Maybe StoredVersion
entry :: Version -> [StoredVersion] -> Maybe StoredVersion
entry Version
version = (StoredVersion -> Bool) -> [StoredVersion] -> Maybe StoredVersion
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
== Version
version) (Version -> Bool)
-> (StoredVersion -> Version) -> StoredVersion -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StoredVersion -> Version
storedVersion)

unchanged :: Version -> [StoredVersion] -> [StoredVersion] -> Bool
unchanged :: Version -> [StoredVersion] -> [StoredVersion] -> Bool
unchanged Version
version [StoredVersion]
before [StoredVersion]
after = Bool -> (StoredVersion -> Bool) -> Maybe StoredVersion -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (StoredVersion -> [StoredVersion] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` [StoredVersion]
after) (Version -> [StoredVersion] -> Maybe StoredVersion
entry Version
version [StoredVersion]
before)

labelled :: DeletionRun -> SweepStore -> SweepPorts
labelled :: DeletionRun -> SweepStore -> SweepPorts
labelled DeletionRun
run SweepStore
store = SweepMount -> StoreObservation -> SweepPorts -> SweepPorts
locatedPorts (DeletionRun -> SweepMount
runMount DeletionRun
run) (SweepStore -> StoreObservation
ssObserve SweepStore
store) (DeletionRun -> SweepPorts
runPorts DeletionRun
run)