Caroline GAUDREAU
GitHub
commit
9a3979926d
35 changed files with 2382 additions and 16 deletions
|
|
@ -12,6 +12,7 @@ packages:
|
|||
servant-docs/
|
||||
servant-foreign/
|
||||
servant-server/
|
||||
servant-swagger/
|
||||
doc/tutorial/
|
||||
|
||||
-- servant streaming
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
143
servant-swagger/CHANGELOG.md
Normal file
143
servant-swagger/CHANGELOG.md
Normal 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
28
servant-swagger/LICENSE
Normal 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
46
servant-swagger/README.md
Normal file
|
|
@ -0,0 +1,46 @@
|
|||
# servant-swagger
|
||||
|
||||
[](http://hackage.haskell.org/package/servant-swagger)
|
||||
[](http://stackage.org/lts/package/servant-swagger)
|
||||
[](http://stackage.org/nightly/package/servant-swagger)
|
||||
|
||||
Swagger 2.0 conforming json for [servant](https://github.com/haskell-servant/servant) APIs.
|
||||
|
||||
|
||||
|
||||
### Motivation
|
||||
|
||||
Swagger is a project used to describe and document RESTful APIs.
|
||||
Unlike Servant it is language-agnostic and thus is quite popular among developers
|
||||
in different languages. It also exists for a longer time and has more tools to work with.
|
||||
|
||||
This package provides means to generate Swagger specification for a Servant API
|
||||
and also to partially test whether API conforms with its specification.
|
||||
|
||||
Generated Swagger specification then can be used for many things such as
|
||||
- displaying interactive documentation using [Swagger UI](http://swagger.io/swagger-ui/);
|
||||
- generating clients and servers in many languages using [Swagger Codegen](http://swagger.io/swagger-codegen/);
|
||||
- and [many others](http://swagger.io/open-source-integrations/).
|
||||
|
||||
### Usage
|
||||
|
||||
Please refer to [haddock documentation](http://hackage.haskell.org/package/servant/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
33
servant-swagger/Setup.hs
Normal 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
28
servant-swagger/example/LICENSE
Normal 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
62
servant-swagger/example/example.cabal
Normal 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
11
servant-swagger/example/server/Main.hs
Normal 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
73
servant-swagger/example/src/Todo.hs
Normal 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
158
servant-swagger/example/swagger.json
Normal 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
1
servant-swagger/example/test/Spec.hs
Normal file
|
|
@ -0,0 +1 @@
|
|||
{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
|
||||
28
servant-swagger/example/test/TodoSpec.hs
Normal file
28
servant-swagger/example/test/TodoSpec.hs
Normal 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
126
servant-swagger/servant-swagger.cabal
Normal 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
186
servant-swagger/src/Servant/Swagger.hs
Normal 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
477
servant-swagger/src/Servant/Swagger/Internal.hs
Normal 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
27
servant-swagger/src/Servant/Swagger/Internal/Orphans.hs
Normal 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
205
servant-swagger/src/Servant/Swagger/Internal/Test.hs
Normal 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)
|
||||
|
|
@ -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
|
||||
|
|
@ -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 = '[]
|
||||
|
||||
|
|
@ -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))
|
||||
|
|
@ -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
13
servant-swagger/src/Servant/Swagger/Test.hs
Normal 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
15
servant-swagger/src/Servant/Swagger/TypeLevel.hs
Normal 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
489
servant-swagger/test/Servant/SwaggerSpec.hs
Normal 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
1
servant-swagger/test/Spec.hs
Normal file
|
|
@ -0,0 +1 @@
|
|||
{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
|
||||
12
servant-swagger/test/doctests.hs
Normal file
12
servant-swagger/test/doctests.hs
Normal 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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue