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

{- | Maintenance through registry protocol endpoints.
Deletion needs the raw document revision, with listing bounds separate from serve-path bounds.
Consent and refill classification rely on operator configuration.
-}
module Ecluse.Core.Registry.Maintenance.Protocol (
    ProtocolRead (..),
    ProtocolStore (..),
    newProtocolObservation,
    newProtocolMaintenance,
) where

import Data.ByteString qualified as BS

import Data.Conduit (ConduitT, yield)
import Data.Map.Strict qualified as Map
import Network.HTTP.Client (Request)

import Ecluse.Core.Credential (ClientCredential (credSecret), Secret)
import Ecluse.Core.Fault.Http (isRetryableStatusCode)
import Ecluse.Core.Package (PackageName)
import Ecluse.Core.Registry (
    BodyOutcome (SuccessBody, UnreadStatus),
    ParseError (parseErrorMessage),
    RegistryResponse (RegistryResponse),
    UrlFormationError,
    isSuccessStatus,
 )
import Ecluse.Core.Registry.Adapter.Capability (
    StoreListing (listingParser, listingRequest),
    VersionDelete (deleteDocumentRequest, deleteRequests),
 )
import Ecluse.Core.Registry.Exchange (boundedExchange, boundedJsonFetch, formThen)
import Ecluse.Core.Registry.JsonStream (StreamResult (streamValue))
import Ecluse.Core.Registry.Maintenance (
    CompletionNotion (CompletesOnCall),
    ConsentVerdict (ConsentGranted, ConsentWithheld),
    DeleteCeiling (AtMost),
    DeleteGuard,
    RefillPosture (RefillPermitted),
    StoreClass (StoreDestroyable, StorePreserved),
    StoreDeletion (..),
    StoreFacts (..),
    StoreFault,
    StoreMaintenance,
    StoreManifestRead,
    StoreObservation (..),
    StoreRefusal,
    StoredVersion (StoredVersion, storedPresence, storedRevision, storedVersion),
    VersionOutcome (VersionRefused, VersionRemoved),
    VersionPresence (VersionServed),
    chunksOfCeiling,
    deleteAll,
    maintenanceOf,
    protocolFault,
    statusFault,
    storeFaultOfFetch,
    storeRefusal,
    unformableFault,
 )
import Ecluse.Core.Registry.Maintenance.Budget (
    QuotaDimension (StoreRequests),
    StoreBudget (bgCosts),
    requestKinds,
    undeclaredBudget,
 )
import Ecluse.Core.Registry.Maintenance.NameSpace (
    NamePrefix,
    inBucket,
    noNameAlphabet,
 )
import Ecluse.Core.Registry.Maintenance.Upstream (noUpstreamMechanism)
import Ecluse.Core.Registry.Origin (OriginClient (ocLimits, ocManager, ocToken), originBaseUrl)
import Ecluse.Core.Registry.Publish (PublishCodec (pcProbeRequest, pcVersionListParser), fetchVersionList)
import Ecluse.Core.Security (BodyLimit (MetadataBodyLimit), Limits (progressFloor), maxMetadataBytes)
import Ecluse.Core.Version (Version)

{- | One protocol-only store as a reader reaches it: where it is, how its protocol enumerates it,
and the consent an operator declared for it. Nothing here changes the store.
-}
data ProtocolRead = ProtocolRead
    { ProtocolRead -> OriginClient
prOrigin :: OriginClient
    -- ^ The store's coordinates, its credential, and the bound every read is held to.
    , ProtocolRead -> StoreListing
prListing :: StoreListing
    -- ^ The ecosystem's package listing verb.
    , ProtocolRead -> PublishCodec
prCodec :: PublishCodec
    -- ^ The ecosystem's publish codec, whose presence probe already reads a store's version list for the mirror worker.
    , ProtocolRead -> StoreManifestRead
prReadManifest :: StoreManifestRead
    -- ^ One package's metadata as this store serves it, assembled at the composition root.
    , ProtocolRead -> Text
prBackendName :: Text
    -- ^ The store backend's name, which the boot line records the Dredger's blast radius as.
    , ProtocolRead -> Bool
prPermitDeletion :: Bool
    -- ^ Whether the operator marked this store for deletion.
    , ProtocolRead -> Text
prConsentDescriptor :: Text
    -- ^ How an operator marks it, logged verbatim when consent is withheld.
    }

