servant-openapi3 (empty) → 2.0.0
raw patch · 25 files changed
+2196/−0 lines, 25 filesdep +QuickCheckdep +aesondep +aeson-prettybuild-type:Customsetup-changed
Dependencies added: QuickCheck, aeson, aeson-pretty, base, base-compat, bytestring, directory, doctest, filepath, hspec, http-media, insert-ordered-containers, lens, lens-aeson, openapi3, servant, servant-openapi3, singleton-bool, template-haskell, text, time, unordered-containers, utf8-string, vector
Files
- CHANGELOG.md +138/−0
- LICENSE +28/−0
- README.md +46/−0
- Setup.hs +33/−0
- example/LICENSE +28/−0
- example/example.cabal +67/−0
- example/server/Main.hs +11/−0
- example/src/Todo.hs +73/−0
- example/swagger.json +165/−0
- example/test/Spec.hs +1/−0
- example/test/TodoSpec.hs +28/−0
- servant-openapi3.cabal +130/−0
- src/Servant/OpenApi.hs +184/−0
- src/Servant/OpenApi/Internal.hs +393/−0
- src/Servant/OpenApi/Internal/Orphans.hs +14/−0
- src/Servant/OpenApi/Internal/Test.hs +200/−0
- src/Servant/OpenApi/Internal/TypeLevel.hs +9/−0
- src/Servant/OpenApi/Internal/TypeLevel/API.hs +87/−0
- src/Servant/OpenApi/Internal/TypeLevel/Every.hs +63/−0
- src/Servant/OpenApi/Internal/TypeLevel/TMap.hs +37/−0
- src/Servant/OpenApi/Test.hs +13/−0
- src/Servant/OpenApi/TypeLevel.hs +15/−0
- test/Servant/OpenApiSpec.hs +420/−0
- test/Spec.hs +1/−0
- test/doctests.hs +12/−0
+ CHANGELOG.md view
@@ -0,0 +1,138 @@+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,46 @@+# servant-openapi3++[](http://hackage.haskell.org/package/servant-openapi3)+[](https://travis-ci.org/biocad/servant-openapi3)+[](http://stackage.org/lts/package/servant-openapi3)+[](http://stackage.org/nightly/package/servant-openapi3)++OpenAPI 3.0 conforming json for [servant](https://github.com/haskell-servant/servant) APIs.++++### Motivation++Swagger is a project used to describe and document RESTful APIs.+Unlike Servant it is language-agnostic and thus is quite popular among developers+in different languages. It also exists for a longer time and has more tools to work with.++This package provides means to generate Swagger specification for a Servant API+and also to partially test whether API conforms with its specification.++Generated Swagger specification then can be used for many things such as+- displaying interactive documentation using [Swagger UI](http://swagger.io/swagger-ui/);+- generating clients and servers in many languages using [Swagger Codegen](http://swagger.io/swagger-codegen/);+- and [many others](http://swagger.io/open-source-integrations/).++### Usage++Please refer to [haddock documentation](http://hackage.haskell.org/package/servant-swagger).++Some examples can be found in [`example/` directory](/example).++### Try it out++All generated swagger specifications can be interactively viewed on [Swagger Editor](http://editor.swagger.io/).++Ready-to-use specification can be served as JSON and interactive API documentation+can be displayed using [Swagger UI](https://github.com/swagger-api/swagger-ui).++Many Swagger tools, including server and client code generation for many languages, can be found on+[Swagger's Tools and Integrations page](http://swagger.io/open-source-integrations/).++### Contributing++We are happy to receive bug reports, fixes, documentation enhancements, and other improvements.++Please report bugs via the [github issue tracker](https://github.com/biocad/servant-openapi3/issues).
+ Setup.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wall #-}+module Main (main) where++#ifndef MIN_VERSION_cabal_doctest+#define MIN_VERSION_cabal_doctest(x,y,z) 0+#endif++#if MIN_VERSION_cabal_doctest(1,0,0)++import Distribution.Extra.Doctest ( defaultMainWithDoctests )+main :: IO ()+main = defaultMainWithDoctests "doctests"++#else++#ifdef MIN_VERSION_Cabal+-- If the macro is defined, we have new cabal-install,+-- but for some reason we don't have cabal-doctest in package-db+--+-- Probably we are running cabal sdist, when otherwise using new-build+-- workflow+#warning You are configuring this package without cabal-doctest installed. \+ The doctests test-suite will not work as a result. \+ To fix this, install cabal-doctest before configuring.+#endif++import Distribution.Simple++main :: IO ()+main = defaultMain++#endif
+ example/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.+
+ example/example.cabal view
@@ -0,0 +1,67 @@+name: example+version: 1.0+synopsis: servant-openapi3 demonstration+description: An example of how servant-openapi3 can be used.+license: BSD3+license-file: LICENSE+author: David Johnson, Nickolay Kudasov+maintainer: nickolay.kudasov@gmail.com+copyright: (c) 2015-2020, Servant contributors+category: Web+build-type: Simple+cabal-version: >=1.10+data-files:+ swagger.json++tested-with:+ GHC ==8.4.4+ || ==8.6.5+ || ==8.8.3++library+ ghc-options: -Wall+ hs-source-dirs: src/+ exposed-modules:+ Todo+ build-depends: base+ , aeson+ , aeson-pretty+ , bytestring+ , lens+ , servant+ , servant-server+ , servant-openapi3+ , openapi3+ , text+ , time+ default-language: Haskell2010++executable swagger-server+ ghc-options: -Wall+ hs-source-dirs: server/+ main-is: Main.hs+ build-depends: base+ , example+ , servant-server+ , warp+ default-language: Haskell2010++test-suite swagger-server-spec+ ghc-options: -Wall+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ other-modules:+ TodoSpec+ Paths_example+ build-tool-depends: hspec-discover:hspec-discover >=2.6.0 && <2.8+ build-depends: base == 4.*+ , base-compat >= 0.6.0+ , aeson >=0.11.2.0+ , bytestring+ , example+ , hspec+ , servant-openapi3+ , QuickCheck+ , quickcheck-instances+ default-language: Haskell2010
+ example/server/Main.hs view
@@ -0,0 +1,11 @@+module Main where++import Network.Wai.Handler.Warp+import Servant+import Todo++main :: IO ()+main = do+ putStrLn "Running on port 8000"+ run 8000 $ serve (Proxy :: Proxy API) server+
+ example/src/Todo.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators #-}+module Todo where++import Control.Lens+import Data.Aeson+import Data.Aeson.Encode.Pretty (encodePretty)+import qualified Data.ByteString.Lazy.Char8 as BL8+import Data.OpenApi hiding (Server)+import Data.Proxy+import Data.Text (Text)+import Data.Time (UTCTime (..), fromGregorian)+import Data.Typeable (Typeable)+import GHC.Generics+import Servant+import Servant.OpenApi++todoAPI :: Proxy TodoAPI+todoAPI = Proxy++-- | The API of a Todo service.+type TodoAPI+ = "todo" :> Get '[JSON] [Todo]+ :<|> "todo" :> ReqBody '[JSON] Todo :> Post '[JSON] TodoId+ :<|> "todo" :> Capture "id" TodoId :> Get '[JSON] Todo+ :<|> "todo" :> Capture "id" TodoId :> ReqBody '[JSON] Todo :> Put '[JSON] TodoId++-- | API for serving @swagger.json@.+type SwaggerAPI = "swagger.json" :> Get '[JSON] OpenApi++-- | Combined API of a Todo service with Swagger documentation.+type API = SwaggerAPI :<|> TodoAPI++-- | A single Todo entry.+data Todo = Todo+ { created :: UTCTime -- ^ Creation datetime.+ , summary :: Text -- ^ Task summary.+ } deriving (Show, Generic, Typeable)++-- | A unique Todo entry ID.+newtype TodoId = TodoId Int+ deriving (Show, Generic, Typeable, ToJSON, FromHttpApiData)++instance ToJSON Todo+instance FromJSON Todo++instance ToSchema Todo where+ declareNamedSchema proxy = genericDeclareNamedSchema defaultSchemaOptions proxy+ & mapped.schema.description ?~ "This is some real Todo right here"+ & mapped.schema.example ?~ toJSON (Todo (UTCTime (fromGregorian 2015 12 31) 0) "get milk")++instance ToParamSchema TodoId+instance ToSchema TodoId++-- | Swagger spec for Todo API.+todoSwagger :: OpenApi+todoSwagger = toOpenApi todoAPI+ & info.title .~ "Todo API"+ & info.version .~ "1.0"+ & info.description ?~ "This is an API that tests swagger integration"+ & info.license ?~ ("MIT" & url ?~ URL "http://mit.com")++-- | Combined server of a Todo service with Swagger documentation.+server :: Server API+server = return todoSwagger :<|> error "not implemented"++-- | Output generated @swagger.json@ file for the @'TodoAPI'@.+writeSwaggerJSON :: IO ()+writeSwaggerJSON = BL8.writeFile "example/swagger.json" (encodePretty todoSwagger)
+ example/swagger.json view
@@ -0,0 +1,165 @@+{+ "openapi": "3.0.0",+ "info": {+ "version": "1.0",+ "title": "Todo API",+ "license": {+ "url": "http://mit.com",+ "name": "MIT"+ },+ "description": "This is an API that tests swagger integration"+ },+ "paths": {+ "/todo": {+ "get": {+ "responses": {+ "200": {+ "content": {+ "application/json;charset=utf-8": {+ "schema": {+ "items": {+ "$ref": "#/components/schemas/Todo"+ },+ "type": "array"+ }+ }+ },+ "description": ""+ }+ }+ },+ "post": {+ "requestBody": {+ "content": {+ "application/json;charset=utf-8": {+ "schema": {+ "$ref": "#/components/schemas/Todo"+ }+ }+ }+ },+ "responses": {+ "400": {+ "description": "Invalid `body`"+ },+ "200": {+ "content": {+ "application/json;charset=utf-8": {+ "schema": {+ "$ref": "#/components/schemas/TodoId"+ }+ }+ },+ "description": ""+ }+ }+ }+ },+ "/todo/{id}": {+ "get": {+ "parameters": [+ {+ "required": true,+ "schema": {+ "maximum": 9223372036854775807,+ "minimum": -9223372036854775808,+ "type": "integer"+ },+ "in": "path",+ "name": "id"+ }+ ],+ "responses": {+ "404": {+ "description": "`id` not found"+ },+ "200": {+ "content": {+ "application/json;charset=utf-8": {+ "schema": {+ "$ref": "#/components/schemas/Todo"+ }+ }+ },+ "description": ""+ }+ }+ },+ "put": {+ "parameters": [+ {+ "required": true,+ "schema": {+ "maximum": 9223372036854775807,+ "minimum": -9223372036854775808,+ "type": "integer"+ },+ "in": "path",+ "name": "id"+ }+ ],+ "requestBody": {+ "content": {+ "application/json;charset=utf-8": {+ "schema": {+ "$ref": "#/components/schemas/Todo"+ }+ }+ }+ },+ "responses": {+ "404": {+ "description": "`id` not found"+ },+ "400": {+ "description": "Invalid `body`"+ },+ "200": {+ "content": {+ "application/json;charset=utf-8": {+ "schema": {+ "$ref": "#/components/schemas/TodoId"+ }+ }+ },+ "description": ""+ }+ }+ }+ }+ },+ "components": {+ "schemas": {+ "Todo": {+ "example": {+ "summary": "get milk",+ "created": "2015-12-31T00:00:00Z"+ },+ "required": [+ "created",+ "summary"+ ],+ "type": "object",+ "description": "This is some real Todo right here",+ "properties": {+ "summary": {+ "type": "string"+ },+ "created": {+ "$ref": "#/components/schemas/UTCTime"+ }+ }+ },+ "UTCTime": {+ "example": "2016-07-22T00:00:00Z",+ "format": "yyyy-mm-ddThh:MM:ssZ",+ "type": "string"+ },+ "TodoId": {+ "maximum": 9223372036854775807,+ "minimum": -9223372036854775808,+ "type": "integer"+ }+ }+ }+}
+ example/test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ example/test/TodoSpec.hs view
@@ -0,0 +1,28 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module TodoSpec where++import Prelude ()+import Prelude.Compat++import Data.Aeson+import qualified Data.ByteString.Lazy.Char8 as BL8+import Paths_example+import Servant.OpenApi.Test+import Test.Hspec+import Test.QuickCheck+import Test.QuickCheck.Instances ()+import Todo++spec :: Spec+spec = describe "Swagger" $ do+ context "ToJSON matches ToSchema" $ validateEveryToJSON todoAPI+ it "swagger.json is up-to-date" $ do+ path <- getDataFileName "swagger.json"+ swag <- eitherDecode <$> BL8.readFile path+ swag `shouldBe` Right todoSwagger++instance Arbitrary Todo where+ arbitrary = Todo <$> arbitrary <*> arbitrary++instance Arbitrary TodoId where+ arbitrary = TodoId <$> arbitrary
+ servant-openapi3.cabal view
@@ -0,0 +1,130 @@+name: servant-openapi3+version: 2.0.0+synopsis: Generate a Swagger/OpenAPI/OAS 3.0 specification for your servant API.+description:+ Swagger is a project used to describe and document RESTful APIs. The core of the + project is the [OpenAPI Specification (OAS)](https://swagger.io/docs/specification/about/). + This library implements v2.0 of the spec. Unlike Servant it is language-agnostic and thus is + quite popular among developers in different languages. It has also existed for a longer time + and has more helpful tooling.+ .+ This package provides means to generate a Swagger/OAS specification for a Servant API+ and also to partially test whether an API conforms with its specification.+ .+ Generated Swagger specification then can be used for many things such as+ .+ * displaying interactive documentation using [Swagger UI](http://swagger.io/swagger-ui/);+ .+ * generating clients and servers in many languages using [Swagger Codegen](http://swagger.io/swagger-codegen/);+ .+ * and [many others](http://swagger.io/open-source-integrations/).+homepage: https://github.com/biocad/servant-openapi3+bug-reports: https://github.com/biocad/servant-openapi3/issues+license: BSD3+license-file: LICENSE+author: David Johnson, Nickolay Kudasov, Maxim Koltsov+maintainer: nickolay.kudasov@gmail.com, kolmax94@gmail.com+copyright: (c) 2015-2020, Servant contributors+category: Web, Servant, Swagger+build-type: Custom+cabal-version: 1.18+tested-with:+ GHC ==8.4.4+ || ==8.6.5+ || ==8.8.3++extra-source-files:+ README.md+ , CHANGELOG.md+ , example/server/*.hs+ , example/src/*.hs+ , example/test/*.hs+ , example/*.cabal+ , example/swagger.json+ , example/LICENSE+extra-doc-files:+ example/src/*.hs+ , example/test/*.hs++source-repository head+ type: git+ location: https://github.com/biocad/servant-openapi3.git++custom-setup+ setup-depends:+ base >=4.9 && <4.15,+ Cabal >= 1.24 && <3.3,+ cabal-doctest >=1.0.6 && <1.1++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 >=1.4.2.0 && <1.6+ , aeson-pretty >=0.8.7 && <0.9+ , base >=4.9.1.0 && <4.15+ , base-compat >=0.10.5 && <0.12+ , bytestring >=0.10.8.1 && <0.11+ , http-media >=0.7.1.3 && <0.9+ , insert-ordered-containers >=0.2.1.0 && <0.3+ , lens >=4.17 && <4.20+ , servant >=0.17 && <0.19+ , singleton-bool >=0.1.4 && <0.2+ , openapi3 >=3.0.0 && <4.0+ , text >=1.2.3.0 && <1.3+ , unordered-containers >=0.2.9.0 && <0.3++ , hspec+ , QuickCheck+ default-language: Haskell2010++test-suite doctests+ ghc-options: -Wall+ build-depends:+ base,+ directory >= 1.0,+ doctest >= 0.11.1 && <0.18,+ servant,+ QuickCheck,+ filepath+ default-language: Haskell2010+ hs-source-dirs: test+ main-is: doctests.hs+ type: exitcode-stdio-1.0++test-suite spec+ ghc-options: -Wall+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ build-tool-depends: hspec-discover:hspec-discover >=2.6.0 && <2.8+ build-depends: base+ , base-compat+ , aeson+ , hspec >=2.6.0 && <2.8+ , QuickCheck+ , lens+ , lens-aeson >=1.0.2 && <1.2+ , servant+ , servant-openapi3+ , openapi3+ , text+ , template-haskell+ , utf8-string >=1.0.1.1 && <1.1+ , time+ , vector+ other-modules:+ Servant.OpenApiSpec+ default-language: Haskell2010
+ src/Servant/OpenApi.hs view
@@ -0,0 +1,184 @@+-- |+-- Module: Servant.OpenApi+-- License: BSD3+-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.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 <http://swagger.io/ OpenApi documentation>.+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+-- >>> :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 $ encode $ toOpenApi (Proxy :: Proxy UserAPI)+-- {"openapi":"3.0.0","info":{"version":"","title":""},"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":{"400":{"description":"Invalid `body`"},"200":{"content":{"application/json;charset=utf-8":{"schema":{"$ref":"#/components/schemas/UserId"}}},"description":""}}}},"/{user_id}":{"get":{"parameters":[{"required":true,"schema":{"type":"integer"},"in":"path","name":"user_id"}],"responses":{"404":{"description":"`user_id` not found"},"200":{"content":{"application/json;charset=utf-8":{"schema":{"$ref":"#/components/schemas/User"}}},"description":""}}}}},"components":{"schemas":{"User":{"required":["name","age"],"type":"object","properties":{"age":{"maximum":9223372036854775807,"minimum":-9223372036854775808,"type":"integer"},"name":{"type":"string"}}},"UserId":{"type":"integer"}}}}+--+-- 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 $ encode $ 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"]+-- :}+-- {"openapi":"3.0.0","info":{"version":"1.0","title":"User API","license":{"name":"MIT"},"description":"This is an API for the Users service"},"servers":[{"url":"https://example.com"}],"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":{"400":{"description":"Invalid `body`"},"200":{"content":{"application/json;charset=utf-8":{"schema":{"$ref":"#/components/schemas/UserId"}}},"description":""}}}},"/{user_id}":{"get":{"parameters":[{"required":true,"schema":{"type":"integer"},"in":"path","name":"user_id"}],"responses":{"404":{"description":"`user_id` not found"},"200":{"content":{"application/json;charset=utf-8":{"schema":{"$ref":"#/components/schemas/User"}}},"description":""}}}}},"components":{"schemas":{"User":{"required":["name","age"],"type":"object","properties":{"age":{"maximum":9223372036854775807,"minimum":-9223372036854775808,"type":"integer"},"name":{"type":"string"}}},"UserId":{"type":"integer"}}}}+--+-- 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 $ encode $ toOpenApi (Proxy :: Proxy UserAPI)+-- & applyTagsFor getOps ["get" & description ?~ "GET operations"]+-- & applyTagsFor postOps ["post" & description ?~ "POST operations"]+-- :}+-- {"openapi":"3.0.0","info":{"version":"","title":""},"paths":{"/":{"get":{"tags":["get"],"responses":{"200":{"content":{"application/json;charset=utf-8":{"schema":{"items":{"$ref":"#/components/schemas/User"},"type":"array"}}},"description":""}}},"post":{"tags":["post"],"requestBody":{"content":{"application/json;charset=utf-8":{"schema":{"$ref":"#/components/schemas/User"}}}},"responses":{"400":{"description":"Invalid `body`"},"200":{"content":{"application/json;charset=utf-8":{"schema":{"$ref":"#/components/schemas/UserId"}}},"description":""}}}},"/{user_id}":{"get":{"tags":["get"],"parameters":[{"required":true,"schema":{"type":"integer"},"in":"path","name":"user_id"}],"responses":{"404":{"description":"`user_id` not found"},"200":{"content":{"application/json;charset=utf-8":{"schema":{"$ref":"#/components/schemas/User"}}},"description":""}}}}},"components":{"schemas":{"User":{"required":["name","age"],"type":"object","properties":{"age":{"maximum":9223372036854775807,"minimum":-9223372036854775808,"type":"integer"},"name":{"type":"string"}}},"UserId":{"type":"integer"}}},"tags":[{"name":"get","description":"GET operations"},{"name":"post","description":"POST operations"}]}+--+-- 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 @swagger.json@ serves as a specification, not a Haskell type.+--+-- In this cases it is a good idea to store generated and annotated @'OpenApi'@ in a @swagger.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 @swagger.json@ rather than changes+-- to the Haskell API.+--+-- See <example/test/TodoSpec.hs TodoSpec.hs> for an example of a complete test suite for a swagger specification.++-- $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,393 @@+{-# 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+module Servant.OpenApi.Internal where++import Prelude ()+import Prelude.Compat++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 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 @'Header'@.+-- @'ToSchema'@ is used for @'ReqBody'@ and response data types.+--+-- You can easily derive those instances via @Generic@.+-- For more information, refer to+-- <http://hackage.haskell.org/package/openapi3/docs/Data-OpenApi.html openapi3 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 ref) path proxy+ & components.schemas .~ defs+ where+ (defs, ref) = runDeclare (declareSchemaRef (Proxy :: Proxy a)) mempty++-- | Make a singletone 'OpenApi' spec (with only one endpoint) and with no content schema.+mkEndpointNoContent :: forall nocontent cs hs proxy method status.+ (AllAccept cs, AllToResponseHeader hs, OpenApiMethod method, KnownNat status)+ => FilePath -- ^ Endpoint path.+ -> proxy (Verb method status cs (Headers hs nocontent)) -- ^ Method, content-types, headers and response.+ -> OpenApi+mkEndpointNoContent path proxy+ = mkEndpointWithSchemaRef Nothing path proxy++-- | Like @'mkEndpoint'@ but with explicit schema reference.+-- Unlike @'mkEndpoint'@ this function does not update @'definitions'@.+mkEndpointWithSchemaRef :: forall cs hs proxy method status a.+ (AllAccept cs, AllToResponseHeader hs, OpenApiMethod method, KnownNat status)+ => 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++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 '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)++-- | @'HttpVersion'@ combinator does not change our specification at all.+instance (HasOpenApi sub) => HasOpenApi (HttpVersion :> sub) where+ toOpenApi _ = toOpenApi (Proxy :: Proxy sub)++-- | @'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_ ?~ 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 %~ (<> defs)+ where+ tname = "body"+ transDesc "" = Nothing+ transDesc desc = Just (Text.pack desc)+ (defs, ref) = runDeclare (declareSchemaRef (Proxy :: Proxy a)) mempty+ reqBody = (mempty :: RequestBody)+ & description .~ transDesc (reflectDescription (Proxy :: Proxy mods))+ & content .~ InsOrdHashMap.fromList [(t, mempty & schema ?~ ref) | t <- allContentType (Proxy :: Proxy cs)]++-- | This instance is an approximation.+--+-- @since 1.1.7+instance (ToSchema a, Accept ct, HasOpenApi sub, KnownSymbol (FoldDescription mods)) => HasOpenApi (StreamBody' mods fr ct a :> sub) where+ toOpenApi _ = toOpenApi (Proxy :: Proxy sub)+ & addRequestBody reqBody+ & addDefaultResponse400 tname+ & components.schemas %~ (<> defs)+ where+ tname = "body"+ transDesc "" = Nothing+ transDesc desc = Just (Text.pack desc)+ (defs, ref) = runDeclare (declareSchemaRef (Proxy :: Proxy a)) mempty+ reqBody = (mempty :: RequestBody)+ & description .~ transDesc (reflectDescription (Proxy :: Proxy mods))+ & content .~ InsOrdHashMap.fromList [(t, mempty & schema ?~ ref) | t <- toList $ contentTypes (Proxy :: Proxy ct)]++-- =======================================================================+-- 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,14 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Servant.OpenApi.Internal.Orphans where++import Data.OpenApi+import Data.Proxy (Proxy (..))+import Servant.Types.SourceT (SourceT)++-- | Pretend that 'SourceT m a' is '[a]'.+--+-- @since 1.1.7+--+instance ToSchema a => ToSchema (SourceT m a) where+ declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
+ src/Servant/OpenApi/Internal/Test.hs view
@@ -0,0 +1,200 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+module Servant.OpenApi.Internal.Test where++import Data.Aeson (ToJSON (..))+import Data.Aeson.Encode.Pretty (encodePretty)+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:+-- {+-- "required": [+-- "name",+-- "phone"+-- ],+-- "type": "object",+-- "properties": {+-- "phone": {+-- "type": "integer"+-- },+-- "name": {+-- "type": "string"+-- }+-- }+-- }+-- <BLANKLINE>+--+-- FIXME: this belongs in "Data.OpenApi.Schema.Validation" (in @swagger2@).+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)
+ src/Servant/OpenApi/Internal/TypeLevel.hs view
@@ -0,0 +1,9 @@+module Servant.OpenApi.Internal.TypeLevel (+ module Servant.OpenApi.Internal.TypeLevel.API,+ module Servant.OpenApi.Internal.TypeLevel.Every,+ module Servant.OpenApi.Internal.TypeLevel.TMap,+) where++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,87 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+module Servant.OpenApi.Internal.TypeLevel.API where++import Data.Type.Bool (If)+import GHC.Exts (Constraint)+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)+ 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+ 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'@.+--+-- @'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 :: [*] 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)+ BodyTypes' c api = '[]+
+ src/Servant/OpenApi/Internal/TypeLevel/Every.hs view
@@ -0,0 +1,63 @@+{-# 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+module Servant.OpenApi.Internal.TypeLevel.Every where++import Data.Proxy+import GHC.Exts (Constraint)++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 :: [* -> Constraint]) (x :: *) 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,37 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+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: Nickolay Kudasov <nickolay@getshoptv.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: Nickolay Kudasov <nickolay@getshoptv.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,420 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE PackageImports #-}+module Servant.OpenApiSpec where++import Control.Lens+import Data.Aeson (ToJSON (toJSON), Value, encode, genericToJSON)+import Data.Aeson.QQ.Simple+import qualified Data.Aeson.Types as JSON+import Data.Char (toLower)+import Data.Int (Int64)+import Data.OpenApi+import Data.Proxy+import Data.Text (Text)+import Data.Time+import GHC.Generics+import Servant.API+import Servant.OpenApi+import Servant.Test.ComprehensiveAPI (comprehensiveAPI)+import Test.Hspec hiding (example)++checkAPI :: HasCallStack => HasOpenApi api => Proxy api -> Value -> IO ()+checkAPI proxy = checkOpenApi (toOpenApi proxy)++checkOpenApi :: HasCallStack => OpenApi -> Value -> IO ()+checkOpenApi swag js = encode (toJSON swag) `shouldBe` (encode js)++spec :: Spec+spec = 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+ let _x = toOpenApi comprehensiveAPI+ True `shouldBe` True -- type-level test++main :: IO ()+main = hspec spec++-- =======================================================================+-- 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.0.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.0.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.0.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"+ }+ ]+}+|]+
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/doctests.hs view
@@ -0,0 +1,12 @@+module Main where++import Build_doctests (flags, pkgs, module_sources)+import Data.Foldable (traverse_)+import Test.DocTest++main :: IO ()+main = do+ traverse_ putStrLn args+ doctest args+ where+ args = flags ++ pkgs ++ ["-package-db=/nix/store/04nvwq8fmk0r81fj19zsp2mwmxw3hnxr-ghc-shell-for-packages-ghc-8.8.4-env/lib/ghc-8.8.4/package.conf.d"] ++ module_sources