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

{- | npm's route table: the list of routes an npm mount serves.

Each entry is one 'Ecluse.Core.Server.Route.Route' record, carrying its method condition,
its path template, what to /do/ when it matches, its prose, and the
'Ecluse.Core.Server.Contract.ResponseContract' that admits every response it can emit.
'npmRouter' folds the list into the
mount's router (first match wins; no match is the deny-by-default @404@) and 'npmRouteSpecs'
projects the same list for the capability manifest, so the routed surface, the emitted
responses, and the documented ones are all readings of one declaration.

Each response body is a codec ('Ecluse.Core.Registry.Npm.Serve.npmErrorCodec' for a
denial) or a named hand-authored schema (the merged packument, the publish document), so
the wire body and the documented schema are one source. The package, artifact, and publish
routes name the shared data-plane handlers ("Ecluse.Core.Server.Pipeline"); the meta-routes
answer locally through their declared outcome.

A @PUT \/{pkg}@ is the npm __publish__ request, so the method is part of the match: a
@PUT@ over a bare-package path publishes, while a __read__ (@GET@, or its bodiless @HEAD@)
over the same path fetches the packument. Those three methods are the only ones the front
door answers; any other (@POST@, @DELETE@, …) matches no route and denies.

The model is __deny by default__. Three npm-specific facts shape the matching, all from
the protocol research (see @docs\/research\/reverse-engineering\/npm.md@ §2 and §7):

* __Reserved meta-routes (@\/-\/…@) are matched first.__ A real package name can never
  begin with @\'-\'@, so a leading @"-"@ segment is unambiguously a meta-route.

* __Scoped names arrive in two encodings.__ The path is percent-decoded before it reaches
  us, so a scoped name arrives either as one decoded segment (@\@scope\/pkg@) or as two
  (@\@scope@, @pkg@). Both are normalised to the same 'PackageName' here.

* __A tarball path is @\/{pkg}\/-\/{file}.tgz@.__ 'tarballCoordinate' is the npm-side parse of
  the artifact coordinate; a basename that does not match the package is a
  __path-confusion__ attempt and denies.

Mount dispatch, prefix-stripping, and the liveness\/readiness routes are handled in the
agnostic web layer (see @docs\/architecture\/web-layer.md@); this table only ever sees the
npm-native request.
-}
module Ecluse.Core.Registry.Npm.Route (
    -- * The mount's router and fallback action
    npmRouter,
    npmNotFound,

    -- * Route-scoped pipeline contracts (exported for direct pipeline specs)
    npmPackumentContract,
    npmPackumentReplies,
    npmTarballContract,
    npmTarballReplies,
    npmPublishContract,
    npmPublishReplies,

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

    -- * The leaf parsers (exported for their specs)
    takePackage,
    tarballCoordinate,
) where

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

import Ecluse.Core.Ecosystem (Ecosystem (Npm))
import Ecluse.Core.Package (PackageName, mkPackageName, mkScope, unscopedName)
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,
    bodilessContract,
    chooseContract,
    documentedJsonContract,
    emptyContract,
    encodeBody,
    jsonContract,
    passthroughContract,
    passthroughResponse,
    responseDocs,
    responseValue,
    variableOpaqueContract,
    variableResponse,
 )
import Ecluse.Core.Server.Path (Filename (Filename), isSafeComponent)
import Ecluse.Core.Server.Pipeline.Packument (PackumentReplies (..), headPackument, servePackument)
import Ecluse.Core.Server.Pipeline.Publish (PublishReplies (..), servePublish)
import Ecluse.Core.Server.Pipeline.Tarball (TarballReplies (..), headTarball, serveTarball)
import Ecluse.Core.Server.Route (
    Capture (Capture),
    MethodMatch (MethodPut, MethodRead),
    PatternSeg (SegCap, SegLit),
    Route (Route),
    RouteName (RouteName),
    routerOf,
 )
import Ecluse.Core.Server.RouteSpec (ParamSpec (ParamSpec), PathSeg (Param), RouteSpec (RouteSpec), specsOf)
import Ecluse.Core.Version (Version, mkVersion)

{- | npm's mount router: the route table folded into the whole routing decision. The
first route that claims the request decides what is done with it; a request no route
claims is the deny-by-default @404@ ('npmNotFound') in npm's own error surface.
-}
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. Its local value and
manifest entry are two interpretations of 'unsupportedContract'.
-}
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")))