-- | One protocol-only store a caller may delete from: its reads, beside the verb that removes a version.
data ProtocolStore = ProtocolStore
    { ProtocolStore -> ProtocolRead
psRead :: ProtocolRead
    , ProtocolStore -> OriginClient
psDeleteOrigin :: OriginClient
    , ProtocolStore -> VersionDelete
psDelete :: VersionDelete
    }

-- | The calls that only enumerate and read, built without the delete verb.
newProtocolObservation :: ProtocolRead -> StoreObservation
newProtocolObservation :: ProtocolRead -> StoreObservation
newProtocolObservation ProtocolRead
store =
    StoreObservation
        { obFacts :: StoreFacts
obFacts = Text -> StoreFacts
protocolFacts (ProtocolRead -> Text
prBackendName ProtocolRead
store)
        , obListPackagesIn :: NamePrefix -> ConduitT () [PackageName] IO (Maybe StoreFault)
obListPackagesIn = ProtocolRead
-> NamePrefix -> ConduitT () [PackageName] IO (Maybe StoreFault)
listBucket ProtocolRead
store
        , obEnumerateVersions :: PackageName -> IO (Either StoreFault [StoredVersion])
obEnumerateVersions = ProtocolRead
-> PackageName -> IO (Either StoreFault [StoredVersion])
listVersions ProtocolRead
store
        , obReadManifest :: StoreManifestRead
obReadManifest = ProtocolRead -> StoreManifestRead
prReadManifest ProtocolRead
store
        , obVerifyConsent :: IO (Either StoreFault ConsentVerdict)
obVerifyConsent = Either StoreFault ConsentVerdict
-> IO (Either StoreFault ConsentVerdict)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConsentVerdict -> Either StoreFault ConsentVerdict
forall a b. b -> Either a b
Right (ProtocolRead -> ConsentVerdict
consentVerdict ProtocolRead
store))
        , obClassifyStore :: IO (Either StoreFault StoreClass)
obClassifyStore = Either StoreFault StoreClass -> IO (Either StoreFault StoreClass)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StoreClass -> Either StoreFault StoreClass
forall a b. b -> Either a b
Right (ProtocolRead -> StoreClass
storeClass ProtocolRead
store))
        , -- A protocol store carries its uplinks in a configuration file it does not serve.
          obProbeUpstream :: IO UpstreamSafety
obProbeUpstream = IO UpstreamSafety
forall (m :: * -> *). Applicative m => m UpstreamSafety
noUpstreamMechanism
        }

-- | Delete versions individually because each edit changes the document revision needed by the next.
newProtocolMaintenance :: ProtocolStore -> StoreMaintenance
newProtocolMaintenance :: ProtocolStore -> StoreMaintenance
newProtocolMaintenance ProtocolStore
store =
    StoreObservation -> StoreDeletion -> StoreMaintenance
maintenanceOf
        (ProtocolRead -> StoreObservation
newProtocolObservation (ProtocolStore -> ProtocolRead
psRead ProtocolStore
store))
        StoreDeletion
            { dlDeleteVersions :: DeleteGuard
-> PackageName -> [Version] -> IO [(Version, VersionOutcome)]
dlDeleteVersions = ProtocolStore
-> DeleteGuard
-> PackageName
-> [Version]
-> IO [(Version, VersionOutcome)]
deleteStoredVersions ProtocolStore
store
            , -- The protocol writes nothing but a publish, so a walk over this store keeps no cursor.
              dlCursor :: Maybe StoreCursor
dlCursor = Maybe StoreCursor
forall a. Maybe a
Nothing
            }

{- The store re-admits a version published again after a delete, and has applied it by the time it
answers. It reports no alphabet: the listing below reads one document whole, bucket or no bucket. -}
protocolFacts :: Text -> StoreFacts
protocolFacts :: Text -> StoreFacts
protocolFacts Text
backend =
    StoreFacts
        { factBackend :: Text
factBackend = Text
backend
        , factDeleteCeiling :: DeleteCeiling
factDeleteCeiling = DeleteCeiling
deleteCeiling
        , factRefill :: RefillPosture
factRefill = RefillPosture
RefillPermitted
        , factCompletion :: CompletionNotion
factCompletion = CompletionNotion
CompletesOnCall
        , factNameAlphabet :: NameAlphabet
factNameAlphabet = NameAlphabet
noNameAlphabet
        , factBudget :: StoreBudget
factBudget = StoreBudget
protocolBudget
        }

{- A protocol-only store publishes no account quota, so its capacity stays undeclared until an
operator declares one. Every call it makes debits the one undivided request dimension. -}
protocolBudget :: StoreBudget
protocolBudget :: StoreBudget
protocolBudget =
    StoreBudget
