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

{- | The response-contract algebra: one value interpreted as both wire behaviour and
capability-manifest documentation.

A 'ResponseContract' is indexed by the value a handler must produce. Its constructor is
private: callers can only build one from the leaf contracts in this module and combine
those leaves with 'chooseContract'. Each leaf owns both its 'ResponseDoc' and the function
that renders its payload, so those two interpretations cannot be supplied separately.

The route layer existentially packages a contract with a handler producing that
contract's response type. The runtime gives the handler only the corresponding typed
responder; a handler therefore cannot reach WAI with a status or body outside its route's
contract. 'bodilessContract' is the same interpretation for @HEAD@: statuses and headers
are preserved while every documented and emitted body is removed.

Owned JSON bodies use the same @autodocodec@ 'JSONCodec' for encoding here and schema
generation in the manifest tier. An intentionally transparent upstream relay is different:
its status, media type, and bytes are not Écluse's to constrain, so
'passthroughContract' documents an explicit OpenAPI @default@ response instead of claiming
a false closed set.
-}
module Ecluse.Core.Server.Contract (
    -- * Documented body shapes
    BodySchema (..),
    RequestSpec (..),
    ResponseStatus (..),
    ResponseDoc (..),

    -- * A response contract
    ResponseContract,
    responseDocs,
    responseToWai,
    bodilessContract,

    -- * Exact response leaves
    ResponseValue,
    responseValue,
    jsonContract,
    documentedJsonContract,
    emptyContract,

    -- * Open response leaves
    VariableResponse,
    variableResponse,
    variableOpaqueContract,
    PassthroughBody (..),
    PassthroughResponse,
    passthroughResponse,
    passthroughContract,

    -- * Combining closed alternatives
    ResponseChoice (..),
    chooseContract,

    -- * Rendering JSON through a codec
    encodeBody,
) where

import Autodocodec (JSONCodec, toJSONVia)
import Data.Aeson qualified as Aeson
import Network.HTTP.Types (Header, Status, hContentType)
import Network.Wai (Response, StreamingBody, responseLBS, responseStream)

{- | The structural shape of a response body, kept OpenAPI-free in the core.

'SchemaPassthrough' is deliberately broad: it means the operation transparently relays
an upstream response whose media type and body shape are outside Écluse's control.
-}
data BodySchema
    = -- | No body at all.
      SchemaEmpty
    | -- | Opaque bytes under one known media type.
      SchemaOpaque ByteString
    | -- | JSON encoded from the same codec the manifest renders as a schema.
      forall a. SchemaJson (JSONCodec a)
    | -- | An imperatively assembled JSON document with a named manifest schema.
      SchemaDocumented Text
    | -- | An upstream-controlled body under an upstream-controlled media type.
      SchemaPassthrough

{- | A request body a route accepts: its prose, requiredness, and documented shape.

Request decoding is not part of the response algebra. A hand-authored request schema
still owes the separate conformance check described in the API-surface architecture.
-}
data RequestSpec = RequestSpec
    { RequestSpec -> Text
reqDescription :: Text
    -- ^ What the body is (the OpenAPI request-body description).
    , RequestSpec -> Bool
reqRequired :: Bool
    -- ^ Whether the request is rejected without it.
    , RequestSpec -> BodySchema
reqSchema :: BodySchema
    -- ^ The shape of the accepted body.
    }

-- | Whether a documented response has one exact status or covers every other status.
data ResponseStatus
    = ExactResponse Status
    | DefaultResponse
    deriving stock (ResponseStatus -> ResponseStatus -> Bool
(ResponseStatus -> ResponseStatus -> Bool)
-> (ResponseStatus -> ResponseStatus -> Bool) -> Eq ResponseStatus
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ResponseStatus -> ResponseStatus -> Bool
== :: ResponseStatus -> ResponseStatus -> Bool
$c/= :: ResponseStatus -> ResponseStatus -> Bool
/= :: ResponseStatus -> ResponseStatus -> Bool
Eq, Int -> ResponseStatus -> ShowS
[ResponseStatus] -> ShowS
ResponseStatus -> String
(Int -> ResponseStatus -> ShowS)
-> (ResponseStatus -> String)
-> ([ResponseStatus] -> ShowS)
-> Show ResponseStatus
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ResponseStatus -> ShowS
showsPrec :: Int -> ResponseStatus -> ShowS
$cshow :: ResponseStatus -> String
show :: ResponseStatus -> String
$cshowList :: [ResponseStatus] -> ShowS
showList :: [ResponseStatus] -> ShowS
Show)

