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

{- | The shared bounded registry exchanges: run one formed 'Request' and read its
response under a response-bound budget, every failure folded into the typed channel
at this edge. Two shapes live here, one per whole-buffered response the proxy reads:
'boundedFetch' returns the body as a 'RegistryResponse'; 'boundedRelay' pairs the
bounded body with the status the target answered as a 'PublishRelayResponse'.

The npm read data plane ("Ecluse.Core.Registry.Npm") and the mirror-write transport
("Ecluse.Core.Registry.Publish") fetch through 'boundedFetch'; the first-party
publish relay ("Ecluse.Core.Registry.Npm") relays through 'boundedRelay'. Each
performs the identical fail-closed exchange: run the request, read the body
chunk-by-chunk against the budget, and report a bound breach or a transport fault as
a typed __value__ rather than an exception. Both live here once so a hardening change
to the response bound touches one implementation, not copies that can drift.

Ecosystem-agnostic: this forms no request and speaks no registry protocol, only the
bounded read of a 'Request' the caller has already shaped. Request formation, and its
own typed fault, stays with the caller.
-}
module Ecluse.Core.Registry.Exchange (
    -- * Bounded response fetch
    boundedFetch,

    -- * Bounded publish relay
    boundedRelay,
) where

import Data.ByteString.Lazy qualified as LBS
import Network.HTTP.Client (
    BodyReader,
    Manager,
    Request,
    Response (responseStatus),
    brRead,
    responseBody,
    withResponse,
 )
import Network.HTTP.Types.Status (statusCode)
import UnliftIO (try)

import Ecluse.Core.Fault.Http (classifyTransport)
import Ecluse.Core.Registry (
    FetchFault (FetchBoundExceeded, FetchTransport),
    PublishRelayFault (RelayBoundExceeded, RelayTransport),
    PublishRelayResponse (..),
    RegistryResponse (RegistryResponse),
 )
import Ecluse.Core.Security (LimitError, Limits, boundedRead)

{- | Run a formed 'Request' over the manager and read its response body bounded
against the budget, folding every failure into the typed 'FetchFault' channel: a
thrown transport exception through 'classifyTransport' as 'FetchTransport', an
over-cap body as 'FetchBoundExceeded'. The transport wrap covers the __whole__
exchange, the bounded body read included, so a connection lost mid-body is a
pre-commit fault with a value representation, never a half-read response.
-}
boundedFetch :: Manager -> Limits -> Request -> IO (Either FetchFault RegistryResponse)
boundedFetch :: Manager
-> Limits -> Request -> IO (Either FetchFault RegistryResponse)
boundedFetch Manager
manager Limits
limits Request
request =
    IO (Either LimitError RegistryResponse)
-> IO (Either HttpException (Either LimitError RegistryResponse))
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try (Request
-> Manager
-> (Response BodyReader -> IO (Either LimitError RegistryResponse))
-> IO (Either LimitError RegistryResponse)
forall a.
Request -> Manager -> (Response BodyReader -> IO a) -> IO a
withResponse Request
request Manager
manager (Limits -> BodyReader -> IO (Either LimitError RegistryResponse)
readBoundedBody Limits
limits (BodyReader -> IO (Either LimitError RegistryResponse))
-> (Response BodyReader -> BodyReader)
-> Response BodyReader
-> IO (Either LimitError RegistryResponse)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response BodyReader -> BodyReader
forall body. Response body -> body
responseBody))
        IO (Either HttpException (Either LimitError RegistryResponse))
-> (Either HttpException (Either LimitError RegistryResponse)
    -> Either FetchFault RegistryResponse)
-> IO (Either FetchFault RegistryResponse)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
            Left HttpException
httpErr -> FetchFault -> Either FetchFault RegistryResponse
forall a b. a -> Either a b
Left (TransportFault -> FetchFault
FetchTransport (HttpException -> TransportFault
classifyTransport HttpException
httpErr))
            Right (Left LimitError
limitErr) -> FetchFault -> Either FetchFault RegistryResponse
forall a b. a -> Either a b
Left (LimitError -> FetchFault
FetchBoundExceeded LimitError
limitErr)
            Right (Right RegistryResponse
response) -> RegistryResponse -> Either FetchFault RegistryResponse
forall a b. b -> Either a b
Right RegistryResponse
response

