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

{- | The response-contract algebra: one value read as both wire behaviour and OpenAPI
documentation. The constructor is private, so a route builds a 'ResponseContract' only from
this module's leaves and 'chooseContract', and cannot supply the docs and the renderer
separately. A leaf reads its media type off the 'BodySchema' it documents, so the wire type
and the manifest type are one spelling. A transparent upstream relay
('passthroughContract') documents an OpenAPI @default@ response rather than a closed status
set it cannot honour.
-}
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,
    mediaJsonContract,
    documentedJsonContract,
    mediaContract,
    optionalBodyContract,
    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 and the media type it is served under, kept
OpenAPI-free in the core.
-}
data BodySchema
    = -- | No body at all.
      SchemaEmpty
    | -- | Opaque bytes under one known media type.
      SchemaOpaque ByteString
    | -- | Text under one known media type.
      SchemaText ByteString
    | -- | Encoded from the same codec the manifest renders as a schema.
      forall a. SchemaJson ByteString (JSONCodec a)
    | -- | An imperatively assembled document with a named manifest schema.
      SchemaDocumented ByteString Text
    | -- | An upstream-controlled body under an upstream-controlled media type.
      SchemaPassthrough

{- | A request body a route accepts. A hand-authored request schema still owes the separate
conformance check the API-surface architecture describes.
-}
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 OpenAPI spec. 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.
    }

-- 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
    = MediaAnswer ByteString LByteString
    | RawAnswer LByteString
    | RawStreamAnswer StreamingBody
    | NoAnswerBody

-- | A response contract indexed by the only value its handler may answer with.
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 these forms a closed route response sum without type-level
programming, and 'chooseContract' builds the 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 = ByteString
-> Status
-> Text
-> JSONCodec a
-> ResponseContract (ResponseValue a)
forall a.
ByteString
-> Status
-> Text
-> JSONCodec a
-> ResponseContract (ResponseValue a)
mediaJsonContract ByteString
applicationJson

{- | One exact response encoded through its codec and served under @media@, for a JSON-family
media type an ecosystem names itself.
-}
mediaJsonContract :: ByteString -> Status -> Text -> JSONCodec a -> ResponseContract (ResponseValue a)
mediaJsonContract :: forall a.
ByteString
-> Status
-> Text
-> JSONCodec a
-> ResponseContract (ResponseValue a)
mediaJsonContract ByteString
media Status
status Text
description JSONCodec a
codec =
    ResponseContract
        { contractDocs :: [ResponseDoc]
contractDocs = [ResponseStatus -> Text -> BodySchema -> ResponseDoc
ResponseDoc (Status -> ResponseStatus
ExactResponse Status
status) Text
description (ByteString -> JSONCodec a -> BodySchema
forall a. ByteString -> JSONCodec a -> BodySchema
SchemaJson ByteString
media JSONCodec a
codec)]
        , contractRender :: ResponseValue a -> Answer
contractRender = \(ResponseValue [Header]
headers a
value) ->
            Status -> [Header] -> AnswerBody -> Answer
Answer Status
status [Header]
headers (ByteString -> ByteString -> AnswerBody
MediaAnswer ByteString
media (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 =
    Status
-> Text
-> BodySchema
-> ResponseContract (ResponseValue ByteString)
mediaContract Status
status Text
description (ByteString -> Text -> BodySchema
SchemaDocumented ByteString
applicationJson Text
schema)

{- | One exact response, served under the media type its 'BodySchema' names and documented as
that same type. A schema naming no media type ('SchemaEmpty', 'SchemaPassthrough') emits no body.
-}
mediaContract :: Status -> Text -> BodySchema -> ResponseContract (ResponseValue LByteString)
mediaContract :: Status
-> Text
-> BodySchema
-> ResponseContract (ResponseValue ByteString)
mediaContract Status
status Text
description BodySchema
schema =
    ResponseContract
        { contractDocs :: [ResponseDoc]
contractDocs = [ResponseStatus -> Text -> BodySchema -> ResponseDoc
ResponseDoc (Status -> ResponseStatus
ExactResponse Status
status) Text
description BodySchema
schema]
        , contractRender :: ResponseValue ByteString -> Answer
contractRender = \(ResponseValue [Header]
headers ByteString
bytes) ->
            Status -> [Header] -> AnswerBody -> Answer
Answer Status
status [Header]
headers (BodySchema -> ByteString -> AnswerBody
mediaAnswer BodySchema
schema ByteString
bytes)
        }

{- | One exact response whose body is optional, the refusal shape of an ecosystem whose upstream
answers a bare status. Both forms are one documented response rather than two.
-}
optionalBodyContract :: Status -> Text -> BodySchema -> ResponseContract (ResponseValue (Maybe LByteString))
optionalBodyContract :: Status
-> Text
-> BodySchema
-> ResponseContract (ResponseValue (Maybe ByteString))
optionalBodyContract Status
status Text
description BodySchema
schema =
    ResponseContract
        { contractDocs :: [ResponseDoc]
contractDocs = [ResponseStatus -> Text -> BodySchema -> ResponseDoc
ResponseDoc (Status -> ResponseStatus
ExactResponse Status
status) Text
description BodySchema
schema]
        , contractRender :: ResponseValue (Maybe ByteString) -> Answer
contractRender = \(ResponseValue [Header]
headers Maybe ByteString
body) ->
            Status -> [Header] -> AnswerBody -> Answer
Answer Status
status [Header]
headers (AnswerBody
-> (ByteString -> AnswerBody) -> Maybe ByteString -> AnswerBody
forall b a. b -> (a -> b) -> Maybe a -> b
maybe AnswerBody
NoAnswerBody (BodySchema -> ByteString -> AnswerBody
mediaAnswer BodySchema
schema) Maybe ByteString
body)
        }

-- The body an exact leaf puts on the wire: absent for a schema that names no media type.
mediaAnswer :: BodySchema -> LByteString -> AnswerBody
mediaAnswer :: BodySchema -> ByteString -> AnswerBody
mediaAnswer BodySchema
schema ByteString
bytes = AnswerBody
-> (ByteString -> AnswerBody) -> Maybe ByteString -> AnswerBody
forall b a. b -> (a -> b) -> Maybe a -> b
maybe AnswerBody
NoAnswerBody (ByteString -> ByteString -> AnswerBody
`MediaAnswer` ByteString
bytes) (BodySchema -> Maybe ByteString
bodyMediaType BodySchema
schema)

-- The media type a body is served under, absent for a body this leaf does not put on the wire.
bodyMediaType :: BodySchema -> Maybe ByteString
bodyMediaType :: BodySchema -> Maybe ByteString
bodyMediaType = \case
    BodySchema
SchemaEmpty -> Maybe ByteString
forall a. Maybe a
Nothing
    SchemaOpaque ByteString
media -> ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
media
    SchemaText ByteString
media -> ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
media
    SchemaJson ByteString
media JSONCodec a
_ -> ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
media
    SchemaDocumented ByteString
media Text
_ -> ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
media
    BodySchema
SchemaPassthrough -> Maybe ByteString
forall a. Maybe a
Nothing

applicationJson :: ByteString
applicationJson :: ByteString
applicationJson = ByteString
"application/json"

-- | 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@. The proxy 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 OpenAPI @default@ contract for a transparent upstream relay. The proxy forwards arbitrary
upstream statuses and media types, so any finite status set beside it would be inaccurate.
-}
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

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
        MediaAnswer ByteString
media ByteString
_ -> [(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
    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
    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
""