{- | One response entry for the capability manifest. This is a projection of a
'ResponseContract' leaf, never independently supplied by a route.
-}
data ResponseDoc = ResponseDoc
    { ResponseDoc -> ResponseStatus
responseStatus :: ResponseStatus
    -- ^ The exact HTTP status, or OpenAPI's @default@ response.
    , ResponseDoc -> Text
responseDescription :: Text
    -- ^ What the response means in the route's terms.
    , ResponseDoc -> BodySchema
responseBodySchema :: BodySchema
    -- ^ The body shape this response carries.
    }

{- | A response contract indexed by the only value its handler may answer with.

The constructor is private. The list and renderer can therefore only be extended together
through this module's leaves and 'chooseContract'.
-}
data ResponseContract response = ResponseContract
    { forall response. ResponseContract response -> [ResponseDoc]
contractDocs :: [ResponseDoc]
    , forall response. ResponseContract response -> response -> Answer
contractRender :: response -> Answer
    }

-- | The manifest projection of a response contract.
responseDocs :: ResponseContract response -> [ResponseDoc]
responseDocs :: forall response. ResponseContract response -> [ResponseDoc]
responseDocs = ResponseContract response -> [ResponseDoc]
forall response. ResponseContract response -> [ResponseDoc]
contractDocs

-- | A payload for an exact-status response, carrying additional response headers.
data ResponseValue a = ResponseValue [Header] a

-- | Supply the additional headers and payload for an exact response leaf.
responseValue :: [Header] -> a -> ResponseValue a
responseValue :: forall a. [Header] -> a -> ResponseValue a
responseValue = [Header] -> a -> ResponseValue a
forall a. [Header] -> a -> ResponseValue a
ResponseValue

{- | A binary response choice. Nesting 'ResponseChoice's forms a closed route response
sum without type-level programming; 'chooseContract' builds its two matching
interpretations together.
-}
data ResponseChoice a b
    = FirstResponse a
    | SecondResponse b

-- | Combine two response contracts into a closed choice of their alternatives.
chooseContract :: ResponseContract a -> ResponseContract b -> ResponseContract (ResponseChoice a b)
chooseContract :: forall a b.
ResponseContract a
-> ResponseContract b -> ResponseContract (ResponseChoice a b)
chooseContract ResponseContract a
left ResponseContract b
right =
    ResponseContract
        { contractDocs :: [ResponseDoc]
contractDocs = ResponseContract a -> [ResponseDoc]
forall response. ResponseContract response -> [ResponseDoc]
contractDocs ResponseContract a
left [ResponseDoc] -> [ResponseDoc] -> [ResponseDoc]
forall a. Semigroup a => a -> a -> a
<> ResponseContract b -> [ResponseDoc]
forall response. ResponseContract response -> [ResponseDoc]
contractDocs ResponseContract b
right
        , contractRender :: ResponseChoice a b -> Answer
contractRender = \case
            FirstResponse a
value -> ResponseContract a -> a -> Answer
forall response. ResponseContract response -> response -> Answer
contractRender ResponseContract a
left a
value
            SecondResponse b
value -> ResponseContract b -> b -> Answer
forall response. ResponseContract response -> response -> Answer
contractRender ResponseContract b
right b
value
        }

