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

{- | Backend maintenance capabilities for a mirror store: the observing and deleting halves of
one handle, and the drives every backend shares. Enumeration and deletion may need a control
plane beyond the store's own package protocol. The buckets a walk addresses are in
"Ecluse.Core.Registry.Maintenance.NameSpace".
-}
module Ecluse.Core.Registry.Maintenance (
    -- * The handle
    StoreMaintenance (..),

    -- * Its two halves, held apart
    StoreObservation (..),
    StoreDeletion (..),
    DeleteGuard (..),
    DeletePhase (..),
    observationOf,
    deletionOf,
    maintenanceOf,

    -- * What the backend does
    StoreFacts (..),
    DeleteCeiling (..),
    RefillPosture (..),
    CompletionNotion (..),

    -- * Counting and pacing what a handle asks of the backend
    meteredObservation,
    meteredMaintenance,

    -- * Enumeration
    StoredVersion (..),
    VersionPresence (..),

    -- * Walk resumption
    StoreCursor (..),

    -- * Reading a package's metadata from the store
    StoreManifestRead,
    storeFaultOfFetch,
    storeFaultOfMetadata,
    protocolFault,
    statusFault,
    unformableFault,

    -- * Deletion
    VersionOutcome (..),
    StoreRefusal,
    storeRefusal,
    refusalCode,
    refusalDetail,
    unreachedBatch,

    -- * Backend-neutral drives
    pageSource,
    collectPages,
    collectPagesBounded,
    pageAll,
    chunksOfCeiling,
    deleteAll,

    -- * Verdicts
    ConsentVerdict (..),
    StoreClass (..),

    -- * Faults
    StoreFault (..),
    RetryAdvice (..),
) where

import Data.Conduit (ConduitT, await, fuseBoth, fuseBothMaybe, fuseUpstream, runConduit, yield)
import Data.Conduit.List qualified as CL
import Data.Set qualified as Set

import Ecluse.Core.Fault (
    RetryAfter,
    TransportCause (TransportProtocol),
    TransportFault,
    boundedDetail,
    tfCause,
    transportFault,
    transportRetryable,
 )
import Ecluse.Core.Fault.Http (isRetryableStatusCode)
import Ecluse.Core.Package (PackageName)
import Ecluse.Core.Registry (
    FetchFault (FetchBoundExceeded, FetchTransport, FetchUrlUnformable),
    UrlFormationError,
    renderUrlFormationError,
 )
import Ecluse.Core.Registry.Maintenance.Budget (
    RequestGate (gateSpend),
    RequestKind (CursorRead, CursorWrite, DeleteBatch, ListingPage, ManifestRead, PermissionRead, VersionPage),
    StoreBudget,
 )
import Ecluse.Core.Registry.Maintenance.NameSpace (NameAlphabet, NamePrefix)
import Ecluse.Core.Registry.Maintenance.Upstream (UpstreamSafety)
import Ecluse.Core.Registry.Metadata (
    Manifest,
    MetadataError (MetadataAbsent, MetadataAuthorisationFailure, MetadataBoundExceeded, MetadataFetch, MetadataHttpFailure, MetadataNameMismatch, MetadataUndecodable),
 )
import Ecluse.Core.Version (Version)

-- | Backend operations for one store, independent of the application's runtime.
data StoreMaintenance = StoreMaintenance
    { StoreMaintenance -> StoreFacts
storeFacts :: StoreFacts
    -- ^ What the backend does, readable without a call.
    , StoreMaintenance
-> NamePrefix -> ConduitT () [PackageName] IO (Maybe StoreFault)
listPackagesIn :: NamePrefix -> ConduitT () [PackageName] IO (Maybe StoreFault)
    -- ^ Stream a bucket's pages, ending with its failure or 'Nothing' on completion.
    , StoreMaintenance
-> PackageName -> IO (Either StoreFault [StoredVersion])
enumerateVersions :: PackageName -> IO (Either StoreFault [StoredVersion])
    -- ^ Every version the store holds for one package, paged to exhaustion.
    , StoreMaintenance -> StoreManifestRead
readStoreManifest :: StoreManifestRead
    -- ^ Read through the store's credential and ecosystem codec, including every stored version.
    , StoreMaintenance
-> DeleteGuard
-> PackageName
-> [Version]
-> IO [(Version, VersionOutcome)]
deleteVersions :: DeleteGuard -> PackageName -> [Version] -> IO [(Version, VersionOutcome)]
    -- ^ Accept any batch size and return exactly one outcome per supplied version.
    , StoreMaintenance -> IO (Either StoreFault ConsentVerdict)
verifyConsent :: IO (Either StoreFault ConsentVerdict)
    -- ^ Whether the operator has marked this store for deletion.
    , StoreMaintenance -> IO (Either StoreFault StoreClass)
classifyStore :: IO (Either StoreFault StoreClass)
    -- ^ Whether deleting from this store destroys anything.
    , StoreMaintenance -> IO UpstreamSafety
probeUpstream :: IO UpstreamSafety
    -- ^ Whether public content can reach a client through this store.
    , StoreMaintenance -> Maybe StoreCursor
storeCursor :: Maybe StoreCursor
    -- ^ Optional persisted progress. Without it, every walk starts at the first bucket.
    }

-- | The calls that only observe a store, which change nothing whatever the caller does.
data StoreObservation = StoreObservation
    { StoreObservation -> StoreFacts
obFacts :: StoreFacts
    -- ^ What the backend does, readable without a call.
    , StoreObservation
-> NamePrefix -> ConduitT () [PackageName] IO (Maybe StoreFault)
obListPackagesIn :: NamePrefix -> ConduitT () [PackageName] IO (Maybe StoreFault)
    -- ^ Stream a bucket's pages, ending with its failure or 'Nothing' on completion.
    , StoreObservation
-> PackageName -> IO (Either StoreFault [StoredVersion])
obEnumerateVersions :: PackageName -> IO (Either StoreFault [StoredVersion])
    -- ^ Every version the store holds for one package, paged to exhaustion.
    , StoreObservation -> StoreManifestRead
obReadManifest :: StoreManifestRead
    -- ^ Read through the store's credential and ecosystem codec, including every stored version.
    , StoreObservation -> IO (Either StoreFault ConsentVerdict)
obVerifyConsent :: IO (Either StoreFault ConsentVerdict)
    -- ^ Whether the operator has marked this store for deletion.
    , StoreObservation -> IO (Either StoreFault StoreClass)
obClassifyStore :: IO (Either StoreFault StoreClass)
    -- ^ Whether deleting from this store destroys anything.
    , StoreObservation -> IO UpstreamSafety
obProbeUpstream :: IO UpstreamSafety
    -- ^ Whether public content can reach a client through this store.
    }

-- | The calls that change a store, which only a role authorised to delete from it holds.
data StoreDeletion = StoreDeletion
    { StoreDeletion
-> DeleteGuard
-> PackageName
-> [Version]
-> IO [(Version, VersionOutcome)]
dlDeleteVersions :: DeleteGuard -> PackageName -> [Version] -> IO [(Version, VersionOutcome)]
    -- ^ Accept any batch size and return exactly one outcome per supplied version.
    , StoreDeletion -> Maybe StoreCursor
dlCursor :: Maybe StoreCursor
    -- ^ Optional persisted progress. Without it, every walk starts at the first bucket.
    }