{- | npm's routes, in matching order: one named value each, aggregated here. The
__structure__ of each is in its own definition; the security-critical __leaf__ parsing
stays in the named functions the captures and builders reference ('takePackage',
'tarballCoordinate'). Ordering follows npm's conventions: the reserved meta-routes are
literal and tried first.
-}
npmRoutes :: [Route NpmCap]
npmRoutes :: [Route NpmCap]
npmRoutes = [Route NpmCap
pingRoute, Route NpmCap
searchRoute, 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
-> [PatternSeg NpmCap]
-> (Method
    -> [NpmCap] -> Maybe (ResponseAction (ResponseValue ())))
-> Text
-> Text
-> Maybe RequestSpec
-> ResponseContract (ResponseValue ())
-> Route NpmCap
forall v response.
RouteName
-> MethodMatch
-> [PatternSeg v]
-> (Method -> [v] -> Maybe (ResponseAction response))
-> Text
-> Text
-> Maybe RequestSpec
-> ResponseContract response
-> Route v
Route
        (Text -> RouteName
RouteName Text
"ping")
        MethodMatch
MethodRead
        [Text -> PatternSeg NpmCap
forall v. Text -> PatternSeg v
SegLit Text
"-", Text -> PatternSeg NpmCap
forall v. Text -> PatternSeg v
SegLit Text
"ping"]
        (ResponseValue ()
-> Method -> [NpmCap] -> Maybe (ResponseAction (ResponseValue ()))
forall response.
response -> Method -> [NpmCap] -> 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
-> [PatternSeg NpmCap]
-> (Method
    -> [NpmCap] -> Maybe (ResponseAction (ResponseValue NpmError)))
-> Text
-> Text
-> Maybe RequestSpec
-> ResponseContract (ResponseValue NpmError)
-> Route NpmCap
forall v response.
RouteName
-> MethodMatch
-> [PatternSeg v]
-> (Method -> [v] -> Maybe (ResponseAction response))
-> Text
-> Text
-> Maybe RequestSpec
-> ResponseContract response
-> Route v
Route
        (Text -> RouteName
RouteName Text
"search")
        MethodMatch
MethodRead
        [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
-> Method
-> [NpmCap]
-> Maybe (ResponseAction (ResponseValue NpmError))
forall response.
response -> Method -> [NpmCap] -> 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}\/-\/{filename}@: a package artifact, streamed.
tarballRoute :: Route NpmCap
tarballRoute :: Route NpmCap
tarballRoute =
    RouteName
-> MethodMatch
-> [PatternSeg NpmCap]
-> (Method
    -> [NpmCap] -> Maybe (ResponseAction PassthroughResponse))
-> Text
-> Text
-> Maybe RequestSpec
-> ResponseContract PassthroughResponse
-> Route NpmCap
forall v response.
RouteName
-> MethodMatch
-> [PatternSeg v]
-> (Method -> [v] -> Maybe (ResponseAction response))
-> Text
-> Text
-> Maybe RequestSpec
-> ResponseContract response
-> Route v
Route
        (Text -> RouteName
RouteName Text
"tarball")
        MethodMatch
MethodRead
        [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]
        Method -> [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
-> [PatternSeg NpmCap]
-> (Method
    -> [NpmCap] -> Maybe (ResponseAction NpmPackumentResponse))
-> Text
-> Text
-> Maybe RequestSpec
-> ResponseContract NpmPackumentResponse
-> Route NpmCap
forall v response.
RouteName
-> MethodMatch
-> [PatternSeg v]
-> (Method -> [v] -> Maybe (ResponseAction response))
-> Text
-> Text
-> Maybe RequestSpec
-> ResponseContract response
-> Route v
Route
        (Text -> RouteName
RouteName Text
"packument")
        MethodMatch
MethodRead
        [Capture NpmCap -> PatternSeg NpmCap
forall v. Capture v -> PatternSeg v
SegCap Capture NpmCap
capPackage]
        Method -> [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
-> [PatternSeg NpmCap]
-> (Method
    -> [NpmCap] -> Maybe (ResponseAction NpmPublishResponse))
-> Text
-> Text
-> Maybe RequestSpec
-> ResponseContract NpmPublishResponse
-> Route NpmCap
forall v response.
RouteName
-> MethodMatch
-> [PatternSeg v]
-> (Method -> [v] -> Maybe (ResponseAction response))
-> Text
-> Text
-> Maybe RequestSpec
-> ResponseContract response
-> Route v
Route
        (Text -> RouteName
RouteName Text
"publish")
        MethodMatch
MethodPut
        [Capture NpmCap -> PatternSeg NpmCap
forall v. Capture v -> PatternSeg v
SegCap Capture NpmCap
capPackage]
        Method -> [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
        (Text -> BodySchema
SchemaDocumented 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

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. Every constructor is introduced by the matching
leaf in 'npmPackumentContract'; 'npmPackumentReplies' is the only interface the pipeline
receives for selecting one.
-}
type NpmPackumentResponse =
    ResponseChoice
        (ResponseValue LByteString)
        ( ResponseChoice
            (ResponseValue ())
            ( 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) (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) (ResponseValue NpmError)))))
-> ResponseContract
     (ResponseChoice
        (ResponseValue ())
        (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) (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
status401 Text
"Edge authentication failed." 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
status403 Text
"Every version was withheld by policy or admission, and none survived the merge." 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) (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) (ResponseValue NpmError)))))
forall a b. a -> ResponseChoice a b
FirstResponse ([Header] -> () -> ResponseValue ()
forall a. [Header] -> a -> ResponseValue a
responseValue [Header]
headers ()))
        , packumentUnauthorised :: [Header] -> Text -> NpmPackumentResponse
