{- | The npm __data plane__: the effectful "Ecluse.Core.Registry" fields over
@http-client@.

This module is the network half of the npm protocol boundary. Where
"Ecluse.Core.Registry.Npm.Wire" and "Ecluse.Core.Registry.Npm.Project" are the pure decode
and projection, this is the side-effecting fetch and publish: 'newNpmClient'
assembles a "Ecluse.Core.Registry.RegistryClient" whose effectful fields talk to a
registry over plain HTTP, and whose @parse*@ fields are the pure projection
re-exported through the handle.

It speaks the npm registry protocol directly with @http-client@, __never__
@amazonka@: the control plane (the @GetAuthorizationToken@ mint, the mirror
queue) is @amazonka@'s job behind separate handles, but the data plane: fetch
metadata, stream a tarball, publish: is ordinary HTTPS+JSON, identical across
every npm-speaking backend. Keeping the streaming path off @amazonka@'s
@conduit@/@ResourceT@ machinery is exactly what makes bounded-memory artifact
proxying tractable.

== Streaming and buffering

'Ecluse.Core.Registry.Npm.Request.artifactRequest' marks its request __non-decompressing__
so a tarball is opaque binary that must reach the client byte-for-byte. The
request is exposed so the web layer can relay the open body __without buffering
the whole artifact in memory__. The handle's 'Ecluse.Core.Registry.fetchArtifact'
field, by contrast, buffers (its 'RegistryResponse' return is whole bytes) and
is for the mirror worker, which must read the entire artifact to verify its
integrity before publishing.

== Authentication

The client accepts an __injected__ bearer token and attaches it to every
request; it never originates credential policy. Which token to send on which request is
the request pipeline's authority model, decided upstream of this module.
-}
module Ecluse.Core.Registry.Npm (
    -- * Construction
    NpmClientConfig (..),
    defaultNpmConfig,
    publicRegistryBaseUrl,
    publicRegistryUrl,
    newNpmClient,
    newNpmPublishClient,

    -- * Lower-level fetch
    fetchMetadataForm,

    -- * First-party publish relay
    relayPublishDocument,

    -- * Response-bound breach
    ResponseBoundExceeded (..),
) where

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

import Ecluse.Core.Credential (Secret)
import Ecluse.Core.Package (Hash (hashAlg, hashValue), HashAlg (SHA1, SRI), PackageName)
import Ecluse.Core.Queue (MirrorArtifact (maFilename, maHashes))
import Ecluse.Core.Registry (
    ParseError (ParseError),
    PublishError (..),
    PublishFault (PublishRejected, PublishUrlUnformable),
    PublishRelayResponse (..),
    RegistryClient (..),
    RegistryResponse (RegistryResponse),
    UrlFormationError,
 )

import Ecluse.Core.Registry.Npm.Project qualified as Project
import Ecluse.Core.Registry.Npm.Publish (npmPublishDocument, publishRequest)
import Ecluse.Core.Registry.Npm.Request (
    MetadataForm (Abbreviated),
    Validators,
    artifactRequest,
    metadataRequest,
    noValidators,
 )
import Ecluse.Core.Security (
    LimitError,
    Limits,
    boundedRead,
    defaultLimits,
 )
import Ecluse.Core.Security.Egress.Internal (RegistryUrl (RegistryUrl))
import Ecluse.Core.Version (Version)

{- | Everything 'newNpmClient' needs to talk to one npm-speaking registry: the
base URL, the shared HTTP 'Manager', and an optional injected bearer token.

The 'Manager' is shared (it owns the connection pool), so it is taken rather than
built here: the same one the composition root reuses across requests. The token
is whatever the request pipeline decided this client should present; this module
never chooses it.
-}
data NpmClientConfig = NpmClientConfig
    { NpmClientConfig -> Text
npmBaseUrl :: Text
    {- ^ The registry base URL (e.g. the public registry, or a CodeArtifact npm
    endpoint). The package path is appended to it.
    -}
    , NpmClientConfig -> Manager
npmManager :: Manager
    -- ^ The shared @http-client@ 'Manager' to issue requests through.
    , NpmClientConfig -> Maybe Secret
npmToken :: Maybe Secret
    -- ^ An injected bearer token to attach, or 'Nothing' for anonymous requests.
    , NpmClientConfig -> Limits
npmLimits :: Limits
    {- ^ The response-bound budget enforced on a metadata fetch: 'fetchMetadataForm'
    reads the body through 'Ecluse.Core.Security.boundedRead' against
    'Ecluse.Core.Security.maxBodyBytes', aborting fail-closed past the cap rather than
    buffering an unbounded body.
    -}
    }

