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

{- | The mirror-write capability: a shared transport, an adapter-provided protocol codec, and the
married 'MirrorPublish' handle a worker bundle carries. A new ecosystem contributes a codec and
never a transport.

The transport mints the bearer per call and re-seals every request, so no codec can ship a write
that follows a redirect.
-}
module Ecluse.Core.Registry.Publish (
    -- * What one write declares
    PublishPlan (..),

    -- * The adapter's protocol codec
    PublishCodec (..),
    fetchVersionList,

    -- * The shared transport
    MirrorTransport (..),

    -- * The married capability
    MirrorPublish (..),
    newMirrorPublish,
) where

import Data.JsonStream.Parser qualified as J

import Network.HTTP.Client (Manager, Request)

import Ecluse.Core.Credential (Secret)
import Ecluse.Core.Package (PackageName)
import Ecluse.Core.Registry (
    BodyOutcome,
    FetchFault (FetchUrlUnformable),
    MirrorArtifact,
    ParseError,
    PublishFault (PublishFetch),
    UrlFormationError,
 )
import Ecluse.Core.Registry.CachedDocument (CachedDoc)
import Ecluse.Core.Registry.Exchange (boundedExchange, boundedJsonFetch, formThen)
import Ecluse.Core.Registry.JsonStream (StreamResult (streamValue))
import Ecluse.Core.Registry.Request (sealRequest)
import Ecluse.Core.Registry.VersionList (VersionListItem, collectVersionList, emptyVersionList, finishVersionList)
import Ecluse.Core.Security (BodyLimit (MetadataBodyLimit), Limits (progressFloor), maxMetadataBytes)
import Ecluse.Core.Security.Egress (RegistryUrl, registryUrlText)
import Ecluse.Core.Version (Version)

{- | What one mirror write declares: the version, the release tag the store must carry once it
lands, and the version's own metadata. The caller decides the tag, so no codec derives one.
-}
data PublishPlan = PublishPlan
    { PublishPlan -> Version
ppVersion :: Version
    -- ^ The version these bytes publish.
    , PublishPlan -> Version
ppLatest :: Version
    -- ^ Always a version the store holds after this write, the published one when it is alone.
    , PublishPlan -> CachedDoc
ppMetadata :: CachedDoc
    -- ^ Supported source fields paired with the release admitted for mirroring.
    }
    deriving stock (PublishPlan -> PublishPlan -> Bool
(PublishPlan -> PublishPlan -> Bool)
-> (PublishPlan -> PublishPlan -> Bool) -> Eq PublishPlan
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PublishPlan -> PublishPlan -> Bool
== :: PublishPlan -> PublishPlan -> Bool
$c/= :: PublishPlan -> PublishPlan -> Bool
/= :: PublishPlan -> PublishPlan -> Bool
Eq, Int -> PublishPlan -> ShowS
[PublishPlan] -> ShowS
PublishPlan -> String
(Int -> PublishPlan -> ShowS)
-> (PublishPlan -> String)
-> ([PublishPlan] -> ShowS)
-> Show PublishPlan
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PublishPlan -> ShowS
showsPrec :: Int -> PublishPlan -> ShowS
$cshow :: PublishPlan -> String
show :: PublishPlan -> String
$cshowList :: [PublishPlan] -> ShowS
showList :: [PublishPlan] -> ShowS
Show)

{- | One ecosystem's mirror-write protocol, all pure. The endpoint and bearer arrive as arguments,
so a codec holds no URL, credential, or connection state.
-}
data PublishCodec = PublishCodec
    { PublishCodec
-> Text
-> Maybe Secret
-> PackageName
-> Either UrlFormationError Request
pcProbeRequest :: Text -> Maybe Secret -> PackageName -> Either UrlFormationError Request
    -- ^ Form the metadata read the presence probe makes against the mirror target.
    , PublishCodec -> Limits -> Parser VersionListItem
pcVersionListParser :: Limits -> J.Parser VersionListItem
    -- ^ Select usable version identifiers without retaining source release objects.
    , PublishCodec
-> Text
-> Maybe Secret
-> PackageName
-> PublishPlan
-> MirrorArtifact
-> ByteString
-> Either PublishFault Request
pcPublishRequest :: Text -> Maybe Secret -> PackageName -> PublishPlan -> MirrorArtifact -> ByteString -> Either PublishFault Request
    {- ^ Form the complete publish request for one verified artifact. A plan whose version object
    the codec cannot read refuses as a value.
    -}
    , PublishCodec -> Int -> Either PublishFault ()
pcPublishOutcome :: Int -> Either PublishFault ()
    {- ^ Classify the status answer. Registries disagree on how an immutable re-publish answers,
    so the codec counts an idempotent already-present as success.
    -}
    }