-- | Observation after uncertainty must not reserve or announce another destructive attempt.
data DeletePhase
    = -- | Recheck and reserve immediately before a destructive attempt.
      BeforeDelete
    | -- | Inspect an uncertain result without reserving or announcing another attempt.
      AfterUncertain
    deriving stock (DeletePhase -> DeletePhase -> Bool
(DeletePhase -> DeletePhase -> Bool)
-> (DeletePhase -> DeletePhase -> Bool) -> Eq DeletePhase
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DeletePhase -> DeletePhase -> Bool
== :: DeletePhase -> DeletePhase -> Bool
$c/= :: DeletePhase -> DeletePhase -> Bool
/= :: DeletePhase -> DeletePhase -> Bool
Eq, Int -> DeletePhase -> ShowS
[DeletePhase] -> ShowS
DeletePhase -> String
(Int -> DeletePhase -> ShowS)
-> (DeletePhase -> String)
-> ([DeletePhase] -> ShowS)
-> Show DeletePhase
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DeletePhase -> ShowS
showsPrec :: Int -> DeletePhase -> ShowS
$cshow :: DeletePhase -> String
show :: DeletePhase -> String
$cshowList :: [DeletePhase] -> ShowS
showList :: [DeletePhase] -> ShowS
Show)

-- | The sweep rechecks authority inside backend-owned batches and bounds each uncertain retry.
data DeleteGuard = DeleteGuard
    { DeleteGuard
-> DeletePhase -> [Version] -> IO (Either StoreFault [Version])
dgCheck :: DeletePhase -> [Version] -> IO (Either StoreFault [Version])
    , DeleteGuard -> StoreFault -> IO Bool
dgRetry :: StoreFault -> IO Bool
    }

-- | The observing half of a whole handle.
observationOf :: StoreMaintenance -> StoreObservation
observationOf :: StoreMaintenance -> StoreObservation
observationOf StoreMaintenance
store =
    StoreObservation
        { obFacts :: StoreFacts
obFacts = StoreMaintenance -> StoreFacts
storeFacts StoreMaintenance
store
        , obListPackagesIn :: NamePrefix -> ConduitT () [PackageName] IO (Maybe StoreFault)
obListPackagesIn = StoreMaintenance
-> NamePrefix -> ConduitT () [PackageName] IO (Maybe StoreFault)
listPackagesIn StoreMaintenance
store
        , obEnumerateVersions :: PackageName -> IO (Either StoreFault [StoredVersion])
obEnumerateVersions = StoreMaintenance
-> PackageName -> IO (Either StoreFault [StoredVersion])
enumerateVersions StoreMaintenance
store
        , obReadManifest :: StoreManifestRead
obReadManifest = StoreMaintenance -> StoreManifestRead
readStoreManifest StoreMaintenance
store
        , obVerifyConsent :: IO (Either StoreFault ConsentVerdict)
obVerifyConsent = StoreMaintenance -> IO (Either StoreFault ConsentVerdict)
verifyConsent StoreMaintenance
store
        , obClassifyStore :: IO (Either StoreFault StoreClass)
obClassifyStore = StoreMaintenance -> IO (Either StoreFault StoreClass)
classifyStore StoreMaintenance
store
        , obProbeUpstream :: IO UpstreamSafety
obProbeUpstream = StoreMaintenance -> IO UpstreamSafety
probeUpstream StoreMaintenance
store
        }

-- | The changing half of a whole handle.
deletionOf :: StoreMaintenance -> StoreDeletion
deletionOf :: StoreMaintenance -> StoreDeletion
deletionOf StoreMaintenance
store = StoreDeletion{dlDeleteVersions :: DeleteGuard
-> PackageName -> [Version] -> IO [(Version, VersionOutcome)]
dlDeleteVersions = StoreMaintenance
-> DeleteGuard
-> PackageName
-> [Version]
-> IO [(Version, VersionOutcome)]
deleteVersions StoreMaintenance
store, dlCursor :: Maybe StoreCursor
dlCursor = StoreMaintenance -> Maybe StoreCursor
storeCursor StoreMaintenance
store}

-- | The two halves joined into a whole handle, which every backend builds its own through.
maintenanceOf :: StoreObservation -> StoreDeletion -> StoreMaintenance
maintenanceOf :: StoreObservation -> StoreDeletion -> StoreMaintenance
maintenanceOf StoreObservation
observed StoreDeletion
deletion =
    StoreMaintenance
        { storeFacts :: StoreFacts
storeFacts = StoreObservation -> StoreFacts
obFacts StoreObservation
observed
        , listPackagesIn :: NamePrefix -> ConduitT () [PackageName] IO (Maybe StoreFault)
listPackagesIn = StoreObservation
-> NamePrefix -> ConduitT () [PackageName] IO (Maybe StoreFault)
obListPackagesIn StoreObservation
observed
        , enumerateVersions :: PackageName -> IO (Either StoreFault [StoredVersion])
enumerateVersions = StoreObservation
-> PackageName -> IO (Either StoreFault [StoredVersion])
obEnumerateVersions StoreObservation
observed
        , readStoreManifest :: StoreManifestRead
readStoreManifest = StoreObservation -> StoreManifestRead
obReadManifest StoreObservation
observed
        , deleteVersions :: DeleteGuard
-> PackageName -> [Version] -> IO [(Version, VersionOutcome)]
deleteVersions = StoreDeletion
-> DeleteGuard
-> PackageName
-> [Version]
-> IO [(Version, VersionOutcome)]
dlDeleteVersions StoreDeletion
deletion
        , verifyConsent :: IO (Either StoreFault ConsentVerdict)
verifyConsent = StoreObservation -> IO (Either StoreFault ConsentVerdict)
obVerifyConsent StoreObservation
observed
        , classifyStore :: IO (Either StoreFault StoreClass)
classifyStore = StoreObservation -> IO (Either StoreFault StoreClass)
obClassifyStore StoreObservation
observed
        , probeUpstream :: IO UpstreamSafety
probeUpstream = StoreObservation -> IO UpstreamSafety
obProbeUpstream StoreObservation
observed
        , storeCursor :: Maybe StoreCursor
storeCursor = StoreDeletion -> Maybe StoreCursor
dlCursor StoreDeletion
deletion
        }

{- | Count and pace every request the observing calls make. A version enumeration counts as one
request however many pages it takes, so a large package costs more than was counted.
-}
meteredObservation :: RequestGate -> StoreObservation -> StoreObservation
meteredObservation :: RequestGate -> StoreObservation -> StoreObservation
meteredObservation RequestGate
gate StoreObservation
observed =
    StoreObservation
observed
        { obListPackagesIn = \NamePrefix
prefix -> StoreObservation
-> NamePrefix -> ConduitT () [PackageName] IO (Maybe StoreFault)
obListPackagesIn StoreObservation
observed NamePrefix
prefix ConduitT () [PackageName] IO (Maybe StoreFault)
-> ConduitT [PackageName] [PackageName] IO ()
-> ConduitT () [PackageName] IO (Maybe StoreFault)
forall (m :: * -> *) a b r c.
Monad m =>
ConduitT a b m r -> ConduitT b c m () -> ConduitT a c m r
`fuseUpstream` ([PackageName] -> IO [PackageName])
-> ConduitT [PackageName] [PackageName] IO ()
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ConduitT a b m ()
CL.mapM [PackageName] -> IO [PackageName]
forall {b}. b -> IO b
counted
        , obEnumerateVersions = \PackageName
name -> RequestKind -> IO ()
spend RequestKind
VersionPage IO ()
-> IO (Either StoreFault [StoredVersion])
-> IO (Either StoreFault [StoredVersion])
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> StoreObservation
-> PackageName -> IO (Either StoreFault [StoredVersion])
obEnumerateVersions StoreObservation
observed PackageName
name
        , obReadManifest = \PackageName
name -> RequestKind -> IO ()
spend RequestKind
ManifestRead IO ()
-> IO (Either StoreFault Manifest)
-> IO (Either StoreFault Manifest)
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> StoreObservation -> StoreManifestRead
obReadManifest StoreObservation
observed PackageName
name
        , obVerifyConsent = spend PermissionRead >> obVerifyConsent observed
        , obClassifyStore = spend PermissionRead >> obClassifyStore observed
        }
  where
    spend :: RequestKind -> IO ()
spend = RequestGate -> RequestKind -> IO ()
gateSpend RequestGate
gate
    -- The page is counted once it arrives, so the wait falls between it and the next request.
    counted :: b -> IO b
counted b
page = RequestKind -> IO ()
spend RequestKind
ListingPage IO () -> b -> IO b
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> b
page

