eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

Merge pull request #1475 from akhesaCaro/aeson_2

Browse source 
support Aeson 2
This commit is contained in:
Caroline GAUDREAU 2021-11-26 17:25:56 +01:00 committed by GitHub
commit 9a3979926d
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
35 changed files with 2382 additions and 16 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
cabal.project
View file

@ -12,6 +12,7 @@ packages:
servant-docs/ servant-docs/
servant-foreign/ servant-foreign/
servant-server/ servant-server/
servant-swagger/
doc/tutorial/ doc/tutorial/
-- servant streaming -- servant streaming

4
servant-auth/servant-auth-client/servant-auth-client.cabal
View file

@ -64,7 +64,7 @@ test-suite spec
build-depends: build-depends:
hspec >= 2.5.5 && < 2.9 hspec >= 2.5.5 && < 2.9
, QuickCheck >= 2.11.3 && < 2.15 , 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 , bytestring >= 0.10.6.0 && < 0.11
, http-client >= 0.5.13.1 && < 0.8 , http-client >= 0.5.13.1 && < 0.8
, http-types >= 0.12.2 && < 0.13 , http-types >= 0.12.2 && < 0.13
@ -74,7 +74,7 @@ test-suite spec
, transformers >= 0.4.2.0 && < 0.6 , transformers >= 0.4.2.0 && < 0.6
, wai >= 3.2.1.2 && < 3.3 , wai >= 3.2.1.2 && < 3.3
, warp >= 3.2.25 && < 3.4 , warp >= 3.2.25 && < 3.4
, jose >= 0.7.0.0 && < 0.9 , jose >= 0.7.0.0 && < 0.10
other-modules: other-modules:
Servant.Auth.ClientSpec Servant.Auth.ClientSpec
default-language: Haskell2010 default-language: Haskell2010

6
servant-auth/servant-auth-server/servant-auth-server.cabal
View file

@ -32,8 +32,8 @@ library
ghc-options: -Wall ghc-options: -Wall
build-depends: build-depends:
base >= 4.10 && < 4.16 base >= 4.10 && < 4.16
, aeson >= 1.3.1.1 && < 1.6 , aeson >= 1.0.0.1 && < 3
, base64-bytestring >= 1.0.0.1 && < 1.3 , base64-bytestring >= 1.0.0.1 && < 2
, blaze-builder >= 0.4.1.0 && < 0.5 , blaze-builder >= 0.4.1.0 && < 0.5
, bytestring >= 0.10.6.0 && < 0.11 , bytestring >= 0.10.6.0 && < 0.11
, case-insensitive >= 1.2.0.11 && < 1.3 , case-insensitive >= 1.2.0.11 && < 1.3
@ -41,7 +41,7 @@ library
, data-default-class >= 0.1.2.0 && < 0.2 , data-default-class >= 0.1.2.0 && < 0.2
, entropy >= 0.4.1.3 && < 0.5 , entropy >= 0.4.1.3 && < 0.5
, http-types >= 0.12.2 && < 0.13 , 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 , lens >= 4.16.1 && < 5.1
, memory >= 0.14.16 && < 0.17 , memory >= 0.14.16 && < 0.17
, monad-time >= 0.3.1.0 && < 0.4 , monad-time >= 0.3.1.0 && < 0.4

4
servant-auth/servant-auth-swagger/servant-auth-swagger.cabal
View file

@ -33,8 +33,8 @@ library
build-depends: build-depends:
base >= 4.10 && < 4.16 base >= 4.10 && < 4.16
, text >= 1.2.3.0 && < 1.3 , text >= 1.2.3.0 && < 1.3
, servant-swagger >= 1.1.5 && < 1.8 , servant-swagger >= 1.1.5 && < 2
, swagger2 >= 2.2.2 && < 2.7 , swagger2 >= 2.2.2 && < 3
, servant >= 0.13 && < 0.19 , servant >= 0.13 && < 0.19
, servant-auth == 0.4.* , servant-auth == 0.4.*
, lens >= 4.16.1 && < 5.1 , lens >= 4.16.1 && < 5.1

5
servant-auth/servant-auth/servant-auth.cabal
View file

