servant-openapi-hs (empty) → 4.0.0
raw patch · 17 files changed
+2627/−0 lines, 17 filesdep +QuickCheckdep +aesondep +aeson-pretty
Dependencies added: QuickCheck, aeson, aeson-pretty, base, base-compat, bytestring, hspec, http-media, insert-ordered-containers, lens, lens-aeson, openapi-hs, servant, servant-openapi-hs, singleton-bool, template-haskell, text, time, unordered-containers, utf8-string, vector
Files
- CHANGELOG.md +167/−0
- LICENSE +28/−0
- README.md +135/−0
- app/GenOpenApi.hs +91/−0
- servant-openapi-hs.cabal +113/−0
- src/Servant/OpenApi.hs +529/−0
- src/Servant/OpenApi/Internal.hs +473/−0
- src/Servant/OpenApi/Internal/Orphans.hs +19/−0
- src/Servant/OpenApi/Internal/Test.hs +206/−0
- src/Servant/OpenApi/Internal/TypeLevel.hs +11/−0
- src/Servant/OpenApi/Internal/TypeLevel/API.hs +97/−0
- src/Servant/OpenApi/Internal/TypeLevel/Every.hs +65/−0
- src/Servant/OpenApi/Internal/TypeLevel/TMap.hs +39/−0
- src/Servant/OpenApi/Test.hs +13/−0
- src/Servant/OpenApi/TypeLevel.hs +15/−0
- test/Servant/OpenApiSpec.hs +625/−0
- test/Spec.hs +1/−0
+ CHANGELOG.md view
@@ -0,0 +1,167 @@+4.0.0+-----++* Renamed to `servant-openapi-hs`, a fork of+ [`biocad/servant-openapi3`](https://github.com/biocad/servant-openapi3)+ targeting OpenAPI 3.1.+* Depend on [`openapi-hs`](https://github.com/shinzui/openapi-hs) instead of+ `openapi3`. The `Data.OpenApi.*` and `Servant.OpenApi.*` namespaces are+ unchanged. Generated documents now report `"openapi": "3.1.0"`.+* Builds and passes its test suite against `openapi-hs`. The port required only+ three library edits for OpenAPI-3.1 model changes — `type_` now takes+ `OpenApiTypeSingle OpenApiArray` (the type-array model), and the `OpenApi` /+ `PathItem` record combiners set the new 3.1 fields `webhooks` and `$ref`+ (`_pathItemRef`).+* Validate generated documents in two in-process layers beyond fixture+ equality: a round-trip decode through `openapi-hs`'s version-enforcing+ `FromJSON OpenApi`, and `validateEveryToJSON` example-conformance.+* Add a `gen-openapi` executable that prints a representative API's OpenAPI 3.1+ document to stdout; its output lints with 0 errors under+ [`vacuum`](https://quobix.com/vacuum/).+* Require GHC 9.12.4 / 9.14.1; modernize to `cabal-version: 3.0`,+ `build-type: Simple`, and `default-language: GHC2024`.+* Drop the `cabal-doctest`-based `doctests` test-suite (use `cabal-docspec` to+ run doctests instead).++---++Earlier history of the upstream `servant-openapi3` package:++1.1.8+-------++* Support `servant-0.17`++1.1.7.1+-------++* Support `swagger2-2.4`++1.1.7+-----++* Support servant-0.15+ - support for 'Stream' and 'StreamBody' combinators+ - orphan 'ToSchema (SourceT m a)' instance+* Fix BodyTypes to work with generalized ReqBody' + [#88](https://github.com/haskell-servant/servant-swagger/pull/88)++1.1.6+-----++* Fixes:+ * `validateEveryToJSON` now prints validation errors++* Notes:+ * GHC-8.6 compatible release++1.1.5+-----++* Notes:+ * `servant-0.13` compatible release+ * Drops compatibility with previous `servant` versions.++1.1.4+-----++* Notes:+ * `servant-0.12` compatible release++1.1.3.1+---++* Notes:+ * GHC-8.2 compatible release++1.1.3+---++* Notes:+ * `servant-0.11` compatible release++1.1.2.1+---++* Notes:+ * `servant-0.10` compatible release++1.1.2+---++* Minor fixes:+ * Support for aeson-1, insert-ordered-containers-0.2+ * CaptureAll instance++1.1.1+---++* Minor fixes:+ * Fix `unused-imports` and `unused-foralls` warnings;+ * Fix tests to match `swagger2-2.1.1` (add `example` property for `UTCTime` schema).++1.1+---++* Breaking changes:+ * Requires `swagger2 >= 2.1`+ * Requires `servant >= 0.5`++* Notes:+ * GHC-8.0 compatible release++1.0.3+---++* Fixes:+ * Improve compile-time performance of `BodyTypes` even further (see [18e0d95](https://github.com/haskell-servant/servant-swagger/commit/18e0d95ef6fe9076dd9621cb515d8d1a189f71d3))!++1.0.2+---++* Minor changes:+ * Add GHC 7.8 support (see [#26](https://github.com/haskell-servant/servant-swagger/pull/26)).++* Fixes:+ * Improve compile-time performance of `BodyTypes` (see [#25](https://github.com/haskell-servant/servant-swagger/issues/25)).++1.0.1+---++* Fixes:+ * Stop using `Data.Swagger.Internal`;+ * Documentation fixes (links to examples).++1.0+---++* Major changes (see [#24](https://github.com/haskell-servant/servant-swagger/pull/24)):+ * Switch to `swagger2-2.*`;+ * Add automatic `ToJSON`/`ToSchema` validation tests;+ * Add great documentation;+ * Export some type-level functions for servant API.++* Minor changes:+ * Rework Todo API example;+ * Stop exporting `ToResponseHeader`, `AllAccept` and `AllToResponseHeader` (see [bd50db4](https://github.com/haskell-servant/servant-swagger/commit/bd50db48ca6a106e4366560ded70932d409de1e2));+ * Change maintainer, update authors/copyrights (see [1a62681](https://github.com/haskell-servant/servant-swagger/commit/1a6268101dc826a92c42e832e402e251c0d32147));+ * Include changelog and example files into `extra-source-files`.++0.1.2+---++* Fixes:+ * Fix default spec for `ReqBody` param to be required (see [#22](https://github.com/haskell-servant/servant-swagger/issues/22));+ * Set version bounds for `swagger2`.++0.1.1+---++* Fixes:+ * Fix `subOperations` to filter endpoints also by method (see [#18](https://github.com/haskell-servant/servant-swagger/issues/18));+ * Fix response schema in `ToSwagger` instance for `Header` (see [b59e557](https://github.com/haskell-servant/servant-swagger/commit/b59e557a05bc2669332c52b397879e7598747b82)).++0.1+---+* Major changes+ * Use `swagger2` for data model (see [#9](https://github.com/dmjio/servant-swagger/pull/9)); this changes almost everything.
+ LICENSE view
@@ -0,0 +1,28 @@+Copyright (c) 2015-2016, Servant contributors+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++* Neither the name of servant-swagger nor the names of its+ contributors may be used to endorse or promote products derived from+ this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+
+ README.md view
@@ -0,0 +1,135 @@+# servant-openapi-hs++[](/LICENSE)++Generate an [OpenAPI 3.1](https://spec.openapis.org/oas/v3.1.0) specification for+your [Servant](https://github.com/haskell-servant/servant) API, and partially+test that the API conforms to its specification.++> **Fork notice.** `servant-openapi-hs` is a fork of+> [`biocad/servant-openapi3`](https://github.com/biocad/servant-openapi3), which+> targets OpenAPI 3.0. This fork retargets it at OpenAPI 3.1 by building on+> [`openapi-hs`](https://github.com/shinzui/openapi-hs) (a fork of+> [`biocad/openapi3`](https://github.com/biocad/openapi3)) instead of `openapi3`.+> The Haskell module namespace is unchanged (`Servant.OpenApi.*`), and because+> `openapi-hs` keeps the `Data.OpenApi.*` namespace, migrating is usually just a+> dependency-name swap: `servant-openapi3` → `servant-openapi-hs` and `openapi3` →+> `openapi-hs`. The fork keeps the upstream [BSD-3-Clause license](#license) and+> copyright.++---++## Motivation++OpenAPI is a language-agnostic format for describing and documenting HTTP APIs.+This package derives an OpenAPI 3.1 specification directly from a Servant API+type, so the description stays in sync with the server, and provides combinators+to test that handlers conform to the generated schema.++A generated specification can then be used to++- display interactive documentation in any OpenAPI 3.1 viewer;+- generate clients and servers in many languages with [OpenAPI Generator](https://openapi-generator.tech/);+- and many other things across the OpenAPI tooling ecosystem.++## 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.++Add `servant-openapi-hs` to your package's `build-depends`:++```cabal+build-depends: servant-openapi-hs+```++Its OpenAPI 3.1 data model comes from+[`openapi-hs`](https://hackage.haskell.org/package/openapi-hs), which is pulled+in automatically as a transitive dependency.++Import the umbrella module:++```haskell+import Servant.OpenApi+```++Requires GHC **9.12.4** or **9.14.1**.++<a id="building-from-source"></a>+> **Building from source.** Until the first Hackage release, depend on this+> repository directly by adding a `source-repository-package` stanza for+> `servant-openapi-hs` to your `cabal.project`:+>+> ```cabal+> source-repository-package+> type: git+> location: https://github.com/shinzui/servant-openapi-hs.git+> tag: <commit-sha>+> ```+>+> Its `openapi-hs` dependency resolves from Hackage automatically.++## Usage++Derive an OpenAPI 3.1 document from a Servant API type with `toOpenApi`:++```haskell+import Data.Aeson (encode)+import Data.OpenApi (OpenApi)+import Data.Proxy (Proxy (..))+import Servant.OpenApi (toOpenApi)++spec :: OpenApi+spec = toOpenApi (Proxy :: Proxy MyApi)+-- encode spec ==> {"openapi":"3.1.0", ...}+```++A runnable example lives in [`app/GenOpenApi.hs`](app/GenOpenApi.hs), built as+the `gen-openapi` executable, which prints a complete Todo-CRUD document:++```bash+cabal run gen-openapi > openapi.json+```++The full API surface is unchanged from upstream; see the+[Haddock documentation](https://hackage.haskell.org/package/servant-openapi-hs).+Generated specifications can be explored interactively in any OpenAPI 3.1+viewer or editor.++## Validation++Generated documents are checked at three levels:++1. **Round-trip** — the test suite decodes each generated document back through+ `openapi-hs`'s `FromJSON OpenApi`, which rejects any `openapi` version outside+ `3.1.0 … 3.1.1`, then compares the result for semantic equality.+2. **Example-conformance** — `Servant.OpenApi.Test.validateEveryToJSON` checks+ that random values of each response type validate against the generated+ schema.+3. **Authoritative conformance** — the `gen-openapi` output lints cleanly under+ [`vacuum`](https://quobix.com/vacuum/):++ ```bash+ cabal run gen-openapi > openapi.json+ nix run nixpkgs#vacuum-go -- lint -d openapi.json+ ```++## Contributing++Bug reports, fixes, documentation improvements, and other contributions are+welcome. Please open an issue or pull request on the+[GitHub issue tracker](https://github.com/shinzui/servant-openapi-hs/issues).++## License++`servant-openapi-hs` retains the original **BSD-3-Clause** license of the upstream+[`servant-openapi3`](https://github.com/biocad/servant-openapi3) project,+including its copyright. See the [`LICENSE`](/LICENSE) file for the full text;+this fork's changes are released under the same terms.++---++*Originally derived from work by the Servant contributors (David Johnson,+Nickolay Kudasov, Maxim Koltsov, and others).*
+ app/GenOpenApi.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Emit a representative API's OpenAPI 3.1 document as JSON to stdout.+--+-- Used to feed Layer-3 (external, authoritative) validation:+--+-- > 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.+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+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++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++-- | 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++main :: IO ()+main = BL.putStrLn (encode spec)
+ servant-openapi-hs.cabal view
@@ -0,0 +1,113 @@+cabal-version: 3.0+name: servant-openapi-hs+version: 4.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+ generates an OpenAPI 3.1 specification from a Servant API and can partially+ test whether an API conforms with its specification.+ .+ A generated specification can be used for many things, such as+ .+ * displaying interactive documentation in any OpenAPI 3.1 viewer;+ .+ * generating clients and servers in many languages using [OpenAPI Generator](https://openapi-generator.tech/);+ .+ * and many others across the OpenAPI tooling ecosystem.+ .+ 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++extra-doc-files:+ README.md+ , CHANGELOG.md++source-repository head+ type: git+ location: https://github.com/shinzui/servant-openapi-hs.git++library+ 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+ Servant.OpenApi.Internal.TypeLevel+ 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++ , hspec >=2.6.0 && <2.12+ , QuickCheck >=2.9 && <2.17+ 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+ default-language: GHC2024++test-suite spec+ ghc-options: -Wall+ 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+ , 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+ other-modules:+ Servant.OpenApiSpec+ default-language: GHC2024
+ src/Servant/OpenApi.hs view
@@ -0,0 +1,529 @@+-- |+-- Module: Servant.OpenApi+-- License: BSD3+-- Maintainer: Nadeem Bitar <nadeem@gmail.com>+-- Stability: experimental+--+-- This module provides means to generate and manipulate+-- OpenApi specification for servant APIs.+--+-- OpenApi is a project used to describe and document RESTful APIs.+--+-- The OpenApi specification defines a set of files required to describe such an API.+-- These files can then be used by the OpenApi-UI project to display the API+-- and OpenApi-Codegen to generate clients in various languages.+-- Additional utilities can also take advantage of the resulting files, such as testing tools.+--+-- For more information see the <https://spec.openapis.org/oas/v3.1.0 OpenAPI 3.1 specification>.+module Servant.OpenApi (+ -- * How to use this library+ -- $howto++ -- ** Generate @OpenApi@+ -- $generate++ -- ** Annotate+ -- $annotate++ -- ** Test+ -- $test++ -- ** Serve+ -- $serve++ -- * @'HasOpenApi'@ class+ HasOpenApi(..),++ -- * Manipulation+ subOperations,++ -- * Testing+ validateEveryToJSON,+ validateEveryToJSONWithPatternChecker,+) where++import Servant.OpenApi.Internal+import Servant.OpenApi.Test+import Servant.OpenApi.Internal.Orphans ()++-- $setup+-- >>> import Control.Applicative+-- >>> import Control.Lens+-- >>> import Data.Aeson+-- >>> import Data.OpenApi+-- >>> import Data.Typeable+-- >>> import GHC.Generics+-- >>> import Servant.API+-- >>> import Test.Hspec+-- >>> import Test.QuickCheck+-- >>> 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)+-- >>> instance ToJSON User+-- >>> instance ToSchema User+-- >>> instance ToSchema UserId+-- >>> instance ToParamSchema UserId+-- >>> type GetUsers = Get '[JSON] [User]+-- >>> type GetUser = Capture "user_id" UserId :> Get '[JSON] User+-- >>> type PostUser = ReqBody '[JSON] User :> Post '[JSON] UserId+-- >>> type UserAPI = GetUsers :<|> GetUser :<|> PostUser++-- $howto+--+-- This section explains how to use this library to generate OpenApi specification,+-- modify it and run automatic tests for a servant API.+--+-- 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)+-- >>> instance ToJSON User+-- >>> instance ToSchema User+-- >>> instance ToSchema UserId+-- >>> instance ToParamSchema UserId+-- >>> type GetUsers = Get '[JSON] [User]+-- >>> type GetUser = Capture "user_id" UserId :> Get '[JSON] User+-- >>> type PostUser = ReqBody '[JSON] User :> Post '[JSON] UserId+-- >>> type UserAPI = GetUsers :<|> GetUser :<|> PostUser+--+-- Here we define a user API with three endpoints. @GetUsers@ endpoint returns a list of all users.+-- @GetUser@ returns a user given his\/her ID. @PostUser@ creates a new user and returns his\/her ID.++-- $generate+-- In order to generate @OpenApi@ specification for a servant API, just use @'toOpenApi'@:+--+-- >>> BSL8.putStrLn $ encodePretty $ toOpenApi (Proxy :: Proxy UserAPI)+-- {+-- "components": {+-- "schemas": {+-- "User": {+-- "properties": {+-- "age": {+-- "maximum": 9223372036854775807,+-- "minimum": -9223372036854775808,+-- "type": "integer"+-- },+-- "name": {+-- "type": "string"+-- }+-- },+-- "required": [+-- "name",+-- "age"+-- ],+-- "type": "object"+-- },+-- "UserId": {+-- "type": "integer"+-- }+-- }+-- },+-- "info": {+-- "title": "",+-- "version": ""+-- },+-- "openapi": "3.0.0",+-- "paths": {+-- "/": {+-- "get": {+-- "responses": {+-- "200": {+-- "content": {+-- "application/json;charset=utf-8": {+-- "schema": {+-- "items": {+-- "$ref": "#/components/schemas/User"+-- },+-- "type": "array"+-- }+-- }+-- },+-- "description": ""+-- }+-- }+-- },+-- "post": {+-- "requestBody": {+-- "content": {+-- "application/json;charset=utf-8": {+-- "schema": {+-- "$ref": "#/components/schemas/User"+-- }+-- }+-- }+-- },+-- "responses": {+-- "200": {+-- "content": {+-- "application/json;charset=utf-8": {+-- "schema": {+-- "$ref": "#/components/schemas/UserId"+-- }+-- }+-- },+-- "description": ""+-- },+-- "400": {+-- "description": "Invalid `body`"+-- }+-- }+-- }+-- },+-- "/{user_id}": {+-- "get": {+-- "parameters": [+-- {+-- "in": "path",+-- "name": "user_id",+-- "required": true,+-- "schema": {+-- "type": "integer"+-- }+-- }+-- ],+-- "responses": {+-- "200": {+-- "content": {+-- "application/json;charset=utf-8": {+-- "schema": {+-- "$ref": "#/components/schemas/User"+-- }+-- }+-- },+-- "description": ""+-- },+-- "404": {+-- "description": "`user_id` not found"+-- }+-- }+-- }+-- }+-- }+-- }+--+-- By default @'toOpenApi'@ will generate specification for all API routes, parameters, headers, responses and data schemas.+--+-- For some parameters it will also add 400 and/or 404 responses with a description mentioning parameter name.+--+-- Data schemas come from @ToParamSchema@ and @ToSchema@ classes.++-- $annotate+-- While initially generated @OpenApi@ looks good, it lacks some information it can't get from a servant API.+--+-- We can add this information using field lenses from @"Data.OpenApi"@:+--+-- >>> :{+-- BSL8.putStrLn $ encodePretty $ toOpenApi (Proxy :: Proxy UserAPI)+-- & info.title .~ "User API"+-- & info.version .~ "1.0"+-- & info.description ?~ "This is an API for the Users service"+-- & info.license ?~ "MIT"+-- & servers .~ ["https://example.com"]+-- :}+-- {+-- "components": {+-- "schemas": {+-- "User": {+-- "properties": {+-- "age": {+-- "maximum": 9223372036854775807,+-- "minimum": -9223372036854775808,+-- "type": "integer"+-- },+-- "name": {+-- "type": "string"+-- }+-- },+-- "required": [+-- "name",+-- "age"+-- ],+-- "type": "object"+-- },+-- "UserId": {+-- "type": "integer"+-- }+-- }+-- },+-- "info": {+-- "description": "This is an API for the Users service",+-- "license": {+-- "name": "MIT"+-- },+-- "title": "User API",+-- "version": "1.0"+-- },+-- "openapi": "3.0.0",+-- "paths": {+-- "/": {+-- "get": {+-- "responses": {+-- "200": {+-- "content": {+-- "application/json;charset=utf-8": {+-- "schema": {+-- "items": {+-- "$ref": "#/components/schemas/User"+-- },+-- "type": "array"+-- }+-- }+-- },+-- "description": ""+-- }+-- }+-- },+-- "post": {+-- "requestBody": {+-- "content": {+-- "application/json;charset=utf-8": {+-- "schema": {+-- "$ref": "#/components/schemas/User"+-- }+-- }+-- }+-- },+-- "responses": {+-- "200": {+-- "content": {+-- "application/json;charset=utf-8": {+-- "schema": {+-- "$ref": "#/components/schemas/UserId"+-- }+-- }+-- },+-- "description": ""+-- },+-- "400": {+-- "description": "Invalid `body`"+-- }+-- }+-- }+-- },+-- "/{user_id}": {+-- "get": {+-- "parameters": [+-- {+-- "in": "path",+-- "name": "user_id",+-- "required": true,+-- "schema": {+-- "type": "integer"+-- }+-- }+-- ],+-- "responses": {+-- "200": {+-- "content": {+-- "application/json;charset=utf-8": {+-- "schema": {+-- "$ref": "#/components/schemas/User"+-- }+-- }+-- },+-- "description": ""+-- },+-- "404": {+-- "description": "`user_id` not found"+-- }+-- }+-- }+-- }+-- },+-- "servers": [+-- {+-- "url": "https://example.com"+-- }+-- ]+-- }+--+-- It is also useful to annotate or modify certain endpoints.+-- @'subOperations'@ provides a convenient way to zoom into a part of an API.+--+-- @'subOperations' sub api@ traverses all operations of the @api@ which are also present in @sub@.+-- Furthermore, @sub@ is required to be an exact sub API of @api. Otherwise it will not typecheck.+--+-- @"Data.OpenApi.Operation"@ provides some useful helpers that can be used with @'subOperations'@.+-- One example is applying tags to certain endpoints:+--+-- >>> let getOps = subOperations (Proxy :: Proxy (GetUsers :<|> GetUser)) (Proxy :: Proxy UserAPI)+-- >>> let postOps = subOperations (Proxy :: Proxy PostUser) (Proxy :: Proxy UserAPI)+-- >>> :{+-- BSL8.putStrLn $ encodePretty $ toOpenApi (Proxy :: Proxy UserAPI)+-- & applyTagsFor getOps ["get" & description ?~ "GET operations"]+-- & applyTagsFor postOps ["post" & description ?~ "POST operations"]+-- :}+-- {+-- "components": {+-- "schemas": {+-- "User": {+-- "properties": {+-- "age": {+-- "maximum": 9223372036854775807,+-- "minimum": -9223372036854775808,+-- "type": "integer"+-- },+-- "name": {+-- "type": "string"+-- }+-- },+-- "required": [+-- "name",+-- "age"+-- ],+-- "type": "object"+-- },+-- "UserId": {+-- "type": "integer"+-- }+-- }+-- },+-- "info": {+-- "title": "",+-- "version": ""+-- },+-- "openapi": "3.0.0",+-- "paths": {+-- "/": {+-- "get": {+-- "responses": {+-- "200": {+-- "content": {+-- "application/json;charset=utf-8": {+-- "schema": {+-- "items": {+-- "$ref": "#/components/schemas/User"+-- },+-- "type": "array"+-- }+-- }+-- },+-- "description": ""+-- }+-- },+-- "tags": [+-- "get"+-- ]+-- },+-- "post": {+-- "requestBody": {+-- "content": {+-- "application/json;charset=utf-8": {+-- "schema": {+-- "$ref": "#/components/schemas/User"+-- }+-- }+-- }+-- },+-- "responses": {+-- "200": {+-- "content": {+-- "application/json;charset=utf-8": {+-- "schema": {+-- "$ref": "#/components/schemas/UserId"+-- }+-- }+-- },+-- "description": ""+-- },+-- "400": {+-- "description": "Invalid `body`"+-- }+-- },+-- "tags": [+-- "post"+-- ]+-- }+-- },+-- "/{user_id}": {+-- "get": {+-- "parameters": [+-- {+-- "in": "path",+-- "name": "user_id",+-- "required": true,+-- "schema": {+-- "type": "integer"+-- }+-- }+-- ],+-- "responses": {+-- "200": {+-- "content": {+-- "application/json;charset=utf-8": {+-- "schema": {+-- "$ref": "#/components/schemas/User"+-- }+-- }+-- },+-- "description": ""+-- },+-- "404": {+-- "description": "`user_id` not found"+-- }+-- },+-- "tags": [+-- "get"+-- ]+-- }+-- }+-- },+-- "tags": [+-- {+-- "description": "GET operations",+-- "name": "get"+-- },+-- {+-- "description": "POST operations",+-- "name": "post"+-- }+-- ]+-- }+--+-- This applies @\"get\"@ tag to the @GET@ endpoints and @\"post\"@ tag to the @POST@ endpoint of the User API.++-- $test+-- Automatic generation of data schemas uses @ToSchema@ instances for the types+-- used in a servant API. But to encode/decode actual data servant uses different classes.+-- For instance in @UserAPI@ @User@ is always encoded/decoded using @ToJSON@ and @FromJSON@ instances.+--+-- To be sure your Haskell server/client handles data properly you need to check+-- that @ToJSON@ instance always generates values that satisfy schema produced+-- by @ToSchema@ instance.+--+-- With @'validateEveryToJSON'@ it is possible to test all those instances automatically,+-- without having to write down every type:+--+-- >>> instance Arbitrary User where arbitrary = User <$> arbitrary <*> arbitrary+-- >>> instance Arbitrary UserId where arbitrary = UserId <$> arbitrary+-- >>> hspec $ validateEveryToJSON (Proxy :: Proxy UserAPI)+-- <BLANKLINE>+-- [User]...+-- ...+-- User...+-- ...+-- UserId...+-- ...+-- Finished in ... seconds+-- ...3 examples, 0 failures...+--+-- Although servant is great, chances are that your API clients don't use Haskell.+-- In many cases @openapi.json@ serves as a specification, not a Haskell type.+--+-- In this cases it is a good idea to store generated and annotated @OpenApi@ in an @openapi.json@ file+-- under a version control system (such as Git, Subversion, Mercurial, etc.).+--+-- It is also recommended to version API based on changes to the @openapi.json@ rather than changes+-- to the Haskell API.++-- $serve+-- If you're implementing a server for an API, you might also want to serve its @OpenApi@ specification.+--+-- See <example/src/Todo.hs Todo.hs> for an example of a server.
+ src/Servant/OpenApi/Internal.hs view
@@ -0,0 +1,473 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# 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++#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.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++-- | Generate a OpenApi specification for a servant API.+--+-- To generate OpenApi specification, your data types need+-- @'ToParamSchema'@ and/or @'ToSchema'@ instances.+--+-- @'ToParamSchema'@ is used for @'Capture'@, @'QueryParam'@ and @t'Header'@.+-- @'ToSchema'@ is used for @'ReqBody'@ and response data types.+--+-- You can easily derive those instances via @Generic@.+-- For more information, refer to+-- <https://hackage.haskell.org/package/openapi-hs/docs/Data-OpenApi.html openapi-hs documentation>.+--+-- Example:+--+-- @+-- newtype Username = Username String deriving (Generic, ToText)+--+-- instance ToParamSchema Username+--+-- data User = User+-- { username :: Username+-- , fullname :: String+-- } deriving (Generic)+--+-- instance ToJSON User+-- instance ToSchema User+--+-- type MyAPI = QueryParam "username" Username :> Get '[JSON] User+--+-- myOpenApi :: OpenApi+-- myOpenApi = toOpenApi (Proxy :: Proxy MyAPI)+-- @+class HasOpenApi api where+ -- | Generate a OpenApi specification for a servant API.+ toOpenApi :: Proxy api -> OpenApi++instance HasOpenApi Raw where+ toOpenApi _ = mempty & paths . at "/" ?~ mempty++instance HasOpenApi EmptyAPI where+ toOpenApi _ = mempty++-- | 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 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+ 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++-- | 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)))+ where+ method = openApiMethod (Proxy :: Proxy method)+ code = fromIntegral (natVal (Proxy :: Proxy status))+ responseContentTypes = allContentType (Proxy :: Proxy cs)+ 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))+ where+ 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 :)++-- | Add RequestBody to every operations in the spec.+addRequestBody :: RequestBody -> OpenApi -> OpenApi+addRequestBody rb = allOperations . requestBody ?~ Inline rb++-- | Format given text as inline code in Markdown.+markdownCode :: Text -> Text+markdownCode s = "`" <> s <> "`"++addDefaultResponse404 :: ParamName -> OpenApi -> OpenApi+addDefaultResponse404 pname = setResponseWith (\old _new -> alter404 old) 404 (return response404)+ where+ sname = markdownCode pname+ description404 = sname <> " not found"+ alter404 = description %~ ((sname <> " or ") <>)+ response404 = mempty & description .~ description404++addDefaultResponse400 :: ParamName -> OpenApi -> OpenApi+addDefaultResponse400 pname = setResponseWith (\old _new -> alter400 old) 400 (return response400)+ where+ sname = markdownCode pname+ description400 = "Invalid " <> sname+ alter400 = description %~ (<> (" or " <> sname))+ response400 = mempty & description .~ description400++-- | Methods, available for OpenApi.+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 'OPTIONS where openApiMethod _ = options+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))+ where+ toOpenApi _ =+ toOpenApi (Proxy :: Proxy (Verb method (StatusOf a) cs a))+ `combineOpenApi` toOpenApi (Proxy :: Proxy (UVerb method cs as))+ where+ -- The derived 'Semigroup' on 'OpenApi'/'PathItem' is left-biased and would+ -- drop one of a UVerb member's responses sharing a path and method, so the+ -- two documents are merged field-by-field instead.+ combinePathItem :: PathItem -> PathItem -> PathItem+ combinePathItem s t = PathItem+ { _pathItemRef = _pathItemRef s <|> _pathItemRef t+ , _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+ }++ combineOpenApi :: OpenApi -> OpenApi -> OpenApi+ combineOpenApi 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)+ , _openApiWebhooks = _openApiWebhooks s <> _openApiWebhooks 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+ declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a)+#endif++instance {-# OVERLAPPABLE #-} (ToSchema a, AllAccept cs, KnownNat status, OpenApiMethod method) => 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+ 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+ toOpenApi = mkEndpoint "/"++-- ATTENTION: do not remove this instance!+-- A similar instance above will always use the more general+-- polymorphic -- HasOpenApi instance and will result in a type error+-- since t'NoContent' does not have a 'ToSchema' instance.+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+ toOpenApi = mkEndpointNoContent "/"++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+ toOpenApi _ = toOpenApi (Proxy :: Proxy sub)++-- | @'IsSecure'@ combinator does not change our specification at all.+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+ toOpenApi _ = toOpenApi (Proxy :: Proxy sub)++-- | @t'HttpVersion'@ combinator does not change our specification at all.+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+ toOpenApi _ = toOpenApi (Proxy :: Proxy sub)+#endif++-- | @'WithNamedContext'@ combinator does not change our specification at all.+instance (HasOpenApi sub) => HasOpenApi (WithNamedContext x c sub) where+ toOpenApi _ = toOpenApi (Proxy :: Proxy sub)++instance (KnownSymbol sym, HasOpenApi sub) => 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+ where+ pname = symbolVal (Proxy :: Proxy sym)+ tname = Text.pack pname+ 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))++-- | 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))) <>)++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 (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+ where+ tname = Text.pack (symbolVal (Proxy :: Proxy sym))+ 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+ 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+ 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))++instance (KnownSymbol sym, HasOpenApi sub) => 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)++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 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))++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)+ where+ tname = "body"+ 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)]++-- | 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)+ where+ tname = "body"+ 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)]++#if MIN_VERSION_servant(0,18,2)+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+ toOpenApi _ = toOpenApi (Proxy :: Proxy (ToServantApi sub))+#endif++-- =======================================================================+-- Below are the definitions that should be in Servant.API.ContentTypes+-- =======================================================================++class AllAccept cs where+ allContentType :: Proxy cs -> [MediaType]++instance AllAccept '[] where+ allContentType _ = []++instance (Accept c, AllAccept cs) => AllAccept (c ': cs) where+ allContentType _ = contentType (Proxy :: Proxy c) : allContentType (Proxy :: Proxy cs)++class ToResponseHeader h where+ toResponseHeader :: Proxy h -> (HeaderName, OpenApi.Header)++instance (KnownSymbol sym, ToParamSchema a) => ToResponseHeader (Header sym a) where+ toResponseHeader _ = (hname, mempty & schema ?~ hschema)+ where+ hname = Text.pack (symbolVal (Proxy :: Proxy sym))+ hschema = Inline $ toParamSchema (Proxy :: Proxy a)++class AllToResponseHeader hs where+ toAllResponseHeaders :: Proxy hs -> InsOrdHashMap HeaderName OpenApi.Header++instance AllToResponseHeader '[] where+ toAllResponseHeaders _ = mempty++instance (ToResponseHeader h, AllToResponseHeader hs) => AllToResponseHeader (h ': hs) where+ toAllResponseHeaders _ = InsOrdHashMap.insert headerName headerBS hdrs+ where+ (headerName, headerBS) = toResponseHeader (Proxy :: Proxy h)+ hdrs = toAllResponseHeaders (Proxy :: Proxy hs)++instance AllToResponseHeader hs => AllToResponseHeader (HList hs) where+ toAllResponseHeaders _ = toAllResponseHeaders (Proxy :: Proxy hs)
+ src/Servant/OpenApi/Internal/Orphans.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}++{-# 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 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])
+ src/Servant/OpenApi/Internal/Test.hs view
@@ -0,0 +1,206 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# 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++-- $setup+-- >>> import Control.Applicative+-- >>> import GHC.Generics+-- >>> import Test.QuickCheck+-- >>> :set -XDeriveGeneric+-- >>> :set -XGeneralizedNewtypeDeriving+-- >>> :set -XDataKinds+-- >>> :set -XTypeOperators++-- | Verify that every type used with @'JSON'@ content type in a servant API+-- has compatible @'ToJSON'@ and @'ToSchema'@ instances using @'validateToJSON'@.+--+-- /NOTE:/ @'validateEveryToJSON'@ does not perform string pattern validation.+-- See @'validateEveryToJSONWithPatternChecker'@.+--+-- @'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)+-- >>> instance ToJSON User+-- >>> instance ToSchema User+-- >>> instance ToSchema UserId+-- >>> instance Arbitrary User where arbitrary = User <$> arbitrary <*> arbitrary+-- >>> type UserAPI = (Capture "user_id" UserId :> Get '[JSON] User) :<|> (ReqBody '[JSON] User :> Post '[JSON] UserId)+--+-- >>> hspec $ context "ToJSON matches ToSchema" $ validateEveryToJSON (Proxy :: Proxy UserAPI)+-- <BLANKLINE>+-- ToJSON matches ToSchema+-- User...+-- ...+-- UserId...+-- ...+-- Finished in ... seconds+-- ...2 examples, 0 failures...+--+-- For the test to compile all body types should have the following instances:+--+-- * @'ToJSON'@ and @'ToSchema'@ are used to perform the validation;+-- * @'Typeable'@ is used to name the test for each type;+-- * @'Show'@ is used to display value for which @'ToJSON'@ does not satisfy @'ToSchema'@.+-- * @'Arbitrary'@ is used to arbitrarily generate values.+--+-- If any of the instances is missing, you'll get a descriptive type error:+--+-- >>> data Contact = Contact { fullname :: String, phone :: Integer } deriving (Show, Generic)+-- >>> instance ToJSON Contact+-- >>> instance ToSchema Contact+-- >>> type ContactAPI = Get '[JSON] Contact+-- >>> hspec $ validateEveryToJSON (Proxy :: Proxy ContactAPI)+-- ...+-- ...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))++-- | 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))++-- * QuickCheck-related stuff++-- | Construct property tests for each type in a list.+-- The name for each property is the name of the corresponding type.+--+-- >>> :{+-- hspec $+-- context "read . show == id" $+-- props+-- (Proxy :: Proxy [Eq, Show, Read])+-- (\x -> read (show x) === x)+-- (Proxy :: Proxy [Bool, Int, String])+-- :}+-- <BLANKLINE>+-- read . show == id+-- Bool...+-- ...+-- Int...+-- ...+-- [Char]...+-- ...+-- 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 _ 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)++-- | Pretty print validation errors+-- together with actual JSON and OpenApi Schema+-- (using 'encodePretty').+--+-- >>> import Data.Aeson+-- >>> import Data.Foldable (traverse_)+-- >>> data Person = Person { name :: String, phone :: Integer } deriving (Generic)+-- >>> instance ToJSON Person where toJSON p = object [ "name" .= name p ]+-- >>> instance ToSchema Person+-- >>> let person = Person { name = "John", phone = 123456 }+-- >>> traverse_ putStrLn $ prettyValidateWith validateToJSON person+-- Validation against the schema fails:+-- * property "phone" is required, but not found in "{\"name\":\"John\"}"+-- <BLANKLINE>+-- JSON value:+-- {+-- "name": "John"+-- }+-- <BLANKLINE>+-- OpenApi Schema:+-- {+-- "properties": {+-- "name": {+-- "type": "string"+-- },+-- "phone": {+-- "type": "integer"+-- }+-- },+-- "required": [+-- "name",+-- "phone"+-- ],+-- "type": "object"+-- }+-- <BLANKLINE>+--+-- FIXME: this belongs in "Data.OpenApi.Schema.Validation" (in @openapi-hs@).+prettyValidateWith+ :: forall a. (ToJSON a, ToSchema a)+ => (a -> [ValidationError]) -> a -> Maybe String+prettyValidateWith 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)+ ]+ where+ ppJSONString = TL.unpack . TL.decodeUtf8 . encodePretty++ json = toJSON x+ schema = toSchema (Proxy :: Proxy a)++-- | Provide a counterexample if there is any.+maybeCounterExample :: Maybe String -> Property+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 }
+ src/Servant/OpenApi/Internal/TypeLevel.hs view
@@ -0,0 +1,11 @@+-- | 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++import Servant.OpenApi.Internal.TypeLevel.API+import Servant.OpenApi.Internal.TypeLevel.Every+import Servant.OpenApi.Internal.TypeLevel.TMap
+ src/Servant/OpenApi/Internal/TypeLevel/API.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+-- | Type families that enumerate the endpoints of a servant API and decide+-- sub-API membership. Not subject to the PVP; import "Servant.OpenApi.TypeLevel".+module Servant.OpenApi.Internal.TypeLevel.API where++import Data.Kind (Constraint, Type)+import Servant.API++-- | 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 (NamedRoutes api) = EndpointsList (ToServantApi api)+#endif+ EndpointsList a = '[a]++-- | Check whether @sub@ is a sub API of @api@.+type family IsSubAPI sub api :: Constraint where+ IsSubAPI sub api = AllIsElem (EndpointsList sub) api++-- | Check that every element of @xs@ is an endpoint of @api@.+type family AllIsElem xs api :: Constraint where+ AllIsElem '[] api = ()+ AllIsElem (x ': xs) api = (IsIn x api, AllIsElem xs api)++-- | Apply @(e :>)@ to every API in @xs@.+type family MapSub e xs where+ MapSub e '[] = '[]+ MapSub e (x ': xs) = (e :> x) ': MapSub e xs++-- | Append two type-level lists.+type family AppendList xs ys where+ AppendList '[] ys = ys+ AppendList (x ': xs) ys = x ': AppendList xs ys++type family Or (a :: Constraint) (b :: Constraint) :: Constraint where+ Or () b = ()+ Or a () = ()++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.+-- This is a type-level analogue of @'elem'@.+type family Elem x xs where+ Elem x '[] = 'False+ Elem x (x ': xs) = 'True+ Elem x (y ': xs) = Elem x xs++-- | Remove duplicates from a type-level list.+type family Nub xs where+ Nub '[] = '[]+ Nub (x ': xs) = x ': Nub (Remove x xs)++-- | Remove element from a type-level list.+type family Remove x xs where+ 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.+type BodyTypes c api = Nub (BodyTypes' c api)++-- | @'AddBodyType' c cs a as@ adds type @a@ to the list @as@+-- only if @c@ is in @cs@.+type AddBodyType c cs a as = If (Elem c cs) (a ': as) as++-- | Extract a list of "body" types for a specific content-type from a servant API.+-- To extract unique types see @'BodyTypes'@.+--+-- @t'NoContent'@ is removed from the list and not tested. (This allows for leaving the body+-- completely empty on responses to requests that only accept 'application/json', while+-- setting the content-type in the response accordingly.)+type family BodyTypes' c api :: [Type] where+ 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 '[]+ 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 = '[]
+ src/Servant/OpenApi/Internal/TypeLevel/Every.hs view
@@ -0,0 +1,65 @@+{-# 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+-- | Apply a list of constraint constructors to a type, as a type family and as+-- 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++-- $setup+-- >>> :set -XDataKinds+-- >>> :set -XFlexibleContexts+-- >>> :set -XGADTs+-- >>> :set -XRankNTypes+-- >>> :set -XScopedTypeVariables+-- >>> import GHC.TypeLits+-- >>> import Data.List++-- | Apply multiple constraint constructors to a type.+--+-- @+-- EveryTF '[Show, Read] a ~ (Show a, Read a)+-- @+--+-- Note that since this is a type family, you have to alway fully apply @'EveryTF'@.+--+-- For partial application of multiple constraint constructors see @'Every'@.+type family EveryTF cs x :: Constraint where+ EveryTF '[] x = ()+ EveryTF (c ': cs) x = (c x, EveryTF cs x)++-- | 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++instance Every '[] x where+instance (c x, Every cs x) => Every (c ': cs) x where++-- | 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 _ = tmap (Proxy :: Proxy (Every cs))
+ src/Servant/OpenApi/Internal/TypeLevel/TMap.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# 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)++-- $setup+-- >>> :set -XDataKinds+-- >>> :set -XFlexibleContexts+-- >>> :set -XGADTs+-- >>> :set -XRankNTypes+-- >>> :set -XScopedTypeVariables+-- >>> import GHC.TypeLits+-- >>> import Data.List++-- | Map a list of constrained types to a list of values.+--+-- >>> 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]++instance TMap q '[] where+ tmap _ _ _ = []++instance (q x, TMap q xs) => TMap q (x ': xs) where+ tmap q f _ = f (Proxy :: Proxy x) : tmap q f (Proxy :: Proxy xs)+
+ src/Servant/OpenApi/Test.hs view
@@ -0,0 +1,13 @@+-- |+-- Module: Servant.OpenApi.Test+-- License: BSD3+-- Maintainer: Nadeem Bitar <nadeem@gmail.com>+-- Stability: experimental+--+-- Automatic tests for servant API against OpenApi spec.+module Servant.OpenApi.Test (+ validateEveryToJSON,+ validateEveryToJSONWithPatternChecker,+) where++import Servant.OpenApi.Internal.Test
+ src/Servant/OpenApi/TypeLevel.hs view
@@ -0,0 +1,15 @@+-- |+-- Module: Servant.OpenApi.TypeLevel+-- License: BSD3+-- Maintainer: Nadeem Bitar <nadeem@gmail.com>+-- Stability: experimental+--+-- Useful type families for servant APIs.+module Servant.OpenApi.TypeLevel (+ IsSubAPI,+ EndpointsList,+ BodyTypes,+) where++import Servant.OpenApi.Internal.TypeLevel+
+ test/Servant/OpenApiSpec.hs view
@@ -0,0 +1,625 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE PackageImports #-}+#if MIN_VERSION_servant(0,18,1)+{-# LANGUAGE TypeFamilies #-}+#endif+module Servant.OpenApiSpec where++import Control.Lens+import Data.Aeson (ToJSON (toJSON), Value, eitherDecode, encode, genericToJSON)+import Data.Aeson.Lens (key, members, _String)+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 Test.QuickCheck (Arbitrary (..))++checkAPI :: HasCallStack => HasOpenApi api => Proxy api -> Value -> IO ()+checkAPI proxy = checkOpenApi (toOpenApi proxy)++checkOpenApi :: HasCallStack => OpenApi -> Value -> IO ()+checkOpenApi openApi js = encode (toJSON openApi) `shouldBe` (encode js)++spec :: Spec+spec = do+ describe "HasOpenApi" $ do+ it "Todo API" $ checkAPI (Proxy :: Proxy TodoAPI) todoAPI+ it "Hackage API (with tags)" $ checkOpenApi hackageOpenApiWithTags hackageAPI+ it "GetPost API (test subOperations)" $ checkOpenApi getPostOpenApi getPostAPI+ it "Comprehensive API" $ do+ -- Exercising every servant combinator must not merely compile: it must+ -- still emit a valid 3.1 document with a non-empty set of paths.+ let doc = toJSON (toOpenApi comprehensiveAPI)+ doc ^? key "openapi" . _String `shouldBe` Just "3.1.0"+ lengthOf (key "paths" . members) doc `shouldSatisfy` (> 0)+#if MIN_VERSION_servant(0,18,1)+ it "UVerb API" $ checkOpenApi uverbOpenApi uverbAPI+#endif++ -- Layer 1: every generated document round-trips through openapi-hs's+ -- 'FromJSON OpenApi', which rejects any version outside 3.1.0 .. 3.1.1.+ -- A successful @eitherDecode (encode spec) == Right spec@ therefore proves+ -- the emitted JSON is a structurally valid OpenAPI 3.1 document.+ describe "round-trips through openapi-hs (valid OpenAPI 3.1)" $ do+ it "Todo API" $ roundTrips (toOpenApi (Proxy :: Proxy TodoAPI))+ it "Hackage API" $ roundTrips hackageOpenApiWithTags+ it "GetPost API" $ roundTrips getPostOpenApi+ it "Comprehensive API" $ roundTrips (toOpenApi comprehensiveAPI)+#if MIN_VERSION_servant(0,18,1)+ it "UVerb API" $ roundTrips uverbOpenApi+#endif++ -- Layer 2: generated random values of each JSON body type are validated+ -- against the *generated* schema, proving the schemas describe the data.+ describe "validateEveryToJSON (schemas describe their data)" $+ validateEveryToJSON (Proxy :: Proxy ValidationAPI)++ -- The 3.1-specific rendering this fork exists to provide, asserted directly+ -- on the generated JSON so a regression to 3.0 output fails loudly.+ describe "OpenAPI 3.1 rendering" $ do+ it "declares openapi version 3.1.0" $+ toJSON (toOpenApi (Proxy :: Proxy TodoAPI)) ^? key "openapi" . _String+ `shouldBe` Just "3.1.0"++ it "expresses nullability as a type array, not a `nullable` keyword" $ do+ let doc = toJSON (toOpenApi (Proxy :: Proxy NullableAPI))+ nickName = doc ^? key "components" . key "schemas" . key "Nickname"+ -- 3.1: nullability lives in the type array @["string","null"]@ ...+ (nickName >>= (^? key "type")) `shouldBe` Just (toJSON ["string", "null" :: Text])+ -- ... and the 3.0-only @nullable@ keyword must not be emitted anywhere.+ (nickName >>= (^? key "nullable")) `shouldBe` Nothing++-- | Layer 1 assertion: a document survives a parse by openapi-hs's+-- @FromJSON OpenApi@ — which rejects any version outside 3.1.0 .. 3.1.1 — and+-- re-serializes to a semantically identical JSON document, proving it is a+-- structurally valid, correctly-versioned OpenAPI 3.1 document.+--+-- The comparison is at the aeson 'Value' level rather than on @OpenApi@ values+-- or raw bytes, for two reasons:+--+-- * @Eq@ for @InsOrdHashSet@ (used by @tags@ / @operationTags@) is sensitive+-- to an internal index counter that a JSON round-trip does not preserve, so+-- @decoded == Right s@ fails for semantically identical documents.+-- * aeson decodes JSON objects into an order-insensitive @KeyMap@, so the+-- re-encoded bytes differ in key order from the original even when the+-- documents are identical.+--+-- Comparing 'Value's sidesteps both: object key order is irrelevant to 'Value'+-- equality while array order (e.g. @required@, @enum@) still is.+roundTrips :: HasCallStack => OpenApi -> Expectation+roundTrips s = case eitherDecode (encode s) :: Either String OpenApi of+ Left err -> expectationFailure ("did not decode as OpenAPI 3.1: " ++ err)+ Right d -> toJSON d `shouldBe` toJSON s++main :: IO ()+main = hspec spec++-- =======================================================================+-- Validation API (Layer 2)+-- =======================================================================++data Health = Health+ { status :: String+ , uptime :: Int+ } deriving (Eq, Show, Generic)++instance ToJSON Health+instance ToSchema Health+instance Arbitrary Health where+ arbitrary = Health <$> arbitrary <*> arbitrary++type ValidationAPI =+ "health" :> Get '[JSON] Health+ :<|> "health" :> ReqBody '[JSON] Health :> Post '[JSON] Health++-- =======================================================================+-- Nullable API (OpenAPI 3.1 type-array nullability)+-- =======================================================================++-- | A type whose schema is explicitly nullable. Under OpenAPI 3.1 this must+-- render as @"type": ["string","null"]@ rather than the 3.0 @nullable: true@,+-- so it pins the headline difference between this fork and its 3.0 upstream.+newtype Nickname = Nickname (Maybe Text) deriving (Generic)++instance ToJSON Nickname++instance ToSchema Nickname where+ declareNamedSchema _ = pure $+ NamedSchema (Just "Nickname") $+ mempty & type_ ?~ OpenApiTypeArray [OpenApiString, OpenApiNull]++type NullableAPI = "nick" :> Get '[JSON] Nickname++-- =======================================================================+-- Todo API+-- =======================================================================++data Todo = Todo+ { created :: UTCTime+ , title :: String+ , summary :: Maybe String+ } deriving (Generic)++instance ToJSON Todo+instance ToSchema Todo++newtype TodoId = TodoId String deriving (Generic)+instance ToParamSchema TodoId++type TodoAPI = "todo" :> Capture "id" TodoId :> Get '[JSON] Todo++todoAPI :: Value+todoAPI = [aesonQQ|+{+ "openapi": "3.1.0",+ "info": {+ "version": "",+ "title": ""+ },+ "components": {+ "schemas": {+ "Todo": {+ "required": [+ "created",+ "title"+ ],+ "type": "object",+ "properties": {+ "summary": {+ "type": "string"+ },+ "created": {+ "$ref": "#/components/schemas/UTCTime"+ },+ "title": {+ "type": "string"+ }+ }+ },+ "UTCTime": {+ "example": "2016-07-22T00:00:00Z",+ "format": "yyyy-mm-ddThh:MM:ssZ",+ "type": "string"+ }+ }+ },+ "paths": {+ "/todo/{id}": {+ "get": {+ "responses": {+ "404": {+ "description": "`id` not found"+ },+ "200": {+ "content": {+ "application/json;charset=utf-8": {+ "schema": {+ "$ref": "#/components/schemas/Todo"+ }+ }+ },+ "description": ""+ }+ },+ "parameters": [+ {+ "required": true,+ "schema": {+ "type": "string"+ },+ "in": "path",+ "name": "id"+ }+ ]+ }+ }+ }+}+|]++-- =======================================================================+-- Hackage API+-- =======================================================================++type HackageAPI+ = HackageUserAPI+ :<|> HackagePackagesAPI++type HackageUserAPI =+ "users" :> Get '[JSON] [UserSummary]+ :<|> "user" :> Capture "username" Username :> Get '[JSON] UserDetailed++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)++lowerCutPrefix :: String -> String -> String+lowerCutPrefix s = map toLower . drop (length s)++instance ToJSON UserSummary where+ 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 }++type Group = Text++data UserDetailed = UserDetailed+ { username :: Username+ , userid :: Int64+ , groups :: [Group]+ } deriving (Eq, Show, Generic)+instance ToSchema UserDetailed++newtype Package = Package { packageName :: Text }+ deriving (Eq, Show, Generic)+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"]+ where+ usersOps, packagesOps :: Traversal' OpenApi Operation+ usersOps = subOperations (Proxy :: Proxy HackageUserAPI) (Proxy :: Proxy HackageAPI)+ packagesOps = subOperations (Proxy :: Proxy HackagePackagesAPI) (Proxy :: Proxy HackageAPI)++hackageAPI :: Value+hackageAPI = [aesonQQ|+{+ "openapi": "3.1.0",+ "servers": [+ {+ "url": "https://hackage.haskell.org"+ }+ ],+ "components": {+ "schemas": {+ "UserDetailed": {+ "required": [+ "username",+ "userid",+ "groups"+ ],+ "type": "object",+ "properties": {+ "groups": {+ "items": {+ "type": "string"+ },+ "type": "array"+ },+ "username": {+ "type": "string"+ },+ "userid": {+ "maximum": 9223372036854775807,+ "format": "int64",+ "minimum": -9223372036854775808,+ "type": "integer"+ }+ }+ },+ "Package": {+ "required": [+ "packageName"+ ],+ "type": "object",+ "properties": {+ "packageName": {+ "type": "string"+ }+ }+ },+ "UserSummary": {+ "example": {+ "username": "JohnDoe",+ "userid": 123+ },+ "required": [+ "username",+ "userid"+ ],+ "type": "object",+ "properties": {+ "username": {+ "type": "string"+ },+ "userid": {+ "maximum": 9223372036854775807,+ "format": "int64",+ "minimum": -9223372036854775808,+ "type": "integer"+ }+ }+ }+ }+ },+ "info": {+ "version": "",+ "title": ""+ },+ "paths": {+ "/users": {+ "get": {+ "responses": {+ "200": {+ "content": {+ "application/json;charset=utf-8": {+ "schema": {+ "items": {+ "$ref": "#/components/schemas/UserSummary"+ },+ "type": "array"+ }+ }+ },+ "description": ""+ }+ },+ "tags": [+ "users"+ ]+ }+ },+ "/packages": {+ "get": {+ "responses": {+ "200": {+ "content": {+ "application/json;charset=utf-8": {+ "schema": {+ "items": {+ "$ref": "#/components/schemas/Package"+ },+ "type": "array"+ }+ }+ },+ "description": ""+ }+ },+ "tags": [+ "packages"+ ]+ }+ },+ "/user/{username}": {+ "get": {+ "responses": {+ "404": {+ "description": "`username` not found"+ },+ "200": {+ "content": {+ "application/json;charset=utf-8": {+ "schema": {+ "$ref": "#/components/schemas/UserDetailed"+ }+ }+ },+ "description": ""+ }+ },+ "parameters": [+ {+ "required": true,+ "schema": {+ "type": "string"+ },+ "in": "path",+ "name": "username"+ }+ ],+ "tags": [+ "users"+ ]+ }+ }+ },+ "tags": [+ {+ "name": "users",+ "description": "Operations about user"+ },+ {+ "name": "packages",+ "description": "Query packages"+ }+ ]+}+|]+++-- =======================================================================+-- Get/Post API (test for subOperations)+-- =======================================================================++type GetPostAPI = Get '[JSON] String :<|> Post '[JSON] String++getPostOpenApi :: OpenApi+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|+{+ "components": {},+ "openapi": "3.1.0",+ "info": {+ "version": "",+ "title": ""+ },+ "paths": {+ "/": {+ "post": {+ "responses": {+ "200": {+ "content": {+ "application/json;charset=utf-8": {+ "schema": {+ "type": "string"+ }+ }+ },+ "description": ""+ }+ }+ },+ "get": {+ "responses": {+ "200": {+ "content": {+ "application/json;charset=utf-8": {+ "schema": {+ "type": "string"+ }+ }+ },+ "description": ""+ }+ },+ "tags": [+ "get"+ ]+ }+ }+ },+ "tags": [+ {+ "name": "get",+ "description": "GET operations"+ }+ ]+}+|]++-- =======================================================================+-- UVerb API+-- =======================================================================++#if MIN_VERSION_servant(0,18,1)++data FisxUser = FisxUser {name :: String}+ deriving (Eq, Show, Generic)++instance ToSchema FisxUser++instance HasStatus FisxUser where+ type StatusOf FisxUser = 203++data ArianUser = ArianUser+ deriving (Eq, Show, Generic)++instance ToSchema 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|+{+ "openapi": "3.1.0",+ "info": {+ "version": "",+ "title": ""+ },+ "components": {+ "schemas": {+ "ArianUser": {+ "type": "string",+ "enum": [+ "ArianUser"+ ]+ },+ "FisxUser": {+ "required": [+ "name"+ ],+ "type": "object",+ "properties": {+ "name": {+ "type": "string"+ }+ }+ }+ }+ },+ "paths": {+ "/arian": {+ "post": {+ "responses": {+ "201": {+ "content": {+ "application/json;charset=utf-8": {+ "schema": {+ "$ref": "#/components/schemas/ArianUser"+ }+ }+ },+ "description": ""+ }+ }+ }+ },+ "/fisx": {+ "get": {+ "responses": {+ "303": {+ "content": {+ "application/json;charset=utf-8": {+ "schema": {+ "type": "string"+ }+ }+ },+ "description": ""+ },+ "203": {+ "content": {+ "application/json;charset=utf-8": {+ "schema": {+ "$ref": "#/components/schemas/FisxUser"+ }+ }+ },+ "description": ""+ }+ }+ }+ }+ }+}+|]++#endif
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}