servant-openapi3 2.0.2.0 → 2.1.0.0

raw patch · 19 files changed

+713/−686 lines, 19 filesdep −directorydep −doctestdep −filepathdep ~QuickCheckdep ~aesondep ~aeson-prettysetup-changednew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies removed: directory, doctest, filepath, generics-sop, insert-ordered-containers, lens-aeson, servant-client-core, template-haskell, unordered-containers, utf8-string, vector

Dependency ranges changed: QuickCheck, aeson, aeson-pretty, base, base-compat, bytestring, hspec, lens, openapi3, servant, servant-server, singleton-bool, text

API changes (from Hackage documentation)

Files

• CHANGELOG.md +28/−0
• README.md +1/−1
• Setup.hs +0/−33
• example/server/Main.hs +1/−1
• example/src/Todo.hs +52/−45
• example/test/TodoSpec.hs +10/−9
• servant-openapi3.cabal +31/−71
• src/Servant/OpenApi.hs +38/−39
• src/Servant/OpenApi/Internal.hs +296/−247
• src/Servant/OpenApi/Internal/Orphans.hs +6/−7
• src/Servant/OpenApi/Internal/Test.hs +73/−56
• src/Servant/OpenApi/Internal/TypeLevel.hs +8/−8
• src/Servant/OpenApi/Internal/TypeLevel/API.hs +16/−30
• src/Servant/OpenApi/Internal/TypeLevel/Every.hs +23/−23
• src/Servant/OpenApi/Internal/TypeLevel/TMap.hs +12/−13
• src/Servant/OpenApi/Test.hs +5/−5
• src/Servant/OpenApi/TypeLevel.hs +6/−7
• test/Servant/OpenApiSpec.hs +107/−79
• test/doctests.hs +0/−12

