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

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

import Ecluse.Core.Registry.Npm (ResponseBoundExceeded (ResponseBoundExceeded))
import Ecluse.Core.Registry.Npm.Request (artifactRequestByUrl)
import Ecluse.Core.Security (Limits (maxBodyBytes), boundedRead, defaultLimits)
import Ecluse.Core.Worker.Types (WorkerM, wrManager)

{- Fetch the artifact bytes from the public upstream at the job's authoritative
URL into memory. 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 (see 'workerArtifactLimits'), so an upstream returning an unbounded body
is refused fail-closed rather than exhausting memory. A network failure is returned
as a transient reason ('Retried' at the call site), not thrown, so a flaky upstream
redelivers rather than killing the iteration. -}
fetchArtifactBytes :: Text -> WorkerM (Either Text ByteString)
fetchArtifactBytes :: Text -> WorkerM (Either Text ByteString)
fetchArtifactBytes Text
url = do
    manager <- (WorkerRuntime -> Manager) -> WorkerM Manager
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WorkerRuntime -> Manager
wrManager
    case artifactRequestByUrl "" Nothing url of
        Left UrlFormationError
urlErr -> Either Text ByteString -> WorkerM (Either Text ByteString)
forall a. a -> WorkerM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Either Text ByteString
forall a b. a -> Either a b
Left (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 (Manager -> Request -> IO (Either ResponseBoundExceeded ByteString)
boundedFetch Manager
manager Request
request)) WorkerM
  (Either HttpException (Either ResponseBoundExceeded ByteString))
-> (Either HttpException (Either ResponseBoundExceeded ByteString)
    -> Either Text ByteString)
-> WorkerM (Either Text ByteString)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
                Left (HttpException
e :: HttpException) -> Text -> Either Text ByteString
forall a b. a -> Either a b
Left (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)) ->
                    Text -> Either Text ByteString
forall a b. a -> Either a b
Left (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 Text 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, returning the whole bytes when within the artifact cap 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 an
unbounded body is refused fail-closed. -}
boundedFetch :: Manager -> Request -> IO (Either ResponseBoundExceeded ByteString)
boundedFetch :: Manager -> Request -> IO (Either ResponseBoundExceeded ByteString)
boundedFetch 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
workerArtifactLimits (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))

{- The response-bound budget for an __artifact__ fetch. The metadata-path
'Ecluse.Core.Security.defaultLimits' caps bodies at 12 MiB, which is fine for a packument
but far too small for a real tarball, so the artifact cap is raised to a realistic
ceiling while the other limits (version count, nesting depth) stay at their defaults
(they do not apply to an opaque tarball). A body past this is refused fail-closed
rather than buffered, bounding the worker's memory per in-flight job. -}
workerArtifactLimits :: Limits
workerArtifactLimits :: Limits
workerArtifactLimits = Limits
defaultLimits{maxBodyBytes = 512 * 1024 * 1024}