-- | One exact JSON response, encoded through the codec its manifest schema uses.
jsonContract :: Status -> Text -> JSONCodec a -> ResponseContract (ResponseValue a)
jsonContract :: forall a.
Status -> Text -> JSONCodec a -> ResponseContract (ResponseValue a)
jsonContract Status
status Text
description JSONCodec a
codec =
    ResponseContract
        { contractDocs :: [ResponseDoc]
contractDocs = [ResponseStatus -> Text -> BodySchema -> ResponseDoc
ResponseDoc (Status -> ResponseStatus
ExactResponse Status
status) Text
description (JSONCodec a -> BodySchema
forall a. JSONCodec a -> BodySchema
SchemaJson JSONCodec a
codec)]
        , contractRender :: ResponseValue a -> Answer
contractRender = \(ResponseValue [Header]
headers a
value) ->
            Status -> [Header] -> AnswerBody -> Answer
Answer Status
status [Header]
headers (ByteString -> AnswerBody
JsonAnswer (JSONCodec a -> a -> ByteString
forall a. JSONCodec a -> a -> ByteString
encodeBody JSONCodec a
codec a
value))
        }

{- | One exact JSON response whose bytes are assembled imperatively and whose schema is
the named hand-authored component in the manifest.
-}
documentedJsonContract :: Status -> Text -> Text -> ResponseContract (ResponseValue LByteString)
documentedJsonContract :: Status
-> Text -> Text -> ResponseContract (ResponseValue ByteString)
documentedJsonContract Status
status Text
description Text
schema =
    ResponseContract
        { contractDocs :: [ResponseDoc]
contractDocs = [ResponseStatus -> Text -> BodySchema -> ResponseDoc
ResponseDoc (Status -> ResponseStatus
ExactResponse Status
status) Text
description (Text -> BodySchema
SchemaDocumented Text
schema)]
        , contractRender :: ResponseValue ByteString -> Answer
contractRender = \(ResponseValue [Header]
headers ByteString
bytes) -> Status -> [Header] -> AnswerBody -> Answer
Answer Status
status [Header]
headers (ByteString -> AnswerBody
JsonAnswer ByteString
bytes)
        }

-- | One exact bodiless response.
emptyContract :: Status -> Text -> ResponseContract (ResponseValue ())
emptyContract :: Status -> Text -> ResponseContract (ResponseValue ())
emptyContract Status
status Text
description =
    ResponseContract
        { contractDocs :: [ResponseDoc]
contractDocs = [ResponseStatus -> Text -> BodySchema -> ResponseDoc
ResponseDoc (Status -> ResponseStatus
ExactResponse Status
status) Text
description BodySchema
SchemaEmpty]
        , contractRender :: ResponseValue () -> Answer
contractRender = \(ResponseValue [Header]
headers ()) -> Status -> [Header] -> AnswerBody -> Answer
Answer Status
status [Header]
headers AnswerBody
NoAnswerBody
        }

{- | A response whose status is supplied by the handler while its media type remains
fixed by the contract. Used for the publication target's arbitrary JSON-labelled status.
-}
data VariableResponse a = VariableResponse Status [Header] a

-- | Supply a dynamic status, additional headers, and body to a variable-status leaf.
variableResponse :: Status -> [Header] -> a -> VariableResponse a
variableResponse :: forall a. Status -> [Header] -> a -> VariableResponse a
variableResponse = Status -> [Header] -> a -> VariableResponse a
forall a. Status -> [Header] -> a -> VariableResponse a
VariableResponse

{- | An OpenAPI @default@ response carrying opaque bytes under a fixed media type.

The schema is intentionally binary even for @application/json@: Écluse relays the
publication target's bytes without parsing them, so it must not promise they satisfy a
JSON schema it never checks.
-}
variableOpaqueContract :: ByteString -> Text -> ResponseContract (VariableResponse LByteString)
variableOpaqueContract :: ByteString
-> Text -> ResponseContract (VariableResponse ByteString)
variableOpaqueContract ByteString
media Text
description =
    ResponseContract
        { contractDocs :: [ResponseDoc]
contractDocs = [ResponseStatus -> Text -> BodySchema -> ResponseDoc
ResponseDoc ResponseStatus
DefaultResponse Text
description (ByteString -> BodySchema
SchemaOpaque ByteString
media)]
        , contractRender :: VariableResponse ByteString -> Answer
contractRender = \(VariableResponse Status
status [Header]
headers ByteString
bytes) ->
            Status -> [Header] -> AnswerBody -> Answer
Answer Status
status [Header]
headers (ByteString -> ByteString -> AnswerBody
MediaAnswer ByteString
media ByteString
bytes)
        }

