diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,10 @@ -1.1.8 +2.0.2.0 ------- + +* Support for `servant-0.20.3.0` features, including `MultiVerb` and `WithHeaders` + +1.1.8 +----- * Support `servant-0.17` diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,14 +1,9 @@ # servant-openapi3 [![Hackage](https://img.shields.io/hackage/v/servant-openapi3.svg)](http://hackage.haskell.org/package/servant-openapi3) -[![Build Status](https://travis-ci.org/biocad/servant-openapi3.svg?branch=master)](https://travis-ci.org/biocad/servant-openapi3) -[![Stackage LTS](http://stackage.org/package/servant-openapi3/badge/lts)](http://stackage.org/lts/package/servant-openapi3) -[![Stackage Nightly](http://stackage.org/package/servant-openapi3/badge/nightly)](http://stackage.org/nightly/package/servant-openapi3) OpenAPI 3.0 conforming json for [servant](https://github.com/haskell-servant/servant) APIs. -![servant-swagger robot](http://s16.postimg.org/rndz1wbyt/servant.png) - ### Motivation Swagger is a project used to describe and document RESTful APIs. @@ -43,4 +38,4 @@ We are happy to receive bug reports, fixes, documentation enhancements, and other improvements. -Please report bugs via the [github issue tracker](https://github.com/biocad/servant-openapi3/issues). +Please report bugs via the [github issue tracker](https://github.com/bitnomial/servant-openapi3/issues). diff --git a/example/example.cabal b/example/example.cabal --- a/example/example.cabal +++ b/example/example.cabal @@ -18,15 +18,19 @@ || ==8.8.4 || ==8.10.7 || ==9.0.2 - || ==9.2.2 - || ==9.4.3 + || ==9.2.8 + || ==9.4.8 + || ==9.6.3 + || ==9.8.1 + || ==9.10.2 + || ==9.12.1 library ghc-options: -Wall hs-source-dirs: src/ exposed-modules: Todo - build-depends: base + build-depends: base < 5 , aeson , aeson-pretty , bytestring @@ -37,6 +41,7 @@ , openapi3 , text , time + , generics-sop default-language: Haskell2010 executable swagger-server diff --git a/example/src/Todo.hs b/example/src/Todo.hs --- a/example/src/Todo.hs +++ b/example/src/Todo.hs @@ -4,6 +4,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DerivingVia #-} module Todo where import Control.Lens @@ -18,6 +19,8 @@ import GHC.Generics import Servant import Servant.OpenApi +import qualified Generics.SOP as GSOP +import Servant.API.MultiVerb todoAPI :: Proxy TodoAPI todoAPI = Proxy @@ -28,7 +31,8 @@ :<|> "todo" :> ReqBody '[JSON] Todo :> Post '[JSON] TodoId :<|> "todo" :> Capture "id" TodoId :> Get '[JSON] Todo :<|> "todo" :> Capture "id" TodoId :> ReqBody '[JSON] Todo :> Put '[JSON] TodoId - + :<|> "todo" :> "choices" :> MultipleChoicesInt + -- | API for serving @swagger.json@. type SwaggerAPI = "swagger.json" :> Get '[JSON] OpenApi @@ -71,3 +75,28 @@ -- | Output generated @swagger.json@ file for the @'TodoAPI'@. writeSwaggerJSON :: IO () writeSwaggerJSON = BL8.writeFile "example/swagger.json" (encodePretty todoSwagger) + +type MultiResponses = + '[ RespondEmpty 400 "Negative" + , Respond 200 "Even number" Bool + , Respond 200 "Odd number" Int + ] + +-- All possible return types +data MultiResult + = NegativeNumber + | Even Bool + | Odd Int + deriving stock (Generic) + deriving (AsUnion MultiResponses) + via GenericAsUnion MultiResponses MultiResult + +instance GSOP.Generic MultiResult + +type MultipleChoicesInt = + Capture "int" Int + :> MultiVerb + 'GET + '[JSON] + MultiResponses + MultiResult diff --git a/example/swagger.json b/example/swagger.json --- a/example/swagger.json +++ b/example/swagger.json @@ -1,14 +1,48 @@ { - "openapi": "3.0.0", + "components": { + "schemas": { + "Todo": { + "description": "This is some real Todo right here", + "example": { + "created": "2015-12-31T00:00:00Z", + "summary": "get milk" + }, + "properties": { + "created": { + "$ref": "#/components/schemas/UTCTime" + }, + "summary": { + "type": "string" + } + }, + "required": [ + "created", + "summary" + ], + "type": "object" + }, + "TodoId": { + "maximum": 9223372036854775807, + "minimum": -9223372036854775808, + "type": "integer" + }, + "UTCTime": { + "example": "2016-07-22T00:00:00Z", + "format": "yyyy-mm-ddThh:MM:ssZ", + "type": "string" + } + } + }, "info": { - "version": "1.0", - "title": "Todo API", + "description": "This is an API that tests swagger integration", "license": { - "url": "http://mit.com", - "name": "MIT" + "name": "MIT", + "url": "http://mit.com" }, - "description": "This is an API that tests swagger integration" + "title": "Todo API", + "version": "1.0" }, + "openapi": "3.0.0", "paths": { "/todo": { "get": { @@ -39,9 +73,6 @@ } }, "responses": { - "400": { - "description": "Invalid `body`" - }, "200": { "content": { "application/json;charset=utf-8": { @@ -51,28 +82,67 @@ } }, "description": "" + }, + "400": { + "description": "Invalid `body`" } } } }, - "/todo/{id}": { + "/todo/choices/{int}": { "get": { "parameters": [ { + "in": "path", + "name": "int", "required": true, "schema": { "maximum": 9223372036854775807, "minimum": -9223372036854775808, "type": "integer" + } + } + ], + "responses": { + "200": { + "content": { + "application/json": { + "schema": { + "type": "boolean" + } + }, + "application/json;charset=utf-8": { + "schema": { + "type": "boolean" + } + } }, + "description": "Even number\n\nOdd number" + }, + "400": { + "description": "Negative" + }, + "404": { + "description": "`int` not found" + } + } + } + }, + "/todo/{id}": { + "get": { + "parameters": [ + { "in": "path", - "name": "id" + "name": "id", + "required": true, + "schema": { + "maximum": 9223372036854775807, + "minimum": -9223372036854775808, + "type": "integer" + } } ], "responses": { - "404": { - "description": "`id` not found" - }, "200": { "content": { "application/json;charset=utf-8": { @@ -82,20 +152,23 @@ } }, "description": "" + }, + "404": { + "description": "`id` not found" } } }, "put": { "parameters": [ { + "in": "path", + "name": "id", "required": true, "schema": { "maximum": 9223372036854775807, "minimum": -9223372036854775808, "type": "integer" - }, - "in": "path", - "name": "id" + } } ], "requestBody": { @@ -108,12 +181,6 @@ } }, "responses": { - "404": { - "description": "`id` not found" - }, - "400": { - "description": "Invalid `body`" - }, "200": { "content": { "application/json;charset=utf-8": { @@ -123,42 +190,14 @@ } }, "description": "" - } - } - } - } - }, - "components": { - "schemas": { - "Todo": { - "example": { - "summary": "get milk", - "created": "2015-12-31T00:00:00Z" - }, - "required": [ - "created", - "summary" - ], - "type": "object", - "description": "This is some real Todo right here", - "properties": { - "summary": { - "type": "string" }, - "created": { - "$ref": "#/components/schemas/UTCTime" + "400": { + "description": "Invalid `body`" + }, + "404": { + "description": "`id` not found" } } - }, - "UTCTime": { - "example": "2016-07-22T00:00:00Z", - "format": "yyyy-mm-ddThh:MM:ssZ", - "type": "string" - }, - "TodoId": { - "maximum": 9223372036854775807, - "minimum": -9223372036854775808, - "type": "integer" } } } diff --git a/servant-openapi3.cabal b/servant-openapi3.cabal --- a/servant-openapi3.cabal +++ b/servant-openapi3.cabal @@ -1,5 +1,5 @@ name: servant-openapi3 -version: 2.0.1.6 +version: 2.0.2.0 synopsis: Generate a Swagger/OpenAPI/OAS 3.0 specification for your servant API. description: Swagger is a project used to describe and document RESTful APIs. The core of the @@ -18,13 +18,15 @@ * generating clients and servers in many languages using [Swagger Codegen](http://swagger.io/swagger-codegen/); . * and [many others](http://swagger.io/open-source-integrations/). -homepage: https://github.com/biocad/servant-openapi3 -bug-reports: https://github.com/biocad/servant-openapi3/issues +homepage: https://github.com/bitnomial/servant-openapi3 +bug-reports: https://github.com/bitnomial/servant-openapi3/issues license: BSD3 license-file: LICENSE author: David Johnson, Nickolay Kudasov, Maxim Koltsov -maintainer: nickolay.kudasov@gmail.com, kolmax94@gmail.com +maintainer: Laurent P. Rene de Cotret copyright: (c) 2015-2020, Servant contributors + (c) 2020-2025 Maxim Koltsov + (c) 2026 servant-openapi3 contributors category: Web, Servant, Swagger build-type: Custom cabal-version: 1.18 @@ -33,8 +35,12 @@ || ==8.8.4 || ==8.10.7 || ==9.0.2 - || ==9.2.2 - || ==9.4.3 + || ==9.2.8 + || ==9.4.8 + || ==9.6.3 + || ==9.8.1 + || ==9.10.2 + || ==9.12.1 extra-source-files: README.md @@ -51,12 +57,12 @@ source-repository head type: git - location: https://github.com/biocad/servant-openapi3.git + location: https://github.com/bitnomial/servant-openapi3.git custom-setup setup-depends: - base >=4.9 && <4.18, - Cabal >= 1.24, + base >=4.9 && <4.22, + Cabal >= 1.24 && < 4, cabal-doctest >=1.0.6 && <1.1 library @@ -75,19 +81,22 @@ Servant.OpenApi.Internal.TypeLevel.Every Servant.OpenApi.Internal.TypeLevel.TMap hs-source-dirs: src - build-depends: aeson >=1.4.2.0 && <1.6 || >=2.0.1.0 && <2.2 + build-depends: aeson >=1.4.2.0 && <1.6 || >=2.0.1.0 && <2.3 , aeson-pretty >=0.8.7 && <0.9 - , base >=4.9.1.0 && <4.18 - , base-compat >=0.10.5 && <0.13 - , bytestring >=0.10.8.1 && <0.12 + , base >=4.9.1.0 && <4.22 + , base-compat >=0.10.5 && <0.15 + , bytestring >=0.10.8.1 && <0.13 , http-media >=0.7.1.3 && <0.9 , insert-ordered-containers >=0.2.1.0 && <0.3 - , lens >=4.17 && <5.3 - , servant >=0.17 && <0.20 + , lens >=4.17 && <5.4 + , servant >=0.17 && <0.21 + , servant-server >=0.17 && <0.21 + , servant-client-core >=0.17 && <0.21 , singleton-bool >=0.1.4 && <0.2 , openapi3 >=3.2.3 && <3.3 , text >=1.2.3.0 && <3 , unordered-containers >=0.2.9.0 && <0.3 + , generics-sop >=0.5.1 , hspec , QuickCheck @@ -96,9 +105,9 @@ test-suite doctests ghc-options: -Wall build-depends: - base, + base <5, directory >= 1.0, - doctest >= 0.11.1 && <0.21, + doctest >= 0.11.1 && <0.25, servant, QuickCheck, filepath @@ -112,11 +121,11 @@ type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Spec.hs - build-tool-depends: hspec-discover:hspec-discover >=2.6.0 && <2.11 - build-depends: base + build-tool-depends: hspec-discover:hspec-discover >=2.6.0 && <2.12 + build-depends: base <5 , base-compat , aeson - , hspec >=2.6.0 && <2.11 + , hspec >=2.6.0 && <2.12 , QuickCheck , lens , lens-aeson >=1.0.2 && <1.3 diff --git a/src/Servant/OpenApi.hs b/src/Servant/OpenApi.hs --- a/src/Servant/OpenApi.hs +++ b/src/Servant/OpenApi.hs @@ -506,13 +506,14 @@ -- >>> hspec $ validateEveryToJSON (Proxy :: Proxy UserAPI) -- -- [User]... --- ... +-- +++ OK, passed 100 tests. -- User... --- ... +-- +++ OK, passed 100 tests. -- UserId... --- ... +-- +++ OK, passed 100 tests. +-- -- Finished in ... seconds --- ...3 examples, 0 failures... +-- 3 examples, 0 failures -- -- Although servant is great, chances are that your API clients don't use Haskell. -- In many cases @swagger.json@ serves as a specification, not a Haskell type. diff --git a/src/Servant/OpenApi/Internal.hs b/src/Servant/OpenApi/Internal.hs --- a/src/Servant/OpenApi/Internal.hs +++ b/src/Servant/OpenApi/Internal.hs @@ -1,25 +1,25 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} -#if __GLASGOW_HASKELL__ >= 806 -{-# LANGUAGE UndecidableInstances #-} -#endif +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} module Servant.OpenApi.Internal where import Prelude () import Prelude.Compat -#if MIN_VERSION_servant(0,18,1) -import Control.Applicative ((<|>)) -#endif +import Control.Applicative ((<|>)) import Control.Lens import Data.Aeson import Data.Foldable (toList) @@ -38,11 +38,14 @@ import Servant.API import Servant.API.Description (FoldDescription, reflectDescription) import Servant.API.Modifiers (FoldRequired) -#if MIN_VERSION_servant(0,19,0) -import Servant.API.Generic (ToServantApi) -#endif - import Servant.OpenApi.Internal.TypeLevel.API +import Data.Kind (Type) +import Servant.API.ContentTypes (AllMime, allMime) +#if MIN_VERSION_servant(0,20,3) +import qualified Servant.Server.Internal.ResponseRender as Server +import Servant.API.MultiVerb +#endif +import qualified Data.Maybe as List -- | Generate a OpenApi specification for a servant API. -- @@ -287,6 +290,12 @@ 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) @@ -461,3 +470,157 @@ instance AllToResponseHeader hs => AllToResponseHeader (HList hs) where toAllResponseHeaders _ = toAllResponseHeaders (Proxy :: Proxy hs) + +#if MIN_VERSION_servant(0,20,3) +type DeclareDefinition = Declare (Definitions Schema) + +class IsSwaggerResponse a where + responseSwagger :: DeclareDefinition Response + +instance + (AllToResponseHeader hs, IsSwaggerResponse r) => + IsSwaggerResponse (WithHeaders hs a r) + where + responseSwagger = + fmap + (headers .~ fmap Inline (toAllResponseHeaders (Proxy @hs))) + (responseSwagger @r) + +simpleResponseSwagger :: forall a cs desc. (ToSchema a, KnownSymbol desc, AllMime cs) => DeclareDefinition Response +simpleResponseSwagger = do + ref <- declareSchemaRef (Proxy @a) + let resps :: InsOrdHashMap MediaType MediaTypeObject + resps = InsOrdHashMap.fromList $ (,MediaTypeObject (pure ref) 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) => + IsSwaggerResponse (Respond s desc a) + where + -- Defaulting this to JSON, as openapi3 needs something to map a schema against. + responseSwagger = simpleResponseSwagger @a @'[JSON] @desc + +instance + (KnownSymbol desc, ToSchema a, Accept ct) => + IsSwaggerResponse (RespondAs (ct :: Type) s desc a) + where + responseSwagger = simpleResponseSwagger @a @'[ct] @desc + +instance + (KnownSymbol desc) => + IsSwaggerResponse (RespondEmpty s desc) + where + responseSwagger = + pure $ + mempty + & description .~ Text.pack (symbolVal (Proxy @desc)) + +class IsSwaggerResponseList (as :: [Type]) where + responseListSwagger :: DeclareDefinition (InsOrdHashMap HttpStatusCode Response) + +instance IsSwaggerResponseList '[] where + responseListSwagger = pure mempty + +instance + ( IsSwaggerResponse a, + KnownNat (Server.ResponseStatus a), + IsSwaggerResponseList as + ) => + IsSwaggerResponseList (a ': as) + where + responseListSwagger = + InsOrdHashMap.insertWith + combineResponseSwagger + (fromIntegral (natVal (Proxy @(Server.ResponseStatus a)))) + <$> responseSwagger @a + <*> responseListSwagger @as + +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 + +combineSwaggerSchema :: Schema -> Schema -> Schema +combineSwaggerSchema s1 s2 + -- if they are both errors, merge label enums + | 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 as) => + HasOpenApi (MultiVerb method '() as r) + where + toOpenApi _ = + mempty + & components . schemas <>~ defs + & paths + . at "/" + ?~ ( mempty + & method + ?~ ( mempty + & responses . responses .~ refResps + ) + ) + where + method = openApiMethod (Proxy @method) + (defs, resps) = runDeclare (responseListSwagger @as) mempty + refResps = Inline <$> resps + +instance + (OpenApiMethod method, IsSwaggerResponseList as, AllMime cs) => + HasOpenApi (MultiVerb method (cs :: [Type]) as r) + where + toOpenApi _ = + mempty + & components . schemas <>~ defs + & paths + . at "/" + ?~ ( mempty + & method + ?~ ( mempty + & responses . responses .~ refResps + ) + ) + where + method = openApiMethod (Proxy @method) + -- This has our content types. + cs = allMime (Proxy @cs) + -- This has our schemas + (defs, resps) = runDeclare (responseListSwagger @as) mempty + -- We need to zip them together, and stick it all back into the contentMap + -- Since we have a single schema per type, and are only changing the content-types, + -- we should be able to pick a schema out of the resps' map, and then use it for + -- all of the values of cs + addMime :: Response -> Response + addMime resp = + resp + & content + %~ + -- pick out an element from the map, if any exist. + -- These will all have the same schemas, and we are reapplying the content types. + foldMap (\c -> InsOrdHashMap.fromList $ (,c) <$> cs) + . List.listToMaybe + . toList + refResps = Inline . addMime <$> resps +#endif diff --git a/src/Servant/OpenApi/Internal/Test.hs b/src/Servant/OpenApi/Internal/Test.hs --- a/src/Servant/OpenApi/Internal/Test.hs +++ b/src/Servant/OpenApi/Internal/Test.hs @@ -52,11 +52,12 @@ -- -- ToJSON matches ToSchema -- User... --- ... +-- +++ OK, passed 100 tests. -- UserId... --- ... +-- +++ OK, passed 100 tests. +-- -- Finished in ... seconds --- ...2 examples, 0 failures... +-- 2 examples, 0 failures -- -- For the test to compile all body types should have the following instances: -- @@ -73,7 +74,7 @@ -- >>> type ContactAPI = Get '[JSON] Contact -- >>> hspec $ validateEveryToJSON (Proxy :: Proxy ContactAPI) -- ... --- ...No instance for (Arbitrary Contact) +-- ...No instance for ...Arbitrary Contact... -- ... arising from a use of ‘validateEveryToJSON’ -- ... validateEveryToJSON @@ -116,13 +117,14 @@ -- -- read . show == id -- Bool... --- ... +-- +++ OK, passed 100 tests. -- Int... --- ... +-- +++ OK, passed 100 tests. -- [Char]... --- ... +-- +++ OK, passed 100 tests. +-- -- Finished in ... seconds --- ...3 examples, 0 failures... +-- 3 examples, 0 failures props :: forall p p'' cs xs. TMap (Every (Typeable ': Show ': Arbitrary ': cs)) xs => p cs -- ^ A list of constraints. -> (forall x. EveryTF cs x => x -> Property) -- ^ Property predicate. diff --git a/src/Servant/OpenApi/Internal/TypeLevel/API.hs b/src/Servant/OpenApi/Internal/TypeLevel/API.hs --- a/src/Servant/OpenApi/Internal/TypeLevel/API.hs +++ b/src/Servant/OpenApi/Internal/TypeLevel/API.hs @@ -13,7 +13,10 @@ #if MIN_VERSION_servant(0,19,0) import Servant.API.Generic (ToServantApi) #endif - +#if MIN_VERSION_servant(0,20,3) +import Servant.API.MultiVerb (MultiVerb, Respond, RespondAs, RespondStreaming, WithHeaders, GenericAsConstructor) +import Data.ByteString (ByteString) +#endif -- | Build a list of endpoints from an API. type family EndpointsList api where EndpointsList (a :<|> b) = AppendList (EndpointsList a) (EndpointsList b) @@ -89,6 +92,9 @@ BodyTypes' c (Verb verb b cs (Headers hdrs a)) = AddBodyType c cs a '[] BodyTypes' c (Verb verb b cs NoContent) = '[] BodyTypes' c (Verb verb b cs a) = AddBodyType c cs a '[] +#if MIN_VERSION_servant(0,20,3) + BodyTypes' c (MultiVerb verb cs as _) = AddBodyType c cs () (MultiVerbResponseBodies as) +#endif BodyTypes' c (ReqBody' mods cs a :> api) = AddBodyType c cs a (BodyTypes' c api) BodyTypes' c (e :> api) = BodyTypes' c api BodyTypes' c (a :<|> b) = AppendList (BodyTypes' c a) (BodyTypes' c b) @@ -96,3 +102,32 @@ BodyTypes' c (NamedRoutes api) = BodyTypes' c (ToServantApi api) #endif BodyTypes' c api = '[] + + +#if MIN_VERSION_servant(0,20,3) +-- | The 'ResponseTypes' class allows to extract all types +-- involved in a response, whether or not this type is +-- in the body of the response, or, for example, in a header. +-- +-- This is problematic because, if the response contains a header (e.g. `Header "Set-Cookie" SetCookie`), +-- then the header type also needs instances for `To/FromJSON` and `Arbitrary` +-- for testing purposes, even though this isn't needed in practice. +-- +-- We want to extract only the body, for which there is no +-- built-in functionality at this time. +-- +-- See Servant.API.MultiVerb.ResponseTypes for an example of how +-- this mechanism can be implemented +type family MultiVerbResponseBody a + +type instance MultiVerbResponseBody (Respond s description a) = a +type instance MultiVerbResponseBody (RespondAs contentType s description a) = a +type instance MultiVerbResponseBody (RespondStreaming s description framing contentType) = SourceIO ByteString +-- The following instance is the main difference between 'MultiVerbResponseBody' and 'ResponseType' +type instance MultiVerbResponseBody (WithHeaders headers returnType response) = MultiVerbResponseBody response +type instance MultiVerbResponseBody (GenericAsConstructor r) = MultiVerbResponseBody r + +type family MultiVerbResponseBodies (as :: [*]) where + MultiVerbResponseBodies '[] = '[] + MultiVerbResponseBodies (a ': as) = MultiVerbResponseBody a ': MultiVerbResponseBodies as +#endif