packumentUnauthorised = \[Header]
headers Text
message -> ResponseChoice
  (ResponseValue ())
  (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) (ResponseValue NpmError))))
-> ResponseChoice
     (ResponseValue ())
     (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 Text
message))))
        , packumentForbidden :: [Header] -> Text -> NpmPackumentResponse
packumentForbidden = \[Header]
headers Text
message -> ResponseChoice
  (ResponseValue ())
  (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) (ResponseValue NpmError))))
-> ResponseChoice
     (ResponseValue ())
     (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 Text
message)))))
        , packumentInternal :: [Header] -> Text -> NpmPackumentResponse
packumentInternal = \[Header]
headers Text
message -> ResponseChoice
  (ResponseValue ())
  (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) (ResponseValue NpmError))))
-> ResponseChoice
     (ResponseValue ())
     (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 Text
message))))))
        , packumentBadGateway :: [Header] -> Text -> NpmPackumentResponse
packumentBadGateway = \[Header]
headers Text
message -> ResponseChoice
  (ResponseValue ())
  (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) (ResponseValue NpmError))))
-> ResponseChoice
     (ResponseValue ())
     (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 Text
message)))))))
        , packumentUnavailable :: [Header] -> Text -> NpmPackumentResponse
packumentUnavailable = \[Header]
headers Text
message -> ResponseChoice
  (ResponseValue ())
  (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) (ResponseValue NpmError))))
-> ResponseChoice
     (ResponseValue ())
     (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 Text
message)))))))
        }

{- | The tarball is deliberately an open relay: any upstream status, headers, media type,
and bytes can be forwarded. The one @default@ document is therefore more accurate than a
closed list that the upstream can escape.
-}
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] -> Text -> PassthroughResponse
tarballError = \Status
status [Header]
headers Text
message ->
            Status -> [Header] -> PassthroughBody -> PassthroughResponse
passthroughResponse
                Status