{- | The same metering over a whole handle. A delete counts one request per batch the backend's
ceiling divides the versions into.
-}
meteredMaintenance :: RequestGate -> StoreMaintenance -> StoreMaintenance
meteredMaintenance :: RequestGate -> StoreMaintenance -> StoreMaintenance
meteredMaintenance RequestGate
gate StoreMaintenance
handle =
    StoreMaintenance
handle
        { listPackagesIn = obListPackagesIn observed
        , enumerateVersions = obEnumerateVersions observed
        , readStoreManifest = obReadManifest observed
        , verifyConsent = obVerifyConsent observed
        , classifyStore = obClassifyStore observed
        , deleteVersions = \DeleteGuard
checks PackageName
name [Version]
versions -> do
            ([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 (RequestGate -> RequestKind -> IO ()
gateSpend RequestGate
gate RequestKind
DeleteBatch)) (DeleteCeiling -> [Version] -> [[Version]]
forall a. DeleteCeiling -> [a] -> [[a]]
chunksOfCeiling (StoreFacts -> DeleteCeiling
factDeleteCeiling (StoreMaintenance -> StoreFacts
storeFacts StoreMaintenance
handle)) [Version]
versions)
            StoreMaintenance
-> DeleteGuard
-> PackageName
-> [Version]
-> IO [(Version, VersionOutcome)]
deleteVersions StoreMaintenance
handle DeleteGuard
checks PackageName
name [Version]
versions
        , storeCursor = meteredCursor gate <$> storeCursor handle
        }
  where
    observed :: StoreObservation
observed = RequestGate -> StoreObservation -> StoreObservation
meteredObservation RequestGate
gate (StoreMaintenance -> StoreObservation
observationOf StoreMaintenance
handle)

-- The marker reads and writes a full walk makes, each counted as its own request.
meteredCursor :: RequestGate -> StoreCursor -> StoreCursor
meteredCursor :: RequestGate -> StoreCursor -> StoreCursor
meteredCursor RequestGate
gate StoreCursor
cursor =
    StoreCursor
        { readCursor :: IO (Either StoreFault (Maybe NamePrefix))
readCursor = RequestGate -> RequestKind -> IO ()
gateSpend RequestGate
gate RequestKind
CursorRead IO ()
-> IO (Either StoreFault (Maybe NamePrefix))
-> IO (Either StoreFault (Maybe NamePrefix))
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> StoreCursor -> IO (Either StoreFault (Maybe NamePrefix))
readCursor StoreCursor
cursor
        , writeCursor :: NamePrefix -> IO (Either StoreFault ())
writeCursor = \NamePrefix
prefix -> RequestGate -> RequestKind -> IO ()
gateSpend RequestGate
gate RequestKind
CursorWrite IO () -> IO (Either StoreFault ()) -> IO (Either StoreFault ())
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> StoreCursor -> NamePrefix -> IO (Either StoreFault ())
writeCursor StoreCursor
cursor NamePrefix
prefix
        , clearCursor :: IO (Either StoreFault ())
clearCursor = RequestGate -> RequestKind -> IO ()
gateSpend RequestGate
gate RequestKind
CursorWrite IO () -> IO (Either StoreFault ()) -> IO (Either StoreFault ())
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> StoreCursor -> IO (Either StoreFault ())
clearCursor StoreCursor
cursor
        }

-- | Backend capabilities and limits fixed for this handle's lifetime.
data StoreFacts = StoreFacts
    { StoreFacts -> Text
factBackend :: Text
    -- ^ The backend's name, for the boot line that puts the Dredger's blast radius on record.
    , StoreFacts -> DeleteCeiling
factDeleteCeiling :: DeleteCeiling
    -- ^ How many versions one destructive call accepts.
    , StoreFacts -> RefillPosture
factRefill :: RefillPosture
    -- ^ What the backend does with a re-publication of a deleted version.
    , StoreFacts -> CompletionNotion
factCompletion :: CompletionNotion
    -- ^ When a delete is finished relative to the call that asked for it.
    , StoreFacts -> NameAlphabet
factNameAlphabet :: NameAlphabet
    -- ^ The characters this store's name space is partitioned into buckets by.
    , StoreFacts -> StoreBudget
factBudget :: StoreBudget
    -- ^ The request capacity this store runs under, which the sweep paces its next cycle by.
    }
    deriving stock (StoreFacts -> StoreFacts -> Bool
(StoreFacts -> StoreFacts -> Bool)
-> (StoreFacts -> StoreFacts -> Bool) -> Eq StoreFacts
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: StoreFacts -> StoreFacts -> Bool
== :: StoreFacts -> StoreFacts -> Bool
$c/= :: StoreFacts -> StoreFacts -> Bool
/= :: StoreFacts -> StoreFacts -> Bool
Eq, Int -> StoreFacts -> ShowS
[StoreFacts] -> ShowS
StoreFacts -> String
(Int -> StoreFacts -> ShowS)
-> (StoreFacts -> String)
-> ([StoreFacts] -> ShowS)
-> Show StoreFacts
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StoreFacts -> ShowS
showsPrec :: Int -> StoreFacts -> ShowS
$cshow :: StoreFacts -> String
show :: StoreFacts -> String
$cshowList :: [StoreFacts] -> ShowS
showList :: [StoreFacts] -> ShowS
Show)

-- | The backend's documented re-publication policy after deletion, without an enforcement guarantee.
data RefillPosture
    = -- | The backend accepts a re-publication of a version it deleted (CodeArtifact).
      RefillPermitted
    | -- | Deletion permanently prevents re-publication under the same version name.
      RefillRefused
    deriving stock (RefillPosture -> RefillPosture -> Bool
(RefillPosture -> RefillPosture -> Bool)
-> (RefillPosture -> RefillPosture -> Bool) -> Eq RefillPosture
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RefillPosture -> RefillPosture -> Bool
== :: RefillPosture -> RefillPosture -> Bool
$c/= :: RefillPosture -> RefillPosture -> Bool
/= :: RefillPosture -> RefillPosture -> Bool
Eq, Int -> RefillPosture -> ShowS
[RefillPosture] -> ShowS
RefillPosture -> String
(Int -> RefillPosture -> ShowS)
-> (RefillPosture -> String)
-> ([RefillPosture] -> ShowS)
-> Show RefillPosture
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RefillPosture -> ShowS
showsPrec :: Int -> RefillPosture -> ShowS
$cshow :: RefillPosture -> String
show :: RefillPosture -> String
$cshowList :: [RefillPosture] -> ShowS
showList :: [RefillPosture] -> ShowS
Show)

-- | The maximum batch size supported by one backend deletion call.
data DeleteCeiling
    = -- | The backend takes a batch of any size, so a caller never splits one.
      NoCeiling
    | -- | The backend refuses a call carrying more than this many versions.
      AtMost Int
    deriving stock (DeleteCeiling -> DeleteCeiling -> Bool
(DeleteCeiling -> DeleteCeiling -> Bool)
-> (DeleteCeiling -> DeleteCeiling -> Bool) -> Eq DeleteCeiling
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DeleteCeiling -> DeleteCeiling -> Bool
== :: DeleteCeiling -> DeleteCeiling -> Bool
$c/= :: DeleteCeiling -> DeleteCeiling -> Bool
/= :: DeleteCeiling -> DeleteCeiling -> Bool
Eq, Int -> DeleteCeiling -> ShowS
[DeleteCeiling] -> ShowS
DeleteCeiling -> String
(Int -> DeleteCeiling -> ShowS)
-> (DeleteCeiling -> String)
-> ([DeleteCeiling] -> ShowS)
-> Show DeleteCeiling
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DeleteCeiling -> ShowS
showsPrec :: Int -> DeleteCeiling -> ShowS
$cshow :: DeleteCeiling -> String
show :: DeleteCeiling -> String
$cshowList :: [DeleteCeiling] -> ShowS
showList :: [DeleteCeiling] -> ShowS
Show)

-- | When a delete is finished, relative to the call that asked for it.
data CompletionNotion
    = -- | The delete is done by the time the call answers.
      CompletesOnCall
    | -- | The call starts a long-running operation, and the outcome names it.
      CompletesLater
    deriving stock (CompletionNotion -> CompletionNotion -> Bool
(CompletionNotion -> CompletionNotion -> Bool)
-> (CompletionNotion -> CompletionNotion -> Bool)
-> Eq CompletionNotion
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CompletionNotion -> CompletionNotion -> Bool
== :: CompletionNotion -> CompletionNotion -> Bool
$c/= :: CompletionNotion -> CompletionNotion -> Bool
/= :: CompletionNotion -> CompletionNotion -> Bool
Eq, Int -> CompletionNotion -> ShowS
[CompletionNotion] -> ShowS
CompletionNotion -> String
(Int -> CompletionNotion -> ShowS)
-> (CompletionNotion -> String)
-> ([CompletionNotion] -> ShowS)
-> Show CompletionNotion
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CompletionNotion -> ShowS
showsPrec :: Int -> CompletionNotion -> ShowS
$cshow :: CompletionNotion -> String
show :: CompletionNotion -> String
$cshowList :: [CompletionNotion] -> ShowS
showList :: [CompletionNotion] -> ShowS
Show)

-- | One version an enumeration found, with what the store does with it now.
data StoredVersion = StoredVersion
    { StoredVersion -> Version
storedVersion :: Version
    , StoredVersion -> VersionPresence
storedPresence :: VersionPresence
    , StoredVersion -> Maybe Text
storedRevision :: Maybe Text
    -- ^ Opaque backend revision, absent where the backend supplies none.
    }
    deriving stock (StoredVersion -> StoredVersion -> Bool
(StoredVersion -> StoredVersion -> Bool)
-> (StoredVersion -> StoredVersion -> Bool) -> Eq StoredVersion
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: StoredVersion -> StoredVersion -> Bool
== :: StoredVersion -> StoredVersion -> Bool
$c/= :: StoredVersion -> StoredVersion -> Bool
/= :: StoredVersion -> StoredVersion -> Bool
Eq, Int -> StoredVersion -> ShowS
[StoredVersion] -> ShowS
StoredVersion -> String
(Int -> StoredVersion -> ShowS)
-> (StoredVersion -> String)
-> ([StoredVersion] -> ShowS)
-> Show StoredVersion
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StoredVersion -> ShowS
showsPrec :: Int -> StoredVersion -> ShowS
$cshow :: StoredVersion -> String
show :: StoredVersion -> String
$cshowList :: [StoredVersion] -> ShowS
showList :: [StoredVersion] -> ShowS
Show)

-- | Distinguish served versions from retained deletion records to avoid repeated deletion.
data VersionPresence
    = -- | The store serves the version, so deleting it removes something.
      VersionServed
    | -- | The store lists the version but no longer serves it.
      VersionWithdrawn
    deriving stock (VersionPresence -> VersionPresence -> Bool
(VersionPresence -> VersionPresence -> Bool)
-> (VersionPresence -> VersionPresence -> Bool)
-> Eq VersionPresence
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: VersionPresence -> VersionPresence -> Bool
== :: VersionPresence -> VersionPresence -> Bool
$c/= :: VersionPresence -> VersionPresence -> Bool
/= :: VersionPresence -> VersionPresence -> Bool
Eq, Int -> VersionPresence -> ShowS
[VersionPresence] -> ShowS
VersionPresence -> String
(Int -> VersionPresence -> ShowS)
-> (VersionPresence -> String)
-> ([VersionPresence] -> ShowS)
-> Show VersionPresence
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> VersionPresence -> ShowS
showsPrec :: Int -> VersionPresence -> ShowS
$cshow :: VersionPresence -> String
show :: VersionPresence -> String
$cshowList :: [VersionPresence] -> ShowS
showList :: [VersionPresence] -> ShowS
Show)

-- | Persist the last completed bucket so a restart repeats only unfinished work.
data StoreCursor = StoreCursor
    { StoreCursor -> IO (Either StoreFault (Maybe NamePrefix))
readCursor :: IO (Either StoreFault (Maybe NamePrefix))
    -- ^ The bucket the last run completed, 'Nothing' when no walk is under way.
    , StoreCursor -> NamePrefix -> IO (Either StoreFault ())
writeCursor :: NamePrefix -> IO (Either StoreFault ())
    -- ^ Record a completed bucket, replacing whatever was recorded before.
    , StoreCursor -> IO (Either StoreFault ())
clearCursor :: IO (Either StoreFault ())
    -- ^ Forget the walk, which a completed one does so the next starts from the first bucket.
    }

-- | What became of one version a caller asked to delete.
data VersionOutcome
    = -- | The backend removed it before answering.
      VersionRemoved
    | -- | The backend accepted the removal and carries on, named by the reference an operator follows the work with.
      VersionRemoving Text
    | -- | The backend refused this one version and said why.
      VersionRefused StoreRefusal
    | -- | The call carrying this version did not reach the backend.
      VersionUnreached StoreFault
    | -- | A destructive call faulted after issue, so its effects need a fresh observation.
      VersionUncertain StoreFault
    deriving stock (VersionOutcome -> VersionOutcome -> Bool
(VersionOutcome -> VersionOutcome -> Bool)
-> (VersionOutcome -> VersionOutcome -> Bool) -> Eq VersionOutcome
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: VersionOutcome -> VersionOutcome -> Bool
== :: VersionOutcome -> VersionOutcome -> Bool
$c/= :: VersionOutcome -> VersionOutcome -> Bool
/= :: VersionOutcome -> VersionOutcome -> Bool
Eq, Int -> VersionOutcome -> ShowS
[VersionOutcome] -> ShowS
VersionOutcome -> String
(Int -> VersionOutcome -> ShowS)
-> (VersionOutcome -> String)
-> ([VersionOutcome] -> ShowS)
-> Show VersionOutcome
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> VersionOutcome -> ShowS
showsPrec :: Int -> VersionOutcome -> ShowS
$cshow :: VersionOutcome -> String
show :: VersionOutcome -> String
$cshowList :: [VersionOutcome] -> ShowS
showList :: [VersionOutcome] -> ShowS
Show)

-- | A backend's refusal of one version. Build it with 'storeRefusal' so the detail stays bounded.
data StoreRefusal = StoreRefusal
    { StoreRefusal -> Text
refusalCode :: Text
    -- ^ The backend's own code, which an operator looks up in its documentation.
    , StoreRefusal -> Text
refusalDetail :: Text
    -- ^ The backend's message, bounded to the shared log-line budget and never parsed.
    }
    deriving stock (StoreRefusal -> StoreRefusal -> Bool
(StoreRefusal -> StoreRefusal -> Bool)
-> (StoreRefusal -> StoreRefusal -> Bool) -> Eq StoreRefusal
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: StoreRefusal -> StoreRefusal -> Bool
== :: StoreRefusal -> StoreRefusal -> Bool
$c/= :: StoreRefusal -> StoreRefusal -> Bool
/= :: StoreRefusal -> StoreRefusal -> Bool
Eq, Int -> StoreRefusal -> ShowS
[StoreRefusal] -> ShowS
StoreRefusal -> String
(Int -> StoreRefusal -> ShowS)
-> (StoreRefusal -> String)
-> ([StoreRefusal] -> ShowS)
-> Show StoreRefusal
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StoreRefusal -> ShowS
showsPrec :: Int -> StoreRefusal -> ShowS
$cshow :: StoreRefusal -> String
show :: StoreRefusal -> String
$cshowList :: [StoreRefusal] -> ShowS
showList :: [StoreRefusal] -> ShowS
Show)

-- | Build a 'StoreRefusal', truncating the detail to the log-line budget.
storeRefusal :: Text -> Text -> StoreRefusal
storeRefusal :: Text -> Text -> StoreRefusal
storeRefusal Text
code Text
detail = Text -> Text -> StoreRefusal
StoreRefusal Text
code (Text -> Text
boundedDetail Text
detail)

-- | Give every version an unreached outcome when its batch call faults.
unreachedBatch :: StoreFault -> [Version] -> [(Version, VersionOutcome)]
unreachedBatch :: StoreFault -> [Version] -> [(Version, VersionOutcome)]
unreachedBatch StoreFault
fault [Version]
versions = [(Version
version, StoreFault -> VersionOutcome
VersionUnreached StoreFault
fault) | Version
version <- [Version]
versions]

-- | Whether the operator has consented to deletion from this store.
data ConsentVerdict
    = -- | The store carries the consent marker.
      ConsentGranted
    | -- | The required consent marker is absent. Carries the backend's instructions for adding it.
      ConsentWithheld Text
    deriving stock (ConsentVerdict -> ConsentVerdict -> Bool
(ConsentVerdict -> ConsentVerdict -> Bool)
-> (ConsentVerdict -> ConsentVerdict -> Bool) -> Eq ConsentVerdict
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ConsentVerdict -> ConsentVerdict -> Bool
== :: ConsentVerdict -> ConsentVerdict -> Bool
$c/= :: ConsentVerdict -> ConsentVerdict -> Bool
/= :: ConsentVerdict -> ConsentVerdict -> Bool
Eq, Int -> ConsentVerdict -> ShowS
[ConsentVerdict] -> ShowS
ConsentVerdict -> String
(Int -> ConsentVerdict -> ShowS)
-> (ConsentVerdict -> String)
-> ([ConsentVerdict] -> ShowS)
-> Show ConsentVerdict
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ConsentVerdict -> ShowS
showsPrec :: Int -> ConsentVerdict -> ShowS
$cshow :: ConsentVerdict -> String
show :: ConsentVerdict -> String
$cshowList :: [ConsentVerdict] -> ShowS
showList :: [ConsentVerdict] -> ShowS
Show)

-- | Whether deleting from this store destroys anything.
data StoreClass
    = -- | A private store that holds only what was published to it, so a delete is final.
      StoreDestroyable
    | -- | The store can refill deleted versions. Carries the reason deletion must be withheld.
      StorePreserved Text
    deriving stock (StoreClass -> StoreClass -> Bool
(StoreClass -> StoreClass -> Bool)
-> (StoreClass -> StoreClass -> Bool) -> Eq StoreClass
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: StoreClass -> StoreClass -> Bool
== :: StoreClass -> StoreClass -> Bool
$c/= :: StoreClass -> StoreClass -> Bool
/= :: StoreClass -> StoreClass -> Bool
Eq, Int -> StoreClass -> ShowS
[StoreClass] -> ShowS
StoreClass -> String
(Int -> StoreClass -> ShowS)
-> (StoreClass -> String)
-> ([StoreClass] -> ShowS)
-> Show StoreClass
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StoreClass -> ShowS
showsPrec :: Int -> StoreClass -> ShowS
$cshow :: StoreClass -> String
show :: StoreClass -> String
$cshowList :: [StoreClass] -> ShowS
showList :: [StoreClass] -> ShowS
Show)

-- | An adapter-classified failure with transport details and retry advice.
data StoreFault = StoreFault
    { StoreFault -> TransportFault
faultTransport :: TransportFault
    , StoreFault -> RetryAdvice
faultRetry :: RetryAdvice
    }
    deriving stock (StoreFault -> StoreFault -> Bool
(StoreFault -> StoreFault -> Bool)
-> (StoreFault -> StoreFault -> Bool) -> Eq StoreFault
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: StoreFault -> StoreFault -> Bool
== :: StoreFault -> StoreFault -> Bool
$c/= :: StoreFault -> StoreFault -> Bool
/= :: StoreFault -> StoreFault -> Bool
Eq, Int -> StoreFault -> ShowS
[StoreFault] -> ShowS
StoreFault -> String
(Int -> StoreFault -> ShowS)
-> (StoreFault -> String)
-> ([StoreFault] -> ShowS)
-> Show StoreFault
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StoreFault -> ShowS
showsPrec :: Int -> StoreFault -> ShowS
$cshow :: StoreFault -> String
show :: StoreFault -> String
$cshowList :: [StoreFault] -> ShowS
showList :: [StoreFault] -> ShowS
Show)

-- | What a caller does after a fault.
data RetryAdvice
    = -- | Another attempt fails the same way, so the caller stops.
      RetryFutile
    | -- | Worth another attempt, with no delay the backend asked for.
      RetryWorthwhile
    | -- | Worth another attempt, no sooner than the delay the backend itself asked for.
      RetryDelayed RetryAfter
    deriving stock (RetryAdvice -> RetryAdvice -> Bool
(RetryAdvice -> RetryAdvice -> Bool)
-> (RetryAdvice -> RetryAdvice -> Bool) -> Eq RetryAdvice
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RetryAdvice -> RetryAdvice -> Bool
== :: RetryAdvice -> RetryAdvice -> Bool
$c/= :: RetryAdvice -> RetryAdvice -> Bool
/= :: RetryAdvice -> RetryAdvice -> Bool
Eq, Int -> RetryAdvice -> ShowS
[RetryAdvice] -> ShowS
RetryAdvice -> String
(Int -> RetryAdvice -> ShowS)
-> (RetryAdvice -> String)
-> ([RetryAdvice] -> ShowS)
-> Show RetryAdvice
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RetryAdvice -> ShowS
showsPrec :: Int -> RetryAdvice -> ShowS
$cshow :: RetryAdvice -> String
show :: RetryAdvice -> String
$cshowList :: [RetryAdvice] -> ShowS
showList :: [RetryAdvice] -> ShowS
Show)

-- | Stream pages until completion, a fault, or a repeated continuation token.
pageSource ::
    (Monad m) =>
    (Maybe Text -> m (Either StoreFault (Maybe Text, [a]))) ->
    ConduitT i [a] m (Maybe StoreFault)
pageSource :: forall (m :: * -> *) a i.
Monad m =>
(Maybe Text -> m (Either StoreFault (Maybe Text, [a])))
-> ConduitT i [a] m (Maybe StoreFault)
pageSource Maybe Text -> m (Either StoreFault (Maybe Text, [a]))
fetch = Set Text -> Maybe Text -> ConduitT i [a] m (Maybe StoreFault)
forall {i}.
Set Text -> Maybe Text -> ConduitT i [a] m (Maybe StoreFault)
go Set Text
forall a. Set a
Set.empty Maybe Text
forall a. Maybe a
Nothing
  where
    go :: Set Text -> Maybe Text -> ConduitT i [a] m (Maybe StoreFault)
go Set Text
seen Maybe Text
token =
        m (Either StoreFault (Maybe Text, [a]))
-> ConduitT i [a] m (Either StoreFault (Maybe Text, [a]))
forall (m :: * -> *) a. Monad m => m a -> ConduitT i [a] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Maybe Text -> m (Either StoreFault (Maybe Text, [a]))
fetch Maybe Text
token) ConduitT i [a] m (Either StoreFault (Maybe Text, [a]))
-> (Either StoreFault (Maybe Text, [a])
    -> ConduitT i [a] m (Maybe StoreFault))
