-- SPDX-FileCopyrightText: 2026 Alexandra de Wit
--
-- SPDX-License-Identifier: MIT

{- | The documented operation view of a route, as plain OpenAPI-free data.

'specsOf' erases an "Ecluse.Core.Server.Route".'Route' into the operations the OpenAPI spec
needs. A write route contributes @PUT@, a submission route @POST@, and a removal route
@DELETE@. A read route contributes both @GET@ and its derived bodiless @HEAD@ operation. The
capture type, builder, and typed response value disappear. Each operation's 'ResponseDoc's
still come from the same 'Ecluse.Core.Server.Contract.ResponseContract' runtime dispatch uses.
-}
module Ecluse.Core.Server.RouteDescription (
    -- * The documented view
    RouteSpec (..),
    PathSeg (..),
    ParamSpec (..),

    -- * Projection from a route
    specsOf,

    -- * The synthetic catch-all
    catchAllSpecs,
    unsupportedPathParam,
) where

import Network.HTTP.Types.Method (StdMethod (DELETE, GET, HEAD, POST, PUT))

import Ecluse.Core.Server.Contract (RequestSpec, ResponseContract, ResponseDoc, bodilessContract, responseDocs)
import Ecluse.Core.Server.Route (
    Capture (capDescription, capName),
    MethodMatch (MethodDelete, MethodPost, MethodPut, MethodRead),
    PatternSeg (SegCap, SegLit),
    Route (Route, routeContract, routeDescription, routeMethod, routeName, routeRequest, routeSegs, routeSummary),
    RouteName (RouteName, unRouteName),
 )

{- | One served HTTP operation, as the manifest documents it. No 'Eq' or 'Show': request and
response schemas may carry @autodocodec@ codecs, which are functions.
-}
data RouteSpec = RouteSpec
    { RouteSpec -> RouteName
rsName :: RouteName
    -- ^ The operation name within its ecosystem. A @HEAD@ projection adds a @.head@ suffix.
    , RouteSpec -> StdMethod
rsMethod :: StdMethod
    -- ^ The exact HTTP method this operation serves.
    , RouteSpec -> [PathSeg]
rsPattern :: [PathSeg]
    -- ^ The mount-relative path template.
    , RouteSpec -> Text
rsSummary :: Text
    -- ^ A one-line summary.
    , RouteSpec -> Text
rsDescription :: Text
    -- ^ The fuller operation description.
    , RouteSpec -> Maybe RequestSpec
rsRequest :: Maybe RequestSpec
    -- ^ The accepted request body, when any.
    , RouteSpec -> [ResponseDoc]
rsOutcomes :: [ResponseDoc]
    -- ^ The responses projected from the operation's runtime contract.
    }

-- | One literal or captured path segment.
data PathSeg
    = Lit Text
    | Param ParamSpec
    deriving stock (PathSeg -> PathSeg -> Bool
(PathSeg -> PathSeg -> Bool)
-> (PathSeg -> PathSeg -> Bool) -> Eq PathSeg
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PathSeg -> PathSeg -> Bool
== :: PathSeg -> PathSeg -> Bool
$c/= :: PathSeg -> PathSeg -> Bool
/= :: PathSeg -> PathSeg -> Bool
Eq, Int -> PathSeg -> ShowS
[PathSeg] -> ShowS
PathSeg -> String
(Int -> PathSeg -> ShowS)
-> (PathSeg -> String) -> ([PathSeg] -> ShowS) -> Show PathSeg
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PathSeg -> ShowS
showsPrec :: Int -> PathSeg -> ShowS
$cshow :: PathSeg -> String
show :: PathSeg -> String
$cshowList :: [PathSeg] -> ShowS
showList :: [PathSeg] -> ShowS
Show)

-- | A named path parameter and its human-facing description.
data ParamSpec = ParamSpec
    { ParamSpec -> Text
psName :: Text
    -- ^ The name as it appears in the template.
    , ParamSpec -> Text
psDescription :: Text
    -- ^ A one-line description.
    }
    deriving stock (ParamSpec -> ParamSpec -> Bool
(ParamSpec -> ParamSpec -> Bool)
-> (ParamSpec -> ParamSpec -> Bool) -> Eq ParamSpec
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ParamSpec -> ParamSpec -> Bool
== :: ParamSpec -> ParamSpec -> Bool
$c/= :: ParamSpec -> ParamSpec -> Bool
/= :: ParamSpec -> ParamSpec -> Bool
Eq, Int -> ParamSpec -> ShowS
[ParamSpec] -> ShowS
ParamSpec -> String
(Int -> ParamSpec -> ShowS)
-> (ParamSpec -> String)
-> ([ParamSpec] -> ShowS)
-> Show ParamSpec
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ParamSpec -> ShowS
showsPrec :: Int -> ParamSpec -> ShowS
$cshow :: ParamSpec -> String
show :: ParamSpec -> String
$cshowList :: [ParamSpec] -> ShowS
showList :: [ParamSpec] -> ShowS
Show)

{- | Project a route to every exact method it serves. The @HEAD@ contract is the 'bodilessContract'
reading of the response value @GET@ uses, so its status set cannot drift from the @GET@'s.
-}
specsOf :: Route v -> [RouteSpec]
specsOf :: forall v. Route v -> [RouteSpec]
specsOf
    Route
        { routeName :: forall v. Route v -> RouteName
routeName = RouteName
name
        , routeMethod :: forall v. Route v -> MethodMatch
routeMethod = MethodMatch
matchedMethod
        , routeSegs :: forall v. Route v -> [PatternSeg v]
routeSegs = [PatternSeg v]
segments
        , routeSummary :: forall v. Route v -> Text
routeSummary = Text
summary
        , routeDescription :: forall v. Route v -> Text
routeDescription = Text
description
        , routeRequest :: forall v. Route v -> Maybe RequestSpec
routeRequest = Maybe RequestSpec
request
        , routeContract :: ()
routeContract = ResponseContract response
contract
        } = ((StdMethod, RouteName, ResponseContract response) -> RouteSpec)