status
                ((HeaderName
hContentType, Method
"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 Text
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 =
    Method -> Text -> ResponseContract NpmPublishResponse
variableOpaqueContract
        Method
"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))
        }

-- A route answered locally, whatever the method and captures (the literal meta-routes).
answering :: response -> Method -> [NpmCap] -> Maybe (ResponseAction response)
answering :: forall response.
response -> Method -> [NpmCap] -> Maybe (ResponseAction response)
answering response
answer Method
_method [NpmCap]
_captures = ResponseAction response -> Maybe (ResponseAction response)
forall a. a -> Maybe a
Just (response -> ResponseAction response
forall response. response -> ResponseAction response
AnswerLocally response
answer)

-- @\/-\/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")

{- @GET \/{package}@: a bare package unit is a packument read. A @HEAD@ takes the
head-mode handler, which runs the identical gating and merge but withholds the body. -}
buildPackument :: Method -> [NpmCap] -> Maybe (ResponseAction NpmPackumentResponse)
buildPackument :: Method -> [NpmCap] -> Maybe (ResponseAction NpmPackumentResponse)
buildPackument Method
method = \case
    [NpmPackage PackageName
name]
        | Method -> Bool
isHead Method
method -> ResponseAction NpmPackumentResponse
-> Maybe (ResponseAction NpmPackumentResponse)
forall a. a -> Maybe a
Just (NpmPackumentResponse
-> (Request
    -> (NpmPackumentResponse -> IO ResponseReceived)
    -> Handler ResponseReceived)
-> ResponseAction NpmPackumentResponse
forall response.
response
-> (Request
    -> (response -> IO ResponseReceived) -> Handler ResponseReceived)
-> ResponseAction response
RunPipeline NpmPackumentResponse
perimeterFallback (PackumentReplies NpmPackumentResponse
-> PackageName
-> Request
-> (NpmPackumentResponse -> IO ResponseReceived)
-> Handler ResponseReceived
forall response.
PackumentReplies response
-> PackageName
-> Request
-> (response -> IO ResponseReceived)
-> Handler ResponseReceived
headPackument PackumentReplies NpmPackumentResponse
npmPackumentReplies PackageName
name))
        | Bool
otherwise -> ResponseAction NpmPackumentResponse
-> Maybe (ResponseAction NpmPackumentResponse)
forall a. a -> Maybe a
Just (NpmPackumentResponse
-> (Request
    -> (NpmPackumentResponse -> IO ResponseReceived)
    -> Handler ResponseReceived)
-> ResponseAction NpmPackumentResponse
forall response.
response
-> (Request
    -> (response -> IO ResponseReceived) -> Handler ResponseReceived)
-> ResponseAction response
RunPipeline NpmPackumentResponse
perimeterFallback (PackumentReplies NpmPackumentResponse
-> PackageName
-> Request
-> (NpmPackumentResponse -> IO ResponseReceived)
-> Handler ResponseReceived
forall response.
PackumentReplies response
-> PackageName
-> Request
-> (response -> IO ResponseReceived)
-> Handler ResponseReceived
servePackument PackumentReplies NpmPackumentResponse
npmPackumentReplies PackageName
name))
    [NpmCap]
_ -> Maybe (ResponseAction NpmPackumentResponse)
forall a. Maybe a
Nothing
  where
    perimeterFallback :: NpmPackumentResponse
perimeterFallback = PackumentReplies NpmPackumentResponse
-> [Header] -> Text -> NpmPackumentResponse
forall response.
PackumentReplies response -> [Header] -> Text -> response
packumentInternal PackumentReplies NpmPackumentResponse
npmPackumentReplies [] Text
"internal server error"

{- @PUT \/{package}@: a bare package unit under the write method is a publish. -}
buildPublish :: Method -> [NpmCap] -> Maybe (ResponseAction NpmPublishResponse)
buildPublish :: Method -> [NpmCap] -> Maybe (ResponseAction NpmPublishResponse)
buildPublish Method
_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

{- @GET \/{package}\/-\/{filename}@: an artifact read. 'tarballCoordinate' applies the
__cross-capture__ path-confusion check and reads the version; a mismatched name yields
'Nothing', so the route falls through to the @404@ rather than being fabricated into a
coordinate. A @HEAD@ takes the head-mode handler, which probes the upstream bodiless. -}
buildTarball :: Method -> [NpmCap] -> Maybe (ResponseAction PassthroughResponse)
buildTarball :: Method -> [NpmCap] -> Maybe (ResponseAction PassthroughResponse)
buildTarball Method
method = \case
    [NpmPackage PackageName
name, NpmFilename Text
file] -> do
        (version, filename) <- PackageName -> Text -> Maybe (Version, Filename)
tarballCoordinate PackageName
name Text
file
        pure $
            if isHead method
                then RunPipeline perimeterFallback (headTarball npmTarballReplies name version filename)
                else RunPipeline perimeterFallback (serveTarball npmTarballReplies name version filename)
    [NpmCap]
_ -> Maybe (ResponseAction PassthroughResponse)
forall a. Maybe a
Nothing
  where
    perimeterFallback :: PassthroughResponse
perimeterFallback = TarballReplies PassthroughResponse
-> Status -> [Header] -> Text -> PassthroughResponse
forall response.
TarballReplies response -> Status -> [Header] -> Text -> response
tarballError TarballReplies PassthroughResponse
npmTarballReplies Status
status500 [] Text
"internal server error"

isHead :: Method -> Bool
isHead :: Method -> Bool
isHead = (Method -> Method -> Bool
forall a. Eq a => a -> a -> Bool
== Method
methodHead)

{- | The captured values npm's routes produce: a parsed package unit, or a raw,
safety-checked artifact file name. Each pattern's builder consumes these positionally.
-}
data NpmCap
    = NpmPackage PackageName
    | NpmFilename Text

{- | The package capture: one npm package unit, both scoped wire encodings handled by
'takePackage' (which may consume one or two segments).

A bare leading @"-"@ is refused __on every method__: @\/-\/…@ is the reserved
meta-route prefix, and a lone @"-"@ is never a package name. Every other
component-safety rejection is 'takePackage''s.
-}
capPackage :: Capture NpmCap
capPackage :: Capture NpmCap
capPackage =
    Text
-> Text -> ([Text] -> Maybe (NpmCap, [Text])) -> Capture NpmCap
forall v.
Text -> Text -> ([Text] -> Maybe (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)
        )

{- | The artifact-file capture: one segment, accepted only when it is a safe component
('isSafeComponent'); 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])) -> Capture NpmCap
forall v.
Text -> Text -> ([Text] -> Maybe (v, [Text])) -> Capture v
Capture
        Text