undeclaredBudget{bgCosts = Map.fromList [(kind, Map.singleton StoreRequests 1) | kind <- requestKinds]}

{- The delete edit addresses the document revision it was formed from, and applying one changes
that revision, so a batch of two would send the second against a revision that no longer exists. -}
deleteCeiling :: DeleteCeiling
deleteCeiling :: DeleteCeiling
deleteCeiling = Int -> DeleteCeiling
AtMost Int
1

consentVerdict :: ProtocolRead -> ConsentVerdict
consentVerdict :: ProtocolRead -> ConsentVerdict
consentVerdict ProtocolRead
store
    | ProtocolRead -> Bool
prPermitDeletion ProtocolRead
store = ConsentVerdict
ConsentGranted
    | Bool
otherwise = Text -> ConsentVerdict
ConsentWithheld (ProtocolRead -> Text
prConsentDescriptor ProtocolRead
store)

{- No protocol read can see whether this store refills itself from an uplink, so the operator's
own key is the only evidence either way. -}
storeClass :: ProtocolRead -> StoreClass
storeClass :: ProtocolRead -> StoreClass
storeClass ProtocolRead
store
    | ProtocolRead -> Bool
prPermitDeletion ProtocolRead
store = StoreClass
StoreDestroyable
    | Bool
otherwise = Text -> StoreClass
StorePreserved (ProtocolRead -> Text
prConsentDescriptor ProtocolRead
store)

{- One bucket of the store's names, as the single page its one listing document holds. The
protocol spells no prefix filter, so the bucket is applied to what came back. -}
listBucket :: ProtocolRead -> NamePrefix -> ConduitT () [PackageName] IO (Maybe StoreFault)
listBucket :: ProtocolRead
-> NamePrefix -> ConduitT () [PackageName] IO (Maybe StoreFault)
listBucket ProtocolRead
store NamePrefix
prefix =
    IO (Either StoreFault [PackageName])
-> ConduitT () [PackageName] IO (Either StoreFault [PackageName])
forall (m :: * -> *) a.
Monad m =>
m a -> ConduitT () [PackageName] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ProtocolRead -> IO (Either StoreFault [PackageName])
listPackages ProtocolRead
store) ConduitT () [PackageName] IO (Either StoreFault [PackageName])
-> (Either StoreFault [PackageName]
    -> ConduitT () [PackageName] IO (Maybe StoreFault))
-> ConduitT () [PackageName] IO (Maybe StoreFault)
forall a b.
ConduitT () [PackageName] IO a
-> (a -> ConduitT () [PackageName] IO b)
-> ConduitT () [PackageName] IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left StoreFault
fault -> Maybe StoreFault -> ConduitT () [PackageName] IO (Maybe StoreFault)
forall a. a -> ConduitT () [PackageName] IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StoreFault -> Maybe StoreFault
forall a. a -> Maybe a
Just StoreFault
fault)
        Right [PackageName]
names -> Maybe StoreFault
forall a. Maybe a
Nothing Maybe StoreFault
-> ConduitT () [PackageName] IO ()
-> ConduitT () [PackageName] IO (Maybe StoreFault)
forall a b.
a
-> ConduitT () [PackageName] IO b -> ConduitT () [PackageName] IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ [PackageName] -> ConduitT () [PackageName] IO ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield ((PackageName -> Bool) -> [PackageName] -> [PackageName]
forall a. (a -> Bool) -> [a] -> [a]
filter (NamePrefix -> PackageName -> Bool
inBucket NamePrefix
prefix) [PackageName]
names)

listPackages :: ProtocolRead -> IO (Either StoreFault [PackageName])
listPackages :: ProtocolRead -> IO (Either StoreFault [PackageName])
listPackages ProtocolRead
store =
    (UrlFormationError -> StoreFault)
-> (Request
    -> IO
         (Either StoreFault (BodyOutcome (StreamResult [PackageName]))))
-> Either UrlFormationError Request
-> IO
     (Either StoreFault (BodyOutcome (StreamResult [PackageName])))
forall fault a.
(UrlFormationError -> fault)
-> (Request -> IO (Either fault a))
-> Either UrlFormationError Request
-> IO (Either fault a)
formThen UrlFormationError -> StoreFault
unformableFault Request
-> IO
     (Either StoreFault (BodyOutcome (StreamResult [PackageName])))
fetch (StoreListing -> OriginClient -> Either UrlFormationError Request
listingRequest (ProtocolRead -> StoreListing
prListing ProtocolRead
store) OriginClient
origin) IO (Either StoreFault (BodyOutcome (StreamResult [PackageName])))
-> (Either StoreFault (BodyOutcome (StreamResult [PackageName]))
    -> Either StoreFault [PackageName])
