-- SPDX-FileCopyrightText: 2026 Alexandra de Wit
--
-- SPDX-License-Identifier: MIT
{-# LANGUAGE ExistentialQuantification #-}

{- | A route is one record for a URL the proxy serves.
It holds the method, template, action, and documentation. A route table folds into a mount
router where the first match wins and all other requests receive a @404@. The manifest renders
'Ecluse.Core.Server.RouteDescription' projections of the records the router runs.
-}
module Ecluse.Core.Server.Route (
    -- * A route
    Route (..),
    RouteName (..),
    PatternSeg (..),
    Capture (..),
    MethodMatch (..),
    MediaNegotiation (..),

    -- * Routing a request
    routerOf,
    matchRoute,

    -- * Rendering a route
    renderRoute,

    -- * Building a route table
    answering,
    refusing,
    safeSegment,
    isHead,
) where

import Network.HTTP.Types.Header (RequestHeaders)
import Network.HTTP.Types.Method (Method, methodDelete, methodGet, methodHead, methodPost, methodPut)

import Ecluse.Core.Server.Accept (acceptsAny)
import Ecluse.Core.Server.Context (
    MountRouter,
    ResponseAction (AnswerLocally, AnswerRefusal),
    RouteAction (RouteAction),
 )
import Ecluse.Core.Server.Contract (RequestSpec, ResponseContract, bodilessContract)
import Ecluse.Core.Server.Path (isSafeComponent)
import Ecluse.Core.Server.Response (HelpMessage)

{- | One route: how it matches, what it does, and what it documents. The type parameter @v@ is the
ecosystem's capture value, the only part of a route not shared across ecosystems.
-}
data Route v = forall response. Route
    { forall v. Route v -> RouteName
routeName :: RouteName
    -- ^ Unique within its ecosystem. The manifest qualifies it for OpenAPI's global operation ID.
    , forall v. Route v -> MethodMatch
routeMethod :: MethodMatch
    -- ^ The method condition a request must satisfy to match.
    , ()
routeAccepts :: MediaNegotiation response
    -- ^ Served media types and the response when a request admits none.
    , forall v. Route v -> [PatternSeg v]
routeSegs :: [PatternSeg v]
    -- ^ The mount-relative path template: literal segments and named captures, in order.
    , ()
routeBuild :: Method -> [v] -> Maybe (ResponseAction response)
    {- ^ Builds an action from captured values in template order. 'Nothing' falls through to the
    next route, and a @HEAD@ uses the @GET@ builder because its response has no body.
    -}
    , forall v. Route v -> Text
routeSummary :: Text
    -- ^ A one-line summary (the OpenAPI operation summary).
    , forall v. Route v -> Text
routeDescription :: Text
    -- ^ The fuller prose description of what the route does.
    , forall v. Route v -> Maybe RequestSpec
routeRequest :: Maybe RequestSpec
    -- ^ The request body a write route accepts. 'Nothing' for a read.
    , ()
routeContract :: ResponseContract response
    -- ^ Runtime dispatch and the manifest share this response contract.
    }

{- | A route's name within its ecosystem (@"packument"@, @"tarball"@). The manifest adds the
ecosystem namespace when it needs a globally unique identifier.
-}
newtype RouteName = RouteName {RouteName -> Text
unRouteName :: Text}
    deriving stock (RouteName -> RouteName -> Bool
(RouteName -> RouteName -> Bool)
-> (RouteName -> RouteName -> Bool) -> Eq RouteName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RouteName -> RouteName -> Bool
== :: RouteName -> RouteName -> Bool
$c/= :: RouteName -> RouteName -> Bool
/= :: RouteName -> RouteName -> Bool
Eq, Eq RouteName
Eq RouteName =>
(RouteName -> RouteName -> Ordering)
-> (RouteName -> RouteName -> Bool)
-> (RouteName -> RouteName -> Bool)
-> (RouteName -> RouteName -> Bool)
-> (RouteName -> RouteName -> Bool)
-> (RouteName -> RouteName -> RouteName)
-> (RouteName -> RouteName -> RouteName)
-> Ord RouteName
RouteName -> RouteName -> Bool
RouteName -> RouteName -> Ordering
RouteName -> RouteName -> RouteName
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: RouteName -> RouteName -> Ordering
compare :: RouteName -> RouteName -> Ordering
$c< :: RouteName -> RouteName -> Bool
< :: RouteName -> RouteName -> Bool
$c<= :: RouteName -> RouteName -> Bool
<= :: RouteName -> RouteName -> Bool
$c> :: RouteName -> RouteName -> Bool
> :: RouteName -> RouteName -> Bool
$c>= :: RouteName -> RouteName -> Bool
>= :: RouteName -> RouteName -> Bool
$cmax :: RouteName -> RouteName -> RouteName
max :: RouteName -> RouteName -> RouteName
$cmin :: RouteName -> RouteName -> RouteName
min :: RouteName -> RouteName -> RouteName
Ord, Int -> RouteName -> ShowS
[RouteName] -> ShowS
RouteName -> String
(Int -> RouteName -> ShowS)
-> (RouteName -> String)
-> ([RouteName] -> ShowS)
-> Show RouteName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RouteName -> ShowS
showsPrec :: Int -> RouteName -> ShowS
$cshow :: RouteName -> String
show :: RouteName -> String
$cshowList :: [RouteName] -> ShowS
showList :: [RouteName] -> ShowS
Show)

{- | One segment of a path template: a fixed segment matched verbatim, or a named
capture. A capture consumes one or more leading segments and yields a value.
-}
data PatternSeg v
    = SegLit Text
    | SegCap (Capture v)

{- | A named path capture and its parser. 'capConsume' may claim more than one segment, which an
ecosystem whose identifier spans a decoded @\'\/\'@ needs, and 'Nothing' fails the match.
-}
data Capture v = Capture
    { forall v. Capture v -> Text
capName :: Text
    -- ^ The capture name, as it appears in the template (@{package}@).
    , forall v. Capture v -> Text
capDescription :: Text
    -- ^ A one-line, human-facing description for the documentation.
    , forall v. Capture v -> [Text] -> Maybe (v, [Text])
capConsume :: [Text] -> Maybe (v, [Text])
    -- ^ Consume the leading segments this capture claims, yielding its value and the tail.
    , forall v. Capture v -> v -> [Text]
capRender :: v -> [Text]
    -- ^ 'capConsume' inverted, so a served URL is built from the record that must claim it.
    }

{- | What a route serves, and what it refuses a client that will not take it. The refusal renders
into the route's own contract, so the @406@ is documented from the record that serves it.
-}
data MediaNegotiation response
    = -- | The route negotiates nothing: every request is admitted whatever it says it accepts.
      AcceptsAnything
    | {- | The route serves these media types alone, and refuses a request whose @Accept@ admits
      none of them under the mount's configured help message.
      -}
      AcceptsOnly (NonEmpty ByteString) (Maybe HelpMessage -> response)

{- | The method condition on a route: a closed vocabulary rather than a predicate, so the
manifest can name the documented method. A method outside it matches no route and denies.
-}
data MethodMatch
    = -- | The write method (@PUT@).
      MethodPut
    | -- | The submission method (@POST@).
      MethodPost
    | -- | The removal method (@DELETE@).
      MethodDelete
    | -- | The read methods (@GET@ and @HEAD@).
      MethodRead
    deriving stock (MethodMatch -> MethodMatch -> Bool
(MethodMatch -> MethodMatch -> Bool)
-> (MethodMatch -> MethodMatch -> Bool) -> Eq MethodMatch
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MethodMatch -> MethodMatch -> Bool
== :: MethodMatch -> MethodMatch -> Bool
$c/= :: MethodMatch -> MethodMatch -> Bool
/= :: MethodMatch -> MethodMatch -> Bool
Eq, Int -> MethodMatch -> ShowS
[MethodMatch] -> ShowS
MethodMatch -> String
(Int -> MethodMatch -> ShowS)
-> (MethodMatch -> String)
-> ([MethodMatch] -> ShowS)
-> Show MethodMatch
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MethodMatch -> ShowS
showsPrec :: Int -> MethodMatch -> ShowS
$cshow :: MethodMatch -> String
show :: MethodMatch -> String
$cshowList :: [MethodMatch] -> ShowS
showList :: [MethodMatch] -> ShowS
Show)

-- | Whether a request method satisfies a route's 'MethodMatch'.
methodMatches :: MethodMatch -> Method -> Bool
methodMatches :: MethodMatch -> Method -> Bool
methodMatches MethodMatch
MethodPut Method
m = Method
m Method -> Method -> Bool
forall a. Eq a => a -> a -> Bool
== Method
methodPut
methodMatches MethodMatch
MethodPost Method
m = Method
m Method -> Method -> Bool
forall a. Eq a => a -> a -> Bool
== Method
methodPost
methodMatches MethodMatch
MethodDelete Method
m = Method
m Method -> Method -> Bool
forall a. Eq a => a -> a -> Bool
== Method
methodDelete
methodMatches MethodMatch
MethodRead Method
m = Method
m Method -> Method -> Bool
forall a. Eq a => a -> a -> Bool
== Method
methodGet Bool -> Bool -> Bool
|| Method
m Method -> Method -> Bool
forall a. Eq a => a -> a -> Bool
== Method
methodHead

{- | Fold an ecosystem's route table into its mount's router. The first route that claims the
request decides it, and deny-by-default is structural because there is no other way to answer.
-}
routerOf :: RouteAction -> [Route v] -> MountRouter
routerOf :: forall v. RouteAction -> [Route v] -> MountRouter
routerOf RouteAction
notFound [Route v]
routes Method
method RequestHeaders
headers [Text]
segments =
    RouteAction
-> ((Route v, RouteAction) -> RouteAction)
-> Maybe (Route v, RouteAction)
-> RouteAction
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Method -> RouteAction -> RouteAction
fallbackAction Method
method RouteAction
notFound) (Route v, RouteAction) -> RouteAction
forall a b. (a, b) -> b
snd ([Route v]
-> Method
-> RequestHeaders
-> [Text]
-> Maybe (Route v, RouteAction)
forall v.
[Route v]
-> Method
-> RequestHeaders
-> [Text]
-> Maybe (Route v, RouteAction)
matchRoute [Route v]
routes Method
method RequestHeaders
headers [Text]
segments)