-> ConduitT i [a] m (Maybe StoreFault)
forall a b.
ConduitT i [a] m a
-> (a -> ConduitT i [a] m b) -> ConduitT i [a] m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Left StoreFault
fault -> Maybe StoreFault -> ConduitT i [a] m (Maybe StoreFault)
forall a. a -> ConduitT i [a] m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StoreFault -> Maybe StoreFault
forall a. a -> Maybe a
Just StoreFault
fault)
            Right (Maybe Text
next, [a]
page) -> do
                [a] -> ConduitT i [a] m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield [a]
page
                case Maybe Text
next of
                    Maybe Text
Nothing -> Maybe StoreFault -> ConduitT i [a] m (Maybe StoreFault)
forall a. a -> ConduitT i [a] m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe StoreFault
forall a. Maybe a
Nothing
                    Just Text
following
                        | Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Text
following Set Text
seen -> Maybe StoreFault -> ConduitT i [a] m (Maybe StoreFault)
forall a. a -> ConduitT i [a] m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StoreFault -> Maybe StoreFault
forall a. a -> Maybe a
Just (Text -> StoreFault
repeatedTokenFault Text
following))
                        | Bool
otherwise -> Set Text -> Maybe Text -> ConduitT i [a] m (Maybe StoreFault)
go (Text -> Set Text -> Set Text
forall a. Ord a => a -> Set a -> Set a
Set.insert Text
following Set Text
seen) (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
following)