{- | The ecosystem-agnostic half of the mirror write. The composition root builds one per
marriage from process-wide parts.
-}
data MirrorTransport = MirrorTransport
    { MirrorTransport -> Manager
ptManager :: Manager
    -- ^ The trusted-path connection manager the worker dials the mirror target through.
    , MirrorTransport -> IO (Maybe Secret)
ptMintToken :: IO (Maybe Secret)
    -- ^ Nothing caches it here: refresh, expiry, and breaker policy live behind the action.
    , MirrorTransport -> Limits
ptLimits :: Limits
    -- ^ The response bound every exchange with the mirror target is held to (fail-closed).
    }

{- | What one worker bundle carries, bound to one mirror-target endpoint under one credential
mint. The worker never sees the codec, the transport, or the adapter.
-}
data MirrorPublish = MirrorPublish
    { MirrorPublish
-> PackageName
-> IO
     (Either FetchFault (BodyOutcome (Either ParseError [Version])))
mpProbeMetadata :: PackageName -> IO (Either FetchFault (BodyOutcome (Either ParseError [Version])))
    -- ^ Every failure is a 'FetchFault' value, so the probe's fall-through match is total.
    , MirrorPublish
-> PackageName
-> PublishPlan
-> MirrorArtifact
-> ByteString
-> IO (Either PublishFault ())
mpPublishArtifact :: PackageName -> PublishPlan -> MirrorArtifact -> ByteString -> IO (Either PublishFault ())
    {- ^ Every failure is a 'PublishFault' value, so the worker's retry-vs-drop decision is
    total at the call site.
    -}
    }

-- | Marry a protocol codec to the shared transport against one mirror-target endpoint.
newMirrorPublish :: MirrorTransport -> RegistryUrl -> PublishCodec -> MirrorPublish
newMirrorPublish :: MirrorTransport -> RegistryUrl -> PublishCodec -> MirrorPublish
newMirrorPublish MirrorTransport
transport RegistryUrl
target PublishCodec
codec =
    MirrorPublish
        { mpProbeMetadata :: PackageName
-> IO
     (Either FetchFault (BodyOutcome (Either ParseError [Version])))
mpProbeMetadata = MirrorTransport
-> Text
-> PublishCodec
-> PackageName
-> IO
     (Either FetchFault (BodyOutcome (Either ParseError [Version])))
probeMetadata MirrorTransport
transport Text
targetUrl PublishCodec
codec
        , mpPublishArtifact :: PackageName
-> PublishPlan
-> MirrorArtifact
-> ByteString
-> IO (Either PublishFault ())
mpPublishArtifact = MirrorTransport
-> Text
-> PublishCodec
-> PackageName
-> PublishPlan
-> MirrorArtifact
-> ByteString
-> IO (Either PublishFault ())
publishArtifact MirrorTransport
transport Text
targetUrl PublishCodec
codec
        }
  where
    -- The codec forms URLs from characters, so the egress witness is read once here
    -- rather than at every formation.
    targetUrl :: Text
targetUrl = RegistryUrl -> Text
registryUrlText RegistryUrl
target

-- Execute the codec's probe read over the transport: mint, form, seal, dial, and read the
-- body bounded, with every failure folded into the typed 'FetchFault' channel.
probeMetadata :: MirrorTransport -> Text -> PublishCodec -> PackageName -> IO (Either FetchFault (BodyOutcome (Either ParseError [Version])))
probeMetadata :: MirrorTransport
-> Text
-> PublishCodec
-> PackageName
-> IO
     (Either FetchFault (BodyOutcome (Either ParseError [Version])))
probeMetadata MirrorTransport
transport Text
targetUrl PublishCodec
codec PackageName
name = do
    token <- MirrorTransport -> IO (Maybe Secret)
ptMintToken MirrorTransport
transport
    formThen
        FetchUrlUnformable
        (fetchVersionList (ptManager transport) (ptLimits transport) (pcVersionListParser codec (ptLimits transport)))
        (sealRequest <$> pcProbeRequest codec targetUrl token name)

-- | Read a codec's identifiers inside the response lifetime, preserving transport and HTTP outcomes.
fetchVersionList :: Manager -> Limits -> J.Parser VersionListItem -> Request -> IO (Either FetchFault (BodyOutcome (Either ParseError [Version])))
fetchVersionList :: Manager
-> Limits
-> Parser VersionListItem
-> Request
-> IO
     (Either FetchFault (BodyOutcome (Either ParseError [Version])))
fetchVersionList Manager
manager Limits
limits Parser VersionListItem
parser Request
request =
    (BodyOutcome (StreamResult VersionListState)
 -> BodyOutcome (Either ParseError [Version]))
