-- SPDX-FileCopyrightText: 2026 Alexandra de Wit
--
-- SPDX-License-Identifier: MIT
-- TupleSections: local convenience for pairing a parsed name with its trailing
-- segments in 'takePackage' and 'takeScoped' ((,rest) / (,more)). See docs/style.md §2.
{-# LANGUAGE TupleSections #-}

{- | The npm route table itself: the router, the fallback action, the route-scoped pipeline
contracts, the capture values, and the leaf parsers.
"Ecluse.Core.Registry.Npm.Route" curates what a caller outside needs of it.

Importing this module opts out of the public surface's stability promises. It exists so a spec can
match one route, one contract, or one parser on its own.
-}
module Ecluse.Core.Registry.Npm.Route.Internal (
    -- * The mount's router and fallback action
    npmRouter,
    npmNotFound,

    -- * Route-scoped pipeline contracts
    npmPackumentContract,
    npmPackumentReplies,
    npmTarballContract,
    npmTarballReplies,

    -- * The table, as data
    npmRoutes,
    npmRouteSpecs,

    -- * The served artifact URL (rendered from the route that claims it)
    tarballPath,

    -- * The capture values and leaf parsers
    NpmCap (..),
    takePackage,
    tarballCoordinate,
) where

import Autodocodec (JSONCodec, object, pureCodec)
import Data.List.NonEmpty qualified as NE
import Data.Text qualified as T
import Network.HTTP.Types (
    Method,
    hContentType,
    status200,
    status304,
    status401,
    status403,
    status404,
    status500,
    status501,
    status502,
    status503,
 )

import Ecluse.Core.Ecosystem (Ecosystem (Npm))
import Ecluse.Core.Package (PackageName, pkgNamespace, renderPackageName, renderScope, unscopedName)
import Ecluse.Core.Registry.Npm.Project (projectName)
import Ecluse.Core.Registry.Npm.Serve (NpmError (NpmError), npmError, npmErrorCodec)
import Ecluse.Core.Server.Context (
    MountRouter,
    ResponseAction (AnswerLocally, RunPipeline),
    RouteAction (RouteAction),
 )
import Ecluse.Core.Server.Contract (
    BodySchema (SchemaDocumented),
    PassthroughBody (PassthroughBytes, PassthroughEmpty, PassthroughStream),
    PassthroughResponse,
    RequestSpec (RequestSpec),
    ResponseChoice (FirstResponse, SecondResponse),
    ResponseContract,
    ResponseValue,
    VariableResponse,
    chooseContract,
    documentedJsonContract,
    emptyContract,
    encodeBody,
    jsonContract,
    passthroughContract,
    passthroughResponse,
    responseValue,
    variableOpaqueContract,
    variableResponse,
 )
import Ecluse.Core.Server.Path (Filename, mkFilename)
import Ecluse.Core.Server.Pipeline.Packument (PackumentReplies (..), packumentAction)
import Ecluse.Core.Server.Pipeline.Publish (PublishReplies (..), servePublish)
import Ecluse.Core.Server.Pipeline.Tarball (tarballAction)
import Ecluse.Core.Server.Pipeline.Tarball.Types (TarballReplies (..))
import Ecluse.Core.Server.Response (renderRefusal)
import Ecluse.Core.Server.Route (
    Capture (Capture),
    MediaNegotiation (AcceptsAnything),
    MethodMatch (MethodDelete, MethodPut, MethodRead),
    PatternSeg (SegCap, SegLit),
    Route (Route),
    RouteName (RouteName),
    answering,
    renderRoute,
    routerOf,
    safeSegment,
 )
import Ecluse.Core.Server.RouteDescription (RouteSpec, catchAllSpecs, specsOf, unsupportedPathParam)
import Ecluse.Core.Version (Version, mkVersion)

-- | Match the first applicable route, otherwise answer 'npmNotFound'.
npmRouter :: MountRouter
npmRouter :: MountRouter
npmRouter = RouteAction -> [Route NpmCap] -> MountRouter
forall v. RouteAction -> [Route v] -> MountRouter
routerOf RouteAction
npmNotFound [Route NpmCap]
npmRoutes

-- | The deny-by-default @404@ action for a path no route claims.
npmNotFound :: RouteAction
npmNotFound :: RouteAction
npmNotFound =
    ResponseContract (ResponseValue NpmError)
-> ResponseAction (ResponseValue NpmError) -> RouteAction
forall response.
ResponseContract response -> ResponseAction response -> RouteAction
RouteAction
        ResponseContract (ResponseValue NpmError)
unsupportedContract
        (ResponseValue NpmError -> ResponseAction (ResponseValue NpmError)
forall response. response -> ResponseAction response
AnswerLocally ([Header] -> NpmError -> ResponseValue NpmError
forall a. [Header] -> a -> ResponseValue a
responseValue [] (Text -> NpmError
NpmError Text
"not found")))

-- | Try reserved meta-routes before package captures.
npmRoutes :: [Route NpmCap]
npmRoutes :: [Route NpmCap]
npmRoutes =
    [ Route NpmCap
pingRoute
    , Route NpmCap
searchRoute
    , Route NpmCap
distTagListRoute
    , Route NpmCap
distTagSetRoute
    , Route NpmCap
distTagRemoveRoute
    , Route NpmCap
tarballRoute
    , Route NpmCap
packumentRoute
    , Route NpmCap
publishRoute
    ]

-- @GET \/-\/ping@: a liveness probe, answered locally with @200 {}@.
pingRoute :: Route NpmCap
pingRoute :: Route NpmCap
pingRoute =
    RouteName
-> MethodMatch
-> MediaNegotiation (ResponseValue ())
-> [PatternSeg NpmCap]
-> (ByteString
    -> [NpmCap] -> Maybe (ResponseAction (ResponseValue ())))
-> Text
-> Text
-> Maybe RequestSpec
-> ResponseContract (ResponseValue ())
-> Route NpmCap
forall v response.
RouteName
-> MethodMatch
-> MediaNegotiation response
-> [PatternSeg v]
-> (ByteString -> [v] -> Maybe (ResponseAction response))
-> Text
-> Text
-> Maybe RequestSpec
-> ResponseContract response
-> Route v
Route
        (Text -> RouteName
RouteName Text
"ping")
        MethodMatch
MethodRead
        MediaNegotiation (ResponseValue ())
forall response. MediaNegotiation response
AcceptsAnything
        [Text -> PatternSeg NpmCap
forall v. Text -> PatternSeg v
SegLit Text
"-", Text -> PatternSeg NpmCap
forall v. Text -> PatternSeg v
SegLit Text
"ping"]
        (ResponseValue ()
-> ByteString
-> [NpmCap]
-> Maybe (ResponseAction (ResponseValue ()))
forall response v.
response -> ByteString -> [v] -> Maybe (ResponseAction response)
answering ResponseValue ()
pingAnswer)
        Text
"Liveness probe"
        Text
"Answered locally with `200` and an empty object; `npm ping` checks the endpoint it talks \
        \to is up, so there is no reason to round-trip upstream."
        Maybe RequestSpec
forall a. Maybe a
Nothing
        ResponseContract (ResponseValue ())
pingContract

-- @GET \/-\/v1\/search@: a documented @501@ boundary. Search is not proxied.
searchRoute :: Route NpmCap
searchRoute :: Route NpmCap
searchRoute =
    RouteName
-> MethodMatch
-> MediaNegotiation (ResponseValue NpmError)
-> [PatternSeg NpmCap]
-> (ByteString
    -> [NpmCap] -> Maybe (ResponseAction (ResponseValue NpmError)))
-> Text
-> Text
-> Maybe RequestSpec
-> ResponseContract (ResponseValue NpmError)
-> Route NpmCap
forall v response.
RouteName
-> MethodMatch
-> MediaNegotiation response
-> [PatternSeg v]
-> (ByteString -> [v] -> Maybe (ResponseAction response))
-> Text
-> Text
-> Maybe RequestSpec
-> ResponseContract response
-> Route v
Route
        (Text -> RouteName
RouteName Text
"search")
        MethodMatch
MethodRead
        MediaNegotiation (ResponseValue NpmError)
forall response. MediaNegotiation response
AcceptsAnything
        [Text -> PatternSeg NpmCap
forall v. Text -> PatternSeg v
SegLit Text
"-", Text -> PatternSeg NpmCap
forall v. Text -> PatternSeg v
SegLit Text
"v1", Text -> PatternSeg NpmCap
forall v. Text -> PatternSeg v
SegLit Text
"search"]
        (ResponseValue NpmError
-> ByteString
-> [NpmCap]
-> Maybe (ResponseAction (ResponseValue NpmError))
forall response v.
response -> ByteString -> [v] -> Maybe (ResponseAction response)
answering ResponseValue NpmError
searchAnswer)
        Text
"Package search (not supported)"
        Text
"Search is a first-class documented boundary: a discovery convenience, not an install path, \
        \so Écluse returns `501` and points to the public registry's website."
        Maybe RequestSpec
forall a. Maybe a
Nothing
        ResponseContract (ResponseValue NpmError)
searchContract

-- @GET \/-\/package\/{package}\/dist-tags@: a documented @501@ boundary.
distTagListRoute :: Route NpmCap
distTagListRoute :: Route NpmCap
distTagListRoute =
    RouteName
-> MethodMatch
-> MediaNegotiation (ResponseValue NpmError)
-> [PatternSeg NpmCap]
-> (ByteString
    -> [NpmCap] -> Maybe (ResponseAction (ResponseValue NpmError)))
-> Text
-> Text
-> Maybe RequestSpec
-> ResponseContract (ResponseValue NpmError)
-> Route NpmCap
forall v response.
RouteName
-> MethodMatch
-> MediaNegotiation response
-> [PatternSeg v]
-> (ByteString -> [v] -> Maybe (ResponseAction response))
-> Text
-> Text
-> Maybe RequestSpec
-> ResponseContract response
-> Route v
Route
        (Text -> RouteName
RouteName Text
"distTagList")
        MethodMatch
MethodRead
        MediaNegotiation (ResponseValue NpmError)
forall response. MediaNegotiation response
AcceptsAnything
        [Text -> PatternSeg NpmCap
forall v. Text -> PatternSeg v
SegLit Text
"-", Text -> PatternSeg NpmCap
forall v. Text -> PatternSeg v
SegLit Text
"package", Capture NpmCap -> PatternSeg NpmCap
forall v. Capture v -> PatternSeg v
SegCap Capture NpmCap
capPackage, Text -> PatternSeg NpmCap
forall v. Text -> PatternSeg v
SegLit Text
"dist-tags"]
        (ResponseValue NpmError
-> ByteString
-> [NpmCap]
-> Maybe (ResponseAction (ResponseValue NpmError))
forall response v.
response -> ByteString -> [v] -> Maybe (ResponseAction response)
answering ResponseValue NpmError
distTagAnswer)
        Text
"List a package's dist-tags (not supported)"
        Text
"A dist-tag is a mutable named pointer, which Écluse does not implement, so it returns \
        \`501` rather than the `404` an unrouted path takes. The merged packument already carries \
        \the reconciled `dist-tags` map, so a client reads a package's tags from its metadata."
        Maybe RequestSpec
forall a. Maybe a
Nothing
        ResponseContract (ResponseValue NpmError)
distTagContract

-- One path template for the tagged dist-tag routes, so the write and the removal cannot drift.
distTagTagSegs :: [PatternSeg NpmCap]
distTagTagSegs :: [PatternSeg NpmCap]
distTagTagSegs = [Text -> PatternSeg NpmCap
forall v. Text -> PatternSeg v
SegLit Text
"-", Text -> PatternSeg NpmCap
forall v. Text -> PatternSeg v
SegLit Text
"package", Capture NpmCap -> PatternSeg NpmCap
forall v. Capture v -> PatternSeg v
SegCap Capture NpmCap
capPackage, Text -> PatternSeg NpmCap
forall v. Text -> PatternSeg v
SegLit Text
"dist-tags", Capture NpmCap -> PatternSeg NpmCap
forall v. Capture v -> PatternSeg v
SegCap Capture NpmCap
capTag]

-- @PUT \/-\/package\/{package}\/dist-tags\/{tag}@: a documented @501@ boundary.
distTagSetRoute :: Route NpmCap
distTagSetRoute :: Route NpmCap
distTagSetRoute =
    RouteName
-> MethodMatch
-> MediaNegotiation (ResponseValue NpmError)
-> [PatternSeg NpmCap]
-> (ByteString
    -> [NpmCap] -> Maybe (ResponseAction (ResponseValue NpmError)))
-> Text
-> Text
-> Maybe RequestSpec
-> ResponseContract (ResponseValue NpmError)
-> Route NpmCap
forall v response.
RouteName
-> MethodMatch
-> MediaNegotiation response
-> [PatternSeg v]
-> (ByteString -> [v] -> Maybe (ResponseAction response))
-> Text
-> Text
-> Maybe RequestSpec
-> ResponseContract response
-> Route v
Route
        (Text -> RouteName
RouteName Text
"distTagSet")
        MethodMatch
MethodPut
        MediaNegotiation (ResponseValue NpmError)
forall response. MediaNegotiation response
AcceptsAnything
        [PatternSeg NpmCap]
distTagTagSegs
        (ResponseValue NpmError
-> ByteString
-> [NpmCap]
-> Maybe (ResponseAction (ResponseValue NpmError))
forall response v.
response -> ByteString -> [v] -> Maybe (ResponseAction response)
answering ResponseValue NpmError
distTagAnswer)
        Text
"Set a package's dist-tag (not supported)"
        Text
"Écluse writes no mutable named pointer, so it returns `501` rather than the `404` an \
        \unrouted path takes. The publication target owns a package's tags, and a publisher sets \
        \them there."
        Maybe RequestSpec
forall a. Maybe a
Nothing
        ResponseContract (ResponseValue NpmError)
distTagContract

-- @DELETE \/-\/package\/{package}\/dist-tags\/{tag}@: a documented @501@ boundary.
distTagRemoveRoute :: Route NpmCap
distTagRemoveRoute :: Route NpmCap
distTagRemoveRoute =
    RouteName
-> MethodMatch
-> MediaNegotiation (ResponseValue NpmError)
-> [PatternSeg NpmCap]
-> (ByteString
    -> [NpmCap] -> Maybe (ResponseAction (ResponseValue NpmError)))
-> Text
-> Text
-> Maybe RequestSpec
-> ResponseContract (ResponseValue NpmError)
-> Route NpmCap
forall v response.
RouteName
-> MethodMatch
-> MediaNegotiation response
-> [PatternSeg v]
-> (ByteString -> [v] -> Maybe (ResponseAction response))
-> Text
-> Text
-> Maybe RequestSpec
-> ResponseContract response
-> Route v
Route
        (Text -> RouteName
RouteName Text
"distTagRemove")
        MethodMatch
MethodDelete
        MediaNegotiation (ResponseValue NpmError)
forall response. MediaNegotiation response
AcceptsAnything
        [PatternSeg NpmCap]
distTagTagSegs
        (ResponseValue NpmError
-> ByteString
-> [NpmCap]
-> Maybe (ResponseAction (ResponseValue NpmError))
forall response v.
response -> ByteString -> [v] -> Maybe (ResponseAction response)
answering ResponseValue NpmError
distTagAnswer)
        Text
"Remove a package's dist-tag (not supported)"
        Text
"Écluse holds no mutable named pointer to remove, so it returns `501` rather than the `404` \
        \an unrouted path takes. The publication target owns a package's tags, and a publisher \
        \removes them there."
        Maybe RequestSpec
forall a. Maybe a
Nothing
        ResponseContract (ResponseValue NpmError)
distTagContract

-- @GET \/{package}\/-\/{filename}@: a package artifact, streamed.
tarballRoute :: Route NpmCap
tarballRoute :: Route NpmCap
tarballRoute =
    RouteName
-> MethodMatch
-> MediaNegotiation PassthroughResponse
-> [PatternSeg NpmCap]
-> (ByteString
    -> [NpmCap] -> Maybe (ResponseAction PassthroughResponse))
-> Text
-> Text
-> Maybe RequestSpec
-> ResponseContract PassthroughResponse
-> Route NpmCap
forall v response.
RouteName
-> MethodMatch
-> MediaNegotiation response
-> [PatternSeg v]
-> (ByteString -> [v] -> Maybe (ResponseAction response))
-> Text
-> Text
-> Maybe RequestSpec
-> ResponseContract response
-> Route v
Route
        (Text -> RouteName
RouteName Text
"tarball")
        MethodMatch
MethodRead
        MediaNegotiation PassthroughResponse
forall response. MediaNegotiation response
AcceptsAnything
        [Capture NpmCap -> PatternSeg NpmCap
forall v. Capture v -> PatternSeg v
SegCap Capture NpmCap
capPackage, Text -> PatternSeg NpmCap
forall v. Text -> PatternSeg v
SegLit Text
"-", Capture NpmCap -> PatternSeg NpmCap
forall v. Capture v -> PatternSeg v
SegCap Capture NpmCap
capFilename]
        ByteString
-> [NpmCap] -> Maybe (ResponseAction PassthroughResponse)
buildTarball
        Text
"Stream a package artifact (tarball)"
        Text
"The artifact bytes are streamed verbatim with bounded memory; the client verifies the bytes \
        \against the packument's preserved integrity digest. Upstream statuses, headers, and media \
        \types are relayed transparently; locally generated refusals use npm's JSON error shape."
        Maybe RequestSpec
forall a. Maybe a
Nothing
        ResponseContract PassthroughResponse
npmTarballContract

-- @GET \/{package}@: the merged, gated packument.
packumentRoute :: Route NpmCap
packumentRoute :: Route NpmCap
packumentRoute =
    RouteName
-> MethodMatch
-> MediaNegotiation NpmPackumentResponse
-> [PatternSeg NpmCap]
-> (ByteString
    -> [NpmCap] -> Maybe (ResponseAction NpmPackumentResponse))
-> Text
-> Text
-> Maybe RequestSpec
-> ResponseContract NpmPackumentResponse
-> Route NpmCap
forall v response.
RouteName
-> MethodMatch
-> MediaNegotiation response
-> [PatternSeg v]
-> (ByteString -> [v] -> Maybe (ResponseAction response))
-> Text
-> Text
-> Maybe RequestSpec
-> ResponseContract response
-> Route v
Route
        (Text -> RouteName
RouteName Text
"packument")
        MethodMatch
MethodRead
        MediaNegotiation NpmPackumentResponse
forall response. MediaNegotiation response
AcceptsAnything
        [Capture NpmCap -> PatternSeg NpmCap
forall v. Capture v -> PatternSeg v
SegCap Capture NpmCap
capPackage]
        ByteString
-> [NpmCap] -> Maybe (ResponseAction NpmPackumentResponse)
buildPackument
        Text
"Fetch a package's metadata (packument)"
        Text
"Returns Écluse's merged-and-filtered packument: versions merged across upstreams and gated, \
        \each `dist.tarball` rewritten to resolve back through this proxy. With no surviving version \
        \the status follows the most recoverable cause."
        Maybe RequestSpec
forall a. Maybe a
Nothing
        ResponseContract NpmPackumentResponse
npmPackumentContract

-- @PUT \/{package}@: a first-party publish, relayed after the anti-shadowing guard.
publishRoute :: Route NpmCap
publishRoute :: Route NpmCap
publishRoute =
    RouteName
-> MethodMatch
-> MediaNegotiation NpmPublishResponse
-> [PatternSeg NpmCap]
-> (ByteString
    -> [NpmCap] -> Maybe (ResponseAction NpmPublishResponse))
-> Text
-> Text
-> Maybe RequestSpec
-> ResponseContract NpmPublishResponse
-> Route NpmCap
forall v response.
RouteName
-> MethodMatch
-> MediaNegotiation response
-> [PatternSeg v]
-> (ByteString -> [v] -> Maybe (ResponseAction response))
-> Text
-> Text
-> Maybe RequestSpec
-> ResponseContract response
-> Route v
Route
        (Text -> RouteName
RouteName Text
"publish")
        MethodMatch
MethodPut
        MediaNegotiation NpmPublishResponse
forall response. MediaNegotiation response
AcceptsAnything
        [Capture NpmCap -> PatternSeg NpmCap
forall v. Capture v -> PatternSeg v
SegCap Capture NpmCap
capPackage]
        ByteString -> [NpmCap] -> Maybe (ResponseAction NpmPublishResponse)
buildPublish
        Text
"Publish a first-party package"
        Text
"Relays the publish document to the configured publication target after the anti-shadowing \
        \scope guard. Écluse keys the write on the route's package name, never the document's \
        \self-reported name. The target's status and JSON-labelled bytes are relayed transparently."
        (RequestSpec -> Maybe RequestSpec
forall a. a -> Maybe a
Just RequestSpec
publishRequest)
        ResponseContract NpmPublishResponse
npmPublishContract

-- The named hand-authored schemas the manifest holds for the documents Écluse builds
-- imperatively rather than round-tripping through a codec.
synthesizedPackumentSchema :: Text
synthesizedPackumentSchema :: Text
synthesizedPackumentSchema = Text
"SynthesizedPackument"

publishDocumentSchema :: Text
publishDocumentSchema :: Text
publishDocumentSchema = Text
"PublishDocument"

-- The publish document a @PUT@ accepts, documented by its hand-authored schema.
publishRequest :: RequestSpec
publishRequest :: RequestSpec
publishRequest =
    Text -> Bool -> BodySchema -> RequestSpec
RequestSpec
        Text
"The npm publish document (the version manifest plus the base64-encoded tarball in `_attachments`)."
        Bool
True
        (ByteString -> Text -> BodySchema
SchemaDocumented ByteString
"application/json" Text
publishDocumentSchema)

-- The empty-object codec: encodes @()@ to @{}@ and documents an empty object schema.
emptyObjectCodec :: JSONCodec ()
emptyObjectCodec :: JSONCodec ()
emptyObjectCodec = Text -> ObjectCodec () () -> JSONCodec ()
forall input output.
Text -> ObjectCodec input output -> ValueCodec input output
object Text
"EmptyObject" (() -> ObjectCodec () ()
forall output input. output -> ObjectCodec input output
pureCodec ())

pingContract :: ResponseContract (ResponseValue ())
pingContract :: ResponseContract (ResponseValue ())
pingContract = Status
-> Text -> JSONCodec () -> ResponseContract (ResponseValue ())
forall a.
Status -> Text -> JSONCodec a -> ResponseContract (ResponseValue a)
jsonContract Status
status200 Text
"An empty object." JSONCodec ()
emptyObjectCodec

searchContract :: ResponseContract (ResponseValue NpmError)
searchContract :: ResponseContract (ResponseValue NpmError)
searchContract = Status
-> Text
-> JSONCodec NpmError
-> ResponseContract (ResponseValue NpmError)
forall a.
Status -> Text -> JSONCodec a -> ResponseContract (ResponseValue a)
jsonContract Status
status501 Text
"Not implemented: search is not supported." JSONCodec NpmError
npmErrorCodec

-- No dist-tag operation is implemented, so the read, the write, and the removal share one contract.
distTagContract :: ResponseContract (ResponseValue NpmError)
distTagContract :: ResponseContract (ResponseValue NpmError)
distTagContract = Status
-> Text
-> JSONCodec NpmError
-> ResponseContract (ResponseValue NpmError)
forall a.
Status -> Text -> JSONCodec a -> ResponseContract (ResponseValue a)
jsonContract Status
status501 Text
"Not implemented: dist-tags are not supported." JSONCodec NpmError
npmErrorCodec

unsupportedContract :: ResponseContract (ResponseValue NpmError)
unsupportedContract :: ResponseContract (ResponseValue NpmError)
unsupportedContract = Status
-> Text
-> JSONCodec NpmError
-> ResponseContract (ResponseValue NpmError)
forall a.
Status -> Text -> JSONCodec a -> ResponseContract (ResponseValue a)
jsonContract Status
status404 Text
"Unrecognised path; deny by default." JSONCodec NpmError
npmErrorCodec

-- | The closed packument response sum. The pipeline selects a constructor only through 'npmPackumentReplies'.
type NpmPackumentResponse =
    ResponseChoice
        (ResponseValue LByteString)
        ( ResponseChoice
            (ResponseValue ())
            ( ResponseChoice
                (ResponseValue NpmError)
                ( ResponseChoice
                    (ResponseValue NpmError)
                    ( ResponseChoice
                        (ResponseValue NpmError)
                        ( ResponseChoice
                            (ResponseValue NpmError)
                            (ResponseChoice (ResponseValue NpmError) (ResponseValue NpmError))
                        )
                    )
                )
            )
        )

npmPackumentContract :: ResponseContract NpmPackumentResponse
npmPackumentContract :: ResponseContract NpmPackumentResponse
npmPackumentContract =
    ResponseContract (ResponseValue LByteString)
-> ResponseContract
     (ResponseChoice
        (ResponseValue ())
        (ResponseChoice
           (ResponseValue NpmError)
           (ResponseChoice
              (ResponseValue NpmError)
              (ResponseChoice
                 (ResponseValue NpmError)
                 (ResponseChoice
                    (ResponseValue NpmError)
                    (ResponseChoice
                       (ResponseValue NpmError) (ResponseValue NpmError)))))))
-> ResponseContract NpmPackumentResponse
forall a b.
ResponseContract a
-> ResponseContract b -> ResponseContract (ResponseChoice a b)
chooseContract
        (Status
-> Text -> Text -> ResponseContract (ResponseValue LByteString)
documentedJsonContract Status
status200 Text
"The synthesized packument." Text
synthesizedPackumentSchema)
        ( ResponseContract (ResponseValue ())
-> ResponseContract
     (ResponseChoice
        (ResponseValue NpmError)
        (ResponseChoice
           (ResponseValue NpmError)
           (ResponseChoice
              (ResponseValue NpmError)
              (ResponseChoice
                 (ResponseValue NpmError)
                 (ResponseChoice
                    (ResponseValue NpmError) (ResponseValue NpmError))))))
-> ResponseContract
     (ResponseChoice
        (ResponseValue ())
        (ResponseChoice
           (ResponseValue NpmError)
           (ResponseChoice
              (ResponseValue NpmError)
              (ResponseChoice
                 (ResponseValue NpmError)
                 (ResponseChoice
                    (ResponseValue NpmError)
                    (ResponseChoice
                       (ResponseValue NpmError) (ResponseValue NpmError)))))))
forall a b.
ResponseContract a
-> ResponseContract b -> ResponseContract (ResponseChoice a b)
chooseContract
            (Status -> Text -> ResponseContract (ResponseValue ())
emptyContract Status
status304 Text
"The client's validator matched the synthesized packument.")
            ( ResponseContract (ResponseValue NpmError)
-> ResponseContract
     (ResponseChoice
        (ResponseValue NpmError)
        (ResponseChoice
           (ResponseValue NpmError)
           (ResponseChoice
              (ResponseValue NpmError)
              (ResponseChoice
                 (ResponseValue NpmError) (ResponseValue NpmError)))))
-> ResponseContract
     (ResponseChoice
        (ResponseValue NpmError)
        (ResponseChoice
           (ResponseValue NpmError)
           (ResponseChoice
              (ResponseValue NpmError)
              (ResponseChoice
                 (ResponseValue NpmError)
                 (ResponseChoice
                    (ResponseValue NpmError) (ResponseValue NpmError))))))
forall a b.
ResponseContract a
-> ResponseContract b -> ResponseContract (ResponseChoice a b)
chooseContract
                (Status
-> Text
-> JSONCodec NpmError
-> ResponseContract (ResponseValue NpmError)
forall a.
Status -> Text -> JSONCodec a -> ResponseContract (ResponseValue a)
jsonContract Status
status401 Text
"Edge authentication failed." JSONCodec NpmError
npmErrorCodec)
                ( ResponseContract (ResponseValue NpmError)
-> ResponseContract
     (ResponseChoice
        (ResponseValue NpmError)
        (ResponseChoice
           (ResponseValue NpmError)
           (ResponseChoice
              (ResponseValue NpmError) (ResponseValue NpmError))))
-> ResponseContract
     (ResponseChoice
        (ResponseValue NpmError)
        (ResponseChoice
           (ResponseValue NpmError)
           (ResponseChoice
              (ResponseValue NpmError)
              (ResponseChoice
                 (ResponseValue NpmError) (ResponseValue NpmError)))))
forall a b.
ResponseContract a
-> ResponseContract b -> ResponseContract (ResponseChoice a b)
chooseContract
                    (Status
-> Text
-> JSONCodec NpmError
-> ResponseContract (ResponseValue NpmError)
forall a.
Status -> Text -> JSONCodec a -> ResponseContract (ResponseValue a)
jsonContract Status
status403 Text
"Private access was refused, or no version survived policy and admission." JSONCodec NpmError
npmErrorCodec)
                    ( ResponseContract (ResponseValue NpmError)
-> ResponseContract
     (ResponseChoice
        (ResponseValue NpmError)
        (ResponseChoice (ResponseValue NpmError) (ResponseValue NpmError)))
-> ResponseContract
     (ResponseChoice
        (ResponseValue NpmError)
        (ResponseChoice
           (ResponseValue NpmError)
           (ResponseChoice
              (ResponseValue NpmError) (ResponseValue NpmError))))
forall a b.
ResponseContract a
-> ResponseContract b -> ResponseContract (ResponseChoice a b)
chooseContract
                        (Status
-> Text
-> JSONCodec NpmError
-> ResponseContract (ResponseValue NpmError)
forall a.
Status -> Text -> JSONCodec a -> ResponseContract (ResponseValue a)
jsonContract Status
status404 Text
"A first-party name the private upstream does not have. It is never fetched from the public upstream." JSONCodec NpmError
npmErrorCodec)
                        ( ResponseContract (ResponseValue NpmError)
-> ResponseContract
     (ResponseChoice (ResponseValue NpmError) (ResponseValue NpmError))
-> ResponseContract
     (ResponseChoice
        (ResponseValue NpmError)
        (ResponseChoice (ResponseValue NpmError) (ResponseValue NpmError)))
forall a b.
ResponseContract a
-> ResponseContract b -> ResponseContract (ResponseChoice a b)
chooseContract
                            (Status
-> Text
-> JSONCodec NpmError
-> ResponseContract (ResponseValue NpmError)
forall a.
Status -> Text -> JSONCodec a -> ResponseContract (ResponseValue a)
jsonContract Status
status500 Text
"A permanent or internal inability to decide." JSONCodec NpmError
npmErrorCodec)
                            ( ResponseContract (ResponseValue NpmError)
-> ResponseContract (ResponseValue NpmError)
-> ResponseContract
     (ResponseChoice (ResponseValue NpmError) (ResponseValue NpmError))
forall a b.
ResponseContract a
-> ResponseContract b -> ResponseContract (ResponseChoice a b)
chooseContract
                                (Status
-> Text
-> JSONCodec NpmError
-> ResponseContract (ResponseValue NpmError)
forall a.
Status -> Text -> JSONCodec a -> ResponseContract (ResponseValue a)
jsonContract Status
status502 Text
"A responding upstream returned a packument for a different package." JSONCodec NpmError
npmErrorCodec)
                                (Status
-> Text
-> JSONCodec NpmError
-> ResponseContract (ResponseValue NpmError)
forall a.
Status -> Text -> JSONCodec a -> ResponseContract (ResponseValue a)
jsonContract Status
status503 Text
"A transient upstream or advisory condition; retry (see `Retry-After`)." JSONCodec NpmError
npmErrorCodec)
                            )
                        )
                    )
                )
            )
        )

npmPackumentReplies :: PackumentReplies NpmPackumentResponse
npmPackumentReplies :: PackumentReplies NpmPackumentResponse
npmPackumentReplies =
    PackumentReplies
        { packumentOk :: [Header] -> LByteString -> NpmPackumentResponse
packumentOk = \[Header]
headers LByteString
body -> ResponseValue LByteString -> NpmPackumentResponse
forall a b. a -> ResponseChoice a b
FirstResponse ([Header] -> LByteString -> ResponseValue LByteString
forall a. [Header] -> a -> ResponseValue a
responseValue [Header]
headers LByteString
body)
        , packumentNotModified :: [Header] -> NpmPackumentResponse
packumentNotModified = \[Header]
headers -> ResponseChoice
  (ResponseValue ())
  (ResponseChoice
     (ResponseValue NpmError)
     (ResponseChoice
        (ResponseValue NpmError)
        (ResponseChoice
           (ResponseValue NpmError)
           (ResponseChoice
              (ResponseValue NpmError)
              (ResponseChoice
                 (ResponseValue NpmError) (ResponseValue NpmError))))))
-> NpmPackumentResponse
forall a b. b -> ResponseChoice a b
SecondResponse (ResponseValue ()
-> ResponseChoice
     (ResponseValue ())
     (ResponseChoice
        (ResponseValue NpmError)
        (ResponseChoice
           (ResponseValue NpmError)
           (ResponseChoice
              (ResponseValue NpmError)
              (ResponseChoice
                 (ResponseValue NpmError)
                 (ResponseChoice
                    (ResponseValue NpmError) (ResponseValue NpmError))))))
forall a b. a -> ResponseChoice a b
FirstResponse ([Header] -> () -> ResponseValue ()
forall a. [Header] -> a -> ResponseValue a
responseValue [Header]
headers ()))
        , packumentUnauthorised :: [Header] -> Refusal -> NpmPackumentResponse
packumentUnauthorised = \[Header]
headers Refusal
message -> ResponseChoice
  (ResponseValue ())
  (ResponseChoice
     (ResponseValue NpmError)
     (ResponseChoice
        (ResponseValue NpmError)
        (ResponseChoice
           (ResponseValue NpmError)
           (ResponseChoice
              (ResponseValue NpmError)
              (ResponseChoice
                 (ResponseValue NpmError) (ResponseValue NpmError))))))
-> NpmPackumentResponse
forall a b. b -> ResponseChoice a b
SecondResponse (ResponseChoice
  (ResponseValue NpmError)
  (ResponseChoice
     (ResponseValue NpmError)
     (ResponseChoice
        (ResponseValue NpmError)
        (ResponseChoice
           (ResponseValue NpmError)
           (ResponseChoice
              (ResponseValue NpmError) (ResponseValue NpmError)))))
-> ResponseChoice
     (ResponseValue ())
     (ResponseChoice
        (ResponseValue NpmError)
        (ResponseChoice
           (ResponseValue NpmError)
           (ResponseChoice
              (ResponseValue NpmError)
              (ResponseChoice
                 (ResponseValue NpmError)
                 (ResponseChoice
                    (ResponseValue NpmError) (ResponseValue NpmError))))))
forall a b. b -> ResponseChoice a b
SecondResponse (ResponseValue NpmError
-> ResponseChoice
     (ResponseValue NpmError)
     (ResponseChoice
        (ResponseValue NpmError)
        (ResponseChoice
           (ResponseValue NpmError)
           (ResponseChoice
              (ResponseValue NpmError)
              (ResponseChoice
                 (ResponseValue NpmError) (ResponseValue NpmError)))))
forall a b. a -> ResponseChoice a b
FirstResponse ([Header] -> NpmError -> ResponseValue NpmError
forall a. [Header] -> a -> ResponseValue a
responseValue [Header]
headers (Text -> NpmError
NpmError (Refusal -> Text
renderRefusal Refusal
message)))))
        , packumentForbidden :: [Header] -> Refusal -> NpmPackumentResponse
packumentForbidden = \[Header]
headers Refusal
message -> ResponseChoice
  (ResponseValue ())
  (ResponseChoice
     (ResponseValue NpmError)
     (ResponseChoice
        (ResponseValue NpmError)
        (ResponseChoice
           (ResponseValue NpmError)
           (ResponseChoice
              (ResponseValue NpmError)
              (ResponseChoice
                 (ResponseValue NpmError) (ResponseValue NpmError))))))
-> NpmPackumentResponse
forall a b. b -> ResponseChoice a b
SecondResponse (ResponseChoice
  (ResponseValue NpmError)
  (ResponseChoice
     (ResponseValue NpmError)
     (ResponseChoice
        (ResponseValue NpmError)
        (ResponseChoice
           (ResponseValue NpmError)
           (ResponseChoice
              (ResponseValue NpmError) (ResponseValue NpmError)))))
-> ResponseChoice
     (ResponseValue ())
     (ResponseChoice
        (ResponseValue NpmError)
        (ResponseChoice
           (ResponseValue NpmError)
           (ResponseChoice
              (ResponseValue NpmError)
              (ResponseChoice
                 (ResponseValue NpmError)
                 (ResponseChoice
                    (ResponseValue NpmError) (ResponseValue NpmError))))))
forall a b. b -> ResponseChoice a b
SecondResponse (ResponseChoice
  (ResponseValue NpmError)
  (ResponseChoice
     (ResponseValue NpmError)
     (ResponseChoice
        (ResponseValue NpmError)
        (ResponseChoice
           (ResponseValue NpmError) (ResponseValue NpmError))))
-> ResponseChoice
     (ResponseValue NpmError)
     (ResponseChoice
        (ResponseValue NpmError)
        (ResponseChoice
           (ResponseValue NpmError)
           (ResponseChoice
              (ResponseValue NpmError)
              (ResponseChoice
                 (ResponseValue NpmError) (ResponseValue NpmError)))))
forall a b. b -> ResponseChoice a b
SecondResponse (ResponseValue NpmError
-> ResponseChoice
     (ResponseValue NpmError)
     (ResponseChoice
        (ResponseValue NpmError)
        (ResponseChoice
           (ResponseValue NpmError)
           (ResponseChoice
              (ResponseValue NpmError) (ResponseValue NpmError))))
forall a b. a -> ResponseChoice a b
FirstResponse ([Header] -> NpmError -> ResponseValue NpmError
forall a. [Header] -> a -> ResponseValue a
responseValue [Header]
headers (Text -> NpmError
NpmError (Refusal -> Text
renderRefusal Refusal
message))))))
        , packumentNotFound :: [Header] -> Refusal -> NpmPackumentResponse
packumentNotFound = \[Header]
headers Refusal
message -> ResponseChoice
  (ResponseValue ())
  (ResponseChoice
     (ResponseValue NpmError)
     (ResponseChoice
        (ResponseValue NpmError)
        (ResponseChoice
           (ResponseValue NpmError)
           (ResponseChoice
              (ResponseValue NpmError)
              (ResponseChoice
                 (ResponseValue NpmError) (ResponseValue NpmError))))))
-> NpmPackumentResponse
forall a b. b -> ResponseChoice a b
SecondResponse (ResponseChoice
  (ResponseValue NpmError)
  (ResponseChoice
     (ResponseValue NpmError)
     (ResponseChoice
        (ResponseValue NpmError)
        (ResponseChoice
           (ResponseValue NpmError)
           (ResponseChoice
              (ResponseValue NpmError) (ResponseValue NpmError)))))
-> ResponseChoice
     (ResponseValue ())
     (ResponseChoice
        (ResponseValue NpmError)
        (ResponseChoice
           (ResponseValue NpmError)
           (ResponseChoice
              (ResponseValue NpmError)
              (ResponseChoice
                 (ResponseValue NpmError)
                 (ResponseChoice
                    (ResponseValue NpmError) (ResponseValue NpmError))))))
forall a b. b -> ResponseChoice a b
SecondResponse (ResponseChoice
  (ResponseValue NpmError)
  (ResponseChoice
     (ResponseValue NpmError)
     (ResponseChoice
        (ResponseValue NpmError)
        (ResponseChoice
           (ResponseValue NpmError) (ResponseValue NpmError))))
-> ResponseChoice
     (ResponseValue NpmError)
     (ResponseChoice
        (ResponseValue NpmError)
        (ResponseChoice
           (ResponseValue NpmError)
           (ResponseChoice
              (ResponseValue NpmError)
              (ResponseChoice
                 (ResponseValue NpmError) (ResponseValue NpmError)))))
forall a b. b -> ResponseChoice a b
SecondResponse (ResponseChoice
  (ResponseValue NpmError)
  (ResponseChoice
     (ResponseValue NpmError)
     (ResponseChoice (ResponseValue NpmError) (ResponseValue NpmError)))
-> ResponseChoice
     (ResponseValue NpmError)
     (ResponseChoice
        (ResponseValue NpmError)
        (ResponseChoice
           (ResponseValue NpmError)
           (ResponseChoice
              (ResponseValue NpmError) (ResponseValue NpmError))))
forall a b. b -> ResponseChoice a b
SecondResponse (ResponseValue NpmError
-> ResponseChoice
     (ResponseValue NpmError)
     (ResponseChoice
        (ResponseValue NpmError)
        (ResponseChoice (ResponseValue NpmError) (ResponseValue NpmError)))
forall a b. a -> ResponseChoice a b
FirstResponse ([Header] -> NpmError -> ResponseValue NpmError
forall a. [Header] -> a -> ResponseValue a
responseValue [Header]
headers (Text -> NpmError
NpmError (Refusal -> Text
renderRefusal Refusal
message)))))))
        , packumentInternal :: [Header] -> Refusal -> NpmPackumentResponse
packumentInternal = \[Header]
headers Refusal
message -> ResponseChoice
  (ResponseValue ())
  (ResponseChoice
     (ResponseValue NpmError)
     (ResponseChoice
        (ResponseValue NpmError)
        (ResponseChoice
           (ResponseValue NpmError)
           (ResponseChoice
              (ResponseValue NpmError)
              (ResponseChoice
                 (ResponseValue NpmError) (ResponseValue NpmError))))))
-> NpmPackumentResponse
forall a b. b -> ResponseChoice a b
SecondResponse (ResponseChoice
  (ResponseValue NpmError)
  (ResponseChoice
     (ResponseValue NpmError)
     (ResponseChoice
        (ResponseValue NpmError)
        (ResponseChoice
           (ResponseValue NpmError)
           (ResponseChoice
              (ResponseValue NpmError) (ResponseValue NpmError)))))
-> ResponseChoice
     (ResponseValue ())
     (ResponseChoice
        (ResponseValue NpmError)
        (ResponseChoice
           (ResponseValue NpmError)
           (ResponseChoice
              (ResponseValue NpmError)
              (ResponseChoice
                 (ResponseValue NpmError)
                 (ResponseChoice
                    (ResponseValue NpmError) (ResponseValue NpmError))))))
forall a b. b -> ResponseChoice a b
SecondResponse (ResponseChoice
  (ResponseValue NpmError)
  (ResponseChoice
     (ResponseValue NpmError)
     (ResponseChoice
        (ResponseValue NpmError)
        (ResponseChoice
           (ResponseValue NpmError) (ResponseValue NpmError))))
-> ResponseChoice
     (ResponseValue NpmError)
     (ResponseChoice
        (ResponseValue NpmError)
        (ResponseChoice
           (ResponseValue NpmError)
           (ResponseChoice
              (ResponseValue NpmError)
              (ResponseChoice
                 (ResponseValue NpmError) (ResponseValue NpmError)))))
forall a b. b -> ResponseChoice a b
SecondResponse (ResponseChoice
  (ResponseValue NpmError)
  (ResponseChoice
     (ResponseValue NpmError)
     (ResponseChoice (ResponseValue NpmError) (ResponseValue NpmError)))
-> ResponseChoice
     (ResponseValue NpmError)
     (ResponseChoice
        (ResponseValue NpmError)
        (ResponseChoice
           (ResponseValue NpmError)
           (ResponseChoice
              (ResponseValue NpmError) (ResponseValue NpmError))))
forall a b. b -> ResponseChoice a b
SecondResponse (ResponseChoice
  (ResponseValue NpmError)
  (ResponseChoice (ResponseValue NpmError) (ResponseValue NpmError))
-> ResponseChoice
     (ResponseValue NpmError)
     (ResponseChoice
        (ResponseValue NpmError)
        (ResponseChoice (ResponseValue NpmError) (ResponseValue NpmError)))
forall a b. b -> ResponseChoice a b
SecondResponse (ResponseValue NpmError
-> ResponseChoice
     (ResponseValue NpmError)
     (ResponseChoice (ResponseValue NpmError) (ResponseValue NpmError))
forall a b. a -> ResponseChoice a b
FirstResponse ([Header] -> NpmError -> ResponseValue NpmError
forall a. [Header] -> a -> ResponseValue a
responseValue [Header]
headers (Text -> NpmError
NpmError (Refusal -> Text
renderRefusal Refusal
message))))))))
        , packumentBadGateway :: [Header] -> Refusal -> NpmPackumentResponse
packumentBadGateway = \[Header]
headers Refusal
message -> ResponseChoice
  (ResponseValue ())
  (ResponseChoice
     (ResponseValue NpmError)
     (ResponseChoice
        (ResponseValue NpmError)
        (ResponseChoice
           (ResponseValue NpmError)
           (ResponseChoice
              (ResponseValue NpmError)
              (ResponseChoice
                 (ResponseValue NpmError) (ResponseValue NpmError))))))
-> NpmPackumentResponse
forall a b. b -> ResponseChoice a b
SecondResponse (ResponseChoice
  (ResponseValue NpmError)
  (ResponseChoice
     (ResponseValue NpmError)
     (ResponseChoice
        (ResponseValue NpmError)
        (ResponseChoice
           (ResponseValue NpmError)
           (ResponseChoice
              (ResponseValue NpmError) (ResponseValue NpmError)))))
-> ResponseChoice
     (ResponseValue ())
     (ResponseChoice
        (ResponseValue NpmError)
        (ResponseChoice
           (ResponseValue NpmError)
           (ResponseChoice
              (ResponseValue NpmError)
              (ResponseChoice
                 (ResponseValue NpmError)
                 (ResponseChoice
                    (ResponseValue NpmError) (ResponseValue NpmError))))))
forall a b. b -> ResponseChoice a b
SecondResponse (ResponseChoice
  (ResponseValue NpmError)
  (ResponseChoice
     (ResponseValue NpmError)
     (ResponseChoice
        (ResponseValue NpmError)
        (ResponseChoice
           (ResponseValue NpmError) (ResponseValue NpmError))))
-> ResponseChoice
     (ResponseValue NpmError)
     (ResponseChoice
        (ResponseValue NpmError)
        (ResponseChoice
           (ResponseValue NpmError)
           (ResponseChoice
              (ResponseValue NpmError)
              (ResponseChoice
                 (ResponseValue NpmError) (ResponseValue NpmError)))))
forall a b. b -> ResponseChoice a b
SecondResponse (ResponseChoice
  (ResponseValue NpmError)
  (ResponseChoice
     (ResponseValue NpmError)
     (ResponseChoice (ResponseValue NpmError) (ResponseValue NpmError)))
-> ResponseChoice
     (ResponseValue NpmError)
     (ResponseChoice
        (ResponseValue NpmError)
        (ResponseChoice
           (ResponseValue NpmError)
           (ResponseChoice
              (ResponseValue NpmError) (ResponseValue NpmError))))
forall a b. b -> ResponseChoice a b
SecondResponse (ResponseChoice
  (ResponseValue NpmError)
  (ResponseChoice (ResponseValue NpmError) (ResponseValue NpmError))
-> ResponseChoice
     (ResponseValue NpmError)
     (ResponseChoice
        (ResponseValue NpmError)
        (ResponseChoice (ResponseValue NpmError) (ResponseValue NpmError)))
forall a b. b -> ResponseChoice a b
SecondResponse (ResponseChoice (ResponseValue NpmError) (ResponseValue NpmError)
-> ResponseChoice
     (ResponseValue NpmError)
     (ResponseChoice (ResponseValue NpmError) (ResponseValue NpmError))
forall a b. b -> ResponseChoice a b
SecondResponse (ResponseValue NpmError
-> ResponseChoice (ResponseValue NpmError) (ResponseValue NpmError)
forall a b. a -> ResponseChoice a b
FirstResponse ([Header] -> NpmError -> ResponseValue NpmError
forall a. [Header] -> a -> ResponseValue a
responseValue [Header]
headers (Text -> NpmError
NpmError (Refusal -> Text
renderRefusal Refusal
message)))))))))
        , packumentUnavailable :: [Header] -> Refusal -> NpmPackumentResponse
packumentUnavailable = \[Header]
headers Refusal
message -> ResponseChoice
  (ResponseValue ())
  (ResponseChoice
     (ResponseValue NpmError)
     (ResponseChoice
        (ResponseValue NpmError)
        (ResponseChoice
           (ResponseValue NpmError)
           (ResponseChoice
              (ResponseValue NpmError)
              (ResponseChoice
                 (ResponseValue NpmError) (ResponseValue NpmError))))))
-> NpmPackumentResponse
forall a b. b -> ResponseChoice a b
SecondResponse (ResponseChoice
  (ResponseValue NpmError)
  (ResponseChoice
     (ResponseValue NpmError)
     (ResponseChoice
        (ResponseValue NpmError)
        (ResponseChoice
           (ResponseValue NpmError)
           (ResponseChoice
              (ResponseValue NpmError) (ResponseValue NpmError)))))
-> ResponseChoice
     (ResponseValue ())
     (ResponseChoice
        (ResponseValue NpmError)
        (ResponseChoice
           (ResponseValue NpmError)
           (ResponseChoice
              (ResponseValue NpmError)
              (ResponseChoice
                 (ResponseValue NpmError)
                 (ResponseChoice
                    (ResponseValue NpmError) (ResponseValue NpmError))))))
forall a b. b -> ResponseChoice a b
SecondResponse (ResponseChoice
  (ResponseValue NpmError)
  (ResponseChoice
     (ResponseValue NpmError)
     (ResponseChoice
        (ResponseValue NpmError)
        (ResponseChoice
           (ResponseValue NpmError) (ResponseValue NpmError))))
-> ResponseChoice
     (ResponseValue NpmError)
     (ResponseChoice
        (ResponseValue NpmError)
        (ResponseChoice
           (ResponseValue NpmError)
           (ResponseChoice
              (ResponseValue NpmError)
              (ResponseChoice
                 (ResponseValue NpmError) (ResponseValue NpmError)))))
forall a b. b -> ResponseChoice a b
SecondResponse (ResponseChoice
  (ResponseValue NpmError)
  (ResponseChoice
     (ResponseValue NpmError)
     (ResponseChoice (ResponseValue NpmError) (ResponseValue NpmError)))
-> ResponseChoice
     (ResponseValue NpmError)
     (ResponseChoice
        (ResponseValue NpmError)
        (ResponseChoice
           (ResponseValue NpmError)
           (ResponseChoice
              (ResponseValue NpmError) (ResponseValue NpmError))))
forall a b. b -> ResponseChoice a b
SecondResponse (ResponseChoice
  (ResponseValue NpmError)
  (ResponseChoice (ResponseValue NpmError) (ResponseValue NpmError))
-> ResponseChoice
     (ResponseValue NpmError)
     (ResponseChoice
        (ResponseValue NpmError)
        (ResponseChoice (ResponseValue NpmError) (ResponseValue NpmError)))
forall a b. b -> ResponseChoice a b
SecondResponse (ResponseChoice (ResponseValue NpmError) (ResponseValue NpmError)
-> ResponseChoice
     (ResponseValue NpmError)
     (ResponseChoice (ResponseValue NpmError) (ResponseValue NpmError))
forall a b. b -> ResponseChoice a b
SecondResponse (ResponseValue NpmError
-> ResponseChoice (ResponseValue NpmError) (ResponseValue NpmError)
forall a b. b -> ResponseChoice a b
SecondResponse ([Header] -> NpmError -> ResponseValue NpmError
forall a. [Header] -> a -> ResponseValue a
responseValue [Header]
headers (Text -> NpmError
NpmError (Refusal -> Text
renderRefusal Refusal
message)))))))))
        }

-- | The tarball is deliberately an open relay: the route can forward any upstream status, headers, media type, and bytes.
npmTarballContract :: ResponseContract PassthroughResponse
npmTarballContract :: ResponseContract PassthroughResponse
npmTarballContract =
    Text -> ResponseContract PassthroughResponse
passthroughContract
        Text
"An upstream-controlled artifact response is relayed transparently. Local authentication, policy, availability, and internal failures use npm's JSON error body under their corresponding status."

npmTarballReplies :: TarballReplies PassthroughResponse
npmTarballReplies :: TarballReplies PassthroughResponse
npmTarballReplies =
    TarballReplies
        { tarballError :: Status -> [Header] -> Refusal -> PassthroughResponse
tarballError = \Status
status [Header]
headers Refusal
message ->
            Status -> [Header] -> PassthroughBody -> PassthroughResponse
passthroughResponse
                Status
status
                ((HeaderName
hContentType, ByteString
"application/json") Header -> [Header] -> [Header]
forall a. a -> [a] -> [a]
: [Header]
headers)
                (LByteString -> PassthroughBody
PassthroughBytes (JSONCodec NpmError -> NpmError -> LByteString
forall a. JSONCodec a -> a -> LByteString
encodeBody JSONCodec NpmError
npmErrorCodec (Text -> NpmError
NpmError (Refusal -> Text
renderRefusal Refusal
message))))
        , tarballStream :: Status -> [Header] -> StreamingBody -> PassthroughResponse
tarballStream = \Status
status [Header]
headers StreamingBody
body -> Status -> [Header] -> PassthroughBody -> PassthroughResponse
passthroughResponse Status
status [Header]
headers (StreamingBody -> PassthroughBody
PassthroughStream StreamingBody
body)
        , tarballEmpty :: Status -> [Header] -> PassthroughResponse
tarballEmpty = \Status
status [Header]
headers -> Status -> [Header] -> PassthroughBody -> PassthroughResponse
passthroughResponse Status
status [Header]
headers PassthroughBody
PassthroughEmpty
        }

type NpmPublishResponse = VariableResponse LByteString

npmPublishContract :: ResponseContract NpmPublishResponse
npmPublishContract :: ResponseContract NpmPublishResponse
npmPublishContract =
    ByteString -> Text -> ResponseContract NpmPublishResponse
variableOpaqueContract
        ByteString
"application/json"
        Text
"The publication target's status and JSON-labelled response bytes are relayed. Local authentication, scope, configuration, transport, and internal failures use npm's JSON error body."

npmPublishReplies :: PublishReplies NpmPublishResponse
npmPublishReplies :: PublishReplies NpmPublishResponse
npmPublishReplies =
    PublishReplies
        { publishRelayed :: Status -> [Header] -> LByteString -> NpmPublishResponse
publishRelayed = Status -> [Header] -> LByteString -> NpmPublishResponse
forall a. Status -> [Header] -> a -> VariableResponse a
variableResponse
        , publishError :: Status -> [Header] -> Text -> NpmPublishResponse
publishError = \Status
status [Header]
headers Text
message ->
            Status -> [Header] -> LByteString -> NpmPublishResponse
forall a. Status -> [Header] -> a -> VariableResponse a
variableResponse Status
status [Header]
headers (JSONCodec NpmError -> NpmError -> LByteString
forall a. JSONCodec a -> a -> LByteString
encodeBody JSONCodec NpmError
npmErrorCodec (Text -> NpmError
NpmError Text
message))
        }

-- @\/-\/ping@: answered locally with @200 {}@.
pingAnswer :: ResponseValue ()
pingAnswer :: ResponseValue ()
pingAnswer = [Header] -> () -> ResponseValue ()
forall a. [Header] -> a -> ResponseValue a
responseValue [] ()

-- @\/-\/v1\/search@: a @501@ pointer, in npm's error surface.
searchAnswer :: ResponseValue NpmError
searchAnswer :: ResponseValue NpmError
searchAnswer =
    [Header] -> NpmError -> ResponseValue NpmError
forall a. [Header] -> a -> ResponseValue a
responseValue [] (Maybe HelpMessage -> Text -> NpmError
npmError Maybe HelpMessage
forall a. Maybe a
Nothing Text
"search is not supported by this proxy; use the public registry's website to discover packages")

-- The dist-tag routes' @501@ pointer, in npm's error surface.
distTagAnswer :: ResponseValue NpmError
distTagAnswer :: ResponseValue NpmError
distTagAnswer =
    [Header] -> NpmError -> ResponseValue NpmError
forall a. [Header] -> a -> ResponseValue a
responseValue [] (Maybe HelpMessage -> Text -> NpmError
npmError Maybe HelpMessage
forall a. Maybe a
Nothing Text
"dist-tags are not supported by this proxy; a package's tags are in the metadata document it serves, and a publisher sets them at the publication target")

-- @GET \/{package}@: a bare package unit is a packument read.
buildPackument :: Method -> [NpmCap] -> Maybe (ResponseAction NpmPackumentResponse)
buildPackument :: ByteString
-> [NpmCap] -> Maybe (ResponseAction NpmPackumentResponse)
buildPackument ByteString
method = \case
    [NpmPackage PackageName
name] -> ResponseAction NpmPackumentResponse
-> Maybe (ResponseAction NpmPackumentResponse)
forall a. a -> Maybe a
Just (PackumentReplies NpmPackumentResponse
-> ByteString -> PackageName -> ResponseAction NpmPackumentResponse
forall response.
PackumentReplies response
-> ByteString -> PackageName -> ResponseAction response
packumentAction PackumentReplies NpmPackumentResponse
npmPackumentReplies ByteString
method PackageName
name)
    [NpmCap]
_ -> Maybe (ResponseAction NpmPackumentResponse)
forall a. Maybe a
Nothing

-- @PUT \/{package}@: a bare package unit under the write method is a publish.
buildPublish :: Method -> [NpmCap] -> Maybe (ResponseAction NpmPublishResponse)
buildPublish :: ByteString -> [NpmCap] -> Maybe (ResponseAction NpmPublishResponse)
buildPublish ByteString
_method = \case
    [NpmPackage PackageName
name] ->
        ResponseAction NpmPublishResponse
-> Maybe (ResponseAction NpmPublishResponse)
forall a. a -> Maybe a
Just
            ( NpmPublishResponse
-> (Request
    -> (NpmPublishResponse -> IO ResponseReceived)
    -> Handler ResponseReceived)
-> ResponseAction NpmPublishResponse
forall response.
response
-> (Request
    -> (response -> IO ResponseReceived) -> Handler ResponseReceived)
-> ResponseAction response
RunPipeline
                (PublishReplies NpmPublishResponse
-> Status -> [Header] -> Text -> NpmPublishResponse
forall response.
PublishReplies response -> Status -> [Header] -> Text -> response
publishError PublishReplies NpmPublishResponse
npmPublishReplies Status
status500 [] Text
"internal server error")
                (PublishReplies NpmPublishResponse
-> PackageName
-> Request
-> (NpmPublishResponse -> IO ResponseReceived)
-> Handler ResponseReceived
forall response.
PublishReplies response
-> PackageName
-> Request
-> (response -> IO ResponseReceived)
-> Handler ResponseReceived
servePublish PublishReplies NpmPublishResponse
npmPublishReplies PackageName
name)
            )
    [NpmCap]
_ -> Maybe (ResponseAction NpmPublishResponse)
forall a. Maybe a
Nothing

buildTarball :: Method -> [NpmCap] -> Maybe (ResponseAction PassthroughResponse)
buildTarball :: ByteString
-> [NpmCap] -> Maybe (ResponseAction PassthroughResponse)
buildTarball ByteString
method = \case
    [NpmPackage PackageName
name, NpmFilename Text
file] -> do
        (version, filename) <- PackageName -> Text -> Maybe (Version, Filename)
tarballCoordinate PackageName
name Text
file
        pure (tarballAction npmTarballReplies method name version filename)
    [NpmCap]
_ -> Maybe (ResponseAction PassthroughResponse)
forall a. Maybe a
Nothing

-- | Positional captures distinguish parsed package identities from checked path segments.
data NpmCap
    = NpmPackage PackageName
    | NpmFilename Text
    | NpmTag Text

-- | The package capture: one npm package unit, both scoped wire encodings handled by 'takePackage'.
capPackage :: Capture NpmCap
capPackage :: Capture NpmCap
capPackage =
    Text
-> Text
-> ([Text] -> Maybe (NpmCap, [Text]))
-> (NpmCap -> [Text])
-> Capture NpmCap
forall v.
Text
-> Text
-> ([Text] -> Maybe (v, [Text]))
-> (v -> [Text])
-> Capture v
Capture
        Text
"package"
        Text
"The package name, URL-encoded; a scoped name is `@scope%2Fname`."
        ( \case
            Text
"-" : [Text]
_ -> Maybe (NpmCap, [Text])
forall a. Maybe a
Nothing
            [Text]
segs -> ((PackageName, [Text]) -> (NpmCap, [Text]))
-> Maybe (PackageName, [Text]) -> Maybe (NpmCap, [Text])
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((PackageName -> NpmCap)
-> (PackageName, [Text]) -> (NpmCap, [Text])
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first PackageName -> NpmCap
NpmPackage) ([Text] -> Maybe (PackageName, [Text])
takePackage [Text]
segs)
        )
        NpmCap -> [Text]
renderPackage

-- | The artifact-file capture. The coordinate parse (the @.tgz@ basename and the version) is 'tarballCoordinate''s, applied in 'buildTarball'.
capFilename :: Capture NpmCap
capFilename :: Capture NpmCap
capFilename =
    Text
-> Text
-> ([Text] -> Maybe (NpmCap, [Text]))
-> (NpmCap -> [Text])
-> Capture NpmCap
forall v.
Text
-> Text
-> ([Text] -> Maybe (v, [Text]))
-> (v -> [Text])
-> Capture v
Capture
        Text
"filename"
        Text
"The artifact's on-the-wire file name, e.g. `lodash-4.17.21.tgz`."
        ((Text -> NpmCap) -> [Text] -> Maybe (NpmCap, [Text])
forall v. (Text -> v) -> [Text] -> Maybe (v, [Text])
safeSegment Text -> NpmCap
NpmFilename)
        NpmCap -> [Text]
renderSegment

-- | Accept one checked dist-tag segment. Tag routes remain unsupported.
capTag :: Capture NpmCap
capTag :: Capture NpmCap
capTag =
    Text
-> Text
-> ([Text] -> Maybe (NpmCap, [Text]))
-> (NpmCap -> [Text])
-> Capture NpmCap
forall v.
Text
-> Text
-> ([Text] -> Maybe (v, [Text]))
-> (v -> [Text])
-> Capture v
Capture
        Text
"tag"
        Text
"The dist-tag name, e.g. `latest`."
        ((Text -> NpmCap) -> [Text] -> Maybe (NpmCap, [Text])
forall v. (Text -> v) -> [Text] -> Maybe (v, [Text])
safeSegment Text -> NpmCap
NpmTag)
        NpmCap -> [Text]
renderSegment

{- The segments a package capture claims, written back out. A scoped name takes the two-segment
encoding, which 'takeScoped' reads back into the one wire name 'projectName' owns. -}
renderPackage :: NpmCap -> [Text]
renderPackage :: NpmCap -> [Text]
renderPackage = \case
    NpmPackage PackageName
name -> case PackageName -> Maybe Scope
pkgNamespace PackageName
name of
        Just Scope
scope -> [Scope -> Text
renderScope Scope
scope, PackageName -> Text
unscopedName PackageName
name]
        Maybe Scope
Nothing -> [PackageName -> Text
renderPackageName PackageName
name]
    NpmCap
other -> NpmCap -> [Text]
renderSegment NpmCap
other

-- The one segment a raw safety-checked capture claims, written back out.
renderSegment :: NpmCap -> [Text]
renderSegment :: NpmCap -> [Text]
renderSegment = \case
    NpmPackage PackageName
name -> [PackageName -> Text
renderPackageName PackageName
name]
    NpmFilename Text
file -> [Text
file]
    NpmTag Text
tag -> [Text
tag]

{- Peel the leading package unit off a path, returning its 'PackageName' and the remaining
segments. The route parses no name of its own: 'projectName' owns the npm name grammar. -}
takePackage :: [Text] -> Maybe (PackageName, [Text])
takePackage :: [Text] -> Maybe (PackageName, [Text])
takePackage [] = Maybe (PackageName, [Text])
forall a. Maybe a
Nothing
takePackage (Text
seg : [Text]
rest)
    | Text -> Text -> Bool
T.isPrefixOf Text
"@" Text
seg = Text -> [Text] -> Maybe (PackageName, [Text])
takeScoped Text
seg [Text]
rest
    | Bool
otherwise = (,[Text]
rest) (PackageName -> (PackageName, [Text]))
-> Maybe PackageName -> Maybe (PackageName, [Text])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either ParseError PackageName -> Maybe PackageName
forall l r. Either l r -> Maybe r
rightToMaybe (Text -> Either ParseError PackageName
projectName Text
seg)

{- Peel a scoped package unit off the leading @\@@ segment. Both wire encodings, one decoded
segment or two, join into the one wire name 'projectName' reads. -}
takeScoped :: Text -> [Text] -> Maybe (PackageName, [Text])
takeScoped :: Text -> [Text] -> Maybe (PackageName, [Text])
takeScoped Text
seg [Text]
rest
    | Text -> Text -> Bool
T.isInfixOf Text
"/" Text
seg = (,[Text]
rest) (PackageName -> (PackageName, [Text]))
-> Maybe PackageName -> Maybe (PackageName, [Text])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either ParseError PackageName -> Maybe PackageName
forall l r. Either l r -> Maybe r
rightToMaybe (Text -> Either ParseError PackageName
projectName Text
seg)
    | Bool
otherwise = case [Text]
rest of
        (Text
base : [Text]
more) -> (,[Text]
more) (PackageName -> (PackageName, [Text]))
-> Maybe PackageName -> Maybe (PackageName, [Text])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either ParseError PackageName -> Maybe PackageName
forall l r. Either l r -> Maybe r
rightToMaybe (Text -> Either ParseError PackageName
projectName (Text
seg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
base))
        [] -> Maybe (PackageName, [Text])
forall a. Maybe a
Nothing

-- | Parse an npm tarball-slot @file@ into the 'Version' and verbatim 'Filename' it names for @name@.
tarballCoordinate :: PackageName -> Text -> Maybe (Version, Filename)
tarballCoordinate :: PackageName -> Text -> Maybe (Version, Filename)
tarballCoordinate PackageName
name Text
file =
    case Text -> Text -> Maybe Text
T.stripSuffix Text
".tgz" Text
file Maybe Text -> (Text -> Maybe Text) -> Maybe Text
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Text -> Maybe Text
T.stripPrefix (PackageName -> Text
unscopedName PackageName
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"-") of
        Just Text
version
            | Bool -> Bool
not (Text -> Bool
T.null Text
version) -> (Ecosystem -> Text -> Version
mkVersion Ecosystem
Npm Text
version,) (Filename -> (Version, Filename))
-> Maybe Filename -> Maybe (Version, Filename)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe Filename
mkFilename Text
file
        Maybe Text
_ -> Maybe (Version, Filename)
forall a. Maybe a
Nothing

-- | Render through the artifact route so generated URLs obey its capture rules.
tarballPath :: PackageName -> Text -> Maybe Text
tarballPath :: PackageName -> Text -> Maybe Text
tarballPath PackageName
name Text
file = Text -> [Text] -> Text
T.intercalate Text
"/" ([Text] -> Text) -> Maybe [Text] -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Route NpmCap -> [NpmCap] -> Maybe [Text]
forall v. Route v -> [v] -> Maybe [Text]
renderRoute Route NpmCap
tarballRoute [PackageName -> NpmCap
NpmPackage PackageName
name, Text -> NpmCap
NpmFilename Text
file]

-- | Describe the live router and its deny-by-default catch-all for OpenAPI.
npmRouteSpecs :: NonEmpty RouteSpec
npmRouteSpecs :: NonEmpty RouteSpec
npmRouteSpecs =
    ResponseContract (ResponseValue NpmError)
-> ParamSpec -> NonEmpty RouteSpec
forall r. ResponseContract r -> ParamSpec -> NonEmpty RouteSpec
catchAllSpecs ResponseContract (ResponseValue NpmError)
unsupportedContract ParamSpec
unsupportedPathParam
        NonEmpty RouteSpec -> [RouteSpec] -> NonEmpty RouteSpec
forall a. NonEmpty a -> [a] -> NonEmpty a
`NE.appendList` (Route NpmCap -> [RouteSpec]) -> [Route NpmCap] -> [RouteSpec]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Route NpmCap -> [RouteSpec]
forall v. Route v -> [RouteSpec]
specsOf [Route NpmCap]
npmRoutes