git.iko.soy/typeable/servant
on master help sign in
Merge pull request #1475 from akhesaCaro/aeson_2

support Aeson 2

commit9a3979926d622faeb014f34dae077ddcd46a8db7 authorCaroline GAUDREAU <caroline.gaudreau@gmail.com> dateFri 26 Nov 2021, 17:25 (5 years ago) parent3ed24fd05ef0dd
35 files changed+2382−16
compare with master
unifiedsplit
cabal.project+1 servant-auth/servant-auth-client/servant-auth-client.cabal+2−2 servant-auth/servant-auth-server/servant-auth-server.cabal+3−3 servant-auth/servant-auth-swagger/servant-auth-swagger.cabal+2−2 servant-auth/servant-auth/servant-auth.cabal+3−2 servant-auth/servant-auth/src/Servant/Auth/JWT.hs+9−2 servant-client-core/servant-client-core.cabal+1−1 servant-docs/servant-docs.cabal+1−1 servant-server/servant-server.cabal+2−2 servant-swagger/CHANGELOG.md+143 servant-swagger/LICENSE+28 servant-swagger/README.md+46 servant-swagger/Setup.hs+33 servant-swagger/example/LICENSE+28 servant-swagger/example/example.cabal+62 servant-swagger/example/server/Main.hs+11 servant-swagger/example/src/Todo.hs+73 servant-swagger/example/swagger.json+158 servant-swagger/example/test/Spec.hs+1 servant-swagger/example/test/TodoSpec.hs+28 servant-swagger/servant-swagger.cabal+126 servant-swagger/src/Servant/Swagger.hs+186 servant-swagger/src/Servant/Swagger/Internal.hs+477 servant-swagger/src/Servant/Swagger/Internal/Orphans.hs+27 servant-swagger/src/Servant/Swagger/Internal/Test.hs+205 servant-swagger/src/Servant/Swagger/Internal/TypeLevel.hs+9 servant-swagger/src/Servant/Swagger/Internal/TypeLevel/API.hs+86 servant-swagger/src/Servant/Swagger/Internal/TypeLevel/Every.hs+63 servant-swagger/src/Servant/Swagger/Internal/TypeLevel/TMap.hs+37 servant-swagger/src/Servant/Swagger/Test.hs+13 servant-swagger/src/Servant/Swagger/TypeLevel.hs+15 servant-swagger/test/Servant/SwaggerSpec.hs+489 servant-swagger/test/Spec.hs+1 servant-swagger/test/doctests.hs+12 servant/servant.cabal+1−1
cabal.project+1
@@ -12,6 +12,7 @@ packages:
1212 servant-docs/
1313 servant-foreign/
1414 servant-server/
15+ servant-swagger/
1516 doc/tutorial/
1617
1718-- servant streaming
servant-auth/servant-auth-client/servant-auth-client.cabal+2−2
@@ -64,7 +64,7 @@ test-suite spec
6464 build-depends:
6565 hspec >= 2.5.5 && < 2.9
6666 , QuickCheck >= 2.11.3 && < 2.15
67− , aeson >= 1.3.1.1 && < 1.6
67+ , aeson >= 1.3.1.1 && < 3
6868 , bytestring >= 0.10.6.0 && < 0.11
6969 , http-client >= 0.5.13.1 && < 0.8
7070 , http-types >= 0.12.2 && < 0.13
@@ -74,7 +74,7 @@ test-suite spec
7474 , transformers >= 0.4.2.0 && < 0.6
7575 , wai >= 3.2.1.2 && < 3.3
7676 , warp >= 3.2.25 && < 3.4
77− , jose >= 0.7.0.0 && < 0.9
77+ , jose >= 0.7.0.0 && < 0.10
7878 other-modules:
7979 Servant.Auth.ClientSpec
8080 default-language: Haskell2010
servant-auth/servant-auth-server/servant-auth-server.cabal+3−3
@@ -32,8 +32,8 @@ library
3232 ghc-options: -Wall
3333 build-depends:
3434 base >= 4.10 && < 4.16
35− , aeson >= 1.3.1.1 && < 1.6
36− , base64-bytestring >= 1.0.0.1 && < 1.3
35+ , aeson >= 1.0.0.1 && < 3
36+ , base64-bytestring >= 1.0.0.1 && < 2
3737 , blaze-builder >= 0.4.1.0 && < 0.5
3838 , bytestring >= 0.10.6.0 && < 0.11
3939 , case-insensitive >= 1.2.0.11 && < 1.3
@@ -41,7 +41,7 @@ library
4141 , data-default-class >= 0.1.2.0 && < 0.2
4242 , entropy >= 0.4.1.3 && < 0.5
4343 , http-types >= 0.12.2 && < 0.13
44− , jose >= 0.7.0.0 && < 0.9
44+ , jose >= 0.7.0.0 && < 0.10
4545 , lens >= 4.16.1 && < 5.1
4646 , memory >= 0.14.16 && < 0.17
4747 , monad-time >= 0.3.1.0 && < 0.4
servant-auth/servant-auth-swagger/servant-auth-swagger.cabal+2−2
@@ -33,8 +33,8 @@ library
3333 build-depends:
3434 base >= 4.10 && < 4.16
3535 , text >= 1.2.3.0 && < 1.3
36− , servant-swagger >= 1.1.5 && < 1.8
37− , swagger2 >= 2.2.2 && < 2.7
36+ , servant-swagger >= 1.1.5 && < 2
37+ , swagger2 >= 2.2.2 && < 3
3838 , servant >= 0.13 && < 0.19
3939 , servant-auth == 0.4.*
4040 , lens >= 4.16.1 && < 5.1
servant-auth/servant-auth/servant-auth.cabal+3−2
@@ -34,8 +34,9 @@ library
3434 ghc-options: -Wall
3535 build-depends:
3636 base >= 4.10 && < 4.16
37− , aeson >= 1.3.1.1 && < 1.6
38− , jose >= 0.7.0.0 && < 0.9
37+ , containers >= 0.6 && < 0.7
38+ , aeson >= 1.3.1.1 && < 3
39+ , jose >= 0.7.0.0 && < 0.10
3940 , lens >= 4.16.1 && < 5.1
4041 , servant >= 0.15 && < 0.19
4142 , text >= 1.2.3.0 && < 1.3
servant-auth/servant-auth/src/Servant/Auth/JWT.hs+9−2
@@ -1,10 +1,17 @@
1+{-# LANGUAGE CPP #-}
2+
13module Servant.Auth.JWT where
24
35import Control.Lens ((^.))
46import qualified Crypto.JWT as Jose
57import Data.Aeson (FromJSON, Result (..), ToJSON, fromJSON,
68 toJSON)
7−import qualified Data.HashMap.Strict as HM
9+#if MIN_VERSION_aeson(2,0,0)
10+import qualified Data.Map as KM
11+#else
12+import qualified Data.HashMap.Strict as KM
13+#endif
14+
815import qualified Data.Text as T
916
1017
@@ -17,7 +24,7 @@ import qualified Data.Text as T
1724class FromJWT a where
1825 decodeJWT :: Jose.ClaimsSet -> Either T.Text a
1926 default decodeJWT :: FromJSON a => Jose.ClaimsSet -> Either T.Text a
20− decodeJWT m = case HM.lookup "dat" (m ^. Jose.unregisteredClaims) of
27+ decodeJWT m = case KM.lookup "dat" (m ^. Jose.unregisteredClaims) of
2128 Nothing -> Left "Missing 'dat' claim"
2229 Just v -> case fromJSON v of
2330 Error e -> Left $ T.pack e
servant-client-core/servant-client-core.cabal+1−1
@@ -70,7 +70,7 @@ library
7070 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.
7171 -- Here can be exceptions if we really need features from the newer versions.
7272 build-depends:
73− aeson >= 1.4.1.0 && < 1.6
73+ aeson >= 1.4.1.0 && < 3
7474 , base-compat >= 0.10.5 && < 0.12
7575 , base64-bytestring >= 1.0.0.1 && < 1.3
7676 , exceptions >= 0.10.0 && < 0.11
servant-docs/servant-docs.cabal+1−1
@@ -52,7 +52,7 @@ library
5252 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.
5353 -- Here can be exceptions if we really need features from the newer versions.
5454 build-depends:
55− aeson >= 1.4.1.0 && < 1.6
55+ aeson >= 1.4.1.0 && < 3
5656 , aeson-pretty >= 0.8.5 && < 0.9
5757 , base-compat >= 0.10.5 && < 0.12
5858 , case-insensitive >= 1.2.0.11 && < 1.3
servant-server/servant-server.cabal+2−2
@@ -114,7 +114,7 @@ executable greet
114114 , text
115115
116116 build-depends:
117− aeson >= 1.4.1.0 && < 1.6
117+ aeson >= 1.4.1.0 && < 3
118118 , warp >= 3.2.25 && < 3.4
119119
120120test-suite spec
@@ -157,7 +157,7 @@ test-suite spec
157157
158158 -- Additional dependencies
159159 build-depends:
160− aeson >= 1.4.1.0 && < 1.6
160+ aeson >= 1.4.1.0 && < 3
161161 , directory >= 1.3.0.0 && < 1.4
162162 , hspec >= 2.6.0 && < 2.9
163163 , hspec-wai >= 0.10.1 && < 0.12
servant-swagger/CHANGELOG.mdnew file+143
@@ -0,0 +1,143 @@
1+1.1.9
2+-------
3+
4+* Support `servant-0.18`
5+
6+1.1.8
7+-------
8+
9+* Support `servant-0.17`
10+
11+1.1.7.1
12+-------
13+
14+* Support `swagger2-2.4`
15+
16+1.1.7
17+-----
18+
19+* Support servant-0.15
20+ - support for 'Stream' and 'StreamBody' combinators
21+ - orphan 'ToSchema (SourceT m a)' instance
22+* Fix BodyTypes to work with generalized ReqBody'
23+ [#88](https://github.com/haskell-servant/servant-swagger/pull/88)
24+
25+1.1.6
26+-----
27+
28+* Fixes:
29+ * `validateEveryToJSON` now prints validation errors
30+
31+* Notes:
32+ * GHC-8.6 compatible release
33+
34+1.1.5
35+-----
36+
37+* Notes:
38+ * `servant-0.13` compatible release
39+ * Drops compatibility with previous `servant` versions.
40+
41+1.1.4
42+-----
43+
44+* Notes:
45+ * `servant-0.12` compatible release
46+
47+1.1.3.1
48+---
49+
50+* Notes:
51+ * GHC-8.2 compatible release
52+
53+1.1.3
54+---
55+
56+* Notes:
57+ * `servant-0.11` compatible release
58+
59+1.1.2.1
60+---
61+
62+* Notes:
63+ * `servant-0.10` compatible release
64+
65+1.1.2
66+---
67+
68+* Minor fixes:
69+ * Support for aeson-1, insert-ordered-containers-0.2
70+ * CaptureAll instance
71+
72+1.1.1
73+---
74+
75+* Minor fixes:
76+ * Fix `unused-imports` and `unused-foralls` warnings;
77+ * Fix tests to match `swagger2-2.1.1` (add `example` property for `UTCTime` schema).
78+
79+1.1
80+---
81+
82+* Breaking changes:
83+ * Requires `swagger2 >= 2.1`
84+ * Requires `servant >= 0.5`
85+
86+* Notes:
87+ * GHC-8.0 compatible release
88+
89+1.0.3
90+---
91+
92+* Fixes:
93+ * Improve compile-time performance of `BodyTypes` even further (see [18e0d95](https://github.com/haskell-servant/servant-swagger/commit/18e0d95ef6fe9076dd9621cb515d8d1a189f71d3))!
94+
95+1.0.2
96+---
97+
98+* Minor changes:
99+ * Add GHC 7.8 support (see [#26](https://github.com/haskell-servant/servant-swagger/pull/26)).
100+
101+* Fixes:
102+ * Improve compile-time performance of `BodyTypes` (see [#25](https://github.com/haskell-servant/servant-swagger/issues/25)).
103+
104+1.0.1
105+---
106+
107+* Fixes:
108+ * Stop using `Data.Swagger.Internal`;
109+ * Documentation fixes (links to examples).
110+
111+1.0
112+---
113+
114+* Major changes (see [#24](https://github.com/haskell-servant/servant-swagger/pull/24)):
115+ * Switch to `swagger2-2.*`;
116+ * Add automatic `ToJSON`/`ToSchema` validation tests;
117+ * Add great documentation;
118+ * Export some type-level functions for servant API.
119+
120+* Minor changes:
121+ * Rework Todo API example;
122+ * Stop exporting `ToResponseHeader`, `AllAccept` and `AllToResponseHeader` (see [bd50db4](https://github.com/haskell-servant/servant-swagger/commit/bd50db48ca6a106e4366560ded70932d409de1e2));
123+ * Change maintainer, update authors/copyrights (see [1a62681](https://github.com/haskell-servant/servant-swagger/commit/1a6268101dc826a92c42e832e402e251c0d32147));
124+ * Include changelog and example files into `extra-source-files`.
125+
126+0.1.2
127+---
128+
129+* Fixes:
130+ * Fix default spec for `ReqBody` param to be required (see [#22](https://github.com/haskell-servant/servant-swagger/issues/22));
131+ * Set version bounds for `swagger2`.
132+
133+0.1.1
134+---
135+
136+* Fixes:
137+ * Fix `subOperations` to filter endpoints also by method (see [#18](https://github.com/haskell-servant/servant-swagger/issues/18));
138+ * Fix response schema in `ToSwagger` instance for `Header` (see [b59e557](https://github.com/haskell-servant/servant-swagger/commit/b59e557a05bc2669332c52b397879e7598747b82)).
139+
140+0.1
141+---
142+* Major changes
143+ * Use `swagger2` for data model (see [#9](https://github.com/dmjio/servant-swagger/pull/9)); this changes almost everything.
servant-swagger/LICENSEnew file+28
@@ -0,0 +1,28 @@
1+Copyright (c) 2015-2016, Servant contributors
2+All rights reserved.
3+
4+Redistribution and use in source and binary forms, with or without
5+modification, are permitted provided that the following conditions are met:
6+
7+* Redistributions of source code must retain the above copyright notice, this
8+ list of conditions and the following disclaimer.
9+
10+* Redistributions in binary form must reproduce the above copyright notice,
11+ this list of conditions and the following disclaimer in the documentation
12+ and/or other materials provided with the distribution.
13+
14+* Neither the name of servant-swagger nor the names of its
15+ contributors may be used to endorse or promote products derived from
16+ this software without specific prior written permission.
17+
18+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
19+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
20+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
21+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
22+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
23+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
24+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
25+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
26+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
27+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
28+
servant-swagger/README.mdnew file+46
@@ -0,0 +1,46 @@
1+# servant-swagger
2+
3+[![Hackage](https://img.shields.io/hackage/v/servant-swagger.svg)](http://hackage.haskell.org/package/servant-swagger)
4+[![Stackage LTS](http://stackage.org/package/servant-swagger/badge/lts)](http://stackage.org/lts/package/servant-swagger)
5+[![Stackage Nightly](http://stackage.org/package/servant-swagger/badge/nightly)](http://stackage.org/nightly/package/servant-swagger)
6+
7+Swagger 2.0 conforming json for [servant](https://github.com/haskell-servant/servant) APIs.
8+
9+![servant-swagger robot](http://s16.postimg.org/rndz1wbyt/servant.png)
10+
11+### Motivation
12+
13+Swagger is a project used to describe and document RESTful APIs.
14+Unlike Servant it is language-agnostic and thus is quite popular among developers
15+in different languages. It also exists for a longer time and has more tools to work with.
16+
17+This package provides means to generate Swagger specification for a Servant API
18+and also to partially test whether API conforms with its specification.
19+
20+Generated Swagger specification then can be used for many things such as
21+- displaying interactive documentation using [Swagger UI](http://swagger.io/swagger-ui/);
22+- generating clients and servers in many languages using [Swagger Codegen](http://swagger.io/swagger-codegen/);
23+- and [many others](http://swagger.io/open-source-integrations/).
24+
25+### Usage
26+
27+Please refer to [haddock documentation](http://hackage.haskell.org/package/servant/servant-swagger).
28+
29+Some examples can be found in [`example/` directory](/example).
30+
31+### Try it out
32+
33+All generated swagger specifications can be interactively viewed on [Swagger Editor](http://editor.swagger.io/).
34+
35+Ready-to-use specification can be served as JSON and interactive API documentation
36+can be displayed using [Swagger UI](https://github.com/swagger-api/swagger-ui).
37+
38+Many Swagger tools, including server and client code generation for many languages, can be found on
39+[Swagger's Tools and Integrations page](http://swagger.io/open-source-integrations/).
40+
41+### Contributing
42+
43+We are happy to receive bug reports, fixes, documentation enhancements, and other improvements.
44+
45+Please report bugs via the [github issue tracker](https://github.com/haskell-servant/servant/issues).
46+
servant-swagger/Setup.hsnew file+33
@@ -0,0 +1,33 @@
1+{-# LANGUAGE CPP #-}
2+{-# OPTIONS_GHC -Wall #-}
3+module Main (main) where
4+
5+#ifndef MIN_VERSION_cabal_doctest
6+#define MIN_VERSION_cabal_doctest(x,y,z) 0
7+#endif
8+
9+#if MIN_VERSION_cabal_doctest(1,0,0)
10+
11+import Distribution.Extra.Doctest ( defaultMainWithDoctests )
12+main :: IO ()
13+main = defaultMainWithDoctests "doctests"
14+
15+#else
16+
17+#ifdef MIN_VERSION_Cabal
18+-- If the macro is defined, we have new cabal-install,
19+-- but for some reason we don't have cabal-doctest in package-db
20+--
21+-- Probably we are running cabal sdist, when otherwise using new-build
22+-- workflow
23+#warning You are configuring this package without cabal-doctest installed. \
24+ The doctests test-suite will not work as a result. \
25+ To fix this, install cabal-doctest before configuring.
26+#endif
27+
28+import Distribution.Simple
29+
30+main :: IO ()
31+main = defaultMain
32+
33+#endif
servant-swagger/example/LICENSEnew file+28
@@ -0,0 +1,28 @@
1+Copyright (c) 2015-2016, Servant contributors
2+All rights reserved.
3+
4+Redistribution and use in source and binary forms, with or without
5+modification, are permitted provided that the following conditions are met:
6+
7+* Redistributions of source code must retain the above copyright notice, this
8+ list of conditions and the following disclaimer.
9+
10+* Redistributions in binary form must reproduce the above copyright notice,
11+ this list of conditions and the following disclaimer in the documentation
12+ and/or other materials provided with the distribution.
13+
14+* Neither the name of servant-swagger nor the names of its
15+ contributors may be used to endorse or promote products derived from
16+ this software without specific prior written permission.
17+
18+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
19+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
20+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
21+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
22+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
23+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
24+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
25+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
26+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
27+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
28+
servant-swagger/example/example.cabalnew file+62
@@ -0,0 +1,62 @@
1+name: example
2+version: 1.0
3+synopsis: servant-swagger demonstration
4+description: servant-swagger demonstration
5+license: BSD3
6+license-file: LICENSE
7+author: David Johnson, Nickolay Kudasov
8+maintainer: nickolay.kudasov@gmail.com
9+copyright: (c) 2015-2016, Servant contributors
10+category: Web
11+build-type: Simple
12+cabal-version: >=1.10
13+data-files:
14+ swagger.json
15+
16+library
17+ ghc-options: -Wall
18+ hs-source-dirs: src/
19+ exposed-modules:
20+ Todo
21+ build-depends: base
22+ , aeson
23+ , aeson-pretty
24+ , bytestring
25+ , lens
26+ , servant
27+ , servant-server
28+ , servant-swagger
29+ , swagger2
30+ , text
31+ , time
32+ default-language: Haskell2010
33+
34+executable swagger-server
35+ ghc-options: -Wall
36+ hs-source-dirs: server/
37+ main-is: Main.hs
38+ build-depends: base
39+ , example
40+ , servant-server
41+ , warp
42+ default-language: Haskell2010
43+
44+test-suite swagger-server-spec
45+ ghc-options: -Wall
46+ type: exitcode-stdio-1.0
47+ hs-source-dirs: test
48+ main-is: Spec.hs
49+ other-modules:
50+ TodoSpec
51+ Paths_example
52+ build-depends: base == 4.*
53+ , base-compat >= 0.6.0
54+ , aeson >=0.11.2.0
55+ , bytestring
56+ , example
57+ , hspec
58+ , servant-swagger
59+ , QuickCheck
60+ , quickcheck-instances
61+ default-language: Haskell2010
62+
servant-swagger/example/server/Main.hsnew file+11
@@ -0,0 +1,11 @@
1+module Main where
2+
3+import Network.Wai.Handler.Warp
4+import Servant
5+import Todo
6+
7+main :: IO ()
8+main = do
9+ putStrLn "Running on port 8000"
10+ run 8000 $ serve (Proxy :: Proxy API) server
11+
servant-swagger/example/src/Todo.hsnew file+73
@@ -0,0 +1,73 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE DeriveDataTypeable #-}
3+{-# LANGUAGE DeriveGeneric #-}
4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5+{-# LANGUAGE OverloadedStrings #-}
6+{-# LANGUAGE TypeOperators #-}
7+module Todo where
8+
9+import Control.Lens
10+import Data.Aeson
11+import Data.Aeson.Encode.Pretty (encodePretty)
12+import qualified Data.ByteString.Lazy.Char8 as BL8
13+import Data.Proxy
14+import Data.Swagger
15+import Data.Text (Text)
16+import Data.Time (UTCTime (..), fromGregorian)
17+import Data.Typeable (Typeable)
18+import GHC.Generics
19+import Servant
20+import Servant.Swagger
21+
22+todoAPI :: Proxy TodoAPI
23+todoAPI = Proxy
24+
25+-- | The API of a Todo service.
26+type TodoAPI
27+ = "todo" :> Get '[JSON] [Todo]
28+ :<|> "todo" :> ReqBody '[JSON] Todo :> Post '[JSON] TodoId
29+ :<|> "todo" :> Capture "id" TodoId :> Get '[JSON] Todo
30+ :<|> "todo" :> Capture "id" TodoId :> ReqBody '[JSON] Todo :> Put '[JSON] TodoId
31+
32+-- | API for serving @swagger.json@.
33+type SwaggerAPI = "swagger.json" :> Get '[JSON] Swagger
34+
35+-- | Combined API of a Todo service with Swagger documentation.
36+type API = SwaggerAPI :<|> TodoAPI
37+
38+-- | A single Todo entry.
39+data Todo = Todo
40+ { created :: UTCTime -- ^ Creation datetime.
41+ , summary :: Text -- ^ Task summary.
42+ } deriving (Show, Generic, Typeable)
43+
44+-- | A unique Todo entry ID.
45+newtype TodoId = TodoId Int
46+ deriving (Show, Generic, Typeable, ToJSON, FromHttpApiData)
47+
48+instance ToJSON Todo
49+instance FromJSON Todo
50+
51+instance ToSchema Todo where
52+ declareNamedSchema proxy = genericDeclareNamedSchema defaultSchemaOptions proxy
53+ & mapped.schema.description ?~ "This is some real Todo right here"
54+ & mapped.schema.example ?~ toJSON (Todo (UTCTime (fromGregorian 2015 12 31) 0) "get milk")
55+
56+instance ToParamSchema TodoId
57+instance ToSchema TodoId
58+
59+-- | Swagger spec for Todo API.
60+todoSwagger :: Swagger
61+todoSwagger = toSwagger todoAPI
62+ & info.title .~ "Todo API"
63+ & info.version .~ "1.0"
64+ & info.description ?~ "This is an API that tests swagger integration"
65+ & info.license ?~ ("MIT" & url ?~ URL "http://mit.com")
66+
67+-- | Combined server of a Todo service with Swagger documentation.
68+server :: Server API
69+server = return todoSwagger :<|> error "not implemented"
70+
71+-- | Output generated @swagger.json@ file for the @'TodoAPI'@.
72+writeSwaggerJSON :: IO ()
73+writeSwaggerJSON = BL8.writeFile "example/swagger.json" (encodePretty todoSwagger)
servant-swagger/example/swagger.jsonnew file+158
@@ -0,0 +1,158 @@
1+{
2+ "swagger": "2.0",
3+ "info": {
4+ "version": "1.0",
5+ "title": "Todo API",
6+ "license": {
7+ "url": "http://mit.com",
8+ "name": "MIT"
9+ },
10+ "description": "This is an API that tests swagger integration"
11+ },
12+ "definitions": {
13+ "Todo": {
14+ "example": {
15+ "summary": "get milk",
16+ "created": "2015-12-31T00:00:00Z"
17+ },
18+ "required": [
19+ "created",
20+ "summary"
21+ ],
22+ "type": "object",
23+ "description": "This is some real Todo right here",
24+ "properties": {
25+ "summary": {
26+ "type": "string"
27+ },
28+ "created": {
29+ "$ref": "#/definitions/UTCTime"
30+ }
31+ }
32+ },
33+ "UTCTime": {
34+ "example": "2016-07-22T00:00:00Z",
35+ "format": "yyyy-mm-ddThh:MM:ssZ",
36+ "type": "string"
37+ },
38+ "TodoId": {
39+ "maximum": 9223372036854775807,
40+ "minimum": -9223372036854775808,
41+ "type": "integer"
42+ }
43+ },
44+ "paths": {
45+ "/todo/{id}": {
46+ "get": {
47+ "responses": {
48+ "400": {
49+ "description": "Invalid `id`"
50+ },
51+ "200": {
52+ "schema": {
53+ "$ref": "#/definitions/Todo"
54+ },
55+ "description": ""
56+ }
57+ },
58+ "produces": [
59+ "application/json;charset=utf-8"
60+ ],
61+ "parameters": [
62+ {
63+ "maximum": 9223372036854775807,
64+ "minimum": -9223372036854775808,
65+ "required": true,
66+ "in": "path",
67+ "name": "id",
68+ "type": "integer"
69+ }
70+ ]
71+ },
72+ "put": {
73+ "consumes": [
74+ "application/json;charset=utf-8"
75+ ],
76+ "responses": {
77+ "400": {
78+ "description": "Invalid `body` or `id`"
79+ },
80+ "200": {
81+ "schema": {
82+ "$ref": "#/definitions/TodoId"
83+ },
84+ "description": ""
85+ }
86+ },
87+ "produces": [
88+ "application/json;charset=utf-8"
89+ ],
90+ "parameters": [
91+ {
92+ "maximum": 9223372036854775807,
93+ "minimum": -9223372036854775808,
94+ "required": true,
95+ "in": "path",
96+ "name": "id",
97+ "type": "integer"
98+ },
99+ {
100+ "required": true,
101+ "schema": {
102+ "$ref": "#/definitions/Todo"
103+ },
104+ "in": "body",
105+ "name": "body"
106+ }
107+ ]
108+ }
109+ },
110+ "/todo": {
111+ "post": {
112+ "consumes": [
113+ "application/json;charset=utf-8"
114+ ],
115+ "responses": {
116+ "400": {
117+ "description": "Invalid `body`"
118+ },
119+ "200": {
120+ "schema": {
121+ "$ref": "#/definitions/TodoId"
122+ },
123+ "description": ""
124+ }
125+ },
126+ "produces": [
127+ "application/json;charset=utf-8"
128+ ],
129+ "parameters": [
130+ {
131+ "required": true,
132+ "schema": {
133+ "$ref": "#/definitions/Todo"
134+ },
135+ "in": "body",
136+ "name": "body"
137+ }
138+ ]
139+ },
140+ "get": {
141+ "responses": {
142+ "200": {
143+ "schema": {
144+ "items": {
145+ "$ref": "#/definitions/Todo"
146+ },
147+ "type": "array"
148+ },
149+ "description": ""
150+ }
151+ },
152+ "produces": [
153+ "application/json;charset=utf-8"
154+ ]
155+ }
156+ }
157+ }
158+}
servant-swagger/example/test/Spec.hsnew file+1
@@ -0,0 +1 @@
1+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
servant-swagger/example/test/TodoSpec.hsnew file+28
@@ -0,0 +1,28 @@
1+{-# OPTIONS_GHC -fno-warn-orphans #-}
2+module TodoSpec where
3+
4+import Prelude ()
5+import Prelude.Compat
6+
7+import Data.Aeson
8+import qualified Data.ByteString.Lazy.Char8 as BL8
9+import Paths_example
10+import Servant.Swagger.Test
11+import Test.Hspec
12+import Test.QuickCheck
13+import Test.QuickCheck.Instances ()
14+import Todo
15+
16+spec :: Spec
17+spec = describe "Swagger" $ do
18+ context "ToJSON matches ToSchema" $ validateEveryToJSON todoAPI
19+ it "swagger.json is up-to-date" $ do
20+ path <- getDataFileName "swagger.json"
21+ swag <- eitherDecode <$> BL8.readFile path
22+ swag `shouldBe` Right todoSwagger
23+
24+instance Arbitrary Todo where
25+ arbitrary = Todo <$> arbitrary <*> arbitrary
26+
27+instance Arbitrary TodoId where
28+ arbitrary = TodoId <$> arbitrary
servant-swagger/servant-swagger.cabalnew file+126
@@ -0,0 +1,126 @@
1+name: servant-swagger
2+version: 1.1.11
3+synopsis: Generate a Swagger/OpenAPI/OAS 2.0 specification for your servant API.
4+description:
5+ Swagger is a project used to describe and document RESTful APIs. The core of the
6+ project is the [OpenAPI Specification (OAS)](https://swagger.io/docs/specification/about/).
7+ This library implements v2.0 of the spec. Unlike Servant it is language-agnostic and thus is
8+ quite popular among developers in different languages. It has also existed for a longer time
9+ and has more helpful tooling.
10+ .
11+ This package provides means to generate a Swagger/OAS specification for a Servant API
12+ and also to partially test whether an API conforms with its specification.
13+ .
14+ Generated Swagger specification then can be used for many things such as
15+ .
16+ * displaying interactive documentation using [Swagger UI](http://swagger.io/swagger-ui/);
17+ .
18+ * generating clients and servers in many languages using [Swagger Codegen](http://swagger.io/swagger-codegen/);
19+ .
20+ * and [many others](http://swagger.io/open-source-integrations/).
21+homepage: https://github.com/haskell-servant/servant/servant-swagger
22+bug-reports: https://github.com/haskell-servant/servant/issues
23+license: BSD3
24+license-file: LICENSE
25+author: Servant Contributors
26+maintainer: haskell-servant-maintainers@googlegroups.com
27+copyright: (c) 2015-2018, Servant contributors
28+category: Web, Servant, Swagger
29+build-type: Custom
30+cabal-version: 1.18
31+tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2
32+
33+extra-source-files:
34+ README.md
35+ , CHANGELOG.md
36+ , example/server/*.hs
37+ , example/src/*.hs
38+ , example/test/*.hs
39+ , example/*.cabal
40+ , example/swagger.json
41+ , example/LICENSE
42+extra-doc-files:
43+ example/src/*.hs
44+ , example/test/*.hs
45+
46+source-repository head
47+ type: git
48+ location: https://github.com/haskell-servant/servant.git
49+
50+custom-setup
51+ setup-depends:
52+ base >=4.9 && <5,
53+ cabal-doctest >=1.0.6 && <1.1
54+
55+library
56+ ghc-options: -Wall
57+ exposed-modules:
58+ Servant.Swagger
59+ Servant.Swagger.Test
60+ Servant.Swagger.TypeLevel
61+
62+ -- Internal modules
63+ Servant.Swagger.Internal
64+ Servant.Swagger.Internal.Orphans
65+ Servant.Swagger.Internal.Test
66+ Servant.Swagger.Internal.TypeLevel
67+ Servant.Swagger.Internal.TypeLevel.API
68+ Servant.Swagger.Internal.TypeLevel.Every
69+ Servant.Swagger.Internal.TypeLevel.TMap
70+ hs-source-dirs: src
71+ build-depends: aeson >=1.4.2.0 && <3
72+ , aeson-pretty >=0.8.7 && <0.9
73+ , base >=4.9.1.0 && <5
74+ , base-compat >=0.10.5 && <0.12
75+ , bytestring >=0.10.8.1 && <0.11
76+ , http-media >=0.7.1.3 && <0.9
77+ , insert-ordered-containers >=0.2.1.0 && <0.3
78+ , lens >=4.17 && <6
79+ , servant >=0.18.1 && <0.19
80+ , singleton-bool >=0.1.4 && <0.2
81+ , swagger2 >=2.3.0.1 && <3
82+ , text >=1.2.3.0 && <1.3
83+ , unordered-containers >=0.2.9.0 && <0.3
84+
85+ , hspec
86+ , QuickCheck
87+ default-language: Haskell2010
88+
89+test-suite doctests
90+ ghc-options: -Wall
91+ build-depends:
92+ base,
93+ directory >= 1.0,
94+ doctest >= 0.18 && <0.19,
95+ servant,
96+ QuickCheck,
97+ filepath
98+ default-language: Haskell2010
99+ hs-source-dirs: test
100+ main-is: doctests.hs
101+ type: exitcode-stdio-1.0
102+
103+test-suite spec
104+ ghc-options: -Wall
105+ type: exitcode-stdio-1.0
106+ hs-source-dirs: test
107+ main-is: Spec.hs
108+ build-tool-depends: hspec-discover:hspec-discover >=2.6.0 && <2.8
109+ build-depends: base
110+ , base-compat
111+ , aeson >=1.4.2.0 && <3
112+ , hspec >=2.6.0 && <2.8
113+ , QuickCheck
114+ , lens
115+ , lens-aeson >=1.0.2 && <1.2
116+ , servant
117+ , servant-swagger
118+ , swagger2
119+ , text
120+ , template-haskell
121+ , utf8-string >=1.0.1.1 && <1.1
122+ , time
123+ , vector
124+ other-modules:
125+ Servant.SwaggerSpec
126+ default-language: Haskell2010
servant-swagger/src/Servant/Swagger.hsnew file+186
@@ -0,0 +1,186 @@
1+-- |
2+-- Module: Servant.Swagger
3+-- License: BSD3
4+-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
5+-- Stability: experimental
6+--
7+-- This module provides means to generate and manipulate
8+-- Swagger specification for servant APIs.
9+--
10+-- Swagger is a project used to describe and document RESTful APIs.
11+--
12+-- The Swagger specification defines a set of files required to describe such an API.
13+-- These files can then be used by the Swagger-UI project to display the API
14+-- and Swagger-Codegen to generate clients in various languages.
15+-- Additional utilities can also take advantage of the resulting files, such as testing tools.
16+--
17+-- For more information see <http://swagger.io/ Swagger documentation>.
18+module Servant.Swagger (
19+ -- * How to use this library
20+ -- $howto
21+
22+ -- ** Generate @'Swagger'@
23+ -- $generate
24+
25+ -- ** Annotate
26+ -- $annotate
27+
28+ -- ** Test
29+ -- $test
30+
31+ -- ** Serve
32+ -- $serve
33+
34+ -- * @'HasSwagger'@ class
35+ HasSwagger(..),
36+
37+ -- * Manipulation
38+ subOperations,
39+
40+ -- * Testing
41+ validateEveryToJSON,
42+ validateEveryToJSONWithPatternChecker,
43+) where
44+
45+import Servant.Swagger.Internal
46+import Servant.Swagger.Test
47+import Servant.Swagger.Internal.Orphans ()
48+
49+-- $setup
50+-- >>> import Control.Applicative
51+-- >>> import Control.Lens
52+-- >>> import Data.Aeson
53+-- >>> import Data.Aeson.Encode.Pretty
54+-- >>> import Data.Swagger
55+-- >>> import Data.Typeable
56+-- >>> import GHC.Generics
57+-- >>> import Servant.API
58+-- >>> import Test.Hspec
59+-- >>> import Test.QuickCheck
60+-- >>> import qualified Data.ByteString.Lazy.Char8 as BSL8
61+-- >>> :set -XDataKinds
62+-- >>> :set -XDeriveDataTypeable
63+-- >>> :set -XDeriveGeneric
64+-- >>> :set -XGeneralizedNewtypeDeriving
65+-- >>> :set -XOverloadedStrings
66+-- >>> :set -XTypeOperators
67+-- >>> data User = User { name :: String, age :: Int } deriving (Show, Generic, Typeable)
68+-- >>> newtype UserId = UserId Integer deriving (Show, Generic, Typeable, ToJSON)
69+-- >>> instance ToJSON User
70+-- >>> instance ToSchema User
71+-- >>> instance ToSchema UserId
72+-- >>> instance ToParamSchema UserId
73+-- >>> type GetUsers = Get '[JSON] [User]
74+-- >>> type GetUser = Capture "user_id" UserId :> Get '[JSON] User
75+-- >>> type PostUser = ReqBody '[JSON] User :> Post '[JSON] UserId
76+-- >>> type UserAPI = GetUsers :<|> GetUser :<|> PostUser
77+-- >>> orderedKeys = encodePretty' (defConfig { confCompare = compare, confIndent = Spaces 0 })
78+
79+-- $howto
80+--
81+-- This section explains how to use this library to generate Swagger specification,
82+-- modify it and run automatic tests for a servant API.
83+--
84+-- For the purposes of this section we will use this servant API:
85+--
86+-- >>> data User = User { name :: String, age :: Int } deriving (Show, Generic, Typeable)
87+-- >>> newtype UserId = UserId Integer deriving (Show, Generic, Typeable, ToJSON)
88+-- >>> instance ToJSON User
89+-- >>> instance ToSchema User
90+-- >>> instance ToSchema UserId
91+-- >>> instance ToParamSchema UserId
92+-- >>> type GetUsers = Get '[JSON] [User]
93+-- >>> type GetUser = Capture "user_id" UserId :> Get '[JSON] User
94+-- >>> type PostUser = ReqBody '[JSON] User :> Post '[JSON] UserId
95+-- >>> type UserAPI = GetUsers :<|> GetUser :<|> PostUser
96+--
97+-- Here we define a user API with three endpoints. @GetUsers@ endpoint returns a list of all users.
98+-- @GetUser@ returns a user given his\/her ID. @PostUser@ creates a new user and returns his\/her ID.
99+
100+-- $generate
101+-- In order to generate @'Swagger'@ specification for a servant API, just use @'toSwagger'@:
102+--
103+-- >>> BSL8.putStrLn . orderedKeys $ toSwagger (Proxy :: Proxy UserAPI)
104+-- {"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"}
105+--
106+-- By default @'toSwagger'@ will generate specification for all API routes, parameters, headers, responses and data schemas.
107+--
108+-- For some parameters it will also add 400 responses with a description mentioning parameter name.
109+--
110+-- Data schemas come from @'ToParamSchema'@ and @'ToSchema'@ classes.
111+
112+-- $annotate
113+-- While initially generated @'Swagger'@ looks good, it lacks some information it can't get from a servant API.
114+--
115+-- We can add this information using field lenses from @"Data.Swagger"@:
116+--
117+-- >>> :{
118+-- BSL8.putStrLn $ orderedKeys $ toSwagger (Proxy :: Proxy UserAPI)
119+-- & info.title .~ "User API"
120+-- & info.version .~ "1.0"
121+-- & info.description ?~ "This is an API for the Users service"
122+-- & info.license ?~ "MIT"
123+-- & host ?~ "example.com"
124+-- :}
125+-- {"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"}
126+--
127+-- It is also useful to annotate or modify certain endpoints.
128+-- @'subOperations'@ provides a convenient way to zoom into a part of an API.
129+--
130+-- @'subOperations' sub api@ traverses all operations of the @api@ which are also present in @sub@.
131+-- Furthermore, @sub@ is required to be an exact sub API of @api. Otherwise it will not typecheck.
132+--
133+-- @"Data.Swagger.Operation"@ provides some useful helpers that can be used with @'subOperations'@.
134+-- One example is applying tags to certain endpoints:
135+--
136+-- >>> let getOps = subOperations (Proxy :: Proxy (GetUsers :<|> GetUser)) (Proxy :: Proxy UserAPI)
137+-- >>> let postOps = subOperations (Proxy :: Proxy PostUser) (Proxy :: Proxy UserAPI)
138+-- >>> :{
139+-- BSL8.putStrLn $ orderedKeys $ toSwagger (Proxy :: Proxy UserAPI)
140+-- & applyTagsFor getOps ["get" & description ?~ "GET operations"]
141+-- & applyTagsFor postOps ["post" & description ?~ "POST operations"]
142+-- :}
143+-- {"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"}]}
144+--
145+-- This applies @\"get\"@ tag to the @GET@ endpoints and @\"post\"@ tag to the @POST@ endpoint of the User API.
146+
147+-- $test
148+-- Automatic generation of data schemas uses @'ToSchema'@ instances for the types
149+-- used in a servant API. But to encode/decode actual data servant uses different classes.
150+-- For instance in @UserAPI@ @User@ is always encoded/decoded using @'ToJSON'@ and @'FromJSON'@ instances.
151+--
152+-- To be sure your Haskell server/client handles data properly you need to check
153+-- that @'ToJSON'@ instance always generates values that satisfy schema produced
154+-- by @'ToSchema'@ instance.
155+--
156+-- With @'validateEveryToJSON'@ it is possible to test all those instances automatically,
157+-- without having to write down every type:
158+--
159+-- >>> instance Arbitrary User where arbitrary = User <$> arbitrary <*> arbitrary
160+-- >>> instance Arbitrary UserId where arbitrary = UserId <$> arbitrary
161+-- >>> hspec $ validateEveryToJSON (Proxy :: Proxy UserAPI)
162+-- <BLANKLINE>
163+-- [User]
164+-- ...
165+-- User
166+-- ...
167+-- UserId
168+-- ...
169+-- Finished in ... seconds
170+-- 3 examples, 0 failures
171+--
172+-- Although servant is great, chances are that your API clients don't use Haskell.
173+-- In many cases @swagger.json@ serves as a specification, not a Haskell type.
174+--
175+-- In this cases it is a good idea to store generated and annotated @'Swagger'@ in a @swagger.json@ file
176+-- under a version control system (such as Git, Subversion, Mercurial, etc.).
177+--
178+-- It is also recommended to version API based on changes to the @swagger.json@ rather than changes
179+-- to the Haskell API.
180+--
181+-- See <example/test/TodoSpec.hs TodoSpec.hs> for an example of a complete test suite for a swagger specification.
182+
183+-- $serve
184+-- If you're implementing a server for an API, you might also want to serve its @'Swagger'@ specification.
185+--
186+-- See <example/src/Todo.hs Todo.hs> for an example of a server.
servant-swagger/src/Servant/Swagger/Internal.hsnew file+477
@@ -0,0 +1,477 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE ConstraintKinds #-}
3+{-# LANGUAGE DataKinds #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE OverloadedStrings #-}
7+{-# LANGUAGE PolyKinds #-}
8+{-# LANGUAGE RankNTypes #-}
9+{-# LANGUAGE ScopedTypeVariables #-}
10+{-# LANGUAGE TypeOperators #-}
11+#if __GLASGOW_HASKELL__ >= 806
12+{-# LANGUAGE UndecidableInstances #-}
13+#endif
14+module Servant.Swagger.Internal where
15+
16+import Prelude ()
17+import Prelude.Compat
18+
19+import Control.Applicative ((<|>))
20+import Control.Lens
21+import Data.Aeson
22+import Data.HashMap.Strict.InsOrd (InsOrdHashMap)
23+import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
24+import Data.Foldable (toList)
25+import Data.Proxy
26+import Data.Typeable
27+import Data.Singletons.Bool
28+import Data.Swagger hiding (Header)
29+import qualified Data.Swagger as Swagger
30+import Data.Swagger.Declare
31+import Data.Text (Text)
32+import qualified Data.Text as Text
33+import GHC.TypeLits
34+import Network.HTTP.Media (MediaType)
35+import Servant.API
36+import Servant.API.Description (FoldDescription,
37+ reflectDescription)
38+import Servant.API.Modifiers (FoldRequired)
39+
40+import Servant.Swagger.Internal.TypeLevel.API
41+
42+-- | Generate a Swagger specification for a servant API.
43+--
44+-- To generate Swagger specification, your data types need
45+-- @'ToParamSchema'@ and/or @'ToSchema'@ instances.
46+--
47+-- @'ToParamSchema'@ is used for @'Capture'@, @'QueryParam'@ and @'Header'@.
48+-- @'ToSchema'@ is used for @'ReqBody'@ and response data types.
49+--
50+-- You can easily derive those instances via @Generic@.
51+-- For more information, refer to <http://hackage.haskell.org/package/swagger2/docs/Data-Swagger.html swagger2 documentation>.
52+--
53+-- Example:
54+--
55+-- @
56+-- newtype Username = Username String deriving (Generic, ToText)
57+--
58+-- instance ToParamSchema Username
59+--
60+-- data User = User
61+-- { username :: Username
62+-- , fullname :: String
63+-- } deriving (Generic)
64+--
65+-- instance ToJSON User
66+-- instance ToSchema User
67+--
68+-- type MyAPI = QueryParam "username" Username :> Get '[JSON] User
69+--
70+-- mySwagger :: Swagger
71+-- mySwagger = toSwagger (Proxy :: Proxy MyAPI)
72+-- @
73+class HasSwagger api where
74+ -- | Generate a Swagger specification for a servant API.
75+ toSwagger :: Proxy api -> Swagger
76+
77+instance HasSwagger Raw where
78+ toSwagger _ = mempty & paths . at "/" ?~ mempty
79+
80+instance HasSwagger EmptyAPI where
81+ toSwagger _ = mempty
82+
83+-- | All operations of sub API.
84+-- This is similar to @'operationsOf'@ but ensures that operations
85+-- indeed belong to the API at compile time.
86+subOperations :: (IsSubAPI sub api, HasSwagger sub) =>
87+ Proxy sub -- ^ Part of a servant API.
88+ -> Proxy api -- ^ The whole servant API.
89+ -> Traversal' Swagger Operation
90+subOperations sub _ = operationsOf (toSwagger sub)
91+
92+-- | Make a singleton Swagger spec (with only one endpoint).
93+-- For endpoints with no content see 'mkEndpointNoContent'.
94+mkEndpoint :: forall a cs hs proxy method status.
95+ (ToSchema a, AllAccept cs, AllToResponseHeader hs, SwaggerMethod method, KnownNat status)
96+ => FilePath -- ^ Endpoint path.
97+ -> proxy (Verb method status cs (Headers hs a)) -- ^ Method, content-types, headers and response.
98+ -> Swagger
99+mkEndpoint path proxy
100+ = mkEndpointWithSchemaRef (Just ref) path proxy
101+ & definitions .~ defs
102+ where
103+ (defs, ref) = runDeclare (declareSchemaRef (Proxy :: Proxy a)) mempty
104+
105+-- | Make a singletone 'Swagger' spec (with only one endpoint) and with no content schema.
106+mkEndpointNoContent :: forall nocontent cs hs proxy method status.
107+ (AllAccept cs, AllToResponseHeader hs, SwaggerMethod method, KnownNat status)
108+ => FilePath -- ^ Endpoint path.
109+ -> proxy (Verb method status cs (Headers hs nocontent)) -- ^ Method, content-types, headers and response.
110+ -> Swagger
111+mkEndpointNoContent path proxy
112+ = mkEndpointWithSchemaRef Nothing path proxy
113+
114+-- | Like @'mkEndpoint'@ but with explicit schema reference.
115+-- Unlike @'mkEndpoint'@ this function does not update @'definitions'@.
116+mkEndpointWithSchemaRef :: forall cs hs proxy method status a.
117+ (AllAccept cs, AllToResponseHeader hs, SwaggerMethod method, KnownNat status)
118+ => Maybe (Referenced Schema)
119+ -> FilePath
120+ -> proxy (Verb method status cs (Headers hs a))
121+ -> Swagger
122+mkEndpointWithSchemaRef mref path _ = mempty
123+ & paths.at path ?~
124+ (mempty & method ?~ (mempty
125+ & produces ?~ MimeList responseContentTypes
126+ & at code ?~ Inline (mempty
127+ & schema .~ mref
128+ & headers .~ responseHeaders)))
129+ where
130+ method = swaggerMethod (Proxy :: Proxy method)
131+ code = fromIntegral (natVal (Proxy :: Proxy status))
132+ responseContentTypes = allContentType (Proxy :: Proxy cs)
133+ responseHeaders = toAllResponseHeaders (Proxy :: Proxy hs)
134+
135+mkEndpointNoContentVerb :: forall proxy method.
136+ (SwaggerMethod method)
137+ => FilePath -- ^ Endpoint path.
138+ -> proxy (NoContentVerb method) -- ^ Method
139+ -> Swagger
140+mkEndpointNoContentVerb path _ = mempty
141+ & paths.at path ?~
142+ (mempty & method ?~ (mempty
143+ & at code ?~ Inline mempty))
144+ where
145+ method = swaggerMethod (Proxy :: Proxy method)
146+ code = 204 -- hardcoded in servant-server
147+
148+-- | Add parameter to every operation in the spec.
149+addParam :: Param -> Swagger -> Swagger
150+addParam param = allOperations.parameters %~ (Inline param :)
151+
152+-- | Add accepted content types to every operation in the spec.
153+addConsumes :: [MediaType] -> Swagger -> Swagger
154+addConsumes cs = allOperations.consumes %~ (<> Just (MimeList cs))
155+
156+-- | Format given text as inline code in Markdown.
157+markdownCode :: Text -> Text
158+markdownCode s = "`" <> s <> "`"
159+
160+addDefaultResponse400 :: ParamName -> Swagger -> Swagger
161+addDefaultResponse400 pname = setResponseWith (\old _new -> alter400 old) 400 (return response400)
162+ where
163+ sname = markdownCode pname
164+ description400 = "Invalid " <> sname
165+ alter400 = description %~ (<> (" or " <> sname))
166+ response400 = mempty & description .~ description400
167+
168+-- | Methods, available for Swagger.
169+class SwaggerMethod method where
170+ swaggerMethod :: proxy method -> Lens' PathItem (Maybe Operation)
171+
172+instance SwaggerMethod 'GET where swaggerMethod _ = get
173+instance SwaggerMethod 'PUT where swaggerMethod _ = put
174+instance SwaggerMethod 'POST where swaggerMethod _ = post
175+instance SwaggerMethod 'DELETE where swaggerMethod _ = delete
176+instance SwaggerMethod 'OPTIONS where swaggerMethod _ = options
177+instance SwaggerMethod 'HEAD where swaggerMethod _ = head_
178+instance SwaggerMethod 'PATCH where swaggerMethod _ = patch
179+
180+instance HasSwagger (UVerb method cs '[]) where
181+ toSwagger _ = mempty
182+
183+-- | @since <TODO>
184+instance
185+ {-# OVERLAPPABLE #-}
186+ ( ToSchema a,
187+ HasStatus a,
188+ AllAccept cs,
189+ SwaggerMethod method,
190+ HasSwagger (UVerb method cs as)
191+ ) =>
192+ HasSwagger (UVerb method cs (a ': as))
193+ where
194+ toSwagger _ =
195+ toSwagger (Proxy :: Proxy (Verb method (StatusOf a) cs a))
196+ `combineSwagger` toSwagger (Proxy :: Proxy (UVerb method cs as))
197+
198+-- ATTENTION: do not remove this instance!
199+-- A similar instance above will always use the more general
200+-- polymorphic -- HasSwagger instance and will result in a type error
201+-- since 'NoContent' does not have a 'ToSchema' instance.
202+instance
203+ ( KnownNat status,
204+ AllAccept cs,
205+ SwaggerMethod method,
206+ HasSwagger (UVerb method cs as)
207+ ) =>
208+ HasSwagger (UVerb method cs (WithStatus status NoContent ': as))
209+ where
210+ toSwagger _ =
211+ toSwagger (Proxy :: Proxy (Verb method status cs NoContent))
212+ `combineSwagger` toSwagger (Proxy :: Proxy (UVerb method cs as))
213+
214+
215+-- workaround for https://github.com/GetShopTV/swagger2/issues/218
216+-- We'd like to juse use (<>) but the instances are wrong
217+combinePathItem :: PathItem -> PathItem -> PathItem
218+combinePathItem s t = PathItem
219+ { _pathItemGet = _pathItemGet s <> _pathItemGet t
220+ , _pathItemPut = _pathItemPut s <> _pathItemPut t
221+ , _pathItemPost = _pathItemPost s <> _pathItemPost t
222+ , _pathItemDelete = _pathItemDelete s <> _pathItemDelete t
223+ , _pathItemOptions = _pathItemOptions s <> _pathItemOptions t
224+ , _pathItemHead = _pathItemHead s <> _pathItemHead t
225+ , _pathItemPatch = _pathItemPatch s <> _pathItemPatch t
226+ , _pathItemParameters = _pathItemParameters s <> _pathItemParameters t
227+ }
228+
229+combineSwagger :: Swagger -> Swagger -> Swagger
230+combineSwagger s t = Swagger
231+ { _swaggerInfo = _swaggerInfo s <> _swaggerInfo t
232+ , _swaggerHost = _swaggerHost s <|> _swaggerHost t
233+ , _swaggerBasePath = _swaggerBasePath s <|> _swaggerBasePath t
234+ , _swaggerSchemes = _swaggerSchemes s <> _swaggerSchemes t
235+ , _swaggerConsumes = _swaggerConsumes s <> _swaggerConsumes t
236+ , _swaggerProduces = _swaggerProduces s <> _swaggerProduces t
237+ , _swaggerPaths = InsOrdHashMap.unionWith combinePathItem (_swaggerPaths s) (_swaggerPaths t)
238+ , _swaggerDefinitions = _swaggerDefinitions s <> _swaggerDefinitions t
239+ , _swaggerParameters = _swaggerParameters s <> _swaggerParameters t
240+ , _swaggerResponses = _swaggerResponses s <> _swaggerResponses t
241+ , _swaggerSecurityDefinitions = _swaggerSecurityDefinitions s <> _swaggerSecurityDefinitions t
242+ , _swaggerSecurity = _swaggerSecurity s <> _swaggerSecurity t
243+ , _swaggerTags = _swaggerTags s <> _swaggerTags t
244+ , _swaggerExternalDocs = _swaggerExternalDocs s <|> _swaggerExternalDocs t
245+ }
246+
247+instance {-# OVERLAPPABLE #-} (ToSchema a, AllAccept cs, KnownNat status, SwaggerMethod method) => HasSwagger (Verb method status cs a) where
248+ toSwagger _ = toSwagger (Proxy :: Proxy (Verb method status cs (Headers '[] a)))
249+
250+-- | @since 1.1.7
251+instance (ToSchema a, Accept ct, KnownNat status, SwaggerMethod method) => HasSwagger (Stream method status fr ct a) where
252+ toSwagger _ = toSwagger (Proxy :: Proxy (Verb method status '[ct] (Headers '[] a)))
253+
254+instance {-# OVERLAPPABLE #-} (ToSchema a, AllAccept cs, AllToResponseHeader hs, KnownNat status, SwaggerMethod method)
255+ => HasSwagger (Verb method status cs (Headers hs a)) where
256+ toSwagger = mkEndpoint "/"
257+
258+-- ATTENTION: do not remove this instance!
259+-- A similar instance above will always use the more general
260+-- polymorphic -- HasSwagger instance and will result in a type error
261+-- since 'NoContent' does not have a 'ToSchema' instance.
262+instance (AllAccept cs, KnownNat status, SwaggerMethod method) => HasSwagger (Verb method status cs NoContent) where
263+ toSwagger _ = toSwagger (Proxy :: Proxy (Verb method status cs (Headers '[] NoContent)))
264+
265+instance (AllAccept cs, AllToResponseHeader hs, KnownNat status, SwaggerMethod method)
266+ => HasSwagger (Verb method status cs (Headers hs NoContent)) where
267+ toSwagger = mkEndpointNoContent "/"
268+
269+instance (SwaggerMethod method) => HasSwagger (NoContentVerb method) where
270+ toSwagger = mkEndpointNoContentVerb "/"
271+
272+instance (HasSwagger a, HasSwagger b) => HasSwagger (a :<|> b) where
273+ toSwagger _ = toSwagger (Proxy :: Proxy a) <> toSwagger (Proxy :: Proxy b)
274+
275+-- | @'Vault'@ combinator does not change our specification at all.
276+instance (HasSwagger sub) => HasSwagger (Vault :> sub) where
277+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
278+
279+-- | @'IsSecure'@ combinator does not change our specification at all.
280+instance (HasSwagger sub) => HasSwagger (IsSecure :> sub) where
281+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
282+
283+-- | @'RemoteHost'@ combinator does not change our specification at all.
284+instance (HasSwagger sub) => HasSwagger (RemoteHost :> sub) where
285+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
286+
287+-- | @'Fragment'@ combinator does not change our specification at all.
288+instance HasSwagger sub => HasSwagger (Fragment a :> sub) where
289+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
290+
291+-- | @'HttpVersion'@ combinator does not change our specification at all.
292+instance (HasSwagger sub) => HasSwagger (HttpVersion :> sub) where
293+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
294+
295+-- | @'WithNamedContext'@ combinator does not change our specification at all.
296+instance (HasSwagger sub) => HasSwagger (WithNamedContext x c sub) where
297+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
298+
299+instance (KnownSymbol sym, HasSwagger sub) => HasSwagger (sym :> sub) where
300+ toSwagger _ = prependPath piece (toSwagger (Proxy :: Proxy sub))
301+ where
302+ piece = symbolVal (Proxy :: Proxy sym)
303+
304+instance (KnownSymbol sym, Typeable a, ToParamSchema a, HasSwagger sub, KnownSymbol (FoldDescription mods)) => HasSwagger (Capture' mods sym a :> sub) where
305+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
306+ & addParam param
307+ & prependPath capture
308+ & addDefaultResponse400 tname
309+ where
310+ symbol = symbolVal (Proxy :: Proxy sym)
311+ pname = if symbol == ""
312+ then camelTo2 '-' . tyConName . typeRepTyCon $ typeRep (Proxy :: Proxy a)
313+ else symbol
314+ tname = Text.pack pname
315+ transDesc "" = Nothing
316+ transDesc desc = Just (Text.pack desc)
317+ capture = "{" <> pname <> "}"
318+ param = mempty
319+ & name .~ tname
320+ & description .~ transDesc (reflectDescription (Proxy :: Proxy mods))
321+ & required ?~ True
322+ & schema .~ ParamOther (mempty
323+ & in_ .~ ParamPath
324+ & paramSchema .~ toParamSchema (Proxy :: Proxy a))
325+
326+-- | Swagger Spec doesn't have a notion of CaptureAll, this instance is the best effort.
327+instance (KnownSymbol sym, Typeable a, ToParamSchema a, HasSwagger sub) => HasSwagger (CaptureAll sym a :> sub) where
328+ toSwagger _ = toSwagger (Proxy :: Proxy (Capture sym a :> sub))
329+
330+instance (KnownSymbol desc, HasSwagger api) => HasSwagger (Description desc :> api) where
331+ toSwagger _ = toSwagger (Proxy :: Proxy api)
332+ & allOperations.description %~ (Just (Text.pack (symbolVal (Proxy :: Proxy desc))) <>)
333+
334+instance (KnownSymbol desc, HasSwagger api) => HasSwagger (Summary desc :> api) where
335+ toSwagger _ = toSwagger (Proxy :: Proxy api)
336+ & allOperations.summary %~ (Just (Text.pack (symbolVal (Proxy :: Proxy desc))) <>)
337+
338+instance (KnownSymbol sym, ToParamSchema a, HasSwagger sub, SBoolI (FoldRequired mods), KnownSymbol (FoldDescription mods)) => HasSwagger (QueryParam' mods sym a :> sub) where
339+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
340+ & addParam param
341+ & addDefaultResponse400 tname
342+ where
343+ tname = Text.pack (symbolVal (Proxy :: Proxy sym))
344+ transDesc "" = Nothing
345+ transDesc desc = Just (Text.pack desc)
346+ param = mempty
347+ & name .~ tname
348+ & description .~ transDesc (reflectDescription (Proxy :: Proxy mods))
349+ & required ?~ reflectBool (Proxy :: Proxy (FoldRequired mods))
350+ & schema .~ ParamOther sch
351+ sch = mempty
352+ & in_ .~ ParamQuery
353+ & paramSchema .~ toParamSchema (Proxy :: Proxy a)
354+
355+instance (KnownSymbol sym, ToParamSchema a, HasSwagger sub) => HasSwagger (QueryParams sym a :> sub) where
356+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
357+ & addParam param
358+ & addDefaultResponse400 tname
359+ where
360+ tname = Text.pack (symbolVal (Proxy :: Proxy sym))
361+ param = mempty
362+ & name .~ tname
363+ & schema .~ ParamOther sch
364+ sch = mempty
365+ & in_ .~ ParamQuery
366+ & paramSchema .~ pschema
367+ pschema = mempty
368+#if MIN_VERSION_swagger2(2,4,0)
369+ & type_ ?~ SwaggerArray
370+#else
371+ & type_ .~ SwaggerArray
372+#endif
373+ & items ?~ SwaggerItemsPrimitive (Just CollectionMulti) (toParamSchema (Proxy :: Proxy a))
374+
375+instance (KnownSymbol sym, HasSwagger sub) => HasSwagger (QueryFlag sym :> sub) where
376+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
377+ & addParam param
378+ & addDefaultResponse400 tname
379+ where
380+ tname = Text.pack (symbolVal (Proxy :: Proxy sym))
381+ param = mempty
382+ & name .~ tname
383+ & schema .~ ParamOther (mempty
384+ & in_ .~ ParamQuery
385+ & allowEmptyValue ?~ True
386+ & paramSchema .~ (toParamSchema (Proxy :: Proxy Bool)
387+ & default_ ?~ toJSON False))
388+
389+instance (KnownSymbol sym, ToParamSchema a, HasSwagger sub, SBoolI (FoldRequired mods), KnownSymbol (FoldDescription mods)) => HasSwagger (Header' mods sym a :> sub) where
390+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
391+ & addParam param
392+ & addDefaultResponse400 tname
393+ where
394+ tname = Text.pack (symbolVal (Proxy :: Proxy sym))
395+ transDesc "" = Nothing
396+ transDesc desc = Just (Text.pack desc)
397+ param = mempty
398+ & name .~ tname
399+ & description .~ transDesc (reflectDescription (Proxy :: Proxy mods))
400+ & required ?~ reflectBool (Proxy :: Proxy (FoldRequired mods))
401+ & schema .~ ParamOther (mempty
402+ & in_ .~ ParamHeader
403+ & paramSchema .~ toParamSchema (Proxy :: Proxy a))
404+
405+instance (ToSchema a, AllAccept cs, HasSwagger sub, KnownSymbol (FoldDescription mods)) => HasSwagger (ReqBody' mods cs a :> sub) where
406+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
407+ & addParam param
408+ & addConsumes (allContentType (Proxy :: Proxy cs))
409+ & addDefaultResponse400 tname
410+ & definitions %~ (<> defs)
411+ where
412+ tname = "body"
413+ transDesc "" = Nothing
414+ transDesc desc = Just (Text.pack desc)
415+ (defs, ref) = runDeclare (declareSchemaRef (Proxy :: Proxy a)) mempty
416+ param = mempty
417+ & name .~ tname
418+ & description .~ transDesc (reflectDescription (Proxy :: Proxy mods))
419+ & required ?~ True
420+ & schema .~ ParamBody ref
421+
422+-- | This instance is an approximation.
423+--
424+-- @since 1.1.7
425+instance (ToSchema a, Accept ct, HasSwagger sub, KnownSymbol (FoldDescription mods)) => HasSwagger (StreamBody' mods fr ct a :> sub) where
426+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
427+ & addParam param
428+ & addConsumes (toList (contentTypes (Proxy :: Proxy ct)))
429+ & addDefaultResponse400 tname
430+ & definitions %~ (<> defs)
431+ where
432+ tname = "body"
433+ transDesc "" = Nothing
434+ transDesc desc = Just (Text.pack desc)
435+ (defs, ref) = runDeclare (declareSchemaRef (Proxy :: Proxy a)) mempty
436+ param = mempty
437+ & name .~ tname
438+ & description .~ transDesc (reflectDescription (Proxy :: Proxy mods))
439+ & required ?~ True
440+ & schema .~ ParamBody ref
441+
442+-- =======================================================================
443+-- Below are the definitions that should be in Servant.API.ContentTypes
444+-- =======================================================================
445+
446+class AllAccept cs where
447+ allContentType :: Proxy cs -> [MediaType]
448+
449+instance AllAccept '[] where
450+ allContentType _ = []
451+
452+instance (Accept c, AllAccept cs) => AllAccept (c ': cs) where
453+ allContentType _ = contentType (Proxy :: Proxy c) : allContentType (Proxy :: Proxy cs)
454+
455+class ToResponseHeader h where
456+ toResponseHeader :: Proxy h -> (HeaderName, Swagger.Header)
457+
458+instance (KnownSymbol sym, ToParamSchema a) => ToResponseHeader (Header sym a) where
459+ toResponseHeader _ = (hname, Swagger.Header Nothing hschema)
460+ where
461+ hname = Text.pack (symbolVal (Proxy :: Proxy sym))
462+ hschema = toParamSchema (Proxy :: Proxy a)
463+
464+class AllToResponseHeader hs where
465+ toAllResponseHeaders :: Proxy hs -> InsOrdHashMap HeaderName Swagger.Header
466+
467+instance AllToResponseHeader '[] where
468+ toAllResponseHeaders _ = mempty
469+
470+instance (ToResponseHeader h, AllToResponseHeader hs) => AllToResponseHeader (h ': hs) where
471+ toAllResponseHeaders _ = InsOrdHashMap.insert headerName headerBS hdrs
472+ where
473+ (headerName, headerBS) = toResponseHeader (Proxy :: Proxy h)
474+ hdrs = toAllResponseHeaders (Proxy :: Proxy hs)
475+
476+instance AllToResponseHeader hs => AllToResponseHeader (HList hs) where
477+ toAllResponseHeaders _ = toAllResponseHeaders (Proxy :: Proxy hs)
servant-swagger/src/Servant/Swagger/Internal/Orphans.hsnew file+27
@@ -0,0 +1,27 @@
1+{-# OPTIONS_GHC -fno-warn-orphans #-}
2+{-# LANGUAGE CPP #-}
3+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4+{-# LANGUAGE ScopedTypeVariables #-}
5+{-# LANGUAGE StandaloneDeriving #-}
6+module Servant.Swagger.Internal.Orphans where
7+
8+import Data.Proxy
9+ (Proxy (..))
10+import Data.Swagger
11+import Servant.Types.SourceT
12+ (SourceT)
13+#if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)
14+import Servant.API (WithStatus(..))
15+#endif
16+
17+-- | Pretend that 'SourceT m a' is '[a]'.
18+--
19+-- @since 1.1.7
20+--
21+instance ToSchema a => ToSchema (SourceT m a) where
22+ declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
23+
24+#if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)
25+-- @since 1.1.11
26+deriving instance ToSchema a => ToSchema (WithStatus s a)
27+#endif
servant-swagger/src/Servant/Swagger/Internal/Test.hsnew file+205
@@ -0,0 +1,205 @@
1+{-# LANGUAGE ConstraintKinds #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE RankNTypes #-}
5+{-# LANGUAGE ScopedTypeVariables #-}
6+{-# LANGUAGE TypeOperators #-}
7+{-# LANGUAGE OverloadedStrings #-}
8+module Servant.Swagger.Internal.Test where
9+
10+import Data.Aeson (ToJSON (..))
11+import Data.Aeson.Encode.Pretty (encodePretty', defConfig,
12+ confCompare)
13+import Data.Swagger (Pattern, ToSchema,
14+ toSchema)
15+import Data.Swagger.Schema.Validation
16+import Data.Text (Text)
17+import qualified Data.Text.Lazy as TL
18+import qualified Data.Text.Lazy.Encoding as TL
19+import Data.Typeable
20+import Test.Hspec
21+import Test.Hspec.QuickCheck
22+import Test.QuickCheck (Arbitrary, Property,
23+ counterexample, property)
24+
25+import Servant.API
26+import Servant.Swagger.Internal.TypeLevel
27+
28+-- $setup
29+-- >>> import Control.Applicative
30+-- >>> import GHC.Generics
31+-- >>> import Test.QuickCheck
32+-- >>> :set -XDeriveGeneric
33+-- >>> :set -XGeneralizedNewtypeDeriving
34+-- >>> :set -XDataKinds
35+-- >>> :set -XTypeOperators
36+
37+-- | Verify that every type used with @'JSON'@ content type in a servant API
38+-- has compatible @'ToJSON'@ and @'ToSchema'@ instances using @'validateToJSON'@.
39+--
40+-- /NOTE:/ @'validateEveryToJSON'@ does not perform string pattern validation.
41+-- See @'validateEveryToJSONWithPatternChecker'@.
42+--
43+-- @'validateEveryToJSON'@ will produce one @'prop'@ specification for every type in the API.
44+-- Each type only gets one test, even if it occurs multiple times in the API.
45+--
46+-- >>> data User = User { name :: String, age :: Maybe Int } deriving (Show, Generic, Typeable)
47+-- >>> newtype UserId = UserId String deriving (Show, Generic, Typeable, ToJSON, Arbitrary)
48+-- >>> instance ToJSON User
49+-- >>> instance ToSchema User
50+-- >>> instance ToSchema UserId
51+-- >>> instance Arbitrary User where arbitrary = User <$> arbitrary <*> arbitrary
52+-- >>> type UserAPI = (Capture "user_id" UserId :> Get '[JSON] User) :<|> (ReqBody '[JSON] User :> Post '[JSON] UserId)
53+--
54+-- >>> hspec $ context "ToJSON matches ToSchema" $ validateEveryToJSON (Proxy :: Proxy UserAPI)
55+-- <BLANKLINE>
56+-- ToJSON matches ToSchema
57+-- User
58+-- ...
59+-- UserId
60+-- ...
61+-- Finished in ... seconds
62+-- 2 examples, 0 failures
63+--
64+-- For the test to compile all body types should have the following instances:
65+--
66+-- * @'ToJSON'@ and @'ToSchema'@ are used to perform the validation;
67+-- * @'Typeable'@ is used to name the test for each type;
68+-- * @'Show'@ is used to display value for which @'ToJSON'@ does not satisfy @'ToSchema'@.
69+-- * @'Arbitrary'@ is used to arbitrarily generate values.
70+--
71+-- If any of the instances is missing, you'll get a descriptive type error:
72+--
73+-- >>> data Contact = Contact { fullname :: String, phone :: Integer } deriving (Show, Generic)
74+-- >>> instance ToJSON Contact
75+-- >>> instance ToSchema Contact
76+-- >>> type ContactAPI = Get '[JSON] Contact
77+-- >>> hspec $ validateEveryToJSON (Proxy :: Proxy ContactAPI)
78+-- ...
79+-- ...No instance for (Arbitrary Contact)
80+-- ... arising from a use of ‘validateEveryToJSON’
81+-- ...
82+validateEveryToJSON
83+ :: forall proxy api .
84+ TMap (Every [Typeable, Show, Arbitrary, ToJSON, ToSchema])
85+ (BodyTypes JSON api)
86+ => proxy api -- ^ Servant API.
87+ -> Spec
88+validateEveryToJSON _ = props
89+ (Proxy :: Proxy [ToJSON, ToSchema])
90+ (maybeCounterExample . prettyValidateWith validateToJSON)
91+ (Proxy :: Proxy (BodyTypes JSON api))
92+
93+-- | Verify that every type used with @'JSON'@ content type in a servant API
94+-- has compatible @'ToJSON'@ and @'ToSchema'@ instances using @'validateToJSONWithPatternChecker'@.
95+--
96+-- For validation without patterns see @'validateEveryToJSON'@.
97+validateEveryToJSONWithPatternChecker :: forall proxy api. TMap (Every [Typeable, Show, Arbitrary, ToJSON, ToSchema]) (BodyTypes JSON api) =>
98+ (Pattern -> Text -> Bool) -- ^ @'Pattern'@ checker.
99+ -> proxy api -- ^ Servant API.
100+ -> Spec
101+validateEveryToJSONWithPatternChecker checker _ = props
102+ (Proxy :: Proxy [ToJSON, ToSchema])
103+ (maybeCounterExample . prettyValidateWith (validateToJSONWithPatternChecker checker))
104+ (Proxy :: Proxy (BodyTypes JSON api))
105+
106+-- * QuickCheck-related stuff
107+
108+-- | Construct property tests for each type in a list.
109+-- The name for each property is the name of the corresponding type.
110+--
111+-- >>> :{
112+-- hspec $
113+-- context "read . show == id" $
114+-- props
115+-- (Proxy :: Proxy [Eq, Show, Read])
116+-- (\x -> read (show x) === x)
117+-- (Proxy :: Proxy [Bool, Int, String])
118+-- :}
119+-- <BLANKLINE>
120+-- read . show == id
121+-- Bool
122+-- ...
123+-- Int
124+-- ...
125+-- [Char]
126+-- ...
127+-- Finished in ... seconds
128+-- 3 examples, 0 failures
129+props :: forall p p'' cs xs. TMap (Every (Typeable ': Show ': Arbitrary ': cs)) xs =>
130+ p cs -- ^ A list of constraints.
131+ -> (forall x. EveryTF cs x => x -> Property) -- ^ Property predicate.
132+ -> p'' xs -- ^ A list of types.
133+ -> Spec
134+props _ f px = sequence_ specs
135+ where
136+ specs :: [Spec]
137+ specs = tmapEvery (Proxy :: Proxy (Typeable ': Show ': Arbitrary ': cs)) aprop px
138+
139+ aprop :: forall p' a. (EveryTF cs a, Typeable a, Show a, Arbitrary a) => p' a -> Spec
140+ aprop _ = prop (show (typeOf (undefined :: a))) (f :: a -> Property)
141+
142+-- | Pretty print validation errors
143+-- together with actual JSON and Swagger Schema
144+-- (using 'encodePretty').
145+--
146+-- >>> import Data.Aeson
147+-- >>> import Data.Foldable (traverse_)
148+-- >>> data Person = Person { name :: String, phone :: Integer } deriving (Generic)
149+-- >>> instance ToJSON Person where toJSON p = object [ "name" .= name p ]
150+-- >>> instance ToSchema Person
151+-- >>> let person = Person { name = "John", phone = 123456 }
152+-- >>> traverse_ putStrLn $ prettyValidateWith validateToJSON person
153+-- Validation against the schema fails:
154+-- * property "phone" is required, but not found in "{\"name\":\"John\"}"
155+-- <BLANKLINE>
156+-- JSON value:
157+-- {
158+-- "name": "John"
159+-- }
160+-- <BLANKLINE>
161+-- Swagger Schema:
162+-- {
163+-- "properties": {
164+-- "name": {
165+-- "type": "string"
166+-- },
167+-- "phone": {
168+-- "type": "integer"
169+-- }
170+-- },
171+-- "required": [
172+-- "name",
173+-- "phone"
174+-- ],
175+-- "type": "object"
176+-- }
177+-- <BLANKLINE>
178+--
179+-- FIXME: this belongs in "Data.Swagger.Schema.Validation" (in @swagger2@).
180+prettyValidateWith
181+ :: forall a. (ToJSON a, ToSchema a)
182+ => (a -> [ValidationError]) -> a -> Maybe String
183+prettyValidateWith f x =
184+ case f x of
185+ [] -> Nothing
186+ errors -> Just $ unlines
187+ [ "Validation against the schema fails:"
188+ , unlines (map (" * " ++) errors)
189+ , "JSON value:"
190+ , ppJSONString json
191+ , ""
192+ , "Swagger Schema:"
193+ , ppJSONString (toJSON schema)
194+ ]
195+ where
196+ ppJSONString = TL.unpack . TL.decodeUtf8 . encodePretty' ppCfg
197+ ppCfg = defConfig { confCompare = compare }
198+
199+ json = toJSON x
200+ schema = toSchema (Proxy :: Proxy a)
201+
202+-- | Provide a counterexample if there is any.
203+maybeCounterExample :: Maybe String -> Property
204+maybeCounterExample Nothing = property True
205+maybeCounterExample (Just s) = counterexample s (property False)
servant-swagger/src/Servant/Swagger/Internal/TypeLevel.hsnew file+9
@@ -0,0 +1,9 @@
1+module Servant.Swagger.Internal.TypeLevel (
2+ module Servant.Swagger.Internal.TypeLevel.API,
3+ module Servant.Swagger.Internal.TypeLevel.Every,
4+ module Servant.Swagger.Internal.TypeLevel.TMap,
5+) where
6+
7+import Servant.Swagger.Internal.TypeLevel.API
8+import Servant.Swagger.Internal.TypeLevel.Every
9+import Servant.Swagger.Internal.TypeLevel.TMap
servant-swagger/src/Servant/Swagger/Internal/TypeLevel/API.hsnew file+86
@@ -0,0 +1,86 @@
1+{-# LANGUAGE ConstraintKinds #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE KindSignatures #-}
4+{-# LANGUAGE PolyKinds #-}
5+{-# LANGUAGE TypeFamilies #-}
6+{-# LANGUAGE TypeOperators #-}
7+{-# LANGUAGE UndecidableInstances #-}
8+module Servant.Swagger.Internal.TypeLevel.API where
9+
10+import GHC.Exts (Constraint)
11+import Servant.API
12+
13+-- | Build a list of endpoints from an API.
14+type family EndpointsList api where
15+ EndpointsList (a :<|> b) = AppendList (EndpointsList a) (EndpointsList b)
16+ EndpointsList (e :> a) = MapSub e (EndpointsList a)
17+ EndpointsList a = '[a]
18+
19+-- | Check whether @sub@ is a sub API of @api@.
20+type family IsSubAPI sub api :: Constraint where
21+ IsSubAPI sub api = AllIsElem (EndpointsList sub) api
22+
23+-- | Check that every element of @xs@ is an endpoint of @api@.
24+type family AllIsElem xs api :: Constraint where
25+ AllIsElem '[] api = ()
26+ AllIsElem (x ': xs) api = (IsIn x api, AllIsElem xs api)
27+
28+-- | Apply @(e :>)@ to every API in @xs@.
29+type family MapSub e xs where
30+ MapSub e '[] = '[]
31+ MapSub e (x ': xs) = (e :> x) ': MapSub e xs
32+
33+-- | Append two type-level lists.
34+type family AppendList xs ys where
35+ AppendList '[] ys = ys
36+ AppendList (x ': xs) ys = x ': AppendList xs ys
37+
38+type family Or (a :: Constraint) (b :: Constraint) :: Constraint where
39+ Or () b = ()
40+ Or a () = ()
41+
42+type family IsIn sub api :: Constraint where
43+ IsIn e (a :<|> b) = Or (IsIn e a) (IsIn e b)
44+ IsIn (e :> a) (e :> b) = IsIn a b
45+ IsIn e e = ()
46+
47+-- | Check whether a type is a member of a list of types.
48+-- This is a type-level analogue of @'elem'@.
49+type family Elem x xs where
50+ Elem x '[] = 'False
51+ Elem x (x ': xs) = 'True
52+ Elem x (y ': xs) = Elem x xs
53+
54+-- | Remove duplicates from a type-level list.
55+type family Nub xs where
56+ Nub '[] = '[]
57+ Nub (x ': xs) = x ': Nub (Remove x xs)
58+
59+-- | Remove element from a type-level list.
60+type family Remove x xs where
61+ Remove x '[] = '[]
62+ Remove x (x ': ys) = Remove x ys
63+ Remove x (y ': ys) = y ': Remove x ys
64+
65+-- | Extract a list of unique "body" types for a specific content-type from a servant API.
66+type BodyTypes c api = Nub (BodyTypes' c api)
67+
68+-- | @'AddBodyType' c cs a as@ adds type @a@ to the list @as@
69+-- only if @c@ is in @cs@.
70+type AddBodyType c cs a as = If (Elem c cs) (a ': as) as
71+
72+-- | Extract a list of "body" types for a specific content-type from a servant API.
73+-- To extract unique types see @'BodyTypes'@.
74+--
75+-- @'NoContent'@ is removed from the list and not tested. (This allows for leaving the body
76+-- completely empty on responses to requests that only accept 'application/json', while
77+-- setting the content-type in the response accordingly.)
78+type family BodyTypes' c api :: [*] where
79+ BodyTypes' c (Verb verb b cs (Headers hdrs a)) = AddBodyType c cs a '[]
80+ BodyTypes' c (Verb verb b cs NoContent) = '[]
81+ BodyTypes' c (Verb verb b cs a) = AddBodyType c cs a '[]
82+ BodyTypes' c (ReqBody' mods cs a :> api) = AddBodyType c cs a (BodyTypes' c api)
83+ BodyTypes' c (e :> api) = BodyTypes' c api
84+ BodyTypes' c (a :<|> b) = AppendList (BodyTypes' c a) (BodyTypes' c b)
85+ BodyTypes' c api = '[]
86+
servant-swagger/src/Servant/Swagger/Internal/TypeLevel/Every.hsnew file+63
@@ -0,0 +1,63 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE ConstraintKinds #-}
3+{-# LANGUAGE DataKinds #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE GADTs #-}
7+{-# LANGUAGE InstanceSigs #-}
8+{-# LANGUAGE KindSignatures #-}
9+{-# LANGUAGE MultiParamTypeClasses #-}
10+{-# LANGUAGE PolyKinds #-}
11+{-# LANGUAGE RankNTypes #-}
12+{-# LANGUAGE ScopedTypeVariables #-}
13+{-# LANGUAGE TypeFamilies #-}
14+{-# LANGUAGE TypeOperators #-}
15+{-# LANGUAGE UndecidableInstances #-}
16+#if __GLASGOW_HASKELL__ >= 800
17+{-# LANGUAGE UndecidableSuperClasses #-}
18+#endif
19+module Servant.Swagger.Internal.TypeLevel.Every where
20+
21+import Data.Proxy
22+import GHC.Exts (Constraint)
23+
24+import Servant.Swagger.Internal.TypeLevel.TMap
25+
26+-- $setup
27+-- >>> :set -XDataKinds
28+-- >>> :set -XFlexibleContexts
29+-- >>> :set -XGADTs
30+-- >>> :set -XRankNTypes
31+-- >>> :set -XScopedTypeVariables
32+-- >>> import GHC.TypeLits
33+-- >>> import Data.List
34+
35+-- | Apply multiple constraint constructors to a type.
36+--
37+-- @
38+-- EveryTF '[Show, Read] a ~ (Show a, Read a)
39+-- @
40+--
41+-- Note that since this is a type family, you have to alway fully apply @'EveryTF'@.
42+--
43+-- For partial application of multiple constraint constructors see @'Every'@.
44+type family EveryTF cs x :: Constraint where
45+ EveryTF '[] x = ()
46+ EveryTF (c ': cs) x = (c x, EveryTF cs x)
47+
48+-- | Apply multiple constraint constructors to a type as a class.
49+--
50+-- This is different from @'EveryTF'@ in that it allows partial application.
51+class EveryTF cs x => Every (cs :: [* -> Constraint]) (x :: *) where
52+
53+instance Every '[] x where
54+instance (c x, Every cs x) => Every (c ': cs) x where
55+
56+-- | Like @'tmap'@, but uses @'Every'@ for multiple constraints.
57+--
58+-- >>> let zero :: forall p a. (Show a, Num a) => p a -> String; zero _ = show (0 :: a)
59+-- >>> tmapEvery (Proxy :: Proxy [Show, Num]) zero (Proxy :: Proxy [Int, Float]) :: [String]
60+-- ["0","0.0"]
61+tmapEvery :: forall a cs p p'' xs. (TMap (Every cs) xs) =>
62+ p cs -> (forall x p'. Every cs x => p' x -> a) -> p'' xs -> [a]
63+tmapEvery _ = tmap (Proxy :: Proxy (Every cs))
servant-swagger/src/Servant/Swagger/Internal/TypeLevel/TMap.hsnew file+37
@@ -0,0 +1,37 @@
1+{-# LANGUAGE ConstraintKinds #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE KindSignatures #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE PolyKinds #-}
7+{-# LANGUAGE RankNTypes #-}
8+{-# LANGUAGE ScopedTypeVariables #-}
9+{-# LANGUAGE TypeOperators #-}
10+{-# LANGUAGE UndecidableInstances #-}
11+module Servant.Swagger.Internal.TypeLevel.TMap where
12+
13+import Data.Proxy
14+import GHC.Exts (Constraint)
15+
16+-- $setup
17+-- >>> :set -XDataKinds
18+-- >>> :set -XFlexibleContexts
19+-- >>> :set -XGADTs
20+-- >>> :set -XRankNTypes
21+-- >>> :set -XScopedTypeVariables
22+-- >>> import GHC.TypeLits
23+-- >>> import Data.List
24+
25+-- | Map a list of constrained types to a list of values.
26+--
27+-- >>> tmap (Proxy :: Proxy KnownSymbol) symbolVal (Proxy :: Proxy ["hello", "world"])
28+-- ["hello","world"]
29+class TMap (q :: k -> Constraint) (xs :: [k]) where
30+ tmap :: p q -> (forall x p'. q x => p' x -> a) -> p'' xs -> [a]
31+
32+instance TMap q '[] where
33+ tmap _ _ _ = []
34+
35+instance (q x, TMap q xs) => TMap q (x ': xs) where
36+ tmap q f _ = f (Proxy :: Proxy x) : tmap q f (Proxy :: Proxy xs)
37+
servant-swagger/src/Servant/Swagger/Test.hsnew file+13
@@ -0,0 +1,13 @@
1+-- |
2+-- Module: Servant.Swagger.Test
3+-- License: BSD3
4+-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
5+-- Stability: experimental
6+--
7+-- Automatic tests for servant API against Swagger spec.
8+module Servant.Swagger.Test (
9+ validateEveryToJSON,
10+ validateEveryToJSONWithPatternChecker,
11+) where
12+
13+import Servant.Swagger.Internal.Test
servant-swagger/src/Servant/Swagger/TypeLevel.hsnew file+15
@@ -0,0 +1,15 @@
1+-- |
2+-- Module: Servant.Swagger.TypeLevel
3+-- License: BSD3
4+-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
5+-- Stability: experimental
6+--
7+-- Useful type families for servant APIs.
8+module Servant.Swagger.TypeLevel (
9+ IsSubAPI,
10+ EndpointsList,
11+ BodyTypes,
12+) where
13+
14+import Servant.Swagger.Internal.TypeLevel
15+
servant-swagger/test/Servant/SwaggerSpec.hsnew file+489
@@ -0,0 +1,489 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE DeriveDataTypeable #-}
4+{-# LANGUAGE DeriveGeneric #-}
5+{-# LANGUAGE OverloadedStrings #-}
6+{-# LANGUAGE QuasiQuotes #-}
7+{-# LANGUAGE TypeFamilies #-}
8+{-# LANGUAGE TypeOperators #-}
9+{-# LANGUAGE PackageImports #-}
10+module Servant.SwaggerSpec where
11+
12+import Control.Lens
13+import Data.Aeson (ToJSON(toJSON), Value, genericToJSON)
14+import Data.Aeson.QQ.Simple
15+import qualified Data.Aeson.Types as JSON
16+import Data.Char (toLower)
17+import Data.Int (Int64)
18+import Data.Proxy
19+import Data.Swagger
20+import Data.Text (Text)
21+import Data.Time
22+import GHC.Generics
23+import Servant.API
24+import Servant.Swagger
25+import Servant.Test.ComprehensiveAPI (comprehensiveAPI)
26+import Test.Hspec hiding (example)
27+
28+#if !MIN_VERSION_swagger2(2,4,0)
29+import Data.Aeson.Lens (key, _Array)
30+import qualified Data.Vector as V
31+#endif
32+
33+checkAPI :: HasSwagger api => Proxy api -> Value -> IO ()
34+checkAPI proxy = checkSwagger (toSwagger proxy)
35+
36+checkSwagger :: Swagger -> Value -> IO ()
37+checkSwagger swag js = toJSON swag `shouldBe` js
38+
39+spec :: Spec
40+spec = describe "HasSwagger" $ do
41+ it "Todo API" $ checkAPI (Proxy :: Proxy TodoAPI) todoAPI
42+ it "Hackage API (with tags)" $ checkSwagger hackageSwaggerWithTags hackageAPI
43+ it "GetPost API (test subOperations)" $ checkSwagger getPostSwagger getPostAPI
44+ it "UVerb API" $ checkSwagger uverbSwagger uverbAPI
45+ it "Comprehensive API" $ do
46+ let _x = toSwagger comprehensiveAPI
47+ True `shouldBe` True -- type-level test
48+
49+main :: IO ()
50+main = hspec spec
51+
52+-- =======================================================================
53+-- Todo API
54+-- =======================================================================
55+
56+data Todo = Todo
57+ { created :: UTCTime
58+ , title :: String
59+ , summary :: Maybe String
60+ } deriving (Generic)
61+
62+instance ToJSON Todo
63+instance ToSchema Todo
64+
65+newtype TodoId = TodoId String deriving (Generic)
66+instance ToParamSchema TodoId
67+
68+type TodoAPI = "todo" :> Capture "id" TodoId :> Get '[JSON] Todo
69+
70+todoAPI :: Value
71+todoAPI = [aesonQQ|
72+{
73+ "swagger":"2.0",
74+ "info":
75+ {
76+ "title": "",
77+ "version": ""
78+ },
79+ "definitions":
80+ {
81+ "Todo":
82+ {
83+ "type": "object",
84+ "required": [ "created", "title" ],
85+ "properties":
86+ {
87+ "created": { "$ref": "#/definitions/UTCTime" },
88+ "title": { "type": "string" },
89+ "summary": { "type": "string" }
90+ }
91+ },
92+ "UTCTime":
93+ {
94+ "type": "string",
95+ "format": "yyyy-mm-ddThh:MM:ssZ",
96+ "example": "2016-07-22T00:00:00Z"
97+ }
98+ },
99+ "paths":
100+ {
101+ "/todo/{id}":
102+ {
103+ "get":
104+ {
105+ "responses":
106+ {
107+ "200":
108+ {
109+ "schema": { "$ref":"#/definitions/Todo" },
110+ "description": ""
111+ },
112+ "400": { "description": "Invalid `id`" }
113+ },
114+ "produces": [ "application/json;charset=utf-8" ],
115+ "parameters":
116+ [
117+ {
118+ "required": true,
119+ "in": "path",
120+ "name": "id",
121+ "type": "string"
122+ }
123+ ]
124+ }
125+ }
126+ }
127+}
128+|]
129+
130+-- =======================================================================
131+-- Hackage API
132+-- =======================================================================
133+
134+type HackageAPI
135+ = HackageUserAPI
136+ :<|> HackagePackagesAPI
137+
138+type HackageUserAPI =
139+ "users" :> Get '[JSON] [UserSummary]
140+ :<|> "user" :> Capture "username" Username :> Get '[JSON] UserDetailed
141+
142+type HackagePackagesAPI
143+ = "packages" :> Get '[JSON] [Package]
144+
145+type Username = Text
146+
147+data UserSummary = UserSummary
148+ { summaryUsername :: Username
149+ , summaryUserid :: Int64 -- Word64 would make sense too
150+ } deriving (Eq, Show, Generic)
151+
152+lowerCutPrefix :: String -> String -> String
153+lowerCutPrefix s = map toLower . drop (length s)
154+
155+instance ToJSON UserSummary where
156+ toJSON = genericToJSON JSON.defaultOptions { JSON.fieldLabelModifier = lowerCutPrefix "summary" }
157+
158+instance ToSchema UserSummary where
159+ declareNamedSchema proxy = genericDeclareNamedSchema defaultSchemaOptions { fieldLabelModifier = lowerCutPrefix "summary" } proxy
160+ & mapped.schema.example ?~ toJSON UserSummary
161+ { summaryUsername = "JohnDoe"
162+ , summaryUserid = 123 }
163+
164+type Group = Text
165+
166+data UserDetailed = UserDetailed
167+ { username :: Username
168+ , userid :: Int64
169+ , groups :: [Group]
170+ } deriving (Eq, Show, Generic)
171+instance ToSchema UserDetailed
172+
173+newtype Package = Package { packageName :: Text }
174+ deriving (Eq, Show, Generic)
175+instance ToSchema Package
176+
177+hackageSwaggerWithTags :: Swagger
178+hackageSwaggerWithTags = toSwagger (Proxy :: Proxy HackageAPI)
179+ & host ?~ Host "hackage.haskell.org" Nothing
180+ & applyTagsFor usersOps ["users" & description ?~ "Operations about user"]
181+ & applyTagsFor packagesOps ["packages" & description ?~ "Query packages"]
182+ where
183+ usersOps, packagesOps :: Traversal' Swagger Operation
184+ usersOps = subOperations (Proxy :: Proxy HackageUserAPI) (Proxy :: Proxy HackageAPI)
185+ packagesOps = subOperations (Proxy :: Proxy HackagePackagesAPI) (Proxy :: Proxy HackageAPI)
186+
187+hackageAPI :: Value
188+hackageAPI = modifyValue [aesonQQ|
189+{
190+ "swagger":"2.0",
191+ "host":"hackage.haskell.org",
192+ "info":{
193+ "version":"",
194+ "title":""
195+ },
196+ "definitions":{
197+ "UserDetailed":{
198+ "required":[
199+ "username",
200+ "userid",
201+ "groups"
202+ ],
203+ "type":"object",
204+ "properties":{
205+ "groups":{
206+ "items":{
207+ "type":"string"
208+ },
209+ "type":"array"
210+ },
211+ "username":{
212+ "type":"string"
213+ },
214+ "userid":{
215+ "maximum":9223372036854775807,
216+ "minimum":-9223372036854775808,
217+ "type":"integer",
218+ "format":"int64"
219+ }
220+ }
221+ },
222+ "Package":{
223+ "required":[
224+ "packageName"
225+ ],
226+ "type":"object",
227+ "properties":{
228+ "packageName":{
229+ "type":"string"
230+ }
231+ }
232+ },
233+ "UserSummary":{
234+ "required":[
235+ "username",
236+ "userid"
237+ ],
238+ "type":"object",
239+ "properties":{
240+ "username":{
241+ "type":"string"
242+ },
243+ "userid":{
244+ "maximum":9223372036854775807,
245+ "minimum":-9223372036854775808,
246+ "type":"integer",
247+ "format":"int64"
248+ }
249+ },
250+ "example":{
251+ "username": "JohnDoe",
252+ "userid": 123
253+ }
254+ }
255+ },
256+ "paths":{
257+ "/users":{
258+ "get":{
259+ "responses":{
260+ "200":{
261+ "schema":{
262+ "items":{
263+ "$ref":"#/definitions/UserSummary"
264+ },
265+ "type":"array"
266+ },
267+ "description":""
268+ }
269+ },
270+ "produces":[
271+ "application/json;charset=utf-8"
272+ ],
273+ "tags":[
274+ "users"
275+ ]
276+ }
277+ },
278+ "/packages":{
279+ "get":{
280+ "responses":{
281+ "200":{
282+ "schema":{
283+ "items":{
284+ "$ref":"#/definitions/Package"
285+ },
286+ "type":"array"
287+ },
288+ "description":""
289+ }
290+ },
291+ "produces":[
292+ "application/json;charset=utf-8"
293+ ],
294+ "tags":[
295+ "packages"
296+ ]
297+ }
298+ },
299+ "/user/{username}":{
300+ "get":{
301+ "responses":{
302+ "400":{
303+ "description":"Invalid `username`"
304+ },
305+ "200":{
306+ "schema":{
307+ "$ref":"#/definitions/UserDetailed"
308+ },
309+ "description":""
310+ }
311+ },
312+ "produces":[
313+ "application/json;charset=utf-8"
314+ ],
315+ "parameters":[
316+ {
317+ "required":true,
318+ "in":"path",
319+ "name":"username",
320+ "type":"string"
321+ }
322+ ],
323+ "tags":[
324+ "users"
325+ ]
326+ }
327+ }
328+ },
329+ "tags":[
330+ {
331+ "name":"users",
332+ "description":"Operations about user"
333+ },
334+ {
335+ "name":"packages",
336+ "description":"Query packages"
337+ }
338+ ]
339+}
340+|]
341+ where
342+ modifyValue :: Value -> Value
343+#if MIN_VERSION_swagger2(2,4,0)
344+ modifyValue = id
345+#else
346+ -- swagger2-2.4 preserves order of tags
347+ -- swagger2-2.3 used Set, so they are ordered
348+ -- packages comes before users.
349+ -- We simply reverse, not properly sort here for simplicity: 2 elements.
350+ modifyValue = over (key "tags" . _Array) V.reverse
351+#endif
352+
353+
354+-- =======================================================================
355+-- Get/Post API (test for subOperations)
356+-- =======================================================================
357+
358+type GetPostAPI = Get '[JSON] String :<|> Post '[JSON] String
359+
360+getPostSwagger :: Swagger
361+getPostSwagger = toSwagger (Proxy :: Proxy GetPostAPI)
362+ & applyTagsFor getOps ["get" & description ?~ "GET operations"]
363+ where
364+ getOps :: Traversal' Swagger Operation
365+ getOps = subOperations (Proxy :: Proxy (Get '[JSON] String)) (Proxy :: Proxy GetPostAPI)
366+
367+getPostAPI :: Value
368+getPostAPI = [aesonQQ|
369+{
370+ "swagger":"2.0",
371+ "info":{
372+ "version":"",
373+ "title":""
374+ },
375+ "paths":{
376+ "/":{
377+ "post":{
378+ "responses":{
379+ "200":{
380+ "schema":{
381+ "type":"string"
382+ },
383+ "description":""
384+ }
385+ },
386+ "produces":[ "application/json;charset=utf-8" ]
387+ },
388+ "get":{
389+ "responses":{
390+ "200":{
391+ "schema":{
392+ "type":"string"
393+ },
394+ "description":""
395+ }
396+ },
397+ "produces":[ "application/json;charset=utf-8" ],
398+ "tags":[ "get" ]
399+ }
400+ }
401+ },
402+ "tags":[
403+ {
404+ "name":"get",
405+ "description":"GET operations"
406+ }
407+ ]
408+}
409+|]
410+
411+-- =======================================================================
412+-- UVerb API
413+-- =======================================================================
414+
415+data Lunch = Lunch {name :: String}
416+ deriving (Eq, Show, Generic)
417+
418+instance ToSchema Lunch
419+
420+instance HasStatus Lunch where
421+ type StatusOf Lunch = 200
422+
423+data NoLunch = NoLunch
424+ deriving (Eq, Show, Generic)
425+
426+instance ToSchema NoLunch
427+
428+instance HasStatus NoLunch where
429+ type StatusOf NoLunch = 404
430+
431+type UVerbAPI2 =
432+ "lunch" :> UVerb 'GET '[JSON] '[Lunch, NoLunch]
433+
434+uverbSwagger :: Swagger
435+uverbSwagger = toSwagger (Proxy :: Proxy UVerbAPI2)
436+
437+uverbAPI :: Value
438+uverbAPI =
439+ [aesonQQ|
440+ {
441+ "swagger": "2.0",
442+ "info": {
443+ "version": "",
444+ "title": ""
445+ },
446+ "definitions": {
447+ "Lunch": {
448+ "required": [
449+ "name"
450+ ],
451+ "type": "object",
452+ "properties": {
453+ "name": {
454+ "type": "string"
455+ }
456+ }
457+ },
458+ "NoLunch": {
459+ "type": "string",
460+ "enum": [
461+ "NoLunch"
462+ ]
463+ }
464+ },
465+ "paths": {
466+ "/lunch": {
467+ "get": {
468+ "responses": {
469+ "404": {
470+ "schema": {
471+ "$ref": "#/definitions/NoLunch"
472+ },
473+ "description": ""
474+ },
475+ "200": {
476+ "schema": {
477+ "$ref": "#/definitions/Lunch"
478+ },
479+ "description": ""
480+ }
481+ },
482+ "produces": [
483+ "application/json;charset=utf-8"
484+ ]
485+ }
486+ }
487+ }
488+}
489+|]
servant-swagger/test/Spec.hsnew file+1
@@ -0,0 +1 @@
1+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
servant-swagger/test/doctests.hsnew file+12
@@ -0,0 +1,12 @@
1+module Main where
2+
3+import Build_doctests (flags, pkgs, module_sources)
4+import Data.Foldable (traverse_)
5+import Test.DocTest
6+
7+main :: IO ()
8+main = do
9+ traverse_ putStrLn args
10+ doctest args
11+ where
12+ args = flags ++ pkgs ++ module_sources
servant/servant.cabal+1−1
@@ -99,7 +99,7 @@ library
9999 -- Here can be exceptions if we really need features from the newer versions.
100100 build-depends:
101101 base-compat >= 0.10.5 && < 0.12
102− , aeson >= 1.4.1.0 && < 1.6
102+ , aeson >= 1.4.1.0 && < 3
103103 , attoparsec >= 0.13.2.2 && < 0.15
104104 , bifunctors >= 5.5.3 && < 5.6
105105 , case-insensitive >= 1.2.0.11 && < 1.3