{- | The canonical public npm registry base URL, @https://registry.npmjs.org@.
The default target when no managed backend is configured.
-}
publicRegistryBaseUrl :: Text
publicRegistryBaseUrl :: Text
publicRegistryBaseUrl = Text
"https://registry.npmjs.org"

{- | The canonical public npm registry as an https 'RegistryUrl': the
'publicRegistryBaseUrl' text, https by construction. The default @ECLUSE_PUBLIC_UPSTREAM@
when none is configured.
-}
publicRegistryUrl :: RegistryUrl
publicRegistryUrl :: RegistryUrl
publicRegistryUrl = Text -> RegistryUrl
RegistryUrl Text
publicRegistryBaseUrl

{- | An anonymous client config against the public registry ('publicRegistryBaseUrl'),
using the given shared 'Manager' and the secure-default response bounds
('Ecluse.Core.Security.defaultLimits'). Override 'npmBaseUrl'/'npmToken'/'npmLimits' for
a managed backend or a per-deployment budget.
-}
defaultNpmConfig :: Manager -> NpmClientConfig
defaultNpmConfig :: Manager -> NpmClientConfig
defaultNpmConfig Manager
manager =
    NpmClientConfig
        { npmBaseUrl :: Text
npmBaseUrl = Text
publicRegistryBaseUrl
        , npmManager :: Manager
npmManager = Manager
manager
        , npmToken :: Maybe Secret
npmToken = Maybe Secret
forall a. Maybe a
Nothing
        , npmLimits :: Limits
npmLimits = Limits
defaultLimits
        }

{- | Assemble a "Ecluse.Core.Registry.RegistryClient" for the npm protocol over the
given configuration.

The effectful fields close over the config's 'Manager' and token and speak npm
over HTTP; the @parse*@ fields are the pure projection from
"Ecluse.Core.Registry.Npm.Project", re-exported through the handle. The handle's
'Ecluse.Core.Registry.fetchMetadata' requests the 'Abbreviated' form
unconditionally; the richer 'fetchMetadataForm' (for the full packument and
relayed validators) is exposed separately for the request pipeline.
-}
newNpmClient :: NpmClientConfig -> IO RegistryClient
newNpmClient :: NpmClientConfig -> IO RegistryClient
newNpmClient NpmClientConfig
config = NpmClientConfig -> IO (Maybe Secret) -> IO RegistryClient
newNpmPublishClient NpmClientConfig
config (Maybe Secret -> IO (Maybe Secret)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NpmClientConfig -> Maybe Secret
npmToken NpmClientConfig
config))