-> IO (Either StoreFault [PackageName])
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
        Left StoreFault
fault -> StoreFault -> Either StoreFault [PackageName]
forall a b. a -> Either a b
Left StoreFault
fault
        Right (SuccessBody Int
200 StreamResult [PackageName]
streamed) -> (ParseError -> StoreFault)
-> Either ParseError [PackageName]
-> Either StoreFault [PackageName]
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 (Text -> ParseError -> StoreFault
parseFault Text
"package listing") (StreamResult [PackageName] -> Either ParseError [PackageName]
forall a. StreamResult a -> Either ParseError a
streamValue StreamResult [PackageName]
streamed)
        Right (SuccessBody Int
status StreamResult [PackageName]
_) -> StoreFault -> Either StoreFault [PackageName]
forall a b. a -> Either a b
Left (Int -> StoreFault
listingUnavailable Int
status)
        Right (UnreadStatus Int
status) -> StoreFault -> Either StoreFault [PackageName]
forall a b. a -> Either a b
Left (Int -> StoreFault
listingUnavailable Int
status)
  where
    origin :: OriginClient
origin = ProtocolRead -> OriginClient
prOrigin ProtocolRead
store
    fetch :: Request
-> IO
     (Either StoreFault (BodyOutcome (StreamResult [PackageName])))
fetch Request
request =
        (FetchFault -> StoreFault)
-> Either FetchFault (BodyOutcome (StreamResult [PackageName]))
-> Either StoreFault (BodyOutcome (StreamResult [PackageName]))
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 FetchFault -> StoreFault
storeFaultOfFetch
            (Either FetchFault (BodyOutcome (StreamResult [PackageName]))
 -> Either StoreFault (BodyOutcome (StreamResult [PackageName])))
-> IO
     (Either FetchFault (BodyOutcome (StreamResult [PackageName])))
-> IO
     (Either StoreFault (BodyOutcome (StreamResult [PackageName])))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Manager
-> ProgressFloor
-> BodyLimit
-> Parser [PackageName]
-> ([PackageName]
    -> [PackageName] -> Either LimitError [PackageName])
-> [PackageName]
-> Request
-> IO
     (Either FetchFault (BodyOutcome (StreamResult [PackageName])))
forall a s.
Manager
-> ProgressFloor
-> BodyLimit
-> Parser a
-> (s -> a -> Either LimitError s)
-> s
-> Request
-> IO (Either FetchFault (BodyOutcome (StreamResult s)))
boundedJsonFetch
                (OriginClient -> Manager
ocManager OriginClient
origin)
                (Limits -> ProgressFloor
progressFloor (OriginClient -> Limits
ocLimits OriginClient
origin))
                (Int -> BodyLimit
MetadataBodyLimit (Limits -> Int
maxMetadataBytes (OriginClient -> Limits
ocLimits OriginClient
origin)))
                (StoreListing -> Parser [PackageName]
listingParser (ProtocolRead -> StoreListing
prListing ProtocolRead
store))
                (\[PackageName]
_ [PackageName]
names -> [PackageName] -> Either LimitError [PackageName]
forall a b. b -> Either a b
Right [PackageName]
names)
                []
                Request
request

listingUnavailable :: Int -> StoreFault
listingUnavailable :: Int -> StoreFault
listingUnavailable Int
status =
    (Int -> Bool) -> Int -> Text -> StoreFault
statusFault
        Int -> Bool
isRetryableStatusCode
        Int
status
        ( Text
"the store answered the package listing 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
status
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> if Int
status Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
404 then Text
": it serves no enumeration this sweep can walk" else Text
""
        )

{- The presence probe's read, which already projects a store's version list for the mirror
worker. A store that holds no document for a package holds no versions of it either. -}
listVersions :: ProtocolRead -> PackageName -> IO (Either StoreFault [StoredVersion])
listVersions :: ProtocolRead
-> PackageName -> IO (Either StoreFault [StoredVersion])
listVersions ProtocolRead
store PackageName
name =
    (UrlFormationError -> StoreFault)
-> (Request
    -> IO
         (Either StoreFault (BodyOutcome (Either ParseError [Version]))))
-> Either UrlFormationError Request
-> IO
     (Either StoreFault (BodyOutcome (Either ParseError [Version])))
