diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. + diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,135 @@ +# 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 +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**. + + +> **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: +> ``` +> +> 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).* diff --git a/app/GenOpenApi.hs b/app/GenOpenApi.hs new file mode 100644 --- /dev/null +++ b/app/GenOpenApi.hs @@ -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) diff --git a/servant-openapi-hs.cabal b/servant-openapi-hs.cabal new file mode 100644 --- /dev/null +++ b/servant-openapi-hs.cabal @@ -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 diff --git a/src/Servant/OpenApi.hs b/src/Servant/OpenApi.hs new file mode 100644 --- /dev/null +++ b/src/Servant/OpenApi.hs @@ -0,0 +1,529 @@ +-- | +-- Module: Servant.OpenApi +-- License: BSD3 +-- Maintainer: Nadeem Bitar +-- 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 . +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) +-- +-- [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 for an example of a server. diff --git a/src/Servant/OpenApi/Internal.hs b/src/Servant/OpenApi/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Servant/OpenApi/Internal.hs @@ -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 +-- . +-- +-- 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) diff --git a/src/Servant/OpenApi/Internal/Orphans.hs b/src/Servant/OpenApi/Internal/Orphans.hs new file mode 100644 --- /dev/null +++ b/src/Servant/OpenApi/Internal/Orphans.hs @@ -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]) diff --git a/src/Servant/OpenApi/Internal/Test.hs b/src/Servant/OpenApi/Internal/Test.hs new file mode 100644 --- /dev/null +++ b/src/Servant/OpenApi/Internal/Test.hs @@ -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) +-- +-- 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]) +-- :} +-- +-- 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\"}" +-- +-- JSON value: +-- { +-- "name": "John" +-- } +-- +-- OpenApi Schema: +-- { +-- "properties": { +-- "name": { +-- "type": "string" +-- }, +-- "phone": { +-- "type": "integer" +-- } +-- }, +-- "required": [ +-- "name", +-- "phone" +-- ], +-- "type": "object" +-- } +-- +-- +-- 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 } diff --git a/src/Servant/OpenApi/Internal/TypeLevel.hs b/src/Servant/OpenApi/Internal/TypeLevel.hs new file mode 100644 --- /dev/null +++ b/src/Servant/OpenApi/Internal/TypeLevel.hs @@ -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 diff --git a/src/Servant/OpenApi/Internal/TypeLevel/API.hs b/src/Servant/OpenApi/Internal/TypeLevel/API.hs new file mode 100644 --- /dev/null +++ b/src/Servant/OpenApi/Internal/TypeLevel/API.hs @@ -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 = '[] diff --git a/src/Servant/OpenApi/Internal/TypeLevel/Every.hs b/src/Servant/OpenApi/Internal/TypeLevel/Every.hs new file mode 100644 --- /dev/null +++ b/src/Servant/OpenApi/Internal/TypeLevel/Every.hs @@ -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)) diff --git a/src/Servant/OpenApi/Internal/TypeLevel/TMap.hs b/src/Servant/OpenApi/Internal/TypeLevel/TMap.hs new file mode 100644 --- /dev/null +++ b/src/Servant/OpenApi/Internal/TypeLevel/TMap.hs @@ -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) + diff --git a/src/Servant/OpenApi/Test.hs b/src/Servant/OpenApi/Test.hs new file mode 100644 --- /dev/null +++ b/src/Servant/OpenApi/Test.hs @@ -0,0 +1,13 @@ +-- | +-- Module: Servant.OpenApi.Test +-- License: BSD3 +-- Maintainer: Nadeem Bitar +-- Stability: experimental +-- +-- Automatic tests for servant API against OpenApi spec. +module Servant.OpenApi.Test ( + validateEveryToJSON, + validateEveryToJSONWithPatternChecker, +) where + +import Servant.OpenApi.Internal.Test diff --git a/src/Servant/OpenApi/TypeLevel.hs b/src/Servant/OpenApi/TypeLevel.hs new file mode 100644 --- /dev/null +++ b/src/Servant/OpenApi/TypeLevel.hs @@ -0,0 +1,15 @@ +-- | +-- Module: Servant.OpenApi.TypeLevel +-- License: BSD3 +-- Maintainer: Nadeem Bitar +-- Stability: experimental +-- +-- Useful type families for servant APIs. +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 new file mode 100644 --- /dev/null +++ b/test/Servant/OpenApiSpec.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}