{- | Build an npm RegistryClient whose 'Ecluse.Core.Registry.publishArtifact' and
'Ecluse.Core.Registry.fetchMetadata' fields mint a fresh token per call via the provided
IO action; the remaining fields use the token in the config. The metadata read mints
because the worker's mirror-presence probe reads the mirror target through this handle,
and a managed mirror (CodeArtifact) requires auth on reads as on writes -- an anonymous
probe would be refused and the dedup would never confirm anything. For 'newNpmClient'
the mint is the configured token, so its behaviour is unchanged.
-}
newNpmPublishClient :: NpmClientConfig -> IO (Maybe Secret) -> IO RegistryClient
newNpmPublishClient :: NpmClientConfig -> IO (Maybe Secret) -> IO RegistryClient
newNpmPublishClient NpmClientConfig
config IO (Maybe Secret)
mintToken =
    RegistryClient -> IO RegistryClient
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        RegistryClient
            { fetchMetadata :: PackageName -> IO RegistryResponse
fetchMetadata = \PackageName
name -> do
                token <- IO (Maybe Secret)
mintToken
                fetchMetadataForm config{npmToken = token} Abbreviated noValidators name
            , fetchArtifact :: PackageName -> Version -> IO RegistryResponse
fetchArtifact = NpmClientConfig -> PackageName -> Version -> IO RegistryResponse
fetchArtifact' NpmClientConfig
config
            , publishArtifact :: PackageName
-> Version
-> MirrorArtifact
-> ByteString
-> IO (Either PublishFault ())
publishArtifact = NpmClientConfig
-> IO (Maybe Secret)
-> PackageName
-> Version
-> MirrorArtifact
-> ByteString
-> IO (Either PublishFault ())
publishArtifact' NpmClientConfig
config IO (Maybe Secret)
mintToken
            , -- Each version's @dist.tarball@ scheme is normalised against the host this
              -- client reads from (same-host http upgraded, foreign-host http dropped) as
              -- a projection post-step; the Handle field types are unchanged.
              parsePackageInfo :: PackageName -> RegistryResponse -> Either ParseError PackageInfo
parsePackageInfo = \PackageName
name RegistryResponse
resp -> Text -> PackageInfo -> PackageInfo
Project.enforceTarballScheme Text
upstreamBaseUrl (PackageInfo -> PackageInfo)
-> Either ParseError PackageInfo -> Either ParseError PackageInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PackageName -> RegistryResponse -> Either ParseError PackageInfo
Project.parsePackageInfo PackageName
name RegistryResponse
resp
            , parseVersionDetails :: RegistryResponse -> Version -> Either ParseError PackageDetails
parseVersionDetails = \RegistryResponse
resp Version
version ->
                RegistryResponse -> Version -> Either ParseError PackageDetails
Project.parseVersionDetails RegistryResponse
resp Version
version
                    Either ParseError PackageDetails
-> (PackageDetails -> Either ParseError PackageDetails)
-> Either ParseError PackageDetails
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
>>= Either ParseError PackageDetails
-> (PackageDetails -> Either ParseError PackageDetails)
-> Maybe PackageDetails
-> Either ParseError PackageDetails
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ParseError -> Either ParseError PackageDetails
forall a b. a -> Either a b
Left ParseError
tarballNotHttps) PackageDetails -> Either ParseError PackageDetails
forall a b. b -> Either a b
Right (Maybe PackageDetails -> Either ParseError PackageDetails)
-> (PackageDetails -> Maybe PackageDetails)
-> PackageDetails
-> Either ParseError PackageDetails
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> PackageDetails -> Maybe PackageDetails
Project.enforceTarballSchemeDetails Text
upstreamBaseUrl
            , parseVersionList :: RegistryResponse -> Either ParseError [Version]
parseVersionList = RegistryResponse -> Either ParseError [Version]
Project.parseVersionList
            }
  where
    upstreamBaseUrl :: Text
upstreamBaseUrl = NpmClientConfig -> Text
npmBaseUrl NpmClientConfig
config
    tarballNotHttps :: ParseError
tarballNotHttps =
        Text -> ParseError
ParseError Text
"the requested version's dist.tarball is not an https URL on the upstream host"

{- | Fetch a package's metadata in the requested 'MetadataForm', relaying any
conditional-GET 'Validators'. The bounded-read fetch used by the handle's
'Ecluse.Core.Registry.fetchMetadata'; the request pipeline calls this directly when it
needs the full packument or wants to revalidate against an @ETag@.

The body is read __chunk-by-chunk through 'Ecluse.Core.Security.boundedRead'__ against
the config's 'npmLimits', not buffered whole: a hostile or compromised upstream
returning a body larger than 'Ecluse.Core.Security.maxBodyBytes' is aborted
__fail-closed__ rather than exhausting memory.
-}
fetchMetadataForm ::
    NpmClientConfig ->
    MetadataForm ->
    Validators ->
    PackageName ->
    IO RegistryResponse
fetchMetadataForm :: NpmClientConfig
-> MetadataForm -> Validators -> PackageName -> IO RegistryResponse
fetchMetadataForm NpmClientConfig
config MetadataForm
form Validators
validators PackageName
name = do
    request <- Either UrlFormationError Request -> IO Request
