diff --git a/cabal.project b/cabal.project index 04b29bd5..ac4a4e3b 100644 --- a/cabal.project +++ b/cabal.project @@ -12,6 +12,7 @@ packages: servant-docs/ servant-foreign/ servant-server/ + servant-swagger/ doc/tutorial/ -- servant streaming diff --git a/servant-auth/servant-auth-client/servant-auth-client.cabal b/servant-auth/servant-auth-client/servant-auth-client.cabal index 20e33af6..7b8279b1 100644 --- a/servant-auth/servant-auth-client/servant-auth-client.cabal +++ b/servant-auth/servant-auth-client/servant-auth-client.cabal @@ -64,7 +64,7 @@ test-suite spec build-depends: hspec >= 2.5.5 && < 2.9 , QuickCheck >= 2.11.3 && < 2.15 - , aeson >= 1.3.1.1 && < 1.6 + , aeson >= 1.3.1.1 && < 3 , bytestring >= 0.10.6.0 && < 0.11 , http-client >= 0.5.13.1 && < 0.8 , http-types >= 0.12.2 && < 0.13 @@ -74,7 +74,7 @@ test-suite spec , transformers >= 0.4.2.0 && < 0.6 , wai >= 3.2.1.2 && < 3.3 , warp >= 3.2.25 && < 3.4 - , jose >= 0.7.0.0 && < 0.9 + , jose >= 0.7.0.0 && < 0.10 other-modules: Servant.Auth.ClientSpec default-language: Haskell2010 diff --git a/servant-auth/servant-auth-server/servant-auth-server.cabal b/servant-auth/servant-auth-server/servant-auth-server.cabal index a58e5364..b300b2ac 100644 --- a/servant-auth/servant-auth-server/servant-auth-server.cabal +++ b/servant-auth/servant-auth-server/servant-auth-server.cabal @@ -32,8 +32,8 @@ library ghc-options: -Wall build-depends: base >= 4.10 && < 4.16 - , aeson >= 1.3.1.1 && < 1.6 - , base64-bytestring >= 1.0.0.1 && < 1.3 + , aeson >= 1.0.0.1 && < 3 + , base64-bytestring >= 1.0.0.1 && < 2 , blaze-builder >= 0.4.1.0 && < 0.5 , bytestring >= 0.10.6.0 && < 0.11 , case-insensitive >= 1.2.0.11 && < 1.3 @@ -41,7 +41,7 @@ library , data-default-class >= 0.1.2.0 && < 0.2 , entropy >= 0.4.1.3 && < 0.5 , http-types >= 0.12.2 && < 0.13 - , jose >= 0.7.0.0 && < 0.9 + , jose >= 0.7.0.0 && < 0.10 , lens >= 4.16.1 && < 5.1 , memory >= 0.14.16 && < 0.17 , monad-time >= 0.3.1.0 && < 0.4 diff --git a/servant-auth/servant-auth-swagger/servant-auth-swagger.cabal b/servant-auth/servant-auth-swagger/servant-auth-swagger.cabal index 840a7591..d524533e 100644 --- a/servant-auth/servant-auth-swagger/servant-auth-swagger.cabal +++ b/servant-auth/servant-auth-swagger/servant-auth-swagger.cabal @@ -33,8 +33,8 @@ library build-depends: base >= 4.10 && < 4.16 , text >= 1.2.3.0 && < 1.3 - , servant-swagger >= 1.1.5 && < 1.8 - , swagger2 >= 2.2.2 && < 2.7 + , servant-swagger >= 1.1.5 && < 2 + , swagger2 >= 2.2.2 && < 3 , servant >= 0.13 && < 0.19 , servant-auth == 0.4.* , lens >= 4.16.1 && < 5.1 diff --git a/servant-auth/servant-auth/servant-auth.cabal b/servant-auth/servant-auth/servant-auth.cabal index 61b3a6a4..36528d3e 100644 --- a/servant-auth/servant-auth/servant-auth.cabal +++ b/servant-auth/servant-auth/servant-auth.cabal @@ -34,8 +34,9 @@ library ghc-options: -Wall build-depends: base >= 4.10 && < 4.16 - , aeson >= 1.3.1.1 && < 1.6 - , jose >= 0.7.0.0 && < 0.9 + , containers >= 0.6 && < 0.7 + , aeson >= 1.3.1.1 && < 3 + , jose >= 0.7.0.0 && < 0.10 , lens >= 4.16.1 && < 5.1 , servant >= 0.15 && < 0.19 , text >= 1.2.3.0 && < 1.3 diff --git a/servant-auth/servant-auth/src/Servant/Auth/JWT.hs b/servant-auth/servant-auth/src/Servant/Auth/JWT.hs index f02494ba..84bf17d0 100644 --- a/servant-auth/servant-auth/src/Servant/Auth/JWT.hs +++ b/servant-auth/servant-auth/src/Servant/Auth/JWT.hs @@ -1,10 +1,17 @@ +{-# LANGUAGE CPP #-} + module Servant.Auth.JWT where import Control.Lens ((^.)) import qualified Crypto.JWT as Jose import Data.Aeson (FromJSON, Result (..), ToJSON, fromJSON, toJSON) -import qualified Data.HashMap.Strict as HM +#if MIN_VERSION_aeson(2,0,0) +import qualified Data.Map as KM +#else +import qualified Data.HashMap.Strict as KM +#endif + import qualified Data.Text as T @@ -17,7 +24,7 @@ import qualified Data.Text as T class FromJWT a where decodeJWT :: Jose.ClaimsSet -> Either T.Text a default decodeJWT :: FromJSON a => Jose.ClaimsSet -> Either T.Text a - decodeJWT m = case HM.lookup "dat" (m ^. Jose.unregisteredClaims) of + decodeJWT m = case KM.lookup "dat" (m ^. Jose.unregisteredClaims) of Nothing -> Left "Missing 'dat' claim" Just v -> case fromJSON v of Error e -> Left $ T.pack e diff --git a/servant-client-core/servant-client-core.cabal b/servant-client-core/servant-client-core.cabal index 808e4185..21ac7923 100644 --- a/servant-client-core/servant-client-core.cabal +++ b/servant-client-core/servant-client-core.cabal @@ -70,7 +70,7 @@ library -- Other dependencies: Lower bound around what is in the latest Stackage LTS. -- Here can be exceptions if we really need features from the newer versions. build-depends: - aeson >= 1.4.1.0 && < 1.6 + aeson >= 1.4.1.0 && < 3 , base-compat >= 0.10.5 && < 0.12 , base64-bytestring >= 1.0.0.1 && < 1.3 , exceptions >= 0.10.0 && < 0.11 diff --git a/servant-docs/servant-docs.cabal b/servant-docs/servant-docs.cabal index 64829f3e..857e87a9 100644 --- a/servant-docs/servant-docs.cabal +++ b/servant-docs/servant-docs.cabal @@ -52,7 +52,7 @@ library -- Other dependencies: Lower bound around what is in the latest Stackage LTS. -- Here can be exceptions if we really need features from the newer versions. build-depends: - aeson >= 1.4.1.0 && < 1.6 + aeson >= 1.4.1.0 && < 3 , aeson-pretty >= 0.8.5 && < 0.9 , base-compat >= 0.10.5 && < 0.12 , case-insensitive >= 1.2.0.11 && < 1.3 diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index 15b63601..6fac8a93 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -114,7 +114,7 @@ executable greet , text build-depends: - aeson >= 1.4.1.0 && < 1.6 + aeson >= 1.4.1.0 && < 3 , warp >= 3.2.25 && < 3.4 test-suite spec @@ -157,7 +157,7 @@ test-suite spec -- Additional dependencies build-depends: - aeson >= 1.4.1.0 && < 1.6 + aeson >= 1.4.1.0 && < 3 , directory >= 1.3.0.0 && < 1.4 , hspec >= 2.6.0 && < 2.9 , hspec-wai >= 0.10.1 && < 0.12 diff --git a/servant-swagger/CHANGELOG.md b/servant-swagger/CHANGELOG.md new file mode 100644 index 00000000..0ee616b1 --- /dev/null +++ b/servant-swagger/CHANGELOG.md @@ -0,0 +1,143 @@ +1.1.9 +------- + +* Support `servant-0.18` + +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/servant-swagger/LICENSE b/servant-swagger/LICENSE new file mode 100644 index 00000000..17ec62d2 --- /dev/null +++ b/servant-swagger/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/servant-swagger/README.md b/servant-swagger/README.md new file mode 100644 index 00000000..5e4400e1 --- /dev/null +++ b/servant-swagger/README.md @@ -0,0 +1,46 @@ +# servant-swagger + +[![Hackage](https://img.shields.io/hackage/v/servant-swagger.svg)](http://hackage.haskell.org/package/servant-swagger) +[![Stackage LTS](http://stackage.org/package/servant-swagger/badge/lts)](http://stackage.org/lts/package/servant-swagger) +[![Stackage Nightly](http://stackage.org/package/servant-swagger/badge/nightly)](http://stackage.org/nightly/package/servant-swagger) + +Swagger 2.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/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/haskell-servant/servant/issues). + diff --git a/servant-swagger/Setup.hs b/servant-swagger/Setup.hs new file mode 100644 index 00000000..8ec54a08 --- /dev/null +++ b/servant-swagger/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/servant-swagger/example/LICENSE b/servant-swagger/example/LICENSE new file mode 100644 index 00000000..17ec62d2 --- /dev/null +++ b/servant-swagger/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/servant-swagger/example/example.cabal b/servant-swagger/example/example.cabal new file mode 100644 index 00000000..6abc75f6 --- /dev/null +++ b/servant-swagger/example/example.cabal @@ -0,0 +1,62 @@ +name: example +version: 1.0 +synopsis: servant-swagger demonstration +description: servant-swagger demonstration +license: BSD3 +license-file: LICENSE +author: David Johnson, Nickolay Kudasov +maintainer: nickolay.kudasov@gmail.com +copyright: (c) 2015-2016, Servant contributors +category: Web +build-type: Simple +cabal-version: >=1.10 +data-files: + swagger.json + +library + ghc-options: -Wall + hs-source-dirs: src/ + exposed-modules: + Todo + build-depends: base + , aeson + , aeson-pretty + , bytestring + , lens + , servant + , servant-server + , servant-swagger + , swagger2 + , 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-depends: base == 4.* + , base-compat >= 0.6.0 + , aeson >=0.11.2.0 + , bytestring + , example + , hspec + , servant-swagger + , QuickCheck + , quickcheck-instances + default-language: Haskell2010 + diff --git a/servant-swagger/example/server/Main.hs b/servant-swagger/example/server/Main.hs new file mode 100644 index 00000000..69197690 --- /dev/null +++ b/servant-swagger/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/servant-swagger/example/src/Todo.hs b/servant-swagger/example/src/Todo.hs new file mode 100644 index 00000000..e562e98e --- /dev/null +++ b/servant-swagger/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.Proxy +import Data.Swagger +import Data.Text (Text) +import Data.Time (UTCTime (..), fromGregorian) +import Data.Typeable (Typeable) +import GHC.Generics +import Servant +import Servant.Swagger + +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] Swagger + +-- | 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 :: Swagger +todoSwagger = toSwagger 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/servant-swagger/example/swagger.json b/servant-swagger/example/swagger.json new file mode 100644 index 00000000..018bd8f5 --- /dev/null +++ b/servant-swagger/example/swagger.json @@ -0,0 +1,158 @@ +{ + "swagger": "2.0", + "info": { + "version": "1.0", + "title": "Todo API", + "license": { + "url": "http://mit.com", + "name": "MIT" + }, + "description": "This is an API that tests swagger integration" + }, + "definitions": { + "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": "#/definitions/UTCTime" + } + } + }, + "UTCTime": { + "example": "2016-07-22T00:00:00Z", + "format": "yyyy-mm-ddThh:MM:ssZ", + "type": "string" + }, + "TodoId": { + "maximum": 9223372036854775807, + "minimum": -9223372036854775808, + "type": "integer" + } + }, + "paths": { + "/todo/{id}": { + "get": { + "responses": { + "400": { + "description": "Invalid `id`" + }, + "200": { + "schema": { + "$ref": "#/definitions/Todo" + }, + "description": "" + } + }, + "produces": [ + "application/json;charset=utf-8" + ], + "parameters": [ + { + "maximum": 9223372036854775807, + "minimum": -9223372036854775808, + "required": true, + "in": "path", + "name": "id", + "type": "integer" + } + ] + }, + "put": { + "consumes": [ + "application/json;charset=utf-8" + ], + "responses": { + "400": { + "description": "Invalid `body` or `id`" + }, + "200": { + "schema": { + "$ref": "#/definitions/TodoId" + }, + "description": "" + } + }, + "produces": [ + "application/json;charset=utf-8" + ], + "parameters": [ + { + "maximum": 9223372036854775807, + "minimum": -9223372036854775808, + "required": true, + "in": "path", + "name": "id", + "type": "integer" + }, + { + "required": true, + "schema": { + "$ref": "#/definitions/Todo" + }, + "in": "body", + "name": "body" + } + ] + } + }, + "/todo": { + "post": { + "consumes": [ + "application/json;charset=utf-8" + ], + "responses": { + "400": { + "description": "Invalid `body`" + }, + "200": { + "schema": { + "$ref": "#/definitions/TodoId" + }, + "description": "" + } + }, + "produces": [ + "application/json;charset=utf-8" + ], + "parameters": [ + { + "required": true, + "schema": { + "$ref": "#/definitions/Todo" + }, + "in": "body", + "name": "body" + } + ] + }, + "get": { + "responses": { + "200": { + "schema": { + "items": { + "$ref": "#/definitions/Todo" + }, + "type": "array" + }, + "description": "" + } + }, + "produces": [ + "application/json;charset=utf-8" + ] + } + } + } +} \ No newline at end of file diff --git a/servant-swagger/example/test/Spec.hs b/servant-swagger/example/test/Spec.hs new file mode 100644 index 00000000..a824f8c3 --- /dev/null +++ b/servant-swagger/example/test/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/servant-swagger/example/test/TodoSpec.hs b/servant-swagger/example/test/TodoSpec.hs new file mode 100644 index 00000000..1e44274b --- /dev/null +++ b/servant-swagger/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.Swagger.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-swagger/servant-swagger.cabal b/servant-swagger/servant-swagger.cabal new file mode 100644 index 00000000..f4595e10 --- /dev/null +++ b/servant-swagger/servant-swagger.cabal @@ -0,0 +1,126 @@ +name: servant-swagger +version: 1.1.11 +synopsis: Generate a Swagger/OpenAPI/OAS 2.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/haskell-servant/servant/servant-swagger +bug-reports: https://github.com/haskell-servant/servant/issues +license: BSD3 +license-file: LICENSE +author: Servant Contributors +maintainer: haskell-servant-maintainers@googlegroups.com +copyright: (c) 2015-2018, Servant contributors +category: Web, Servant, Swagger +build-type: Custom +cabal-version: 1.18 +tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 + +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/haskell-servant/servant.git + +custom-setup + setup-depends: + base >=4.9 && <5, + cabal-doctest >=1.0.6 && <1.1 + +library + ghc-options: -Wall + exposed-modules: + Servant.Swagger + Servant.Swagger.Test + Servant.Swagger.TypeLevel + + -- Internal modules + Servant.Swagger.Internal + Servant.Swagger.Internal.Orphans + Servant.Swagger.Internal.Test + Servant.Swagger.Internal.TypeLevel + Servant.Swagger.Internal.TypeLevel.API + Servant.Swagger.Internal.TypeLevel.Every + Servant.Swagger.Internal.TypeLevel.TMap + hs-source-dirs: src + build-depends: aeson >=1.4.2.0 && <3 + , aeson-pretty >=0.8.7 && <0.9 + , base >=4.9.1.0 && <5 + , 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 && <6 + , servant >=0.18.1 && <0.19 + , singleton-bool >=0.1.4 && <0.2 + , swagger2 >=2.3.0.1 && <3 + , 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.18 && <0.19, + 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 >=1.4.2.0 && <3 + , hspec >=2.6.0 && <2.8 + , QuickCheck + , lens + , lens-aeson >=1.0.2 && <1.2 + , servant + , servant-swagger + , swagger2 + , text + , template-haskell + , utf8-string >=1.0.1.1 && <1.1 + , time + , vector + other-modules: + Servant.SwaggerSpec + default-language: Haskell2010 diff --git a/servant-swagger/src/Servant/Swagger.hs b/servant-swagger/src/Servant/Swagger.hs new file mode 100644 index 00000000..c45b0fbc --- /dev/null +++ b/servant-swagger/src/Servant/Swagger.hs @@ -0,0 +1,186 @@ +-- | +-- Module: Servant.Swagger +-- License: BSD3 +-- Maintainer: Nickolay Kudasov +-- Stability: experimental +-- +-- This module provides means to generate and manipulate +-- Swagger specification for servant APIs. +-- +-- Swagger is a project used to describe and document RESTful APIs. +-- +-- The Swagger specification defines a set of files required to describe such an API. +-- These files can then be used by the Swagger-UI project to display the API +-- and Swagger-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.Swagger ( + -- * How to use this library + -- $howto + + -- ** Generate @'Swagger'@ + -- $generate + + -- ** Annotate + -- $annotate + + -- ** Test + -- $test + + -- ** Serve + -- $serve + + -- * @'HasSwagger'@ class + HasSwagger(..), + + -- * Manipulation + subOperations, + + -- * Testing + validateEveryToJSON, + validateEveryToJSONWithPatternChecker, +) where + +import Servant.Swagger.Internal +import Servant.Swagger.Test +import Servant.Swagger.Internal.Orphans () + +-- $setup +-- >>> import Control.Applicative +-- >>> import Control.Lens +-- >>> import Data.Aeson +-- >>> import Data.Aeson.Encode.Pretty +-- >>> import Data.Swagger +-- >>> 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 +-- >>> orderedKeys = encodePretty' (defConfig { confCompare = compare, confIndent = Spaces 0 }) + +-- $howto +-- +-- This section explains how to use this library to generate Swagger 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 @'Swagger'@ specification for a servant API, just use @'toSwagger'@: +-- +-- >>> BSL8.putStrLn . orderedKeys $ toSwagger (Proxy :: Proxy UserAPI) +-- {"definitions":{"User":{"properties":{"age":{"maximum":9223372036854775807,"minimum":-9223372036854775808,"type":"integer"},"name":{"type":"string"}},"required":["name","age"],"type":"object"},"UserId":{"type":"integer"}},"info":{"title":"","version":""},"paths":{"/":{"get":{"produces":["application/json;charset=utf-8"],"responses":{"200":{"description":"","schema":{"items":{"$ref":"#/definitions/User"},"type":"array"}}}},"post":{"consumes":["application/json;charset=utf-8"],"parameters":[{"in":"body","name":"body","required":true,"schema":{"$ref":"#/definitions/User"}}],"produces":["application/json;charset=utf-8"],"responses":{"200":{"description":"","schema":{"$ref":"#/definitions/UserId"}},"400":{"description":"Invalid `body`"}}}},"/{user_id}":{"get":{"parameters":[{"in":"path","name":"user_id","required":true,"type":"integer"}],"produces":["application/json;charset=utf-8"],"responses":{"200":{"description":"","schema":{"$ref":"#/definitions/User"}},"400":{"description":"Invalid `user_id`"}}}}},"swagger":"2.0"} +-- +-- By default @'toSwagger'@ will generate specification for all API routes, parameters, headers, responses and data schemas. +-- +-- For some parameters it will also add 400 responses with a description mentioning parameter name. +-- +-- Data schemas come from @'ToParamSchema'@ and @'ToSchema'@ classes. + +-- $annotate +-- While initially generated @'Swagger'@ looks good, it lacks some information it can't get from a servant API. +-- +-- We can add this information using field lenses from @"Data.Swagger"@: +-- +-- >>> :{ +-- BSL8.putStrLn $ orderedKeys $ toSwagger (Proxy :: Proxy UserAPI) +-- & info.title .~ "User API" +-- & info.version .~ "1.0" +-- & info.description ?~ "This is an API for the Users service" +-- & info.license ?~ "MIT" +-- & host ?~ "example.com" +-- :} +-- {"definitions":{"User":{"properties":{"age":{"maximum":9223372036854775807,"minimum":-9223372036854775808,"type":"integer"},"name":{"type":"string"}},"required":["name","age"],"type":"object"},"UserId":{"type":"integer"}},"host":"example.com","info":{"description":"This is an API for the Users service","license":{"name":"MIT"},"title":"User API","version":"1.0"},"paths":{"/":{"get":{"produces":["application/json;charset=utf-8"],"responses":{"200":{"description":"","schema":{"items":{"$ref":"#/definitions/User"},"type":"array"}}}},"post":{"consumes":["application/json;charset=utf-8"],"parameters":[{"in":"body","name":"body","required":true,"schema":{"$ref":"#/definitions/User"}}],"produces":["application/json;charset=utf-8"],"responses":{"200":{"description":"","schema":{"$ref":"#/definitions/UserId"}},"400":{"description":"Invalid `body`"}}}},"/{user_id}":{"get":{"parameters":[{"in":"path","name":"user_id","required":true,"type":"integer"}],"produces":["application/json;charset=utf-8"],"responses":{"200":{"description":"","schema":{"$ref":"#/definitions/User"}},"400":{"description":"Invalid `user_id`"}}}}},"swagger":"2.0"} +-- +-- 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.Swagger.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 $ orderedKeys $ toSwagger (Proxy :: Proxy UserAPI) +-- & applyTagsFor getOps ["get" & description ?~ "GET operations"] +-- & applyTagsFor postOps ["post" & description ?~ "POST operations"] +-- :} +-- {"definitions":{"User":{"properties":{"age":{"maximum":9223372036854775807,"minimum":-9223372036854775808,"type":"integer"},"name":{"type":"string"}},"required":["name","age"],"type":"object"},"UserId":{"type":"integer"}},"info":{"title":"","version":""},"paths":{"/":{"get":{"produces":["application/json;charset=utf-8"],"responses":{"200":{"description":"","schema":{"items":{"$ref":"#/definitions/User"},"type":"array"}}},"tags":["get"]},"post":{"consumes":["application/json;charset=utf-8"],"parameters":[{"in":"body","name":"body","required":true,"schema":{"$ref":"#/definitions/User"}}],"produces":["application/json;charset=utf-8"],"responses":{"200":{"description":"","schema":{"$ref":"#/definitions/UserId"}},"400":{"description":"Invalid `body`"}},"tags":["post"]}},"/{user_id}":{"get":{"parameters":[{"in":"path","name":"user_id","required":true,"type":"integer"}],"produces":["application/json;charset=utf-8"],"responses":{"200":{"description":"","schema":{"$ref":"#/definitions/User"}},"400":{"description":"Invalid `user_id`"}},"tags":["get"]}}},"swagger":"2.0","tags":[{"description":"GET operations","name":"get"},{"description":"POST operations","name":"post"}]} +-- +-- This applies @\"get\"@ tag to the @GET@ endpoints and @\"post\"@ tag to the @POST@ endpoint of the User API. + +-- $test +-- Automatic generation of data schemas uses @'ToSchema'@ instances for the types +-- used in a servant API. But to encode/decode actual data servant uses different classes. +-- For instance in @UserAPI@ @User@ is always encoded/decoded using @'ToJSON'@ and @'FromJSON'@ instances. +-- +-- To be sure your Haskell server/client handles data properly you need to check +-- that @'ToJSON'@ instance always generates values that satisfy schema produced +-- by @'ToSchema'@ instance. +-- +-- With @'validateEveryToJSON'@ it is possible to test all those instances automatically, +-- without having to write down every type: +-- +-- >>> instance Arbitrary User where arbitrary = User <$> arbitrary <*> arbitrary +-- >>> instance Arbitrary UserId where arbitrary = UserId <$> arbitrary +-- >>> hspec $ validateEveryToJSON (Proxy :: Proxy UserAPI) +-- +-- [User] +-- ... +-- User +-- ... +-- UserId +-- ... +-- Finished in ... seconds +-- 3 examples, 0 failures +-- +-- Although servant is great, chances are that your API clients don't use Haskell. +-- In many cases @swagger.json@ serves as a specification, not a Haskell type. +-- +-- In this cases it is a good idea to store generated and annotated @'Swagger'@ 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 @'Swagger'@ specification. +-- +-- See for an example of a server. diff --git a/servant-swagger/src/Servant/Swagger/Internal.hs b/servant-swagger/src/Servant/Swagger/Internal.hs new file mode 100644 index 00000000..c4cc2780 --- /dev/null +++ b/servant-swagger/src/Servant/Swagger/Internal.hs @@ -0,0 +1,477 @@ +{-# 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.Swagger.Internal where + +import Prelude () +import Prelude.Compat + +import Control.Applicative ((<|>)) +import Control.Lens +import Data.Aeson +import Data.HashMap.Strict.InsOrd (InsOrdHashMap) +import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap +import Data.Foldable (toList) +import Data.Proxy +import Data.Typeable +import Data.Singletons.Bool +import Data.Swagger hiding (Header) +import qualified Data.Swagger as Swagger +import Data.Swagger.Declare +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.Swagger.Internal.TypeLevel.API + +-- | Generate a Swagger specification for a servant API. +-- +-- To generate Swagger 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 +-- +-- mySwagger :: Swagger +-- mySwagger = toSwagger (Proxy :: Proxy MyAPI) +-- @ +class HasSwagger api where + -- | Generate a Swagger specification for a servant API. + toSwagger :: Proxy api -> Swagger + +instance HasSwagger Raw where + toSwagger _ = mempty & paths . at "/" ?~ mempty + +instance HasSwagger EmptyAPI where + toSwagger _ = 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, HasSwagger sub) => + Proxy sub -- ^ Part of a servant API. + -> Proxy api -- ^ The whole servant API. + -> Traversal' Swagger Operation +subOperations sub _ = operationsOf (toSwagger sub) + +-- | Make a singleton Swagger 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, SwaggerMethod method, KnownNat status) + => FilePath -- ^ Endpoint path. + -> proxy (Verb method status cs (Headers hs a)) -- ^ Method, content-types, headers and response. + -> Swagger +mkEndpoint path proxy + = mkEndpointWithSchemaRef (Just ref) path proxy + & definitions .~ defs + where + (defs, ref) = runDeclare (declareSchemaRef (Proxy :: Proxy a)) mempty + +-- | Make a singletone 'Swagger' spec (with only one endpoint) and with no content schema. +mkEndpointNoContent :: forall nocontent cs hs proxy method status. + (AllAccept cs, AllToResponseHeader hs, SwaggerMethod method, KnownNat status) + => FilePath -- ^ Endpoint path. + -> proxy (Verb method status cs (Headers hs nocontent)) -- ^ Method, content-types, headers and response. + -> Swagger +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, SwaggerMethod method, KnownNat status) + => Maybe (Referenced Schema) + -> FilePath + -> proxy (Verb method status cs (Headers hs a)) + -> Swagger +mkEndpointWithSchemaRef mref path _ = mempty + & paths.at path ?~ + (mempty & method ?~ (mempty + & produces ?~ MimeList responseContentTypes + & at code ?~ Inline (mempty + & schema .~ mref + & headers .~ responseHeaders))) + where + method = swaggerMethod (Proxy :: Proxy method) + code = fromIntegral (natVal (Proxy :: Proxy status)) + responseContentTypes = allContentType (Proxy :: Proxy cs) + responseHeaders = toAllResponseHeaders (Proxy :: Proxy hs) + +mkEndpointNoContentVerb :: forall proxy method. + (SwaggerMethod method) + => FilePath -- ^ Endpoint path. + -> proxy (NoContentVerb method) -- ^ Method + -> Swagger +mkEndpointNoContentVerb path _ = mempty + & paths.at path ?~ + (mempty & method ?~ (mempty + & at code ?~ Inline mempty)) + where + method = swaggerMethod (Proxy :: Proxy method) + code = 204 -- hardcoded in servant-server + +-- | Add parameter to every operation in the spec. +addParam :: Param -> Swagger -> Swagger +addParam param = allOperations.parameters %~ (Inline param :) + +-- | Add accepted content types to every operation in the spec. +addConsumes :: [MediaType] -> Swagger -> Swagger +addConsumes cs = allOperations.consumes %~ (<> Just (MimeList cs)) + +-- | Format given text as inline code in Markdown. +markdownCode :: Text -> Text +markdownCode s = "`" <> s <> "`" + +addDefaultResponse400 :: ParamName -> Swagger -> Swagger +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 Swagger. +class SwaggerMethod method where + swaggerMethod :: proxy method -> Lens' PathItem (Maybe Operation) + +instance SwaggerMethod 'GET where swaggerMethod _ = get +instance SwaggerMethod 'PUT where swaggerMethod _ = put +instance SwaggerMethod 'POST where swaggerMethod _ = post +instance SwaggerMethod 'DELETE where swaggerMethod _ = delete +instance SwaggerMethod 'OPTIONS where swaggerMethod _ = options +instance SwaggerMethod 'HEAD where swaggerMethod _ = head_ +instance SwaggerMethod 'PATCH where swaggerMethod _ = patch + +instance HasSwagger (UVerb method cs '[]) where + toSwagger _ = mempty + +-- | @since +instance + {-# OVERLAPPABLE #-} + ( ToSchema a, + HasStatus a, + AllAccept cs, + SwaggerMethod method, + HasSwagger (UVerb method cs as) + ) => + HasSwagger (UVerb method cs (a ': as)) + where + toSwagger _ = + toSwagger (Proxy :: Proxy (Verb method (StatusOf a) cs a)) + `combineSwagger` toSwagger (Proxy :: Proxy (UVerb method cs as)) + +-- ATTENTION: do not remove this instance! +-- A similar instance above will always use the more general +-- polymorphic -- HasSwagger instance and will result in a type error +-- since 'NoContent' does not have a 'ToSchema' instance. +instance + ( KnownNat status, + AllAccept cs, + SwaggerMethod method, + HasSwagger (UVerb method cs as) + ) => + HasSwagger (UVerb method cs (WithStatus status NoContent ': as)) + where + toSwagger _ = + toSwagger (Proxy :: Proxy (Verb method status cs NoContent)) + `combineSwagger` toSwagger (Proxy :: Proxy (UVerb method cs as)) + + +-- workaround for https://github.com/GetShopTV/swagger2/issues/218 +-- We'd like to juse use (<>) but the instances are wrong +combinePathItem :: PathItem -> PathItem -> PathItem +combinePathItem s t = PathItem + { _pathItemGet = _pathItemGet s <> _pathItemGet t + , _pathItemPut = _pathItemPut s <> _pathItemPut t + , _pathItemPost = _pathItemPost s <> _pathItemPost t + , _pathItemDelete = _pathItemDelete s <> _pathItemDelete t + , _pathItemOptions = _pathItemOptions s <> _pathItemOptions t + , _pathItemHead = _pathItemHead s <> _pathItemHead t + , _pathItemPatch = _pathItemPatch s <> _pathItemPatch t + , _pathItemParameters = _pathItemParameters s <> _pathItemParameters t + } + +combineSwagger :: Swagger -> Swagger -> Swagger +combineSwagger s t = Swagger + { _swaggerInfo = _swaggerInfo s <> _swaggerInfo t + , _swaggerHost = _swaggerHost s <|> _swaggerHost t + , _swaggerBasePath = _swaggerBasePath s <|> _swaggerBasePath t + , _swaggerSchemes = _swaggerSchemes s <> _swaggerSchemes t + , _swaggerConsumes = _swaggerConsumes s <> _swaggerConsumes t + , _swaggerProduces = _swaggerProduces s <> _swaggerProduces t + , _swaggerPaths = InsOrdHashMap.unionWith combinePathItem (_swaggerPaths s) (_swaggerPaths t) + , _swaggerDefinitions = _swaggerDefinitions s <> _swaggerDefinitions t + , _swaggerParameters = _swaggerParameters s <> _swaggerParameters t + , _swaggerResponses = _swaggerResponses s <> _swaggerResponses t + , _swaggerSecurityDefinitions = _swaggerSecurityDefinitions s <> _swaggerSecurityDefinitions t + , _swaggerSecurity = _swaggerSecurity s <> _swaggerSecurity t + , _swaggerTags = _swaggerTags s <> _swaggerTags t + , _swaggerExternalDocs = _swaggerExternalDocs s <|> _swaggerExternalDocs t + } + +instance {-# OVERLAPPABLE #-} (ToSchema a, AllAccept cs, KnownNat status, SwaggerMethod method) => HasSwagger (Verb method status cs a) where + toSwagger _ = toSwagger (Proxy :: Proxy (Verb method status cs (Headers '[] a))) + +-- | @since 1.1.7 +instance (ToSchema a, Accept ct, KnownNat status, SwaggerMethod method) => HasSwagger (Stream method status fr ct a) where + toSwagger _ = toSwagger (Proxy :: Proxy (Verb method status '[ct] (Headers '[] a))) + +instance {-# OVERLAPPABLE #-} (ToSchema a, AllAccept cs, AllToResponseHeader hs, KnownNat status, SwaggerMethod method) + => HasSwagger (Verb method status cs (Headers hs a)) where + toSwagger = mkEndpoint "/" + +-- ATTENTION: do not remove this instance! +-- A similar instance above will always use the more general +-- polymorphic -- HasSwagger instance and will result in a type error +-- since 'NoContent' does not have a 'ToSchema' instance. +instance (AllAccept cs, KnownNat status, SwaggerMethod method) => HasSwagger (Verb method status cs NoContent) where + toSwagger _ = toSwagger (Proxy :: Proxy (Verb method status cs (Headers '[] NoContent))) + +instance (AllAccept cs, AllToResponseHeader hs, KnownNat status, SwaggerMethod method) + => HasSwagger (Verb method status cs (Headers hs NoContent)) where + toSwagger = mkEndpointNoContent "/" + +instance (SwaggerMethod method) => HasSwagger (NoContentVerb method) where + toSwagger = mkEndpointNoContentVerb "/" + +instance (HasSwagger a, HasSwagger b) => HasSwagger (a :<|> b) where + toSwagger _ = toSwagger (Proxy :: Proxy a) <> toSwagger (Proxy :: Proxy b) + +-- | @'Vault'@ combinator does not change our specification at all. +instance (HasSwagger sub) => HasSwagger (Vault :> sub) where + toSwagger _ = toSwagger (Proxy :: Proxy sub) + +-- | @'IsSecure'@ combinator does not change our specification at all. +instance (HasSwagger sub) => HasSwagger (IsSecure :> sub) where + toSwagger _ = toSwagger (Proxy :: Proxy sub) + +-- | @'RemoteHost'@ combinator does not change our specification at all. +instance (HasSwagger sub) => HasSwagger (RemoteHost :> sub) where + toSwagger _ = toSwagger (Proxy :: Proxy sub) + +-- | @'Fragment'@ combinator does not change our specification at all. +instance HasSwagger sub => HasSwagger (Fragment a :> sub) where + toSwagger _ = toSwagger (Proxy :: Proxy sub) + +-- | @'HttpVersion'@ combinator does not change our specification at all. +instance (HasSwagger sub) => HasSwagger (HttpVersion :> sub) where + toSwagger _ = toSwagger (Proxy :: Proxy sub) + +-- | @'WithNamedContext'@ combinator does not change our specification at all. +instance (HasSwagger sub) => HasSwagger (WithNamedContext x c sub) where + toSwagger _ = toSwagger (Proxy :: Proxy sub) + +instance (KnownSymbol sym, HasSwagger sub) => HasSwagger (sym :> sub) where + toSwagger _ = prependPath piece (toSwagger (Proxy :: Proxy sub)) + where + piece = symbolVal (Proxy :: Proxy sym) + +instance (KnownSymbol sym, Typeable a, ToParamSchema a, HasSwagger sub, KnownSymbol (FoldDescription mods)) => HasSwagger (Capture' mods sym a :> sub) where + toSwagger _ = toSwagger (Proxy :: Proxy sub) + & addParam param + & prependPath capture + & addDefaultResponse400 tname + where + symbol = symbolVal (Proxy :: Proxy sym) + pname = if symbol == "" + then camelTo2 '-' . tyConName . typeRepTyCon $ typeRep (Proxy :: Proxy a) + else symbol + 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 + & schema .~ ParamOther (mempty + & in_ .~ ParamPath + & paramSchema .~ toParamSchema (Proxy :: Proxy a)) + +-- | Swagger Spec doesn't have a notion of CaptureAll, this instance is the best effort. +instance (KnownSymbol sym, Typeable a, ToParamSchema a, HasSwagger sub) => HasSwagger (CaptureAll sym a :> sub) where + toSwagger _ = toSwagger (Proxy :: Proxy (Capture sym a :> sub)) + +instance (KnownSymbol desc, HasSwagger api) => HasSwagger (Description desc :> api) where + toSwagger _ = toSwagger (Proxy :: Proxy api) + & allOperations.description %~ (Just (Text.pack (symbolVal (Proxy :: Proxy desc))) <>) + +instance (KnownSymbol desc, HasSwagger api) => HasSwagger (Summary desc :> api) where + toSwagger _ = toSwagger (Proxy :: Proxy api) + & allOperations.summary %~ (Just (Text.pack (symbolVal (Proxy :: Proxy desc))) <>) + +instance (KnownSymbol sym, ToParamSchema a, HasSwagger sub, SBoolI (FoldRequired mods), KnownSymbol (FoldDescription mods)) => HasSwagger (QueryParam' mods sym a :> sub) where + toSwagger _ = toSwagger (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)) + & schema .~ ParamOther sch + sch = mempty + & in_ .~ ParamQuery + & paramSchema .~ toParamSchema (Proxy :: Proxy a) + +instance (KnownSymbol sym, ToParamSchema a, HasSwagger sub) => HasSwagger (QueryParams sym a :> sub) where + toSwagger _ = toSwagger (Proxy :: Proxy sub) + & addParam param + & addDefaultResponse400 tname + where + tname = Text.pack (symbolVal (Proxy :: Proxy sym)) + param = mempty + & name .~ tname + & schema .~ ParamOther sch + sch = mempty + & in_ .~ ParamQuery + & paramSchema .~ pschema + pschema = mempty +#if MIN_VERSION_swagger2(2,4,0) + & type_ ?~ SwaggerArray +#else + & type_ .~ SwaggerArray +#endif + & items ?~ SwaggerItemsPrimitive (Just CollectionMulti) (toParamSchema (Proxy :: Proxy a)) + +instance (KnownSymbol sym, HasSwagger sub) => HasSwagger (QueryFlag sym :> sub) where + toSwagger _ = toSwagger (Proxy :: Proxy sub) + & addParam param + & addDefaultResponse400 tname + where + tname = Text.pack (symbolVal (Proxy :: Proxy sym)) + param = mempty + & name .~ tname + & schema .~ ParamOther (mempty + & in_ .~ ParamQuery + & allowEmptyValue ?~ True + & paramSchema .~ (toParamSchema (Proxy :: Proxy Bool) + & default_ ?~ toJSON False)) + +instance (KnownSymbol sym, ToParamSchema a, HasSwagger sub, SBoolI (FoldRequired mods), KnownSymbol (FoldDescription mods)) => HasSwagger (Header' mods sym a :> sub) where + toSwagger _ = toSwagger (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)) + & schema .~ ParamOther (mempty + & in_ .~ ParamHeader + & paramSchema .~ toParamSchema (Proxy :: Proxy a)) + +instance (ToSchema a, AllAccept cs, HasSwagger sub, KnownSymbol (FoldDescription mods)) => HasSwagger (ReqBody' mods cs a :> sub) where + toSwagger _ = toSwagger (Proxy :: Proxy sub) + & addParam param + & addConsumes (allContentType (Proxy :: Proxy cs)) + & addDefaultResponse400 tname + & definitions %~ (<> defs) + where + tname = "body" + transDesc "" = Nothing + transDesc desc = Just (Text.pack desc) + (defs, ref) = runDeclare (declareSchemaRef (Proxy :: Proxy a)) mempty + param = mempty + & name .~ tname + & description .~ transDesc (reflectDescription (Proxy :: Proxy mods)) + & required ?~ True + & schema .~ ParamBody ref + +-- | This instance is an approximation. +-- +-- @since 1.1.7 +instance (ToSchema a, Accept ct, HasSwagger sub, KnownSymbol (FoldDescription mods)) => HasSwagger (StreamBody' mods fr ct a :> sub) where + toSwagger _ = toSwagger (Proxy :: Proxy sub) + & addParam param + & addConsumes (toList (contentTypes (Proxy :: Proxy ct))) + & addDefaultResponse400 tname + & definitions %~ (<> defs) + where + tname = "body" + transDesc "" = Nothing + transDesc desc = Just (Text.pack desc) + (defs, ref) = runDeclare (declareSchemaRef (Proxy :: Proxy a)) mempty + param = mempty + & name .~ tname + & description .~ transDesc (reflectDescription (Proxy :: Proxy mods)) + & required ?~ True + & schema .~ ParamBody ref + +-- ======================================================================= +-- 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, Swagger.Header) + +instance (KnownSymbol sym, ToParamSchema a) => ToResponseHeader (Header sym a) where + toResponseHeader _ = (hname, Swagger.Header Nothing hschema) + where + hname = Text.pack (symbolVal (Proxy :: Proxy sym)) + hschema = toParamSchema (Proxy :: Proxy a) + +class AllToResponseHeader hs where + toAllResponseHeaders :: Proxy hs -> InsOrdHashMap HeaderName Swagger.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/servant-swagger/src/Servant/Swagger/Internal/Orphans.hs b/servant-swagger/src/Servant/Swagger/Internal/Orphans.hs new file mode 100644 index 00000000..22263eca --- /dev/null +++ b/servant-swagger/src/Servant/Swagger/Internal/Orphans.hs @@ -0,0 +1,27 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +module Servant.Swagger.Internal.Orphans where + +import Data.Proxy + (Proxy (..)) +import Data.Swagger +import Servant.Types.SourceT + (SourceT) +#if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0) +import Servant.API (WithStatus(..)) +#endif + +-- | Pretend that 'SourceT m a' is '[a]'. +-- +-- @since 1.1.7 +-- +instance ToSchema a => ToSchema (SourceT m a) where + declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a]) + +#if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0) +-- @since 1.1.11 +deriving instance ToSchema a => ToSchema (WithStatus s a) +#endif diff --git a/servant-swagger/src/Servant/Swagger/Internal/Test.hs b/servant-swagger/src/Servant/Swagger/Internal/Test.hs new file mode 100644 index 00000000..0fecb0a1 --- /dev/null +++ b/servant-swagger/src/Servant/Swagger/Internal/Test.hs @@ -0,0 +1,205 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE OverloadedStrings #-} +module Servant.Swagger.Internal.Test where + +import Data.Aeson (ToJSON (..)) +import Data.Aeson.Encode.Pretty (encodePretty', defConfig, + confCompare) +import Data.Swagger (Pattern, ToSchema, + toSchema) +import Data.Swagger.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.Swagger.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 Swagger 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" +-- } +-- +-- Swagger Schema: +-- { +-- "properties": { +-- "name": { +-- "type": "string" +-- }, +-- "phone": { +-- "type": "integer" +-- } +-- }, +-- "required": [ +-- "name", +-- "phone" +-- ], +-- "type": "object" +-- } +-- +-- +-- FIXME: this belongs in "Data.Swagger.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 + , "" + , "Swagger Schema:" + , ppJSONString (toJSON schema) + ] + where + ppJSONString = TL.unpack . TL.decodeUtf8 . encodePretty' ppCfg + ppCfg = defConfig { confCompare = compare } + + 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/servant-swagger/src/Servant/Swagger/Internal/TypeLevel.hs b/servant-swagger/src/Servant/Swagger/Internal/TypeLevel.hs new file mode 100644 index 00000000..f050c117 --- /dev/null +++ b/servant-swagger/src/Servant/Swagger/Internal/TypeLevel.hs @@ -0,0 +1,9 @@ +module Servant.Swagger.Internal.TypeLevel ( + module Servant.Swagger.Internal.TypeLevel.API, + module Servant.Swagger.Internal.TypeLevel.Every, + module Servant.Swagger.Internal.TypeLevel.TMap, +) where + +import Servant.Swagger.Internal.TypeLevel.API +import Servant.Swagger.Internal.TypeLevel.Every +import Servant.Swagger.Internal.TypeLevel.TMap diff --git a/servant-swagger/src/Servant/Swagger/Internal/TypeLevel/API.hs b/servant-swagger/src/Servant/Swagger/Internal/TypeLevel/API.hs new file mode 100644 index 00000000..818e378b --- /dev/null +++ b/servant-swagger/src/Servant/Swagger/Internal/TypeLevel/API.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +module Servant.Swagger.Internal.TypeLevel.API where + +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/servant-swagger/src/Servant/Swagger/Internal/TypeLevel/Every.hs b/servant-swagger/src/Servant/Swagger/Internal/TypeLevel/Every.hs new file mode 100644 index 00000000..b1d64b0e --- /dev/null +++ b/servant-swagger/src/Servant/Swagger/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.Swagger.Internal.TypeLevel.Every where + +import Data.Proxy +import GHC.Exts (Constraint) + +import Servant.Swagger.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/servant-swagger/src/Servant/Swagger/Internal/TypeLevel/TMap.hs b/servant-swagger/src/Servant/Swagger/Internal/TypeLevel/TMap.hs new file mode 100644 index 00000000..d2aa3b04 --- /dev/null +++ b/servant-swagger/src/Servant/Swagger/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.Swagger.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/servant-swagger/src/Servant/Swagger/Test.hs b/servant-swagger/src/Servant/Swagger/Test.hs new file mode 100644 index 00000000..7fa2e406 --- /dev/null +++ b/servant-swagger/src/Servant/Swagger/Test.hs @@ -0,0 +1,13 @@ +-- | +-- Module: Servant.Swagger.Test +-- License: BSD3 +-- Maintainer: Nickolay Kudasov +-- Stability: experimental +-- +-- Automatic tests for servant API against Swagger spec. +module Servant.Swagger.Test ( + validateEveryToJSON, + validateEveryToJSONWithPatternChecker, +) where + +import Servant.Swagger.Internal.Test diff --git a/servant-swagger/src/Servant/Swagger/TypeLevel.hs b/servant-swagger/src/Servant/Swagger/TypeLevel.hs new file mode 100644 index 00000000..89b8af93 --- /dev/null +++ b/servant-swagger/src/Servant/Swagger/TypeLevel.hs @@ -0,0 +1,15 @@ +-- | +-- Module: Servant.Swagger.TypeLevel +-- License: BSD3 +-- Maintainer: Nickolay Kudasov +-- Stability: experimental +-- +-- Useful type families for servant APIs. +module Servant.Swagger.TypeLevel ( + IsSubAPI, + EndpointsList, + BodyTypes, +) where + +import Servant.Swagger.Internal.TypeLevel + diff --git a/servant-swagger/test/Servant/SwaggerSpec.hs b/servant-swagger/test/Servant/SwaggerSpec.hs new file mode 100644 index 00000000..c422c95c --- /dev/null +++ b/servant-swagger/test/Servant/SwaggerSpec.hs @@ -0,0 +1,489 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE PackageImports #-} +module Servant.SwaggerSpec where + +import Control.Lens +import Data.Aeson (ToJSON(toJSON), Value, genericToJSON) +import Data.Aeson.QQ.Simple +import qualified Data.Aeson.Types as JSON +import Data.Char (toLower) +import Data.Int (Int64) +import Data.Proxy +import Data.Swagger +import Data.Text (Text) +import Data.Time +import GHC.Generics +import Servant.API +import Servant.Swagger +import Servant.Test.ComprehensiveAPI (comprehensiveAPI) +import Test.Hspec hiding (example) + +#if !MIN_VERSION_swagger2(2,4,0) +import Data.Aeson.Lens (key, _Array) +import qualified Data.Vector as V +#endif + +checkAPI :: HasSwagger api => Proxy api -> Value -> IO () +checkAPI proxy = checkSwagger (toSwagger proxy) + +checkSwagger :: Swagger -> Value -> IO () +checkSwagger swag js = toJSON swag `shouldBe` js + +spec :: Spec +spec = describe "HasSwagger" $ do + it "Todo API" $ checkAPI (Proxy :: Proxy TodoAPI) todoAPI + it "Hackage API (with tags)" $ checkSwagger hackageSwaggerWithTags hackageAPI + it "GetPost API (test subOperations)" $ checkSwagger getPostSwagger getPostAPI + it "UVerb API" $ checkSwagger uverbSwagger uverbAPI + it "Comprehensive API" $ do + let _x = toSwagger 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| +{ + "swagger":"2.0", + "info": + { + "title": "", + "version": "" + }, + "definitions": + { + "Todo": + { + "type": "object", + "required": [ "created", "title" ], + "properties": + { + "created": { "$ref": "#/definitions/UTCTime" }, + "title": { "type": "string" }, + "summary": { "type": "string" } + } + }, + "UTCTime": + { + "type": "string", + "format": "yyyy-mm-ddThh:MM:ssZ", + "example": "2016-07-22T00:00:00Z" + } + }, + "paths": + { + "/todo/{id}": + { + "get": + { + "responses": + { + "200": + { + "schema": { "$ref":"#/definitions/Todo" }, + "description": "" + }, + "400": { "description": "Invalid `id`" } + }, + "produces": [ "application/json;charset=utf-8" ], + "parameters": + [ + { + "required": true, + "in": "path", + "name": "id", + "type": "string" + } + ] + } + } + } +} +|] + +-- ======================================================================= +-- 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 + +hackageSwaggerWithTags :: Swagger +hackageSwaggerWithTags = toSwagger (Proxy :: Proxy HackageAPI) + & host ?~ Host "hackage.haskell.org" Nothing + & applyTagsFor usersOps ["users" & description ?~ "Operations about user"] + & applyTagsFor packagesOps ["packages" & description ?~ "Query packages"] + where + usersOps, packagesOps :: Traversal' Swagger Operation + usersOps = subOperations (Proxy :: Proxy HackageUserAPI) (Proxy :: Proxy HackageAPI) + packagesOps = subOperations (Proxy :: Proxy HackagePackagesAPI) (Proxy :: Proxy HackageAPI) + +hackageAPI :: Value +hackageAPI = modifyValue [aesonQQ| +{ + "swagger":"2.0", + "host":"hackage.haskell.org", + "info":{ + "version":"", + "title":"" + }, + "definitions":{ + "UserDetailed":{ + "required":[ + "username", + "userid", + "groups" + ], + "type":"object", + "properties":{ + "groups":{ + "items":{ + "type":"string" + }, + "type":"array" + }, + "username":{ + "type":"string" + }, + "userid":{ + "maximum":9223372036854775807, + "minimum":-9223372036854775808, + "type":"integer", + "format":"int64" + } + } + }, + "Package":{ + "required":[ + "packageName" + ], + "type":"object", + "properties":{ + "packageName":{ + "type":"string" + } + } + }, + "UserSummary":{ + "required":[ + "username", + "userid" + ], + "type":"object", + "properties":{ + "username":{ + "type":"string" + }, + "userid":{ + "maximum":9223372036854775807, + "minimum":-9223372036854775808, + "type":"integer", + "format":"int64" + } + }, + "example":{ + "username": "JohnDoe", + "userid": 123 + } + } + }, + "paths":{ + "/users":{ + "get":{ + "responses":{ + "200":{ + "schema":{ + "items":{ + "$ref":"#/definitions/UserSummary" + }, + "type":"array" + }, + "description":"" + } + }, + "produces":[ + "application/json;charset=utf-8" + ], + "tags":[ + "users" + ] + } + }, + "/packages":{ + "get":{ + "responses":{ + "200":{ + "schema":{ + "items":{ + "$ref":"#/definitions/Package" + }, + "type":"array" + }, + "description":"" + } + }, + "produces":[ + "application/json;charset=utf-8" + ], + "tags":[ + "packages" + ] + } + }, + "/user/{username}":{ + "get":{ + "responses":{ + "400":{ + "description":"Invalid `username`" + }, + "200":{ + "schema":{ + "$ref":"#/definitions/UserDetailed" + }, + "description":"" + } + }, + "produces":[ + "application/json;charset=utf-8" + ], + "parameters":[ + { + "required":true, + "in":"path", + "name":"username", + "type":"string" + } + ], + "tags":[ + "users" + ] + } + } + }, + "tags":[ + { + "name":"users", + "description":"Operations about user" + }, + { + "name":"packages", + "description":"Query packages" + } + ] +} +|] + where + modifyValue :: Value -> Value +#if MIN_VERSION_swagger2(2,4,0) + modifyValue = id +#else + -- swagger2-2.4 preserves order of tags + -- swagger2-2.3 used Set, so they are ordered + -- packages comes before users. + -- We simply reverse, not properly sort here for simplicity: 2 elements. + modifyValue = over (key "tags" . _Array) V.reverse +#endif + + +-- ======================================================================= +-- Get/Post API (test for subOperations) +-- ======================================================================= + +type GetPostAPI = Get '[JSON] String :<|> Post '[JSON] String + +getPostSwagger :: Swagger +getPostSwagger = toSwagger (Proxy :: Proxy GetPostAPI) + & applyTagsFor getOps ["get" & description ?~ "GET operations"] + where + getOps :: Traversal' Swagger Operation + getOps = subOperations (Proxy :: Proxy (Get '[JSON] String)) (Proxy :: Proxy GetPostAPI) + +getPostAPI :: Value +getPostAPI = [aesonQQ| +{ + "swagger":"2.0", + "info":{ + "version":"", + "title":"" + }, + "paths":{ + "/":{ + "post":{ + "responses":{ + "200":{ + "schema":{ + "type":"string" + }, + "description":"" + } + }, + "produces":[ "application/json;charset=utf-8" ] + }, + "get":{ + "responses":{ + "200":{ + "schema":{ + "type":"string" + }, + "description":"" + } + }, + "produces":[ "application/json;charset=utf-8" ], + "tags":[ "get" ] + } + } + }, + "tags":[ + { + "name":"get", + "description":"GET operations" + } + ] +} +|] + +-- ======================================================================= +-- UVerb API +-- ======================================================================= + +data Lunch = Lunch {name :: String} + deriving (Eq, Show, Generic) + +instance ToSchema Lunch + +instance HasStatus Lunch where + type StatusOf Lunch = 200 + +data NoLunch = NoLunch + deriving (Eq, Show, Generic) + +instance ToSchema NoLunch + +instance HasStatus NoLunch where + type StatusOf NoLunch = 404 + +type UVerbAPI2 = + "lunch" :> UVerb 'GET '[JSON] '[Lunch, NoLunch] + +uverbSwagger :: Swagger +uverbSwagger = toSwagger (Proxy :: Proxy UVerbAPI2) + +uverbAPI :: Value +uverbAPI = + [aesonQQ| + { + "swagger": "2.0", + "info": { + "version": "", + "title": "" + }, + "definitions": { + "Lunch": { + "required": [ + "name" + ], + "type": "object", + "properties": { + "name": { + "type": "string" + } + } + }, + "NoLunch": { + "type": "string", + "enum": [ + "NoLunch" + ] + } + }, + "paths": { + "/lunch": { + "get": { + "responses": { + "404": { + "schema": { + "$ref": "#/definitions/NoLunch" + }, + "description": "" + }, + "200": { + "schema": { + "$ref": "#/definitions/Lunch" + }, + "description": "" + } + }, + "produces": [ + "application/json;charset=utf-8" + ] + } + } + } +} +|] diff --git a/servant-swagger/test/Spec.hs b/servant-swagger/test/Spec.hs new file mode 100644 index 00000000..a824f8c3 --- /dev/null +++ b/servant-swagger/test/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/servant-swagger/test/doctests.hs b/servant-swagger/test/doctests.hs new file mode 100644 index 00000000..aff961f5 --- /dev/null +++ b/servant-swagger/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 ++ module_sources diff --git a/servant/servant.cabal b/servant/servant.cabal index 4c23da32..7b7e3150 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -99,7 +99,7 @@ library -- Here can be exceptions if we really need features from the newer versions. build-depends: base-compat >= 0.10.5 && < 0.12 - , aeson >= 1.4.1.0 && < 1.6 + , aeson >= 1.4.1.0 && < 3 , attoparsec >= 0.13.2.2 && < 0.15 , bifunctors >= 5.5.3 && < 5.6 , case-insensitive >= 1.2.0.11 && < 1.3