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

module Ecluse.Core.Worker.Fetch (
    ArtifactFetchFault (..),
    fetchArtifactBytes,
) where

import Network.HTTP.Client (HttpException, Manager, Request, brRead, responseBody, withResponse)
import UnliftIO.Exception (try)

import Ecluse.Core.Credential (Secret)
import Ecluse.Core.Registry (UrlFormationError)
import Ecluse.Core.Registry.Fault (ResponseBoundExceeded (ResponseBoundExceeded))
import Ecluse.Core.Security (Limits, boundedRead)
import Ecluse.Core.Security.Egress (RegistryUrl, registryUrlText)
import Ecluse.Core.Worker.Types (WorkerM, wrManager)

{- | Why a mirror-artifact fetch failed, split by whether a redelivery could ever
help, so the job's ack decision ('Ecluse.Core.Worker.Job.mirrorArtifact') follows
from the type rather than re-parsing a reason string.
-}
data ArtifactFetchFault
    = {- | The artifact exceeded the plan-sized byte cap. Deterministic in the
      artifact's own size, so a redelivery re-fetches the same over-cap bytes and
      fails identically: __terminal__, never worth retrying. Carries the detail.
      -}
      ArtifactOverCap Text
    | {- | A transient fetch fault (an unformable URL, a network failure): a
      redelivery may succeed. Carries the detail.
      -}
      ArtifactUnavailable Text
    deriving stock (ArtifactFetchFault -> ArtifactFetchFault -> Bool
(ArtifactFetchFault -> ArtifactFetchFault -> Bool)
-> (ArtifactFetchFault -> ArtifactFetchFault -> Bool)
-> Eq ArtifactFetchFault
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ArtifactFetchFault -> ArtifactFetchFault -> Bool
== :: ArtifactFetchFault -> ArtifactFetchFault -> Bool
$c/= :: ArtifactFetchFault -> ArtifactFetchFault -> Bool
/= :: ArtifactFetchFault -> ArtifactFetchFault -> Bool
Eq, Int -> ArtifactFetchFault -> ShowS
[ArtifactFetchFault] -> ShowS
ArtifactFetchFault -> String
(Int -> ArtifactFetchFault -> ShowS)
-> (ArtifactFetchFault -> String)
-> ([ArtifactFetchFault] -> ShowS)
-> Show ArtifactFetchFault
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ArtifactFetchFault -> ShowS
showsPrec :: Int -> ArtifactFetchFault -> ShowS
$cshow :: ArtifactFetchFault -> String
show :: ArtifactFetchFault -> String
$cshowList :: [ArtifactFetchFault] -> ShowS
showList :: [ArtifactFetchFault] -> ShowS
Show)

{- Fetch the artifact bytes from the public upstream at the job's authoritative
URL into memory, under the plan-sized artifact byte cap. The URL arrives as the
job's validated 'RegistryUrl' witness, so the https guarantee is the argument type,
not trust in the caller. The request builder is the job ecosystem's own formation,
passed in from the re-evaluation bundle that admitted the job
('Ecluse.Core.Worker.Types.wpBuildArtifactRequest'). Publishing is
__publish-by-document__: the npm @PUT \/{pkg}@ carries the tarball base64-encoded
under @_attachments@, so the whole artifact must be in hand to verify it and assemble
the document. This path is therefore __bounded-buffered__, not streamed -- the bytes
are necessarily held -- but the read is capped by the caller's 'Limits' (the
composition root sizes it from the memory plan's mirror-artifact tenant, in
@Ecluse.Composition.MemoryPlan@), so an upstream returning a body past the cap is
refused fail-closed rather than exhausting the heap the plan partitions. An over-cap
body is an 'ArtifactOverCap' (terminal at the call site); a network or URL failure an
'ArtifactUnavailable' (transient), so a flaky upstream redelivers rather than killing
the iteration. -}
fetchArtifactBytes ::
    Limits ->
    (Limits -> Manager -> Text -> Maybe Secret -> Text -> Either UrlFormationError Request) ->
    RegistryUrl ->
    WorkerM (Either ArtifactFetchFault ByteString)
fetchArtifactBytes :: Limits
-> (Limits
    -> Manager
    -> Text
    -> Maybe Secret
    -> Text
    -> Either UrlFormationError Request)