-- | The body of a transparent upstream response.
data PassthroughBody
    = PassthroughBytes LByteString
    | PassthroughStream StreamingBody
    | PassthroughEmpty

-- | A transparent upstream response: status, headers, and body all remain upstream's.
data PassthroughResponse = PassthroughResponse Status [Header] PassthroughBody

-- | Build a transparent response value for 'passthroughContract'.
passthroughResponse :: Status -> [Header] -> PassthroughBody -> PassthroughResponse
passthroughResponse :: Status -> [Header] -> PassthroughBody -> PassthroughResponse
passthroughResponse = Status -> [Header] -> PassthroughBody -> PassthroughResponse
PassthroughResponse

{- | An explicit OpenAPI @default@ contract for a transparent upstream relay.

This is the honest contract when the proxy intentionally forwards arbitrary upstream
statuses and media types. It prevents drift by documenting that open behaviour rather
than placing an inaccurate finite status set beside it.
-}
passthroughContract :: Text -> ResponseContract PassthroughResponse
passthroughContract :: Text -> ResponseContract PassthroughResponse
passthroughContract Text
description =
    ResponseContract
        { contractDocs :: [ResponseDoc]
contractDocs = [ResponseStatus -> Text -> BodySchema -> ResponseDoc
ResponseDoc ResponseStatus
DefaultResponse Text
description BodySchema
SchemaPassthrough]
        , contractRender :: PassthroughResponse -> Answer
contractRender = \(PassthroughResponse Status
status [Header]
headers PassthroughBody
body) ->
            Status -> [Header] -> AnswerBody -> Answer
Answer Status
status [Header]
headers (AnswerBody -> Answer) -> AnswerBody -> Answer
forall a b. (a -> b) -> a -> b
$ case PassthroughBody
body of
                PassthroughBytes ByteString
bytes -> ByteString -> AnswerBody
RawAnswer ByteString
bytes
                PassthroughStream StreamingBody
stream -> StreamingBody -> AnswerBody
RawStreamAnswer StreamingBody
stream
                PassthroughBody
PassthroughEmpty -> AnswerBody
NoAnswerBody
        }

{- | Derive the @HEAD@ interpretation of a contract: the same response alternatives,
statuses, and headers, with no documented or emitted body.
-}
bodilessContract :: ResponseContract response -> ResponseContract response
bodilessContract :: forall response.
ResponseContract response -> ResponseContract response
bodilessContract ResponseContract response
contract =
    ResponseContract
        { contractDocs :: [ResponseDoc]
contractDocs = (ResponseDoc -> ResponseDoc) -> [ResponseDoc] -> [ResponseDoc]
forall a b. (a -> b) -> [a] -> [b]
map ResponseDoc -> ResponseDoc
withoutDocumentedBody (ResponseContract response -> [ResponseDoc]
forall response. ResponseContract response -> [ResponseDoc]
contractDocs ResponseContract response
contract)
        , contractRender :: response -> Answer
contractRender = Answer -> Answer
withoutAnswerBody (Answer -> Answer) -> (response -> Answer) -> response -> Answer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResponseContract response -> response -> Answer
forall response. ResponseContract response -> response -> Answer
contractRender ResponseContract response
contract
        }
  where
    withoutDocumentedBody :: ResponseDoc -> ResponseDoc
withoutDocumentedBody ResponseDoc
doc = ResponseDoc
doc{responseBodySchema = SchemaEmpty}

