diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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. 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,46 @@ +# servant-openapi3 + +[![Hackage](https://img.shields.io/hackage/v/servant-openapi3.svg)](http://hackage.haskell.org/package/servant-openapi3) +[![Build Status](https://travis-ci.org/biocad/servant-openapi3.svg?branch=master)](https://travis-ci.org/biocad/servant-openapi3) +[![Stackage LTS](http://stackage.org/package/servant-openapi3/badge/lts)](http://stackage.org/lts/package/servant-openapi3) +[![Stackage Nightly](http://stackage.org/package/servant-openapi3/badge/nightly)](http://stackage.org/nightly/package/servant-openapi3) + +OpenAPI 3.0 conforming json for [servant](https://github.com/haskell-servant/servant) APIs. + +![servant-swagger robot](http://s16.postimg.org/rndz1wbyt/servant.png) + +### 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). diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -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 diff --git a/example/LICENSE b/example/LICENSE new file mode 100644 --- /dev/null +++ b/example/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/example/example.cabal b/example/example.cabal new file mode 100644 --- /dev/null +++ b/example/example.cabal @@ -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 diff --git a/example/server/Main.hs b/example/server/Main.hs new file mode 100644 --- /dev/null +++ b/example/server/Main.hs @@ -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 + diff --git a/example/src/Todo.hs b/example/src/Todo.hs new file mode 100644 --- /dev/null +++ b/example/src/Todo.hs @@ -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) diff --git a/example/swagger.json b/example/swagger.json new file mode 100644 --- /dev/null +++ b/example/swagger.json @@ -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" + } + } + } +} diff --git a/example/test/Spec.hs b/example/test/Spec.hs new file mode 100644 --- /dev/null +++ b/example/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/example/test/TodoSpec.hs b/example/test/TodoSpec.hs new file mode 100644 --- /dev/null +++ b/example/test/TodoSpec.hs @@ -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 diff --git a/servant-openapi3.cabal b/servant-openapi3.cabal new file mode 100644 --- /dev/null +++ b/servant-openapi3.cabal @@ -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 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,184 @@ +-- | +-- Module: Servant.OpenApi +-- License: BSD3 +-- Maintainer: Nickolay Kudasov +-- 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 . +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) +-- +-- [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 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 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,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 +-- . +-- +-- 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) 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,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]) 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,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) +-- +-- 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: +-- { +-- "required": [ +-- "name", +-- "phone" +-- ], +-- "type": "object", +-- "properties": { +-- "phone": { +-- "type": "integer" +-- }, +-- "name": { +-- "type": "string" +-- } +-- } +-- } +-- +-- +-- 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) 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,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 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,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 = '[] + 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,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)) 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,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) + 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: Nickolay Kudasov +-- 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: Nickolay Kudasov +-- 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,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" + } + ] +} +|] + 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 #-} diff --git a/test/doctests.hs b/test/doctests.hs new file mode 100644 --- /dev/null +++ b/test/doctests.hs @@ -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