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

{- | Run the supervised Dredger cycle, advisory synchronisation, and health probes.
"Ecluse.Core.Registry.Sweep" owns the selection and execution decisions.
-}
module Ecluse.Dredger (
    runDredger,
    withSyncTasks,
    dredgerServerConfig,
    dredgerReady,
    latchedStep,
) where

import Data.Map.Strict qualified as Map
import Data.Time (getCurrentTime)
import Katip (LogEnv, Severity (ErrorS, InfoS, WarningS), SimpleLogPayload, runKatipContextT)
import UnliftIO.Async (link, mapConcurrently_, withAsync)
import UnliftIO.Concurrent (threadDelay)

import Ecluse.Boot (BootEnv (..), probeServerConfig)
import Ecluse.Composition.Executable (PrunerWiring (pwBudget, pwCveSync, pwDeferredMetrics, pwMounts))
import Ecluse.Config (AppConfig, Config (configApp))
import Ecluse.Core.Clock (secondsToMicros)
import Ecluse.Core.Cve.Slot (currentAdvisoryEtag)
import Ecluse.Core.Ecosystem (Ecosystem, ecosystemName)
import Ecluse.Core.Registry.Maintenance (
    RefillPosture (RefillPermitted, RefillRefused),
    StoreFacts (factBackend, factNameAlphabet, factRefill),
    StoreObservation (obFacts),
 )
import Ecluse.Core.Registry.Maintenance.Budget (BudgetPort)
import Ecluse.Core.Registry.Sweep (paceAtCeiling, storeBudgets, sweepCycle)
import Ecluse.Core.Registry.Sweep.Outcome (
    CycleHalt,
    CycleOutcome (outcomeHalt),
    latches,
    renderCycleHalt,
 )
import Ecluse.Core.Registry.Sweep.Pacing (renderScopeBudget)
import Ecluse.Core.Registry.Sweep.Types (
    SweepAudit (SweepAudit, auditError, auditInfo, auditWarn),
    SweepCache (scObserve),
    SweepMount (smEcosystem, smStore),
    SweepPacing (swpCyclePause, swpShape),
    SweepPorts (SweepPorts, sweepAdvisoryEtag, sweepAudit, sweepBudget, sweepDelay, sweepMetrics, sweepNow, sweepReport, sweepTarget),
    SweepReport,
    SweepShape (SweepCandidates, SweepEverything),
    SweepStore (ssObserve, ssPrivate),
    privateStore,
    walkMarkerOf,
 )
import Ecluse.Core.Server.Readiness (Readiness (Latched), allMountsReady)
import Ecluse.Core.Supervision (backgroundLoopBackoff, superviseLoop, transientPolicy)
import Ecluse.Core.Telemetry.Metrics (SweepTarget (SweepMirror))
import Ecluse.Cve.Sync (
    CveSyncHandle (csEnv),
    cveSyncReadiness,
    cveSyncScheduleFor,
    cveSyncTasks,
    registerAdvisoryAges,
 )
import Ecluse.Dredger.Plan (
    DredgerOptions (doMode, doRepetition),
    SweepMode (SweepDeletes, SweepPreviews),
    SweepRepetition (SweepContinuously, SweepOnce),
    advisoryPollMicros,
    advisoryWaitAttempts,
    cycleEnding,
    sweepPacingFor,
    sweepReportFor,
    waitsForAdvisories,
 )
import Ecluse.Runtime.Cve.Sync (SyncEnv (syncSlot))
import Ecluse.Runtime.Log (moduleLog)
import Ecluse.Runtime.Server (
    ServerConfig (scCheckReady),
    probeOnlyApplication,
    raceServerAgainstLoop,
    runWarp,
 )
import Ecluse.Runtime.Telemetry.Instruments (Metrics, dredgerMetricsPortOf, newMetrics)
import Ecluse.Runtime.Telemetry.Reporters (installMetrics)

data SweepStatus = SweepStatus
    { SweepStatus -> IORef (Maybe CycleHalt)
stLatched :: IORef (Maybe CycleHalt)
    , SweepStatus -> IORef (Maybe CycleOutcome)
stFinal :: IORef (Maybe CycleOutcome)
    }

