packages feed

servant-openapi-hs 4.1.0 → 5.0.0

raw patch · 16 files changed

+614/−488 lines, 16 filesdep −insert-ordered-containersdep ~bytestringdep ~lensdep ~openapi-hsPVP ok

version bump matches the API change (PVP)

Dependencies removed: insert-ordered-containers

Dependency ranges changed: bytestring, lens, openapi-hs

API changes (from Hackage documentation)

Files

CHANGELOG.md view
@@ -1,3 +1,19 @@+5.0.0+-----++* Breaking: require `openapi-hs >=5.0 && <6`, resolved from its published+  Hackage release. `openapi-hs` 5 vendors the insertion-ordered map and set+  types it previously took from `insert-ordered-containers`, so this package no+  longer depends on `insert-ordered-containers` directly.+* Breaking: code that imports `Servant.OpenApi.Internal` may need to replace+  `Data.HashMap.Strict.InsOrd` with `Data.HashMap.Strict.InsOrd.Compat`. The+  stable `Servant.OpenApi` generation API and generated schemas are unchanged.+* Guard generated output with a byte-for-byte golden captured under+  `openapi-hs-4.1.0` (`test/golden/openapi-hs-4.1-gen-openapi.json`). The+  document `gen-openapi` produces under `openapi-hs-5.0.0` is identical to it,+  and still lints with 0 errors under [`vacuum`](https://quobix.com/vacuum/).+* Raise the `lens` lower bound to `>=5.3.3`.+ 4.1.0 -----
README.md view
@@ -1,5 +1,6 @@ # servant-openapi-hs +[![Hackage](https://img.shields.io/hackage/v/servant-openapi-hs.svg)](https://hackage.haskell.org/package/servant-openapi-hs) [![License BSD-3-Clause](https://img.shields.io/badge/license-BSD--3--Clause-blue.svg)](/LICENSE)  Generate an [OpenAPI 3.1](https://spec.openapis.org/oas/v3.1.0) specification for@@ -34,15 +35,15 @@  ## Installation -> **Pre-release.** The first Hackage release is still in preparation. Until it-> is published, depend on this repository directly (see-> [Building from source](#building-from-source) below); the instructions in this-> section describe the package once it is on Hackage.+`servant-openapi-hs` is available on+[Hackage](https://hackage.haskell.org/package/servant-openapi-hs). The `5.0`+series builds against `openapi-hs` 5; see the [changelog](CHANGELOG.md) for the+OpenAPI 3.1 port, `MultiVerb` support, and the `openapi-hs` 5 upgrade.  Add `servant-openapi-hs` to your package's `build-depends`:  ```cabal-build-depends: servant-openapi-hs+build-depends: servant-openapi-hs >= 5.0 && < 6 ```  Its OpenAPI 3.1 data model comes from@@ -58,7 +59,7 @@ Requires GHC **9.12.4** or **9.14.1**.  <a id="building-from-source"></a>-> **Building from source.** Until the first Hackage release, depend on this+> **Building from source.** To test unreleased changes, depend on this > repository directly by adding a `source-repository-package` stanza for > `servant-openapi-hs` to your `cabal.project`: >
app/GenOpenApi.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP               #-} {-# LANGUAGE OverloadedStrings #-}  -- | Emit a representative API's OpenAPI 3.1 document as JSON to stdout.@@ -7,111 +6,11 @@ -- -- > cabal run gen-openapi > openapi.json -- > nix run nixpkgs#vacuum-go -- lint -d openapi.json------ The document is deliberately a complete OpenAPI 3.1 contract — it carries--- @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-import           Data.Aeson                 (ToJSON, encode)-import qualified Data.ByteString.Lazy.Char8 as BL-import           Data.Char                  (isAlphaNum, toUpper)-import           Data.OpenApi               (ToSchema)-import qualified Data.OpenApi               as O-import           Data.Proxy                 (Proxy (..))-import qualified Data.Text                  as T-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--- nested optional field, a request body, a path capture, and a no-content--- delete.--data Todo = Todo-  { todoId    :: Int-  , title     :: Text-  , completed :: Bool-  , notes     :: Maybe Text-  } deriving (Generic)--instance ToJSON Todo-instance ToSchema Todo--data NewTodo = NewTodo-  { newTitle :: Text-  , newNotes :: Maybe Text-  } deriving (Generic)--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-spec = toOpenApi (Proxy :: Proxy TodoAPI)-  & O.info . O.title       .~ "Todo API"-  & O.info . O.version     .~ "1.0.0"-  & O.info . O.description ?~ "A small, representative Todo CRUD API."-  & O.servers              .~ ["https://api.example.com"]-  & O.applyTags            [O.Tag "todos" (Just "Operations on todo items") Nothing]-  & withOperationIds---- | Assign a unique @operationId@ to every operation, derived from its HTTP--- method and path (e.g. @GET \/todos\/{id}@ → @getTodosId@). Operations whose--- method is absent on a path are left untouched.-withOperationIds :: O.OpenApi -> O.OpenApi-withOperationIds = O.paths %~ imap setForPath-  where-    setForPath path =-        (O.get    . _Just . O.operationId %~ orSet ("get"    <> key))-      . (O.post   . _Just . O.operationId %~ orSet ("create" <> key))-      . (O.put    . _Just . O.operationId %~ orSet ("update" <> key))-      . (O.delete . _Just . O.operationId %~ orSet ("delete" <> key))-      where key = camel path-    orSet v = Just . maybe v id---- | Turn a path like @"\/todos\/{id}"@ into @"TodosId"@.-camel :: FilePath -> Text-camel = T.pack . concatMap capitalize . words . map keepAlnum-  where-    keepAlnum c   = if isAlphaNum c then c else ' '-    capitalize [] = []-    capitalize (c:cs) = toUpper c : cs+import Data.Aeson (encode)+import Data.ByteString.Lazy.Char8 qualified as BL+import GenOpenApi.Spec qualified as GenOpenApi  main :: IO ()-main = BL.putStrLn (encode spec)+main = BL.putStrLn (encode GenOpenApi.spec)
+ app/GenOpenApi/Spec.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}++-- | A representative API's complete OpenAPI 3.1 document.+--+-- The document carries @info@ (title/version/description), a @server@, @tags@,+-- and a unique @operationId@ per operation so both the executable and tests+-- exercise a realistic generated contract.+--+-- On servant >= 0.20.3 the API also includes a 'MultiVerb' endpoint, so the+-- contract covers multiple status codes, an empty-body response, and a+-- response carrying headers.+module GenOpenApi.Spec (spec) where++import Control.Lens+import Data.Aeson (ToJSON)+import Data.Char (isAlphaNum, toUpper)+import Data.OpenApi (ToSchema)+import Data.OpenApi qualified as O+import Data.Proxy (Proxy (..))+import Data.Text (Text)+import Data.Text qualified as T+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+-- nested optional field, a request body, a path capture, and a no-content+-- delete.++data Todo = Todo+  { todoId :: Int,+    title :: Text,+    completed :: Bool,+    notes :: Maybe Text+  }+  deriving (Generic)++instance ToJSON Todo++instance ToSchema Todo++data NewTodo = NewTodo+  { newTitle :: Text,+    newNotes :: Maybe Text+  }+  deriving (Generic)++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+spec =+  toOpenApi (Proxy :: Proxy TodoAPI)+    & O.info . O.title .~ "Todo API"+    & O.info . O.version .~ "1.0.0"+    & O.info . O.description ?~ "A small, representative Todo CRUD API."+    & O.servers .~ ["https://api.example.com"]+    & O.applyTags [O.Tag "todos" (Just "Operations on todo items") Nothing]+    & withOperationIds++-- | Assign a unique @operationId@ to every operation, derived from its HTTP+-- method and path (e.g. @GET \/todos\/{id}@ → @getTodosId@). Operations whose+-- method is absent on a path are left untouched.+withOperationIds :: O.OpenApi -> O.OpenApi+withOperationIds = O.paths %~ imap setForPath+  where+    setForPath path =+      (O.get . _Just . O.operationId %~ orSet ("get" <> key))+        . (O.post . _Just . O.operationId %~ orSet ("create" <> key))+        . (O.put . _Just . O.operationId %~ orSet ("update" <> key))+        . (O.delete . _Just . O.operationId %~ orSet ("delete" <> key))+      where+        key = camel path+    orSet v = Just . maybe v id++-- | Turn a path like @"\/todos\/{id}"@ into @"TodosId"@.+camel :: FilePath -> Text+camel = T.pack . concatMap capitalize . words . map keepAlnum+  where+    keepAlnum c = if isAlphaNum c then c else ' '+    capitalize [] = []+    capitalize (c : cs) = toUpper c : cs
servant-openapi-hs.cabal view
@@ -1,7 +1,7 @@-cabal-version:       3.0-name:                servant-openapi-hs-version:             4.1.0-synopsis:            Generate an OpenAPI 3.1 specification for your servant API.+cabal-version:      3.0+name:               servant-openapi-hs+version:            5.0.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   for describing and documenting HTTP APIs in JSON or YAML. This library@@ -19,34 +19,31 @@   This package is a fork of   [@servant-openapi3@](https://github.com/biocad/servant-openapi3) that targets   OpenAPI 3.1 via [@openapi-hs@](https://github.com/shinzui/openapi-hs).-homepage:            https://github.com/shinzui/servant-openapi-hs-bug-reports:         https://github.com/shinzui/servant-openapi-hs/issues-license:             BSD-3-Clause-license-file:        LICENSE-author:              David Johnson, Nickolay Kudasov, Maxim Koltsov-maintainer:          nadeem@gmail.com-copyright:           (c) 2015-2020, Servant contributors-category:            Web, Servant, OpenApi-build-type:          Simple-tested-with:-  GHC ==9.12.4 || ==9.14.1 +homepage:           https://github.com/shinzui/servant-openapi-hs+bug-reports:        https://github.com/shinzui/servant-openapi-hs/issues+license:            BSD-3-Clause+license-file:       LICENSE+author:             David Johnson, Nickolay Kudasov, Maxim Koltsov+maintainer:         nadeem@gmail.com+copyright:          (c) 2015-2020, Servant contributors+category:           Web, Servant, OpenApi+build-type:         Simple+tested-with:        GHC ==9.12.4 || ==9.14.1 extra-doc-files:-    README.md-  , CHANGELOG.md+  CHANGELOG.md+  README.md +extra-source-files: test/golden/*.json+ source-repository head   type:     git   location: https://github.com/shinzui/servant-openapi-hs.git  library-  ghc-options:         -Wall+  ghc-options:      -Wall   exposed-modules:     Servant.OpenApi-    Servant.OpenApi.Test-    Servant.OpenApi.TypeLevel--    -- Internal modules     Servant.OpenApi.Internal     Servant.OpenApi.Internal.Orphans     Servant.OpenApi.Internal.Test@@ -54,60 +51,72 @@     Servant.OpenApi.Internal.TypeLevel.API     Servant.OpenApi.Internal.TypeLevel.Every     Servant.OpenApi.Internal.TypeLevel.TMap-  hs-source-dirs:      src-  build-depends:       aeson                     >=2.0.1.0  && <2.3-                     , aeson-pretty              >=0.8.7    && <0.9-                     , base                      >=4.21     && <4.23-                     , 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.4-                     , servant                   >=0.17     && <0.21-                     , singleton-bool            >=0.1.4    && <0.2-                     , openapi-hs                >=4.0      && <5-                     , text                      >=1.2.3.0  && <3-                     , unordered-containers      >=0.2.9.0  && <0.3+    Servant.OpenApi.Test+    Servant.OpenApi.TypeLevel -                     , hspec                     >=2.6.0    && <2.12-                     , QuickCheck                >=2.9      && <2.17-  default-language:    GHC2024+  -- Internal modules+  hs-source-dirs:   src+  build-depends:+    , aeson                 >=2.0.1.0  && <2.3+    , aeson-pretty          >=0.8.7    && <0.9+    , base                  >=4.21     && <4.23+    , base-compat           >=0.10.5   && <0.15+    , bytestring            >=0.10.8.1 && <0.13+    , hspec                 >=2.6.0    && <2.12+    , http-media            >=0.7.1.3  && <0.9+    , lens                  >=5.3.3    && <5.4+    , openapi-hs            >=5.0      && <6+    , QuickCheck            >=2.9      && <2.17+    , servant               >=0.17     && <0.21+    , singleton-bool        >=0.1.4    && <0.2+    , text                  >=1.2.3.0  && <3+    , unordered-containers  >=0.2.9.0  && <0.3 +  default-language: GHC2024+ executable gen-openapi   ghc-options:      -Wall   hs-source-dirs:   app   main-is:          GenOpenApi.hs-  build-depends:    base-                  , aeson-                  , bytestring-                  , lens-                  , openapi-hs-                  , servant-                  , servant-openapi-hs-                  , text+  other-modules:    GenOpenApi.Spec+  build-depends:+    , aeson+    , base+    , bytestring+    , lens+    , openapi-hs          >=5.0 && <6+    , servant+    , servant-openapi-hs+    , text+   default-language: GHC2024  test-suite spec-  ghc-options:      -Wall-  type:             exitcode-stdio-1.0-  hs-source-dirs:   test-  main-is:          Spec.hs+  ghc-options:        -Wall+  type:               exitcode-stdio-1.0+  hs-source-dirs:     test app+  main-is:            Spec.hs   build-tool-depends: hspec-discover:hspec-discover >=2.6.0 && <2.12-  build-depends:    base-                  , base-compat-                  , aeson-                  , hspec >=2.6.0 && <2.12-                  , QuickCheck-                  , lens-                  , lens-aeson >=1.0.2    && <1.3-                  , servant-                  , servant-openapi-hs-                  , openapi-hs >= 4.0-                  , text-                  , template-haskell-                  , utf8-string >=1.0.1.1 && <1.1-                  , time-                  , vector+  build-depends:+    , aeson+    , base+    , base-compat+    , bytestring+    , hspec               >=2.6.0   && <2.12+    , lens+    , lens-aeson          >=1.0.2   && <1.3+    , openapi-hs          >=5.0     && <6+    , QuickCheck+    , servant+    , servant-openapi-hs+    , template-haskell+    , text+    , time+    , utf8-string         >=1.0.1.1 && <1.1+    , vector+   other-modules:+    GenOpenApi.Spec     Servant.OpenApiSpec-  default-language: GHC2024++  default-language:   GHC2024
src/Servant/OpenApi.hs view
@@ -15,36 +15,37 @@ -- Additional utilities can also take advantage of the resulting files, such as testing tools. -- -- For more information see the <https://spec.openapis.org/oas/v3.1.0 OpenAPI 3.1 specification>.-module Servant.OpenApi (-  -- * How to use this library-  -- $howto+module Servant.OpenApi+  ( -- * How to use this library+    -- $howto -  -- ** Generate @OpenApi@-  -- $generate+    -- ** Generate @OpenApi@+    -- $generate -  -- ** Annotate-  -- $annotate+    -- ** Annotate+    -- $annotate -  -- ** Test-  -- $test+    -- ** Test+    -- $test -  -- ** Serve-  -- $serve+    -- ** Serve+    -- $serve -  -- * @'HasOpenApi'@ class-  HasOpenApi(..),+    -- * @'HasOpenApi'@ class+    HasOpenApi (..), -  -- * Manipulation-  subOperations,+    -- * Manipulation+    subOperations, -  -- * Testing-  validateEveryToJSON,-  validateEveryToJSONWithPatternChecker,-) where+    -- * Testing+    validateEveryToJSON,+    validateEveryToJSONWithPatternChecker,+  )+where -import           Servant.OpenApi.Internal-import           Servant.OpenApi.Test-import           Servant.OpenApi.Internal.Orphans ()+import Servant.OpenApi.Internal+import Servant.OpenApi.Internal.Orphans ()+import Servant.OpenApi.Test  -- $setup -- >>> import Control.Applicative
src/Servant/OpenApi/Internal.hs view
@@ -1,56 +1,57 @@-{-# LANGUAGE AllowAmbiguousTypes  #-}-{-# LANGUAGE CPP                  #-}-{-# LANGUAGE ConstraintKinds      #-}-{-# LANGUAGE DataKinds            #-}-{-# LANGUAGE FlexibleContexts     #-}-{-# LANGUAGE TypeFamilies         #-}-{-# LANGUAGE FlexibleInstances    #-}-{-# LANGUAGE OverloadedStrings    #-}-{-# LANGUAGE PolyKinds            #-}-{-# LANGUAGE RankNTypes           #-}-{-# LANGUAGE ScopedTypeVariables  #-}-{-# LANGUAGE TypeOperators        #-}+{-# 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 () 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 (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-import           Data.Proxy-import           Data.Singletons.Bool-import           Data.Text                  (Text)-import qualified Data.Text                  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)+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.Maybe (listToMaybe)+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+import Servant.OpenApi.Internal.TypeLevel.API  -- | Generate a OpenApi specification for a servant API. --@@ -97,71 +98,98 @@ -- | 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) =>-  Proxy sub     -- ^ Part of a servant API.-  -> Proxy api  -- ^ The whole servant API.-  -> Traversal' OpenApi Operation+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)-  => FilePath                                       -- ^ Endpoint path.-  -> proxy (Verb method status cs (Headers hs a))  -- ^ Method, content-types, headers and response.-  -> OpenApi-mkEndpoint path proxy-  = mkEndpointWithSchemaRef (Just schemaRef) path proxy-      & components.schemas .~ schemaDefs+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)-  => FilePath                                               -- ^ Endpoint path.-  -> proxy (Verb method status cs (Headers hs nocontent))  -- ^ Method, content-types, headers and response.-  -> OpenApi-mkEndpointNoContent path proxy-  = mkEndpointWithSchemaRef Nothing path proxy+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)))+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))+    method = openApiMethod (Proxy :: Proxy method)+    code = fromIntegral (natVal (Proxy :: Proxy status))     responseContentTypes = allContentType (Proxy :: Proxy cs)-    responseHeaders      = Inline <$> toAllResponseHeaders (Proxy :: Proxy hs)+    responseHeaders = Inline <$> toAllResponseHeaders (Proxy :: Proxy hs) -mkEndpointNoContentVerb :: forall proxy method.-  (OpenApiMethod method)-  => FilePath                      -- ^ Endpoint path.-  -> proxy (NoContentVerb method)  -- ^ Method-  -> OpenApi-mkEndpointNoContentVerb path _ = mempty-  & paths.at path ?~-    (mempty & method ?~ (mempty-      & at code ?~ Inline mempty))+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+    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 :)+addParam param = allOperations . parameters %~ (Inline param :)  -- | Add RequestBody to every operations in the spec. addRequestBody :: RequestBody -> OpenApi -> OpenApi@@ -191,14 +219,20 @@ 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 '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 +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@@ -262,8 +296,11 @@ 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+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!@@ -273,12 +310,14 @@ 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+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 "/"+  toOpenApi = mkEndpointNoContentVerb "/"  instance (HasOpenApi a, HasOpenApi b) => HasOpenApi (a :<|> b) where   toOpenApi _ = toOpenApi (Proxy :: Proxy a) <> toOpenApi (Proxy :: Proxy b)@@ -315,123 +354,143 @@       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+  toOpenApi _ =+    toOpenApi (Proxy :: Proxy sub)+      & addParam param+      & prependPath capture+      & addDefaultResponse404 tname     where       pname = symbolVal (Proxy :: Proxy sym)       tname = Text.pack pname-      transDesc ""   = Nothing+      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))+      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))) <>)+  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))) <>)+  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+  toOpenApi _ =+    toOpenApi (Proxy :: Proxy sub)+      & addParam param+      & addDefaultResponse400 tname     where       tname = Text.pack (symbolVal (Proxy :: Proxy sym))-      transDesc ""   = Nothing+      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+      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+  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))+      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+  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)+      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+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 "" = 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))+      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)+  toOpenApi _ =+    toOpenApi (Proxy :: Proxy sub)+      & addRequestBody reqBody+      & addDefaultResponse400 tname+      & components . schemas %~ (<> schemaDefs)     where       tname = "body"-      transDesc ""   = Nothing+      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)]+      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)+  toOpenApi _ =+    toOpenApi (Proxy :: Proxy sub)+      & addRequestBody reqBody+      & addDefaultResponse400 tname+      & components . schemas %~ (<> schemaDefs)     where       tname = "body"-      transDesc ""   = Nothing+      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)]+      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@@ -477,7 +536,7 @@       (headerName, headerBS) = toResponseHeader (Proxy :: Proxy h)       hdrs = toAllResponseHeaders (Proxy :: Proxy hs) -instance AllToResponseHeader hs => AllToResponseHeader (HList hs) where+instance (AllToResponseHeader hs) => AllToResponseHeader (HList hs) where   toAllResponseHeaders _ = toAllResponseHeaders (Proxy :: Proxy hs)  #if MIN_VERSION_servant(0,20,3)
src/Servant/OpenApi/Internal/Orphans.hs view
@@ -1,19 +1,18 @@-{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-}-+{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-}+ -- | Orphan instances needed to derive OpenAPI documents for servant APIs. -- Not subject to the PVP; import "Servant.OpenApi" instead. module Servant.OpenApi.Internal.Orphans where  import Data.OpenApi-import Data.Proxy            (Proxy (..))-import Data.Typeable         (Typeable)+import Data.Proxy (Proxy (..))+import Data.Typeable (Typeable) import Servant.Types.SourceT (SourceT)  -- | Pretend that 'SourceT m a' is '[a]'. -- -- @since 1.1.7--- instance (Typeable (SourceT m a), ToSchema a) => ToSchema (SourceT m a) where-    declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])+  declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
src/Servant/OpenApi/Internal/Test.hs view
@@ -1,28 +1,28 @@-{-# LANGUAGE ConstraintKinds     #-}-{-# LANGUAGE DataKinds           #-}-{-# LANGUAGE FlexibleContexts    #-}-{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeOperators       #-}+{-# LANGUAGE TypeOperators #-}+ -- | Internal implementation of the response-conformance test helpers. -- Not subject to the PVP; import "Servant.OpenApi.Test" instead. module Servant.OpenApi.Internal.Test where -import           Data.Aeson                     (ToJSON (..))-import qualified Data.Aeson.Encode.Pretty       as P-import qualified Data.ByteString.Lazy           as BSL-import           Data.OpenApi                   (Pattern, ToSchema, toSchema)-import           Data.OpenApi.Schema.Validation-import           Data.Text                      (Text)-import qualified Data.Text.Lazy                 as TL-import qualified Data.Text.Lazy.Encoding        as TL-import           Data.Typeable-import           Test.Hspec-import           Test.Hspec.QuickCheck-import           Test.QuickCheck                (Arbitrary, Property, counterexample, property)--import           Servant.API-import           Servant.OpenApi.Internal.TypeLevel+import Data.Aeson (ToJSON (..))+import Data.Aeson.Encode.Pretty qualified as P+import Data.ByteString.Lazy qualified as BSL+import Data.OpenApi (Pattern, ToSchema, toSchema)+import Data.OpenApi.Schema.Validation+import Data.Text (Text)+import Data.Text.Lazy qualified as TL+import Data.Text.Lazy.Encoding qualified as TL+import Data.Typeable+import Servant.API+import Servant.OpenApi.Internal.TypeLevel+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck (Arbitrary, Property, counterexample, property)  -- $setup -- >>> import Control.Applicative@@ -78,29 +78,38 @@ -- ...No instance for ...Arbitrary Contact... -- ...  arising from a use of ‘validateEveryToJSON’ -- ...-validateEveryToJSON-  :: forall proxy api .-     TMap (Every [Typeable, Show, Arbitrary, ToJSON, ToSchema])-          (BodyTypes JSON api)-  => proxy api   -- ^ Servant API.-  -> Spec-validateEveryToJSON _ = props-  (Proxy :: Proxy [ToJSON, ToSchema])-  (maybeCounterExample . prettyValidateWith validateToJSON)-  (Proxy :: Proxy (BodyTypes JSON api))+validateEveryToJSON ::+  forall proxy api.+  ( TMap+      (Every [Typeable, Show, Arbitrary, ToJSON, ToSchema])+      (BodyTypes JSON api)+  ) =>+  -- | Servant API.+  proxy api ->+  Spec+validateEveryToJSON _ =+  props+    (Proxy :: Proxy [ToJSON, ToSchema])+    (maybeCounterExample . prettyValidateWith validateToJSON)+    (Proxy :: Proxy (BodyTypes JSON api))  -- | Verify that every type used with @'JSON'@ content type in a servant API -- has compatible @'ToJSON'@ and @'ToSchema'@ instances using @'validateToJSONWithPatternChecker'@. -- -- For validation without patterns see @'validateEveryToJSON'@.-validateEveryToJSONWithPatternChecker :: forall proxy api. TMap (Every [Typeable, Show, Arbitrary, ToJSON, ToSchema]) (BodyTypes JSON api) =>-  (Pattern -> Text -> Bool)   -- ^ @'Pattern'@ checker.-  -> proxy api                -- ^ Servant API.-  -> Spec-validateEveryToJSONWithPatternChecker checker _ = props-  (Proxy :: Proxy [ToJSON, ToSchema])-  (maybeCounterExample . prettyValidateWith (validateToJSONWithPatternChecker checker))-  (Proxy :: Proxy (BodyTypes JSON api))+validateEveryToJSONWithPatternChecker ::+  forall proxy api.+  (TMap (Every [Typeable, Show, Arbitrary, ToJSON, ToSchema]) (BodyTypes JSON api)) =>+  -- | @'Pattern'@ checker.+  (Pattern -> Text -> Bool) ->+  -- | Servant API.+  proxy api ->+  Spec+validateEveryToJSONWithPatternChecker checker _ =+  props+    (Proxy :: Proxy [ToJSON, ToSchema])+    (maybeCounterExample . prettyValidateWith (validateToJSONWithPatternChecker checker))+    (Proxy :: Proxy (BodyTypes JSON api))  -- * QuickCheck-related stuff @@ -125,11 +134,16 @@ -- ... -- Finished in ... seconds -- ...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.-  -> p'' xs                                     -- ^ A list of types.-  -> Spec+props ::+  forall p p'' cs xs.+  (TMap (Every (Typeable ': Show ': Arbitrary ': cs)) xs) =>+  -- | A list of constraints.+  p cs ->+  -- | Property predicate.+  (forall x. (EveryTF cs x) => x -> Property) ->+  -- | A list of types.+  p'' xs ->+  Spec props _ f px = sequence_ specs   where     specs :: [Spec]@@ -176,31 +190,34 @@ -- <BLANKLINE> -- -- FIXME: this belongs in "Data.OpenApi.Schema.Validation" (in @openapi-hs@).-prettyValidateWith-  :: forall a. (ToJSON a, ToSchema a)-  => (a -> [ValidationError]) -> a -> Maybe String+prettyValidateWith ::+  forall a.+  (ToJSON a, ToSchema a) =>+  (a -> [ValidationError]) -> a -> Maybe String prettyValidateWith f x =   case f x of-    []      -> Nothing-    errors  -> Just $ unlines-      [ "Validation against the schema fails:"-      , unlines (map ("  * " ++) errors)-      , "JSON value:"-      , ppJSONString json-      , ""-      , "OpenApi Schema:"-      , ppJSONString (toJSON schema)-      ]+    [] -> Nothing+    errors ->+      Just $+        unlines+          [ "Validation against the schema fails:",+            unlines (map ("  * " ++) errors),+            "JSON value:",+            ppJSONString json,+            "",+            "OpenApi Schema:",+            ppJSONString (toJSON schema)+          ]   where     ppJSONString = TL.unpack . TL.decodeUtf8 . encodePretty -    json   = toJSON x+    json = toJSON x     schema = toSchema (Proxy :: Proxy a)  -- | Provide a counterexample if there is any. maybeCounterExample :: Maybe String -> Property-maybeCounterExample Nothing  = property True+maybeCounterExample Nothing = property True maybeCounterExample (Just s) = counterexample s (property False) -encodePretty :: ToJSON a => a -> BSL.ByteString-encodePretty = P.encodePretty' $ P.defConfig { P.confCompare = P.compare }+encodePretty :: (ToJSON a) => a -> BSL.ByteString+encodePretty = P.encodePretty' $ P.defConfig {P.confCompare = P.compare}
src/Servant/OpenApi/Internal/TypeLevel.hs view
@@ -1,11 +1,12 @@ -- | Re-exports of the type-level helpers used to enumerate and match servant -- API endpoints. Not subject to the PVP; import "Servant.OpenApi.TypeLevel".-module Servant.OpenApi.Internal.TypeLevel (-  module Servant.OpenApi.Internal.TypeLevel.API,-  module Servant.OpenApi.Internal.TypeLevel.Every,-  module Servant.OpenApi.Internal.TypeLevel.TMap,-) where+module Servant.OpenApi.Internal.TypeLevel+  ( module Servant.OpenApi.Internal.TypeLevel.API,+    module Servant.OpenApi.Internal.TypeLevel.Every,+    module Servant.OpenApi.Internal.TypeLevel.TMap,+  )+where -import           Servant.OpenApi.Internal.TypeLevel.API-import           Servant.OpenApi.Internal.TypeLevel.Every-import           Servant.OpenApi.Internal.TypeLevel.TMap+import Servant.OpenApi.Internal.TypeLevel.API+import Servant.OpenApi.Internal.TypeLevel.Every+import Servant.OpenApi.Internal.TypeLevel.TMap
src/Servant/OpenApi/Internal/TypeLevel/Every.hs view
@@ -1,18 +1,18 @@-{-# LANGUAGE CPP                     #-}-{-# LANGUAGE ConstraintKinds         #-}-{-# LANGUAGE DataKinds               #-}-{-# LANGUAGE FlexibleContexts        #-}-{-# LANGUAGE FlexibleInstances       #-}-{-# LANGUAGE GADTs                   #-}-{-# LANGUAGE InstanceSigs            #-}-{-# LANGUAGE KindSignatures          #-}-{-# LANGUAGE MultiParamTypeClasses   #-}-{-# LANGUAGE PolyKinds               #-}-{-# LANGUAGE RankNTypes              #-}-{-# LANGUAGE ScopedTypeVariables     #-}-{-# LANGUAGE TypeFamilies            #-}-{-# LANGUAGE TypeOperators           #-}-{-# LANGUAGE UndecidableInstances    #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-} #if __GLASGOW_HASKELL__ >= 800 {-# LANGUAGE UndecidableSuperClasses #-} #endif@@ -20,10 +20,9 @@ -- a class. Not subject to the PVP; import "Servant.OpenApi.TypeLevel" instead. module Servant.OpenApi.Internal.TypeLevel.Every where -import           Data.Kind                               (Constraint, Type)-import           Data.Proxy--import           Servant.OpenApi.Internal.TypeLevel.TMap+import Data.Kind (Constraint, Type)+import Data.Proxy+import Servant.OpenApi.Internal.TypeLevel.TMap  -- $setup -- >>> :set -XDataKinds@@ -50,16 +49,19 @@ -- | Apply multiple constraint constructors to a type as a class. -- -- This is different from @'EveryTF'@ in that it allows partial application.-class EveryTF cs x => Every (cs :: [Type -> Constraint]) (x :: Type) where+class (EveryTF cs x) => Every (cs :: [Type -> Constraint]) (x :: Type) -instance Every '[] x where-instance (c x, Every cs x) => Every (c ': cs) x where+instance Every '[] x +instance (c x, Every cs x) => Every (c ': cs) x+ -- | Like @'tmap'@, but uses @'Every'@ for multiple constraints. -- -- >>> let zero :: forall p a. (Show a, Num a) => p a -> String; zero _ = show (0 :: a) -- >>> tmapEvery (Proxy :: Proxy [Show, Num]) zero (Proxy :: Proxy [Int, Float]) :: [String] -- ["0","0.0"]-tmapEvery :: forall a cs p p'' xs. (TMap (Every cs) xs) =>-  p cs -> (forall x p'. Every cs x => p' x -> a) -> p'' xs -> [a]+tmapEvery ::+  forall a cs p p'' xs.+  (TMap (Every cs) xs) =>+  p cs -> (forall x p'. (Every cs x) => p' x -> a) -> p'' xs -> [a] tmapEvery _ = tmap (Proxy :: Proxy (Every cs))
src/Servant/OpenApi/Internal/TypeLevel/TMap.hs view
@@ -1,19 +1,20 @@-{-# LANGUAGE ConstraintKinds       #-}-{-# LANGUAGE DataKinds             #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE KindSignatures        #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PolyKinds             #-}-{-# LANGUAGE RankNTypes            #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE TypeOperators         #-}-{-# LANGUAGE UndecidableInstances  #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+ -- | A type-level list traversal that applies a function under a constraint to -- every element. Not subject to the PVP; import "Servant.OpenApi.TypeLevel". module Servant.OpenApi.Internal.TypeLevel.TMap where -import           Data.Proxy-import           GHC.Exts   (Constraint)+import Data.Proxy+import GHC.Exts (Constraint)  -- $setup -- >>> :set -XDataKinds@@ -29,11 +30,10 @@ -- >>> tmap (Proxy :: Proxy KnownSymbol) symbolVal (Proxy :: Proxy ["hello", "world"]) -- ["hello","world"] class TMap (q :: k -> Constraint) (xs :: [k]) where-  tmap :: p q -> (forall x p'. q x => p' x -> a) -> p'' xs -> [a]+  tmap :: p q -> (forall x p'. (q x) => p' x -> a) -> p'' xs -> [a]  instance TMap q '[] where   tmap _ _ _ = []  instance (q x, TMap q xs) => TMap q (x ': xs) where   tmap q f _ = f (Proxy :: Proxy x) : tmap q f (Proxy :: Proxy xs)-
src/Servant/OpenApi/Test.hs view
@@ -5,9 +5,10 @@ -- Stability:   experimental -- -- Automatic tests for servant API against OpenApi spec.-module Servant.OpenApi.Test (-  validateEveryToJSON,-  validateEveryToJSONWithPatternChecker,-) where+module Servant.OpenApi.Test+  ( validateEveryToJSON,+    validateEveryToJSONWithPatternChecker,+  )+where -import           Servant.OpenApi.Internal.Test+import Servant.OpenApi.Internal.Test
src/Servant/OpenApi/TypeLevel.hs view
@@ -5,11 +5,11 @@ -- Stability:   experimental -- -- Useful type families for servant APIs.-module Servant.OpenApi.TypeLevel (-  IsSubAPI,-  EndpointsList,-  BodyTypes,-) where--import           Servant.OpenApi.Internal.TypeLevel+module Servant.OpenApi.TypeLevel+  ( IsSubAPI,+    EndpointsList,+    BodyTypes,+  )+where +import Servant.OpenApi.Internal.TypeLevel
test/Servant/OpenApiSpec.hs view
@@ -15,6 +15,7 @@ import           Data.Aeson.Lens               (key, members, _String) import           Data.Aeson.QQ.Simple import qualified Data.Aeson.Types              as JSON+import qualified Data.ByteString.Lazy           as BSL import           Data.Char                     (toLower) import           Data.Int                      (Int64) import           Data.OpenApi@@ -22,6 +23,7 @@ import           Data.Text                     (Text) import           Data.Time import           GHC.Generics+import qualified GenOpenApi.Spec                as GenOpenApi import           Servant.API #if MIN_VERSION_servant(0,20,3) import           Servant.API.MultiVerb          (MultiVerb, Respond, RespondAs, RespondEmpty, WithHeaders)@@ -39,6 +41,12 @@  spec :: Spec spec = do+  describe "openapi-hs upgrade regression" $+    it "preserves the openapi-hs 4.1 generated document byte-for-byte" $ do+      expected <- BSL.readFile "test/golden/openapi-hs-4.1-gen-openapi.json"+      let actual = encode GenOpenApi.spec <> BSL.singleton 10+      actual `shouldBe` expected+   describe "HasOpenApi" $ do     it "Todo API" $ checkAPI (Proxy :: Proxy TodoAPI) todoAPI     it "Hackage API (with tags)" $ checkOpenApi hackageOpenApiWithTags hackageAPI
+ test/golden/openapi-hs-4.1-gen-openapi.json view
@@ -0,0 +1,1 @@+{"info":{"description":"A small, representative Todo CRUD API.","title":"Todo API","version":"1.0.0"},"servers":[{"url":"https://api.example.com"}],"paths":{"/todos":{"get":{"operationId":"getTodos","responses":{"200":{"content":{"application/json;charset=utf-8":{"schema":{"items":{"$ref":"#/components/schemas/Todo"},"type":"array"}}},"description":""}},"tags":["todos"]},"post":{"operationId":"createTodos","requestBody":{"content":{"application/json;charset=utf-8":{"schema":{"$ref":"#/components/schemas/NewTodo"}}}},"responses":{"200":{"content":{"application/json;charset=utf-8":{"schema":{"$ref":"#/components/schemas/Todo"}}},"description":""},"400":{"description":"Invalid `body`"}},"tags":["todos"]}},"/todos/{id}":{"delete":{"operationId":"deleteTodosId","parameters":[{"in":"path","name":"id","required":true,"schema":{"maximum":9223372036854775807,"minimum":-9223372036854775808,"type":"integer"}}],"responses":{"200":{"content":{"application/json;charset=utf-8":{}},"description":""},"404":{"description":"`id` not found"}},"tags":["todos"]},"get":{"operationId":"getTodosId","parameters":[{"in":"path","name":"id","required":true,"schema":{"maximum":9223372036854775807,"minimum":-9223372036854775808,"type":"integer"}}],"responses":{"200":{"content":{"application/json;charset=utf-8":{"schema":{"$ref":"#/components/schemas/Todo"}}},"description":""},"404":{"description":"`id` not found"}},"tags":["todos"]},"put":{"operationId":"updateTodosId","parameters":[{"in":"path","name":"id","required":true,"schema":{"maximum":9223372036854775807,"minimum":-9223372036854775808,"type":"integer"}}],"requestBody":{"content":{"application/json;charset=utf-8":{"schema":{"$ref":"#/components/schemas/NewTodo"}}}},"responses":{"200":{"content":{"application/json;charset=utf-8":{"schema":{"$ref":"#/components/schemas/Todo"}}},"description":""},"400":{"description":"Invalid `body`"},"404":{"description":"`id` not found"}},"tags":["todos"]}},"/todos/status/{id}":{"get":{"operationId":"getTodosStatusId","parameters":[{"in":"path","name":"id","required":true,"schema":{"maximum":9223372036854775807,"minimum":-9223372036854775808,"type":"integer"}}],"responses":{"200":{"content":{"application/json":{"schema":{"$ref":"#/components/schemas/Todo"}},"application/json;charset=utf-8":{"schema":{"$ref":"#/components/schemas/Todo"}}},"description":"The todo's current state"},"203":{"content":{"application/json":{"schema":{"$ref":"#/components/schemas/Todo"}},"application/json;charset=utf-8":{"schema":{"$ref":"#/components/schemas/Todo"}}},"description":"Non-authoritative todo state","headers":{"X-Revision":{"schema":{"maximum":9223372036854775807,"minimum":-9223372036854775808,"type":"integer"}}}},"404":{"description":"`id` or No todo with that id"}},"tags":["todos"]}}},"components":{"schemas":{"Todo":{"properties":{"completed":{"type":"boolean"},"notes":{"type":"string"},"title":{"type":"string"},"todoId":{"maximum":9223372036854775807,"minimum":-9223372036854775808,"type":"integer"}},"required":["todoId","title","completed"],"type":"object"},"NewTodo":{"properties":{"newNotes":{"type":"string"},"newTitle":{"type":"string"}},"required":["newTitle"],"type":"object"}}},"tags":[{"description":"Operations on todo items","name":"todos"}],"openapi":"3.1.0"}