forall fault a.
(UrlFormationError -> fault)
-> (Request -> IO (Either fault a))
-> Either UrlFormationError Request
-> IO (Either fault a)
formThen UrlFormationError -> StoreFault
unformableFault Request
-> IO
     (Either StoreFault (BodyOutcome (Either ParseError [Version])))
fetch (PublishCodec
-> Text
-> Maybe Secret
-> PackageName
-> Either UrlFormationError Request
pcProbeRequest PublishCodec
codec (ProtocolRead -> Text
originBase ProtocolRead
store) (ProtocolRead -> Maybe Secret
originToken ProtocolRead
store) PackageName
name) IO (Either StoreFault (BodyOutcome (Either ParseError [Version])))
-> (Either StoreFault (BodyOutcome (Either ParseError [Version]))
    -> Either StoreFault [StoredVersion])
-> IO (Either StoreFault [StoredVersion])
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
        Left StoreFault
fault -> StoreFault -> Either StoreFault [StoredVersion]
forall a b. a -> Either a b
Left StoreFault
fault
        Right (SuccessBody Int
_ Either ParseError [Version]
listed) -> (ParseError -> StoreFault)
-> Either ParseError [StoredVersion]
-> Either StoreFault [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 (Text -> ParseError -> StoreFault
parseFault Text
"version list") ((Version -> StoredVersion) -> [Version] -> [StoredVersion]
forall a b. (a -> b) -> [a] -> [b]
map Version -> StoredVersion
stored ([Version] -> [StoredVersion])
-> Either ParseError [Version] -> Either ParseError [StoredVersion]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either ParseError [Version]
listed)
        Right (UnreadStatus Int
404) -> [StoredVersion] -> Either StoreFault [StoredVersion]
forall a b. b -> Either a b
Right []
        Right (UnreadStatus Int
status) -> StoreFault -> Either StoreFault [StoredVersion]
forall a b. a -> Either a b
Left (Text -> Int -> StoreFault
readFault Text
"version list" Int
status)
  where
    origin :: OriginClient
origin = ProtocolRead -> OriginClient
prOrigin ProtocolRead
store
    codec :: PublishCodec
codec = ProtocolRead -> PublishCodec
prCodec ProtocolRead
store
    fetch :: Request
-> IO
     (Either StoreFault (BodyOutcome (Either ParseError [Version])))
fetch Request
request = (FetchFault -> StoreFault)
-> Either FetchFault (BodyOutcome (Either ParseError [Version]))
-> Either StoreFault (BodyOutcome (Either ParseError [Version]))
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 FetchFault -> StoreFault
storeFaultOfFetch (Either FetchFault (BodyOutcome (Either ParseError [Version]))
 -> Either StoreFault (BodyOutcome (Either ParseError [Version])))
-> IO
     (Either FetchFault (BodyOutcome (Either ParseError [Version])))
-> IO
     (Either StoreFault (BodyOutcome (Either ParseError [Version])))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Manager
-> Limits
-> Parser VersionListItem
-> Request
-> IO
     (Either FetchFault (BodyOutcome (Either ParseError [Version])))
fetchVersionList (OriginClient -> Manager
ocManager OriginClient
origin) (OriginClient -> Limits
ocLimits OriginClient
origin) (PublishCodec -> Limits -> Parser VersionListItem
pcVersionListParser PublishCodec
codec (OriginClient -> Limits
ocLimits OriginClient
origin)) Request
request
    stored :: Version -> StoredVersion
stored Version
version = StoredVersion{storedVersion :: Version
storedVersion = Version
version, storedPresence :: VersionPresence
storedPresence = VersionPresence
VersionServed, storedRevision :: Maybe Text
storedRevision = Maybe Text
forall a. Maybe a
Nothing}

deleteStoredVersions :: ProtocolStore -> DeleteGuard -> PackageName -> [Version] -> IO [(Version, VersionOutcome)]
deleteStoredVersions :: ProtocolStore
-> DeleteGuard
-> PackageName
-> [Version]
-> IO [(Version, VersionOutcome)]
deleteStoredVersions ProtocolStore
store DeleteGuard
checks PackageName
name [Version]
versions =
    DeleteGuard
-> ([Version]
    -> IO (Either StoreFault [(Version, VersionOutcome)]))
-> [[Version]]
-> IO [(Version, VersionOutcome)]
deleteAll DeleteGuard
checks (ProtocolStore
-> PackageName
-> [Version]
-> IO (Either StoreFault [(Version, VersionOutcome)])
deleteChunk ProtocolStore
store PackageName
name) (DeleteCeiling -> [Version] -> [[Version]]
forall a. DeleteCeiling -> [a] -> [[a]]
chunksOfCeiling DeleteCeiling
deleteCeiling [Version]
versions)

{- One version at a time: re-read the document, form the protocol's request sequence over it,
and send each in turn. A refusal is this version's alone, and a fault ends the whole run. -}
deleteChunk :: ProtocolStore -> PackageName -> [Version] -> IO (Either StoreFault [(Version, VersionOutcome)])
deleteChunk :: ProtocolStore
-> PackageName
-> [Version]
-> IO (Either StoreFault [(Version, VersionOutcome)])
deleteChunk ProtocolStore
store PackageName
name = \case
    [Version
version] ->
        ProtocolRead
-> Either UrlFormationError Request
-> IO (Either StoreFault (Int, ByteString))
sendFormed (ProtocolStore -> ProtocolRead
psRead ProtocolStore
store) (VersionDelete
-> OriginClient -> PackageName -> Either UrlFormationError Request
deleteDocumentRequest (ProtocolStore -> VersionDelete
psDelete ProtocolStore
store) (ProtocolRead -> OriginClient
prOrigin (ProtocolStore -> ProtocolRead
psRead ProtocolStore
store)) PackageName
name) IO (Either StoreFault (Int, ByteString))
-> (Either StoreFault (Int, ByteString)
    -> IO (Either StoreFault [(Version, VersionOutcome)]))
-> IO (Either StoreFault [(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 -> Either StoreFault [(Version, VersionOutcome)]
-> IO (Either StoreFault [(Version, VersionOutcome)])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StoreFault -> Either StoreFault [(Version, VersionOutcome)]
forall a b. a -> Either a b
Left StoreFault
fault)
            Right (Int
status, ByteString
body)
                | Int
status Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
404 -> Either StoreFault [(Version, VersionOutcome)]
-> IO (Either StoreFault [(Version, VersionOutcome)])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Version
-> StoreRefusal -> Either StoreFault [(Version, VersionOutcome)]
refused Version
version StoreRefusal
absentDocument)
                | Bool -> Bool
not (Int -> Bool
isSuccessStatus Int
status) -> Either StoreFault [(Version, VersionOutcome)]
-> IO (Either StoreFault [(Version, VersionOutcome)])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StoreFault -> Either StoreFault [(Version, VersionOutcome)]
forall a b. a -> Either a b
Left (Text -> Int -> StoreFault
readFault Text
"document" Int
status))
                | Bool
otherwise -> ProtocolStore
-> PackageName
-> Version
-> Int
-> ByteString
-> IO (Either StoreFault [(Version, VersionOutcome)])
applyDelete ProtocolStore
store PackageName
name Version
version Int
status ByteString
body
    -- 'deleteCeiling' splits to one, so a wider chunk refuses whole rather than losing its tail.
    [Version]
chunk -> Either StoreFault [(Version, VersionOutcome)]
-> IO (Either StoreFault [(Version, VersionOutcome)])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Version, VersionOutcome)]
-> Either StoreFault [(Version, VersionOutcome)]
forall a b. b -> Either a b
Right [(Version
version, StoreRefusal -> VersionOutcome
VersionRefused StoreRefusal
oversizedChunk) | Version
version <- [Version]
chunk])
  where
    absentDocument :: StoreRefusal