@@ -1,3 +1,31 @@+2.1.0.0+-------++* `servant-openapi3` is now developed and released as part of the+  [servant](https://github.com/haskell-servant/servant) repository++* Add `HasOpenApi` instance for the `OperationId` combinator, which sets+  `operationId` on the generated operations++* Require `openapi3-3.2.5` and `insert-ordered-containers-0.3`++  `openapi3-3.2.5` wraps `InsOrdHashMap` in a compatibility newtype+  (`Data.HashMap.Strict.InsOrd.Compat`) when built against+  `insert-ordered-containers-0.3`, and that is the type appearing in its lenses.+  Code combining `servant-openapi3` with `Data.HashMap.Strict.InsOrd` directly+  needs to switch to the compatibility module as well.++* Generated specifications now describe `JSON` request and response bodies as+  `application/json` rather than `application/json;charset=utf-8`, following the+  `Accept JSON` instance in `servant`+  [#1881](https://github.com/haskell-servant/servant/pull/1881)++* Add upper bounds to the `generics-sop`, `hspec` and `QuickCheck` dependencies++* Doctests are no longer a `cabal` test suite; they run as `cabal repl+  --with-ghc=doctest`, which lets the package use `build-type: Simple` instead of+  requiring `cabal-doctest` and a custom `Setup.hs`+ 2.0.2.0 ------- 

@@ -38,4 +38,4 @@  We are happy to receive bug reports, fixes, documentation enhancements, and other improvements. -Please report bugs via the [github issue tracker](https://github.com/bitnomial/servant-openapi3/issues).+Please report bugs via the [github issue tracker](https://github.com/haskell-servant/servant/issues).

@@ -1,33 +0,0 @@-{-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -Wall #-}-module Main (main) where--#ifndef MIN_VERSION_cabal_doctest-#define MIN_VERSION_cabal_doctest(x,y,z) 0-#endif--#if MIN_VERSION_cabal_doctest(1,0,0)--import Distribution.Extra.Doctest ( defaultMainWithDoctests )-main :: IO ()-main = defaultMainWithDoctests "doctests"--#else--#ifdef MIN_VERSION_Cabal--- If the macro is defined, we have new cabal-install,--- but for some reason we don't have cabal-doctest in package-db------ Probably we are running cabal sdist, when otherwise using new-build--- workflow-#warning You are configuring this package without cabal-doctest installed. \-         The doctests test-suite will not work as a result. \-         To fix this, install cabal-doctest before configuring.-#endif--import Distribution.Simple--main :: IO ()-main = defaultMain--#endif

@@ -2,10 +2,10 @@  import Network.Wai.Handler.Warp import Servant+ import Todo  main :: IO () main = do   putStrLn "Running on port 8000"   run 8000 $ serve (Proxy :: Proxy API) server-

@@ -1,38 +1,39 @@-{-# LANGUAGE DataKinds                  #-}-{-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingVia #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings          #-}-{-# LANGUAGE TypeOperators              #-}-{-# LANGUAGE DerivingVia                #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators #-}+ module Todo where -import           Control.Lens-import           Data.Aeson-import           Data.Aeson.Encode.Pretty   (encodePretty)+import Control.Lens+import Data.Aeson+import Data.Aeson.Encode.Pretty (encodePretty) import qualified Data.ByteString.Lazy.Char8 as BL8-import           Data.OpenApi               hiding (Server)-import           Data.Proxy-import           Data.Text                  (Text)-import           Data.Time                  (UTCTime (..), fromGregorian)-import           Data.Typeable              (Typeable)-import           GHC.Generics-import           Servant-import           Servant.OpenApi-import           qualified Generics.SOP as GSOP-import           Servant.API.MultiVerb+import Data.OpenApi hiding (Server)+import Data.Proxy+import Data.Text (Text)+import Data.Time (UTCTime (..), fromGregorian)+import Data.Typeable (Typeable)+import GHC.Generics+import qualified Generics.SOP as GSOP+import Servant+import Servant.API.MultiVerb+import Servant.OpenApi  todoAPI :: Proxy TodoAPI todoAPI = Proxy  -- | The API of a Todo service.-type TodoAPI-    = "todo" :> Get '[JSON] [Todo]- :<|> "todo" :> ReqBody '[JSON] Todo :> Post '[JSON] TodoId- :<|> "todo" :> Capture "id" TodoId :> Get '[JSON] Todo- :<|> "todo" :> Capture "id" TodoId :> ReqBody '[JSON] Todo :> Put '[JSON] TodoId- :<|> "todo" :> "choices" :> MultipleChoicesInt- +type TodoAPI =+  "todo" :> Get '[JSON] [Todo]+    :<|> "todo" :> ReqBody '[JSON] Todo :> Post '[JSON] TodoId+    :<|> "todo" :> Capture "id" TodoId :> Get '[JSON] Todo+    :<|> "todo" :> Capture "id" TodoId :> ReqBody '[JSON] Todo :> Put '[JSON] TodoId+    :<|> "todo" :> "choices" :> MultipleChoicesInt+ -- | API for serving @swagger.json@. type SwaggerAPI = "swagger.json" :> Get '[JSON] OpenApi @@ -41,36 +42,41 @@  -- | A single Todo entry. data Todo = Todo-  { created :: UTCTime  -- ^ Creation datetime.-  , summary :: Text     -- ^ Task summary.-  } deriving (Show, Generic, Typeable)+  { created :: UTCTime+  -- ^ Creation datetime.+  , summary :: Text+  -- ^ Task summary.+  }+  deriving (Generic, Show, Typeable)  -- | A unique Todo entry ID. newtype TodoId = TodoId Int-  deriving (Show, Generic, Typeable, ToJSON, FromHttpApiData)+  deriving (FromHttpApiData, Generic, Show, ToJSON, Typeable)  instance ToJSON Todo instance FromJSON Todo  instance ToSchema Todo where-  declareNamedSchema proxy = genericDeclareNamedSchema defaultSchemaOptions proxy-    & mapped.schema.description ?~ "This is some real Todo right here"-    & mapped.schema.example ?~ toJSON (Todo (UTCTime (fromGregorian 2015 12 31) 0) "get milk")+  declareNamedSchema proxy =+    genericDeclareNamedSchema defaultSchemaOptions proxy+      & mapped . schema . description ?~ "This is some real Todo right here"+      & mapped . schema . example ?~ toJSON (Todo (UTCTime (fromGregorian 2015 12 31) 0) "get milk")  instance ToParamSchema TodoId instance ToSchema TodoId  -- | Swagger spec for Todo API. todoSwagger :: OpenApi-todoSwagger = toOpenApi todoAPI-  & info.title   .~ "Todo API"-  & info.version .~ "1.0"-  & info.description ?~ "This is an API that tests swagger integration"-  & info.license ?~ ("MIT" & url ?~ URL "http://mit.com")+todoSwagger =+  toOpenApi todoAPI+    & info . title .~ "Todo API"+    & info . version .~ "1.0"+    & info . description ?~ "This is an API that tests swagger integration"+    & info . license ?~ ("MIT" & url ?~ URL "http://mit.com")  -- | Combined server of a Todo service with Swagger documentation. server :: Server API-server = return todoSwagger :<|> error "not implemented"+server = pure todoSwagger :<|> error "not implemented"  -- | Output generated @swagger.json@ file for the @'TodoAPI'@. writeSwaggerJSON :: IO ()@@ -88,15 +94,16 @@   | Even Bool   | Odd Int   deriving stock (Generic)-  deriving (AsUnion MultiResponses)+  deriving+    (AsUnion MultiResponses)     via GenericAsUnion MultiResponses MultiResult  instance GSOP.Generic MultiResult  type MultipleChoicesInt =   Capture "int" Int-  :> MultiVerb-    'GET-    '[JSON]-    MultiResponses-    MultiResult+    :> MultiVerb+         'GET+         '[JSON]+         MultiResponses+         MultiResult

@@ -1,17 +1,18 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}+ module TodoSpec where -import Prelude ()+import Data.Aeson+import qualified Data.ByteString.Lazy.Char8 as BL8 import Prelude.Compat+import Servant.OpenApi.Test+import Test.Hspec+import Test.QuickCheck+import Test.QuickCheck.Instances ()+import Prelude () -import           Data.Aeson-import qualified Data.ByteString.Lazy.Char8 as BL8-import           Paths_example-import           Servant.OpenApi.Test-import           Test.Hspec-import           Test.QuickCheck-import           Test.QuickCheck.Instances  ()-import           Todo+import Paths_example+import Todo  spec :: Spec spec = describe "Swagger" $ do

@@ -1,5 +1,6 @@+cabal-version:       3.0 name:                servant-openapi3-version:             2.0.2.0+version:             2.1.0.0 synopsis:            Generate a Swagger/OpenAPI/OAS 3.0 specification for your servant API. description:   Swagger is a project used to describe and document RESTful APIs. The core of the @@ -18,33 +19,21 @@   * generating clients and servers in many languages using [Swagger Codegen](http://swagger.io/swagger-codegen/);   .   * and [many others](http://swagger.io/open-source-integrations/).-homepage:            https://github.com/bitnomial/servant-openapi3-bug-reports:         https://github.com/bitnomial/servant-openapi3/issues-license:             BSD3+homepage:            https://github.com/haskell-servant/servant+bug-reports:         https://github.com/haskell-servant/servant/issues+license:             BSD-3-Clause license-file:        LICENSE author:              David Johnson, Nickolay Kudasov, Maxim Koltsov maintainer:          Laurent P. Rene de Cotret copyright:           (c) 2015-2020, Servant contributors                      (c) 2020-2025 Maxim Koltsov-                     (c) 2026 servant-openapi3 contributors+                     (c) 2026 Servant contributors category:            Web, Servant, Swagger-build-type:          Custom-cabal-version:       1.18-tested-with:-  GHC ==8.6.5-   || ==8.8.4-   || ==8.10.7-   || ==9.0.2-   || ==9.2.8-   || ==9.4.8-   || ==9.6.3-   || ==9.8.1-   || ==9.10.2-   || ==9.12.1+build-type:          Simple+tested-with:         GHC ==9.2.8 || ==9.4.8 || ==9.6.6 || ==9.8.4 || ==9.10.1 || ==9.12.1  extra-source-files:     README.md-  , CHANGELOG.md   , example/server/*.hs   , example/src/*.hs   , example/test/*.hs@@ -52,21 +41,17 @@   , example/swagger.json   , example/LICENSE extra-doc-files:-    example/src/*.hs+    CHANGELOG.md+  , example/src/*.hs   , example/test/*.hs  source-repository head   type:     git-  location: https://github.com/bitnomial/servant-openapi3.git--custom-setup-  setup-depends:-    base >=4.9 && <4.22,-    Cabal >= 1.24 && < 4,-    cabal-doctest >=1.0.6 && <1.1+  location: https://github.com/haskell-servant/servant.git+  subdir:   servant-openapi3  library-  ghc-options:         -Wall+  ghc-options:         -Wall -Wunused-packages   exposed-modules:     Servant.OpenApi     Servant.OpenApi.Test@@ -81,63 +66,38 @@     Servant.OpenApi.Internal.TypeLevel.Every     Servant.OpenApi.Internal.TypeLevel.TMap   hs-source-dirs:      src-  build-depends:       aeson                     >=1.4.2.0  && <1.6 || >=2.0.1.0 && <2.3-                     , aeson-pretty              >=0.8.7    && <0.9-                     , base                      >=4.9.1.0  && <4.22-                     , base-compat               >=0.10.5   && <0.15-                     , bytestring                >=0.10.8.1 && <0.13+  build-depends:       aeson                     >=2.2      && <2.4+                     , aeson-pretty              >=0.8.9    && <0.9+                     , base                      >=4.16.4   && <4.23+                     , base-compat               >=0.12     && <0.15+                     , bytestring                >=0.11     && <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-                     , servant-server            >=0.17     && <0.21-                     , servant-client-core       >=0.17     && <0.21-                     , singleton-bool            >=0.1.4    && <0.2-                     , openapi3                  >=3.2.3    && <3.3-                     , text                      >=1.2.3.0  && <3-                     , unordered-containers      >=0.2.9.0  && <0.3-                     , generics-sop              >=0.5.1+                     , lens                      >=5.3.6    && <5.4+                     , servant                   >=0.20.3   && <0.21+                     , servant-server            >=0.20.3   && <0.21+                     , singleton-bool            >=0.1.6    && <0.2+                     , openapi3                  >=3.2.5    && <3.3+                     , text                      >=1.2.5.0  && <3 -                     , hspec-                     , QuickCheck+                     , hspec                     >=2.11     && <2.12+                     , QuickCheck                >=2.18     && <2.19   default-language:    Haskell2010 -test-suite doctests-  ghc-options:      -Wall-  build-depends:-    base <5,-    directory >= 1.0,-    doctest >= 0.11.1 && <0.25,-    servant,-    QuickCheck,-    filepath-  default-language: Haskell2010-  hs-source-dirs:   test-  main-is:          doctests.hs-  type:             exitcode-stdio-1.0- test-suite spec-  ghc-options:      -Wall+  ghc-options:      -Wall -Wunused-packages   type:             exitcode-stdio-1.0   hs-source-dirs:   test   main-is:          Spec.hs-  build-tool-depends: hspec-discover:hspec-discover >=2.6.0 && <2.12-  build-depends:    base <5-                  , base-compat+  build-tool-depends: hspec-discover:hspec-discover >=2.11  && <2.12+  build-depends:    base                   , aeson-                  , hspec >=2.6.0 && <2.12-                  , QuickCheck+                  , hspec                   , lens-                  , lens-aeson >=1.0.2    && <1.3                   , servant                   , servant-openapi3-                    -- openapi3 3.1.0 fixes some ordering-related issues, making tests stable-                  , openapi3 >= 3.1.0+                  , openapi3                   , text-                  , template-haskell-                  , utf8-string >=1.0.1.1 && <1.1                   , time-                  , vector   other-modules:     Servant.OpenApiSpec   default-language: Haskell2010

@@ -15,36 +15,36 @@ -- Additional utilities can also take advantage of the resulting files, such as testing tools. -- -- For more information see <http://swagger.io/ OpenApi documentation>.-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@@ -59,13 +59,12 @@ -- >>> import qualified Data.ByteString.Lazy.Char8 as BSL8 -- >>> import Servant.OpenApi.Internal.Test -- >>> :set -XDataKinds--- >>> :set -XDeriveDataTypeable -- >>> :set -XDeriveGeneric -- >>> :set -XGeneralizedNewtypeDeriving -- >>> :set -XOverloadedStrings -- >>> :set -XTypeOperators--- >>> data User = User { name :: String, age :: Int } deriving (Show, Generic, Typeable)--- >>> newtype UserId = UserId Integer deriving (Show, Generic, Typeable, ToJSON)+-- >>> data User = User { name :: String, age :: Int } deriving (Show, Generic)+-- >>> newtype UserId = UserId Integer deriving (Show, Generic, ToJSON) -- >>> instance ToJSON User -- >>> instance ToSchema User -- >>> instance ToSchema UserId@@ -82,8 +81,8 @@ -- -- For the purposes of this section we will use this servant API: ----- >>> data User = User { name :: String, age :: Int } deriving (Show, Generic, Typeable)--- >>> newtype UserId = UserId Integer deriving (Show, Generic, Typeable, ToJSON)+-- >>> data User = User { name :: String, age :: Int } deriving (Show, Generic)+-- >>> newtype UserId = UserId Integer deriving (Show, Generic, ToJSON) -- >>> instance ToJSON User -- >>> instance ToSchema User -- >>> instance ToSchema UserId@@ -136,7 +135,7 @@ --                 "responses": { --                     "200": { --                         "content": {---                             "application/json;charset=utf-8": {+--                             "application/json": { --                                 "schema": { --                                     "items": { --                                         "$ref": "#/components/schemas/User"@@ -152,7 +151,7 @@ --             "post": { --                 "requestBody": { --                     "content": {---                         "application/json;charset=utf-8": {+--                         "application/json": { --                             "schema": { --                                 "$ref": "#/components/schemas/User" --                             }@@ -162,7 +161,7 @@ --                 "responses": { --                     "200": { --                         "content": {---                             "application/json;charset=utf-8": {+--                             "application/json": { --                                 "schema": { --                                     "$ref": "#/components/schemas/UserId" --                                 }@@ -191,7 +190,7 @@ --                 "responses": { --                     "200": { --                         "content": {---                             "application/json;charset=utf-8": {+--                             "application/json": { --                                 "schema": { --                                     "$ref": "#/components/schemas/User" --                                 }@@ -267,7 +266,7 @@ --                 "responses": { --                     "200": { --                         "content": {---                             "application/json;charset=utf-8": {+--                             "application/json": { --                                 "schema": { --                                     "items": { --                                         "$ref": "#/components/schemas/User"@@ -283,7 +282,7 @@ --             "post": { --                 "requestBody": { --                     "content": {---                         "application/json;charset=utf-8": {+--                         "application/json": { --                             "schema": { --                                 "$ref": "#/components/schemas/User" --                             }@@ -293,7 +292,7 @@ --                 "responses": { --                     "200": { --                         "content": {---                             "application/json;charset=utf-8": {+--                             "application/json": { --                                 "schema": { --                                     "$ref": "#/components/schemas/UserId" --                                 }@@ -322,7 +321,7 @@ --                 "responses": { --                     "200": { --                         "content": {---                             "application/json;charset=utf-8": {+--                             "application/json": { --                                 "schema": { --                                     "$ref": "#/components/schemas/User" --                                 }@@ -396,7 +395,7 @@ --                 "responses": { --                     "200": { --                         "content": {---                             "application/json;charset=utf-8": {+--                             "application/json": { --                                 "schema": { --                                     "items": { --                                         "$ref": "#/components/schemas/User"@@ -415,7 +414,7 @@ --             "post": { --                 "requestBody": { --                     "content": {---                         "application/json;charset=utf-8": {+--                         "application/json": { --                             "schema": { --                                 "$ref": "#/components/schemas/User" --                             }@@ -425,7 +424,7 @@ --                 "responses": { --                     "200": { --                         "content": {---                             "application/json;charset=utf-8": {+--                             "application/json": { --                                 "schema": { --                                     "$ref": "#/components/schemas/UserId" --                                 }@@ -457,7 +456,7 @@ --                 "responses": { --                     "200": { --                         "content": {---                             "application/json;charset=utf-8": {+--                             "application/json": { --                                 "schema": { --                                     "$ref": "#/components/schemas/User" --                                 }

@@ -1,52 +1,51 @@-{-# LANGUAGE CPP                   #-}-{-# LANGUAGE ConstraintKinds       #-}-{-# LANGUAGE DataKinds             #-}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE PolyKinds             #-}-{-# LANGUAGE RankNTypes            #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE TypeOperators         #-}-{-# LANGUAGE TypeApplications      #-}-{-# LANGUAGE TupleSections         #-}-{-# LANGUAGE AllowAmbiguousTypes   #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE UndecidableInstances  #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-}+ module Servant.OpenApi.Internal where -import Prelude ()+import Control.Applicative ((<|>))+import Control.Lens+import Data.Aeson+import Data.Foldable (toList)+import Data.HashMap.Strict.InsOrd.Compat (InsOrdHashMap)+import qualified Data.HashMap.Strict.InsOrd.Compat as InsOrdHashMap+import Data.Kind (Type)+import qualified Data.Maybe as List+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 Prelude.Compat--import           Control.Applicative        ((<|>))-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.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.Description    (FoldDescription, reflectDescription)-import           Servant.API.Modifiers      (FoldRequired)-import           Servant.OpenApi.Internal.TypeLevel.API-import           Data.Kind (Type)-import           Servant.API.ContentTypes (AllMime, allMime)-#if MIN_VERSION_servant(0,20,3)+import Servant.API+import Servant.API.ContentTypes (AllMime, allMime)+import Servant.API.Description (FoldDescription, reflectDescription)+import Servant.API.Modifiers (FoldRequired)+import Servant.API.MultiVerb import qualified Servant.Server.Internal.ResponseRender as Server-import           Servant.API.MultiVerb-#endif-import qualified Data.Maybe as List+import Prelude () +import Servant.OpenApi.Internal.TypeLevel.API+ -- | Generate a OpenApi specification for a servant API. -- -- To generate OpenApi specification, your data types need@@ -92,71 +91,97 @@ -- | 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.+subOperations+  :: (HasOpenApi sub, IsSubAPI sub api)+  => Proxy sub+  -- ^ Part of a servant API.+  -> Proxy api+  -- ^ The whole servant 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.+mkEndpoint+  :: forall a cs hs proxy method status+   . (AllAccept cs, AllToResponseHeader hs, KnownNat status, OpenApiMethod method, ToSchema a)+  => FilePath+  -- ^ Endpoint path.+  -> proxy (Verb method status cs (Headers hs a))+  -- ^ Method, content-types, headers and response.   -> OpenApi-mkEndpoint path proxy-  = mkEndpointWithSchemaRef (Just ref) path proxy-      & components.schemas .~ defs+mkEndpoint path proxy =+  mkEndpointWithSchemaRef (Just ref) path proxy+    & components . schemas .~ defs   where     (defs, ref) = runDeclare (declareSchemaRef (Proxy :: Proxy a)) mempty  -- | Make a singletone '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.+mkEndpointNoContent+  :: forall nocontent cs hs proxy method status+   . (AllAccept cs, AllToResponseHeader hs, KnownNat status, OpenApiMethod method)+  => 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 = mkEndpointWithSchemaRef Nothing  -- | Like @'mkEndpoint'@ but with explicit schema reference. -- Unlike @'mkEndpoint'@ this function does not update @'definitions'@.-mkEndpointWithSchemaRef :: forall cs hs proxy method status a.-  (AllAccept cs, AllToResponseHeader hs, OpenApiMethod method, KnownNat status)+mkEndpointWithSchemaRef+  :: forall cs hs proxy method status a+   . (AllAccept cs, AllToResponseHeader hs, KnownNat status, OpenApiMethod method)   => 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 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+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 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@@ -167,7 +192,7 @@ markdownCode s = "`" <> s <> "`"  addDefaultResponse404 :: ParamName -> OpenApi -> OpenApi-addDefaultResponse404 pname = setResponseWith (\old _new -> alter404 old) 404 (return response404)+addDefaultResponse404 pname = setResponseWith (\old _new -> alter404 old) 404 (pure response404)   where     sname = markdownCode pname     description404 = sname <> " not found"@@ -175,7 +200,7 @@     response404 = mempty & description .~ description404  addDefaultResponse400 :: ParamName -> OpenApi -> OpenApi-addDefaultResponse400 pname = setResponseWith (\old _new -> alter400 old) 400 (return response400)+addDefaultResponse400 pname = setResponseWith (\old _new -> alter400 old) 400 (pure response400)   where     sname = markdownCode pname     description400 = "Invalid " <> sname@@ -186,28 +211,27 @@ 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  -- | @since <2.0.1.0> instance   {-# OVERLAPPABLE #-}-  ( ToSchema a,-    HasStatus a,-    AllAccept cs,-    OpenApiMethod method,-    HasOpenApi (UVerb method cs as)-  ) =>-  HasOpenApi (UVerb method cs (a ': as))+  ( AllAccept cs+  , HasOpenApi (UVerb method cs as)+  , HasStatus a+  , OpenApiMethod method+  , ToSchema a+  )+  => HasOpenApi (UVerb method cs (a ': as))   where   toOpenApi _ =     toOpenApi (Proxy :: Proxy (Verb method (StatusOf a) cs a))@@ -215,46 +239,50 @@     where       -- workaround for https://github.com/GetShopTV/swagger2/issues/218       combinePathItem :: PathItem -> PathItem -> PathItem-      combinePathItem s t = PathItem-        { _pathItemGet = _pathItemGet s <> _pathItemGet t-        , _pathItemPut = _pathItemPut s <> _pathItemPut t-        , _pathItemPost = _pathItemPost s <> _pathItemPost t-        , _pathItemDelete = _pathItemDelete s <> _pathItemDelete t-        , _pathItemOptions = _pathItemOptions s <> _pathItemOptions t-        , _pathItemHead = _pathItemHead s <> _pathItemHead t-        , _pathItemPatch = _pathItemPatch s <> _pathItemPatch t-        , _pathItemTrace = _pathItemTrace s <> _pathItemTrace t-        , _pathItemParameters = _pathItemParameters s <> _pathItemParameters t-        , _pathItemSummary = _pathItemSummary s <|> _pathItemSummary t-        , _pathItemDescription = _pathItemDescription s <|> _pathItemDescription t-        , _pathItemServers = _pathItemServers s <> _pathItemServers t-        }+      combinePathItem s t =+        PathItem+          { _pathItemGet = _pathItemGet s <> _pathItemGet t+          , _pathItemPut = _pathItemPut s <> _pathItemPut t+          , _pathItemPost = _pathItemPost s <> _pathItemPost t+          , _pathItemDelete = _pathItemDelete s <> _pathItemDelete t+          , _pathItemOptions = _pathItemOptions s <> _pathItemOptions t+          , _pathItemHead = _pathItemHead s <> _pathItemHead t+          , _pathItemPatch = _pathItemPatch s <> _pathItemPatch t+          , _pathItemTrace = _pathItemTrace s <> _pathItemTrace t+          , _pathItemParameters = _pathItemParameters s <> _pathItemParameters t+          , _pathItemSummary = _pathItemSummary s <|> _pathItemSummary t+          , _pathItemDescription = _pathItemDescription s <|> _pathItemDescription t+          , _pathItemServers = _pathItemServers s <> _pathItemServers t+          }        combineSwagger :: OpenApi -> OpenApi -> OpenApi-      combineSwagger s t = OpenApi-        { _openApiOpenapi = _openApiOpenapi s <> _openApiOpenapi t-        , _openApiInfo = _openApiInfo s <> _openApiInfo t-        , _openApiServers = _openApiServers s <> _openApiServers t-        , _openApiPaths = InsOrdHashMap.unionWith combinePathItem (_openApiPaths s) (_openApiPaths t)-        , _openApiComponents = _openApiComponents s <> _openApiComponents t-        , _openApiSecurity = _openApiSecurity s <> _openApiSecurity t-        , _openApiTags = _openApiTags s <> _openApiTags t-        , _openApiExternalDocs = _openApiExternalDocs s <|> _openApiExternalDocs t-        }+      combineSwagger s t =+        OpenApi+          { _openApiOpenapi = _openApiOpenapi s <> _openApiOpenapi t+          , _openApiInfo = _openApiInfo s <> _openApiInfo t+          , _openApiServers = _openApiServers s <> _openApiServers t+          , _openApiPaths = InsOrdHashMap.unionWith combinePathItem (_openApiPaths s) (_openApiPaths t)+          , _openApiComponents = _openApiComponents s <> _openApiComponents t+          , _openApiSecurity = _openApiSecurity s <> _openApiSecurity t+          , _openApiTags = _openApiTags s <> _openApiTags t+          , _openApiExternalDocs = _openApiExternalDocs s <|> _openApiExternalDocs t+          } -instance (Typeable (WithStatus s a), ToSchema a) => ToSchema (WithStatus s a) where+instance (ToSchema a, Typeable (WithStatus s a)) => ToSchema (WithStatus s a) where   declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a)-#endif -instance {-# OVERLAPPABLE #-} (ToSchema a, AllAccept cs, KnownNat status, OpenApiMethod method) => HasOpenApi (Verb method status cs a) where+instance {-# OVERLAPPABLE #-} (AllAccept cs, KnownNat status, OpenApiMethod method, ToSchema a) => HasOpenApi (Verb method status cs a) where   toOpenApi _ = toOpenApi (Proxy :: Proxy (Verb method status cs (Headers '[] a)))  -- | @since 1.1.7-instance (ToSchema a, Accept ct, KnownNat status, OpenApiMethod method) => HasOpenApi (Stream method status fr ct a) where+instance (Accept ct, KnownNat status, OpenApiMethod method, ToSchema a) => 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 #-}+  (AllAccept cs, AllToResponseHeader hs, KnownNat status, OpenApiMethod method, ToSchema a)+  => HasOpenApi (Verb method status cs (Headers hs a))+  where   toOpenApi = mkEndpoint "/"  -- ATTENTION: do not remove this instance!@@ -264,175 +292,198 @@ 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 "/"+instance OpenApiMethod method => HasOpenApi (NoContentVerb method) where+  toOpenApi = mkEndpointNoContentVerb "/"  instance (HasOpenApi a, HasOpenApi b) => HasOpenApi (a :<|> b) where   toOpenApi _ = toOpenApi (Proxy :: Proxy a) <> toOpenApi (Proxy :: Proxy b)  -- | @'Vault'@ combinator does not change our specification at all.-instance (HasOpenApi sub) => HasOpenApi (Vault :> sub) where+instance HasOpenApi sub => HasOpenApi (Vault :> sub) where   toOpenApi _ = toOpenApi (Proxy :: Proxy sub)  -- | @'IsSecure'@ combinator does not change our specification at all.-instance (HasOpenApi sub) => HasOpenApi (IsSecure :> sub) where+instance HasOpenApi sub => HasOpenApi (IsSecure :> sub) where   toOpenApi _ = toOpenApi (Proxy :: Proxy sub)  -- | @'RemoteHost'@ combinator does not change our specification at all.-instance (HasOpenApi sub) => HasOpenApi (RemoteHost :> sub) where+instance HasOpenApi sub => HasOpenApi (RemoteHost :> sub) where   toOpenApi _ = toOpenApi (Proxy :: Proxy sub)  -- | @'HttpVersion'@ combinator does not change our specification at all.-instance (HasOpenApi sub) => HasOpenApi (HttpVersion :> sub) where+instance HasOpenApi sub => HasOpenApi (HttpVersion :> sub) where   toOpenApi _ = toOpenApi (Proxy :: Proxy sub) -#if MIN_VERSION_servant(0,20,0) -- | @'WithResource'@ combinator does not change our specification at all.-instance (HasOpenApi sub) => HasOpenApi (WithResource res :> sub) where+instance HasOpenApi sub => HasOpenApi (WithResource res :> sub) where   toOpenApi _ = toOpenApi (Proxy :: Proxy sub)-#endif  -- | @'WithNamedContext'@ combinator does not change our specification at all.-instance (HasOpenApi sub) => HasOpenApi (WithNamedContext x c sub) where+instance HasOpenApi sub => HasOpenApi (WithNamedContext x c sub) where   toOpenApi _ = toOpenApi (Proxy :: Proxy sub) -instance (KnownSymbol sym, HasOpenApi sub) => HasOpenApi (sym :> sub) where+instance (HasOpenApi sub, KnownSymbol sym) => HasOpenApi (sym :> sub) where   toOpenApi _ = prependPath piece (toOpenApi (Proxy :: Proxy sub))     where       piece = symbolVal (Proxy :: Proxy sym) -instance (KnownSymbol sym, ToParamSchema a, HasOpenApi sub, KnownSymbol (FoldDescription mods)) => HasOpenApi (Capture' mods sym a :> sub) where-  toOpenApi _ = toOpenApi (Proxy :: Proxy sub)-    & addParam param-    & prependPath capture-    & addDefaultResponse404 tname+instance (HasOpenApi sub, KnownSymbol (FoldDescription mods), KnownSymbol sym, ToParamSchema a) => HasOpenApi (Capture' mods sym a :> sub) where+  toOpenApi _ =+    toOpenApi (Proxy :: Proxy sub)+      & addParam param+      & prependPath capture+      & addDefaultResponse404 tname     where       pname = symbolVal (Proxy :: Proxy sym)       tname = Text.pack pname-      transDesc ""   = Nothing+      transDesc "" = 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+instance (HasOpenApi sub, KnownSymbol sym, ToParamSchema a) => HasOpenApi (CaptureAll sym a :> sub) where   toOpenApi _ = toOpenApi (Proxy :: Proxy (Capture sym a :> sub)) -instance (KnownSymbol desc, HasOpenApi api) => HasOpenApi (Description desc :> api) where-  toOpenApi _ = toOpenApi (Proxy :: Proxy api)-    & allOperations.description %~ (Just (Text.pack (symbolVal (Proxy :: Proxy desc))) <>)+instance (HasOpenApi api, KnownSymbol desc) => HasOpenApi (Description desc :> api) where+  toOpenApi _ =+    toOpenApi (Proxy :: Proxy api)+      & allOperations . description %~ (Just (Text.pack (symbolVal (Proxy :: Proxy desc))) <>) -instance (KnownSymbol desc, HasOpenApi api) => HasOpenApi (Summary desc :> api) where-  toOpenApi _ = toOpenApi (Proxy :: Proxy api)-    & allOperations.summary %~ (Just (Text.pack (symbolVal (Proxy :: Proxy desc))) <>)+instance (HasOpenApi api, KnownSymbol desc) => HasOpenApi (Summary desc :> api) where+  toOpenApi _ =+    toOpenApi (Proxy :: Proxy api)+      & allOperations . summary %~ (Just (Text.pack (symbolVal (Proxy :: Proxy desc))) <>) -instance (KnownSymbol sym, ToParamSchema a, HasOpenApi sub, SBoolI (FoldRequired mods), KnownSymbol (FoldDescription mods)) => HasOpenApi (QueryParam' mods sym a :> sub) where-  toOpenApi _ = toOpenApi (Proxy :: Proxy sub)-    & addParam param-    & addDefaultResponse400 tname+#if MIN_VERSION_servant(0,20,4)+instance (HasOpenApi api, KnownSymbol operationId) => HasOpenApi (OperationId operationId :> api) where+  toOpenApi _ =+    toOpenApi (Proxy :: Proxy api)+      & allOperations . operationId %~ (Just (Text.pack (symbolVal (Proxy :: Proxy operationId))) <>)+#endif++instance (HasOpenApi sub, KnownSymbol (FoldDescription mods), KnownSymbol sym, SBoolI (FoldRequired mods), ToParamSchema a) => HasOpenApi (QueryParam' mods sym a :> sub) where+  toOpenApi _ =+    toOpenApi (Proxy :: Proxy sub)+      & addParam param+      & addDefaultResponse400 tname     where       tname = Text.pack (symbolVal (Proxy :: Proxy sym))-      transDesc ""   = Nothing+      transDesc "" = 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+instance (HasOpenApi sub, KnownSymbol sym, ToParamSchema a) => HasOpenApi (QueryParams sym a :> sub) where+  toOpenApi _ =+    toOpenApi (Proxy :: Proxy sub)+      & addParam param+      & addDefaultResponse400 tname     where       tname = Text.pack (symbolVal (Proxy :: Proxy sym))-      param = mempty-        & name .~ tname-        & in_ .~ ParamQuery-        & schema ?~ Inline pschema-      pschema = mempty-        & type_ ?~ OpenApiArray-        & items ?~ OpenApiItemsObject (Inline $ toParamSchema (Proxy :: Proxy a))+      param =+        mempty+          & name .~ tname+          & in_ .~ ParamQuery+          & schema ?~ Inline pschema+      pschema =+        mempty+          & type_ ?~ 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+instance (HasOpenApi sub, KnownSymbol sym) => HasOpenApi (QueryFlag sym :> sub) where+  toOpenApi _ =+    toOpenApi (Proxy :: Proxy sub)+      & addParam param+      & addDefaultResponse400 tname     where       tname = Text.pack (symbolVal (Proxy :: Proxy sym))-      param = mempty-        & name .~ tname-        & in_ .~ ParamQuery-        & allowEmptyValue ?~ True-        & schema ?~ (Inline $ (toParamSchema (Proxy :: Proxy Bool))-                & default_ ?~ toJSON False)+      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 (HasOpenApi sub, KnownSymbol (FoldDescription mods), KnownSymbol sym, SBoolI (FoldRequired mods), ToParamSchema a) => 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 %~ (<> defs)+instance (AllAccept cs, HasOpenApi sub, KnownSymbol (FoldDescription mods), ToSchema a) => HasOpenApi (ReqBody' mods cs a :> sub) where+  toOpenApi _ =+    toOpenApi (Proxy :: Proxy sub)+      & addRequestBody reqBody+      & addDefaultResponse400 tname+      & components . schemas %~ (<> defs)     where       tname = "body"-      transDesc ""   = Nothing+      transDesc "" = Nothing       transDesc desc = Just (Text.pack desc)       (defs, ref) = runDeclare (declareSchemaRef (Proxy :: Proxy a)) mempty-      reqBody = (mempty :: RequestBody)-        & description .~ transDesc (reflectDescription (Proxy :: Proxy mods))-        & content .~ InsOrdHashMap.fromList [(t, mempty & schema ?~ ref) | t <- allContentType (Proxy :: Proxy cs)]+      reqBody =+        (mempty :: RequestBody)+          & description .~ transDesc (reflectDescription (Proxy :: Proxy mods))+          & content .~ InsOrdHashMap.fromList [(t, mempty & schema ?~ ref) | 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 %~ (<> defs)+instance (Accept ct, HasOpenApi sub, KnownSymbol (FoldDescription mods), ToSchema a) => HasOpenApi (StreamBody' mods fr ct a :> sub) where+  toOpenApi _ =+    toOpenApi (Proxy :: Proxy sub)+      & addRequestBody reqBody+      & addDefaultResponse400 tname+      & components . schemas %~ (<> defs)     where       tname = "body"-      transDesc ""   = Nothing+      transDesc "" = Nothing       transDesc desc = Just (Text.pack desc)       (defs, ref) = runDeclare (declareSchemaRef (Proxy :: Proxy a)) mempty-      reqBody = (mempty :: RequestBody)-        & description .~ transDesc (reflectDescription (Proxy :: Proxy mods))-        & content .~ InsOrdHashMap.fromList [(t, mempty & schema ?~ ref) | t <- toList $ contentTypes (Proxy :: Proxy ct)]+      reqBody =+        (mempty :: RequestBody)+          & description .~ transDesc (reflectDescription (Proxy :: Proxy mods))+          & content .~ InsOrdHashMap.fromList [(t, mempty & schema ?~ ref) | t <- toList $ contentTypes (Proxy :: Proxy ct)] -#if MIN_VERSION_servant(0,18,2)-instance (HasOpenApi sub) => HasOpenApi (Fragment a :> sub) where+instance HasOpenApi sub => HasOpenApi (Fragment a :> sub) where   toOpenApi _ = toOpenApi (Proxy :: Proxy sub)-#endif -#if MIN_VERSION_servant(0,19,0)-instance (HasOpenApi (ToServantApi sub)) => HasOpenApi (NamedRoutes sub) where+instance HasOpenApi (ToServantApi sub) => HasOpenApi (NamedRoutes sub) where   toOpenApi _ = toOpenApi (Proxy :: Proxy (ToServantApi sub))-#endif  -- ======================================================================= -- Below are the definitions that should be in Servant.API.ContentTypes@@ -462,7 +513,7 @@ instance AllToResponseHeader '[] where   toAllResponseHeaders _ = mempty -instance (ToResponseHeader h, AllToResponseHeader hs) => AllToResponseHeader (h ': hs) where+instance (AllToResponseHeader hs, ToResponseHeader h) => AllToResponseHeader (h ': hs) where   toAllResponseHeaders _ = InsOrdHashMap.insert headerName headerBS hdrs     where       (headerName, headerBS) = toResponseHeader (Proxy :: Proxy h)@@ -471,22 +522,21 @@ instance AllToResponseHeader hs => AllToResponseHeader (HList hs) where   toAllResponseHeaders _ = toAllResponseHeaders (Proxy :: Proxy hs) -#if MIN_VERSION_servant(0,20,3) type DeclareDefinition = Declare (Definitions Schema)  class IsSwaggerResponse a where   responseSwagger :: DeclareDefinition Response  instance-  (AllToResponseHeader hs, IsSwaggerResponse r) =>-  IsSwaggerResponse (WithHeaders hs a r)+  (AllToResponseHeader hs, IsSwaggerResponse r)+  => IsSwaggerResponse (WithHeaders hs a r)   where   responseSwagger =     fmap       (headers .~ fmap Inline (toAllResponseHeaders (Proxy @hs)))       (responseSwagger @r) -simpleResponseSwagger :: forall a cs desc. (ToSchema a, KnownSymbol desc, AllMime cs) => DeclareDefinition Response+simpleResponseSwagger :: forall a cs desc. (AllMime cs, KnownSymbol desc, ToSchema a) => DeclareDefinition Response simpleResponseSwagger = do   ref <- declareSchemaRef (Proxy @a)   let resps :: InsOrdHashMap MediaType MediaTypeObject@@ -500,21 +550,21 @@     cs = allMime $ Proxy @cs  instance-  (KnownSymbol desc, ToSchema a) =>-  IsSwaggerResponse (Respond s desc a)+  (KnownSymbol desc, ToSchema a)+  => IsSwaggerResponse (Respond s desc a)   where   -- Defaulting this to JSON, as openapi3 needs something to map a schema against.   responseSwagger = simpleResponseSwagger @a @'[JSON] @desc  instance-  (KnownSymbol desc, ToSchema a, Accept ct) =>-  IsSwaggerResponse (RespondAs (ct :: Type) s desc a)+  (Accept ct, KnownSymbol desc, ToSchema a)+  => IsSwaggerResponse (RespondAs (ct :: Type) s desc a)   where   responseSwagger = simpleResponseSwagger @a @'[ct] @desc  instance-  (KnownSymbol desc) =>-  IsSwaggerResponse (RespondEmpty s desc)+  KnownSymbol desc+  => IsSwaggerResponse (RespondEmpty s desc)   where   responseSwagger =     pure $@@ -528,11 +578,11 @@   responseListSwagger = pure mempty  instance-  ( IsSwaggerResponse a,-    KnownNat (Server.ResponseStatus a),-    IsSwaggerResponseList as-  ) =>-  IsSwaggerResponseList (a ': as)+  ( IsSwaggerResponse a+  , IsSwaggerResponseList as+  , KnownNat (Server.ResponseStatus a)+  )+  => IsSwaggerResponseList (a ': as)   where   responseListSwagger =     InsOrdHashMap.insertWith@@ -568,8 +618,8 @@   | otherwise = s1  instance-  (OpenApiMethod method, IsSwaggerResponseList as) =>-  HasOpenApi (MultiVerb method '() as r)+  (IsSwaggerResponseList as, OpenApiMethod method)+  => HasOpenApi (MultiVerb method '() as r)   where   toOpenApi _ =     mempty@@ -588,8 +638,8 @@       refResps = Inline <$> resps  instance-  (OpenApiMethod method, IsSwaggerResponseList as, AllMime cs) =>-  HasOpenApi (MultiVerb method (cs :: [Type]) as r)+  (AllMime cs, IsSwaggerResponseList as, OpenApiMethod method)+  => HasOpenApi (MultiVerb method (cs :: [Type]) as r)   where   toOpenApi _ =     mempty@@ -623,4 +673,3 @@               . List.listToMaybe               . toList       refResps = Inline . addMime <$> resps-#endif

@@ -1,17 +1,16 @@-{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-}-+{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-}+ 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])+instance (ToSchema a, Typeable (SourceT m a)) => ToSchema (SourceT m a) where+  declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])

@@ -1,26 +1,27 @@-{-# LANGUAGE ConstraintKinds     #-}-{-# LANGUAGE DataKinds           #-}-{-# LANGUAGE FlexibleContexts    #-}-{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeOperators       #-}+{-# LANGUAGE TypeOperators #-}+ 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 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 Servant.API+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck (Arbitrary, Property, counterexample, property) -import           Servant.API-import           Servant.OpenApi.Internal.TypeLevel+import Servant.OpenApi.Internal.TypeLevel  -- $setup -- >>> import Control.Applicative@@ -40,8 +41,8 @@ -- @'validateEveryToJSON'@ will produce one @'prop'@ specification for every type in the API. -- Each type only gets one test, even if it occurs multiple times in the API. ----- >>> data User = User { name :: String, age :: Maybe Int } deriving (Show, Generic, Typeable)--- >>> newtype UserId = UserId String deriving (Show, Generic, Typeable, ToJSON, Arbitrary)+-- >>> data User = User { name :: String, age :: Maybe Int } deriving (Show, Generic)+-- >>> newtype UserId = UserId String deriving (Show, Generic, ToJSON, Arbitrary) -- >>> instance ToJSON User -- >>> instance ToSchema User -- >>> instance ToSchema UserId@@ -78,28 +79,36 @@ -- ...  arising from a use of ‘validateEveryToJSON’ -- ... validateEveryToJSON-  :: forall proxy api .-     TMap (Every [Typeable, Show, Arbitrary, ToJSON, ToSchema])-          (BodyTypes JSON api)-  => proxy api   -- ^ Servant API.+  :: 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 _ =+  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.+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 checker _ =+  props+    (Proxy :: Proxy [ToJSON, ToSchema])+    (maybeCounterExample . prettyValidateWith (validateToJSONWithPatternChecker checker))+    (Proxy :: Proxy (BodyTypes JSON api))  -- * QuickCheck-related stuff @@ -125,18 +134,23 @@ -- <BLANKLINE> -- 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.+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 _ f px = sequence_ specs   where     specs :: [Spec]     specs = tmapEvery (Proxy :: Proxy (Typeable ': Show ': Arbitrary ': cs)) aprop px -    aprop :: forall p' a. (EveryTF cs a, Typeable a, Show a, Arbitrary a) => p' a -> Spec-    aprop _ = prop (show (typeOf (undefined :: a))) (f :: a -> Property)+    aprop :: forall p' a. (Arbitrary a, EveryTF cs a, Show a, Typeable a) => p' a -> Spec+    aprop _ = prop (show (typeRep (Proxy :: Proxy a))) (f :: a -> Property)  -- | Pretty print validation errors -- together with actual JSON and OpenApi Schema@@ -177,30 +191,33 @@ -- -- FIXME: this belongs in "Data.OpenApi.Schema.Validation" (in @swagger2@). prettyValidateWith-  :: forall a. (ToJSON a, ToSchema a)+  :: 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 = P.encodePretty' $ P.defConfig{P.confCompare = P.compare}

@@ -1,9 +1,9 @@-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

@@ -1,29 +1,23 @@-{-# LANGUAGE CPP                  #-}-{-# LANGUAGE ConstraintKinds      #-}-{-# LANGUAGE DataKinds            #-}-{-# LANGUAGE KindSignatures       #-}-{-# LANGUAGE PolyKinds            #-}-{-# LANGUAGE TypeFamilies         #-}-{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}+ module Servant.OpenApi.Internal.TypeLevel.API where -import           GHC.Exts            (Constraint)-import           Servant.API-#if MIN_VERSION_servant(0,19,0)-import           Servant.API.Generic (ToServantApi)-#endif-#if MIN_VERSION_servant(0,20,3)-import Servant.API.MultiVerb (MultiVerb, Respond, RespondAs, RespondStreaming, WithHeaders, GenericAsConstructor) import Data.ByteString (ByteString)-#endif+import GHC.Exts (Constraint)+import Servant.API+import Servant.API.Generic (ToServantApi)+import Servant.API.MultiVerb (GenericAsConstructor, MultiVerb, Respond, RespondAs, RespondStreaming, WithHeaders)+ -- | Build a list of endpoints from an API. type family EndpointsList api where   EndpointsList (a :<|> b) = AppendList (EndpointsList a) (EndpointsList b)-  EndpointsList (e :> a)   = MapSub e (EndpointsList a)-#if MIN_VERSION_servant(0,19,0)+  EndpointsList (e :> a) = MapSub e (EndpointsList a)   EndpointsList (NamedRoutes api) = EndpointsList (ToServantApi api)-#endif   EndpointsList a = '[a]  -- | Check whether @sub@ is a sub API of @api@.@@ -42,7 +36,7 @@  -- | Append two type-level lists. type family AppendList xs ys where-  AppendList '[]       ys = ys+  AppendList '[] ys = ys   AppendList (x ': xs) ys = x ': AppendList xs ys  type family Or (a :: Constraint) (b :: Constraint) :: Constraint where@@ -52,9 +46,7 @@ type family IsIn sub api :: Constraint where   IsIn e (a :<|> b) = Or (IsIn e a) (IsIn e b)   IsIn (e :> a) (e :> b) = IsIn a b-#if MIN_VERSION_servant(0,19,0)   IsIn e (NamedRoutes api) = IsIn e (ToServantApi api)-#endif   IsIn e e = ()  -- | Check whether a type is a member of a list of types.@@ -71,8 +63,8 @@  -- | Remove element from a type-level list. type family Remove x xs where-  Remove x '[]       = '[]-  Remove x (x ': ys) =      Remove x ys+  Remove x '[] = '[]+  Remove x (x ': ys) = Remove x ys   Remove x (y ': ys) = y ': Remove x ys  -- | Extract a list of unique "body" types for a specific content-type from a servant API.@@ -92,19 +84,13 @@   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)-#if MIN_VERSION_servant(0,19,0)   BodyTypes' c (NamedRoutes api) = BodyTypes' c (ToServantApi api)-#endif   BodyTypes' c api = '[] --#if MIN_VERSION_servant(0,20,3) -- | The 'ResponseTypes' class allows to extract all types -- involved in a response, whether or not this type is -- in the body of the response, or, for example, in a header.@@ -123,6 +109,7 @@ type instance MultiVerbResponseBody (Respond s description a) = a type instance MultiVerbResponseBody (RespondAs contentType s description a) = a type instance MultiVerbResponseBody (RespondStreaming s description framing contentType) = SourceIO ByteString+ -- The following instance is the main difference between 'MultiVerbResponseBody' and 'ResponseType' type instance MultiVerbResponseBody (WithHeaders headers returnType response) = MultiVerbResponseBody response type instance MultiVerbResponseBody (GenericAsConstructor r) = MultiVerbResponseBody r@@ -130,4 +117,3 @@ type family MultiVerbResponseBodies (as :: [*]) where   MultiVerbResponseBodies '[] = '[]   MultiVerbResponseBodies (a ': as) = MultiVerbResponseBody a ': MultiVerbResponseBodies as-#endif

@@ -1,27 +1,25 @@-{-# 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 MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-} #if __GLASGOW_HASKELL__ >= 800 {-# LANGUAGE UndecidableSuperClasses #-} #endif module Servant.OpenApi.Internal.TypeLevel.Every where -import           Data.Proxy-import           GHC.Exts                                (Constraint)+import Data.Proxy+import GHC.Exts (Constraint) -import           Servant.OpenApi.Internal.TypeLevel.TMap+import Servant.OpenApi.Internal.TypeLevel.TMap  -- $setup -- >>> :set -XDataKinds@@ -48,16 +46,18 @@ -- | 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 :: [* -> Constraint]) (x :: *) where+class EveryTF cs x => Every (cs :: [* -> Constraint]) (x :: *) -instance Every '[] x where-instance (c x, Every cs x) => Every (c ': cs) x where+instance Every '[] x+instance (Every cs x, c 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))

@@ -1,17 +1,17 @@-{-# LANGUAGE ConstraintKinds       #-}-{-# LANGUAGE DataKinds             #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE KindSignatures        #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PolyKinds             #-}-{-# LANGUAGE RankNTypes            #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE TypeOperators         #-}-{-# LANGUAGE UndecidableInstances  #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+ module Servant.OpenApi.Internal.TypeLevel.TMap where -import           Data.Proxy-import           GHC.Exts   (Constraint)+import Data.Proxy+import GHC.Exts (Constraint)  -- $setup -- >>> :set -XDataKinds@@ -32,6 +32,5 @@ instance TMap q '[] where   tmap _ _ _ = [] -instance (q x, TMap q xs) => TMap q (x ': xs) where+instance (TMap q xs, q x) => TMap q (x ': xs) where   tmap q f _ = f (Proxy :: Proxy x) : tmap q f (Proxy :: Proxy xs)-

@@ -5,9 +5,9 @@ -- 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

@@ -5,11 +5,10 @@ -- 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

@@ -1,37 +1,58 @@-{-# LANGUAGE CPP                #-}-{-# LANGUAGE DataKinds          #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric      #-}-{-# LANGUAGE OverloadedStrings  #-}-{-# LANGUAGE QuasiQuotes        #-}-{-# LANGUAGE TypeOperators      #-}-{-# LANGUAGE PackageImports     #-}-#if MIN_VERSION_servant(0,18,1)-{-# LANGUAGE TypeFamilies       #-}-#endif+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+ module Servant.OpenApiSpec where -import           Control.Lens-import           Data.Aeson                    (ToJSON (toJSON), Value, encode, genericToJSON)-import           Data.Aeson.QQ.Simple-import qualified Data.Aeson.Types              as JSON-import           Data.Char                     (toLower)-import           Data.Int                      (Int64)-import           Data.OpenApi-import           Data.Proxy-import           Data.Text                     (Text)-import           Data.Time-import           GHC.Generics-import           Servant.API-import           Servant.OpenApi-import           Servant.Test.ComprehensiveAPI (comprehensiveAPI)-import           Test.Hspec                    hiding (example)+import Control.Lens+import Data.Aeson (ToJSON (toJSON), Value (Array, Object), encode, genericToJSON)+import Data.Aeson.Key (Key)+import qualified Data.Aeson.Key as Key+import qualified Data.Aeson.KeyMap as KeyMap+import Data.Aeson.QQ.Simple+import qualified Data.Aeson.Types as JSON+import Data.Char (toLower)+import Data.Int (Int64)+import Data.OpenApi+import Data.Proxy+import Data.Text (Text)+import Data.Time+import GHC.Generics+import Servant.API+import Servant.Test.ComprehensiveAPI (comprehensiveAPI)+import Test.Hspec hiding (example) +import Servant.OpenApi++-- | The key the generated content maps use for @JSON@. Taken from servant+-- rather than hardcoded, because servant-0.20.4 dropped the @charset@ parameter+-- from its @Accept JSON@ instance and older versions still carry it.+-- <https://github.com/haskell-servant/servant/pull/1881>+jsonMediaType :: Key+jsonMediaType = Key.fromString (show (Servant.API.contentType (Proxy :: Proxy JSON)))++-- | Restate a golden document in terms of 'jsonMediaType'. The goldens below are+-- written as @application/json@, so this is a no-op unless the servant we are+-- built against spells the media type differently.+withJsonMediaType :: Value -> Value+withJsonMediaType (Object o) = Object (KeyMap.mapKeyVal rename withJsonMediaType o)+  where+    rename k+      | k == "application/json" = jsonMediaType+      | otherwise = k+withJsonMediaType (Array a) = Array (withJsonMediaType <$> a)+withJsonMediaType v = v+ checkAPI :: HasCallStack => HasOpenApi api => Proxy api -> Value -> IO () checkAPI proxy = checkOpenApi (toOpenApi proxy)  checkOpenApi :: HasCallStack => OpenApi -> Value -> IO ()-checkOpenApi swag js = encode (toJSON swag) `shouldBe` (encode js)+checkOpenApi swag js = encode (toJSON swag) `shouldBe` encode (withJsonMediaType js)  spec :: Spec spec = describe "HasOpenApi" $ do@@ -41,9 +62,7 @@   it "Comprehensive API" $ do     let _x = toOpenApi comprehensiveAPI     True `shouldBe` True -- type-level test-#if MIN_VERSION_servant(0,18,1)   it "UVerb API" $ checkOpenApi uverbOpenApi uverbAPI-#endif  main :: IO () main = hspec spec@@ -54,9 +73,10 @@  data Todo = Todo   { created :: UTCTime-  , title   :: String+  , title :: String   , summary :: Maybe String-  } deriving (Generic)+  }+  deriving (Generic)  instance ToJSON Todo instance ToSchema Todo@@ -67,7 +87,8 @@ type TodoAPI = "todo" :> Capture "id" TodoId :> Get '[JSON] Todo  todoAPI :: Value-todoAPI = [aesonQQ|+todoAPI =+  [aesonQQ| {   "openapi": "3.0.0",   "info": {@@ -110,7 +131,7 @@           },           "200": {             "content": {-              "application/json;charset=utf-8": {+              "application/json": {                 "schema": {                   "$ref": "#/components/schemas/Todo"                 }@@ -139,61 +160,69 @@ -- Hackage API -- ======================================================================= -type HackageAPI-    = HackageUserAPI- :<|> HackagePackagesAPI+type HackageAPI =+  HackageUserAPI+    :<|> HackagePackagesAPI  type HackageUserAPI =-      "users" :> Get '[JSON] [UserSummary]- :<|> "user"  :> Capture "username" Username :> Get '[JSON] UserDetailed+  "users" :> Get '[JSON] [UserSummary]+    :<|> "user" :> Capture "username" Username :> Get '[JSON] UserDetailed -type HackagePackagesAPI-    = "packages" :> Get '[JSON] [Package]+type HackagePackagesAPI =+  "packages" :> Get '[JSON] [Package]  type Username = Text  data UserSummary = UserSummary   { summaryUsername :: Username-  , summaryUserid   :: Int64  -- Word64 would make sense too-  } deriving (Eq, Show, Generic)+  , summaryUserid :: Int64 -- Word64 would make sense too+  }+  deriving (Eq, Generic, Show)  lowerCutPrefix :: String -> String -> String lowerCutPrefix s = map toLower . drop (length s)  instance ToJSON UserSummary where-  toJSON = genericToJSON JSON.defaultOptions { JSON.fieldLabelModifier = lowerCutPrefix "summary" }+  toJSON = genericToJSON JSON.defaultOptions{JSON.fieldLabelModifier = lowerCutPrefix "summary"}  instance ToSchema UserSummary where-  declareNamedSchema proxy = genericDeclareNamedSchema defaultSchemaOptions { fieldLabelModifier = lowerCutPrefix "summary" } proxy-    & mapped.schema.example ?~ toJSON UserSummary-         { summaryUsername = "JohnDoe"-         , summaryUserid   = 123 }+  declareNamedSchema proxy =+    genericDeclareNamedSchema defaultSchemaOptions{fieldLabelModifier = lowerCutPrefix "summary"} proxy+      & mapped . schema . example+        ?~ toJSON+          UserSummary+            { summaryUsername = "JohnDoe"+            , summaryUserid = 123+            }  type Group = Text  data UserDetailed = UserDetailed   { username :: Username-  , userid   :: Int64-  , groups   :: [Group]-  } deriving (Eq, Show, Generic)+  , userid :: Int64+  , groups :: [Group]+  }+  deriving (Eq, Generic, Show) instance ToSchema UserDetailed -newtype Package = Package { packageName :: Text }-  deriving (Eq, Show, Generic)+newtype Package = Package {packageName :: Text}+  deriving (Eq, Generic, Show) instance ToSchema Package  hackageOpenApiWithTags :: OpenApi-hackageOpenApiWithTags = toOpenApi (Proxy :: Proxy HackageAPI)-  & servers .~ ["https://hackage.haskell.org"]-  & applyTagsFor usersOps    ["users"    & description ?~ "Operations about user"]-  & applyTagsFor packagesOps ["packages" & description ?~ "Query packages"]+hackageOpenApiWithTags =+  toOpenApi (Proxy :: Proxy HackageAPI)+    & servers .~ ["https://hackage.haskell.org"]+    & applyTagsFor usersOps ["users" & description ?~ "Operations about user"]+    & applyTagsFor packagesOps ["packages" & description ?~ "Query packages"]   where     usersOps, packagesOps :: Traversal' OpenApi Operation-    usersOps    = subOperations (Proxy :: Proxy HackageUserAPI)     (Proxy :: Proxy HackageAPI)+    usersOps = subOperations (Proxy :: Proxy HackageUserAPI) (Proxy :: Proxy HackageAPI)     packagesOps = subOperations (Proxy :: Proxy HackagePackagesAPI) (Proxy :: Proxy HackageAPI)  hackageAPI :: Value-hackageAPI = [aesonQQ|+hackageAPI =+  [aesonQQ| {   "openapi": "3.0.0",   "servers": [@@ -273,7 +302,7 @@         "responses": {           "200": {             "content": {-              "application/json;charset=utf-8": {+              "application/json": {                 "schema": {                   "items": {                     "$ref": "#/components/schemas/UserSummary"@@ -295,7 +324,7 @@         "responses": {           "200": {             "content": {-              "application/json;charset=utf-8": {+              "application/json": {                 "schema": {                   "items": {                     "$ref": "#/components/schemas/Package"@@ -320,7 +349,7 @@           },           "200": {             "content": {-              "application/json;charset=utf-8": {+              "application/json": {                 "schema": {                   "$ref": "#/components/schemas/UserDetailed"                 }@@ -358,7 +387,6 @@ } |] - -- ======================================================================= -- Get/Post API (test for subOperations) -- =======================================================================@@ -366,14 +394,16 @@ type GetPostAPI = Get '[JSON] String :<|> Post '[JSON] String  getPostOpenApi :: OpenApi-getPostOpenApi = toOpenApi (Proxy :: Proxy GetPostAPI)-  & applyTagsFor getOps ["get" & description ?~ "GET operations"]+getPostOpenApi =+  toOpenApi (Proxy :: Proxy GetPostAPI)+    & applyTagsFor getOps ["get" & description ?~ "GET operations"]   where     getOps :: Traversal' OpenApi Operation     getOps = subOperations (Proxy :: Proxy (Get '[JSON] String)) (Proxy :: Proxy GetPostAPI)  getPostAPI :: Value-getPostAPI = [aesonQQ|+getPostAPI =+  [aesonQQ| {   "components": {},   "openapi": "3.0.0",@@ -387,7 +417,7 @@         "responses": {           "200": {             "content": {-              "application/json;charset=utf-8": {+              "application/json": {                 "schema": {                   "type": "string"                 }@@ -401,7 +431,7 @@         "responses": {           "200": {             "content": {-              "application/json;charset=utf-8": {+              "application/json": {                 "schema": {                   "type": "string"                 }@@ -429,10 +459,8 @@ -- UVerb API -- ======================================================================= -#if MIN_VERSION_servant(0,18,1)--data FisxUser = FisxUser {name :: String}-  deriving (Eq, Show, Generic)+newtype FisxUser = FisxUser {name :: String}+  deriving (Eq, Generic, Show)  instance ToSchema FisxUser @@ -440,18 +468,20 @@   type StatusOf FisxUser = 203  data ArianUser = ArianUser-  deriving (Eq, Show, Generic)+  deriving (Eq, Generic, Show)  instance ToSchema ArianUser -type UVerbAPI = "fisx" :> UVerb 'GET '[JSON] '[FisxUser, WithStatus 303 String]-           :<|> "arian" :> UVerb 'POST '[JSON] '[WithStatus 201 ArianUser]+type UVerbAPI =+  "fisx" :> UVerb 'GET '[JSON] '[FisxUser, WithStatus 303 String]+    :<|> "arian" :> UVerb 'POST '[JSON] '[WithStatus 201 ArianUser]  uverbOpenApi :: OpenApi uverbOpenApi = toOpenApi (Proxy :: Proxy UVerbAPI)  uverbAPI :: Value-uverbAPI = [aesonQQ|+uverbAPI =+  [aesonQQ| {   "openapi": "3.0.0",   "info": {@@ -485,7 +515,7 @@         "responses": {           "201": {             "content": {-              "application/json;charset=utf-8": {+              "application/json": {                 "schema": {                   "$ref": "#/components/schemas/ArianUser"                 }@@ -501,7 +531,7 @@         "responses": {           "303": {             "content": {-              "application/json;charset=utf-8": {+              "application/json": {                 "schema": {                   "type": "string"                 }@@ -511,7 +541,7 @@           },           "203": {             "content": {-              "application/json;charset=utf-8": {+              "application/json": {                 "schema": {                   "$ref": "#/components/schemas/FisxUser"                 }@@ -525,5 +555,3 @@   } } |]--#endif

@@ -1,12 +0,0 @@-module Main where--import Build_doctests (flags, pkgs, module_sources)-import Data.Foldable (traverse_)-import Test.DocTest--main :: IO ()-main = do-    traverse_ putStrLn args-    doctest args-  where-    args = flags ++ pkgs ++ module_sources