diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,12 @@ +4.1.0 +----- + +* Support servant's `MultiVerb` combinator (servant ≥ 0.20.3): `toOpenApi` + now describes `MultiVerb` endpoints — one response object per status code, + merging alternatives that share a code — and `validateEveryToJSON` / + `Servant.OpenApi.Test` extract their body types. Ports + biocad/servant-openapi3#59 without taking on a `servant-server` dependency. + 4.0.0 ----- diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -109,18 +109,14 @@ that random values of each response type validate against the generated schema. 3. **Authoritative conformance** — the `gen-openapi` output lints cleanly under - [`vacuum`](https://quobix.com/vacuum/): + [`vacuum`](https://quobix.com/vacuum/) (0 errors). On servant ≥ 0.20.3 the + API includes a `MultiVerb` endpoint, so this check also validates MultiVerb + rendering against the OpenAPI 3.1 spec: ```bash cabal run gen-openapi > openapi.json nix run nixpkgs#vacuum-go -- lint -d openapi.json ``` - -## Contributing - -Bug reports, fixes, documentation improvements, and other contributions are -welcome. Please open an issue or pull request on the -[GitHub issue tracker](https://github.com/shinzui/servant-openapi-hs/issues). ## License diff --git a/app/GenOpenApi.hs b/app/GenOpenApi.hs --- a/app/GenOpenApi.hs +++ b/app/GenOpenApi.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -- | Emit a representative API's OpenAPI 3.1 document as JSON to stdout. @@ -11,6 +12,11 @@ -- @info@ (title/version/description), a @server@, @tags@, and a unique -- @operationId@ per operation — so an external linter has a realistic document -- to validate rather than the bare skeleton @toOpenApi@ produces by default. +-- +-- On servant >= 0.20.3 the API also includes a 'MultiVerb' endpoint, so the +-- external linter exercises MultiVerb rendering (multiple status codes, an +-- empty-body response, and a response carrying headers) and catches any future +-- regression that produces a structurally invalid OpenAPI 3.1 document. module Main (main) where import Control.Lens @@ -24,6 +30,9 @@ import Data.Text (Text) import GHC.Generics (Generic) import Servant.API +#if MIN_VERSION_servant(0,20,3) +import Servant.API.MultiVerb (MultiVerb, Respond, RespondEmpty, WithHeaders) +#endif import Servant.OpenApi (toOpenApi) -- A small but representative Todo-style CRUD API: a response record with a @@ -48,12 +57,29 @@ instance ToJSON NewTodo instance ToSchema NewTodo +#if MIN_VERSION_servant(0,20,3) +-- | Responses for the MultiVerb status endpoint: an empty-body 404, a plain +-- 200 carrying the todo, and a 203 whose response also carries a header — so +-- the linted document exercises MultiVerb's multi-status, empty-body, and +-- header-carrying rendering paths. +type TodoStatusResponses = + '[ RespondEmpty 404 "No todo with that id" + , Respond 200 "The todo's current state" Todo + , WithHeaders '[Header "X-Revision" Int] Todo + (Respond 203 "Non-authoritative todo state" Todo) + ] +#endif + type TodoAPI = "todos" :> Get '[JSON] [Todo] :<|> "todos" :> ReqBody '[JSON] NewTodo :> Post '[JSON] Todo :<|> "todos" :> Capture "id" Int :> Get '[JSON] Todo :<|> "todos" :> Capture "id" Int :> ReqBody '[JSON] NewTodo :> Put '[JSON] Todo :<|> "todos" :> Capture "id" Int :> Delete '[JSON] NoContent +#if MIN_VERSION_servant(0,20,3) + :<|> "todos" :> "status" :> Capture "id" Int + :> MultiVerb 'GET '[JSON] TodoStatusResponses () +#endif -- | The generated bare document enriched into a complete OpenAPI 3.1 contract. spec :: O.OpenApi diff --git a/servant-openapi-hs.cabal b/servant-openapi-hs.cabal --- a/servant-openapi-hs.cabal +++ b/servant-openapi-hs.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: servant-openapi-hs -version: 4.0.0 +version: 4.1.0 synopsis: Generate an OpenAPI 3.1 specification for your servant API. description: [OpenAPI](https://spec.openapis.org/oas/v3.1.0) is a language-agnostic format 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,7 +1,9 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} @@ -28,6 +30,8 @@ import Data.Foldable (toList) import Data.HashMap.Strict.InsOrd (InsOrdHashMap) import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap +import Data.Kind (Type) +import Data.Maybe (listToMaybe) import Data.OpenApi hiding (Header, contentType) import qualified Data.OpenApi as OpenApi import Data.OpenApi.Declare @@ -39,8 +43,12 @@ 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 @@ -471,3 +479,192 @@ 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 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) + +-- | 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) => + IsSwaggerResponse (Respond s desc a) + where + -- Default the schema's content type to JSON: openapi needs *some* media type + -- to hang the schema on, and the enclosing MultiVerb instance reapplies the + -- real content-type list afterwards. + 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)) + +-- | 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 (as :: [Type]) where + responseListSwagger :: DeclareDefinition (InsOrdHashMap HttpStatusCode Response) + +instance IsSwaggerResponseList '[] where + responseListSwagger = pure mempty + +instance + ( IsSwaggerResponse a + , KnownNat (MultiVerbStatus a) + , IsSwaggerResponseList as + ) => + IsSwaggerResponseList (a ': as) + where + responseListSwagger = + InsOrdHashMap.insertWith + combineResponseSwagger + (fromIntegral (natVal (Proxy @(MultiVerbStatus a)))) + <$> responseSwagger @a + <*> responseListSwagger @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 + +-- | MultiVerb whose request-mime-types slot is @'()@ (no content types given): +-- the response schemas keep their JSON default. +instance + (OpenApiMethod method, IsSwaggerResponseList as) => + HasOpenApi (MultiVerb method '() 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 @as) mempty + refResps = Inline <$> resps + +-- | MultiVerb with an explicit content-type list @cs@: reapply @cs@ to every +-- response's single schema. +instance + (OpenApiMethod method, IsSwaggerResponseList as, AllMime cs) => + HasOpenApi (MultiVerb method (cs :: [Type]) as r) + where + toOpenApi _ = + mempty + & components . schemas <>~ schemaDefs + & paths . at "/" ?~ + (mempty & method ?~ + (mempty & responses . responses .~ refResps)) + where + method = openApiMethod (Proxy @method) + cs = allMime (Proxy @cs) + (schemaDefs, resps) = runDeclare (responseListSwagger @as) mempty + -- Each alternative already holds a single (JSON-defaulted) schema; swap in + -- the MultiVerb's own content types, reusing that one schema for each. + addMime :: Response -> Response + addMime resp = + resp + & content %~ + ( foldMap (\c -> InsOrdHashMap.fromList $ (,c) <$> cs) + . listToMaybe + . toList + ) + refResps = Inline . addMime <$> resps +#endif 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 @@ -12,6 +12,10 @@ import Data.Kind (Constraint, Type) import Servant.API +#if MIN_VERSION_servant(0,20,3) +import Data.ByteString (ByteString) +import Servant.API.MultiVerb (MultiVerb, Respond, RespondAs, RespondStreaming, WithHeaders, GenericAsConstructor) +#endif -- | Build a list of endpoints from an API. type family EndpointsList api where @@ -88,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) @@ -95,3 +102,22 @@ BodyTypes' c (NamedRoutes api) = BodyTypes' c (ToServantApi api) #endif BodyTypes' c api = '[] + +#if MIN_VERSION_servant(0,20,3) +-- | The body type carried by a single MultiVerb response alternative. +-- +-- Unlike servant's own 'Servant.API.MultiVerb.ResponseType', this looks +-- *through* 'WithHeaders' to the underlying body, so that header types — which +-- need no JSON/Arbitrary instances — are never dragged into 'validateEveryToJSON'. +type family MultiVerbResponseBody a +type instance MultiVerbResponseBody (Respond s desc a) = a +type instance MultiVerbResponseBody (RespondAs ct s desc a) = a +type instance MultiVerbResponseBody (RespondStreaming s desc fr ct) = SourceIO ByteString +type instance MultiVerbResponseBody (WithHeaders hs a r) = MultiVerbResponseBody r +type instance MultiVerbResponseBody (GenericAsConstructor r) = MultiVerbResponseBody r + +-- | Map 'MultiVerbResponseBody' over a MultiVerb's response list. +type family MultiVerbResponseBodies (as :: [Type]) where + MultiVerbResponseBodies '[] = '[] + MultiVerbResponseBodies (a ': as) = MultiVerbResponseBody a ': MultiVerbResponseBodies as +#endif diff --git a/test/Servant/OpenApiSpec.hs b/test/Servant/OpenApiSpec.hs --- a/test/Servant/OpenApiSpec.hs +++ b/test/Servant/OpenApiSpec.hs @@ -23,6 +23,9 @@ import Data.Time import GHC.Generics import Servant.API +#if MIN_VERSION_servant(0,20,3) +import Servant.API.MultiVerb (MultiVerb, Respond, RespondAs, RespondEmpty, WithHeaders) +#endif import Servant.OpenApi import Servant.Test.ComprehensiveAPI (comprehensiveAPI) import Test.Hspec hiding (example) @@ -49,6 +52,17 @@ #if MIN_VERSION_servant(0,18,1) it "UVerb API" $ checkOpenApi uverbOpenApi uverbAPI #endif +#if MIN_VERSION_servant(0,20,3) + it "MultiVerb API" $ checkOpenApi multiVerbOpenApi multiVerbAPI + it "MultiVerb covers every supported response constructor" $ do + let doc = toJSON coverageOpenApi + codes k = doc ^? key "paths" . key "/cov" . key "get" + . key "responses" . key k + codes "200" `shouldSatisfy` has _Just + codes "201" `shouldSatisfy` has _Just + codes "202" `shouldSatisfy` has _Just + codes "204" `shouldSatisfy` has _Just +#endif -- Layer 1: every generated document round-trips through openapi-hs's -- 'FromJSON OpenApi', which rejects any version outside 3.1.0 .. 3.1.1. @@ -62,6 +76,9 @@ #if MIN_VERSION_servant(0,18,1) it "UVerb API" $ roundTrips uverbOpenApi #endif +#if MIN_VERSION_servant(0,20,3) + it "MultiVerb API" $ roundTrips multiVerbOpenApi +#endif -- Layer 2: generated random values of each JSON body type are validated -- against the *generated* schema, proving the schemas describe the data. @@ -122,9 +139,30 @@ instance Arbitrary Health where arbitrary = Health <$> arbitrary <*> arbitrary +#if MIN_VERSION_servant(0,20,3) +type MultiVerbResponses = + '[ RespondEmpty 400 "Negative" + , Respond 200 "Even number" Bool + , Respond 200 "Odd number" Int + ] + +-- Phantom handler-return type; only the endpoint *type* is inspected, so this +-- needs no instances. +data MultiVerbResult + = NegativeNumber + | EvenNumber Bool + | OddNumber Int + type ValidationAPI = "health" :> Get '[JSON] Health :<|> "health" :> ReqBody '[JSON] Health :> Post '[JSON] Health + :<|> "choices" :> Capture "int" Int + :> MultiVerb 'GET '[JSON] MultiVerbResponses MultiVerbResult +#else +type ValidationAPI = + "health" :> Get '[JSON] Health + :<|> "health" :> ReqBody '[JSON] Health :> Post '[JSON] Health +#endif -- ======================================================================= -- Nullable API (OpenAPI 3.1 type-array nullability) @@ -621,5 +659,74 @@ } } |] + +#endif + +-- ======================================================================= +-- MultiVerb API +-- ======================================================================= + +#if MIN_VERSION_servant(0,20,3) +-- Reuses 'MultiVerbResponses' / 'MultiVerbResult' from the Validation API +-- section above. A *bare* MultiVerb (no 'Capture') keeps the golden document +-- small and deterministic. +type MultiVerbAPI = + "choices" :> MultiVerb 'GET '[JSON] MultiVerbResponses MultiVerbResult + +multiVerbOpenApi :: OpenApi +multiVerbOpenApi = toOpenApi (Proxy :: Proxy MultiVerbAPI) + +-- Note: a JSON response advertises *two* media types — @application/json@ and +-- @application/json;charset=utf-8@ — because servant's @Accept JSON@ declares +-- both and the MultiVerb rendering uses @allMime@. The two 200 alternatives +-- ('Respond' Bool / 'Respond' Int) merge under status 200: descriptions +-- concatenate ("Even number\n\nOdd number") and the first schema (Bool) wins. +multiVerbAPI :: Value +multiVerbAPI = [aesonQQ| +{ + "openapi": "3.1.0", + "info": { "version": "", "title": "" }, + "components": {}, + "paths": { + "/choices": { + "get": { + "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" + } + } + } + } + } +} +|] + +-- Exercises every response constructor the port renders. Note: 'RespondStreaming' +-- is intentionally omitted — it has no 'IsSwaggerResponse' instance (see the +-- MultiVerb block in Servant.OpenApi.Internal); if streaming support is added, +-- extend this list too. +type CoverageResponses = + '[ RespondEmpty 204 "No content" + , Respond 200 "Plain int" Int + , RespondAs PlainText 201 "Created, as text" String + , WithHeaders '[Servant.API.Header "X-Trace" Text] Int (Respond 202 "Accepted" Int) + ] + +type CoverageAPI = + "cov" :> MultiVerb 'GET '[JSON] CoverageResponses () + +coverageOpenApi :: OpenApi +coverageOpenApi = toOpenApi (Proxy :: Proxy CoverageAPI) #endif