-- | Buffer a bounded listing, discarding collected pages if the stream faults.
collectPages :: (Monad m) => ConduitT () [a] m (Maybe StoreFault) -> m (Either StoreFault [a])
collectPages :: forall (m :: * -> *) a.
Monad m =>
ConduitT () [a] m (Maybe StoreFault) -> m (Either StoreFault [a])
collectPages ConduitT () [a] m (Maybe StoreFault)
source = (Maybe StoreFault, [[a]]) -> Either StoreFault [a]
forall {t :: * -> *} {a} {a}.
Foldable t =>
(Maybe a, t [a]) -> Either a [a]
outcome ((Maybe StoreFault, [[a]]) -> Either StoreFault [a])
-> m (Maybe StoreFault, [[a]]) -> m (Either StoreFault [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConduitT () Void m (Maybe StoreFault, [[a]])
-> m (Maybe StoreFault, [[a]])
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () [a] m (Maybe StoreFault)
-> ConduitT [a] Void m [[a]]
-> ConduitT () Void m (Maybe StoreFault, [[a]])
forall (m :: * -> *) a b r1 c r2.
Monad m =>
ConduitT a b m r1 -> ConduitT b c m r2 -> ConduitT a c m (r1, r2)
fuseBoth ConduitT () [a] m (Maybe StoreFault)
source ConduitT [a] Void m [[a]]
forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
CL.consume)
  where
    outcome :: (Maybe a, t [a]) -> Either a [a]
outcome (Maybe a
mFault, t [a]
pages) = Either a [a] -> (a -> Either a [a]) -> Maybe a -> Either a [a]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([a] -> Either a [a]
forall a b. b -> Either a b
Right (t [a] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat t [a]
pages)) a -> Either a [a]
forall a b. a -> Either a b
Left Maybe a
mFault

-- | Stop consuming pages at the item bound and return no partial inventory.
collectPagesBounded :: (Monad m) => Int -> ConduitT () [a] m (Maybe StoreFault) -> m (Either StoreFault [a])
collectPagesBounded :: forall (m :: * -> *) a.
Monad m =>
Int
-> ConduitT () [a] m (Maybe StoreFault)
-> m (Either StoreFault [a])
collectPagesBounded Int
limit ConduitT () [a] m (Maybe StoreFault)
source = (Maybe (Maybe StoreFault), Maybe [a]) -> Either StoreFault [a]
forall {b}.
(Maybe (Maybe StoreFault), Maybe b) -> Either StoreFault b
outcome ((Maybe (Maybe StoreFault), Maybe [a]) -> Either StoreFault [a])
-> m (Maybe (Maybe StoreFault), Maybe [a])
-> m (Either StoreFault [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConduitT () Void m (Maybe (Maybe StoreFault), Maybe [a])
-> m (Maybe (Maybe StoreFault), Maybe [a])
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () [a] m (Maybe StoreFault)
-> ConduitT [a] Void m (Maybe [a])
-> ConduitT () Void m (Maybe (Maybe StoreFault), Maybe [a])
forall (m :: * -> *) a b r1 c r2.
Monad m =>
ConduitT a b m r1
-> ConduitT b c m r2 -> ConduitT a c m (Maybe r1, r2)
fuseBothMaybe ConduitT () [a] m (Maybe StoreFault)
source (Int -> [[a]] -> ConduitT [a] Void m (Maybe [a])
forall {m :: * -> *} {a} {o}.
Monad m =>
Int -> [[a]] -> ConduitT [a] o m (Maybe [a])
consume Int
0 []))
  where
    consume :: Int -> [[a]] -> ConduitT [a] o m (Maybe [a])
consume Int
held [[a]]
pages =
        ConduitT [a] o m (Maybe [a])
forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await ConduitT [a] o m (Maybe [a])
-> (Maybe [a] -> ConduitT [a] o m (Maybe [a]))
-> ConduitT [a] o m (Maybe [a])
forall a b.
ConduitT [a] o m a
-> (a -> ConduitT [a] o m b) -> ConduitT [a] o m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Maybe [a]
Nothing -> Maybe [a] -> ConduitT [a] o m (Maybe [a])
forall a. a -> ConduitT [a] o m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([a] -> Maybe [a]
forall a. a -> Maybe a
Just ([[a]] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[a]] -> [[a]]
forall a. [a] -> [a]
reverse [[a]]
pages)))
            Just [a]