orThrow (Text
-> Maybe Secret
-> MetadataForm
-> Validators
-> PackageName
-> Either UrlFormationError Request
metadataRequest (NpmClientConfig -> Text
npmBaseUrl NpmClientConfig
config) (NpmClientConfig -> Maybe Secret
npmToken NpmClientConfig
config) MetadataForm
form Validators
validators PackageName
name)
    withResponse request (npmManager config) $ \Response BodyReader
response ->
        Limits -> BodyReader -> IO RegistryResponse
readBoundedBody (NpmClientConfig -> Limits
npmLimits NpmClientConfig
config) (Response BodyReader -> BodyReader
forall body. Response body -> body
responseBody Response BodyReader
response)

{- | Raised when an upstream metadata body breaches a 'Ecluse.Core.Security.Limits'
ceiling: the body-size guard here, or: surfaced through the same type by the serve
pipeline: the version-count or nesting-depth guard.
-}
newtype ResponseBoundExceeded = ResponseBoundExceeded LimitError
    deriving stock (ResponseBoundExceeded -> ResponseBoundExceeded -> Bool
(ResponseBoundExceeded -> ResponseBoundExceeded -> Bool)
-> (ResponseBoundExceeded -> ResponseBoundExceeded -> Bool)
-> Eq ResponseBoundExceeded
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ResponseBoundExceeded -> ResponseBoundExceeded -> Bool
== :: ResponseBoundExceeded -> ResponseBoundExceeded -> Bool
$c/= :: ResponseBoundExceeded -> ResponseBoundExceeded -> Bool
/= :: ResponseBoundExceeded -> ResponseBoundExceeded -> Bool
Eq, Int -> ResponseBoundExceeded -> ShowS
[ResponseBoundExceeded] -> ShowS
ResponseBoundExceeded -> String
(Int -> ResponseBoundExceeded -> ShowS)
-> (ResponseBoundExceeded -> String)
-> ([ResponseBoundExceeded] -> ShowS)
-> Show ResponseBoundExceeded
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ResponseBoundExceeded -> ShowS
showsPrec :: Int -> ResponseBoundExceeded -> ShowS
$cshow :: ResponseBoundExceeded -> String
show :: ResponseBoundExceeded -> String
$cshowList :: [ResponseBoundExceeded] -> ShowS
showList :: [ResponseBoundExceeded] -> ShowS
Show)

instance Exception ResponseBoundExceeded

{- Read a response body chunk-by-chunk through 'boundedRead' against the budget,
returning the whole body as a 'RegistryResponse' when within the cap. A body past
'Ecluse.Core.Security.maxBodyBytes' aborts the read fail-closed and is raised as a typed
'ResponseBoundExceeded' (never a truncated body). -}
readBoundedBody :: Limits -> BodyReader -> IO RegistryResponse
readBoundedBody :: Limits -> BodyReader -> IO RegistryResponse
readBoundedBody Limits
limits BodyReader
bodyReader =
    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) IO (Either LimitError ByteString)
-> (Either LimitError ByteString -> IO RegistryResponse)
-> IO RegistryResponse
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 -> RegistryResponse -> IO RegistryResponse
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> RegistryResponse
RegistryResponse ByteString
body)
        Left LimitError
err -> ResponseBoundExceeded -> IO RegistryResponse
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (LimitError -> ResponseBoundExceeded
ResponseBoundExceeded LimitError
err)

-- Fetch and __buffer__ a version's artifact bytes (the handle's 'fetchArtifact').
fetchArtifact' :: NpmClientConfig -> PackageName -> Version -> IO RegistryResponse
fetchArtifact' :: NpmClientConfig -> PackageName -> Version -> IO RegistryResponse
fetchArtifact' NpmClientConfig
config PackageName
name Version
version = do
    request <- Either UrlFormationError Request -> IO Request
orThrow (Text
-> Maybe Secret
-> PackageName
-> Version
-> Either UrlFormationError Request
artifactRequest (NpmClientConfig -> Text
npmBaseUrl NpmClientConfig
config) (NpmClientConfig -> Maybe Secret
npmToken NpmClientConfig
config) PackageName
name Version
version)
    response <- httpLbs request (npmManager config)
    pure (RegistryResponse (toStrict (responseBody response)))