newSweepStatus :: IO SweepStatus
newSweepStatus :: IO SweepStatus
newSweepStatus = IORef (Maybe CycleHalt)
-> IORef (Maybe CycleOutcome) -> SweepStatus
SweepStatus (IORef (Maybe CycleHalt)
 -> IORef (Maybe CycleOutcome) -> SweepStatus)
-> IO (IORef (Maybe CycleHalt))
-> IO (IORef (Maybe CycleOutcome) -> SweepStatus)
forall (f :: * -> *) a b. Functor 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 IO (IORef (Maybe CycleOutcome) -> SweepStatus)
-> IO (IORef (Maybe CycleOutcome)) -> IO SweepStatus
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe CycleOutcome -> IO (IORef (Maybe CycleOutcome))
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef Maybe CycleOutcome
forall a. Maybe a
Nothing

{- | Run the Dredger. Under @--once@ the sweep returns and the race ends with it, carrying what
that cycle ended on, which is what makes the role scriptable.
-}
runDredger :: BootEnv -> DredgerOptions -> PrunerWiring -> IO (Maybe Text)
runDredger :: BootEnv -> DredgerOptions -> PrunerWiring -> IO (Maybe Text)
runDredger BootEnv
bootEnv DredgerOptions
opts PrunerWiring
pruner = do
    metrics <- Telemetry -> IO Metrics
newMetrics Telemetry
telemetry
    -- The instruments exist now, so installing them makes the credential providers' and the
    -- effectful rules' deferred reporters live for the rest of the run.
    installMetrics (pwDeferredMetrics pruner) metrics
    registerAdvisoryAges metrics (pwCveSync pruner)
    status <- newSweepStatus
    traverse_ (moduleLog logEnv dredgerModule InfoS) bootLines
    when (doMode opts == SweepDeletes) $
        moduleLog logEnv dredgerModule InfoS "this command deletes permitted mirrorTarget and privateUpstream versions under independent target consent"
    traverse_ (logMountStores logEnv opts pacing) mounts
    traverse_ (moduleLog logEnv dredgerModule InfoS . renderScopeBudget pacing) (storeBudgets mounts)
    -- Nothing has measured a cycle yet, so every pool starts at the ceiling its capacity allows.
    paceAtCeiling pacing (portsOver metrics) mounts
    moduleLog logEnv dredgerModule InfoS "Dredger starting up"
    raceServerAgainstLoop
        (runWarp logEnv "Dredger health probes" (cfg status) probeOnlyApplication)
        (withSyncTasks (syncTasks metrics) (sweepTask logEnv opts pacing (portsOver metrics) syncReady status mounts))
    (>>= cycleEnding (doMode opts)) <$> readIORef (stFinal status)
  where
    logEnv :: LogEnv
logEnv = BootEnv -> LogEnv
beLogEnv BootEnv
bootEnv
    telemetry :: Telemetry
telemetry = BootEnv -> Telemetry
beTelemetry BootEnv
bootEnv
    appConfig :: AppConfig
appConfig = Config -> AppConfig
configApp (BootEnv -> Config
beConfig BootEnv
bootEnv)
    (SweepPacing
pacing, [Text]
bootLines) = AppConfig -> Int -> (SweepPacing, [Text])
sweepPacingFor AppConfig
appConfig ([SweepMount] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (PrunerWiring -> [SweepMount]
pwMounts PrunerWiring
pruner))
    -- The boot built each mount's own execution, so the loop never asks which run it is in.
    mounts :: [SweepMount]
mounts = PrunerWiring -> [SweepMount]
pwMounts PrunerWiring
pruner
    syncReady :: IO Readiness
syncReady = Map Ecosystem CveSyncHandle -> IO Readiness
cveSyncReadiness (PrunerWiring -> Map Ecosystem CveSyncHandle
pwCveSync PrunerWiring
pruner)
    cfg :: SweepStatus -> ServerConfig
cfg SweepStatus
status = AppConfig -> IO Readiness -> ServerConfig
dredgerServerConfig AppConfig
appConfig (IO Readiness -> IO (Maybe CycleHalt) -> IO Readiness
dredgerReady IO Readiness
syncReady (IORef (Maybe CycleHalt) -> IO (Maybe CycleHalt)
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef (SweepStatus -> IORef (Maybe CycleHalt)
stLatched SweepStatus
status)))
    syncTasks :: Metrics -> [IO ()]
