diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 ------- diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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). diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -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 diff --git a/example/server/Main.hs b/example/server/Main.hs --- a/example/server/Main.hs +++ b/example/server/Main.hs @@ -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 - diff --git a/example/src/Todo.hs b/example/src/Todo.hs --- a/example/src/Todo.hs +++ b/example/src/Todo.hs @@ -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 diff --git a/example/test/TodoSpec.hs b/example/test/TodoSpec.hs --- a/example/test/TodoSpec.hs +++ b/example/test/TodoSpec.hs @@ -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 diff --git a/servant-openapi3.cabal b/servant-openapi3.cabal --- a/servant-openapi3.cabal +++ b/servant-openapi3.cabal @@ -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 diff --git a/src/Servant/OpenApi.hs b/src/Servant/OpenApi.hs --- a/src/Servant/OpenApi.hs +++ b/src/Servant/OpenApi.hs @@ -15,36 +15,36 @@ -- Additional utilities can also take advantage of the resulting files, such as testing tools. -- -- For more information see . -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" -- } diff --git a/src/Servant/OpenApi/Internal.hs b/src/Servant/OpenApi/Internal.hs --- a/src/Servant/OpenApi/Internal.hs +++ b/src/Servant/OpenApi/Internal.hs @@ -1,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 diff --git a/src/Servant/OpenApi/Internal/Orphans.hs b/src/Servant/OpenApi/Internal/Orphans.hs --- a/src/Servant/OpenApi/Internal/Orphans.hs +++ b/src/Servant/OpenApi/Internal/Orphans.hs @@ -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]) diff --git a/src/Servant/OpenApi/Internal/Test.hs b/src/Servant/OpenApi/Internal/Test.hs --- a/src/Servant/OpenApi/Internal/Test.hs +++ b/src/Servant/OpenApi/Internal/Test.hs @@ -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 @@ -- -- 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} diff --git a/src/Servant/OpenApi/Internal/TypeLevel.hs b/src/Servant/OpenApi/Internal/TypeLevel.hs --- a/src/Servant/OpenApi/Internal/TypeLevel.hs +++ b/src/Servant/OpenApi/Internal/TypeLevel.hs @@ -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 diff --git a/src/Servant/OpenApi/Internal/TypeLevel/API.hs b/src/Servant/OpenApi/Internal/TypeLevel/API.hs --- a/src/Servant/OpenApi/Internal/TypeLevel/API.hs +++ b/src/Servant/OpenApi/Internal/TypeLevel/API.hs @@ -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 diff --git a/src/Servant/OpenApi/Internal/TypeLevel/Every.hs b/src/Servant/OpenApi/Internal/TypeLevel/Every.hs --- a/src/Servant/OpenApi/Internal/TypeLevel/Every.hs +++ b/src/Servant/OpenApi/Internal/TypeLevel/Every.hs @@ -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)) diff --git a/src/Servant/OpenApi/Internal/TypeLevel/TMap.hs b/src/Servant/OpenApi/Internal/TypeLevel/TMap.hs --- a/src/Servant/OpenApi/Internal/TypeLevel/TMap.hs +++ b/src/Servant/OpenApi/Internal/TypeLevel/TMap.hs @@ -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) - diff --git a/src/Servant/OpenApi/Test.hs b/src/Servant/OpenApi/Test.hs --- a/src/Servant/OpenApi/Test.hs +++ b/src/Servant/OpenApi/Test.hs @@ -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 diff --git a/src/Servant/OpenApi/TypeLevel.hs b/src/Servant/OpenApi/TypeLevel.hs --- a/src/Servant/OpenApi/TypeLevel.hs +++ b/src/Servant/OpenApi/TypeLevel.hs @@ -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 diff --git a/test/Servant/OpenApiSpec.hs b/test/Servant/OpenApiSpec.hs --- a/test/Servant/OpenApiSpec.hs +++ b/test/Servant/OpenApiSpec.hs @@ -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. +-- +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 diff --git a/test/doctests.hs b/test/doctests.hs deleted file mode 100644 --- a/test/doctests.hs +++ /dev/null @@ -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