-> RegistryUrl
-> WorkerM (Either ArtifactFetchFault ByteString)
fetchArtifactBytes Limits
limits Limits
-> Manager
-> Text
-> Maybe Secret
-> Text
-> Either UrlFormationError Request
buildRequest RegistryUrl
url = do
    manager <- (WorkerRuntime -> Manager) -> WorkerM Manager
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WorkerRuntime -> Manager
wrManager
    -- The job's URL is authoritative and absolute (no base to resolve against)
    -- and the public artifact fetch is anonymous, so the builder gets an empty
    -- base and no token (the by-URL builder's documented contract).
    case buildRequest limits manager "" Nothing (registryUrlText url) of
        Left UrlFormationError
urlErr -> Either ArtifactFetchFault ByteString
-> WorkerM (Either ArtifactFetchFault ByteString)
forall a. a -> WorkerM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ArtifactFetchFault -> Either ArtifactFetchFault ByteString
forall a b. a -> Either a b
Left (Text -> ArtifactFetchFault
ArtifactUnavailable (Text
"unformable artifact URL: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> UrlFormationError -> Text
forall b a. (Show a, IsString b) => a -> b
show UrlFormationError
urlErr)))
        Right Request
request ->
            WorkerM (Either ResponseBoundExceeded ByteString)
-> WorkerM
     (Either HttpException (Either ResponseBoundExceeded ByteString))
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try (IO (Either ResponseBoundExceeded ByteString)
-> WorkerM (Either ResponseBoundExceeded ByteString)
forall a. IO a -> WorkerM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Limits
-> Manager
-> Request
-> IO (Either ResponseBoundExceeded ByteString)
boundedFetch Limits
limits Manager
manager Request
request)) WorkerM
  (Either HttpException (Either ResponseBoundExceeded ByteString))
-> (Either HttpException (Either ResponseBoundExceeded ByteString)
    -> Either ArtifactFetchFault ByteString)
-> WorkerM (Either ArtifactFetchFault ByteString)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
                Left (HttpException
e :: HttpException) -> ArtifactFetchFault -> Either ArtifactFetchFault ByteString
forall a b. a -> Either a b
Left (Text -> ArtifactFetchFault
ArtifactUnavailable (Text
"artifact fetch failed: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> HttpException -> Text
forall b a. (Show a, IsString b) => a -> b
show HttpException
e))
                Right (Left (ResponseBoundExceeded LimitError
limitErr)) ->
                    ArtifactFetchFault -> Either ArtifactFetchFault ByteString
forall a b. a -> Either a b
Left (Text -> ArtifactFetchFault
ArtifactOverCap (Text
"artifact exceeded the response bound: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> LimitError -> Text
forall b a. (Show a, IsString b) => a -> b
show LimitError
limitErr))
                Right (Right ByteString
bytes) -> ByteString -> Either ArtifactFetchFault ByteString
forall a b. b -> Either a b
Right ByteString
bytes

{- Open the artifact request and read its body chunk-by-chunk through the bounded
read against the supplied cap, returning the whole bytes when within it or a typed
'ResponseBoundExceeded' otherwise. A network failure throws (caught by the caller as
a transient reason). The cap bounds the necessarily-buffered tarball so a body past
it is refused fail-closed. -}
boundedFetch :: Limits -> Manager -> Request -> IO (Either ResponseBoundExceeded ByteString)
boundedFetch :: Limits
-> Manager
-> Request
-> IO (Either ResponseBoundExceeded ByteString)
boundedFetch Limits
limits Manager
manager Request
request =
    Request
-> Manager
-> (Response BodyReader
    -> IO (Either ResponseBoundExceeded ByteString))
-> IO (Either ResponseBoundExceeded ByteString)
forall a.
Request -> Manager -> (Response BodyReader -> IO a) -> IO a
withResponse Request
request Manager
manager ((Response BodyReader
  -> IO (Either ResponseBoundExceeded ByteString))
 -> IO (Either ResponseBoundExceeded ByteString))
-> (Response BodyReader
    -> IO (Either ResponseBoundExceeded ByteString))
-> IO (Either ResponseBoundExceeded ByteString)
forall a b. (a -> b) -> a -> b
$ \Response BodyReader
response ->
        Limits -> BodyReader -> IO (Either LimitError ByteString)
forall (m :: * -> *).
Monad m =>
Limits -> m ByteString -> m (Either LimitError ByteString)
boundedRead Limits
limits (BodyReader -> BodyReader
brRead (Response BodyReader -> BodyReader
forall body. Response body -> body
responseBody Response BodyReader
response)) IO (Either LimitError ByteString)
-> (Either LimitError ByteString
    -> IO (Either ResponseBoundExceeded ByteString))
-> IO (Either ResponseBoundExceeded ByteString)
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 ByteString
body -> Either ResponseBoundExceeded ByteString
-> IO (Either ResponseBoundExceeded ByteString)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Either ResponseBoundExceeded ByteString
forall a b. b -> Either a b
Right ByteString
body)
            Left LimitError
limitErr -> Either ResponseBoundExceeded ByteString
-> IO (Either ResponseBoundExceeded ByteString)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ResponseBoundExceeded -> Either ResponseBoundExceeded ByteString
forall a b. a -> Either a b
Left (LimitError -> ResponseBoundExceeded
ResponseBoundExceeded LimitError
limitErr))