"filename"
        Text
"The artifact's on-the-wire file name, e.g. `lodash-4.17.21.tgz`."
        ( \case
            Text
seg : [Text]
rest | Text -> Bool
isSafeComponent Text
seg -> (NpmCap, [Text]) -> Maybe (NpmCap, [Text])
forall a. a -> Maybe a
Just (Text -> NpmCap
NpmFilename Text
seg, [Text]
rest)
            [Text]
_ -> Maybe (NpmCap, [Text])
forall a. Maybe a
Nothing
        )

{- Peel the leading package unit off a path, returning its 'PackageName' and
the remaining segments. A leading segment beginning with @\'\@\'@ is a scoped
name, peeled by 'takeScoped' (which handles both wire encodings).

Returns 'Nothing' (so the caller denies it) for anything without a usable
package: an empty path, or a name with an __unsafe component__ -- a scope or base
name that 'isSafeComponent' rejects (empty, @"."@\/@".."@, or carrying a
@\'\/\'@, @\'\\\\\'@, or control character). 'mkScope'\/'mkPackageName' do no
validation, so this boundary is where such names are rejected rather than passed
downstream into an interpolated upstream URL.
-}
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
"@" <- Int -> Text -> Text
T.take Int
1 Text
seg = Text -> [Text] -> Maybe (PackageName, [Text])
takeScoped Text
seg [Text]
rest
    | Text -> Bool
isSafeComponent Text
seg = (PackageName, [Text]) -> Maybe (PackageName, [Text])
forall a. a -> Maybe a
Just (Ecosystem -> Maybe Scope -> Text -> PackageName
mkPackageName Ecosystem
Npm Maybe Scope
forall a. Maybe a
Nothing Text
seg, [Text]
rest)
    | Bool
otherwise = Maybe (PackageName, [Text])
forall a. Maybe a
Nothing

{- Peel a scoped package unit -- the leading @\@…@ segment -- handling both wire
encodings of a scoped name:

\* one decoded segment, @\@scope\/pkg@ -- split on the first @\'\/\'@;
\* two segments, @\@scope@ then @pkg@ -- consume both.
-}
takeScoped :: Text -> [Text] -> Maybe (PackageName, [Text])
takeScoped :: Text -> [Text] -> Maybe (PackageName, [Text])
takeScoped Text
seg [Text]
rest =
    case HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOn Text
"/" (Int -> Text -> Text
T.drop Int
1 Text
seg) of
        (Text
scope, Text
base)
            | Bool -> Bool
not (Text -> Bool
T.null Text
base) ->
                (,[Text]
rest) (PackageName -> (PackageName, [Text]))
-> Maybe PackageName -> Maybe (PackageName, [Text])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Text -> Maybe PackageName
scopedName Text
scope (Int -> Text -> Text
T.drop Int
1 Text
base)
        (Text, Text)
_ -> 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
<$> Text -> Text -> Maybe PackageName
scopedName (Int -> Text -> Text
T.drop Int
1 Text
seg) Text
base
            [Text]
_ -> Maybe (PackageName, [Text])
forall a. Maybe a
Nothing

-- A scoped name is usable only when both halves are safe components. The
-- leading '@' is already stripped from both arguments, so a degenerate or
-- hostile name ('@/pkg', '@scope/', '@scope/a/b', '@../pkg') is rejected here.
scopedName :: Text -> Text -> Maybe PackageName
scopedName :: Text -> Text -> Maybe PackageName
scopedName Text
scope Text
base
    | Text -> Bool
isSafeComponent Text
scope Bool -> Bool -> Bool
&& Text -> Bool
isSafeComponent Text
base =
        PackageName -> Maybe PackageName
forall a. a -> Maybe a
Just (Ecosystem -> Maybe Scope -> Text -> PackageName
mkPackageName Ecosystem
Npm (Scope -> Maybe Scope
forall a. a -> Maybe a
Just (Text -> Scope
mkScope Text
scope)) Text
base)
    | Bool
otherwise = Maybe PackageName
forall a. Maybe a
Nothing

{- | Parse an npm tarball-slot @file@ into the artifact coordinate it names for @name@:
the 'Version' and the verbatim 'Filename'. 'Nothing' denies it.

The npm convention is @{unscoped-name}-{version}.tgz@, so the file must end in @.tgz@ over a
non-empty name and have a basename of exactly @{unscoped-name}-{version}@. A basename that
does not begin with @{unscoped-name}-@ is a path-confusion attempt and denies. On a match
the @version@ run is read by the total 'mkVersion', and the @file@ is preserved verbatim.

Exported so the coordinate parse -- the security-critical half of the artifact route -- is
asserted directly, rather than only through the router.
-}
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) -> (Version, Filename) -> Maybe (Version, Filename)
forall a. a -> Maybe a
Just (Ecosystem -> Text -> Version
mkVersion Ecosystem
Npm Text
version, Text -> Filename
Filename Text
file)
        Maybe Text