syncTasks Metrics
metrics = LogEnv
-> Metrics
-> Telemetry
-> SyncSchedule
-> Map Ecosystem CveSyncHandle
-> [IO ()]
cveSyncTasks LogEnv
logEnv Metrics
metrics Telemetry
telemetry (AppConfig -> SyncSchedule
cveSyncScheduleFor AppConfig
appConfig) (PrunerWiring -> Map Ecosystem CveSyncHandle
pwCveSync PrunerWiring
pruner)
    portsOver :: Metrics -> SweepPorts
portsOver Metrics
metrics = LogEnv
-> Metrics
-> BudgetPort
-> SweepReport
-> Map Ecosystem CveSyncHandle
-> SweepPorts
sweepPortsFor LogEnv
logEnv Metrics
metrics (PrunerWiring -> BudgetPort
pwBudget PrunerWiring
pruner) (SweepMode -> SweepReport
sweepReportFor (DredgerOptions -> SweepMode
doMode DredgerOptions
opts)) (PrunerWiring -> Map Ecosystem CveSyncHandle
pwCveSync PrunerWiring
pruner)

{- | The Dredger's health surface: the shared @server.port@, and a readiness the advisory sync
opens and a latched halt closes for good. A latch never fails liveness, so nothing restarts it.
-}
dredgerServerConfig :: AppConfig -> IO Readiness -> ServerConfig
dredgerServerConfig :: AppConfig -> IO Readiness -> ServerConfig
dredgerServerConfig AppConfig
appConfig IO Readiness
checkReady = (AppConfig -> ServerConfig
probeServerConfig AppConfig
appConfig){scCheckReady = checkReady}

{- | The advisory sync's own verdict until a halt latches, and 'Latched' for good after one.
Liveness stays untouched, because a restart would begin sweeping the generation that latched it.
-}
dredgerReady :: IO Readiness -> IO (Maybe CycleHalt) -> IO Readiness
dredgerReady :: IO Readiness -> IO (Maybe CycleHalt) -> IO Readiness
dredgerReady IO Readiness
checkReady IO (Maybe CycleHalt)
readLatched = IO (Maybe CycleHalt)
readLatched IO (Maybe CycleHalt)
-> (Maybe CycleHalt -> IO Readiness) -> IO Readiness
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO Readiness
-> (CycleHalt -> IO Readiness) -> Maybe CycleHalt -> IO Readiness
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO Readiness
checkReady (IO Readiness -> CycleHalt -> IO Readiness
forall a b. a -> b -> a
const (Readiness -> IO Readiness
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Readiness
Latched))

{- Run the sweep on the invocation's repetition. A cycle is one supervised step, so a fault that
escapes a store handle's typed contract backs off and the next cycle runs. -}
sweepTask :: LogEnv -> DredgerOptions -> SweepPacing -> SweepPorts -> IO Readiness -> SweepStatus -> [SweepMount] -> IO ()
sweepTask :: LogEnv
-> DredgerOptions
-> SweepPacing
-> SweepPorts
-> IO Readiness
-> SweepStatus
-> [SweepMount]
-> IO ()
sweepTask LogEnv
logEnv DredgerOptions
opts SweepPacing
pacing SweepPorts
ports IO Readiness
checkReady SweepStatus
status [SweepMount]
mounts = case DredgerOptions -> SweepRepetition
doRepetition DredgerOptions
opts of
    SweepRepetition
SweepOnce -> IO ()
awaitAdvisories IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
onceCycle
    SweepRepetition
SweepContinuously ->
        IO Void -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Void -> IO ())
-> (KatipContextT IO Void -> IO Void)
-> KatipContextT IO Void
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogEnv
-> SimpleLogPayload
-> Namespace
-> KatipContextT IO Void
-> IO Void
forall c (m :: * -> *) a.
LogItem c =>
LogEnv -> c -> Namespace -> KatipContextT m a -> m a
runKatipContextT LogEnv
logEnv (SimpleLogPayload
forall a. Monoid a => a
mempty :: SimpleLogPayload) Namespace
"dredger" (KatipContextT IO Void -> IO ()) -> KatipContextT IO Void -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            IO () -> KatipContextT IO ()
forall a. IO a -> KatipContextT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
awaitAdvisories
            SupervisionPolicy -> KatipContextT IO () -> KatipContextT IO Void