{- Publish a version's artifact: assemble the ecosystem-specific publish document
from the artifact metadata and raw tarball bytes, then PUT it, treating a
@409 Conflict@ (the version is already present) as idempotent success.
-}
publishArtifact' ::
    NpmClientConfig ->
    IO (Maybe Secret) ->
    PackageName ->
    Version ->
    MirrorArtifact ->
    ByteString ->
    IO (Either PublishFault ())
publishArtifact' :: NpmClientConfig
-> IO (Maybe Secret)
-> PackageName
-> Version
-> MirrorArtifact
-> ByteString
-> IO (Either PublishFault ())
publishArtifact' NpmClientConfig
config IO (Maybe Secret)
mintToken PackageName
name Version
version MirrorArtifact
artifact ByteString
tarball = do
    token <- IO (Maybe Secret)
mintToken
    let document = PackageName
-> Version
-> Text
-> Maybe Text
-> Maybe Text
-> ByteString
-> ByteString
npmPublishDocument PackageName
name Version
version (MirrorArtifact -> Text
maFilename MirrorArtifact
artifact) (MirrorArtifact -> Maybe Text
sriOf MirrorArtifact
artifact) (MirrorArtifact -> Maybe Text
sha1Of MirrorArtifact
artifact) ByteString
tarball
    case publishRequest (npmBaseUrl config) token name document of
        Left UrlFormationError
urlErr -> Either PublishFault () -> IO (Either PublishFault ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PublishFault -> Either PublishFault ()
forall a b. a -> Either a b
Left (UrlFormationError -> PublishFault
PublishUrlUnformable UrlFormationError
urlErr))
        Right Request
request -> do
            response <- Request -> Manager -> IO (Response ByteString)
httpLbs Request
request (NpmClientConfig -> Manager
npmManager NpmClientConfig
config)
            let code = Status -> Int
statusCode (Response ByteString -> Status
forall body. Response body -> Status
responseStatus Response ByteString
response)
            pure (classifyPublish code)

{- Map a publish response status onto success or a 'PublishFault'. A 2xx or a
@409@ (already present, immutable) is success; anything else is a retryable
'PublishRejected' naming the status the job saw.
-}
classifyPublish :: Int -> Either PublishFault ()
classifyPublish :: Int -> Either PublishFault ()
classifyPublish Int
code
    | Int
code Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
200 Bool -> Bool -> Bool
&& Int
code Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
300 = () -> Either PublishFault ()
forall a b. b -> Either a b
Right ()
    | Int
code Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
409 = () -> Either PublishFault ()
forall a b. b -> Either a b
Right () -- version already present; immutable, so success-equivalent
    | Bool
otherwise =
        PublishFault -> Either PublishFault ()
forall a b. a -> Either a b
Left (PublishError -> PublishFault
PublishRejected (Text -> PublishError
PublishError (Text
"publish failed with HTTP status " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
code)))

{- | Relay a client's npm publish document to the publication target and return the
target's own response: the first-party publish primitive behind the @PUT /{pkg}@
serve path.
-}
relayPublishDocument ::
    NpmClientConfig ->
    PackageName ->
    ByteString ->
    IO (Either UrlFormationError PublishRelayResponse)
relayPublishDocument :: NpmClientConfig
-> PackageName
-> ByteString
-> IO (Either UrlFormationError PublishRelayResponse)
relayPublishDocument NpmClientConfig
config PackageName
name ByteString
document =
    case Text
-> Maybe Secret
-> PackageName
-> ByteString
-> Either UrlFormationError Request
publishRequest (NpmClientConfig -> Text
npmBaseUrl NpmClientConfig
config) (NpmClientConfig -> Maybe Secret
npmToken NpmClientConfig
config) PackageName
name ByteString
document of
        Left UrlFormationError
urlErr -> Either UrlFormationError PublishRelayResponse
-> IO (Either UrlFormationError PublishRelayResponse)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UrlFormationError -> Either UrlFormationError PublishRelayResponse
forall a b. a -> Either a b
Left UrlFormationError
urlErr)
        Right Request
request ->
            Request
