servant-openapi-hs 4.0.0 → 4.1.0

raw patch · 7 files changed

+369/−8 lines, 7 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +9/−0
• README.md +3/−7
• app/GenOpenApi.hs +26/−0
• servant-openapi-hs.cabal +1/−1
• src/Servant/OpenApi/Internal.hs +197/−0
• src/Servant/OpenApi/Internal/TypeLevel/API.hs +26/−0
• test/Servant/OpenApiSpec.hs +107/−0

@@ -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 ----- 

@@ -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 

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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