servant-openapi-hs-5.1.0: src/Servant/OpenApi/Internal.hs
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
#if __GLASGOW_HASKELL__ >= 806
{-# LANGUAGE UndecidableInstances #-}
#endif
{-# OPTIONS_GHC -Wno-orphans #-}
-- | Internal implementation of the 'HasOpenApi' class and the machinery that
-- derives an OpenAPI 3.1 document from a servant API type. Not subject to the
-- PVP; import "Servant.OpenApi" instead.
module Servant.OpenApi.Internal where
import Prelude.Compat
import Prelude ()
#if MIN_VERSION_servant(0,18,1)
import Control.Applicative ((<|>))
#endif
import Control.Lens
import Data.Aeson
import Data.Foldable (toList)
import Data.HashMap.Strict.InsOrd.Compat (InsOrdHashMap)
import Data.HashMap.Strict.InsOrd.Compat qualified as InsOrdHashMap
import Data.Kind (Type)
import Data.OpenApi hiding (Header, contentType)
import Data.OpenApi qualified as OpenApi
import Data.OpenApi.Declare
import Data.Proxy
import Data.Singletons.Bool
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Typeable (Typeable)
import GHC.TypeLits
import Network.HTTP.Media (MediaType)
import Servant.API
import Servant.API.ContentTypes (AllMime, allMime)
import Servant.API.Description (FoldDescription, reflectDescription)
import Servant.API.Modifiers (FoldRequired)
#if MIN_VERSION_servant(0,20,3)
import Servant.API.MultiVerb
#endif
import Servant.OpenApi.Internal.TypeLevel.API
-- | Generate a OpenApi specification for a servant API.
--
-- To generate OpenApi specification, your data types need
-- @'ToParamSchema'@ and/or @'ToSchema'@ instances.
--
-- @'ToParamSchema'@ is used for @'Capture'@, @'QueryParam'@ and @t'Header'@.
-- @'ToSchema'@ is used for @'ReqBody'@ and response data types.
--
-- You can easily derive those instances via @Generic@.
-- For more information, refer to
-- <https://hackage.haskell.org/package/openapi-hs/docs/Data-OpenApi.html openapi-hs documentation>.
--
-- Example:
--
-- @
-- newtype Username = Username String deriving (Generic, ToText)
--
-- instance ToParamSchema Username
--
-- data User = User
-- { username :: Username
-- , fullname :: String
-- } deriving (Generic)
--
-- instance ToJSON User
-- instance ToSchema User
--
-- type MyAPI = QueryParam "username" Username :> Get '[JSON] User
--
-- myOpenApi :: OpenApi
-- myOpenApi = toOpenApi (Proxy :: Proxy MyAPI)
-- @
class HasOpenApi api where
-- | Generate a OpenApi specification for a servant API.
toOpenApi :: Proxy api -> OpenApi
instance HasOpenApi Raw where
toOpenApi _ = mempty & paths . at "/" ?~ mempty
instance HasOpenApi EmptyAPI where
toOpenApi _ = mempty
-- | All operations of sub API.
-- This is similar to @'operationsOf'@ but ensures that operations
-- indeed belong to the API at compile time.
subOperations ::
(IsSubAPI sub api, HasOpenApi sub) =>
-- | Part of a servant API.
Proxy sub ->
-- | The whole servant API.
Proxy api ->
Traversal' OpenApi Operation
subOperations sub _ = operationsOf (toOpenApi sub)
-- | Make a singleton OpenApi spec (with only one endpoint).
-- For endpoints with no content see 'mkEndpointNoContent'.
mkEndpoint ::
forall a cs hs proxy method status.
(ToSchema a, AllAccept cs, AllToResponseHeader hs, OpenApiMethod method, KnownNat status) =>
-- | Endpoint path.
FilePath ->
-- | Method, content-types, headers and response.
proxy (Verb method status cs (Headers hs a)) ->
OpenApi
mkEndpoint path proxy =
mkEndpointWithSchemaRef (Just schemaRef) path proxy
& components . schemas .~ schemaDefs
where
(schemaDefs, schemaRef) = runDeclare (declareSchemaRef (Proxy :: Proxy a)) mempty
-- | Make a singleton t'OpenApi' spec (with only one endpoint) and with no content schema.
mkEndpointNoContent ::
forall nocontent cs hs proxy method status.
(AllAccept cs, AllToResponseHeader hs, OpenApiMethod method, KnownNat status) =>
-- | Endpoint path.
FilePath ->
-- | Method, content-types, headers and response.
proxy (Verb method status cs (Headers hs nocontent)) ->
OpenApi
mkEndpointNoContent path proxy =
mkEndpointWithSchemaRef Nothing path proxy
-- | Like @'mkEndpoint'@ but with explicit schema reference.
-- Unlike @'mkEndpoint'@ this function does not register any schema components.
mkEndpointWithSchemaRef ::
forall cs hs proxy method status a.
(AllAccept cs, AllToResponseHeader hs, OpenApiMethod method, KnownNat status) =>
Maybe (Referenced Schema) ->
FilePath ->
proxy (Verb method status cs (Headers hs a)) ->
OpenApi
mkEndpointWithSchemaRef mref path _ =
mempty
& paths . at path
?~ ( mempty
& method
?~ ( mempty
& at code
?~ Inline
( mempty
& content
.~ InsOrdHashMap.fromList
[(t, mempty & schema .~ mref) | t <- responseContentTypes]
& headers .~ responseHeaders
)
)
)
where
method = openApiMethod (Proxy :: Proxy method)
code = fromIntegral (natVal (Proxy :: Proxy status))
responseContentTypes = allContentType (Proxy :: Proxy cs)
responseHeaders = Inline <$> toAllResponseHeaders (Proxy :: Proxy hs)
mkEndpointNoContentVerb ::
forall proxy method.
(OpenApiMethod method) =>
-- | Endpoint path.
FilePath ->
-- | Method
proxy (NoContentVerb method) ->
OpenApi
mkEndpointNoContentVerb path _ =
mempty
& paths . at path
?~ ( mempty
& method
?~ ( mempty
& at code ?~ Inline mempty
)
)
where
method = openApiMethod (Proxy :: Proxy method)
code = 204 -- hardcoded in servant-server
-- | Add parameter to every operation in the spec.
addParam :: Param -> OpenApi -> OpenApi
addParam param = allOperations . parameters %~ (Inline param :)
-- | Add RequestBody to every operations in the spec.
addRequestBody :: RequestBody -> OpenApi -> OpenApi
addRequestBody rb = allOperations . requestBody ?~ Inline rb
-- | Format given text as inline code in Markdown.
markdownCode :: Text -> Text
markdownCode s = "`" <> s <> "`"
addDefaultResponse404 :: ParamName -> OpenApi -> OpenApi
addDefaultResponse404 pname = setResponseWith (\old _new -> alter404 old) 404 (return response404)
where
sname = markdownCode pname
description404 = sname <> " not found"
alter404 = description %~ ((sname <> " or ") <>)
response404 = mempty & description .~ description404
addDefaultResponse400 :: ParamName -> OpenApi -> OpenApi
addDefaultResponse400 pname = setResponseWith (\old _new -> alter400 old) 400 (return response400)
where
sname = markdownCode pname
description400 = "Invalid " <> sname
alter400 = description %~ (<> (" or " <> sname))
response400 = mempty & description .~ description400
-- | Methods, available for OpenApi.
class OpenApiMethod method where
openApiMethod :: proxy method -> Lens' PathItem (Maybe Operation)
instance OpenApiMethod 'GET where openApiMethod _ = get
instance OpenApiMethod 'PUT where openApiMethod _ = put
instance OpenApiMethod 'POST where openApiMethod _ = post
instance OpenApiMethod 'DELETE where openApiMethod _ = delete
instance OpenApiMethod 'OPTIONS where openApiMethod _ = options
instance OpenApiMethod 'HEAD where openApiMethod _ = head_
instance OpenApiMethod 'PATCH where openApiMethod _ = patch
#if MIN_VERSION_servant(0,18,1)
instance HasOpenApi (UVerb method cs '[]) where
toOpenApi _ = mempty
-- | @since <2.0.1.0>
instance
{-# OVERLAPPABLE #-}
( ToSchema a,
HasStatus a,
AllAccept cs,
OpenApiMethod method,
HasOpenApi (UVerb method cs as)
) =>
HasOpenApi (UVerb method cs (a ': as))
where
toOpenApi _ =
toOpenApi (Proxy :: Proxy (Verb method (StatusOf a) cs a))
`combineOpenApi` toOpenApi (Proxy :: Proxy (UVerb method cs as))
where
-- The derived 'Semigroup' on 'OpenApi'/'PathItem' is left-biased and would
-- drop one of a UVerb member's responses sharing a path and method, so the
-- two documents are merged field-by-field instead.
combinePathItem :: PathItem -> PathItem -> PathItem
combinePathItem s t = PathItem
{ _pathItemRef = _pathItemRef s <|> _pathItemRef t
, _pathItemGet = _pathItemGet s <> _pathItemGet t
, _pathItemPut = _pathItemPut s <> _pathItemPut t
, _pathItemPost = _pathItemPost s <> _pathItemPost t
, _pathItemDelete = _pathItemDelete s <> _pathItemDelete t
, _pathItemOptions = _pathItemOptions s <> _pathItemOptions t
, _pathItemHead = _pathItemHead s <> _pathItemHead t
, _pathItemPatch = _pathItemPatch s <> _pathItemPatch t
, _pathItemTrace = _pathItemTrace s <> _pathItemTrace t
, _pathItemParameters = _pathItemParameters s <> _pathItemParameters t
, _pathItemSummary = _pathItemSummary s <|> _pathItemSummary t
, _pathItemDescription = _pathItemDescription s <|> _pathItemDescription t
, _pathItemServers = _pathItemServers s <> _pathItemServers t
}
combineOpenApi :: OpenApi -> OpenApi -> OpenApi
combineOpenApi s t = OpenApi
{ _openApiOpenapi = _openApiOpenapi s <> _openApiOpenapi t
, _openApiInfo = _openApiInfo s <> _openApiInfo t
, _openApiServers = _openApiServers s <> _openApiServers t
, _openApiPaths = InsOrdHashMap.unionWith combinePathItem (_openApiPaths s) (_openApiPaths t)
, _openApiWebhooks = _openApiWebhooks s <> _openApiWebhooks t
, _openApiComponents = _openApiComponents s <> _openApiComponents t
, _openApiSecurity = _openApiSecurity s <> _openApiSecurity t
, _openApiTags = _openApiTags s <> _openApiTags t
, _openApiExternalDocs = _openApiExternalDocs s <|> _openApiExternalDocs t
}
instance (Typeable (WithStatus s a), ToSchema a) => ToSchema (WithStatus s a) where
declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a)
#endif
instance {-# OVERLAPPABLE #-} (ToSchema a, AllAccept cs, KnownNat status, OpenApiMethod method) => HasOpenApi (Verb method status cs a) where
toOpenApi _ = toOpenApi (Proxy :: Proxy (Verb method status cs (Headers '[] a)))
-- | @since 1.1.7
instance (ToSchema a, Accept ct, KnownNat status, OpenApiMethod method) => HasOpenApi (Stream method status fr ct a) where
toOpenApi _ = toOpenApi (Proxy :: Proxy (Verb method status '[ct] (Headers '[] a)))
instance
{-# OVERLAPPABLE #-}
(ToSchema a, AllAccept cs, AllToResponseHeader hs, KnownNat status, OpenApiMethod method) =>
HasOpenApi (Verb method status cs (Headers hs a))
where
toOpenApi = mkEndpoint "/"
-- ATTENTION: do not remove this instance!
-- A similar instance above will always use the more general
-- polymorphic -- HasOpenApi instance and will result in a type error
-- since t'NoContent' does not have a 'ToSchema' instance.
instance (AllAccept cs, KnownNat status, OpenApiMethod method) => HasOpenApi (Verb method status cs NoContent) where
toOpenApi _ = toOpenApi (Proxy :: Proxy (Verb method status cs (Headers '[] NoContent)))
instance
(AllAccept cs, AllToResponseHeader hs, KnownNat status, OpenApiMethod method) =>
HasOpenApi (Verb method status cs (Headers hs NoContent))
where
toOpenApi = mkEndpointNoContent "/"
instance (OpenApiMethod method) => HasOpenApi (NoContentVerb method) where
toOpenApi = mkEndpointNoContentVerb "/"
instance (HasOpenApi a, HasOpenApi b) => HasOpenApi (a :<|> b) where
toOpenApi _ = toOpenApi (Proxy :: Proxy a) <> toOpenApi (Proxy :: Proxy b)
-- | @'Vault'@ combinator does not change our specification at all.
instance (HasOpenApi sub) => HasOpenApi (Vault :> sub) where
toOpenApi _ = toOpenApi (Proxy :: Proxy sub)
-- | @'IsSecure'@ combinator does not change our specification at all.
instance (HasOpenApi sub) => HasOpenApi (IsSecure :> sub) where
toOpenApi _ = toOpenApi (Proxy :: Proxy sub)
-- | @'RemoteHost'@ combinator does not change our specification at all.
instance (HasOpenApi sub) => HasOpenApi (RemoteHost :> sub) where
toOpenApi _ = toOpenApi (Proxy :: Proxy sub)
-- | @t'HttpVersion'@ combinator does not change our specification at all.
instance (HasOpenApi sub) => HasOpenApi (HttpVersion :> sub) where
toOpenApi _ = toOpenApi (Proxy :: Proxy sub)
#if MIN_VERSION_servant(0,20,0)
-- | @'WithResource'@ combinator does not change our specification at all.
instance (HasOpenApi sub) => HasOpenApi (WithResource res :> sub) where
toOpenApi _ = toOpenApi (Proxy :: Proxy sub)
#endif
-- | @'WithNamedContext'@ combinator does not change our specification at all.
instance (HasOpenApi sub) => HasOpenApi (WithNamedContext x c sub) where
toOpenApi _ = toOpenApi (Proxy :: Proxy sub)
instance (KnownSymbol sym, HasOpenApi sub) => HasOpenApi (sym :> sub) where
toOpenApi _ = prependPath piece (toOpenApi (Proxy :: Proxy sub))
where
piece = symbolVal (Proxy :: Proxy sym)
instance (KnownSymbol sym, ToParamSchema a, HasOpenApi sub, KnownSymbol (FoldDescription mods)) => HasOpenApi (Capture' mods sym a :> sub) where
toOpenApi _ =
toOpenApi (Proxy :: Proxy sub)
& addParam param
& prependPath capture
& addDefaultResponse404 tname
where
pname = symbolVal (Proxy :: Proxy sym)
tname = Text.pack pname
transDesc "" = Nothing
transDesc desc = Just (Text.pack desc)
capture = "{" <> pname <> "}"
param =
mempty
& name .~ tname
& description .~ transDesc (reflectDescription (Proxy :: Proxy mods))
& required ?~ True
& in_ .~ ParamPath
& schema ?~ Inline (toParamSchema (Proxy :: Proxy a))
-- | OpenApi Spec doesn't have a notion of CaptureAll, this instance is the best effort.
instance (KnownSymbol sym, ToParamSchema a, HasOpenApi sub) => HasOpenApi (CaptureAll sym a :> sub) where
toOpenApi _ = toOpenApi (Proxy :: Proxy (Capture sym a :> sub))
instance (KnownSymbol desc, HasOpenApi api) => HasOpenApi (Description desc :> api) where
toOpenApi _ =
toOpenApi (Proxy :: Proxy api)
& allOperations . description %~ (Just (Text.pack (symbolVal (Proxy :: Proxy desc))) <>)
instance (KnownSymbol desc, HasOpenApi api) => HasOpenApi (Summary desc :> api) where
toOpenApi _ =
toOpenApi (Proxy :: Proxy api)
& allOperations . summary %~ (Just (Text.pack (symbolVal (Proxy :: Proxy desc))) <>)
instance (KnownSymbol sym, ToParamSchema a, HasOpenApi sub, SBoolI (FoldRequired mods), KnownSymbol (FoldDescription mods)) => HasOpenApi (QueryParam' mods sym a :> sub) where
toOpenApi _ =
toOpenApi (Proxy :: Proxy sub)
& addParam param
& addDefaultResponse400 tname
where
tname = Text.pack (symbolVal (Proxy :: Proxy sym))
transDesc "" = Nothing
transDesc desc = Just (Text.pack desc)
param =
mempty
& name .~ tname
& description .~ transDesc (reflectDescription (Proxy :: Proxy mods))
& required ?~ reflectBool (Proxy :: Proxy (FoldRequired mods))
& in_ .~ ParamQuery
& schema ?~ Inline sch
sch = toParamSchema (Proxy :: Proxy a)
instance (KnownSymbol sym, ToParamSchema a, HasOpenApi sub) => HasOpenApi (QueryParams sym a :> sub) where
toOpenApi _ =
toOpenApi (Proxy :: Proxy sub)
& addParam param
& addDefaultResponse400 tname
where
tname = Text.pack (symbolVal (Proxy :: Proxy sym))
param =
mempty
& name .~ tname
& in_ .~ ParamQuery
& schema ?~ Inline pschema
pschema =
mempty
& type_ ?~ OpenApiTypeSingle OpenApiArray
& items ?~ OpenApiItemsObject (Inline $ toParamSchema (Proxy :: Proxy a))
instance (KnownSymbol sym, HasOpenApi sub) => HasOpenApi (QueryFlag sym :> sub) where
toOpenApi _ =
toOpenApi (Proxy :: Proxy sub)
& addParam param
& addDefaultResponse400 tname
where
tname = Text.pack (symbolVal (Proxy :: Proxy sym))
param =
mempty
& name .~ tname
& in_ .~ ParamQuery
& allowEmptyValue ?~ True
& schema
?~ ( Inline $
(toParamSchema (Proxy :: Proxy Bool))
& default_ ?~ toJSON False
)
instance (KnownSymbol sym, ToParamSchema a, HasOpenApi sub, SBoolI (FoldRequired mods), KnownSymbol (FoldDescription mods)) => HasOpenApi (Header' mods sym a :> sub) where
toOpenApi _ =
toOpenApi (Proxy :: Proxy sub)
& addParam param
& addDefaultResponse400 tname
where
tname = Text.pack (symbolVal (Proxy :: Proxy sym))
transDesc "" = Nothing
transDesc desc = Just (Text.pack desc)
param =
mempty
& name .~ tname
& description .~ transDesc (reflectDescription (Proxy :: Proxy mods))
& required ?~ reflectBool (Proxy :: Proxy (FoldRequired mods))
& in_ .~ ParamHeader
& schema ?~ (Inline $ toParamSchema (Proxy :: Proxy a))
instance (ToSchema a, AllAccept cs, HasOpenApi sub, KnownSymbol (FoldDescription mods)) => HasOpenApi (ReqBody' mods cs a :> sub) where
toOpenApi _ =
toOpenApi (Proxy :: Proxy sub)
& addRequestBody reqBody
& addDefaultResponse400 tname
& components . schemas %~ (<> schemaDefs)
where
tname = "body"
transDesc "" = Nothing
transDesc desc = Just (Text.pack desc)
(schemaDefs, schemaRef) = runDeclare (declareSchemaRef (Proxy :: Proxy a)) mempty
reqBody =
(mempty :: RequestBody)
& description .~ transDesc (reflectDescription (Proxy :: Proxy mods))
& content .~ InsOrdHashMap.fromList [(t, mempty & schema ?~ schemaRef) | t <- allContentType (Proxy :: Proxy cs)]
-- | This instance is an approximation.
--
-- @since 1.1.7
instance (ToSchema a, Accept ct, HasOpenApi sub, KnownSymbol (FoldDescription mods)) => HasOpenApi (StreamBody' mods fr ct a :> sub) where
toOpenApi _ =
toOpenApi (Proxy :: Proxy sub)
& addRequestBody reqBody
& addDefaultResponse400 tname
& components . schemas %~ (<> schemaDefs)
where
tname = "body"
transDesc "" = Nothing
transDesc desc = Just (Text.pack desc)
(schemaDefs, schemaRef) = runDeclare (declareSchemaRef (Proxy :: Proxy a)) mempty
reqBody =
(mempty :: RequestBody)
& description .~ transDesc (reflectDescription (Proxy :: Proxy mods))
& content .~ InsOrdHashMap.fromList [(t, mempty & schema ?~ schemaRef) | t <- toList $ contentTypes (Proxy :: Proxy ct)]
#if MIN_VERSION_servant(0,18,2)
instance (HasOpenApi sub) => HasOpenApi (Fragment a :> sub) where
toOpenApi _ = toOpenApi (Proxy :: Proxy sub)
#endif
#if MIN_VERSION_servant(0,19,0)
instance (HasOpenApi (ToServantApi sub)) => HasOpenApi (NamedRoutes sub) where
toOpenApi _ = toOpenApi (Proxy :: Proxy (ToServantApi sub))
#endif
-- =======================================================================
-- Below are the definitions that should be in Servant.API.ContentTypes
-- =======================================================================
class AllAccept cs where
allContentType :: Proxy cs -> [MediaType]
instance AllAccept '[] where
allContentType _ = []
instance (Accept c, AllAccept cs) => AllAccept (c ': cs) where
allContentType _ = contentType (Proxy :: Proxy c) : allContentType (Proxy :: Proxy cs)
class ToResponseHeader h where
toResponseHeader :: Proxy h -> (HeaderName, OpenApi.Header)
instance (KnownSymbol sym, ToParamSchema a) => ToResponseHeader (Header sym a) where
toResponseHeader _ = (hname, mempty & schema ?~ hschema)
where
hname = Text.pack (symbolVal (Proxy :: Proxy sym))
hschema = Inline $ toParamSchema (Proxy :: Proxy a)
class AllToResponseHeader hs where
toAllResponseHeaders :: Proxy hs -> InsOrdHashMap HeaderName OpenApi.Header
instance AllToResponseHeader '[] where
toAllResponseHeaders _ = mempty
instance (ToResponseHeader h, AllToResponseHeader hs) => AllToResponseHeader (h ': hs) where
toAllResponseHeaders _ = InsOrdHashMap.insert headerName headerBS hdrs
where
(headerName, headerBS) = toResponseHeader (Proxy :: Proxy h)
hdrs = toAllResponseHeaders (Proxy :: Proxy hs)
instance (AllToResponseHeader hs) => AllToResponseHeader (HList hs) where
toAllResponseHeaders _ = toAllResponseHeaders (Proxy :: Proxy hs)
#if MIN_VERSION_servant(0,20,3)
-- ================================================================
-- MultiVerb (servant >= 0.20.3) OpenAPI support.
--
-- Ported from biocad/servant-openapi3#59 (tchoutri) plus the
-- validateEveryToJSON / WithHeaders follow-ups (LaurentRDC).
-- The original 'simpleResponseSwagger' helper originates in Wire's codebase.
-- ================================================================
-- | The 'Declare' monad specialised to accumulate reusable 'Schema'
-- definitions while a 'Response' is being built.
type DeclareDefinition = Declare (Definitions Schema)
-- | The HTTP status code (a type-level 'Nat') produced by a single MultiVerb
-- response alternative.
--
-- This mirrors the associated type family
-- @Servant.Server.Internal.ResponseRender.ResponseStatus@ from servant-server,
-- but is defined locally so this package need not depend on servant-server:
-- the status already sits in the public 'Servant.API.MultiVerb' response types.
--
-- It is deliberately an /open/ type family (a list of @type instance@
-- declarations rather than a closed @where@ block) so that a user who defines a
-- custom MultiVerb response type can extend it from their own module — matching
-- the extensibility of servant-server's open associated type, without the
-- dependency. A response type with no matching instance fails loudly at compile
-- time (a stuck @MultiVerbStatus@ / "No instance for @KnownNat@"), never
-- silently.
type family MultiVerbStatus a :: Nat
type instance MultiVerbStatus (Respond s desc a) = s
type instance MultiVerbStatus (RespondAs ct s desc a) = s
type instance MultiVerbStatus (RespondStreaming s desc fr ct) = s
type instance MultiVerbStatus (WithHeaders hs a r) = MultiVerbStatus r
-- | Produce the OpenAPI 'Response' object for one MultiVerb response
-- alternative.
class IsSwaggerResponse (cs :: k) a where
responseSwagger :: DeclareDefinition Response
instance
(AllToResponseHeader hs, IsSwaggerResponse cs r) =>
IsSwaggerResponse cs (WithHeaders hs a r)
where
responseSwagger =
fmap
(headers .~ fmap Inline (toAllResponseHeaders (Proxy @hs)))
(responseSwagger @_ @cs @r)
-- | Build a 'Response' carrying a single schema, exposed under the given list
-- of content types.
simpleResponseSwagger
:: forall a cs desc. (ToSchema a, KnownSymbol desc, AllMime cs)
=> DeclareDefinition Response
simpleResponseSwagger = do
schemaRef <- declareSchemaRef (Proxy @a)
let resps :: InsOrdHashMap MediaType MediaTypeObject
resps = InsOrdHashMap.fromList $
(,MediaTypeObject (pure schemaRef) Nothing mempty mempty) <$> cs
pure $
mempty
& description .~ Text.pack (symbolVal (Proxy @desc))
& content .~ resps
where
cs :: [MediaType]
cs = allMime (Proxy @cs)
instance
(KnownSymbol desc, ToSchema a, AllMime cs) =>
IsSwaggerResponse (cs :: [Type]) (Respond s desc a)
where
responseSwagger = simpleResponseSwagger @a @cs @desc
instance
(KnownSymbol desc, ToSchema a) =>
IsSwaggerResponse '() (Respond s desc a)
where
responseSwagger = simpleResponseSwagger @a @'[JSON] @desc
instance
(KnownSymbol desc, ToSchema a, Accept ct) =>
IsSwaggerResponse cs (RespondAs (ct :: Type) s desc a)
where
responseSwagger = simpleResponseSwagger @a @'[ct] @desc
instance
(KnownSymbol desc) =>
IsSwaggerResponse cs (RespondEmpty s desc)
where
responseSwagger =
pure $
mempty & description .~ Text.pack (symbolVal (Proxy @desc))
-- | Fold a MultiVerb's list of response alternatives into a
-- status-code-keyed map of 'Response' objects, merging alternatives that
-- share a status code.
class IsSwaggerResponseList (cs :: k) (as :: [Type]) where
responseListSwagger :: DeclareDefinition (InsOrdHashMap HttpStatusCode Response)
instance IsSwaggerResponseList cs '[] where
responseListSwagger = pure mempty
instance
( IsSwaggerResponse cs a
, KnownNat (MultiVerbStatus a)
, IsSwaggerResponseList cs as
) =>
IsSwaggerResponseList cs (a ': as)
where
responseListSwagger =
InsOrdHashMap.insertWith
combineResponseSwagger
(fromIntegral (natVal (Proxy @(MultiVerbStatus a))))
<$> responseSwagger @_ @cs @a
<*> responseListSwagger @_ @cs @as
-- | Merge two responses that share a status code: concatenate descriptions and
-- union their content maps.
combineResponseSwagger :: Response -> Response -> Response
combineResponseSwagger r1 r2 =
r1
& description <>~ ("\n\n" <> r2 ^. description)
& content %~ flip (InsOrdHashMap.unionWith combineMediaTypeObject) (r2 ^. content)
combineMediaTypeObject :: MediaTypeObject -> MediaTypeObject -> MediaTypeObject
combineMediaTypeObject m1 m2 =
m1 & schema .~ merge (m1 ^. schema) (m2 ^. schema)
where
merge Nothing a = a
merge a Nothing = a
merge (Just (Inline a)) (Just (Inline b)) = pure $ Inline $ combineSwaggerSchema a b
merge a@(Just (Ref _)) _ = a
merge _ a@(Just (Ref _)) = a
-- | Heuristic used by 'combineMediaTypeObject': when two inline schemas both
-- look like tagged error objects (both carry a @code@ property), union their
-- @label@ enums; otherwise keep the first schema. (Inherited from the Wire
-- codebase; harmless for non-error schemas.)
combineSwaggerSchema :: Schema -> Schema -> Schema
combineSwaggerSchema s1 s2
| notNullOf (properties . ix "code") s1
&& notNullOf (properties . ix "code") s2 =
s1
& properties . ix "label" . _Inline . enum_ . _Just
<>~ (s2 ^. properties . ix "label" . _Inline . enum_ . _Just)
| otherwise = s1
instance
(OpenApiMethod method, IsSwaggerResponseList cs as) =>
HasOpenApi (MultiVerb method cs as r)
where
toOpenApi _ =
mempty
& components . schemas <>~ schemaDefs
& paths . at "/" ?~
(mempty & method ?~
(mempty & responses . responses .~ refResps))
where
method = openApiMethod (Proxy @method)
(schemaDefs, resps) = runDeclare (responseListSwagger @_ @cs @as) mempty
refResps = Inline <$> resps
#endif