-> Either FetchFault (BodyOutcome (StreamResult VersionListState))
-> Either FetchFault (BodyOutcome (Either ParseError [Version]))
forall a b. (a -> b) -> Either FetchFault a -> Either FetchFault b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((StreamResult VersionListState -> Either ParseError [Version])
-> BodyOutcome (StreamResult VersionListState)
-> BodyOutcome (Either ParseError [Version])
forall a b. (a -> b) -> BodyOutcome a -> BodyOutcome b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap StreamResult VersionListState -> Either ParseError [Version]
versions) (Either FetchFault (BodyOutcome (StreamResult VersionListState))
 -> Either FetchFault (BodyOutcome (Either ParseError [Version])))
-> IO
     (Either FetchFault (BodyOutcome (StreamResult VersionListState)))
-> IO
     (Either FetchFault (BodyOutcome (Either ParseError [Version])))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Manager
-> ProgressFloor
-> BodyLimit
-> Parser VersionListItem
-> (VersionListState
    -> VersionListItem -> Either LimitError VersionListState)
-> VersionListState
-> Request
-> IO
     (Either FetchFault (BodyOutcome (StreamResult VersionListState)))
forall a s.
Manager
-> ProgressFloor
-> BodyLimit
-> Parser a
-> (s -> a -> Either LimitError s)
-> s
-> Request
-> IO (Either FetchFault (BodyOutcome (StreamResult s)))
boundedJsonFetch Manager
manager (Limits -> ProgressFloor
progressFloor Limits
limits) (Int -> BodyLimit
MetadataBodyLimit (Limits -> Int
maxMetadataBytes Limits
limits)) Parser VersionListItem
parser (Limits
-> VersionListState
-> VersionListItem
-> Either LimitError VersionListState
collectVersionList Limits
limits) VersionListState
emptyVersionList Request
request
  where
    versions :: StreamResult VersionListState -> Either ParseError [Version]
versions StreamResult VersionListState
streamed = StreamResult VersionListState -> Either ParseError VersionListState
forall a. StreamResult a -> Either ParseError a
streamValue StreamResult VersionListState
streamed Either ParseError VersionListState
-> (VersionListState -> Either ParseError [Version])
-> Either ParseError [Version]
forall a b.
Either ParseError a
-> (a -> Either ParseError b) -> Either ParseError b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= VersionListState -> Either ParseError [Version]
finishVersionList

publishArtifact :: MirrorTransport -> Text -> PublishCodec -> PackageName -> PublishPlan -> MirrorArtifact -> ByteString -> IO (Either PublishFault ())
publishArtifact :: MirrorTransport
-> Text
-> PublishCodec
-> PackageName
-> PublishPlan
-> MirrorArtifact
-> ByteString
-> IO (Either PublishFault ())
publishArtifact MirrorTransport
transport Text
targetUrl PublishCodec
codec PackageName
name PublishPlan
plan MirrorArtifact
artifact ByteString
bytes = do
    token <- MirrorTransport -> IO (Maybe Secret)
ptMintToken MirrorTransport
transport
    either
        (pure . Left)
        (writeArtifact transport codec . sealRequest)
        (pcPublishRequest codec targetUrl token name plan artifact bytes)

-- Read the codec's verdict from the answered status. The 'const' projection drops the
-- target's body, which the write has no use for, and the exchange bounds it either way.
writeArtifact :: MirrorTransport -> PublishCodec -> Request -> IO (Either PublishFault ())
writeArtifact :: MirrorTransport
-> PublishCodec -> Request -> IO (Either PublishFault ())
writeArtifact MirrorTransport
transport PublishCodec
codec Request
request =
    (Int -> Int -> ByteString -> Int)
-> Manager
-> ProgressFloor
-> BodyLimit
-> Request
-> IO (Either FetchFault Int)
forall a.
(Int -> Int -> ByteString -> a)
-> Manager
-> ProgressFloor
-> BodyLimit
-> Request
-> IO (Either FetchFault a)
boundedExchange (\Int
status Int
_ ByteString
_ -> Int
status) (MirrorTransport -> Manager
ptManager MirrorTransport
transport) (Limits -> ProgressFloor
progressFloor (MirrorTransport -> Limits
ptLimits MirrorTransport
transport)) (Int -> BodyLimit
MetadataBodyLimit (Limits -> Int
maxMetadataBytes (MirrorTransport -> Limits
ptLimits MirrorTransport
transport))) Request
request
        IO (Either FetchFault Int)
-> (Either FetchFault Int -> Either PublishFault ())
-> IO (Either PublishFault ())
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
            Left FetchFault
fault -> PublishFault -> Either PublishFault ()
forall a b. a -> Either a b
Left (FetchFault -> PublishFault
PublishFetch FetchFault
fault)
            Right Int
status -> PublishCodec -> Int -> Either PublishFault ()
pcPublishOutcome PublishCodec
codec Int
status