-> [(StdMethod, RouteName, ResponseContract response)]
-> [RouteSpec]
forall a b. (a -> b) -> [a] -> [b]
map (StdMethod, RouteName, ResponseContract response) -> RouteSpec
forall {response}.
(StdMethod, RouteName, ResponseContract response) -> RouteSpec
operationSpec [(StdMethod, RouteName, ResponseContract response)]
operations
      where
        operations :: [(StdMethod, RouteName, ResponseContract response)]
operations = case MethodMatch
matchedMethod of
            MethodMatch
MethodRead -> [(StdMethod
GET, RouteName
name, ResponseContract response
contract), (StdMethod
HEAD, RouteName -> RouteName
headName RouteName
name, ResponseContract response -> ResponseContract response
forall response.
ResponseContract response -> ResponseContract response
bodilessContract ResponseContract response
contract)]
            MethodMatch
MethodPut -> [(StdMethod
PUT, RouteName
name, ResponseContract response
contract)]
            MethodMatch
MethodPost -> [(StdMethod
POST, RouteName
name, ResponseContract response
contract)]
            MethodMatch
MethodDelete -> [(StdMethod
DELETE, RouteName
name, ResponseContract response
contract)]

        operationSpec :: (StdMethod, RouteName, ResponseContract response) -> RouteSpec
operationSpec (StdMethod
method, RouteName
operationName, ResponseContract response
operationContract) =
            RouteSpec
                { rsName :: RouteName
rsName = RouteName
operationName
                , rsMethod :: StdMethod
rsMethod = StdMethod
method
                , rsPattern :: [PathSeg]
rsPattern = (PatternSeg v -> PathSeg) -> [PatternSeg v] -> [PathSeg]
forall a b. (a -> b) -> [a] -> [b]
map PatternSeg v -> PathSeg
forall v. PatternSeg v -> PathSeg
pathSegOf [PatternSeg v]
segments
                , rsSummary :: Text
rsSummary = Text
summary
                , rsDescription :: Text
rsDescription = Text
description
                , rsRequest :: Maybe RequestSpec
rsRequest = Maybe RequestSpec
request
                , rsOutcomes :: [ResponseDoc]
rsOutcomes = ResponseContract response -> [ResponseDoc]
forall response. ResponseContract response -> [ResponseDoc]
responseDocs ResponseContract response
operationContract
                }

pathSegOf :: PatternSeg v -> PathSeg
pathSegOf :: forall v. PatternSeg v -> PathSeg
pathSegOf = \case
    SegLit Text
text -> Text -> PathSeg
Lit Text
text
    SegCap Capture v
capture -> ParamSpec -> PathSeg
Param (Text -> Text -> ParamSpec
ParamSpec (Capture v -> Text
forall v. Capture v -> Text
capName Capture v
capture) (Capture v -> Text
forall v. Capture v -> Text
capDescription Capture v
capture))

-- The @HEAD@ projection's operation name, derived so it cannot collide with its @GET@.
headName :: RouteName -> RouteName
headName :: RouteName -> RouteName
headName RouteName
name = Text -> RouteName
RouteName (RouteName -> Text
unRouteName RouteName
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".head")

{- | The @GET@ and @HEAD@ pair documenting a mount's deny-by-default catch-all. It is the
absence of a match rather than a route, so no 'Route' carries it and each table appends it.
-}
catchAllSpecs :: ResponseContract r -> ParamSpec -> NonEmpty RouteSpec
catchAllSpecs :: forall r. ResponseContract r -> ParamSpec -> NonEmpty RouteSpec
catchAllSpecs ResponseContract r
contract ParamSpec
param = RouteSpec
catchAllGet RouteSpec -> [RouteSpec] -> NonEmpty RouteSpec
forall a. a -> [a] -> NonEmpty a
:| [RouteSpec
catchAllHead]
  where
    catchAllGet :: RouteSpec
catchAllGet =
        RouteName
-> StdMethod
-> [PathSeg]
-> Text
-> Text
-> Maybe RequestSpec
-> [ResponseDoc]
-> RouteSpec
RouteSpec
            (Text -> RouteName
RouteName Text
"unsupported")
            StdMethod
GET
            [ParamSpec -> PathSeg
Param ParamSpec
param]
            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 r -> [ResponseDoc]
forall response. ResponseContract response -> [ResponseDoc]
responseDocs ResponseContract r
contract)

    catchAllHead :: RouteSpec
catchAllHead =
        RouteName
-> StdMethod
-> [PathSeg]
-> Text
-> Text
-> Maybe RequestSpec
-> [ResponseDoc]
-> RouteSpec
RouteSpec
            (RouteName -> RouteName
headName (Text -> RouteName
RouteName Text
"unsupported"))
            StdMethod
HEAD
            [ParamSpec -> PathSeg
Param ParamSpec
param]
            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 r -> [ResponseDoc]
forall response. ResponseContract response -> [ResponseDoc]
responseDocs (ResponseContract r -> ResponseContract r
forall response.
ResponseContract response -> ResponseContract response
bodilessContract ResponseContract r
contract))

-- | The catch-all's path parameter, as every mount's route table documents it.
unsupportedPathParam :: ParamSpec
unsupportedPathParam :: ParamSpec
unsupportedPathParam = Text -> Text -> ParamSpec
ParamSpec Text
"unsupportedPath" Text
"Any path under this mount matched by none of the routes above."