@ -34,8 +34,9 @@ library
ghc-options: -Wall ghc-options: -Wall
build-depends: build-depends:
base >= 4.10 && < 4.16 base >= 4.10 && < 4.16
, aeson >= 1.3.1.1 && < 1.6 , containers >= 0.6 && < 0.7
, jose >= 0.7.0.0 && < 0.9 , aeson >= 1.3.1.1 && < 3
, jose >= 0.7.0.0 && < 0.10
, lens >= 4.16.1 && < 5.1 , lens >= 4.16.1 && < 5.1
, servant >= 0.15 && < 0.19 , servant >= 0.15 && < 0.19
, text >= 1.2.3.0 && < 1.3 , text >= 1.2.3.0 && < 1.3

11
servant-auth/servant-auth/src/Servant/Auth/JWT.hs
View file

@ -1,10 +1,17 @@
{-# LANGUAGE CPP #-}
module Servant.Auth.JWT where module Servant.Auth.JWT where
import Control.Lens ((^.)) import Control.Lens ((^.))
import qualified Crypto.JWT as Jose import qualified Crypto.JWT as Jose
import Data.Aeson (FromJSON, Result (..), ToJSON, fromJSON, import Data.Aeson (FromJSON, Result (..), ToJSON, fromJSON,
toJSON) 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 import qualified Data.Text as T
@ -17,7 +24,7 @@ import qualified Data.Text as T
class FromJWT a where class FromJWT a where
decodeJWT :: Jose.ClaimsSet -> Either T.Text a decodeJWT :: Jose.ClaimsSet -> Either T.Text a
default decodeJWT :: FromJSON a => 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" Nothing -> Left "Missing 'dat' claim"
Just v -> case fromJSON v of Just v -> case fromJSON v of
Error e -> Left $ T.pack e Error e -> Left $ T.pack e

2
servant-client-core/servant-client-core.cabal
View file

@ -70,7 +70,7 @@ library
-- Other dependencies: Lower bound around what is in the latest Stackage LTS. -- 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. -- Here can be exceptions if we really need features from the newer versions.
build-depends: build-depends:
aeson >= 1.4.1.0 && < 1.6 aeson >= 1.4.1.0 && < 3
, base-compat >= 0.10.5 && < 0.12 , base-compat >= 0.10.5 && < 0.12
, base64-bytestring >= 1.0.0.1 && < 1.3 , base64-bytestring >= 1.0.0.1 && < 1.3
, exceptions >= 0.10.0 && < 0.11 , exceptions >= 0.10.0 && < 0.11

2
servant-docs/servant-docs.cabal
View file

@ -52,7 +52,7 @@ library
-- Other dependencies: Lower bound around what is in the latest Stackage LTS. -- 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. -- Here can be exceptions if we really need features from the newer versions.
build-depends: build-depends:
aeson >= 1.4.1.0 && < 1.6 aeson >= 1.4.1.0 && < 3
, aeson-pretty >= 0.8.5 && < 0.9 , aeson-pretty >= 0.8.5 && < 0.9
, base-compat >= 0.10.5 && < 0.12 , base-compat >= 0.10.5 && < 0.12
, case-insensitive >= 1.2.0.11 && < 1.3 , case-insensitive >= 1.2.0.11 && < 1.3

4
servant-server/servant-server.cabal
View file

@ -114,7 +114,7 @@ executable greet
, text , text
build-depends: build-depends:
aeson >= 1.4.1.0 && < 1.6 aeson >= 1.4.1.0 && < 3
, warp >= 3.2.25 && < 3.4 , warp >= 3.2.25 && < 3.4
test-suite spec test-suite spec
@ -157,7 +157,7 @@ test-suite spec
-- Additional dependencies -- Additional dependencies
build-depends: build-depends:
aeson >= 1.4.1.0 && < 1.6 aeson >= 1.4.1.0 && < 3
, directory >= 1.3.0.0 && < 1.4 , directory >= 1.3.0.0 && < 1.4
, hspec >= 2.6.0 && < 2.9 , hspec >= 2.6.0 && < 2.9
, hspec-wai >= 0.10.1 && < 0.12 , hspec-wai >= 0.10.1 && < 0.12

143
servant-swagger/CHANGELOG.md Normal file
View file

@ -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.

28
servant-swagger/LICENSE Normal file
View file

@ -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.

46
servant-swagger/README.md Normal file
View file

@ -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).

33
servant-swagger/Setup.hs Normal file
View file

@ -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

28
servant-swagger/example/LICENSE Normal file
View file

@ -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.

62
servant-swagger/example/example.cabal Normal file
View file

@ -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

11
servant-swagger/example/server/Main.hs Normal file
View file

@ -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

73
servant-swagger/example/src/Todo.hs Normal file
View file

@ -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)