absentDocument = Text -> Text -> StoreRefusal
storeRefusal Text
"NOT_FOUND" Text
"the store holds no document for this package"
    oversizedChunk :: StoreRefusal
oversizedChunk = Text -> Text -> StoreRefusal
storeRefusal Text
"CEILING_EXCEEDED" Text
"this protocol deletes one version per call"

applyDelete :: ProtocolStore -> PackageName -> Version -> Int -> ByteString -> IO (Either StoreFault [(Version, VersionOutcome)])
applyDelete :: ProtocolStore
-> PackageName
-> Version
-> Int
-> ByteString
-> IO (Either StoreFault [(Version, VersionOutcome)])
applyDelete ProtocolStore
store PackageName
name Version
version Int
status ByteString
body =
    case VersionDelete
-> OriginClient
-> PackageName
-> Version
-> RegistryResponse
-> Either StoreRefusal (NonEmpty Request)
deleteRequests (ProtocolStore -> VersionDelete
psDelete ProtocolStore
store) (ProtocolRead -> OriginClient
prOrigin (ProtocolStore -> ProtocolRead
psRead ProtocolStore
store)) PackageName
name Version
version (Int -> Int -> ByteString -> RegistryResponse
RegistryResponse Int
status (ByteString -> Int
BS.length ByteString
body) ByteString
body) of
        Left StoreRefusal