forall (m :: * -> *).
(MonadUnliftIO m, KatipContext m) =>
SupervisionPolicy -> m () -> m Void
superviseLoop (Text -> BackoffSchedule -> SupervisionPolicy
transientPolicy Text
"dredger-sweep" BackoffSchedule
backgroundLoopBackoff) (IO () -> KatipContextT IO ()
forall a. IO a -> KatipContextT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
step)
  where
    -- Only a one-shot run reports its cycle's halt as the process ending. A cycling Dredger stops
    -- by being asked to, whatever its last cycle did, so a supervisor does not restart it.
    onceCycle :: IO ()
onceCycle = do
        outcome <- SweepPacing -> SweepPorts -> [SweepMount] -> IO CycleOutcome
sweepCycle SweepPacing
pacing SweepPorts
ports [SweepMount]
mounts
        writeIORef (stFinal status) (Just outcome)
        when (any latches (outcomeHalt outcome)) (writeIORef (stLatched status) (outcomeHalt outcome))

    step :: IO ()
step = SweepPacing
-> SweepPorts -> [SweepMount] -> IORef (Maybe CycleHalt) -> IO ()
latchedStep SweepPacing
pacing SweepPorts
ports [SweepMount]
mounts (SweepStatus -> IORef (Maybe CycleHalt)
stLatched SweepStatus
status)

    {- Give every mount's first sync a bounded chance to land, because a sweep reads each
    mount's own database and partial readiness is not enough. Past the bound the cycle runs. -}
    awaitAdvisories :: IO ()
awaitAdvisories = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([SweepMount] -> Bool
waitsForAdvisories [SweepMount]
mounts) (Int -> IO ()
poll (SweepPacing -> Int
advisoryWaitAttempts SweepPacing
pacing))

    poll :: Int -> IO ()
poll Int
remaining
        | Int
remaining Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= (Int
0 :: Int) = IO ()
forall (f :: * -> *). Applicative f => f ()
pass
        | Bool
otherwise = IO Readiness
checkReady IO Readiness -> (Readiness -> 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
>>= IO () -> IO () -> Bool -> IO ()
forall a. a -> a -> Bool -> a
bool (Int -> IO ()
forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay Int
advisoryPollMicros IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> IO ()
poll (Int
remaining Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)) IO ()
forall (f :: * -> *). Applicative f => f ()
pass (Bool -> IO ()) -> (Readiness -> Bool) -> Readiness -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Readiness -> Bool
allMountsReady

{- | Run the sweep with the advisory sync tasks beside it. The sweep alone decides when the run
ends, and a task that faults still brings the run down with it.
-}
withSyncTasks :: [IO ()] -> IO a -> IO a
withSyncTasks :: forall a. [IO ()] -> IO a -> IO a
withSyncTasks [IO ()]
tasks IO a
act = IO () -> (Async () -> IO a) -> IO a
forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> (Async a -> m b) -> m b
withAsync ((IO () -> IO ()) -> [IO ()] -> IO ()
forall (m :: * -> *) (f :: * -> *) a b.
(MonadUnliftIO m, Foldable f) =>
(a -> m b) -> f a -> m ()
mapConcurrently_ IO () -> IO ()
forall a. a -> a
id [IO ()]
tasks) (\Async ()
syncs -> Async () -> IO ()
forall (m :: * -> *) a. MonadIO m => Async a -> m ()
link Async ()
syncs IO () -> IO a -> IO a
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO a
act)

{- | One step of the cycling Dredger: run a cycle, or report the halt that latched instead, then
wait the cycle pause. A latched Dredger touches no store and keeps reporting until it is restarted.
-}
latchedStep :: SweepPacing -> SweepPorts -> [SweepMount] -> IORef (Maybe CycleHalt) -> IO ()
latchedStep :: SweepPacing
-> SweepPorts -> [SweepMount] -> IORef (Maybe CycleHalt) -> IO ()
latchedStep SweepPacing
pacing SweepPorts
ports [SweepMount]
mounts IORef (Maybe CycleHalt)
latched = do
    IORef (Maybe CycleHalt) -> IO (Maybe CycleHalt)
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (Maybe CycleHalt)
latched IO (Maybe CycleHalt) -> (Maybe CycleHalt -> 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
>>= IO () -> (CycleHalt -> IO ()) -> Maybe CycleHalt -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO ()
runCycle (SweepPorts -> CycleHalt -> IO ()
reportLatched SweepPorts
ports)
    SweepPorts -> NominalDiffTime -> IO ()
sweepDelay SweepPorts
ports (SweepPacing -> NominalDiffTime
swpCyclePause SweepPacing
pacing)
  where
    runCycle :: IO ()
runCycle = do
        halt <- CycleOutcome -> Maybe CycleHalt
outcomeHalt (CycleOutcome -> Maybe CycleHalt)
-> IO CycleOutcome -> IO (Maybe CycleHalt)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SweepPacing -> SweepPorts -> [SweepMount] -> IO CycleOutcome
sweepCycle SweepPacing
pacing SweepPorts
ports [SweepMount]
mounts
        when (any latches halt) (writeIORef latched halt)

reportLatched :: SweepPorts -> CycleHalt -> IO ()
reportLatched :: SweepPorts -> CycleHalt -> IO ()
reportLatched SweepPorts
ports CycleHalt
halt =
    SweepAudit -> Text -> IO ()
auditError (SweepPorts -> SweepAudit
sweepAudit SweepPorts
ports) (Text
"the mirror sweep is halted and runs no cycle: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CycleHalt -> Text
renderCycleHalt CycleHalt
halt)

sweepPortsFor :: LogEnv -> Metrics -> BudgetPort -> SweepReport -> Map Ecosystem CveSyncHandle -> SweepPorts
sweepPortsFor :: LogEnv
-> Metrics
-> BudgetPort
-> SweepReport
-> Map Ecosystem CveSyncHandle
-> SweepPorts
sweepPortsFor LogEnv
logEnv Metrics
metrics BudgetPort
budget SweepReport
report Map Ecosystem CveSyncHandle
cveSync =
    SweepPorts
        { sweepNow :: IO UTCTime
sweepNow = IO UTCTime
getCurrentTime
        , sweepAdvisoryEtag :: Ecosystem -> IO (Maybe DbEtag)
sweepAdvisoryEtag = \Ecosystem
eco ->
            IO (Maybe DbEtag)
-> (CveSyncHandle -> IO (Maybe DbEtag))
-> Maybe CveSyncHandle
-> IO (Maybe DbEtag)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe DbEtag -> IO (Maybe DbEtag)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe DbEtag
forall a. Maybe a
Nothing) (CveSlot -> IO (Maybe DbEtag)
currentAdvisoryEtag (CveSlot -> IO (Maybe DbEtag))
-> (CveSyncHandle -> CveSlot) -> CveSyncHandle -> IO (Maybe DbEtag)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SyncEnv -> CveSlot
syncSlot (SyncEnv -> CveSlot)
-> (CveSyncHandle -> SyncEnv) -> CveSyncHandle -> CveSlot
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CveSyncHandle -> SyncEnv
csEnv) (Ecosystem -> Map Ecosystem CveSyncHandle -> Maybe CveSyncHandle
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Ecosystem
eco Map Ecosystem CveSyncHandle
cveSync)
        , sweepDelay :: NominalDiffTime -> IO ()
sweepDelay = Int -> IO ()
forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay (Int -> IO ())
-> (NominalDiffTime -> Int) -> NominalDiffTime -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NominalDiffTime -> Int
secondsToMicros
        , sweepTarget :: SweepTarget
sweepTarget = SweepTarget
SweepMirror
        , sweepMetrics :: DredgerMetricsPort
sweepMetrics = Metrics -> DredgerMetricsPort
dredgerMetricsPortOf Metrics
metrics
        , sweepAudit :: SweepAudit
sweepAudit =
            SweepAudit
                { auditInfo :: Text -> IO ()
auditInfo = LogEnv -> Text -> Severity -> Text -> IO ()
moduleLog LogEnv
logEnv Text
dredgerModule Severity
InfoS
                , auditWarn :: Text -> IO ()
auditWarn = LogEnv -> Text -> Severity -> Text -> IO ()
moduleLog LogEnv
logEnv Text
dredgerModule Severity
WarningS
                , auditError :: Text -> IO ()
auditError = LogEnv -> Text -> Severity -> Text -> IO ()
moduleLog LogEnv
logEnv Text
dredgerModule Severity
ErrorS
                }
        , sweepReport :: SweepReport
sweepReport = SweepReport
report
        , sweepBudget :: BudgetPort
sweepBudget = BudgetPort
budget
        }

-- Both of a mount's stores, each on its own line under the role that mount gives it.
logMountStores :: LogEnv -> DredgerOptions -> SweepPacing -> SweepMount -> IO ()
logMountStores :: LogEnv -> DredgerOptions -> SweepPacing -> SweepMount -> IO ()
logMountStores LogEnv
logEnv DredgerOptions
opts SweepPacing
pacing SweepMount
mount =
    ((Text, SweepMount) -> IO ()) -> [(Text, SweepMount)] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_
        ((Text -> SweepMount -> IO ()) -> (Text, SweepMount) -> IO ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (LogEnv
-> DredgerOptions -> SweepPacing -> Text -> SweepMount -> IO ()
logBlastRadius LogEnv
logEnv DredgerOptions
opts SweepPacing
pacing))
        [(Text
"mirror store", SweepMount
mount), (Text
"private cache", SweepMount
mount{smStore = privateStore (smStore mount)})]

{- One boot line per store, putting the Dredger's blast radius on record: which backend holds it,
whether a deleted version can come back, what this run does, and whether a walk over it resumes. -}
logBlastRadius :: LogEnv -> DredgerOptions -> SweepPacing -> Text -> SweepMount -> IO ()
logBlastRadius :: LogEnv
-> DredgerOptions -> SweepPacing -> Text -> SweepMount -> IO ()
logBlastRadius LogEnv
logEnv DredgerOptions
opts SweepPacing
pacing Text
subject SweepMount
mount =
    LogEnv -> Text -> Severity -> Text -> IO ()
moduleLog LogEnv
logEnv Text
dredgerModule Severity
InfoS (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
        Text
"sweeping 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
" "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
subject
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" on "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> StoreFacts -> Text
factBackend StoreFacts
facts
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
refill
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
disposition
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
resumption
  where
    facts :: StoreFacts
facts = StoreObservation -> StoreFacts
obFacts (SweepStore -> StoreObservation
ssObserve (SweepMount -> SweepStore
smStore SweepMount
mount))
    refill :: Text
refill = case StoreFacts -> RefillPosture
factRefill StoreFacts
facts of
        RefillPosture
RefillPermitted -> Text
"which accepts a re-publication of a version it deleted"
        RefillPosture
RefillRefused -> Text
"which refuses a re-publication, so a delete retires the version for good"
    disposition :: Text
disposition = case DredgerOptions -> SweepMode
doMode DredgerOptions
opts of
        SweepMode
SweepDeletes -> Text
"deleting what a named decisive deny condemns"
        SweepMode
SweepPreviews -> Text
"previewing only: this run holds nothing that could delete"
    compatibleCursor :: Maybe StoreCursor
compatibleCursor = do
        let mirror :: SweepStore
mirror = SweepMount -> SweepStore
smStore SweepMount
mount
        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (StoreFacts -> NameAlphabet
factNameAlphabet (StoreObservation -> StoreFacts
obFacts (SweepCache -> StoreObservation
scObserve (SweepStore -> SweepCache
ssPrivate SweepStore
mirror))) NameAlphabet -> NameAlphabet -> Bool
forall a. Eq a => a -> a -> Bool
== StoreFacts -> NameAlphabet
factNameAlphabet StoreFacts
facts)
        SweepStore -> Maybe StoreCursor
walkMarkerOf SweepStore
mirror
    resumption :: Text
resumption = case (SweepPacing -> SweepShape
swpShape SweepPacing
pacing, Maybe StoreCursor
compatibleCursor) of
        (SweepShape
SweepCandidates, Maybe StoreCursor
_) -> Text
""
        (SweepShape
SweepEverything, Just StoreCursor
_) -> Text
"; the full walk resumes from this store's own marker"
        (SweepShape
SweepEverything, Maybe StoreCursor
Nothing) -> Text
"; this run keeps no marker, so the full walk starts at the first bucket"

dredgerModule :: Text
dredgerModule :: Text
dredgerModule = Text
"Ecluse.Dredger"