158
servant-swagger/example/swagger.json Normal file
View file

@ -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"
]
}
}
}
}

1
servant-swagger/example/test/Spec.hs Normal file
View file

@ -0,0 +1 @@
{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

28
servant-swagger/example/test/TodoSpec.hs Normal file
View file

@ -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

126
servant-swagger/servant-swagger.cabal Normal file
View file

@ -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

186
servant-swagger/src/Servant/Swagger.hs Normal file
View file

@ -0,0 +1,186 @@
-- |
-- Module: Servant.Swagger
-- License: BSD3
-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
-- 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 <http://swagger.io/ Swagger documentation>.
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)
-- <BLANKLINE>
-- [User]
-- ...
-- User
-- ...
-- UserId
-- ...
-- Finished in ... seconds
-- 3 examples, 0 failures
--
-- Although servant is great, chances are that your API clients don't use Haskell.
-- In many cases @swagger.json@ serves as a specification, not a Haskell type.
--
-- In this cases it is a good idea to store generated and annotated @'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 <example/test/TodoSpec.hs TodoSpec.hs> for an example of a complete test suite for a swagger specification.
-- $serve
-- If you're implementing a server for an API, you might also want to serve its @'Swagger'@ specification.
--
-- See <example/src/Todo.hs Todo.hs> for an example of a server.

477
servant-swagger/src/Servant/Swagger/Internal.hs Normal file
View file

@ -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 <http://hackage.haskell.org/package/swagger2/docs/Data-Swagger.html swagger2 documentation>.
--
-- Example:
--
-- @
-- newtype Username = Username String deriving (Generic, ToText)
--
-- instance ToParamSchema Username
--
-- data User = User
-- { username :: Username
-- , fullname :: String
-- } deriving (Generic)
--
-- instance ToJSON User
-- instance ToSchema User
--
-- type MyAPI = QueryParam "username" Username :> Get '[JSON] User
--
-- 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 <TODO>
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)

27
servant-swagger/src/Servant/Swagger/Internal/Orphans.hs Normal file
View file

@ -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

205
servant-swagger/src/Servant/Swagger/Internal/Test.hs Normal file
View file