page ->
                let taken :: Int
taken = [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
page
                 in if Int
taken Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 Int
limit Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
held
                        then Maybe [a] -> ConduitT [a] o m (Maybe [a])
forall a. a -> ConduitT [a] o m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [a]
forall a. Maybe a
Nothing
                        else Int -> [[a]] -> ConduitT [a] o m (Maybe [a])
consume (Int
held Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
taken) ([a]
page [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [[a]]
pages)
    outcome :: (Maybe (Maybe StoreFault), Maybe b) -> Either StoreFault b
outcome = \case
        (Maybe (Maybe StoreFault)
_, Maybe b
Nothing) -> StoreFault -> Either StoreFault b
forall a b. a -> Either a b
Left (Text -> StoreFault
protocolFault Text
"the store inventory crossed limits.maxVersionCount")
        (Just (Just StoreFault
fault), Maybe b
_) -> StoreFault -> Either StoreFault b
forall a b. a -> Either a b
Left StoreFault
fault
        (Maybe (Maybe StoreFault)
_, Just b
values) -> b -> Either StoreFault b
forall a b. b -> Either a b
Right b
values

-- | Collect one package's versions. Return a fault without partial results.
pageAll ::
    (Monad m) =>
    (Maybe Text -> m (Either StoreFault (Maybe Text, [a]))) ->
    m (Either StoreFault [a])
pageAll :: forall (m :: * -> *) a.
Monad m =>
(Maybe Text -> m (Either StoreFault (Maybe Text, [a])))
-> m (Either StoreFault [a])
pageAll = ConduitT () [a] m (Maybe StoreFault) -> m (Either StoreFault [a])
forall (m :: * -> *) a.
Monad m =>
ConduitT () [a] m (Maybe StoreFault) -> m (Either StoreFault [a])
collectPages (ConduitT () [a] m (Maybe StoreFault) -> m (Either StoreFault [a]))
-> ((Maybe Text -> m (Either StoreFault (Maybe Text, [a])))
    -> ConduitT () [a] m (Maybe StoreFault))
-> (Maybe Text -> m (Either StoreFault (Maybe Text, [a])))
-> m (Either StoreFault [a])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Text -> m (Either StoreFault (Maybe Text, [a])))
-> ConduitT () [a] m (Maybe StoreFault)
forall (m :: * -> *) a i.
Monad m =>
(Maybe Text -> m (Either StoreFault (Maybe Text, [a])))
-> ConduitT i [a] m (Maybe StoreFault)
pageSource

-- A cycle in the store's own paging, which the next attempt reproduces.
repeatedTokenFault :: Text -> StoreFault
repeatedTokenFault :: Text -> StoreFault
repeatedTokenFault Text
token =
    StoreFault
        { faultTransport :: TransportFault
faultTransport =
            TransportCause -> Text -> TransportFault
transportFault TransportCause
TransportProtocol (Text
"the store handed back a page token it had already given: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
token)
        , faultRetry :: RetryAdvice
faultRetry = RetryAdvice
RetryFutile
        }

-- | Read a package manifest using the store's credential and ecosystem codec.
type StoreManifestRead = PackageName -> IO (Either StoreFault Manifest)

-- | Only retryable transport faults warrant another attempt within the same cycle.
storeFaultOfFetch :: FetchFault -> StoreFault
storeFaultOfFetch :: FetchFault -> StoreFault
storeFaultOfFetch = \case
    FetchTransport TransportFault
fault ->
        StoreFault
            { faultTransport :: TransportFault
faultTransport = TransportFault
fault
            , faultRetry :: RetryAdvice
faultRetry = if TransportCause -> Bool
transportRetryable (TransportFault -> TransportCause
tfCause TransportFault
fault) then RetryAdvice
RetryWorthwhile else RetryAdvice
RetryFutile
            }
    FetchBoundExceeded LimitError
_ -> Text -> StoreFault
protocolFault Text
"the store's answer crossed the response-size bound"
    FetchUrlUnformable UrlFormationError
err -> UrlFormationError -> StoreFault
unformableFault UrlFormationError
err

-- | Preserve HTTP and transport retry advice. Absence and other terminal refusals advise no retry.
storeFaultOfMetadata :: MetadataError -> StoreFault
storeFaultOfMetadata :: MetadataError -> StoreFault
storeFaultOfMetadata = \case
    MetadataError
MetadataAbsent -> Text -> StoreFault
protocolFault Text
"the store has no metadata for the requested package (HTTP 404)"
    MetadataHttpFailure Int
code ->
        (Int -> Bool) -> Int -> Text -> StoreFault
statusFault Int -> Bool
isRetryableStatusCode Int
code (Text
"the store refused the metadata read with HTTP " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
code)
    MetadataAuthorisationFailure Int
_ -> Text -> StoreFault
protocolFault Text
"the store refused metadata access"
    MetadataFetch FetchFault
fault -> FetchFault -> StoreFault
storeFaultOfFetch FetchFault
fault
    MetadataBoundExceeded LimitError
_ -> Text -> StoreFault
protocolFault Text
"the store's metadata crossed a structural bound"
    MetadataError
MetadataUndecodable -> Text -> StoreFault
protocolFault Text
"the store's metadata did not decode into a manifest"
    MetadataNameMismatch Text
reported ->
        Text -> StoreFault
protocolFault (Text
"the store's metadata reported another package's name: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
reported)

-- | A URL the store's own coordinates could not form, reduced to its authority.
unformableFault :: UrlFormationError -> StoreFault
unformableFault :: UrlFormationError -> StoreFault
unformableFault UrlFormationError
err =
    Text -> StoreFault
protocolFault (Text
"the store's request could not be formed: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> UrlFormationError -> Text
renderUrlFormationError UrlFormationError
err)

-- | A fault in the store's own answer, which the next attempt reproduces.
protocolFault :: Text -> StoreFault
protocolFault :: Text -> StoreFault
protocolFault Text
detail =
    StoreFault{faultTransport :: TransportFault
faultTransport = TransportCause -> Text -> TransportFault
transportFault TransportCause
TransportProtocol Text
detail, faultRetry :: RetryAdvice
faultRetry = RetryAdvice
RetryFutile}

{- | A fault the store's answer status classifies. The predicate is the caller's own: the
statuses worth another attempt differ between the reads.
-}
statusFault :: (Int -> Bool) -> Int -> Text -> StoreFault
statusFault :: (Int -> Bool) -> Int -> Text -> StoreFault
statusFault Int -> Bool
retryable Int
status Text
detail =
    StoreFault
        { faultTransport :: TransportFault
faultTransport = TransportCause -> Text -> TransportFault
transportFault TransportCause
TransportProtocol Text
detail
        , faultRetry :: RetryAdvice
faultRetry = if Int -> Bool
retryable Int
status then RetryAdvice
RetryWorthwhile else RetryAdvice
RetryFutile
        }

-- | Apply the backend batch limit, treating a non-positive limit as one.
chunksOfCeiling :: DeleteCeiling -> [a] -> [[a]]
chunksOfCeiling :: forall a. DeleteCeiling -> [a] -> [[a]]
chunksOfCeiling DeleteCeiling
ceiling' [a]
items = case DeleteCeiling
ceiling' of
    DeleteCeiling
NoCeiling -> [[a]
items | Bool -> Bool
not ([a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
items)]
    AtMost Int
limit -> Int -> [a] -> [[a]]
forall {a}. Int -> [a] -> [[a]]
go (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 Int
limit) [a]
items
  where
    go :: Int -> [a] -> [[a]]
go Int
_ [] = []
    go Int
size [a]
batch = let ([a]
chunk, [a]
rest) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
size [a]
batch in [a]
chunk [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: Int -> [a] -> [[a]]
go Int
size [a]
rest

-- | The backend owns chunks. A request fault stops later chunks, including after a guarded retry.
deleteAll ::
    DeleteGuard ->
    ([Version] -> IO (Either StoreFault [(Version, VersionOutcome)])) ->
    [[Version]] ->
    IO [(Version, VersionOutcome)]
deleteAll :: DeleteGuard
-> ([Version]
    -> IO (Either StoreFault [(Version, VersionOutcome)]))
-> [[Version]]
-> IO [(Version, VersionOutcome)]
deleteAll DeleteGuard
checks [Version] -> IO (Either StoreFault [(Version, VersionOutcome)])
send = DeleteRun
-> [[(Version, VersionOutcome)]]
-> [[Version]]
-> IO [(Version, VersionOutcome)]
deleteChunks DeleteRun{drChecks :: DeleteGuard
drChecks = DeleteGuard
checks, drSend :: [Version] -> IO (Either StoreFault [(Version, VersionOutcome)])
drSend = [Version] -> IO (Either StoreFault [(Version, VersionOutcome)])
send} []

-- The guard and the destructive call one run of 'deleteAll' drives, bundled so each step below
-- carries one parameter for both.
data DeleteRun = DeleteRun
    { DeleteRun -> DeleteGuard
drChecks :: DeleteGuard
    , DeleteRun
-> [Version] -> IO (Either StoreFault [(Version, VersionOutcome)])
drSend :: [Version] -> IO (Either StoreFault [(Version, VersionOutcome)])
    }

deleteChunks :: DeleteRun -> [[(Version, VersionOutcome)]] -> [[Version]] -> IO [(Version, VersionOutcome)]
deleteChunks :: DeleteRun
-> [[(Version, VersionOutcome)]]
-> [[Version]]
-> IO [(Version, VersionOutcome)]
deleteChunks DeleteRun
_ [[(Version, VersionOutcome)]]
sent [] = [(Version, VersionOutcome)] -> IO [(Version, VersionOutcome)]
forall {b}. b -> IO b
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([[(Version, VersionOutcome)]] -> [(Version, VersionOutcome)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(Version, VersionOutcome)]] -> [[(Version, VersionOutcome)]]
forall a. [a] -> [a]
reverse [[(Version, VersionOutcome)]]
sent))
deleteChunks DeleteRun
run [[(Version, VersionOutcome)]]
sent ([Version]
chunk : [[Version]]
rest) =
    DeleteGuard
-> DeletePhase -> [Version] -> IO (Either StoreFault [Version])
dgCheck (DeleteRun -> DeleteGuard
drChecks DeleteRun
run) DeletePhase
BeforeDelete [Version]
chunk IO (Either StoreFault [Version])
-> (Either StoreFault [Version] -> IO [(Version, VersionOutcome)])
-> IO [(Version, VersionOutcome)]
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 -> [(Version, VersionOutcome)] -> IO [(Version, VersionOutcome)]
forall {b}. b -> IO b
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Version, VersionOutcome)]
settled [(Version, VersionOutcome)]
-> [(Version, VersionOutcome)] -> [(Version, VersionOutcome)]
forall a. Semigroup a => a -> a -> a
<> ([Version] -> [(Version, VersionOutcome)])
-> [[Version]] -> [(Version, VersionOutcome)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (StoreFault -> [Version] -> [(Version, VersionOutcome)]
unreachedBatch StoreFault
fault) ([Version]
chunk [Version] -> [[Version]] -> [[Version]]
forall a. a -> [a] -> [a]
: [[Version]]
rest))
        Right [Version]