-> Manager
-> (Response BodyReader
    -> IO (Either UrlFormationError PublishRelayResponse))
-> IO (Either UrlFormationError PublishRelayResponse)
forall a.
Request -> Manager -> (Response BodyReader -> IO a) -> IO a
withResponse Request
request (NpmClientConfig -> Manager
npmManager NpmClientConfig
config) ((Response BodyReader
  -> IO (Either UrlFormationError PublishRelayResponse))
 -> IO (Either UrlFormationError PublishRelayResponse))
-> (Response BodyReader
    -> IO (Either UrlFormationError PublishRelayResponse))
-> IO (Either UrlFormationError PublishRelayResponse)
forall a b. (a -> b) -> a -> b
$
                (PublishRelayResponse
 -> Either UrlFormationError PublishRelayResponse)
-> IO PublishRelayResponse
-> IO (Either UrlFormationError PublishRelayResponse)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PublishRelayResponse
-> Either UrlFormationError PublishRelayResponse
forall a b. b -> Either a b
Right (IO PublishRelayResponse
 -> IO (Either UrlFormationError PublishRelayResponse))
-> (Response BodyReader -> IO PublishRelayResponse)
-> Response BodyReader
-> IO (Either UrlFormationError PublishRelayResponse)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Limits -> Response BodyReader -> IO PublishRelayResponse
readRelayResponse (NpmClientConfig -> Limits
npmLimits NpmClientConfig
config)

{- Buffer the publication target's response to a relayed publish: the body read
bounded against the budget, paired with the status the target answered. -}
readRelayResponse :: Limits -> Response BodyReader -> IO PublishRelayResponse
readRelayResponse :: Limits -> Response BodyReader -> IO PublishRelayResponse
readRelayResponse Limits
limits Response BodyReader
response = do
    RegistryResponse body <- Limits -> BodyReader -> IO RegistryResponse
readBoundedBody Limits
limits (Response BodyReader -> BodyReader
forall body. Response body -> body
responseBody Response BodyReader
response)
    pure
        PublishRelayResponse
            { relayStatus = statusCode (responseStatus response)
            , relayBody = LBS.fromStrict body
            }

{- Run a request-building 'Either' from a __read__ path, raising its
'UrlFormationError' as the typed exception it is (no stringly @stringException@).
Used by the metadata and artifact fetches, where an unformable URL is a config
fault rather than a per-response condition; the write path instead returns it as
a 'PublishUrlUnformable' value.
-}
orThrow :: Either UrlFormationError Request -> IO Request
orThrow :: Either UrlFormationError Request -> IO Request
orThrow = \case
    Left UrlFormationError
err -> UrlFormationError -> IO Request
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO UrlFormationError
err
    Right Request
request -> Request -> IO Request
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Request
request

-- Pick the SRI (@dist.integrity@) string from the admitted digests, if present.
sriOf :: MirrorArtifact -> Maybe Text
sriOf :: MirrorArtifact -> Maybe Text
sriOf = HashAlg -> MirrorArtifact -> Maybe Text
firstHashValue HashAlg
SRI

-- Pick the SHA-1 shasum from the admitted digests, if present.
sha1Of :: MirrorArtifact -> Maybe Text
sha1Of :: MirrorArtifact -> Maybe Text
sha1Of = HashAlg -> MirrorArtifact -> Maybe Text
firstHashValue HashAlg
SHA1

firstHashValue :: HashAlg -> MirrorArtifact -> Maybe Text
firstHashValue :: HashAlg -> MirrorArtifact -> Maybe Text
firstHashValue HashAlg
alg MirrorArtifact
artifact =
    (Hash -> Text) -> Maybe Hash -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Hash -> Text
hashValue ((Hash -> Bool) -> [Hash] -> Maybe Hash
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((HashAlg -> HashAlg -> Bool
forall a. Eq a => a -> a -> Bool
== HashAlg
alg) (HashAlg -> Bool) -> (Hash -> HashAlg) -> Hash -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash -> HashAlg
hashAlg) (NonEmpty Hash -> [Hash]
forall a. NonEmpty a -> [a]
NE.toList (MirrorArtifact -> NonEmpty Hash
maHashes MirrorArtifact
artifact)))