{- | Run a formed publish 'Request' over the manager and buffer the publication
target's response bounded against the budget, folding every failure into the typed
'PublishRelayFault' channel: a thrown transport exception through 'classifyTransport'
as 'RelayTransport', an over-cap body as 'RelayBoundExceeded'. The transport wrap
covers the __whole__ exchange, the bounded body read included, so a connection lost
mid-body is a pre-commit fault with a value representation, never a half-relayed
response. The status the target answered is carried back paired with the buffered
body.
-}
boundedRelay :: Manager -> Limits -> Request -> IO (Either PublishRelayFault PublishRelayResponse)
boundedRelay :: Manager
-> Limits
-> Request
-> IO (Either PublishRelayFault PublishRelayResponse)
boundedRelay Manager
manager Limits
limits Request
request =
    IO (Either PublishRelayFault PublishRelayResponse)
-> IO
     (Either
        HttpException (Either PublishRelayFault PublishRelayResponse))
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try (Request
-> Manager
-> (Response BodyReader
    -> IO (Either PublishRelayFault PublishRelayResponse))
-> IO (Either PublishRelayFault PublishRelayResponse)
forall a.
Request -> Manager -> (Response BodyReader -> IO a) -> IO a
withResponse Request
request Manager
manager (Limits
-> Response BodyReader
-> IO (Either PublishRelayFault PublishRelayResponse)
readRelayResponse Limits
limits))
        IO
  (Either
     HttpException (Either PublishRelayFault PublishRelayResponse))
-> (Either
      HttpException (Either PublishRelayFault PublishRelayResponse)
    -> Either PublishRelayFault PublishRelayResponse)
-> IO (Either PublishRelayFault PublishRelayResponse)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
            Left HttpException
httpErr -> PublishRelayFault -> Either PublishRelayFault PublishRelayResponse
forall a b. a -> Either a b
Left (TransportFault -> PublishRelayFault
RelayTransport (HttpException -> TransportFault
classifyTransport HttpException
httpErr))
            Right Either PublishRelayFault PublishRelayResponse
relayed -> Either PublishRelayFault PublishRelayResponse
relayed

{- Read a response body chunk-by-chunk through 'boundedRead' against the budget,
returning the whole body as a 'RegistryResponse' when within the cap, or the
'LimitError' as a __value__ when the body crosses the budget (never a truncated
body). Shared by both exchanges: 'boundedFetch' returns it directly, 'boundedRelay'
pairs it with the answered status. -}
readBoundedBody :: Limits -> BodyReader -> IO (Either LimitError RegistryResponse)
readBoundedBody :: Limits -> BodyReader -> IO (Either LimitError RegistryResponse)
readBoundedBody Limits
limits BodyReader
bodyReader =
    (ByteString -> RegistryResponse)
-> Either LimitError ByteString
-> Either LimitError RegistryResponse
forall a b. (a -> b) -> Either LimitError a -> Either LimitError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> RegistryResponse
RegistryResponse (Either LimitError ByteString
 -> Either LimitError RegistryResponse)
-> IO (Either LimitError ByteString)
-> IO (Either LimitError RegistryResponse)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Limits -> BodyReader -> IO (Either LimitError ByteString)
forall (m :: * -> *).
Monad m =>
Limits -> m ByteString -> m (Either LimitError ByteString)
boundedRead Limits
limits (BodyReader -> BodyReader
brRead BodyReader
bodyReader)

{- Buffer the publication target's response to a relayed publish: the body read
bounded against the budget (an overstep is the typed 'RelayBoundExceeded'), paired
with the status the target answered. -}
readRelayResponse :: Limits -> Response BodyReader -> IO (Either PublishRelayFault PublishRelayResponse)
readRelayResponse :: Limits
-> Response BodyReader
-> IO (Either PublishRelayFault PublishRelayResponse)
readRelayResponse Limits
limits Response BodyReader
response =
    Limits -> BodyReader -> IO (Either LimitError RegistryResponse)
readBoundedBody Limits
limits (Response BodyReader -> BodyReader
forall body. Response body -> body
responseBody Response BodyReader
response) IO (Either LimitError RegistryResponse)
-> (Either LimitError RegistryResponse
    -> Either PublishRelayFault PublishRelayResponse)
-> IO (Either PublishRelayFault PublishRelayResponse)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
        Left LimitError
limitErr -> PublishRelayFault -> Either PublishRelayFault PublishRelayResponse
forall a b. a -> Either a b
Left (LimitError -> PublishRelayFault
RelayBoundExceeded LimitError
limitErr)
        Right (RegistryResponse ByteString
body) ->
            PublishRelayResponse
-> Either PublishRelayFault PublishRelayResponse
forall a b. b -> Either a b
Right
                PublishRelayResponse
                    { relayStatus :: Int
relayStatus = Status -> Int
statusCode (Response BodyReader -> Status
forall body. Response body -> Status
responseStatus Response BodyReader
response)
                    , relayBody :: LByteString
relayBody = ByteString -> LByteString
LBS.fromStrict ByteString
body
                    }