current -> do
            let permitted :: [Version]
permitted = (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
`elem` [Version]
current) [Version]
chunk
                withheld :: [(Version, VersionOutcome)]
withheld = [Version] -> [(Version, VersionOutcome)]
skipped ((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]
current) [Version]
chunk)
            DeleteRun
-> [Version] -> IO (Either StoreFault [(Version, VersionOutcome)])
issueBatch DeleteRun
run [Version]
permitted IO (Either StoreFault [(Version, VersionOutcome)])
-> (Either StoreFault [(Version, VersionOutcome)]
    -> IO [(Version, VersionOutcome)])
-> IO [(Version, VersionOutcome)]
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 [(Version, VersionOutcome)]
outcomes -> DeleteRun
-> [[(Version, VersionOutcome)]]
-> [[Version]]
-> IO [(Version, VersionOutcome)]
deleteChunks DeleteRun
run (([(Version, VersionOutcome)]
withheld [(Version, VersionOutcome)]
-> [(Version, VersionOutcome)] -> [(Version, VersionOutcome)]
forall a. Semigroup a => a -> a -> a
<> [(Version, VersionOutcome)]
outcomes) [(Version, VersionOutcome)]
-> [[(Version, VersionOutcome)]] -> [[(Version, VersionOutcome)]]
forall a. a -> [a] -> [a]
: [[(Version, VersionOutcome)]]
sent) [[Version]]
rest
                Left StoreFault
