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