-- The catch-all, under the requested method's own contract.
fallbackAction :: Method -> RouteAction -> RouteAction
fallbackAction :: Method -> RouteAction -> RouteAction
fallbackAction Method
method (RouteAction ResponseContract response
contract ResponseAction response
action) =
    ResponseContract response -> ResponseAction response -> RouteAction
forall response.
ResponseContract response -> ResponseAction response -> RouteAction
RouteAction (Method -> ResponseContract response -> ResponseContract response
forall response.
Method -> ResponseContract response -> ResponseContract response
contractForMethod Method
method ResponseContract response
contract) ResponseAction response
action

{- | The route that claims a request, and the action it names: the first route whose method
condition holds, whose segments are consumed exactly, and whose builder accepts the captures.
-}
matchRoute :: [Route v] -> Method -> RequestHeaders -> [Text] -> Maybe (Route v, RouteAction)
matchRoute :: forall v.
[Route v]
-> Method
-> RequestHeaders
-> [Text]
-> Maybe (Route v, RouteAction)
matchRoute [Route v]
routes Method
method RequestHeaders
headers [Text]
segments =
    [(Route v, RouteAction)] -> Maybe (Route v, RouteAction)
forall a. [a] -> Maybe a
listToMaybe ((Route v -> Maybe (Route v, RouteAction))
-> [Route v] -> [(Route v, RouteAction)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Route v -> Maybe (Route v, RouteAction)
forall {v}. Route v -> Maybe (Route v, RouteAction)
claim [Route v]
routes)
  where
    claim :: Route v -> Maybe (Route v, RouteAction)
claim route :: Route v
route@Route{routeMethod :: forall v. Route v -> MethodMatch
routeMethod = MethodMatch
matchedMethod, routeAccepts :: ()
routeAccepts = MediaNegotiation response
negotiation, routeSegs :: forall v. Route v -> [PatternSeg v]
routeSegs = [PatternSeg v]
patternSegs, routeBuild :: ()
routeBuild = Method -> [v] -> Maybe (ResponseAction response)
build, routeContract :: ()
routeContract = ResponseContract response
contract}
        | MethodMatch -> Method -> Bool
methodMatches MethodMatch
matchedMethod Method
method = do
            captures <- [PatternSeg v] -> [Text] -> Maybe [v]
forall v. [PatternSeg v] -> [Text] -> Maybe [v]
consumeSegs [PatternSeg v]
patternSegs [Text]
segments
            action <- negotiated headers negotiation (build method captures)
            pure (route, RouteAction (contractForMethod method contract) action)
        | Bool
otherwise = Maybe (Route v, RouteAction)
forall a. Maybe a
Nothing

-- A @HEAD@ answers the contract of its @GET@ with the body dropped.
contractForMethod :: Method -> ResponseContract response -> ResponseContract response
contractForMethod :: forall response.
Method -> ResponseContract response -> ResponseContract response
contractForMethod Method
method
    | Method -> Bool
isHead Method
method = ResponseContract response -> ResponseContract response
forall response.
ResponseContract response -> ResponseContract response
bodilessContract
    | Bool
otherwise = ResponseContract response -> ResponseContract response
forall a. a -> a
id

{- A route the request will not take answers its own refusal, decided before the builder's action
is ever run. A route that negotiates nothing keeps whatever its builder decided. -}
negotiated ::
    RequestHeaders ->
    MediaNegotiation response ->
    Maybe (ResponseAction response) ->
    Maybe (ResponseAction response)
negotiated :: forall response.
RequestHeaders
-> MediaNegotiation response
-> Maybe (ResponseAction response)
-> Maybe (ResponseAction response)
negotiated RequestHeaders
headers MediaNegotiation response
negotiation Maybe (ResponseAction response)
built = case MediaNegotiation response
negotiation of
    MediaNegotiation response
AcceptsAnything -> Maybe (ResponseAction response)
built
    AcceptsOnly NonEmpty Method
served Maybe HelpMessage -> response
refusal
        | RequestHeaders -> NonEmpty Method -> Bool
acceptsAny RequestHeaders
headers NonEmpty Method
served -> Maybe (ResponseAction response)
built
        | Bool
otherwise -> (Maybe HelpMessage -> response) -> ResponseAction response
forall response.
(Maybe HelpMessage -> response) -> ResponseAction response
AnswerRefusal Maybe HelpMessage -> response
refusal ResponseAction response
-> Maybe (ResponseAction response)
-> Maybe (ResponseAction response)
forall a b. a -> Maybe b -> Maybe a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Maybe (ResponseAction response)
built

{- Requires exact consumption: a leftover request segment, or a template segment with nothing to
match, fails. A 'SegCap' threads the remainder to the rest of the template. -}
consumeSegs :: [PatternSeg v] -> [Text] -> Maybe [v]
consumeSegs :: forall v. [PatternSeg v] -> [Text] -> Maybe [v]
consumeSegs [] [] = [v] -> Maybe [v]
forall a. a -> Maybe a
Just []
consumeSegs (SegLit Text
l : [PatternSeg v]
ps) (Text
s : [Text]
ss)
    | Text
l Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
s = [PatternSeg v] -> [Text] -> Maybe [v]
forall v. [PatternSeg v] -> [Text] -> Maybe [v]
consumeSegs [PatternSeg v]
ps [Text]
ss
consumeSegs (SegCap Capture v
c : [PatternSeg v]
ps) [Text]
ss = do
    (v, rest) <- Capture v -> [Text] -> Maybe (v, [Text])
forall v. Capture v -> [Text] -> Maybe (v, [Text])
capConsume Capture v
c [Text]
ss
    (v :) <$> consumeSegs ps rest
consumeSegs [PatternSeg v]
_ [Text]
_ = Maybe [v]
forall a. Maybe a
Nothing

{- | A 'routeBuild' that answers with one fixed value whatever the method and captures. The
literal routes an ecosystem answers itself, rather than through the data plane, are built with it.
-}
answering :: response -> Method -> [v] -> Maybe (ResponseAction response)
answering :: forall response v.
response -> Method -> [v] -> Maybe (ResponseAction response)
answering response
answer Method
_method [v]
_captures = ResponseAction response -> Maybe (ResponseAction response)
forall a. a -> Maybe a
Just (response -> ResponseAction response
forall response. response -> ResponseAction response
AnswerLocally response
answer)

{- | 'answering' for a refusal: the route decides it, and the site holding the mount's
dependencies renders it under the configured help message.
-}
refusing :: (Maybe HelpMessage -> response) -> Method -> [v] -> Maybe (ResponseAction response)
refusing :: forall response v.
(Maybe HelpMessage -> response)
-> Method -> [v] -> Maybe (ResponseAction response)
refusing Maybe HelpMessage -> response
render Method
_method [v]
_captures = ResponseAction response -> Maybe (ResponseAction response)
forall a. a -> Maybe a
Just ((Maybe HelpMessage -> response) -> ResponseAction response
forall response.
(Maybe HelpMessage -> response) -> ResponseAction response
AnswerRefusal Maybe HelpMessage -> response
render)

{- | A 'capConsume' that claims one leading segment, and only when it is a safe path component.
A traversal, separator, or control character therefore fails the match before the value exists.
-}
safeSegment :: (Text -> v) -> [Text] -> Maybe (v, [Text])
safeSegment :: forall v. (Text -> v) -> [Text] -> Maybe (v, [Text])
safeSegment Text -> v
build = \case
    Text
seg : [Text]
rest | Text -> Bool
isSafeComponent Text
seg -> (v, [Text]) -> Maybe (v, [Text])
forall a. a -> Maybe a
Just (Text -> v
build Text
seg, [Text]
rest)
    [Text]
_ -> Maybe (v, [Text])
forall a. Maybe a
Nothing

{- | The mount-relative path a route serves one set of captures under. A rewritten artifact URL
is built through this, so the URL served and the route that must claim it are one record.
-}
renderRoute :: Route v -> [v] -> Maybe [Text]
renderRoute :: forall v. Route v -> [v] -> Maybe [Text]
renderRoute Route{routeSegs :: forall v. Route v -> [PatternSeg v]
routeSegs = [PatternSeg v]
patternSegs} = [PatternSeg v] -> [v] -> Maybe [Text]
forall v. [PatternSeg v] -> [v] -> Maybe [Text]
fillSegs [PatternSeg v]
patternSegs

-- The inverse of 'consumeSegs': one capture value per 'SegCap', in template order.
fillSegs :: [PatternSeg v] -> [v] -> Maybe [Text]
fillSegs :: forall v. [PatternSeg v] -> [v] -> Maybe [Text]
fillSegs [] [] = [Text] -> Maybe [Text]
forall a. a -> Maybe a
Just []
fillSegs (SegLit Text
lit : [PatternSeg v]
ps) [v]
vs = (Text
lit Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:) ([Text] -> [Text]) -> Maybe [Text] -> Maybe [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PatternSeg v] -> [v] -> Maybe [Text]
forall v. [PatternSeg v] -> [v] -> Maybe [Text]
fillSegs [PatternSeg v]
ps [v]
vs
fillSegs (SegCap Capture v
capture : [PatternSeg v]
ps) (v
v : [v]
vs) = (Capture v -> v -> [Text]
forall v. Capture v -> v -> [Text]
capRender Capture v
capture v
v [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<>) ([Text] -> [Text]) -> Maybe [Text] -> Maybe [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PatternSeg v] -> [v] -> Maybe [Text]
forall v. [PatternSeg v] -> [v] -> Maybe [Text]
fillSegs [PatternSeg v]
ps [v]
vs
fillSegs [PatternSeg v]
_ [v]
_ = Maybe [Text]
forall a. Maybe a
Nothing

-- | Whether a request is the bodiless read. A @HEAD@ is a variation of its @GET@, not a route.
isHead :: Method -> Bool
isHead :: Method -> Bool
isHead = (Method -> Method -> Bool
forall a. Eq a => a -> a -> Bool
== Method
methodHead)