@ -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)
-- <BLANKLINE>
-- ToJSON matches ToSchema
-- User
-- ...
-- UserId
-- ...
-- Finished in ... seconds
-- 2 examples, 0 failures
--
-- For the test to compile all body types should have the following instances:
--
-- * @'ToJSON'@ and @'ToSchema'@ are used to perform the validation;
-- * @'Typeable'@ is used to name the test for each type;
-- * @'Show'@ is used to display value for which @'ToJSON'@ does not satisfy @'ToSchema'@.
-- * @'Arbitrary'@ is used to arbitrarily generate values.
--
-- If any of the instances is missing, you'll get a descriptive type error:
--
-- >>> data Contact = Contact { fullname :: String, phone :: Integer } deriving (Show, Generic)
-- >>> instance ToJSON Contact
-- >>> instance ToSchema Contact
-- >>> type ContactAPI = Get '[JSON] Contact
-- >>> hspec $ validateEveryToJSON (Proxy :: Proxy ContactAPI)
-- ...
-- ...No instance for (Arbitrary Contact)
-- ... arising from a use of ‘validateEveryToJSON’
-- ...
validateEveryToJSON
:: forall proxy api .
TMap (Every [Typeable, Show, Arbitrary, ToJSON, ToSchema])
(BodyTypes JSON api)
=> proxy api -- ^ Servant API.
-> Spec
validateEveryToJSON _ = props
(Proxy :: Proxy [ToJSON, ToSchema])
(maybeCounterExample . prettyValidateWith validateToJSON)
(Proxy :: Proxy (BodyTypes JSON api))
-- | Verify that every type used with @'JSON'@ content type in a servant API
-- has compatible @'ToJSON'@ and @'ToSchema'@ instances using @'validateToJSONWithPatternChecker'@.
--
-- For validation without patterns see @'validateEveryToJSON'@.
validateEveryToJSONWithPatternChecker :: forall proxy api. TMap (Every [Typeable, Show, Arbitrary, ToJSON, ToSchema]) (BodyTypes JSON api) =>
(Pattern -> Text -> Bool) -- ^ @'Pattern'@ checker.
-> proxy api -- ^ Servant API.
-> Spec
validateEveryToJSONWithPatternChecker checker _ = props
(Proxy :: Proxy [ToJSON, ToSchema])
(maybeCounterExample . prettyValidateWith (validateToJSONWithPatternChecker checker))
(Proxy :: Proxy (BodyTypes JSON api))
-- * QuickCheck-related stuff
-- | Construct property tests for each type in a list.
-- The name for each property is the name of the corresponding type.
--
-- >>> :{
-- hspec $
-- context "read . show == id" $
-- props
-- (Proxy :: Proxy [Eq, Show, Read])
-- (\x -> read (show x) === x)
-- (Proxy :: Proxy [Bool, Int, String])
-- :}
-- <BLANKLINE>
-- read . show == id
-- Bool
-- ...
-- Int
-- ...
-- [Char]
-- ...
-- Finished in ... seconds
-- 3 examples, 0 failures
props :: forall p p'' cs xs. TMap (Every (Typeable ': Show ': Arbitrary ': cs)) xs =>
p cs -- ^ A list of constraints.
-> (forall x. EveryTF cs x => x -> Property) -- ^ Property predicate.
-> p'' xs -- ^ A list of types.
-> Spec
props _ f px = sequence_ specs
where
specs :: [Spec]
specs = tmapEvery (Proxy :: Proxy (Typeable ': Show ': Arbitrary ': cs)) aprop px
aprop :: forall p' a. (EveryTF cs a, Typeable a, Show a, Arbitrary a) => p' a -> Spec
aprop _ = prop (show (typeOf (undefined :: a))) (f :: a -> Property)
-- | Pretty print validation errors
-- together with actual JSON and 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\"}"
-- <BLANKLINE>
-- JSON value:
-- {
-- "name": "John"
-- }
-- <BLANKLINE>
-- Swagger Schema:
-- {
-- "properties": {
-- "name": {
-- "type": "string"
-- },
-- "phone": {
-- "type": "integer"
-- }
-- },
-- "required": [
-- "name",
-- "phone"
-- ],
-- "type": "object"
-- }
-- <BLANKLINE>
--
-- 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)

9
servant-swagger/src/Servant/Swagger/Internal/TypeLevel.hs Normal file
View file

@ -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

86
servant-swagger/src/Servant/Swagger/Internal/TypeLevel/API.hs Normal file
View file

@ -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 = '[]

63
servant-swagger/src/Servant/Swagger/Internal/TypeLevel/Every.hs Normal file
View file

@ -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))

37
servant-swagger/src/Servant/Swagger/Internal/TypeLevel/TMap.hs Normal file
View file

@ -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)

13
servant-swagger/src/Servant/Swagger/Test.hs Normal file
View file

@ -0,0 +1,13 @@
-- |
-- Module: Servant.Swagger.Test
-- License: BSD3
-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
-- Stability: experimental
--
-- Automatic tests for servant API against Swagger spec.
module Servant.Swagger.Test (
validateEveryToJSON,
validateEveryToJSONWithPatternChecker,
) where
import Servant.Swagger.Internal.Test

15
servant-swagger/src/Servant/Swagger/TypeLevel.hs Normal file
View file

@ -0,0 +1,15 @@
-- |
-- Module: Servant.Swagger.TypeLevel
-- License: BSD3
-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
-- Stability: experimental
--
-- Useful type families for servant APIs.
module Servant.Swagger.TypeLevel (
IsSubAPI,
EndpointsList,
BodyTypes,
) where
import Servant.Swagger.Internal.TypeLevel

489
servant-swagger/test/Servant/SwaggerSpec.hs Normal file
View file

@ -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"
]
}
}
}
}
|]

1
servant-swagger/test/Spec.hs Normal file
View file

@ -0,0 +1 @@
{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

12
servant-swagger/test/doctests.hs Normal file
View file

@ -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

2
servant/servant.cabal
View file

@ -99,7 +99,7 @@ library
-- Here can be exceptions if we really need features from the newer versions. -- Here can be exceptions if we really need features from the newer versions.
build-depends: build-depends:
base-compat >= 0.10.5 && < 0.12 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 , attoparsec >= 0.13.2.2 && < 0.15
, bifunctors >= 5.5.3 && < 5.6 , bifunctors >= 5.5.3 && < 5.6
, case-insensitive >= 1.2.0.11 && < 1.3 , case-insensitive >= 1.2.0.11 && < 1.3