_ -> Maybe (Version, Filename)
forall a. Maybe a
Nothing

{- | npm's routes as data for the __capability manifest__: the 'specsOf' projection of the
same 'npmRoutes' the router runs, plus the synthetic deny-by-default catch-all.
-}
npmRouteSpecs :: NonEmpty RouteSpec
npmRouteSpecs :: NonEmpty RouteSpec
npmRouteSpecs = RouteSpec
unsupportedGetSpec RouteSpec -> [RouteSpec] -> NonEmpty RouteSpec
forall a. a -> [a] -> NonEmpty a
:| (RouteSpec
unsupportedHeadSpec RouteSpec -> [RouteSpec] -> [RouteSpec]
forall a. a -> [a] -> [a]
: (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)

{- | The synthetic spec for the deny-by-default catch-all. It is not a route (it is the
/absence/ of a match), so it has no record in 'npmRoutes'; the manifest documents it
explicitly as the boundary.
-}
unsupportedGetSpec :: RouteSpec
unsupportedGetSpec :: RouteSpec
unsupportedGetSpec =
    RouteName
-> StdMethod
-> [PathSeg]
-> Text
-> Text
-> Maybe RequestSpec
-> [ResponseDoc]
-> RouteSpec
RouteSpec
        (Text -> RouteName
RouteName Text
"unsupported")
        StdMethod
GET
        [ParamSpec -> PathSeg
Param ParamSpec
unsupportedParam]
        Text
"Deny by default (unsupported path)"
        Text
"Any request under this mount matched by none of the routes above is denied with `404` -- \
        \deny by default at the routing layer."
        Maybe RequestSpec
forall a. Maybe a
Nothing
        (ResponseContract (ResponseValue NpmError) -> [ResponseDoc]
forall response. ResponseContract response -> [ResponseDoc]
responseDocs ResponseContract (ResponseValue NpmError)
unsupportedContract)

unsupportedHeadSpec :: RouteSpec
unsupportedHeadSpec :: RouteSpec
unsupportedHeadSpec =
    RouteName
-> StdMethod
-> [PathSeg]
-> Text
-> Text
-> Maybe RequestSpec
-> [ResponseDoc]
-> RouteSpec
RouteSpec
        (Text -> RouteName
RouteName Text
"unsupported.head")
        StdMethod
HEAD
        [ParamSpec -> PathSeg
Param ParamSpec
unsupportedParam]
        Text
"Deny by default (unsupported path)"
        Text
"Any HEAD request under this mount matched by none of the routes above is denied with `404` \
        \and no response body."
        Maybe RequestSpec
forall a. Maybe a
Nothing
        (ResponseContract (ResponseValue NpmError) -> [ResponseDoc]
forall response. ResponseContract response -> [ResponseDoc]
responseDocs (ResponseContract (ResponseValue NpmError)
-> ResponseContract (ResponseValue NpmError)
forall response.
ResponseContract response -> ResponseContract response
bodilessContract ResponseContract (ResponseValue NpmError)
unsupportedContract))

unsupportedParam :: ParamSpec
unsupportedParam :: ParamSpec
unsupportedParam = Text -> Text -> ParamSpec
ParamSpec Text
"unsupportedPath" Text
"Any path under this mount matched by none of the routes above."