{- | Render one value through its contract and into WAI. This is the only application
boundary at which a route response becomes an unrestricted WAI 'Response'.
-}
responseToWai :: ResponseContract response -> response -> Response
responseToWai :: forall response. ResponseContract response -> response -> Response
responseToWai ResponseContract response
contract = Answer -> Response
answerToResponse (Answer -> Response)
-> (response -> Answer) -> response -> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResponseContract response -> response -> Answer
forall response. ResponseContract response -> response -> Answer
contractRender ResponseContract response
contract

-- | Encode a JSON value to bytes through its @autodocodec@ codec.
encodeBody :: JSONCodec a -> a -> LByteString
encodeBody :: forall a. JSONCodec a -> a -> ByteString
encodeBody JSONCodec a
codec = Value -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode (Value -> ByteString) -> (a -> Value) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSONCodec a -> a -> Value
forall a void. ValueCodec a void -> a -> Value
toJSONVia JSONCodec a
codec

-- The concrete response is deliberately private: pipeline modules can select only a
-- value admitted by their route's public 'ResponseContract'.
data Answer = Answer Status [Header] AnswerBody

data AnswerBody
    = JsonAnswer LByteString
    | MediaAnswer ByteString LByteString
    | MediaStreamAnswer ByteString StreamingBody
    | RawAnswer LByteString
    | RawStreamAnswer StreamingBody
    | NoAnswerBody

withoutAnswerBody :: Answer -> Answer
withoutAnswerBody :: Answer -> Answer
withoutAnswerBody (Answer Status
status [Header]
headers AnswerBody
body) =
    Status -> [Header] -> AnswerBody -> Answer
Answer Status
status (AnswerBody -> [Header]
contentTypeOf AnswerBody
body [Header] -> [Header] -> [Header]
forall a. Semigroup a => a -> a -> a
<> [Header]
headers) AnswerBody
NoAnswerBody
  where
    contentTypeOf :: AnswerBody -> [Header]
contentTypeOf = \case
        JsonAnswer ByteString
_ -> [(HeaderName
hContentType, ByteString
"application/json")]
        MediaAnswer ByteString
media ByteString
_ -> [(HeaderName
hContentType, ByteString
media)]
        MediaStreamAnswer ByteString
media StreamingBody
_ -> [(HeaderName
hContentType, ByteString
media)]
        RawAnswer ByteString
_ -> []
        RawStreamAnswer StreamingBody
_ -> []
        AnswerBody
NoAnswerBody -> []

answerToResponse :: Answer -> Response
answerToResponse :: Answer -> Response
answerToResponse (Answer Status
status [Header]
headers AnswerBody
body) = case AnswerBody
body of
    JsonAnswer ByteString
bytes -> Status -> [Header] -> ByteString -> Response
responseLBS Status
status ((HeaderName
hContentType, ByteString
"application/json") Header -> [Header] -> [Header]
forall a. a -> [a] -> [a]
: [Header]
headers) ByteString
bytes
    MediaAnswer ByteString
media ByteString
bytes -> Status -> [Header] -> ByteString -> Response
responseLBS Status
status ((HeaderName
hContentType, ByteString
media) Header -> [Header] -> [Header]
forall a. a -> [a] -> [a]
: [Header]
headers) ByteString
bytes
    MediaStreamAnswer ByteString
media StreamingBody
stream -> Status -> [Header] -> StreamingBody -> Response
responseStream Status
status ((HeaderName
hContentType, ByteString
media) Header -> [Header] -> [Header]
forall a. a -> [a] -> [a]
: [Header]
headers) StreamingBody
stream
    RawAnswer ByteString
bytes -> Status -> [Header] -> ByteString -> Response
responseLBS Status
status [Header]
headers ByteString
bytes
    RawStreamAnswer StreamingBody
stream -> Status -> [Header] -> StreamingBody -> Response
responseStream Status
status [Header]
headers StreamingBody
stream
    AnswerBody
NoAnswerBody -> Status -> [Header] -> ByteString -> Response
responseLBS Status
status [Header]
headers ByteString
""