fault -> do
                    outcomes <- DeleteRun
-> StoreFault -> [Version] -> IO [(Version, VersionOutcome)]
reassessThenRetry DeleteRun
run StoreFault
fault [Version]
permitted
                    pure (settled <> withheld <> outcomes <> concatMap (unreachedBatch fault) rest)
  where
    settled :: [(Version, VersionOutcome)]
settled = [[(Version, VersionOutcome)]] -> [(Version, VersionOutcome)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(Version, VersionOutcome)]] -> [[(Version, VersionOutcome)]]
forall a. [a] -> [a]
reverse [[(Version, VersionOutcome)]]
sent)

{- An uncertain batch is observed without reserving, then the guard decides whether another
attempt is allowed at all, and only then is the reservation taken again. -}
reassessThenRetry :: DeleteRun -> StoreFault -> [Version] -> IO [(Version, VersionOutcome)]
reassessThenRetry :: DeleteRun
-> StoreFault -> [Version] -> IO [(Version, VersionOutcome)]
reassessThenRetry DeleteRun
run StoreFault
fault [Version]
issued = do
    IO (Either StoreFault [Version]) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (DeleteGuard
-> DeletePhase -> [Version] -> IO (Either StoreFault [Version])
dgCheck (DeleteRun -> DeleteGuard
drChecks DeleteRun
run) DeletePhase
AfterUncertain [Version]
issued)
    retry <- DeleteGuard -> StoreFault -> IO Bool
dgRetry (DeleteRun -> DeleteGuard
drChecks DeleteRun
run) StoreFault
fault
    fresh <- if retry then dgCheck (drChecks run) BeforeDelete issued else pure (Right [])
    retryBatch run fault issued fresh

-- A refused retry arrives as an empty reservation, so the versions it covers stay uncertain.
retryBatch :: DeleteRun -> StoreFault -> [Version] -> Either StoreFault [Version] -> IO [(Version, VersionOutcome)]
retryBatch :: DeleteRun
-> StoreFault
-> [Version]
-> Either StoreFault [Version]
-> IO [(Version, VersionOutcome)]
retryBatch DeleteRun
run StoreFault
fault [Version]
issued = \case
    Right [Version]
current | Bool -> Bool
not ([Version] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Version]
current) -> do
        let permitted :: [Version]
permitted = (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
`elem` [Version]
current) [Version]
issued
            unchanged :: [(Version, VersionOutcome)]
unchanged = StoreFault -> [Version] -> [(Version, VersionOutcome)]
uncertain StoreFault
fault ((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]
current) [Version]
issued)
        DeleteRun
-> [Version] -> IO (Either StoreFault [(Version, VersionOutcome)])
issueBatch DeleteRun
run [Version]
permitted IO (Either StoreFault [(Version, VersionOutcome)])
-> (Either StoreFault [(Version, VersionOutcome)]
    -> IO [(Version, VersionOutcome)])
-> IO [(Version, VersionOutcome)]
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 [(Version, VersionOutcome)]
outcomes -> [(Version, VersionOutcome)] -> IO [(Version, VersionOutcome)]
forall {b}. b -> IO b
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Version, VersionOutcome)]
unchanged [(Version, VersionOutcome)]
-> [(Version, VersionOutcome)] -> [(Version, VersionOutcome)]
forall a. Semigroup a => a -> a -> a
<> [(Version, VersionOutcome)]
outcomes)
            Left StoreFault
again -> do
                IO (Either StoreFault [Version]) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (DeleteGuard
-> DeletePhase -> [Version] -> IO (Either StoreFault [Version])
dgCheck (DeleteRun -> DeleteGuard
drChecks DeleteRun
run) DeletePhase
AfterUncertain [Version]
permitted)
                [(Version, VersionOutcome)] -> IO [(Version, VersionOutcome)]
forall {b}. b -> IO b
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Version, VersionOutcome)]
unchanged [(Version, VersionOutcome)]
-> [(Version, VersionOutcome)] -> [(Version, VersionOutcome)]
forall a. Semigroup a => a -> a -> a
<> StoreFault -> [Version] -> [(Version, VersionOutcome)]
uncertain StoreFault
again [Version]
permitted)
    Either StoreFault [Version]
_ -> [(Version, VersionOutcome)] -> IO [(Version, VersionOutcome)]
forall {b}. b -> IO b
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StoreFault -> [Version] -> [(Version, VersionOutcome)]
uncertain StoreFault
fault [Version]
issued)

-- An empty batch reaches the backend as no call at all.
issueBatch :: DeleteRun -> [Version] -> IO (Either StoreFault [(Version, VersionOutcome)])
issueBatch :: DeleteRun
-> [Version] -> IO (Either StoreFault [(Version, VersionOutcome)])
issueBatch DeleteRun
run [Version]
versions
    | [Version] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Version]
versions = Either StoreFault [(Version, VersionOutcome)]
-> IO (Either StoreFault [(Version, VersionOutcome)])
forall {b}. b -> IO b
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Version, VersionOutcome)]
-> Either StoreFault [(Version, VersionOutcome)]
forall a b. b -> Either a b
Right [])
    | Bool
otherwise = DeleteRun
-> [Version] -> IO (Either StoreFault [(Version, VersionOutcome)])
drSend DeleteRun
run [Version]
versions

skipped :: [Version] -> [(Version, VersionOutcome)]
skipped :: [Version] -> [(Version, VersionOutcome)]
skipped = (Version -> (Version, VersionOutcome))
-> [Version] -> [(Version, VersionOutcome)]
forall a b. (a -> b) -> [a] -> [b]
map (,StoreRefusal -> VersionOutcome
VersionRefused (Text -> Text -> StoreRefusal
storeRefusal Text
"REASSESSED" Text
"current evidence does not authorise this delete"))

uncertain :: StoreFault -> [Version] -> [(Version, VersionOutcome)]
uncertain :: StoreFault -> [Version] -> [(Version, VersionOutcome)]
uncertain StoreFault
fault = (Version -> (Version, VersionOutcome))
-> [Version] -> [(Version, VersionOutcome)]
forall a b. (a -> b) -> [a] -> [b]
map (,StoreFault -> VersionOutcome
VersionUncertain StoreFault
fault)