refusal -> Either StoreFault [(Version, VersionOutcome)]
-> IO (Either StoreFault [(Version, VersionOutcome)])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Version
-> StoreRefusal -> Either StoreFault [(Version, VersionOutcome)]
refused Version
version StoreRefusal
refusal)
        Right NonEmpty Request
requests ->
            ProtocolRead
-> [Request] -> IO (Either StoreFault (Maybe StoreRefusal))
sendSequence (ProtocolStore -> ProtocolRead
psRead ProtocolStore
store){prOrigin = psDeleteOrigin store} (NonEmpty Request -> [Request]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty Request
requests) IO (Either StoreFault (Maybe StoreRefusal))
-> (Either StoreFault (Maybe StoreRefusal)
    -> Either StoreFault [(Version, VersionOutcome)])
-> IO (Either StoreFault [(Version, VersionOutcome)])
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Maybe StoreRefusal -> [(Version, VersionOutcome)])
-> Either StoreFault (Maybe StoreRefusal)
-> Either StoreFault [(Version, VersionOutcome)]
forall a b. (a -> b) -> Either StoreFault a -> Either StoreFault b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe StoreRefusal -> [(Version, VersionOutcome)]
outcomeOf
  where
    outcomeOf :: Maybe StoreRefusal -> [(Version, VersionOutcome)]
outcomeOf = \case
        Maybe StoreRefusal
Nothing -> [(Version
version, VersionOutcome
VersionRemoved)]
        Just StoreRefusal
refusal -> [(Version
version, StoreRefusal -> VersionOutcome
VersionRefused StoreRefusal
refusal)]

{- Send each request in order, stopping at the first refusal. That can leave the version
half-removed, so the code an operator looks up names which call stopped. -}
sendSequence :: ProtocolRead -> [Request] -> IO (Either StoreFault (Maybe StoreRefusal))
sendSequence :: ProtocolRead
-> [Request] -> IO (Either StoreFault (Maybe StoreRefusal))
sendSequence ProtocolRead
store = Int -> [Request] -> IO (Either StoreFault (Maybe StoreRefusal))
forall {a}.
(Num a, Show a) =>
a -> [Request] -> IO (Either StoreFault (Maybe StoreRefusal))
go (Int
1 :: Int)
  where
    go :: a -> [Request] -> IO (Either StoreFault (Maybe StoreRefusal))
go a
_ [] = Either StoreFault (Maybe StoreRefusal)
-> IO (Either StoreFault (Maybe StoreRefusal))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe StoreRefusal -> Either StoreFault (Maybe StoreRefusal)
forall a b. b -> Either a b
Right Maybe StoreRefusal
forall a. Maybe a
Nothing)
    go a
position (Request
request : [Request]
rest) =
        ProtocolRead -> Request -> IO (Either StoreFault (Int, ByteString))
send ProtocolRead
store Request
request IO (Either StoreFault (Int, ByteString))
-> (Either StoreFault (Int, ByteString)
    -> IO (Either StoreFault (Maybe StoreRefusal)))
-> IO (Either StoreFault (Maybe StoreRefusal))
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 -> Either StoreFault (Maybe StoreRefusal)
-> IO (Either StoreFault (Maybe StoreRefusal))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StoreFault -> Either StoreFault (Maybe StoreRefusal)
forall a b. a -> Either a b
Left StoreFault
fault)
            Right (Int
status, ByteString
_)
                | Int -> Bool
isSuccessStatus Int
status -> a -> [Request] -> IO (Either StoreFault (Maybe StoreRefusal))
go (a
position a -> a -> a
forall a. Num a => a -> a -> a
+ a
1) [Request]
rest
                | Bool
otherwise -> Either StoreFault (Maybe StoreRefusal)
-> IO (Either StoreFault (Maybe StoreRefusal))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe StoreRefusal -> Either StoreFault (Maybe StoreRefusal)
forall a b. b -> Either a b
Right (StoreRefusal -> Maybe StoreRefusal
forall a. a -> Maybe a
Just (a -> Int -> StoreRefusal
forall {a} {a}. (Show a, Show a) => a -> a -> StoreRefusal
refusedAt a
position Int
status)))

    refusedAt :: a -> a -> StoreRefusal
refusedAt a
position a
status =
        Text -> Text -> StoreRefusal
storeRefusal
            (Text
"HTTP " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall b a. (Show a, IsString b) => a -> b
show a
status)
            (Text
"the store refused request " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall b a. (Show a, IsString b) => a -> b
show a
position Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" of the delete sequence")

refused :: Version -> StoreRefusal -> Either StoreFault [(Version, VersionOutcome)]
refused :: Version
-> StoreRefusal -> Either StoreFault [(Version, VersionOutcome)]
refused Version
version StoreRefusal
refusal = [(Version, VersionOutcome)]
-> Either StoreFault [(Version, VersionOutcome)]
forall a b. b -> Either a b
Right [(Version
version, StoreRefusal -> VersionOutcome
VersionRefused StoreRefusal
refusal)]

send :: ProtocolRead -> Request -> IO (Either StoreFault (Int, ByteString))
send :: ProtocolRead -> Request -> IO (Either StoreFault (Int, ByteString))
send ProtocolRead
store Request
request =
    (FetchFault -> StoreFault)
-> Either FetchFault (Int, ByteString)
-> Either StoreFault (Int, ByteString)
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 FetchFault -> StoreFault
storeFaultOfFetch
        (Either FetchFault (Int, ByteString)
 -> Either StoreFault (Int, ByteString))
-> IO (Either FetchFault (Int, ByteString))
-> IO (Either StoreFault (Int, ByteString))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Int -> ByteString -> (Int, ByteString))
-> Manager
-> ProgressFloor
-> BodyLimit
-> Request
-> IO (Either FetchFault (Int, ByteString))
forall a.
(Int -> Int -> ByteString -> a)
-> Manager
-> ProgressFloor
-> BodyLimit
-> Request
-> IO (Either FetchFault a)
boundedExchange (\Int
status Int
_ ByteString
body -> (Int
status, ByteString
body)) (OriginClient -> Manager
ocManager OriginClient
origin) (Limits -> ProgressFloor
progressFloor (OriginClient -> Limits
ocLimits OriginClient
origin)) (Int -> BodyLimit
MetadataBodyLimit (Limits -> Int
maxMetadataBytes (OriginClient -> Limits
ocLimits OriginClient
origin))) Request
request
  where
    origin :: OriginClient
origin = ProtocolRead -> OriginClient
prOrigin ProtocolRead
store

sendFormed :: ProtocolRead -> Either UrlFormationError Request -> IO (Either StoreFault (Int, ByteString))
sendFormed :: ProtocolRead
-> Either UrlFormationError Request
-> IO (Either StoreFault (Int, ByteString))
sendFormed ProtocolRead
store = (UrlFormationError -> StoreFault)
-> (Request -> IO (Either StoreFault (Int, ByteString)))
-> Either UrlFormationError Request
-> IO (Either StoreFault (Int, ByteString))
forall fault a.
(UrlFormationError -> fault)
-> (Request -> IO (Either fault a))
-> Either UrlFormationError Request
-> IO (Either fault a)
formThen UrlFormationError -> StoreFault
unformableFault (ProtocolRead -> Request -> IO (Either StoreFault (Int, ByteString))
send ProtocolRead
store)

originBase :: ProtocolRead -> Text
originBase :: ProtocolRead -> Text
originBase = OriginClient -> Text
originBaseUrl (OriginClient -> Text)
-> (ProtocolRead -> OriginClient) -> ProtocolRead -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProtocolRead -> OriginClient
prOrigin

originToken :: ProtocolRead -> Maybe Secret
originToken :: ProtocolRead -> Maybe Secret
originToken = (ClientCredential -> Secret)
-> Maybe ClientCredential -> Maybe Secret
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ClientCredential -> Secret
credSecret (Maybe ClientCredential -> Maybe Secret)
-> (ProtocolRead -> Maybe ClientCredential)
-> ProtocolRead
-> Maybe Secret
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OriginClient -> Maybe ClientCredential
ocToken (OriginClient -> Maybe ClientCredential)
-> (ProtocolRead -> OriginClient)
-> ProtocolRead
-> Maybe ClientCredential
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProtocolRead -> OriginClient
prOrigin

parseFault :: Text -> ParseError -> StoreFault
parseFault :: Text -> ParseError -> StoreFault
parseFault Text
subject ParseError
err =
    Text -> StoreFault
protocolFault (Text
"the store's " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
subject Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" did not parse: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ParseError -> Text
parseErrorMessage ParseError
err)

-- Version and document reads retain their server-error-only retry policy.
readFault :: Text -> Int -> StoreFault
readFault :: Text -> Int -> StoreFault
readFault Text
subject Int
status =
    (Int -> Bool) -> Int -> Text -> StoreFault
statusFault (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
500) Int
status (Text
"the store answered the " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
subject Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" 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
status)