git.iko.soy/typeable/servant
on master help sign in
.github/workflows/master.yml+17−29
since splitsnapshots
unifiedsplit
@@ -13,12 +13,13 @@ jobs:
13 strategy:
13 strategy:
14 matrix:
14 matrix:
15 os: [ubuntu-latest]
15 os: [ubuntu-latest]
16− cabal: ["3.4"]
16+ cabal: ["3.6"]
17 ghc:
17 ghc:
18 - "8.6.5"
18 - "8.6.5"
19 - "8.8.4"
19 - "8.8.4"
20 - "8.10.7"
20 - "8.10.7"
21− - "9.0.1"
21+ - "9.0.2"
22+ - "9.2.2"
22
23
23 steps:
24 steps:
24 - uses: actions/checkout@v2
25 - uses: actions/checkout@v2
@@ -47,10 +48,7 @@ jobs:
47
48
48 - name: Configure
49 - name: Configure
49 run: |
50 run: |
50− # Using separate store-dir because default one already has 'ghc-paths' package installed
51− # with hardcoded path to ghcup's GHC path (which it was built with). This leads to failure in
52− # doctest, as it tries to invoke that GHC, and it doesn't exist here.
53− cabal --store-dir /tmp/cabal-store install --ignore-project -j2 doctest --constraint='doctest ^>=0.18'
51+ cabal install --ignore-project -j2 doctest --constraint='doctest ^>=0.20'
54
52
55 - name: Build
53 - name: Build
56 run: |
54 run: |
@@ -61,39 +59,29 @@ jobs:
61 cabal test all
59 cabal test all
62
60
63 - name: Run doctests
61 - name: Run doctests
64− # doctests are broken on GHC 9 due to compiler bug:
65− # https://gitlab.haskell.org/ghc/ghc/-/issues/19460
66− continue-on-error: ${{ matrix.ghc == '9.0.1' }}
67 run: |
62 run: |
68 # Necessary for doctest to be found in $PATH
63 # Necessary for doctest to be found in $PATH
69 export PATH="$HOME/.cabal/bin:$PATH"
64 export PATH="$HOME/.cabal/bin:$PATH"
70
65
71− # Filter out base-compat-batteries from .ghc.environment.*, as its modules
66+ DOCTEST="cabal repl --with-ghc=doctest --ghc-options=-w"
72− # conflict with those of base-compat.
73− #
74− # FIXME: This is an ugly hack. Ultimately, we'll want to use cabal-doctest
75− # (or cabal v2-doctest, if it ever lands) to provide a clean GHC environment.
76− # This might allow running doctests in GHCJS build as well.
77− perl -i -e 'while (<ARGV>) { print unless /package-id\s+(base-compat-batteries)-\d+(\.\d+)*/; }' .ghc.environment.*
78−
79− (cd servant && doctest src)
67+ (cd servant && eval $DOCTEST)
80− (cd servant-client && doctest src)
68+ (cd servant-client && eval $DOCTEST)
81− (cd servant-client-core && doctest src)
69+ (cd servant-client-core && eval $DOCTEST)
82− (cd servant-http-streams && doctest src)
70+ (cd servant-http-streams && eval $DOCTEST)
83− (cd servant-docs && doctest src)
71+ (cd servant-docs && eval $DOCTEST)
84− (cd servant-foreign && doctest src)
72+ (cd servant-foreign && eval $DOCTEST)
85− (cd servant-server && doctest src)
73+ (cd servant-server && eval $DOCTEST)
86− (cd servant-machines && doctest src)
74+ (cd servant-machines && eval $DOCTEST)
87− (cd servant-conduit && doctest src)
75+ (cd servant-conduit && eval $DOCTEST)
88− (cd servant-pipes && doctest src)
76+ (cd servant-pipes && eval $DOCTEST)
89
77
90 stack:
78 stack:
91 name: stack / ghc ${{ matrix.ghc }}
79 name: stack / ghc ${{ matrix.ghc }}
92 runs-on: ubuntu-latest
80 runs-on: ubuntu-latest
93 strategy:
81 strategy:
94 matrix:
82 matrix:
95− stack: ["2.7.3"]
83+ stack: ["2.7.5"]
96− ghc: ["8.10.4"]
84+ ghc: ["8.10.7"]
97
85
98 steps:
86 steps:
99 - uses: actions/checkout@v2
87 - uses: actions/checkout@v2
.gitignore+1
@@ -31,6 +31,7 @@ doc/venv
31doc/tutorial/static/api.js
31doc/tutorial/static/api.js
32doc/tutorial/static/jq.js
32doc/tutorial/static/jq.js
33shell.nix
33shell.nix
34+.hspec-failures
34
35
35# nix
36# nix
36result*
37result*
CONTRIBUTING.md+4−2
@@ -79,8 +79,10 @@ not been a timely response to a PR, you can ping the Maintainers group (with
79We encourage people to experiment with new combinators and instances - it is
79We encourage people to experiment with new combinators and instances - it is
80one of the most powerful ways of using `servant`, and a wonderful way of
80one of the most powerful ways of using `servant`, and a wonderful way of
81getting to know it better. If you do write a new combinator, we would love to
81getting to know it better. If you do write a new combinator, we would love to
82−know about it! Either hop on #servant on freenode and let us know, or open an
82+know about it! Either hop on
83+[#haskell-servant on libera.chat](https://web.libera.chat/#haskell-servant) and
83−issue with the `news` tag (which we will close when we read it).
84+let us know, or open an issue with the `news` tag (which we will close when we
85+read it).
84
86
85As for adding them to the main repo: maintaining combinators can be expensive,
87As for adding them to the main repo: maintaining combinators can be expensive,
86since official combinators must have instances for all classes (and new classes
88since official combinators must have instances for all classes (and new classes
cabal.project+2−24
@@ -12,6 +12,7 @@ packages:
12 servant-docs/
12 servant-docs/
13 servant-foreign/
13 servant-foreign/
14 servant-server/
14 servant-server/
15+ servant-swagger/
15 doc/tutorial/
16 doc/tutorial/
16
17
17-- servant streaming
18-- servant streaming
@@ -36,7 +37,7 @@ packages:
36 doc/cookbook/generic
37 doc/cookbook/generic
37 doc/cookbook/hoist-server-with-context
38 doc/cookbook/hoist-server-with-context
38 doc/cookbook/https
39 doc/cookbook/https
39− -- doc/cookbook/jwt-and-basic-auth/
40+ doc/cookbook/jwt-and-basic-auth
40 doc/cookbook/pagination
41 doc/cookbook/pagination
41 -- doc/cookbook/sentry
42 -- doc/cookbook/sentry
42 -- Commented out because servant-quickcheck currently doesn't build.
43 -- Commented out because servant-quickcheck currently doesn't build.
@@ -50,26 +51,3 @@ packages:
50tests: True
51tests: True
51optimization: False
52optimization: False
52-- reorder-goals: True
53-- reorder-goals: True
53−
54−constraints:
55− -- see https://github.com/haskell-infra/hackage-trustees/issues/119
56− foundation >=0.0.14,
57− memory <0.14.12 || >0.14.12
58−
59−constraints: base-compat ^>=0.11
60−constraints: semigroups ^>=0.19
61−
62−-- allow-newer: sqlite-simple-0.4.16.0:semigroups
63−-- allow-newer: direct-sqlite-2.3.24:semigroups
64−
65−-- needed for doctests
66−write-ghc-environment-files: always
67−
68−-- https://github.com/chordify/haskell-servant-pagination/pull/12
69−allow-newer: servant-pagination-2.2.2:servant
70−allow-newer: servant-pagination-2.2.2:servant-server
71−
72−allow-newer: servant-js:servant
73−
74−-- ghc 9
75−allow-newer: tdigest:base
changelog.d/1469new file+11
@@ -0,0 +1,11 @@
1+synopsis: Derive HasClient good response status from Verb status
2+prs: #1469
3+description: {
4+`HasClient` instances for the `Verb` datatype use `runRequest` in
5+`clientWithRoute` definitions.
6+This means that a request performed with `runClientM` will be successful if and
7+only if the endpoint specify a response status code >=200 and <300.
8+This change replaces `runRequest` with `runRequestAcceptStatus` in `Verb`
9+instances for the `HasClient` class, deriving the good response status from
10+the `Verb` status.
11+}
changelog.d/1529new file+10
@@ -0,0 +1,10 @@
1+synopsis: Fix performRequest in servant-client-ghcjs
2+prs: #1529
3+
4+description: {
5+
6+performRequest function in servant-client-ghcjs was not compatible with the
7+latest RunClient typeclass. Added the acceptStatus parameter and fixed the
8+functionality to match what servant-client provides.
9+
10+}
changelog.d/1556new file+81
@@ -0,0 +1,81 @@
1+synopsis: Display capture hints in router layout
2+prs: #1556
3+
4+description: {
5+
6+This PR enhances the `Servant.Server.layout` function, which produces a textual description of the routing layout of an API. More precisely, it changes `<capture>` blocks, so that they display the name and type of the variable being captured instead.
7+
8+Example:
9+
10+For the following API
11+```haskell
12+type API =
13+ "a" :> "d" :> Get '[JSON] NoContent
14+ :<|> "b" :> Capture "x" Int :> Get '[JSON] Bool
15+ :<|> "a" :> "e" :> Get '[JSON] Int
16+```
17+
18+we previously got the following output:
19+
20+```
21+/
22+├─ a/
23+│ ├─ d/
24+│ │ └─•
25+│ └─ e/
26+│ └─•
27+└─ b/
28+ └─ <capture>/
29+ ├─•
30+ ┆
31+ └─•
32+```
33+
34+now we get:
35+
36+```
37+/
38+├─ a/
39+│ ├─ d/
40+│ │ └─•
41+│ └─ e/
42+│ └─•
43+└─ b/
44+ └─ <x::Int>/
45+ ├─•
46+ ┆
47+ └─•
48+```
49+
50+This change is achieved by the introduction of a CaptureHint type, which is passed as an extra argument to the CaptureRouter and CaptureAllRouter constructors for the Router' type.
51+CaptureHint values are then used in routerLayout, to display the name and type of captured values, instead of just `<capture>` previously.
52+
53+N.B.:
54+Because the choice smart constructor for routers can aggregate Capture combinators with different capture hints, the Capture*Router constructors actually take a list of CaptureHint, instead of a single one.
55+
56+This PR also introduces Spec tests for the routerLayout function.
57+
58+Warning:
59+This change is potentially breaking, because it adds the constraint `Typeable a` to all types that are to be captured. Because all types are typeable since GHC 7.10, this is not as bad as it sounds ; it only break expressions where `a` is quantified in an expression with `Capture a`.
60+In those cases, the fix is easy: it suffices to add `Typeable a` to the left-hand side of the quantification constraint.
61+
62+For instance, the following code will no longer compile:
63+```haskell
64+type MyAPI a = Capture "foo" a :> Get '[JSON] ()
65+
66+myServer :: forall a. Server (MyAPI a)
67+myServer = const $ return ()
68+
69+myApi :: forall a. Proxy (MyAPI a)
70+myApi = Proxy
71+
72+app :: forall a. (FromHttpApiData a) => Application
73+app = serve (myApi @a) (myServer @a)
74+```
75+
76+Indeed, `app` should be replaced with:
77+```haskell
78+app :: forall a. (FromHttpApiData a, Typeable a) => Application
79+app = serve (myApi @a) (myServer @a)
80+```
81+}
changelog.d/1569new file+13
@@ -0,0 +1,13 @@
1+synopsis: Encode captures using toEncodedUrlPiece
2+prs: #1569
3+issues: #1511
4+
5+description: {
6+The `servant-client` library now makes direct use of `toEncodedUrlPiece` from `ToHttpApiData`
7+to encode captured values when building the request path. It gives user freedom to implement
8+URL-encoding however they need.
9+
10+Previous behavior was to use `toUrlPiece` and URL-encode its output using `toEncodedUrlPiece`
11+from the `Text` instance of `ToHttpApiData`. The issue with this approach is that
12+`ToHttpApiData Text` is overly zealous and also encodes characters, such as `*`, which are perfectly valid in a URL.
13+}
changelog.d/1580new file+12
@@ -0,0 +1,12 @@
1+synopsis: Allow IO in validationKeys
2+prs: #1580
3+issues: #1579
4+
5+description: {
6+
7+Currently validationKeys are a fixed JWKSet. This does not work with OIDC
8+providers such as AWS Cognito or Okta, which regularly fetching jwks_uri to
9+discover new and expired keys.
10+
11+This change alters the type of validationKeys from JWKSet to IO JWKSet.
12+}
changelog.d/1589new file+2
@@ -0,0 +1,2 @@
1+synopsis: Only include question mark for nonempty query strings
2+prs: 1589
changelog.d/1595new file+2
@@ -0,0 +1,2 @@
1+synopsis: Run ClientEnv's makeClientRequest in IO.
2+prs: #1595
doc/Makefile+1−1
@@ -10,7 +10,7 @@ BUILDDIR = _build
10
10
11# Put it first so that "make" without argument is like "make help".
11# Put it first so that "make" without argument is like "make help".
12help:
12help:
13− @if [ ! -d venv ]; then echo "WARNING: There is no venv directory, did you forget to 'virtualenv venv'. Check building-the-docs file."; fi
13+ @if [ ! -d venv ]; then echo "WARNING: There is no venv directory, did you forget to 'virtualenv venv'. Check README.md."; fi
14 @if [ ! "z$$(which $(SPHINXBUILD))" = "z$$(pwd)/venv/bin/sphinx-build" ]; then echo "WARNING: Did you forgot to 'source venv/bin/activate'"; fi
14 @if [ ! "z$$(which $(SPHINXBUILD))" = "z$$(pwd)/venv/bin/sphinx-build" ]; then echo "WARNING: Did you forgot to 'source venv/bin/activate'"; fi
15 @$(SPHINXBUILD) -M help "$(SOURCEDIR)" "$(BUILDDIR)" $(SPHINXOPTS) $(O)
15 @$(SPHINXBUILD) -M help "$(SOURCEDIR)" "$(BUILDDIR)" $(SPHINXOPTS) $(O)
16
16
doc/conf.py+1−2
@@ -46,7 +46,7 @@ master_doc = 'index'
46
46
47# General information about the project.
47# General information about the project.
48project = u'Servant'
48project = u'Servant'
49−copyright = u'2018, Servant Contributors'
49+copyright = u'2022, Servant Contributors'
50author = u'Servant Contributors'
50author = u'Servant Contributors'
51
51
52# The version info for the project you're documenting, acts as replacement for
52# The version info for the project you're documenting, acts as replacement for
@@ -169,4 +169,3 @@ texinfo_documents = [
169source_parsers = {
169source_parsers = {
170 '.lhs': CommonMarkParser,
170 '.lhs': CommonMarkParser,
171}
171}
172−
doc/cookbook/basic-auth/basic-auth.cabal+2−2
@@ -1,13 +1,13 @@
1+cabal-version: 2.2
1name: cookbook-basic-auth
2name: cookbook-basic-auth
2version: 0.1
3version: 0.1
3synopsis: Basic Authentication cookbook example
4synopsis: Basic Authentication cookbook example
4homepage: http://docs.servant.dev/
5homepage: http://docs.servant.dev/
5−license: BSD3
6+license: BSD-3-Clause
6license-file: ../../../servant/LICENSE
7license-file: ../../../servant/LICENSE
7author: Servant Contributors
8author: Servant Contributors
8maintainer: haskell-servant-maintainers@googlegroups.com
9maintainer: haskell-servant-maintainers@googlegroups.com
9build-type: Simple
10build-type: Simple
10−cabal-version: >=1.10
11tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
11tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
12
12
13executable cookbook-basic-auth
13executable cookbook-basic-auth
doc/cookbook/basic-streaming/basic-streaming.cabal+2−2
@@ -1,13 +1,13 @@
1+cabal-version: 2.2
1name: cookbook-basic-streaming
2name: cookbook-basic-streaming
2version: 2.1
3version: 2.1
3synopsis: Streaming in servant without streaming libs
4synopsis: Streaming in servant without streaming libs
4homepage: http://docs.servant.dev/
5homepage: http://docs.servant.dev/
5−license: BSD3
6+license: BSD-3-Clause
6license-file: ../../../servant/LICENSE
7license-file: ../../../servant/LICENSE
7author: Servant Contributors
8author: Servant Contributors
8maintainer: haskell-servant-maintainers@googlegroups.com
9maintainer: haskell-servant-maintainers@googlegroups.com
9build-type: Simple
10build-type: Simple
10−cabal-version: >=1.10
11tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
11tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
12
12
13executable cookbook-basic-streaming
13executable cookbook-basic-streaming
doc/cookbook/curl-mock/curl-mock.cabal+5−2
@@ -1,16 +1,19 @@
1+cabal-version: 2.2
1name: cookbook-curl-mock
2name: cookbook-curl-mock
2version: 0.1
3version: 0.1
3synopsis: Generate curl mock requests cookbook example
4synopsis: Generate curl mock requests cookbook example
4homepage: http://docs.servant.dev
5homepage: http://docs.servant.dev
5−license: BSD3
6+license: BSD-3-Clause
6license-file: ../../../servant/LICENSE
7license-file: ../../../servant/LICENSE
7author: Servant Contributors
8author: Servant Contributors
8maintainer: haskell-servant-maintainers@googlegroups.com
9maintainer: haskell-servant-maintainers@googlegroups.com
9build-type: Simple
10build-type: Simple
10−cabal-version: >=1.10
11tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
11tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
12
12
13executable cookbock-curl-mock
13executable cookbock-curl-mock
14+ if impl(ghc >= 9.2)
15+ -- generic-arbitrary is incompatible
16+ buildable: False
14 main-is: CurlMock.lhs
17 main-is: CurlMock.lhs
15 build-depends: base == 4.*
18 build-depends: base == 4.*
16 , aeson
19 , aeson
doc/cookbook/custom-errors/custom-errors.cabal+2−2
@@ -1,13 +1,13 @@
1+cabal-version: 2.2
1name: cookbook-custom-errors
2name: cookbook-custom-errors
2version: 0.1
3version: 0.1
3synopsis: Return custom error messages from combinators
4synopsis: Return custom error messages from combinators
4homepage: http://docs.servant.dev
5homepage: http://docs.servant.dev
5−license: BSD3
6+license: BSD-3-Clause
6license-file: ../../../servant/LICENSE
7license-file: ../../../servant/LICENSE
7author: Servant Contributors
8author: Servant Contributors
8maintainer: haskell-servant-maintainers@googlegroups.com
9maintainer: haskell-servant-maintainers@googlegroups.com
9build-type: Simple
10build-type: Simple
10−cabal-version: >=1.10
11tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
11tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
12
12
13executable cookbook-custom-errors
13executable cookbook-custom-errors
doc/cookbook/db-mysql-basics/mysql-basics.cabal+2−2
@@ -1,13 +1,13 @@
1+cabal-version: 2.2
1name: mysql-basics
2name: mysql-basics
2version: 0.1.0.0
3version: 0.1.0.0
3synopsis: Simple MySQL API cookbook example
4synopsis: Simple MySQL API cookbook example
4homepage: http://docs.servant.dev/
5homepage: http://docs.servant.dev/
5−license: BSD3
6+license: BSD-3-Clause
6license-file: ../../../servant/LICENSE
7license-file: ../../../servant/LICENSE
7author: Servant Contributors
8author: Servant Contributors
8maintainer: haskell-servant-maintainers@googlegroups.com
9maintainer: haskell-servant-maintainers@googlegroups.com
9build-type: Simple
10build-type: Simple
10−cabal-version: >=1.10
11
11
12executable run
12executable run
13 hs-source-dirs: .
13 hs-source-dirs: .
doc/cookbook/db-postgres-pool/db-postgres-pool.cabal+2−2
@@ -1,13 +1,13 @@
1+cabal-version: 2.2
1name: cookbook-db-postgres-pool
2name: cookbook-db-postgres-pool
2version: 0.1
3version: 0.1
3synopsis: Simple PostgreSQL connection pool cookbook example
4synopsis: Simple PostgreSQL connection pool cookbook example
4homepage: http://docs.servant.dev/
5homepage: http://docs.servant.dev/
5−license: BSD3
6+license: BSD-3-Clause
6license-file: ../../../servant/LICENSE
7license-file: ../../../servant/LICENSE
7author: Servant Contributors
8author: Servant Contributors
8maintainer: haskell-servant-maintainers@googlegroups.com
9maintainer: haskell-servant-maintainers@googlegroups.com
9build-type: Simple
10build-type: Simple
10−cabal-version: >=1.10
11tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
11tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
12
12
13executable cookbook-db-postgres-pool
13executable cookbook-db-postgres-pool
doc/cookbook/db-sqlite-simple/db-sqlite-simple.cabal+2−2
@@ -1,13 +1,13 @@
1+cabal-version: 2.2
1name: cookbook-db-sqlite-simple
2name: cookbook-db-sqlite-simple
2version: 0.1
3version: 0.1
3synopsis: Simple SQLite DB cookbook example
4synopsis: Simple SQLite DB cookbook example
4homepage: http://docs.servant.dev/
5homepage: http://docs.servant.dev/
5−license: BSD3
6+license: BSD-3-Clause
6license-file: ../../../servant/LICENSE
7license-file: ../../../servant/LICENSE
7author: Servant Contributors
8author: Servant Contributors
8maintainer: haskell-servant-maintainers@googlegroups.com
9maintainer: haskell-servant-maintainers@googlegroups.com
9build-type: Simple
10build-type: Simple
10−cabal-version: >=1.10
11tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
11tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
12
12
13executable cookbook-db-sqlite-simple
13executable cookbook-db-sqlite-simple
doc/cookbook/file-upload/file-upload.cabal+2−2
@@ -1,13 +1,13 @@
1+cabal-version: 2.2
1name: cookbook-file-upload
2name: cookbook-file-upload
2version: 0.1
3version: 0.1
3synopsis: File upload cookbook example
4synopsis: File upload cookbook example
4homepage: http://docs.servant.dev/
5homepage: http://docs.servant.dev/
5−license: BSD3
6+license: BSD-3-Clause
6license-file: ../../../servant/LICENSE
7license-file: ../../../servant/LICENSE
7author: Servant Contributors
8author: Servant Contributors
8maintainer: haskell-servant-maintainers@googlegroups.com
9maintainer: haskell-servant-maintainers@googlegroups.com
9build-type: Simple
10build-type: Simple
10−cabal-version: >=1.10
11tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
11tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
12
12
13executable cookbook-file-upload
13executable cookbook-file-upload
doc/cookbook/generic/generic.cabal+2−2
@@ -1,13 +1,13 @@
1+cabal-version: 2.2
1name: cookbook-generic
2name: cookbook-generic
2version: 0.1
3version: 0.1
3synopsis: Using custom monad to pass a state between handlers
4synopsis: Using custom monad to pass a state between handlers
4homepage: http://docs.servant.dev/
5homepage: http://docs.servant.dev/
5−license: BSD3
6+license: BSD-3-Clause
6license-file: ../../../servant/LICENSE
7license-file: ../../../servant/LICENSE
7author: Servant Contributors
8author: Servant Contributors
8maintainer: haskell-servant-maintainers@googlegroups.com
9maintainer: haskell-servant-maintainers@googlegroups.com
9build-type: Simple
10build-type: Simple
10−cabal-version: >=1.10
11tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
11tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
12
12
13executable cookbook-using-custom-monad
13executable cookbook-using-custom-monad
doc/cookbook/hoist-server-with-context/hoist-server-with-context.cabal+2−2
@@ -1,16 +1,16 @@
1+cabal-version: 2.2
1name: cookbook-hoist-server-with-context
2name: cookbook-hoist-server-with-context
2version: 0.0.1
3version: 0.0.1
3synopsis: JWT and basic access authentication with a Custom Monad cookbook example
4synopsis: JWT and basic access authentication with a Custom Monad cookbook example
4description: Using servant-auth to support both JWT-based and basic
5description: Using servant-auth to support both JWT-based and basic
5 authentication.
6 authentication.
6homepage: http://docs.servant.dev/
7homepage: http://docs.servant.dev/
7−license: BSD3
8+license: BSD-3-Clause
8license-file: ../../../servant/LICENSE
9license-file: ../../../servant/LICENSE
9author: Servant Contributors
10author: Servant Contributors
10maintainer: haskell-servant-maintainers@googlegroups.com
11maintainer: haskell-servant-maintainers@googlegroups.com
11category: Servant
12category: Servant
12build-type: Simple
13build-type: Simple
13−cabal-version: >=1.10
14tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
14tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
15
15
16executable cookbook-hoist-server-with-context
16executable cookbook-hoist-server-with-context
doc/cookbook/https/https.cabal+2−2
@@ -1,13 +1,13 @@
1+cabal-version: 2.2
1name: cookbook-https
2name: cookbook-https
2version: 0.1
3version: 0.1
3synopsis: HTTPS cookbook example
4synopsis: HTTPS cookbook example
4homepage: http://docs.servant.dev/
5homepage: http://docs.servant.dev/
5−license: BSD3
6+license: BSD-3-Clause
6license-file: ../../../servant/LICENSE
7license-file: ../../../servant/LICENSE
7author: Servant Contributors
8author: Servant Contributors
8maintainer: haskell-servant-maintainers@googlegroups.com
9maintainer: haskell-servant-maintainers@googlegroups.com
9build-type: Simple
10build-type: Simple
10−cabal-version: >=1.10
11tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
11tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
12
12
13executable cookbook-https
13executable cookbook-https
doc/cookbook/index.rst+2−2
@@ -6,8 +6,8 @@ how to solve many common problems with servant. If you're
6interested in contributing examples of your own, feel free
6interested in contributing examples of your own, feel free
7to open an issue or a pull request on
7to open an issue or a pull request on
8`our github repository <https://github.com/haskell-servant/servant>`_
8`our github repository <https://github.com/haskell-servant/servant>`_
9−or even to just get in touch with us on the **#servant** IRC channel
9+or even to just get in touch with us on the `**#haskell-servant** IRC channel
10−on freenode or on
10+on libera.chat <https://web.libera.chat/#haskell-servant>_ or on
11`the mailing list <https://groups.google.com/forum/#!forum/haskell-servant>`_.
11`the mailing list <https://groups.google.com/forum/#!forum/haskell-servant>`_.
12
12
13The scope is very wide. Simple and fancy authentication schemes,
13The scope is very wide. Simple and fancy authentication schemes,
doc/cookbook/jwt-and-basic-auth/jwt-and-basic-auth.cabal+3−3
@@ -1,16 +1,16 @@
1+cabal-version: 2.2
1name: cookbook-jwt-and-basic-auth
2name: cookbook-jwt-and-basic-auth
2version: 0.0.1
3version: 0.0.1
3synopsis: JWT and basic access authentication cookbook example
4synopsis: JWT and basic access authentication cookbook example
4description: Using servant-auth to support both JWT-based and basic
5description: Using servant-auth to support both JWT-based and basic
5 authentication.
6 authentication.
6homepage: http://docs.servant.dev/
7homepage: http://docs.servant.dev/
7−license: BSD3
8+license: BSD-3-Clause
8license-file: ../../../servant/LICENSE
9license-file: ../../../servant/LICENSE
9author: Servant Contributors
10author: Servant Contributors
10maintainer: haskell-servant-maintainers@googlegroups.com
11maintainer: haskell-servant-maintainers@googlegroups.com
11category: Servant
12category: Servant
12build-type: Simple
13build-type: Simple
13−cabal-version: >=1.10
14tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
14tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
15
15
16executable cookbook-jwt-and-basic-auth
16executable cookbook-jwt-and-basic-auth
@@ -22,7 +22,7 @@ executable cookbook-jwt-and-basic-auth
22 , servant
22 , servant
23 , servant-client
23 , servant-client
24 , servant-server
24 , servant-server
25− , servant-auth ==0.3.*
25+ , servant-auth == 0.4.*
26 , servant-auth-server >= 0.3.1.0
26 , servant-auth-server >= 0.3.1.0
27 , warp >= 3.2
27 , warp >= 3.2
28 , wai >= 3.2
28 , wai >= 3.2
doc/cookbook/open-id-connect/OpenIdConnect.cabal+2−2
@@ -1,13 +1,13 @@
1+cabal-version: 2.2
1name: open-id-connect
2name: open-id-connect
2version: 0.1
3version: 0.1
3synopsis: OpenId Connect with Servant example
4synopsis: OpenId Connect with Servant example
4homepage: http://haskell-servant.readthedocs.org/
5homepage: http://haskell-servant.readthedocs.org/
5−license: BSD3
6+license: BSD-3-Clause
6license-file: ../../../servant/LICENSE
7license-file: ../../../servant/LICENSE
7author: Servant Contributors
8author: Servant Contributors
8maintainer: haskell-servant-maintainers@googlegroups.com
9maintainer: haskell-servant-maintainers@googlegroups.com
9build-type: Simple
10build-type: Simple
10−cabal-version: >= 1.10
11tested-with: GHC==8.6.5
11tested-with: GHC==8.6.5
12
12
13executable cookbook-openidconnect
13executable cookbook-openidconnect
doc/cookbook/pagination/pagination.cabal+2−2
@@ -1,13 +1,13 @@
1+cabal-version: 2.2
1name: cookbook-pagination
2name: cookbook-pagination
2version: 2.1
3version: 2.1
3synopsis: Pagination with Servant example
4synopsis: Pagination with Servant example
4homepage: http://docs.servant.dev/
5homepage: http://docs.servant.dev/
5−license: BSD3
6+license: BSD-3-Clause
6license-file: ../../../servant/LICENSE
7license-file: ../../../servant/LICENSE
7author: Servant Contributors
8author: Servant Contributors
8maintainer: haskell-servant-maintainers@googlegroups.com
9maintainer: haskell-servant-maintainers@googlegroups.com
9build-type: Simple
10build-type: Simple
10−cabal-version: >=1.10
11tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
11tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
12
12
13executable cookbook-pagination
13executable cookbook-pagination
doc/cookbook/sentry/sentry.cabal+2−2
@@ -1,13 +1,13 @@
1+cabal-version: 2.2
1name: cookbook-sentry
2name: cookbook-sentry
2version: 0.1
3version: 0.1
3synopsis: Collecting runtime exceptions using Sentry
4synopsis: Collecting runtime exceptions using Sentry
4homepage: http://docs.servant.dev/
5homepage: http://docs.servant.dev/
5−license: BSD3
6+license: BSD-3-Clause
6license-file: ../../../servant/LICENSE
7license-file: ../../../servant/LICENSE
7author: Servant Contributors
8author: Servant Contributors
8maintainer: haskell-servant-maintainers@googlegroups.com
9maintainer: haskell-servant-maintainers@googlegroups.com
9build-type: Simple
10build-type: Simple
10−cabal-version: >=1.10
11tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
11tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
12
12
13executable cookbook-sentry
13executable cookbook-sentry
doc/cookbook/structuring-apis/structuring-apis.cabal+2−2
@@ -1,13 +1,13 @@
1+cabal-version: 2.2
1name: cookbook-structuring-apis
2name: cookbook-structuring-apis
2version: 0.1
3version: 0.1
3synopsis: Example that shows how APIs can be structured
4synopsis: Example that shows how APIs can be structured
4homepage: http://docs.servant.dev/
5homepage: http://docs.servant.dev/
5−license: BSD3
6+license: BSD-3-Clause
6license-file: ../../../servant/LICENSE
7license-file: ../../../servant/LICENSE
7author: Servant Contributors
8author: Servant Contributors
8maintainer: haskell-servant-maintainers@googlegroups.com
9maintainer: haskell-servant-maintainers@googlegroups.com
9build-type: Simple
10build-type: Simple
10−cabal-version: >=1.10
11tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
11tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
12
12
13executable cookbook-structuring-apis
13executable cookbook-structuring-apis
doc/cookbook/testing/testing.cabal+2−2
@@ -1,15 +1,15 @@
1+cabal-version: 2.2
1name: cookbook-testing
2name: cookbook-testing
2version: 0.0.1
3version: 0.0.1
3synopsis: Common testing patterns in Servant apps
4synopsis: Common testing patterns in Servant apps
4description: This recipe includes various strategies for writing tests for Servant.
5description: This recipe includes various strategies for writing tests for Servant.
5homepage: http://docs.servant.dev/
6homepage: http://docs.servant.dev/
6−license: BSD3
7+license: BSD-3-Clause
7license-file: ../../../servant/LICENSE
8license-file: ../../../servant/LICENSE
8author: Servant Contributors
9author: Servant Contributors
9maintainer: haskell-servant-maintainers@googlegroups.com
10maintainer: haskell-servant-maintainers@googlegroups.com
10category: Servant
11category: Servant
11build-type: Simple
12build-type: Simple
12−cabal-version: >=1.10
13tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
13tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
14
14
15executable cookbook-testing
15executable cookbook-testing
doc/cookbook/using-custom-monad/using-custom-monad.cabal+2−2
@@ -1,13 +1,13 @@
1+cabal-version: 2.2
1name: cookbook-using-custom-monad
2name: cookbook-using-custom-monad
2version: 0.1
3version: 0.1
3synopsis: Using custom monad to pass a state between handlers
4synopsis: Using custom monad to pass a state between handlers
4homepage: http://docs.servant.dev/
5homepage: http://docs.servant.dev/
5−license: BSD3
6+license: BSD-3-Clause
6license-file: ../../../servant/LICENSE
7license-file: ../../../servant/LICENSE
7author: Servant Contributors
8author: Servant Contributors
8maintainer: haskell-servant-maintainers@googlegroups.com
9maintainer: haskell-servant-maintainers@googlegroups.com
9build-type: Simple
10build-type: Simple
10−cabal-version: >=1.10
11tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
11tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
12
12
13executable cookbook-using-custom-monad
13executable cookbook-using-custom-monad
doc/cookbook/using-free-client/UsingFreeClient.lhs+1−1
@@ -119,7 +119,7 @@ Now we can use `servant-client`'s internals to convert servant's `Request`
119to http-client's `Request`, and we can inspect it:
119to http-client's `Request`, and we can inspect it:
120
120
121```haskell
121```haskell
122− let req' = I.defaultMakeClientRequest burl req
122+ req' <- I.defaultMakeClientRequest burl req
123 putStrLn $ "Making request: " ++ show req'
123 putStrLn $ "Making request: " ++ show req'
124```
124```
125
125
doc/cookbook/using-free-client/using-free-client.cabal+2−2
@@ -1,13 +1,13 @@
1+cabal-version: 2.2
1name: cookbook-using-free-client
2name: cookbook-using-free-client
2version: 0.1
3version: 0.1
3synopsis: Using Free client
4synopsis: Using Free client
4homepage: http://docs.servant.dev/
5homepage: http://docs.servant.dev/
5−license: BSD3
6+license: BSD-3-Clause
6license-file: ../../../servant/LICENSE
7license-file: ../../../servant/LICENSE
7author: Servant Contributors
8author: Servant Contributors
8maintainer: haskell-servant-maintainers@googlegroups.com
9maintainer: haskell-servant-maintainers@googlegroups.com
9build-type: Simple
10build-type: Simple
10−cabal-version: >=1.10
11tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
11tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
12
12
13executable cookbook-using-free-client
13executable cookbook-using-free-client
doc/cookbook/uverb/uverb.cabal+2−2
@@ -1,15 +1,15 @@
1+cabal-version: 2.2
1name: cookbook-uverb
2name: cookbook-uverb
2version: 0.0.1
3version: 0.0.1
3synopsis: How to use the 'UVerb' type.
4synopsis: How to use the 'UVerb' type.
4description: Listing alternative responses and exceptions in your API types.
5description: Listing alternative responses and exceptions in your API types.
5homepage: http://docs.servant.dev/
6homepage: http://docs.servant.dev/
6−license: BSD3
7+license: BSD-3-Clause
7license-file: ../../../servant/LICENSE
8license-file: ../../../servant/LICENSE
8author: Servant Contributors
9author: Servant Contributors
9maintainer: haskell-servant-maintainers@googlegroups.com
10maintainer: haskell-servant-maintainers@googlegroups.com
10category: Servant
11category: Servant
11build-type: Simple
12build-type: Simple
12−cabal-version: >=1.10
13tested-with: GHC==8.6.5, GHC==8.8.4, GHC==8.10.7
13tested-with: GHC==8.6.5, GHC==8.8.4, GHC==8.10.7
14
14
15executable cookbook-uverb
15executable cookbook-uverb
doc/links.rst+1−1
@@ -12,7 +12,7 @@ Helpful Links
12 `https://github.com/haskell-servant/servant/issues <https://github.com/haskell-servant/servant/issues>`_
12 `https://github.com/haskell-servant/servant/issues <https://github.com/haskell-servant/servant/issues>`_
13
13
14- the irc channel:
14- the irc channel:
15− ``#servant`` on freenode
15+ `#haskell-servant on libera.chat <https://web.libera.chat/#haskell-servant>`_
16
16
17- the mailing list:
17- the mailing list:
18 `groups.google.com/forum/#!forum/haskell-servant <https://groups.google.com/forum/#!forum/haskell-servant>`_
18 `groups.google.com/forum/#!forum/haskell-servant <https://groups.google.com/forum/#!forum/haskell-servant>`_
doc/tutorial/install.rst+26
@@ -40,3 +40,29 @@ nix
40`Nix <https://nixos.org/nix/>`_ users should feel free to take a look at
40`Nix <https://nixos.org/nix/>`_ users should feel free to take a look at
41the `nix/shell.nix` file in the repository and use it to provision a suitable
41the `nix/shell.nix` file in the repository and use it to provision a suitable
42environment to build and run the examples.
42environment to build and run the examples.
43+
44+Note for Ubuntu users
45+--------
46+
47+Ubuntu's packages for `ghc`, `cabal`, and `stack` are years out of date.
48+If the instructions above fail for you,
49+try replacing the Ubuntu packages with up-to-date versions.
50+First remove the installed versions:
51+
52+.. code-block:: bash
53+
54+ # remove the obsolete versions
55+ $ sudo apt remove ghc haskell-stack cabal-install
56+
57+Then install fresh versions of the Haskell toolchain
58+using the `ghcup <https://www.haskell.org/ghcup/install/>`_ installer.
59+
60+As of February 2022, one easy way to do this is by running a bootstrap script:
61+
62+.. code-block:: bash
63+
64+ $ curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh
65+
66+The script is interactive and will prompt you for details about what
67+you want installed and where. To install manually,
68+see `the detailed instructions <https://www.haskell.org/ghcup/install/#manual-install>`_.
doc/tutorial/tutorial.cabal+3−3
@@ -1,3 +1,4 @@
1+cabal-version: 2.2
1name: tutorial
2name: tutorial
2version: 0.10
3version: 0.10
3synopsis: The servant tutorial
4synopsis: The servant tutorial
@@ -6,12 +7,11 @@ description:
6 <http://docs.servant.dev/>
7 <http://docs.servant.dev/>
7homepage: http://docs.servant.dev/
8homepage: http://docs.servant.dev/
8category: Servant, Documentation
9category: Servant, Documentation
9−license: BSD3
10+license: BSD-3-Clause
10license-file: LICENSE
11license-file: LICENSE
11author: Servant Contributors
12author: Servant Contributors
12maintainer: haskell-servant-maintainers@googlegroups.com
13maintainer: haskell-servant-maintainers@googlegroups.com
13build-type: Simple
14build-type: Simple
14−cabal-version: >=1.10
15tested-with:
15tested-with:
16 GHC==8.6.5
16 GHC==8.6.5
17 GHC==8.8.3, GHC ==8.10.7
17 GHC==8.8.3, GHC ==8.10.7
@@ -64,7 +64,7 @@ library
64 , blaze-markup >= 0.8.0.0 && < 0.9
64 , blaze-markup >= 0.8.0.0 && < 0.9
65 , cookie >= 0.4.3 && < 0.5
65 , cookie >= 0.4.3 && < 0.5
66 , js-jquery >= 3.3.1 && < 3.4
66 , js-jquery >= 3.3.1 && < 3.4
67− , lucid >= 2.9.11 && < 2.10
67+ , lucid >= 2.9.11 && < 2.12
68 , random >= 1.1 && < 1.3
68 , random >= 1.1 && < 1.3
69 , servant-js >= 0.9 && < 0.10
69 , servant-js >= 0.9 && < 0.10
70 , time >= 1.6.0.1 && < 1.13
70 , time >= 1.6.0.1 && < 1.13
servant-auth/servant-auth-client/servant-auth-client.cabal+14−16
@@ -1,3 +1,4 @@
1+cabal-version: 2.2
1name: servant-auth-client
2name: servant-auth-client
2version: 0.4.1.0
3version: 0.4.1.0
3synopsis: servant-client/servant-auth compatibility
4synopsis: servant-client/servant-auth compatibility
@@ -6,18 +7,17 @@ description: This package provides instances that allow generating clients fr
6 APIs that use
7 APIs that use
7 <https://hackage.haskell.org/package/servant-auth servant-auth's> @Auth@ combinator.
8 <https://hackage.haskell.org/package/servant-auth servant-auth's> @Auth@ combinator.
8 .
9 .
9− For a quick overview of the usage, see the <http://github.com/haskell-servant/servant/servant-auth#readme README>.
10+ For a quick overview of the usage, see the <https://github.com/haskell-servant/servant/tree/master/servant-auth#readme README>.
10category: Web, Servant, Authentication
11category: Web, Servant, Authentication
11−homepage: http://github.com/haskell-servant/servant/servant-auth#readme
12+homepage: https://github.com/haskell-servant/servant/tree/master/servant-auth#readme
12bug-reports: https://github.com/haskell-servant/servant/issues
13bug-reports: https://github.com/haskell-servant/servant/issues
13author: Julian K. Arni
14author: Julian K. Arni
14maintainer: jkarni@gmail.com
15maintainer: jkarni@gmail.com
15copyright: (c) Julian K. Arni
16copyright: (c) Julian K. Arni
16−license: BSD3
17+license: BSD-3-Clause
17license-file: LICENSE
18license-file: LICENSE
18tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1
19tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1
19build-type: Simple
20build-type: Simple
20−cabal-version: >= 1.10
21extra-source-files:
21extra-source-files:
22 CHANGELOG.md
22 CHANGELOG.md
23
23
@@ -31,12 +31,12 @@ library
31 default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
31 default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
32 ghc-options: -Wall
32 ghc-options: -Wall
33 build-depends:
33 build-depends:
34− base >= 4.10 && < 4.16
34+ base >= 4.10 && < 4.17
35− , bytestring >= 0.10.6.0 && < 0.11
35+ , bytestring >= 0.10.6.0 && < 0.12
36 , containers >= 0.5.6.2 && < 0.7
36 , containers >= 0.5.6.2 && < 0.7
37 , servant-auth == 0.4.*
37 , servant-auth == 0.4.*
38− , servant >= 0.13 && < 0.19
38+ , servant >= 0.13 && < 0.20
39− , servant-client-core >= 0.13 && < 0.19
39+ , servant-client-core >= 0.13 && < 0.20
40
40
41 exposed-modules:
41 exposed-modules:
42 Servant.Auth.Client
42 Servant.Auth.Client
@@ -50,7 +50,7 @@ test-suite spec
50 test
50 test
51 default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
51 default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
52 ghc-options: -Wall
52 ghc-options: -Wall
53− build-tool-depends: hspec-discover:hspec-discover >=2.5.5 && <2.9
53+ build-tool-depends: hspec-discover:hspec-discover >=2.5.5 && <2.10
54
54
55 -- dependencies with bounds inherited from the library stanza
55 -- dependencies with bounds inherited from the library stanza
56 build-depends:
56 build-depends:
@@ -59,24 +59,22 @@ test-suite spec
59 , servant-auth
59 , servant-auth
60 , servant
60 , servant
61 , servant-auth-client
61 , servant-auth-client
62− if impl(ghc >= 9)
63− buildable: False
64
62
65 -- test dependencies
63 -- test dependencies
66 build-depends:
64 build-depends:
67− hspec >= 2.5.5 && < 2.9
65+ hspec >= 2.5.5 && < 2.10
68 , QuickCheck >= 2.11.3 && < 2.15
66 , QuickCheck >= 2.11.3 && < 2.15
69− , aeson >= 1.3.1.1 && < 1.6
67+ , aeson >= 1.3.1.1 && < 3
70− , bytestring >= 0.10.6.0 && < 0.11
68+ , bytestring >= 0.10.6.0 && < 0.12
71 , http-client >= 0.5.13.1 && < 0.8
69 , http-client >= 0.5.13.1 && < 0.8
72 , http-types >= 0.12.2 && < 0.13
70 , http-types >= 0.12.2 && < 0.13
73 , servant-auth-server >= 0.4.2.0 && < 0.5
71 , servant-auth-server >= 0.4.2.0 && < 0.5
74− , servant-server >= 0.13 && < 0.19
72+ , servant-server >= 0.13 && < 0.20
75 , time >= 1.5.0.1 && < 1.13
73 , time >= 1.5.0.1 && < 1.13
76 , transformers >= 0.4.2.0 && < 0.6
74 , transformers >= 0.4.2.0 && < 0.6
77 , wai >= 3.2.1.2 && < 3.3
75 , wai >= 3.2.1.2 && < 3.3
78 , warp >= 3.2.25 && < 3.4
76 , warp >= 3.2.25 && < 3.4
79− , jose >= 0.7.0.0 && < 0.9
77+ , jose >= 0.7.0.0 && < 0.10
80 other-modules:
78 other-modules:
81 Servant.Auth.ClientSpec
79 Servant.Auth.ClientSpec
82 default-language: Haskell2010
80 default-language: Haskell2010
servant-auth/servant-auth-docs/servant-auth-docs.cabal+10−10
@@ -1,3 +1,4 @@
1+cabal-version: 2.2
1name: servant-auth-docs
2name: servant-auth-docs
2version: 0.2.10.0
3version: 0.2.10.0
3synopsis: servant-docs/servant-auth compatibility
4synopsis: servant-docs/servant-auth compatibility
@@ -6,18 +7,17 @@ description: This package provides instances that allow generating docs from
6 APIs that use
7 APIs that use
7 <https://hackage.haskell.org/package/servant-auth servant-auth's> @Auth@ combinator.
8 <https://hackage.haskell.org/package/servant-auth servant-auth's> @Auth@ combinator.
8 .
9 .
9− For a quick overview of the usage, see the <http://github.com/haskell-servant/servant/servant-auth#readme README>.
10+ For a quick overview of the usage, see the <https://github.com/haskell-servant/servant/tree/master/servant-auth#readme README>.
10category: Web, Servant, Authentication
11category: Web, Servant, Authentication
11−homepage: http://github.com/haskell-servant/servant/servant-auth#readme
12+homepage: https://github.com/haskell-servant/servant/tree/master/servant-auth#readme
12bug-reports: https://github.com/haskell-servant/servant/issues
13bug-reports: https://github.com/haskell-servant/servant/issues
13author: Julian K. Arni
14author: Julian K. Arni
14maintainer: jkarni@gmail.com
15maintainer: jkarni@gmail.com
15copyright: (c) Julian K. Arni
16copyright: (c) Julian K. Arni
16−license: BSD3
17+license: BSD-3-Clause
17license-file: LICENSE
18license-file: LICENSE
18tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1
19tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1
19build-type: Custom
20build-type: Custom
20−cabal-version: >= 1.10
21extra-source-files:
21extra-source-files:
22 CHANGELOG.md
22 CHANGELOG.md
23
23
@@ -35,11 +35,11 @@ library
35 default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
35 default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
36 ghc-options: -Wall
36 ghc-options: -Wall
37 build-depends:
37 build-depends:
38− base >= 4.10 && < 4.16
38+ base >= 4.10 && < 4.17
39− , servant-docs >= 0.11.2 && < 0.12
39+ , servant-docs >= 0.11.2 && < 0.13
40− , servant >= 0.13 && < 0.19
40+ , servant >= 0.13 && < 0.20
41 , servant-auth == 0.4.*
41 , servant-auth == 0.4.*
42− , lens >= 4.16.1 && <5.1
42+ , lens >= 4.16.1 && <5.2
43 exposed-modules:
43 exposed-modules:
44 Servant.Auth.Docs
44 Servant.Auth.Docs
45 default-language: Haskell2010
45 default-language: Haskell2010
@@ -64,7 +64,7 @@ test-suite spec
64 test
64 test
65 default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
65 default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
66 ghc-options: -Wall
66 ghc-options: -Wall
67− build-tool-depends: hspec-discover:hspec-discover >=2.5.5 && <2.9
67+ build-tool-depends: hspec-discover:hspec-discover >=2.5.5 && <2.10
68
68
69 -- dependencies with bounds inherited from the library stanza
69 -- dependencies with bounds inherited from the library stanza
70 build-depends:
70 build-depends:
@@ -78,7 +78,7 @@ test-suite spec
78 -- test dependencies
78 -- test dependencies
79 build-depends:
79 build-depends:
80 servant-auth-docs
80 servant-auth-docs
81− , hspec >= 2.5.5 && < 2.9
81+ , hspec >= 2.5.5 && < 2.10
82 , QuickCheck >= 2.11.3 && < 2.15
82 , QuickCheck >= 2.11.3 && < 2.15
83
83
84 default-language: Haskell2010
84 default-language: Haskell2010
servant-auth/servant-auth-server/servant-auth-server.cabal+26−23
@@ -1,23 +1,23 @@
1+cabal-version: 2.2
1name: servant-auth-server
2name: servant-auth-server
2−version: 0.4.6.0
3+version: 0.4.7.0
3synopsis: servant-server/servant-auth compatibility
4synopsis: servant-server/servant-auth compatibility
4description: This package provides the required instances for using the @Auth@ combinator
5description: This package provides the required instances for using the @Auth@ combinator
5 in your 'servant' server.
6 in your 'servant' server.
6 .
7 .
7 Both cookie- and token- (REST API) based authentication is provided.
8 Both cookie- and token- (REST API) based authentication is provided.
8 .
9 .
9− For a quick overview of the usage, see the <http://github.com/haskell-servant/servant/servant-auth#readme README>.
10+ For a quick overview of the usage, see the <https://github.com/haskell-servant/servant/tree/master/servant-auth#readme README>.
10category: Web, Servant, Authentication
11category: Web, Servant, Authentication
11−homepage: http://github.com/haskell-servant/servant/servant-auth#readme
12+homepage: https://github.com/haskell-servant/servant/tree/master/servant-auth#readme
12bug-reports: https://github.com/haskell-servant/servant/issues
13bug-reports: https://github.com/haskell-servant/servant/issues
13author: Julian K. Arni
14author: Julian K. Arni
14maintainer: jkarni@gmail.com
15maintainer: jkarni@gmail.com
15copyright: (c) Julian K. Arni
16copyright: (c) Julian K. Arni
16−license: BSD3
17+license: BSD-3-Clause
17license-file: LICENSE
18license-file: LICENSE
18tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1
19tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1
19build-type: Simple
20build-type: Simple
20−cabal-version: >= 1.10
21extra-source-files:
21extra-source-files:
22 CHANGELOG.md
22 CHANGELOG.md
23
23
@@ -31,30 +31,37 @@ library
31 default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
31 default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
32 ghc-options: -Wall
32 ghc-options: -Wall
33 build-depends:
33 build-depends:
34− base >= 4.10 && < 4.16
34+ base >= 4.10 && < 4.17
35− , aeson >= 1.3.1.1 && < 1.6
35+ , aeson >= 1.0.0.1 && < 3
36− , base64-bytestring >= 1.0.0.1 && < 1.2
36+ , base64-bytestring >= 1.0.0.1 && < 2
37 , blaze-builder >= 0.4.1.0 && < 0.5
37 , blaze-builder >= 0.4.1.0 && < 0.5
38− , bytestring >= 0.10.6.0 && < 0.11
38+ , bytestring >= 0.10.6.0 && < 0.12
39 , case-insensitive >= 1.2.0.11 && < 1.3
39 , case-insensitive >= 1.2.0.11 && < 1.3
40 , cookie >= 0.4.4 && < 0.5
40 , cookie >= 0.4.4 && < 0.5
41 , data-default-class >= 0.1.2.0 && < 0.2
41 , data-default-class >= 0.1.2.0 && < 0.2
42 , entropy >= 0.4.1.3 && < 0.5
42 , entropy >= 0.4.1.3 && < 0.5
43 , http-types >= 0.12.2 && < 0.13
43 , http-types >= 0.12.2 && < 0.13
44− , jose >= 0.7.0.0 && < 0.9
44+ , jose >= 0.7.0.0 && < 0.10
45− , lens >= 4.16.1 && < 5.1
45+ , lens >= 4.16.1 && < 5.2
46− , memory >= 0.14.16 && < 0.17
46+ , memory >= 0.14.16 && < 0.18
47 , monad-time >= 0.3.1.0 && < 0.4
47 , monad-time >= 0.3.1.0 && < 0.4
48 , mtl >= 2.2.2 && < 2.3
48 , mtl >= 2.2.2 && < 2.3
49− , servant >= 0.13 && < 0.19
49+ , servant >= 0.13 && < 0.20
50 , servant-auth == 0.4.*
50 , servant-auth == 0.4.*
51− , servant-server >= 0.13 && < 0.19
51+ , servant-server >= 0.13 && < 0.20
52 , tagged >= 0.8.4 && < 0.9
52 , tagged >= 0.8.4 && < 0.9
53− , text >= 1.2.3.0 && < 1.3
53+ , text >= 1.2.3.0 && < 2.1
54− , time >= 1.5.0.1 && < 1.10
54+ , time >= 1.5.0.1 && < 1.12
55 , unordered-containers >= 0.2.9.0 && < 0.3
55 , unordered-containers >= 0.2.9.0 && < 0.3
56 , wai >= 3.2.1.2 && < 3.3
56 , wai >= 3.2.1.2 && < 3.3
57
57
58+ if impl(ghc >= 9)
59+ build-depends:
60+ -- base64-bytestring 1.2.1.0 contains important fix for GHC-9, lower versions
61+ -- produce wrong results, thus corrupring JWT via jose package.
62+ -- See: https://github.com/haskell/base64-bytestring/pull/46
63+ base64-bytestring >= 1.2.1.0
64+
58 exposed-modules:
65 exposed-modules:
59 Servant.Auth.Server
66 Servant.Auth.Server
60 Servant.Auth.Server.Internal
67 Servant.Auth.Server.Internal
@@ -87,8 +94,6 @@ test-suite readme
87 default-language: Haskell2010
94 default-language: Haskell2010
88 if impl(ghcjs)
95 if impl(ghcjs)
89 buildable: False
96 buildable: False
90− if impl(ghc >= 9)
91− buildable: False
92
97
93test-suite spec
98test-suite spec
94 type: exitcode-stdio-1.0
99 type: exitcode-stdio-1.0
@@ -97,7 +102,7 @@ test-suite spec
97 test
102 test
98 default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
103 default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
99 ghc-options: -Wall
104 ghc-options: -Wall
100− build-tool-depends: hspec-discover:hspec-discover >=2.5.5 && <2.8
105+ build-tool-depends: hspec-discover:hspec-discover >=2.5.5 && <2.10
101
106
102 -- dependencies with bounds inherited from the library stanza
107 -- dependencies with bounds inherited from the library stanza
103 build-depends:
108 build-depends:
@@ -114,16 +119,14 @@ test-suite spec
114 , servant
119 , servant
115 , servant-server
120 , servant-server
116 , transformers
121 , transformers
117− if impl(ghc >= 9)
118− buildable: False
119
122
120 -- test dependencies
123 -- test dependencies
121 build-depends:
124 build-depends:
122 servant-auth-server
125 servant-auth-server
123− , hspec >= 2.5.5 && < 2.8
126+ , hspec >= 2.5.5 && < 2.10
124 , QuickCheck >= 2.11.3 && < 2.15
127 , QuickCheck >= 2.11.3 && < 2.15
125 , http-client >= 0.5.13.1 && < 0.8
128 , http-client >= 0.5.13.1 && < 0.8
126− , lens-aeson >= 1.0.2 && < 1.2
129+ , lens-aeson >= 1.0.2 && < 1.3
127 , warp >= 3.2.25 && < 3.4
130 , warp >= 3.2.25 && < 3.4
128 , wreq >= 0.5.2.1 && < 0.6
131 , wreq >= 0.5.2.1 && < 0.6
129 other-modules:
132 other-modules:
servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/AddSetCookie.hs+12
@@ -11,6 +11,8 @@ import Data.Tagged (Tagged (..))
11import qualified Network.HTTP.Types as HTTP
11import qualified Network.HTTP.Types as HTTP
12import Network.Wai (mapResponseHeaders)
12import Network.Wai (mapResponseHeaders)
13import Servant
13import Servant
14+import Servant.API.Generic
15+import Servant.Server.Generic
14import Web.Cookie
16import Web.Cookie
15
17
16-- What are we doing here? Well, the idea is to add headers to the response,
18-- What are we doing here? Well, the idea is to add headers to the response,
@@ -34,6 +36,7 @@ type family AddSetCookieApiVerb a where
34type family AddSetCookieApi a :: *
36type family AddSetCookieApi a :: *
35type instance AddSetCookieApi (a :> b) = a :> AddSetCookieApi b
37type instance AddSetCookieApi (a :> b) = a :> AddSetCookieApi b
36type instance AddSetCookieApi (a :<|> b) = AddSetCookieApi a :<|> AddSetCookieApi b
38type instance AddSetCookieApi (a :<|> b) = AddSetCookieApi a :<|> AddSetCookieApi b
39+type instance AddSetCookieApi (NamedRoutes api) = AddSetCookieApi (ToServantApi api)
37type instance AddSetCookieApi (Verb method stat ctyps a)
40type instance AddSetCookieApi (Verb method stat ctyps a)
38 = Verb method stat ctyps (AddSetCookieApiVerb a)
41 = Verb method stat ctyps (AddSetCookieApiVerb a)
39type instance AddSetCookieApi Raw = Raw
42type instance AddSetCookieApi Raw = Raw
@@ -72,6 +75,15 @@ instance {-# OVERLAPS #-}
72 => AddSetCookies ('S n) (a :<|> b) (a' :<|> b') where
75 => AddSetCookies ('S n) (a :<|> b) (a' :<|> b') where
73 addSetCookies cookies (a :<|> b) = addSetCookies cookies a :<|> addSetCookies cookies b
76 addSetCookies cookies (a :<|> b) = addSetCookies cookies a :<|> addSetCookies cookies b
74
77
78+instance {-# OVERLAPS #-}
79+ ( AddSetCookies ('S n) (ServerT (ToServantApi api) m) cookiedApi
80+ , Generic (api (AsServerT m))
81+ , GServantProduct (Rep (api (AsServerT m)))
82+ , ToServant api (AsServerT m) ~ ServerT (ToServantApi api) m
83+ )
84+ => AddSetCookies ('S n) (api (AsServerT m)) cookiedApi where
85+ addSetCookies cookies = addSetCookies cookies . toServant
86+
75-- | for @servant <0.11@
87-- | for @servant <0.11@
76instance
88instance
77 AddSetCookies ('S n) Application Application where
89 AddSetCookies ('S n) Application Application where
servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/ConfigTypes.hs+2−2
@@ -33,7 +33,7 @@ data JWTSettings = JWTSettings
33 -- | Algorithm used to sign JWT.
33 -- | Algorithm used to sign JWT.
34 , jwtAlg :: Maybe Jose.Alg
34 , jwtAlg :: Maybe Jose.Alg
35 -- | Keys used to validate JWT.
35 -- | Keys used to validate JWT.
36− , validationKeys :: Jose.JWKSet
36+ , validationKeys :: IO Jose.JWKSet
37 -- | An @aud@ predicate. The @aud@ is a string or URI that identifies the
37 -- | An @aud@ predicate. The @aud@ is a string or URI that identifies the
38 -- intended recipient of the JWT.
38 -- intended recipient of the JWT.
39 , audienceMatches :: Jose.StringOrURI -> IsMatch
39 , audienceMatches :: Jose.StringOrURI -> IsMatch
@@ -44,7 +44,7 @@ defaultJWTSettings :: Jose.JWK -> JWTSettings
44defaultJWTSettings k = JWTSettings
44defaultJWTSettings k = JWTSettings
45 { signingKey = k
45 { signingKey = k
46 , jwtAlg = Nothing
46 , jwtAlg = Nothing
47− , validationKeys = Jose.JWKSet [k]
47+ , validationKeys = pure $ Jose.JWKSet [k]
48 , audienceMatches = const Matches }
48 , audienceMatches = const Matches }
49
49
50-- | The policies to use when generating cookies.
50-- | The policies to use when generating cookies.
servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/JWT.hs+4−3
@@ -58,14 +58,15 @@ makeJWT v cfg expiry = runExceptT $ do
58
58
59verifyJWT :: FromJWT a => JWTSettings -> BS.ByteString -> IO (Maybe a)
59verifyJWT :: FromJWT a => JWTSettings -> BS.ByteString -> IO (Maybe a)
60verifyJWT jwtCfg input = do
60verifyJWT jwtCfg input = do
61+ keys <- validationKeys jwtCfg
61− verifiedJWT <- liftIO $ runExceptT $ do
62+ verifiedJWT <- runExceptT $ do
62 unverifiedJWT <- Jose.decodeCompact (BSL.fromStrict input)
63 unverifiedJWT <- Jose.decodeCompact (BSL.fromStrict input)
63 Jose.verifyClaims
64 Jose.verifyClaims
64 (jwtSettingsToJwtValidationSettings jwtCfg)
65 (jwtSettingsToJwtValidationSettings jwtCfg)
65− (validationKeys jwtCfg)
66+ keys
66 unverifiedJWT
67 unverifiedJWT
67 return $ case verifiedJWT of
68 return $ case verifiedJWT of
68 Left (_ :: Jose.JWTError) -> Nothing
69 Left (_ :: Jose.JWTError) -> Nothing
69 Right v -> case decodeJWT v of
70 Right v -> case decodeJWT v of
70 Left _ -> Nothing
71 Left _ -> Nothing
71− Right v' -> Just v'
72+ Right v' -> Just v'
servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/ThrowAll.hs+10−1
@@ -8,7 +8,10 @@ module Servant.Auth.Server.Internal.ThrowAll where
8
8
9import Control.Monad.Error.Class
9import Control.Monad.Error.Class
10import Data.Tagged (Tagged (..))
10import Data.Tagged (Tagged (..))
11−import Servant ((:<|>) (..), ServerError(..))
11+import Servant ((:<|>) (..), ServerError(..), NamedRoutes(..))
12+import Servant.API.Generic
13+import Servant.Server.Generic
14+import Servant.Server
12import Network.HTTP.Types
15import Network.HTTP.Types
13import Network.Wai
16import Network.Wai
14
17
@@ -26,6 +29,12 @@ class ThrowAll a where
26instance (ThrowAll a, ThrowAll b) => ThrowAll (a :<|> b) where
29instance (ThrowAll a, ThrowAll b) => ThrowAll (a :<|> b) where
27 throwAll e = throwAll e :<|> throwAll e
30 throwAll e = throwAll e :<|> throwAll e
28
31
32+instance
33+ ( ThrowAll (ToServant api (AsServerT m)) , GenericServant api (AsServerT m)) =>
34+ ThrowAll (api (AsServerT m)) where
35+
36+ throwAll = fromServant . throwAll
37+
29-- Really this shouldn't be necessary - ((->) a) should be an instance of
38-- Really this shouldn't be necessary - ((->) a) should be an instance of
30-- MonadError, no?
39-- MonadError, no?
31instance {-# OVERLAPPING #-} ThrowAll b => ThrowAll (a -> b) where
40instance {-# OVERLAPPING #-} ThrowAll b => ThrowAll (a -> b) where
servant-auth/servant-auth-server/test/Servant/Auth/ServerSpec.hs+7
@@ -50,6 +50,7 @@ import Network.Wreq (Options, auth, basicAuth,
50import Network.Wreq.Types (Postable(..))
50import Network.Wreq.Types (Postable(..))
51import Servant hiding (BasicAuth,
51import Servant hiding (BasicAuth,
52 IsSecure (..), header)
52 IsSecure (..), header)
53+import Servant.API.Generic ((:-))
53import Servant.Auth.Server
54import Servant.Auth.Server
54import Servant.Auth.Server.Internal.Cookie (expireTime)
55import Servant.Auth.Server.Internal.Cookie (expireTime)
55import Servant.Auth.Server.SetCookieOrphan ()
56import Servant.Auth.Server.SetCookieOrphan ()
@@ -405,6 +406,7 @@ type API auths
405 = Auth auths User :>
406 = Auth auths User :>
406 ( Get '[JSON] Int
407 ( Get '[JSON] Int
407 :<|> ReqBody '[JSON] Int :> Post '[JSON] Int
408 :<|> ReqBody '[JSON] Int :> Post '[JSON] Int
409+ :<|> NamedRoutes DummyRoutes
408 :<|> "header" :> Get '[JSON] (Headers '[Header "Blah" Int] Int)
410 :<|> "header" :> Get '[JSON] (Headers '[Header "Blah" Int] Int)
409#if MIN_VERSION_servant_server(0,15,0)
411#if MIN_VERSION_servant_server(0,15,0)
410 :<|> "stream" :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString)
412 :<|> "stream" :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString)
@@ -416,6 +418,10 @@ type API auths
416 :<|> "logout" :> Get '[JSON] (Headers '[ Header "Set-Cookie" SetCookie
418 :<|> "logout" :> Get '[JSON] (Headers '[ Header "Set-Cookie" SetCookie
417 , Header "Set-Cookie" SetCookie ] NoContent)
419 , Header "Set-Cookie" SetCookie ] NoContent)
418
420
421+data DummyRoutes mode = DummyRoutes
422+ { dummyInt :: mode :- "dummy" :> Get '[JSON] Int
423+ } deriving Generic
424+
419jwtOnlyApi :: Proxy (API '[Servant.Auth.Server.JWT])
425jwtOnlyApi :: Proxy (API '[Servant.Auth.Server.JWT])
420jwtOnlyApi = Proxy
426jwtOnlyApi = Proxy
421
427
@@ -476,6 +482,7 @@ server ccfg =
476 (\authResult -> case authResult of
482 (\authResult -> case authResult of
477 Authenticated usr -> getInt usr
483 Authenticated usr -> getInt usr
478 :<|> postInt usr
484 :<|> postInt usr
485+ :<|> DummyRoutes { dummyInt = getInt usr }
479 :<|> getHeaderInt
486 :<|> getHeaderInt
480#if MIN_VERSION_servant_server(0,15,0)
487#if MIN_VERSION_servant_server(0,15,0)
481 :<|> return (S.source ["bytestring"])
488 :<|> return (S.source ["bytestring"])
servant-auth/servant-auth-swagger/servant-auth-swagger.cabal+13−17
@@ -1,3 +1,4 @@
1+cabal-version: 2.2
1name: servant-auth-swagger
2name: servant-auth-swagger
2version: 0.2.10.1
3version: 0.2.10.1
3synopsis: servant-swagger/servant-auth compatibility
4synopsis: servant-swagger/servant-auth compatibility
@@ -6,18 +7,17 @@ description: This package provides instances that allow generating swagger2 s
6 APIs that use
7 APIs that use
7 <https://hackage.haskell.org/package/servant-auth servant-auth's> @Auth@ combinator.
8 <https://hackage.haskell.org/package/servant-auth servant-auth's> @Auth@ combinator.
8 .
9 .
9− For a quick overview of the usage, see the <http://github.com/haskell-servant/servant/servant-auth#readme README>.
10+ For a quick overview of the usage, see the <https://github.com/haskell-servant/servant/tree/master/servant-auth#readme README>.
10category: Web, Servant, Authentication
11category: Web, Servant, Authentication
11−homepage: http://github.com/haskell-servant/servant/servant-auth#readme
12+homepage: https://github.com/haskell-servant/servant/tree/master/servant-auth#readme
12bug-reports: https://github.com/haskell-servant/servant/issues
13bug-reports: https://github.com/haskell-servant/servant/issues
13author: Julian K. Arni
14author: Julian K. Arni
14maintainer: jkarni@gmail.com
15maintainer: jkarni@gmail.com
15copyright: (c) Julian K. Arni
16copyright: (c) Julian K. Arni
16−license: BSD3
17+license: BSD-3-Clause
17license-file: LICENSE
18license-file: LICENSE
18tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4
19tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4
19build-type: Simple
20build-type: Simple
20−cabal-version: >= 1.10
21extra-source-files:
21extra-source-files:
22 CHANGELOG.md
22 CHANGELOG.md
23
23
@@ -31,15 +31,13 @@ library
31 default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
31 default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
32 ghc-options: -Wall
32 ghc-options: -Wall
33 build-depends:
33 build-depends:
34− base >= 4.10 && < 4.16
34+ base >= 4.10 && < 4.17
35− , text >= 1.2.3.0 && < 1.3
35+ , text >= 1.2.3.0 && < 2.1
36− , servant-swagger >= 1.1.5 && < 1.8
36+ , servant-swagger >= 1.1.5 && < 2
37− , swagger2 >= 2.2.2 && < 2.7
37+ , swagger2 >= 2.2.2 && < 3
38− , servant >= 0.13 && < 0.19
38+ , servant >= 0.13 && < 0.20
39 , servant-auth == 0.4.*
39 , servant-auth == 0.4.*
40− , lens >= 4.16.1 && < 5.1
40+ , lens >= 4.16.1 && < 5.2
41− if impl(ghc >= 9)
42− buildable: False
43 exposed-modules:
41 exposed-modules:
44 Servant.Auth.Swagger
42 Servant.Auth.Swagger
45 default-language: Haskell2010
43 default-language: Haskell2010
@@ -51,7 +49,7 @@ test-suite spec
51 test
49 test
52 default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
50 default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
53 ghc-options: -Wall
51 ghc-options: -Wall
54− build-tool-depends: hspec-discover:hspec-discover >= 2.5.5 && <2.9
52+ build-tool-depends: hspec-discover:hspec-discover >= 2.5.5 && <2.10
55 -- dependencies with bounds inherited from the library stanza
53 -- dependencies with bounds inherited from the library stanza
56 build-depends:
54 build-depends:
57 base
55 base
@@ -61,13 +59,11 @@ test-suite spec
61 , servant
59 , servant
62 , servant-auth
60 , servant-auth
63 , lens
61 , lens
64− if impl(ghc >= 9)
62+
65− buildable: False
66−
67 -- test dependencies
63 -- test dependencies
68 build-depends:
64 build-depends:
69 servant-auth-swagger
65 servant-auth-swagger
70− , hspec >= 2.5.5 && < 2.9
66+ , hspec >= 2.5.5 && < 2.10
71 , QuickCheck >= 2.11.3 && < 2.15
67 , QuickCheck >= 2.11.3 && < 2.15
72 other-modules:
68 other-modules:
73 Servant.Auth.SwaggerSpec
69 Servant.Auth.SwaggerSpec
servant-auth/servant-auth/servant-auth.cabal+12−11
@@ -1,5 +1,6 @@
1+cabal-version: 2.2
1name: servant-auth
2name: servant-auth
2−version: 0.4.0.0
3+version: 0.4.1.0
3synopsis: Authentication combinators for servant
4synopsis: Authentication combinators for servant
4description: This package provides an @Auth@ combinator for 'servant'. This combinator
5description: This package provides an @Auth@ combinator for 'servant'. This combinator
5 allows using different authentication schemes in a straightforward way,
6 allows using different authentication schemes in a straightforward way,
@@ -8,18 +9,17 @@ description: This package provides an @Auth@ combinator for 'servant'. This c
8 'servant-auth' additionally provides concrete authentication schemes, such
9 'servant-auth' additionally provides concrete authentication schemes, such
9 as Basic Access Authentication, JSON Web Tokens, and Cookies.
10 as Basic Access Authentication, JSON Web Tokens, and Cookies.
10 .
11 .
11− For more details on how to use this, see the <http://github.com/haskell-servant/servant/servant-auth#readme README>.
12+ For more details on how to use this, see the <https://github.com/haskell-servant/servant/tree/master/servant-auth#readme README>.
12category: Web, Servant, Authentication
13category: Web, Servant, Authentication
13−homepage: http://github.com/haskell-servant/servant/servant-auth#readme
14+homepage: https://github.com/haskell-servant/servant/tree/master/servant-auth#readme
14bug-reports: https://github.com/haskell-servant/servant/issues
15bug-reports: https://github.com/haskell-servant/servant/issues
15author: Julian K. Arni
16author: Julian K. Arni
16maintainer: jkarni@gmail.com
17maintainer: jkarni@gmail.com
17copyright: (c) Julian K. Arni
18copyright: (c) Julian K. Arni
18−license: BSD3
19+license: BSD-3-Clause
19license-file: LICENSE
20license-file: LICENSE
20tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1
21tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1
21build-type: Simple
22build-type: Simple
22−cabal-version: >= 1.10
23extra-source-files:
23extra-source-files:
24 CHANGELOG.md
24 CHANGELOG.md
25
25
@@ -33,12 +33,13 @@ library
33 default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
33 default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
34 ghc-options: -Wall
34 ghc-options: -Wall
35 build-depends:
35 build-depends:
36− base >= 4.10 && < 4.16
36+ base >= 4.10 && < 4.17
37+ , containers >= 0.6 && < 0.7
37− , aeson >= 1.3.1.1 && < 1.6
38+ , aeson >= 1.3.1.1 && < 3
38− , jose >= 0.7.0.0 && < 0.9
39+ , jose >= 0.7.0.0 && < 0.10
39− , lens >= 4.16.1 && < 5.1
40+ , lens >= 4.16.1 && < 5.2
40− , servant >= 0.15 && < 0.19
41+ , servant >= 0.15 && < 0.20
41− , text >= 1.2.3.0 && < 1.3
42+ , text >= 1.2.3.0 && < 2.1
42 , unordered-containers >= 0.2.9.0 && < 0.3
43 , unordered-containers >= 0.2.9.0 && < 0.3
43 exposed-modules:
44 exposed-modules:
44 Servant.Auth
45 Servant.Auth
servant-auth/servant-auth/src/Servant/Auth/JWT.hs+9−2
@@ -1,10 +1,17 @@
1+{-# LANGUAGE CPP #-}
2+
1module Servant.Auth.JWT where
3module Servant.Auth.JWT where
2
4
3import Control.Lens ((^.))
5import Control.Lens ((^.))
4import qualified Crypto.JWT as Jose
6import qualified Crypto.JWT as Jose
5import Data.Aeson (FromJSON, Result (..), ToJSON, fromJSON,
7import Data.Aeson (FromJSON, Result (..), ToJSON, fromJSON,
6 toJSON)
8 toJSON)
9+#if MIN_VERSION_aeson(2,0,0)
10+import qualified Data.Map as KM
11+#else
7−import qualified Data.HashMap.Strict as HM
12+import qualified Data.HashMap.Strict as KM
13+#endif
14+
8import qualified Data.Text as T
15import qualified Data.Text as T
9
16
10
17
@@ -17,7 +24,7 @@ import qualified Data.Text as T
17class FromJWT a where
24class FromJWT a where
18 decodeJWT :: Jose.ClaimsSet -> Either T.Text a
25 decodeJWT :: Jose.ClaimsSet -> Either T.Text a
19 default decodeJWT :: FromJSON a => Jose.ClaimsSet -> Either T.Text a
26 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
21 Nothing -> Left "Missing 'dat' claim"
28 Nothing -> Left "Missing 'dat' claim"
22 Just v -> case fromJSON v of
29 Just v -> case fromJSON v of
23 Error e -> Left $ T.pack e
30 Error e -> Left $ T.pack e
servant-client-core/CHANGELOG.md+31
@@ -1,6 +1,37 @@
1[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-client-core/CHANGELOG.md)
1[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-client-core/CHANGELOG.md)
2[Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)
2[Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)
3
3
4+Package versions follow the [Package Versioning Policy](https://pvp.haskell.org/): in A.B.C, bumps to either A or B represent major versions.
5+
6+0.19
7+----
8+
9+### Significant changes
10+
11+- Drop support for GHC < 8.6.
12+- Support GHC 9.0 (GHC 9.2 should work as well, but isn't fully tested yet).
13+- Support Aeson 2 ([#1475](https://github.com/haskell-servant/servant/pull/1475)),
14+ which fixes a [DOS vulnerability](https://github.com/haskell/aeson/issues/864)
15+ related to hash collisions.
16+- Add `NamedRoutes` combinator, making support for records first-class in Servant
17+ ([#1388](https://github.com/haskell-servant/servant/pull/1388)).
18+- Add custom type errors for partially applied combinators
19+ ([#1289](https://github.com/haskell-servant/servant/pull/1289),
20+ [#1486](https://github.com/haskell-servant/servant/pull/1486)).
21+- *servant-client* / *servant-client-core* / *servant-http-streams*: Fix
22+ erroneous behavior, where only 2XX status codes would be considered
23+ successful, irrelevant of the status parameter specified by the verb
24+ combinator. ([#1469](https://github.com/haskell-servant/servant/pull/1469))
25+- *servant-client* / *servant-client-core*: Fix `Show` instance for
26+ `Servant.Client.Core.Request`.
27+- *servant-client* / *servant-client-core*: Allow passing arbitrary binary data
28+ in Query parameters.
29+ ([#1432](https://github.com/haskell-servant/servant/pull/1432)).
30+
31+### Other changes
32+
33+- Various version bumps.
34+
40.18.3
350.18.3
5------
36------
6
37
servant-client-core/servant-client-core.cabal+12−11
@@ -1,6 +1,6 @@
1−cabal-version: >=1.10
1+cabal-version: 2.2
2name: servant-client-core
2name: servant-client-core
3−version: 0.18.3
3+version: 0.19
4
4
5synopsis: Core functionality and class for client function generation for servant APIs
5synopsis: Core functionality and class for client function generation for servant APIs
6category: Servant, Web
6category: Servant, Web
@@ -10,7 +10,7 @@ description:
10
10
11homepage: http://docs.servant.dev/
11homepage: http://docs.servant.dev/
12bug-reports: http://github.com/haskell-servant/servant/issues
12bug-reports: http://github.com/haskell-servant/servant/issues
13−license: BSD3
13+license: BSD-3-Clause
14license-file: LICENSE
14license-file: LICENSE
15author: Servant Contributors
15author: Servant Contributors
16maintainer: haskell-servant-maintainers@googlegroups.com
16maintainer: haskell-servant-maintainers@googlegroups.com
@@ -50,13 +50,14 @@ library
50 --
50 --
51 -- note: mtl lower bound is so low because of GHC-7.8
51 -- note: mtl lower bound is so low because of GHC-7.8
52 build-depends:
52 build-depends:
53− base >= 4.9 && < 4.16
53+ base >= 4.9 && < 4.17
54 , bytestring >= 0.10.8.1 && < 0.12
54 , bytestring >= 0.10.8.1 && < 0.12
55+ , constraints >= 0.2 && < 0.14
55 , containers >= 0.5.7.1 && < 0.7
56 , containers >= 0.5.7.1 && < 0.7
56 , deepseq >= 1.4.2.0 && < 1.5
57 , deepseq >= 1.4.2.0 && < 1.5
57− , text >= 1.2.3.0 && < 1.3
58+ , text >= 1.2.3.0 && < 2.1
58 , transformers >= 0.5.2.0 && < 0.6
59 , transformers >= 0.5.2.0 && < 0.6
59− , template-haskell >= 2.11.1.0 && < 2.18
60+ , template-haskell >= 2.11.1.0 && < 2.19
60
61
61 if !impl(ghc >= 8.2)
62 if !impl(ghc >= 8.2)
62 build-depends:
63 build-depends:
@@ -64,13 +65,13 @@ library
64
65
65 -- Servant dependencies
66 -- Servant dependencies
66 build-depends:
67 build-depends:
67− servant >= 0.18.3 && <0.19
68+ servant >= 0.19
68
69
69 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.
70 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.
70 -- Here can be exceptions if we really need features from the newer versions.
71 -- Here can be exceptions if we really need features from the newer versions.
71 build-depends:
72 build-depends:
72− aeson >= 1.4.1.0 && < 1.6
73+ aeson >= 1.4.1.0 && < 3
73− , base-compat >= 0.10.5 && < 0.12
74+ , base-compat >= 0.10.5 && < 0.13
74 , base64-bytestring >= 1.0.0.1 && < 1.3
75 , base64-bytestring >= 1.0.0.1 && < 1.3
75 , exceptions >= 0.10.0 && < 0.11
76 , exceptions >= 0.10.0 && < 0.11
76 , free >= 5.1 && < 5.2
77 , free >= 5.1 && < 5.2
@@ -103,8 +104,8 @@ test-suite spec
103 -- Additional dependencies
104 -- Additional dependencies
104 build-depends:
105 build-depends:
105 deepseq >= 1.4.2.0 && < 1.5
106 deepseq >= 1.4.2.0 && < 1.5
106− , hspec >= 2.6.0 && < 2.9
107+ , hspec >= 2.6.0 && < 2.10
107 , QuickCheck >= 2.12.6.1 && < 2.15
108 , QuickCheck >= 2.12.6.1 && < 2.15
108
109
109 build-tool-depends:
110 build-tool-depends:
110− hspec-discover:hspec-discover >= 2.6.0 && <2.9
111+ hspec-discover:hspec-discover >= 2.6.0 && <2.10
servant-client-core/src/Servant/Client/Core.hs+1
@@ -59,6 +59,7 @@ module Servant.Client.Core
59 , appendToPath
59 , appendToPath
60 , setRequestBodyLBS
60 , setRequestBodyLBS
61 , setRequestBody
61 , setRequestBody
62+ , encodeQueryParamValue
62 ) where
63 ) where
63import Servant.Client.Core.Auth
64import Servant.Client.Core.Auth
64import Servant.Client.Core.BaseUrl
65import Servant.Client.Core.BaseUrl
servant-client-core/src/Servant/Client/Core/HasClient.hs+170−36
@@ -1,5 +1,4 @@
1{-# LANGUAGE ConstraintKinds #-}
1{-# LANGUAGE ConstraintKinds #-}
2−{-# LANGUAGE CPP #-}
3{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DataKinds #-}
4{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE FlexibleInstances #-}
@@ -7,6 +6,7 @@
7{-# LANGUAGE MultiParamTypeClasses #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE OverloadedStrings #-}
7{-# LANGUAGE OverloadedStrings #-}
9{-# LANGUAGE PolyKinds #-}
8{-# LANGUAGE PolyKinds #-}
9+{-# LANGUAGE QuantifiedConstraints #-}
10{-# LANGUAGE RankNTypes #-}
10{-# LANGUAGE RankNTypes #-}
11{-# LANGUAGE ScopedTypeVariables #-}
11{-# LANGUAGE ScopedTypeVariables #-}
12{-# LANGUAGE TypeApplications #-}
12{-# LANGUAGE TypeApplications #-}
@@ -14,14 +14,13 @@
14{-# LANGUAGE TypeOperators #-}
14{-# LANGUAGE TypeOperators #-}
15{-# LANGUAGE UndecidableInstances #-}
15{-# LANGUAGE UndecidableInstances #-}
16
16
17−#if MIN_VERSION_base(4,9,0) && __GLASGOW_HASKELL__ >= 802
18−#define HAS_TYPE_ERROR
19−#endif
20−
21module Servant.Client.Core.HasClient (
17module Servant.Client.Core.HasClient (
22 clientIn,
18 clientIn,
23 HasClient (..),
19 HasClient (..),
24 EmptyClient (..),
20 EmptyClient (..),
21+ AsClientT,
22+ (//),
23+ (/:),
25 foldMapUnion,
24 foldMapUnion,
26 matchUnion,
25 matchUnion,
27 ) where
26 ) where
@@ -34,11 +33,10 @@ import Control.Arrow
34import Control.Monad
33import Control.Monad
35 (unless)
34 (unless)
36import qualified Data.ByteString as BS
35import qualified Data.ByteString as BS
37−import Data.ByteString.Builder
38− (toLazyByteString)
39−import qualified Data.ByteString.Lazy as BL
36+import qualified Data.ByteString.Lazy as BL
40import Data.Either
37import Data.Either
41 (partitionEithers)
38 (partitionEithers)
39+import Data.Constraint (Dict(..))
42import Data.Foldable
40import Data.Foldable
43 (toList)
41 (toList)
44import Data.List
42import Data.List
@@ -47,7 +45,8 @@ import Data.Sequence
47 (fromList)
45 (fromList)
48import qualified Data.Text as T
46import qualified Data.Text as T
49import Network.HTTP.Media
47import Network.HTTP.Media
50− (MediaType, matches, parseAccept, (//))
48+ (MediaType, matches, parseAccept)
49+import qualified Network.HTTP.Media as Media
51import qualified Data.Sequence as Seq
50import qualified Data.Sequence as Seq
52import Data.SOP.BasicFunctors
51import Data.SOP.BasicFunctors
53 (I (I), (:.:) (Comp))
52 (I (I), (:.:) (Comp))
@@ -64,7 +63,7 @@ import Data.Text
64import Data.Proxy
63import Data.Proxy
65 (Proxy (Proxy))
64 (Proxy (Proxy))
66import GHC.TypeLits
65import GHC.TypeLits
67− (KnownSymbol, symbolVal)
66+ (KnownNat, KnownSymbol, TypeError, symbolVal)
68import Network.HTTP.Types
67import Network.HTTP.Types
69 (Status)
68 (Status)
70import qualified Network.HTTP.Types as H
69import qualified Network.HTTP.Types as H
@@ -79,12 +78,18 @@ import Servant.API
79 ReflectMethod (..), RemoteHost, ReqBody', SBoolI, Stream,
78 ReflectMethod (..), RemoteHost, ReqBody', SBoolI, Stream,
80 StreamBody', Summary, ToHttpApiData, ToSourceIO (..), Vault,
79 StreamBody', Summary, ToHttpApiData, ToSourceIO (..), Vault,
81 Verb, WithNamedContext, WithStatus (..), contentType, getHeadersHList,
80 Verb, WithNamedContext, WithStatus (..), contentType, getHeadersHList,
82− getResponse, toEncodedUrlPiece, toUrlPiece)
81+ getResponse, toEncodedUrlPiece, toUrlPiece, NamedRoutes)
82+import Servant.API.Generic
83+ (GenericMode(..), ToServant, ToServantApi
84+ , GenericServant, toServant, fromServant)
83import Servant.API.ContentTypes
85import Servant.API.ContentTypes
84 (contentTypes, AllMime (allMime), AllMimeUnrender (allMimeUnrender))
86 (contentTypes, AllMime (allMime), AllMimeUnrender (allMimeUnrender))
87+import Servant.API.Status
88+ (statusFromNat)
85import Servant.API.TypeLevel (FragmentUnique, AtLeastOneFragment)
89import Servant.API.TypeLevel (FragmentUnique, AtLeastOneFragment)
86import Servant.API.Modifiers
90import Servant.API.Modifiers
87 (FoldRequired, RequiredArgument, foldRequiredArgument)
91 (FoldRequired, RequiredArgument, foldRequiredArgument)
92+import Servant.API.TypeErrors
88import Servant.API.UVerb
93import Servant.API.UVerb
89 (HasStatus, HasStatuses (Statuses, statuses), UVerb, Union, Unique, inject, statusOf, foldMapUnion, matchUnion)
94 (HasStatus, HasStatuses (Statuses, statuses), UVerb, Union, Unique, inject, statusOf, foldMapUnion, matchUnion)
90
95
@@ -203,7 +208,7 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m api)
203 clientWithRoute pm (Proxy :: Proxy api)
208 clientWithRoute pm (Proxy :: Proxy api)
204 (appendToPath p req)
209 (appendToPath p req)
205
210
206− where p = (toUrlPiece val)
211+ where p = toEncodedUrlPiece val
207
212
208 hoistClientMonad pm _ f cl = \a ->
213 hoistClientMonad pm _ f cl = \a ->
209 hoistClientMonad pm (Proxy :: Proxy api) f (cl a)
214 hoistClientMonad pm (Proxy :: Proxy api) f (cl a)
@@ -238,7 +243,7 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m sublayout)
238 clientWithRoute pm (Proxy :: Proxy sublayout)
243 clientWithRoute pm (Proxy :: Proxy sublayout)
239 (foldl' (flip appendToPath) req ps)
244 (foldl' (flip appendToPath) req ps)
240
245
241− where ps = map (toUrlPiece) vals
246+ where ps = map toEncodedUrlPiece vals
242
247
243 hoistClientMonad pm _ f cl = \as ->
248 hoistClientMonad pm _ f cl = \as ->
244 hoistClientMonad pm (Proxy :: Proxy sublayout) f (cl as)
249 hoistClientMonad pm (Proxy :: Proxy sublayout) f (cl as)
@@ -246,10 +251,11 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m sublayout)
246instance {-# OVERLAPPABLE #-}
251instance {-# OVERLAPPABLE #-}
247 -- Note [Non-Empty Content Types]
252 -- Note [Non-Empty Content Types]
248 ( RunClient m, MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)
253 ( RunClient m, MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)
254+ , KnownNat status
249 ) => HasClient m (Verb method status cts' a) where
255 ) => HasClient m (Verb method status cts' a) where
250 type Client m (Verb method status cts' a) = m a
256 type Client m (Verb method status cts' a) = m a
251 clientWithRoute _pm Proxy req = do
257 clientWithRoute _pm Proxy req = do
252− response <- runRequest req
258+ response <- runRequestAcceptStatus (Just [status]) req
253 { requestAccept = fromList $ toList accept
259 { requestAccept = fromList $ toList accept
254 , requestMethod = method
260 , requestMethod = method
255 }
261 }
@@ -257,18 +263,20 @@ instance {-# OVERLAPPABLE #-}
257 where
263 where
258 accept = contentTypes (Proxy :: Proxy ct)
264 accept = contentTypes (Proxy :: Proxy ct)
259 method = reflectMethod (Proxy :: Proxy method)
265 method = reflectMethod (Proxy :: Proxy method)
266+ status = statusFromNat (Proxy :: Proxy status)
260
267
261 hoistClientMonad _ _ f ma = f ma
268 hoistClientMonad _ _ f ma = f ma
262
269
263instance {-# OVERLAPPING #-}
270instance {-# OVERLAPPING #-}
264− ( RunClient m, ReflectMethod method
271+ ( RunClient m, ReflectMethod method, KnownNat status
265 ) => HasClient m (Verb method status cts NoContent) where
272 ) => HasClient m (Verb method status cts NoContent) where
266 type Client m (Verb method status cts NoContent)
273 type Client m (Verb method status cts NoContent)
267 = m NoContent
274 = m NoContent
268 clientWithRoute _pm Proxy req = do
275 clientWithRoute _pm Proxy req = do
269− _response <- runRequest req { requestMethod = method }
276+ _response <- runRequestAcceptStatus (Just [status]) req { requestMethod = method }
270 return NoContent
277 return NoContent
271 where method = reflectMethod (Proxy :: Proxy method)
278 where method = reflectMethod (Proxy :: Proxy method)
279+ status = statusFromNat (Proxy :: Proxy status)
272
280
273 hoistClientMonad _ _ f ma = f ma
281 hoistClientMonad _ _ f ma = f ma
274
282
@@ -285,13 +293,13 @@ instance (RunClient m, ReflectMethod method) =>
285
293
286instance {-# OVERLAPPING #-}
294instance {-# OVERLAPPING #-}
287 -- Note [Non-Empty Content Types]
295 -- Note [Non-Empty Content Types]
288− ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls
296+ ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls, KnownNat status
289 , ReflectMethod method, cts' ~ (ct ': cts)
297 , ReflectMethod method, cts' ~ (ct ': cts)
290 ) => HasClient m (Verb method status cts' (Headers ls a)) where
298 ) => HasClient m (Verb method status cts' (Headers ls a)) where
291 type Client m (Verb method status cts' (Headers ls a))
299 type Client m (Verb method status cts' (Headers ls a))
292 = m (Headers ls a)
300 = m (Headers ls a)
293 clientWithRoute _pm Proxy req = do
301 clientWithRoute _pm Proxy req = do
294− response <- runRequest req
302+ response <- runRequestAcceptStatus (Just [status]) req
295 { requestMethod = method
303 { requestMethod = method
296 , requestAccept = fromList $ toList accept
304 , requestAccept = fromList $ toList accept
297 }
305 }
@@ -299,22 +307,26 @@ instance {-# OVERLAPPING #-}
299 return $ Headers { getResponse = val
307 return $ Headers { getResponse = val
300 , getHeadersHList = buildHeadersTo . toList $ responseHeaders response
308 , getHeadersHList = buildHeadersTo . toList $ responseHeaders response
301 }
309 }
310+ where
302− where method = reflectMethod (Proxy :: Proxy method)
311+ method = reflectMethod (Proxy :: Proxy method)
303− accept = contentTypes (Proxy :: Proxy ct)
312+ accept = contentTypes (Proxy :: Proxy ct)
313+ status = statusFromNat (Proxy :: Proxy status)
304
314
305 hoistClientMonad _ _ f ma = f ma
315 hoistClientMonad _ _ f ma = f ma
306
316
307instance {-# OVERLAPPING #-}
317instance {-# OVERLAPPING #-}
308− ( RunClient m, BuildHeadersTo ls, ReflectMethod method
318+ ( RunClient m, BuildHeadersTo ls, ReflectMethod method, KnownNat status
309 ) => HasClient m (Verb method status cts (Headers ls NoContent)) where
319 ) => HasClient m (Verb method status cts (Headers ls NoContent)) where
310 type Client m (Verb method status cts (Headers ls NoContent))
320 type Client m (Verb method status cts (Headers ls NoContent))
311 = m (Headers ls NoContent)
321 = m (Headers ls NoContent)
312 clientWithRoute _pm Proxy req = do
322 clientWithRoute _pm Proxy req = do
313− let method = reflectMethod (Proxy :: Proxy method)
314− response <- runRequest req { requestMethod = method }
323+ response <- runRequestAcceptStatus (Just [status]) req { requestMethod = method }
315 return $ Headers { getResponse = NoContent
324 return $ Headers { getResponse = NoContent
316 , getHeadersHList = buildHeadersTo . toList $ responseHeaders response
325 , getHeadersHList = buildHeadersTo . toList $ responseHeaders response
317 }
326 }
327+ where
328+ method = reflectMethod (Proxy :: Proxy method)
329+ status = statusFromNat (Proxy :: Proxy status)
318
330
319 hoistClientMonad _ _ f ma = f ma
331 hoistClientMonad _ _ f ma = f ma
320
332
@@ -557,7 +569,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequire
557 (Proxy :: Proxy mods) add (maybe req add) mparam
569 (Proxy :: Proxy mods) add (maybe req add) mparam
558 where
570 where
559 add :: a -> Request
571 add :: a -> Request
560− add param = appendToQueryString pname (Just $ encodeQueryParam param) req
572+ add param = appendToQueryString pname (Just $ encodeQueryParamValue param) req
561
573
562 pname :: Text
574 pname :: Text
563 pname = pack $ symbolVal (Proxy :: Proxy sym)
575 pname = pack $ symbolVal (Proxy :: Proxy sym)
@@ -565,9 +577,6 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequire
565 hoistClientMonad pm _ f cl = \arg ->
577 hoistClientMonad pm _ f cl = \arg ->
566 hoistClientMonad pm (Proxy :: Proxy api) f (cl arg)
578 hoistClientMonad pm (Proxy :: Proxy api) f (cl arg)
567
579
568−encodeQueryParam :: ToHttpApiData a => a -> BS.ByteString
569−encodeQueryParam = BL.toStrict . toLazyByteString . toEncodedUrlPiece
570−
571-- | If you use a 'QueryParams' in one of your endpoints in your API,
580-- | If you use a 'QueryParams' in one of your endpoints in your API,
572-- the corresponding querying function will automatically take
581-- the corresponding querying function will automatically take
573-- an additional argument, a list of values of the type specified
582-- an additional argument, a list of values of the type specified
@@ -609,7 +618,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api)
609 )
618 )
610
619
611 where pname = pack $ symbolVal (Proxy :: Proxy sym)
620 where pname = pack $ symbolVal (Proxy :: Proxy sym)
612− paramlist' = map (Just . encodeQueryParam) paramlist
621+ paramlist' = map (Just . encodeQueryParamValue) paramlist
613
622
614 hoistClientMonad pm _ f cl = \as ->
623 hoistClientMonad pm _ f cl = \as ->
615 hoistClientMonad pm (Proxy :: Proxy api) f (cl as)
624 hoistClientMonad pm (Proxy :: Proxy api) f (cl as)
@@ -731,7 +740,7 @@ instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where
731 clientWithRoute pm (Proxy :: Proxy api)
740 clientWithRoute pm (Proxy :: Proxy api)
732 (appendToPath p req)
741 (appendToPath p req)
733
742
734− where p = pack $ symbolVal (Proxy :: Proxy path)
743+ where p = toEncodedUrlPiece $ pack $ symbolVal (Proxy :: Proxy path)
735
744
736 hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
745 hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
737
746
@@ -780,7 +789,7 @@ instance ( HasClient m api
780
789
781-- | Ignore @'Fragment'@ in client functions.
790-- | Ignore @'Fragment'@ in client functions.
782-- See <https://ietf.org/rfc/rfc2616.html#section-15.1.3> for more details.
791-- See <https://ietf.org/rfc/rfc2616.html#section-15.1.3> for more details.
783−--
792+--
784-- Example:
793-- Example:
785--
794--
786-- > type MyApi = "books" :> Fragment Text :> Get '[JSON] [Book]
795-- > type MyApi = "books" :> Fragment Text :> Get '[JSON] [Book]
@@ -792,16 +801,12 @@ instance ( HasClient m api
792-- > getBooks = client myApi
801-- > getBooks = client myApi
793-- > -- then you can just use "getBooksBy" to query that endpoint.
802-- > -- then you can just use "getBooksBy" to query that endpoint.
794-- > -- 'getBooks' for all books.
803-- > -- 'getBooks' for all books.
795−#ifdef HAS_TYPE_ERROR
796instance (AtLeastOneFragment api, FragmentUnique (Fragment a :> api), HasClient m api
804instance (AtLeastOneFragment api, FragmentUnique (Fragment a :> api), HasClient m api
797−#else
798−instance ( HasClient m api
799−#endif
800 ) => HasClient m (Fragment a :> api) where
805 ) => HasClient m (Fragment a :> api) where
801
806
802 type Client m (Fragment a :> api) = Client m api
807 type Client m (Fragment a :> api) = Client m api
803
808
804− clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api)
809+ clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api)
805
810
806 hoistClientMonad pm _ = hoistClientMonad pm (Proxy :: Proxy api)
811 hoistClientMonad pm _ = hoistClientMonad pm (Proxy :: Proxy api)
807
812
@@ -816,6 +821,119 @@ instance HasClient m api => HasClient m (BasicAuth realm usr :> api) where
816 hoistClientMonad pm _ f cl = \bauth ->
821 hoistClientMonad pm _ f cl = \bauth ->
817 hoistClientMonad pm (Proxy :: Proxy api) f (cl bauth)
822 hoistClientMonad pm (Proxy :: Proxy api) f (cl bauth)
818
823
824+-- | A type that specifies that an API record contains a client implementation.
825+data AsClientT (m :: * -> *)
826+instance GenericMode (AsClientT m) where
827+ type AsClientT m :- api = Client m api
828+
829+
830+type GClientConstraints api m =
831+ ( GenericServant api (AsClientT m)
832+ , Client m (ToServantApi api) ~ ToServant api (AsClientT m)
833+ )
834+
835+class GClient (api :: * -> *) m where
836+ gClientProof :: Dict (GClientConstraints api m)
837+
838+instance GClientConstraints api m => GClient api m where
839+ gClientProof = Dict
840+
841+instance
842+ ( forall n. GClient api n
843+ , HasClient m (ToServantApi api)
844+ , RunClient m
845+ )
846+ => HasClient m (NamedRoutes api) where
847+ type Client m (NamedRoutes api) = api (AsClientT m)
848+
849+ clientWithRoute :: Proxy m -> Proxy (NamedRoutes api) -> Request -> Client m (NamedRoutes api)
850+ clientWithRoute pm _ request =
851+ case gClientProof @api @m of
852+ Dict -> fromServant $ clientWithRoute pm (Proxy @(ToServantApi api)) request
853+
854+ hoistClientMonad
855+ :: forall ma mb.
856+ Proxy m
857+ -> Proxy (NamedRoutes api)
858+ -> (forall x. ma x -> mb x)
859+ -> Client ma (NamedRoutes api)
860+ -> Client mb (NamedRoutes api)
861+ hoistClientMonad _ _ nat clientA =
862+ case (gClientProof @api @ma, gClientProof @api @mb) of
863+ (Dict, Dict) ->
864+ fromServant @api @(AsClientT mb) $
865+ hoistClientMonad @m @(ToServantApi api) @ma @mb Proxy Proxy nat $
866+ toServant @api @(AsClientT ma) clientA
867+
868+infixl 1 //
869+infixl 2 /:
870+
871+-- | Helper to make code using records of clients more readable.
872+--
873+-- Can be mixed with (/:) for supplying arguments.
874+--
875+-- Example:
876+--
877+-- @
878+-- type Api = NamedRoutes RootApi
879+--
880+-- data RootApi mode = RootApi
881+-- { subApi :: mode :- NamedRoutes SubApi
882+-- , …
883+-- } deriving Generic
884+--
885+-- data SubApi mode = SubApi
886+-- { endpoint :: mode :- Get '[JSON] Person
887+-- , …
888+-- } deriving Generic
889+--
890+-- api :: Proxy API
891+-- api = Proxy
892+--
893+-- rootClient :: RootApi (AsClientT ClientM)
894+-- rootClient = client api
895+--
896+-- endpointClient :: ClientM Person
897+-- endpointClient = client // subApi // endpoint
898+-- @
899+(//) :: a -> (a -> b) -> b
900+x // f = f x
901+
902+-- | Convenience function for supplying arguments to client functions when
903+-- working with records of clients.
904+--
905+-- Intended to be used in conjunction with '(//)'.
906+--
907+-- Example:
908+--
909+-- @
910+-- type Api = NamedRoutes RootApi
911+--
912+-- data RootApi mode = RootApi
913+-- { subApi :: mode :- Capture "token" String :> NamedRoutes SubApi
914+-- , hello :: mode :- Capture "name" String :> Get '[JSON] String
915+-- , …
916+-- } deriving Generic
917+--
918+-- data SubApi mode = SubApi
919+-- { endpoint :: mode :- Get '[JSON] Person
920+-- , …
921+-- } deriving Generic
922+--
923+-- api :: Proxy API
924+-- api = Proxy
925+--
926+-- rootClient :: RootApi (AsClientT ClientM)
927+-- rootClient = client api
928+--
929+-- hello :: String -> ClientM String
930+-- hello name = rootClient // hello /: name
931+--
932+-- endpointClient :: ClientM Person
933+-- endpointClient = client // subApi /: "foobar123" // endpoint
934+-- @
935+(/:) :: (a -> b -> c) -> b -> a -> c
936+(/:) = flip
819
937
820
938
821{- Note [Non-Empty Content Types]
939{- Note [Non-Empty Content Types]
@@ -841,7 +959,7 @@ for empty and one for non-empty lists).
841checkContentTypeHeader :: RunClient m => Response -> m MediaType
959checkContentTypeHeader :: RunClient m => Response -> m MediaType
842checkContentTypeHeader response =
960checkContentTypeHeader response =
843 case lookup "Content-Type" $ toList $ responseHeaders response of
961 case lookup "Content-Type" $ toList $ responseHeaders response of
844− Nothing -> return $ "application"//"octet-stream"
962+ Nothing -> return $ "application" Media.// "octet-stream"
845 Just t -> case parseAccept t of
963 Just t -> case parseAccept t of
846 Nothing -> throwClientError $ InvalidContentTypeHeader response
964 Nothing -> throwClientError $ InvalidContentTypeHeader response
847 Just t' -> return t'
965 Just t' -> return t'
@@ -857,3 +975,19 @@ decodedAs response ct = do
857 Right val -> return val
975 Right val -> return val
858 where
976 where
859 accept = toList $ contentTypes ct
977 accept = toList $ contentTypes ct
978+
979+-------------------------------------------------------------------------------
980+-- Custom type errors
981+-------------------------------------------------------------------------------
982+
983+-- Erroring instance for HasClient' when a combinator is not fully applied
984+instance (RunClient m, TypeError (PartialApplication HasClient arr)) => HasClient m ((arr :: a -> b) :> sub)
985+ where
986+ type Client m (arr :> sub) = TypeError (PartialApplication HasClient arr)
987+ clientWithRoute _ _ _ = error "unreachable"
988+ hoistClientMonad _ _ _ _ = error "unreachable"
989+
990+-- Erroring instances for 'HasClient' for unknown API combinators
991+instance {-# OVERLAPPABLE #-} (RunClient m, TypeError (NoInstanceForSub (HasClient m) ty)) => HasClient m (ty :> sub)
992+
993+instance {-# OVERLAPPABLE #-} (RunClient m, TypeError (NoInstanceFor (HasClient m api))) => HasClient m api
servant-client-core/src/Servant/Client/Core/Reexport.hs+4
@@ -7,6 +7,9 @@ module Servant.Client.Core.Reexport
7 HasClient(..)
7 HasClient(..)
8 , foldMapUnion
8 , foldMapUnion
9 , matchUnion
9 , matchUnion
10+ , AsClientT
11+ , (//)
12+ , (/:)
10
13
11 -- * Response (for @Raw@)
14 -- * Response (for @Raw@)
12 , Response
15 , Response
@@ -23,6 +26,7 @@ module Servant.Client.Core.Reexport
23 , showBaseUrl
26 , showBaseUrl
24 , parseBaseUrl
27 , parseBaseUrl
25 , InvalidBaseUrlException
28 , InvalidBaseUrlException
29+
26 ) where
30 ) where
27
31
28
32
servant-client-core/src/Servant/Client/Core/Request.hs+25−8
@@ -17,6 +17,7 @@ module Servant.Client.Core.Request (
17 addHeader,
17 addHeader,
18 appendToPath,
18 appendToPath,
19 appendToQueryString,
19 appendToQueryString,
20+ encodeQueryParamValue,
20 setRequestBody,
21 setRequestBody,
21 setRequestBodyLBS,
22 setRequestBodyLBS,
22 ) where
23 ) where
@@ -33,6 +34,8 @@ import Data.Bifunctor
33import Data.Bitraversable
34import Data.Bitraversable
34 (Bitraversable (..), bifoldMapDefault, bimapDefault)
35 (Bitraversable (..), bifoldMapDefault, bimapDefault)
35import qualified Data.ByteString as BS
36import qualified Data.ByteString as BS
37+import Data.ByteString.Builder
38+ (Builder)
36import qualified Data.ByteString.Builder as Builder
39import qualified Data.ByteString.Builder as Builder
37import qualified Data.ByteString.Lazy as LBS
40import qualified Data.ByteString.Lazy as LBS
38import qualified Data.Sequence as Seq
41import qualified Data.Sequence as Seq
@@ -48,9 +51,9 @@ import Network.HTTP.Media
48 (MediaType)
51 (MediaType)
49import Network.HTTP.Types
52import Network.HTTP.Types
50 (Header, HeaderName, HttpVersion (..), Method, QueryItem,
53 (Header, HeaderName, HttpVersion (..), Method, QueryItem,
51− http11, methodGet)
54+ http11, methodGet, urlEncodeBuilder)
52import Servant.API
55import Servant.API
53− (ToHttpApiData, toEncodedUrlPiece, toHeader, SourceIO)
56+ (ToHttpApiData, toEncodedUrlPiece, toQueryParam, toHeader, SourceIO)
54
57
55import Servant.Client.Core.Internal (mediaTypeRnf)
58import Servant.Client.Core.Internal (mediaTypeRnf)
56
59
@@ -78,12 +81,13 @@ instance (Show a, Show b) =>
78 . showString ", requestAccept = "
81 . showString ", requestAccept = "
79 . showsPrec 0 (requestAccept req)
82 . showsPrec 0 (requestAccept req)
80 . showString ", requestHeaders = "
83 . showString ", requestHeaders = "
81− . showsPrec 0 (redactSensitiveHeader <$> requestHeaders req))
84+ . showsPrec 0 (redactSensitiveHeader <$> requestHeaders req)
82 . showString ", requestHttpVersion = "
85 . showString ", requestHttpVersion = "
83 . showsPrec 0 (requestHttpVersion req)
86 . showsPrec 0 (requestHttpVersion req)
84 . showString ", requestMethod = "
87 . showString ", requestMethod = "
85 . showsPrec 0 (requestMethod req)
88 . showsPrec 0 (requestMethod req)
86 . showString "}"
89 . showString "}"
90+ )
87 where
91 where
88 redactSensitiveHeader :: Header -> Header
92 redactSensitiveHeader :: Header -> Header
89 redactSensitiveHeader ("Authorization", _) = ("Authorization", "<REDACTED>")
93 redactSensitiveHeader ("Authorization", _) = ("Authorization", "<REDACTED>")
@@ -110,7 +114,7 @@ instance (NFData path, NFData body) => NFData (RequestF body path) where
110 rnfB Nothing = ()
114 rnfB Nothing = ()
111 rnfB (Just (b, mt)) = rnf b `seq` mediaTypeRnf mt
115 rnfB (Just (b, mt)) = rnf b `seq` mediaTypeRnf mt
112
116
113−type Request = RequestF RequestBody Builder.Builder
117+type Request = RequestF RequestBody Builder
114
118
115-- | The request body. R replica of the @http-client@ @RequestBody@.
119-- | The request body. R replica of the @http-client@ @RequestBody@.
116data RequestBody
120data RequestBody
@@ -141,18 +145,31 @@ defaultRequest = Request
141 , requestMethod = methodGet
145 , requestMethod = methodGet
142 }
146 }
143
147
148+-- | Append extra path to the request being constructed.
149+--
150+-- Warning: This function assumes that the path fragment is already URL-encoded.
144−appendToPath :: Text -> Request -> Request
151+appendToPath :: Builder -> Request -> Request
145appendToPath p req
152appendToPath p req
146− = req { requestPath = requestPath req <> "/" <> toEncodedUrlPiece p }
153+ = req { requestPath = requestPath req <> "/" <> p }
147
154
155+-- | Append a query parameter to the request being constructed.
156+--
148−appendToQueryString :: Text -- ^ param name
157+appendToQueryString :: Text -- ^ query param name
149− -> Maybe BS.ByteString -- ^ param value
158+ -> Maybe BS.ByteString -- ^ query param value
150 -> Request
159 -> Request
151 -> Request
160 -> Request
152appendToQueryString pname pvalue req
161appendToQueryString pname pvalue req
153 = req { requestQueryString = requestQueryString req
162 = req { requestQueryString = requestQueryString req
154 Seq.|> (encodeUtf8 pname, pvalue)}
163 Seq.|> (encodeUtf8 pname, pvalue)}
155
164
165+-- | Encode a query parameter value.
166+--
167+encodeQueryParamValue :: ToHttpApiData a => a -> BS.ByteString
168+encodeQueryParamValue = LBS.toStrict . Builder.toLazyByteString
169+ . urlEncodeBuilder True . encodeUtf8 . toQueryParam
170+
171+-- | Add header to the request being constructed.
172+--
156addHeader :: ToHttpApiData a => HeaderName -> a -> Request -> Request
173addHeader :: ToHttpApiData a => HeaderName -> a -> Request -> Request
157addHeader name val req
174addHeader name val req
158 = req { requestHeaders = requestHeaders req Seq.|> (name, toHeader val)}
175 = req { requestHeaders = requestHeaders req Seq.|> (name, toHeader val)}
servant-client-core/src/Servant/Client/Generic.hs+8−11
@@ -1,9 +1,10 @@
1−{-# LANGUAGE ConstraintKinds #-}
1+{-# OPTIONS_GHC -fno-warn-orphans #-}
2−{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE FlexibleContexts #-}
3−{-# LANGUAGE KindSignatures #-}
3+{-# LANGUAGE KindSignatures #-}
4−{-# LANGUAGE RankNTypes #-}
4+{-# LANGUAGE RankNTypes #-}
5−{-# LANGUAGE ScopedTypeVariables #-}
5+{-# LANGUAGE ScopedTypeVariables #-}
6−{-# LANGUAGE TypeFamilies #-}
6+{-# LANGUAGE TypeFamilies #-}
7+
7module Servant.Client.Generic (
8module Servant.Client.Generic (
8 AsClientT,
9 AsClientT,
9 genericClient,
10 genericClient,
@@ -15,11 +16,7 @@ import Data.Proxy
15
16
16import Servant.API.Generic
17import Servant.API.Generic
17import Servant.Client.Core
18import Servant.Client.Core
18−
19+import Servant.Client.Core.HasClient (AsClientT)
19−-- | A type that specifies that an API record contains a client implementation.
20−data AsClientT (m :: * -> *)
21−instance GenericMode (AsClientT m) where
22− type AsClientT m :- api = Client m api
23
20
24-- | Generate a record of client functions.
21-- | Generate a record of client functions.
25genericClient
22genericClient
servant-client-core/test/Servant/Client/Core/RequestSpec.hs+12
@@ -10,10 +10,22 @@ import Data.List (isInfixOf)
10import Servant.Client.Core.Request
10import Servant.Client.Core.Request
11import Test.Hspec
11import Test.Hspec
12
12
13+newtype DataWithRequest = DataWithRequest (RequestF RequestBody ())
14+ deriving Show
15+
13spec :: Spec
16spec :: Spec
14spec = do
17spec = do
15 describe "Request" $ do
18 describe "Request" $ do
16 describe "show" $ do
19 describe "show" $ do
20+ it "has parenthesis correctly positioned" $ do
21+ let d = DataWithRequest (void defaultRequest)
22+ show d `shouldBe` "DataWithRequest (Request {requestPath = ()\
23+ \, requestQueryString = fromList []\
24+ \, requestBody = Nothing\
25+ \, requestAccept = fromList []\
26+ \, requestHeaders = fromList []\
27+ \, requestHttpVersion = HTTP/1.1\
28+ \, requestMethod = \"GET\"})"
17 it "redacts the authorization header" $ do
29 it "redacts the authorization header" $ do
18 let request = void $ defaultRequest { requestHeaders = pure ("authorization", "secret") }
30 let request = void $ defaultRequest { requestHeaders = pure ("authorization", "secret") }
19 isInfixOf "secret" (show request) `shouldBe` False
31 isInfixOf "secret" (show request) `shouldBe` False
servant-client-ghcjs/servant-client-ghcjs.cabal+5−5
@@ -1,4 +1,4 @@
1−cabal-version: >=1.10
1+cabal-version: 2.2
2name: servant-client-ghcjs
2name: servant-client-ghcjs
3version: 0.16
3version: 0.16
4synopsis:
4synopsis:
@@ -15,7 +15,7 @@ description:
15
15
16homepage: http://docs.servant.dev/
16homepage: http://docs.servant.dev/
17bug-reports: http://github.com/haskell-servant/servant/issues
17bug-reports: http://github.com/haskell-servant/servant/issues
18−license: BSD3
18+license: BSD-3-Clause
19license-file: LICENSE
19license-file: LICENSE
20author: Servant Contributors
20author: Servant Contributors
21maintainer: haskell-servant-maintainers@googlegroups.com
21maintainer: haskell-servant-maintainers@googlegroups.com
@@ -38,7 +38,7 @@ library
38 Servant.Client.Internal.XhrClient
38 Servant.Client.Internal.XhrClient
39
39
40 build-depends:
40 build-depends:
41− base >=4.11 && <4.12
41+ base >=4.11 && <5
42 , bytestring >=0.10 && <0.12
42 , bytestring >=0.10 && <0.12
43 , case-insensitive >=1.2.0.0 && <1.3.0.0
43 , case-insensitive >=1.2.0.0 && <1.3.0.0
44 , containers >=0.5 && <0.7
44 , containers >=0.5 && <0.7
@@ -56,8 +56,8 @@ library
56
56
57 -- strict, as we re-export stuff
57 -- strict, as we re-export stuff
58 build-depends:
58 build-depends:
59− servant >=0.16 && <0.17
59+ servant >=0.16 && <0.20
60− , servant-client-core >=0.16 && <0.16.1
60+ , servant-client-core >=0.16 && <0.20
61
61
62 hs-source-dirs: src
62 hs-source-dirs: src
63 default-language: Haskell2010
63 default-language: Haskell2010
servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs+8−5
@@ -120,7 +120,7 @@ instance Exception StreamingNotSupportedException where
120 displayException _ = "streamingRequest: streaming is not supported!"
120 displayException _ = "streamingRequest: streaming is not supported!"
121
121
122instance RunClient ClientM where
122instance RunClient ClientM where
123− runRequest = performRequest
123+ runRequestAcceptStatus = performRequest
124 throwClientError = throwError
124 throwClientError = throwError
125
125
126runClientMOrigin :: ClientM a -> ClientEnv -> IO (Either ClientError a)
126runClientMOrigin :: ClientM a -> ClientEnv -> IO (Either ClientError a)
@@ -152,15 +152,18 @@ runClientM m = do
152
152
153 runClientMOrigin m (ClientEnv (BaseUrl protocol hostname port ""))
153 runClientMOrigin m (ClientEnv (BaseUrl protocol hostname port ""))
154
154
155−performRequest :: Request -> ClientM Response
155+performRequest :: Maybe [Status] -> Request -> ClientM Response
156−performRequest req = do
156+performRequest acceptStatus req = do
157 xhr <- liftIO initXhr
157 xhr <- liftIO initXhr
158 burl <- asks baseUrl
158 burl <- asks baseUrl
159 liftIO $ performXhr xhr burl req
159 liftIO $ performXhr xhr burl req
160 resp <- toResponse xhr
160 resp <- toResponse xhr
161
161
162− let status = statusCode (responseStatusCode resp)
162+ let status = responseStatusCode resp
163− unless (status >= 200 && status < 300) $ do
163+ goodStatus = case acceptStatus of
164+ Nothing -> statusIsSuccessful status
165+ Just good -> status `elem` good
166+ unless goodStatus $ do
164 let f b = (burl, BL.toStrict $ toLazyByteString b)
167 let f b = (burl, BL.toStrict $ toLazyByteString b)
165 throwError $ FailureResponse (bimap (const ()) f req) resp
168 throwError $ FailureResponse (bimap (const ()) f req) resp
166
169
servant-client/CHANGELOG.md+31
@@ -1,6 +1,37 @@
1[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-client/CHANGELOG.md)
1[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-client/CHANGELOG.md)
2[Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)
2[Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)
3
3
4+Package versions follow the [Package Versioning Policy](https://pvp.haskell.org/): in A.B.C, bumps to either A or B represent major versions.
5+
6+0.19
7+----
8+
9+### Significant changes
10+
11+- Drop support for GHC < 8.6.
12+- Support GHC 9.0 (GHC 9.2 should work as well, but isn't fully tested yet).
13+- Support Aeson 2 ([#1475](https://github.com/haskell-servant/servant/pull/1475)),
14+ which fixes a [DOS vulnerability](https://github.com/haskell/aeson/issues/864)
15+ related to hash collisions.
16+- Add `NamedRoutes` combinator, making support for records first-class in Servant
17+ ([#1388](https://github.com/haskell-servant/servant/pull/1388)).
18+- Add custom type errors for partially applied combinators
19+ ([#1289](https://github.com/haskell-servant/servant/pull/1289),
20+ [#1486](https://github.com/haskell-servant/servant/pull/1486)).
21+- *servant-client* / *servant-client-core* / *servant-http-streams*: Fix
22+ erroneous behavior, where only 2XX status codes would be considered
23+ successful, irrelevant of the status parameter specified by the verb
24+ combinator. ([#1469](https://github.com/haskell-servant/servant/pull/1469))
25+- *servant-client* / *servant-client-core*: Fix `Show` instance for
26+ `Servant.Client.Core.Request`.
27+- *servant-client* / *servant-client-core*: Allow passing arbitrary binary data
28+ in Query parameters.
29+ ([#1432](https://github.com/haskell-servant/servant/pull/1432)).
30+
31+### Other changes
32+
33+- Various version bumps.
34+
40.18.3
350.18.3
5------
36------
6
37
servant-client/servant-client.cabal+15−13
@@ -1,6 +1,6 @@
1−cabal-version: >=1.10
1+cabal-version: 2.2
2name: servant-client
2name: servant-client
3−version: 0.18.3
3+version: 0.19
4
4
5synopsis: Automatic derivation of querying functions for servant
5synopsis: Automatic derivation of querying functions for servant
6category: Servant, Web
6category: Servant, Web
@@ -14,7 +14,7 @@ description:
14
14
15homepage: http://docs.servant.dev/
15homepage: http://docs.servant.dev/
16bug-reports: http://github.com/haskell-servant/servant/issues
16bug-reports: http://github.com/haskell-servant/servant/issues
17−license: BSD3
17+license: BSD-3-Clause
18license-file: LICENSE
18license-file: LICENSE
19author: Servant Contributors
19author: Servant Contributors
20maintainer: haskell-servant-maintainers@googlegroups.com
20maintainer: haskell-servant-maintainers@googlegroups.com
@@ -41,14 +41,14 @@ library
41 -- Bundled with GHC: Lower bound to not force re-installs
41 -- Bundled with GHC: Lower bound to not force re-installs
42 -- text and mtl are bundled starting with GHC-8.4
42 -- text and mtl are bundled starting with GHC-8.4
43 build-depends:
43 build-depends:
44− base >= 4.9 && < 4.16
44+ base >= 4.9 && < 4.17
45 , bytestring >= 0.10.8.1 && < 0.12
45 , bytestring >= 0.10.8.1 && < 0.12
46 , containers >= 0.5.7.1 && < 0.7
46 , containers >= 0.5.7.1 && < 0.7
47 , deepseq >= 1.4.2.0 && < 1.5
47 , deepseq >= 1.4.2.0 && < 1.5
48 , mtl >= 2.2.2 && < 2.3
48 , mtl >= 2.2.2 && < 2.3
49 , stm >= 2.4.5.1 && < 2.6
49 , stm >= 2.4.5.1 && < 2.6
50− , text >= 1.2.3.0 && < 1.3
50+ , text >= 1.2.3.0 && < 2.1
51− , time >= 1.6.0.1 && < 1.10
51+ , time >= 1.6.0.1 && < 1.12
52 , transformers >= 0.5.2.0 && < 0.6
52 , transformers >= 0.5.2.0 && < 0.6
53
53
54 if !impl(ghc >= 8.2)
54 if !impl(ghc >= 8.2)
@@ -58,13 +58,13 @@ library
58 -- Servant dependencies.
58 -- Servant dependencies.
59 -- Strict dependency on `servant-client-core` as we re-export things.
59 -- Strict dependency on `servant-client-core` as we re-export things.
60 build-depends:
60 build-depends:
61− servant == 0.18.*
61+ servant >= 0.18 && < 0.20
62− , servant-client-core >= 0.18.3 && <0.18.4
62+ , servant-client-core >= 0.19 && < 0.19.1
63
63
64 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.
64 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.
65 -- Here can be exceptions if we really need features from the newer versions.
65 -- Here can be exceptions if we really need features from the newer versions.
66 build-depends:
66 build-depends:
67− base-compat >= 0.10.5 && < 0.12
67+ base-compat >= 0.10.5 && < 0.13
68 , http-client >= 0.5.13.1 && < 0.8
68 , http-client >= 0.5.13.1 && < 0.8
69 , http-media >= 0.7.1.3 && < 0.9
69 , http-media >= 0.7.1.3 && < 0.9
70 , http-types >= 0.12.2 && < 0.13
70 , http-types >= 0.12.2 && < 0.13
@@ -89,10 +89,12 @@ test-suite spec
89 main-is: Spec.hs
89 main-is: Spec.hs
90 other-modules:
90 other-modules:
91 Servant.BasicAuthSpec
91 Servant.BasicAuthSpec
92+ Servant.BrokenSpec
92 Servant.ClientTestUtils
93 Servant.ClientTestUtils
93 Servant.ConnectionErrorSpec
94 Servant.ConnectionErrorSpec
94 Servant.FailSpec
95 Servant.FailSpec
95 Servant.GenAuthSpec
96 Servant.GenAuthSpec
97+ Servant.GenericSpec
96 Servant.HoistClientSpec
98 Servant.HoistClientSpec
97 Servant.StreamSpec
99 Servant.StreamSpec
98 Servant.SuccessSpec
100 Servant.SuccessSpec
@@ -122,16 +124,16 @@ test-suite spec
122 -- Additional dependencies
124 -- Additional dependencies
123 build-depends:
125 build-depends:
124 entropy >= 0.4.1.3 && < 0.5
126 entropy >= 0.4.1.3 && < 0.5
125− , hspec >= 2.6.0 && < 2.9
127+ , hspec >= 2.6.0 && < 2.10
126 , HUnit >= 1.6.0.0 && < 1.7
128 , HUnit >= 1.6.0.0 && < 1.7
127 , network >= 2.8.0.0 && < 3.2
129 , network >= 2.8.0.0 && < 3.2
128 , QuickCheck >= 2.12.6.1 && < 2.15
130 , QuickCheck >= 2.12.6.1 && < 2.15
129− , servant == 0.18.*
131+ , servant == 0.19.*
130− , servant-server == 0.18.*
132+ , servant-server == 0.19.*
131 , tdigest >= 0.2 && < 0.3
133 , tdigest >= 0.2 && < 0.3
132
134
133 build-tool-depends:
135 build-tool-depends:
134− hspec-discover:hspec-discover >= 2.6.0 && < 2.9
136+ hspec-discover:hspec-discover >= 2.6.0 && < 2.10
135
137
136test-suite readme
138test-suite readme
137 type: exitcode-stdio-1.0
139 type: exitcode-stdio-1.0
servant-client/src/Servant/Client/Internal/HttpClient.hs+11−11
@@ -24,7 +24,7 @@ import Control.Monad
24import Control.Monad.Base
24import Control.Monad.Base
25 (MonadBase (..))
25 (MonadBase (..))
26import Control.Monad.Catch
26import Control.Monad.Catch
27− (MonadCatch, MonadThrow)
27+ (MonadCatch, MonadThrow, MonadMask)
28import Control.Monad.Error.Class
28import Control.Monad.Error.Class
29 (MonadError (..))
29 (MonadError (..))
30import Control.Monad.IO.Class
30import Control.Monad.IO.Class
@@ -63,7 +63,7 @@ import GHC.Generics
63import Network.HTTP.Media
63import Network.HTTP.Media
64 (renderHeader)
64 (renderHeader)
65import Network.HTTP.Types
65import Network.HTTP.Types
66− (hContentType, renderQuery, statusCode, urlEncode, Status)
66+ (hContentType, renderQuery, statusIsSuccessful, urlEncode, Status)
67import Servant.Client.Core
67import Servant.Client.Core
68
68
69import qualified Network.HTTP.Client as Client
69import qualified Network.HTTP.Client as Client
@@ -80,7 +80,7 @@ data ClientEnv
80 { manager :: Client.Manager
80 { manager :: Client.Manager
81 , baseUrl :: BaseUrl
81 , baseUrl :: BaseUrl
82 , cookieJar :: Maybe (TVar Client.CookieJar)
82 , cookieJar :: Maybe (TVar Client.CookieJar)
83− , makeClientRequest :: BaseUrl -> Request -> Client.Request
83+ , makeClientRequest :: BaseUrl -> Request -> IO Client.Request
84 -- ^ this function can be used to customize the creation of @http-client@ requests from @servant@ requests. Default value: 'defaultMakeClientRequest'
84 -- ^ this function can be used to customize the creation of @http-client@ requests from @servant@ requests. Default value: 'defaultMakeClientRequest'
85 -- Note that:
85 -- Note that:
86 -- 1. 'makeClientRequest' exists to allow overriding operational semantics e.g. 'responseTimeout' per request,
86 -- 1. 'makeClientRequest' exists to allow overriding operational semantics e.g. 'responseTimeout' per request,
@@ -136,7 +136,7 @@ newtype ClientM a = ClientM
136 { unClientM :: ReaderT ClientEnv (ExceptT ClientError IO) a }
136 { unClientM :: ReaderT ClientEnv (ExceptT ClientError IO) a }
137 deriving ( Functor, Applicative, Monad, MonadIO, Generic
137 deriving ( Functor, Applicative, Monad, MonadIO, Generic
138 , MonadReader ClientEnv, MonadError ClientError, MonadThrow
138 , MonadReader ClientEnv, MonadError ClientError, MonadThrow
139− , MonadCatch)
139+ , MonadCatch, MonadMask)
140
140
141instance MonadBase IO ClientM where
141instance MonadBase IO ClientM where
142 liftBase = ClientM . liftBase
142 liftBase = ClientM . liftBase
@@ -162,7 +162,7 @@ runClientM cm env = runExceptT $ flip runReaderT env $ unClientM cm
162performRequest :: Maybe [Status] -> Request -> ClientM Response
162performRequest :: Maybe [Status] -> Request -> ClientM Response
163performRequest acceptStatus req = do
163performRequest acceptStatus req = do
164 ClientEnv m burl cookieJar' createClientRequest <- ask
164 ClientEnv m burl cookieJar' createClientRequest <- ask
165− let clientRequest = createClientRequest burl req
165+ clientRequest <- liftIO $ createClientRequest burl req
166 request <- case cookieJar' of
166 request <- case cookieJar' of
167 Nothing -> pure clientRequest
167 Nothing -> pure clientRequest
168 Just cj -> liftIO $ do
168 Just cj -> liftIO $ do
@@ -179,10 +179,9 @@ performRequest acceptStatus req = do
179
179
180 response <- maybe (requestWithoutCookieJar m request) (requestWithCookieJar m request) cookieJar'
180 response <- maybe (requestWithoutCookieJar m request) (requestWithCookieJar m request) cookieJar'
181 let status = Client.responseStatus response
181 let status = Client.responseStatus response
182− status_code = statusCode status
183 ourResponse = clientResponseToResponse id response
182 ourResponse = clientResponseToResponse id response
184 goodStatus = case acceptStatus of
183 goodStatus = case acceptStatus of
185− Nothing -> status_code >= 200 && status_code < 300
184+ Nothing -> statusIsSuccessful status
186 Just good -> status `elem` good
185 Just good -> status `elem` good
187 unless goodStatus $ do
186 unless goodStatus $ do
188 throwError $ mkFailureResponse burl req ourResponse
187 throwError $ mkFailureResponse burl req ourResponse
@@ -230,8 +229,8 @@ clientResponseToResponse f r = Response
230-- | Create a @http-client@ 'Client.Request' from a @servant@ 'Request'
229-- | Create a @http-client@ 'Client.Request' from a @servant@ 'Request'
231-- The 'Client.host', 'Client.path' and 'Client.port' fields are extracted from the 'BaseUrl'
230-- The 'Client.host', 'Client.path' and 'Client.port' fields are extracted from the 'BaseUrl'
232-- otherwise the body, headers and query string are derived from the @servant@ 'Request'
231-- otherwise the body, headers and query string are derived from the @servant@ 'Request'
233−defaultMakeClientRequest :: BaseUrl -> Request -> Client.Request
232+defaultMakeClientRequest :: BaseUrl -> Request -> IO Client.Request
234−defaultMakeClientRequest burl r = Client.defaultRequest
233+defaultMakeClientRequest burl r = return Client.defaultRequest
235 { Client.method = requestMethod r
234 { Client.method = requestMethod r
236 , Client.host = fromString $ baseUrlHost burl
235 , Client.host = fromString $ baseUrlHost burl
237 , Client.port = baseUrlPort burl
236 , Client.port = baseUrlPort burl
@@ -247,7 +246,7 @@ defaultMakeClientRequest burl r = Client.defaultRequest
247 where
246 where
248 -- Content-Type and Accept are specified by requestBody and requestAccept
247 -- Content-Type and Accept are specified by requestBody and requestAccept
249 headers = filter (\(h, _) -> h /= "Accept" && h /= "Content-Type") $
248 headers = filter (\(h, _) -> h /= "Accept" && h /= "Content-Type") $
250− toList $requestHeaders r
249+ toList $ requestHeaders r
251
250
252 acceptHdr
251 acceptHdr
253 | null hs = Nothing
252 | null hs = Nothing
@@ -290,7 +289,8 @@ defaultMakeClientRequest burl r = Client.defaultRequest
290 Https -> True
289 Https -> True
291
290
292 -- Query string builder which does not do any encoding
291 -- Query string builder which does not do any encoding
292+ buildQueryString [] = mempty
293− buildQueryString = ("?" <>) . foldl' addQueryParam mempty
293+ buildQueryString qps = "?" <> foldl' addQueryParam mempty qps
294
294
295 addQueryParam qs (k, v) =
295 addQueryParam qs (k, v) =
296 qs <> (if BS.null qs then mempty else "&") <> urlEncode True k <> foldMap ("=" <>) v
296 qs <> (if BS.null qs then mempty else "&") <> urlEncode True k <> foldMap ("=" <>) v
servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs+5−7
@@ -47,7 +47,7 @@ import Data.Time.Clock
47 (getCurrentTime)
47 (getCurrentTime)
48import GHC.Generics
48import GHC.Generics
49import Network.HTTP.Types
49import Network.HTTP.Types
50− (Status, statusCode)
50+ (Status, statusIsSuccessful)
51
51
52import qualified Network.HTTP.Client as Client
52import qualified Network.HTTP.Client as Client
53
53
@@ -140,7 +140,7 @@ performRequest :: Maybe [Status] -> Request -> ClientM Response
140performRequest acceptStatus req = do
140performRequest acceptStatus req = do
141 -- TODO: should use Client.withResponse here too
141 -- TODO: should use Client.withResponse here too
142 ClientEnv m burl cookieJar' createClientRequest <- ask
142 ClientEnv m burl cookieJar' createClientRequest <- ask
143− let clientRequest = createClientRequest burl req
143+ clientRequest <- liftIO $ createClientRequest burl req
144 request <- case cookieJar' of
144 request <- case cookieJar' of
145 Nothing -> pure clientRequest
145 Nothing -> pure clientRequest
146 Just cj -> liftIO $ do
146 Just cj -> liftIO $ do
@@ -163,10 +163,9 @@ performRequest acceptStatus req = do
163 now' <- getCurrentTime
163 now' <- getCurrentTime
164 atomically $ modifyTVar' cj (fst . Client.updateCookieJar response request now')
164 atomically $ modifyTVar' cj (fst . Client.updateCookieJar response request now')
165 let status = Client.responseStatus response
165 let status = Client.responseStatus response
166− status_code = statusCode status
167 ourResponse = clientResponseToResponse id response
166 ourResponse = clientResponseToResponse id response
168 goodStatus = case acceptStatus of
167 goodStatus = case acceptStatus of
169− Nothing -> status_code >= 200 && status_code < 300
168+ Nothing -> statusIsSuccessful status
170 Just good -> status `elem` good
169 Just good -> status `elem` good
171 unless goodStatus $ do
170 unless goodStatus $ do
172 throwError $ mkFailureResponse burl req ourResponse
171 throwError $ mkFailureResponse burl req ourResponse
@@ -178,14 +177,13 @@ performWithStreamingRequest req k = do
178 m <- asks manager
177 m <- asks manager
179 burl <- asks baseUrl
178 burl <- asks baseUrl
180 createClientRequest <- asks makeClientRequest
179 createClientRequest <- asks makeClientRequest
181− let request = createClientRequest burl req
180+ request <- liftIO $ createClientRequest burl req
182 ClientM $ lift $ lift $ Codensity $ \k1 ->
181 ClientM $ lift $ lift $ Codensity $ \k1 ->
183 Client.withResponse request m $ \res -> do
182 Client.withResponse request m $ \res -> do
184 let status = Client.responseStatus res
183 let status = Client.responseStatus res
185− status_code = statusCode status
186
184
187 -- we throw FailureResponse in IO :(
185 -- we throw FailureResponse in IO :(
188− unless (status_code >= 200 && status_code < 300) $ do
186+ unless (statusIsSuccessful status) $ do
189 b <- BSL.fromChunks <$> Client.brConsume (Client.responseBody res)
187 b <- BSL.fromChunks <$> Client.brConsume (Client.responseBody res)
190 throwIO $ mkFailureResponse burl req (clientResponseToResponse (const b) res)
188 throwIO $ mkFailureResponse burl req (clientResponseToResponse (const b) res)
191
189
servant-client/test/Servant/BrokenSpec.hsnew file+71
@@ -0,0 +1,71 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE TypeOperators #-}
3+{-# OPTIONS_GHC -freduction-depth=100 #-}
4+{-# OPTIONS_GHC -fno-warn-orphans #-}
5+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
6+
7+module Servant.BrokenSpec (spec) where
8+
9+import Prelude ()
10+import Prelude.Compat
11+
12+import Data.Monoid ()
13+import Data.Proxy
14+import qualified Network.HTTP.Types as HTTP
15+import Test.Hspec
16+
17+import Servant.API
18+ ((:<|>) ((:<|>)), (:>), JSON, Verb, Get, StdMethod (GET))
19+import Servant.Client
20+import Servant.ClientTestUtils
21+import Servant.Server
22+
23+-- * api for testing inconsistencies between client and server
24+
25+type Get201 = Verb 'GET 201
26+type Get301 = Verb 'GET 301
27+
28+type BrokenAPI =
29+ -- the server should respond with 200, but returns 201
30+ "get200" :> Get201 '[JSON] ()
31+ -- the server should respond with 307, but returns 301
32+ :<|> "get307" :> Get301 '[JSON] ()
33+
34+brokenApi :: Proxy BrokenAPI
35+brokenApi = Proxy
36+
37+brokenServer :: Application
38+brokenServer = serve brokenApi (pure () :<|> pure ())
39+
40+type PublicAPI =
41+ -- the client expects 200
42+ "get200" :> Get '[JSON] ()
43+ -- the client expects 307
44+ :<|> "get307" :> Get307 '[JSON] ()
45+
46+publicApi :: Proxy PublicAPI
47+publicApi = Proxy
48+
49+get200Client :: ClientM ()
50+get307Client :: ClientM ()
51+get200Client :<|> get307Client = client publicApi
52+
53+
54+spec :: Spec
55+spec = describe "Servant.BrokenSpec" $ do
56+ brokenSpec
57+
58+brokenSpec :: Spec
59+brokenSpec = beforeAll (startWaiApp brokenServer) $ afterAll endWaiApp $ do
60+ context "client returns errors for inconsistencies between client and server api" $ do
61+ it "reports FailureResponse with wrong 2xx status code" $ \(_, baseUrl) -> do
62+ res <- runClient get200Client baseUrl
63+ case res of
64+ Left (FailureResponse _ r) | responseStatusCode r == HTTP.status201 -> return ()
65+ _ -> fail $ "expected 201 broken response, but got " <> show res
66+
67+ it "reports FailureResponse with wrong 3xx status code" $ \(_, baseUrl) -> do
68+ res <- runClient get307Client baseUrl
69+ case res of
70+ Left (FailureResponse _ r) | responseStatusCode r == HTTP.status301 -> return ()
71+ _ -> fail $ "expected 301 broken response, but got " <> show res
servant-client/test/Servant/ClientTestUtils.hs+48−4
@@ -64,7 +64,8 @@ import Servant.API
64 JSON, MimeRender (mimeRender), MimeUnrender (mimeUnrender),
64 JSON, MimeRender (mimeRender), MimeUnrender (mimeUnrender),
65 NoContent (NoContent), PlainText, Post, QueryFlag, QueryParam,
65 NoContent (NoContent), PlainText, Post, QueryFlag, QueryParam,
66 QueryParams, Raw, ReqBody, StdMethod (GET), ToHttpApiData (..), UVerb, Union,
66 QueryParams, Raw, ReqBody, StdMethod (GET), ToHttpApiData (..), UVerb, Union,
67− WithStatus (WithStatus), addHeader)
67+ Verb, WithStatus (WithStatus), NamedRoutes, addHeader)
68+import Servant.API.Generic ((:-))
68import Servant.Client
69import Servant.Client
69import qualified Servant.Client.Core.Auth as Auth
70import qualified Servant.Client.Core.Auth as Auth
70import Servant.Server
71import Servant.Server
@@ -107,9 +108,26 @@ carol = Person "Carol" 17
107
108
108type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]
109type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]
109
110
111+data RecordRoutes mode = RecordRoutes
112+ { version :: mode :- "version" :> Get '[JSON] Int
113+ , echo :: mode :- "echo" :> Capture "string" String :> Get '[JSON] String
114+ , otherRoutes :: mode :- "other" :> Capture "someParam" Int :> NamedRoutes OtherRoutes
115+ } deriving Generic
116+
117+data OtherRoutes mode = OtherRoutes
118+ { something :: mode :- "something" :> Get '[JSON] [String]
119+ } deriving Generic
120+
121+-- Get for HTTP 307 Temporary Redirect
122+type Get307 = Verb 'GET 307
123+
110type Api =
124type Api =
111 Get '[JSON] Person
125 Get '[JSON] Person
112 :<|> "get" :> Get '[JSON] Person
126 :<|> "get" :> Get '[JSON] Person
127+ -- This endpoint returns a response with status code 307 Temporary Redirect,
128+ -- different from the ones in the 2xx successful class, to test derivation
129+ -- of clients' api.
130+ :<|> "get307" :> Get307 '[PlainText] Text
113 :<|> "deleteEmpty" :> DeleteNoContent
131 :<|> "deleteEmpty" :> DeleteNoContent
114 :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person
132 :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person
115 :<|> "captureAll" :> CaptureAll "names" String :> Get '[JSON] [Person]
133 :<|> "captureAll" :> CaptureAll "names" String :> Get '[JSON] [Person]
@@ -141,13 +159,15 @@ type Api =
141 UVerb 'GET '[PlainText] '[WithStatus 200 Person,
159 UVerb 'GET '[PlainText] '[WithStatus 200 Person,
142 WithStatus 301 Text]
160 WithStatus 301 Text]
143 :<|> "uverb-get-created" :> UVerb 'GET '[PlainText] '[WithStatus 201 Person]
161 :<|> "uverb-get-created" :> UVerb 'GET '[PlainText] '[WithStatus 201 Person]
144−
162+ :<|> NamedRoutes RecordRoutes
163+ :<|> "captureVerbatim" :> Capture "someString" Verbatim :> Get '[PlainText] Text
145
164
146api :: Proxy Api
165api :: Proxy Api
147api = Proxy
166api = Proxy
148
167
149getRoot :: ClientM Person
168getRoot :: ClientM Person
150getGet :: ClientM Person
169getGet :: ClientM Person
170+getGet307 :: ClientM Text
151getDeleteEmpty :: ClientM NoContent
171getDeleteEmpty :: ClientM NoContent
152getCapture :: String -> ClientM Person
172getCapture :: String -> ClientM Person
153getCaptureAll :: [String] -> ClientM [Person]
173getCaptureAll :: [String] -> ClientM [Person]
@@ -170,9 +190,11 @@ uverbGetSuccessOrRedirect :: Bool
170 -> ClientM (Union '[WithStatus 200 Person,
190 -> ClientM (Union '[WithStatus 200 Person,
171 WithStatus 301 Text])
191 WithStatus 301 Text])
172uverbGetCreated :: ClientM (Union '[WithStatus 201 Person])
192uverbGetCreated :: ClientM (Union '[WithStatus 201 Person])
193+recordRoutes :: RecordRoutes (AsClientT ClientM)
173
194
174getRoot
195getRoot
175 :<|> getGet
196 :<|> getGet
197+ :<|> getGet307
176 :<|> getDeleteEmpty
198 :<|> getDeleteEmpty
177 :<|> getCapture
199 :<|> getCapture
178 :<|> getCaptureAll
200 :<|> getCaptureAll
@@ -192,12 +214,15 @@ getRoot
192 :<|> getRedirectWithCookie
214 :<|> getRedirectWithCookie
193 :<|> EmptyClient
215 :<|> EmptyClient
194 :<|> uverbGetSuccessOrRedirect
216 :<|> uverbGetSuccessOrRedirect
195− :<|> uverbGetCreated = client api
217+ :<|> uverbGetCreated
218+ :<|> recordRoutes
219+ :<|> captureVerbatim = client api
196
220
197server :: Application
221server :: Application
198server = serve api (
222server = serve api (
199 return carol
223 return carol
200 :<|> return alice
224 :<|> return alice
225+ :<|> return "redirecting"
201 :<|> return NoContent
226 :<|> return NoContent
202 :<|> (\ name -> return $ Person name 0)
227 :<|> (\ name -> return $ Person name 0)
203 :<|> (\ names -> return (zipWith Person names [0..]))
228 :<|> (\ names -> return (zipWith Person names [0..]))
@@ -229,8 +254,18 @@ server = serve api (
229 then respond (WithStatus @301 ("redirecting" :: Text))
254 then respond (WithStatus @301 ("redirecting" :: Text))
230 else respond (WithStatus @200 alice ))
255 else respond (WithStatus @200 alice ))
231 :<|> respond (WithStatus @201 carol)
256 :<|> respond (WithStatus @201 carol)
257+ :<|> RecordRoutes
258+ { version = pure 42
259+ , echo = pure
260+ , otherRoutes = \_ -> OtherRoutes
261+ { something = pure ["foo", "bar", "pweet"]
262+ }
263+ }
264+ :<|> pure . decodeUtf8 . unVerbatim
232 )
265 )
233
266
267+-- * api for testing failures
268+
234type FailApi =
269type FailApi =
235 "get" :> Raw
270 "get" :> Raw
236 :<|> "capture" :> Capture "name" String :> Raw
271 :<|> "capture" :> Capture "name" String :> Raw
@@ -245,7 +280,7 @@ failServer = serve failApi (
245 :<|> (\ _capture -> Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "application/json")] "")
280 :<|> (\ _capture -> Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "application/json")] "")
246 :<|> (Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "fooooo")] "")
281 :<|> (Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "fooooo")] "")
247 :<|> (Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "application/x-www-form-urlencoded"), ("X-Example1", "1"), ("X-Example2", "foo")] "")
282 :<|> (Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "application/x-www-form-urlencoded"), ("X-Example1", "1"), ("X-Example2", "foo")] "")
248− )
283+ )
249
284
250-- * basic auth stuff
285-- * basic auth stuff
251
286
@@ -338,3 +373,12 @@ instance ToHttpApiData UrlEncodedByteString where
338
373
339instance FromHttpApiData UrlEncodedByteString where
374instance FromHttpApiData UrlEncodedByteString where
340 parseUrlPiece = pure . UrlEncodedByteString . HTTP.urlDecode True . encodeUtf8
375 parseUrlPiece = pure . UrlEncodedByteString . HTTP.urlDecode True . encodeUtf8
376+
377+newtype Verbatim = Verbatim { unVerbatim :: ByteString }
378+
379+instance ToHttpApiData Verbatim where
380+ toEncodedUrlPiece = byteString . unVerbatim
381+ toUrlPiece = decodeUtf8 . unVerbatim
382+
383+instance FromHttpApiData Verbatim where
384+ parseUrlPiece = pure . Verbatim . encodeUtf8
servant-client/test/Servant/FailSpec.hs+3−3
@@ -38,14 +38,14 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
38
38
39 context "client returns errors appropriately" $ do
39 context "client returns errors appropriately" $ do
40 it "reports FailureResponse" $ \(_, baseUrl) -> do
40 it "reports FailureResponse" $ \(_, baseUrl) -> do
41− let (_ :<|> _ :<|> getDeleteEmpty :<|> _) = client api
41+ let (_ :<|> _ :<|> _ :<|> getDeleteEmpty :<|> _) = client api
42 Left res <- runClient getDeleteEmpty baseUrl
42 Left res <- runClient getDeleteEmpty baseUrl
43 case res of
43 case res of
44 FailureResponse _ r | responseStatusCode r == HTTP.status404 -> return ()
44 FailureResponse _ r | responseStatusCode r == HTTP.status404 -> return ()
45 _ -> fail $ "expected 404 response, but got " <> show res
45 _ -> fail $ "expected 404 response, but got " <> show res
46
46
47 it "reports DecodeFailure" $ \(_, baseUrl) -> do
47 it "reports DecodeFailure" $ \(_, baseUrl) -> do
48− let (_ :<|> _ :<|> _ :<|> getCapture :<|> _) = client api
48+ let (_ :<|> _ :<|> _ :<|> _ :<|> getCapture :<|> _) = client api
49 Left res <- runClient (getCapture "foo") baseUrl
49 Left res <- runClient (getCapture "foo") baseUrl
50 case res of
50 case res of
51 DecodeFailure _ _ -> return ()
51 DecodeFailure _ _ -> return ()
@@ -72,7 +72,7 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
72 _ -> fail $ "expected UnsupportedContentType, but got " <> show res
72 _ -> fail $ "expected UnsupportedContentType, but got " <> show res
73
73
74 it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do
74 it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do
75− let (_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api
75+ let (_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api
76 Left res <- runClient (getBody alice) baseUrl
76 Left res <- runClient (getBody alice) baseUrl
77 case res of
77 case res of
78 InvalidContentTypeHeader _ -> return ()
78 InvalidContentTypeHeader _ -> return ()
servant-client/test/Servant/GenericSpec.hsnew file+37
@@ -0,0 +1,37 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE ConstraintKinds #-}
3+{-# LANGUAGE DataKinds #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE GADTs #-}
7+{-# LANGUAGE MultiParamTypeClasses #-}
8+{-# LANGUAGE OverloadedStrings #-}
9+{-# LANGUAGE PolyKinds #-}
10+{-# LANGUAGE ScopedTypeVariables #-}
11+{-# LANGUAGE TypeFamilies #-}
12+{-# LANGUAGE TypeOperators #-}
13+{-# LANGUAGE UndecidableInstances #-}
14+{-# OPTIONS_GHC -freduction-depth=100 #-}
15+{-# OPTIONS_GHC -fno-warn-orphans #-}
16+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
17+
18+module Servant.GenericSpec (spec) where
19+
20+import Test.Hspec
21+
22+import Servant.Client ((//), (/:))
23+import Servant.ClientTestUtils
24+
25+spec :: Spec
26+spec = describe "Servant.GenericSpec" $ do
27+ genericSpec
28+
29+genericSpec :: Spec
30+genericSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
31+ context "Record clients work as expected" $ do
32+
33+ it "Client functions return expected values" $ \(_,baseUrl) -> do
34+ runClient (recordRoutes // version) baseUrl `shouldReturn` Right 42
35+ runClient (recordRoutes // echo /: "foo") baseUrl `shouldReturn` Right "foo"
36+ it "Clients can be nested" $ \(_,baseUrl) -> do
37+ runClient (recordRoutes // otherRoutes /: 42 // something) baseUrl `shouldReturn` Right ["foo", "bar", "pweet"]
servant-client/test/Servant/SuccessSpec.hs+21−6
@@ -36,6 +36,8 @@ import Data.Maybe
36import Data.Monoid ()
36import Data.Monoid ()
37import Data.Text
37import Data.Text
38 (Text)
38 (Text)
39+import Data.Text.Encoding
40+ (encodeUtf8)
39import qualified Network.HTTP.Client as C
41import qualified Network.HTTP.Client as C
40import qualified Network.HTTP.Types as HTTP
42import qualified Network.HTTP.Types as HTTP
41import Test.Hspec
43import Test.Hspec
@@ -59,11 +61,15 @@ spec = describe "Servant.SuccessSpec" $ do
59
61
60successSpec :: Spec
62successSpec :: Spec
61successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
63successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
62− it "Servant.API.Get root" $ \(_, baseUrl) -> do
64+ describe "Servant.API.Get" $ do
65+ it "get root endpoint" $ \(_, baseUrl) -> do
63− left show <$> runClient getRoot baseUrl `shouldReturn` Right carol
66+ left show <$> runClient getRoot baseUrl `shouldReturn` Right carol
64
67
65− it "Servant.API.Get" $ \(_, baseUrl) -> do
68+ it "get simple endpoint" $ \(_, baseUrl) -> do
66− left show <$> runClient getGet baseUrl `shouldReturn` Right alice
69+ left show <$> runClient getGet baseUrl `shouldReturn` Right alice
70+
71+ it "get redirection endpoint" $ \(_, baseUrl) -> do
72+ left show <$> runClient getGet307 baseUrl `shouldReturn` Right "redirecting"
67
73
68 describe "Servant.API.Delete" $ do
74 describe "Servant.API.Delete" $ do
69 it "allows empty content type" $ \(_, baseUrl) -> do
75 it "allows empty content type" $ \(_, baseUrl) -> do
@@ -111,6 +117,7 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
111
117
112 it "Servant.API.Fragment" $ \(_, baseUrl) -> do
118 it "Servant.API.Fragment" $ \(_, baseUrl) -> do
113 left id <$> runClient getFragment baseUrl `shouldReturn` Right alice
119 left id <$> runClient getFragment baseUrl `shouldReturn` Right alice
120+
114 it "Servant.API.Raw on success" $ \(_, baseUrl) -> do
121 it "Servant.API.Raw on success" $ \(_, baseUrl) -> do
115 res <- runClient (getRawSuccess HTTP.methodGet) baseUrl
122 res <- runClient (getRawSuccess HTTP.methodGet) baseUrl
116 case res of
123 case res of
@@ -155,8 +162,9 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
155 mgr <- C.newManager C.defaultManagerSettings
162 mgr <- C.newManager C.defaultManagerSettings
156 -- In proper situation, extra headers should probably be visible in API type.
163 -- In proper situation, extra headers should probably be visible in API type.
157 -- However, testing for response timeout is difficult, so we test with something which is easy to observe
164 -- However, testing for response timeout is difficult, so we test with something which is easy to observe
158− let createClientRequest url r = (defaultMakeClientRequest url r) { C.requestHeaders = [("X-Added-Header", "XXX")] }
165+ let createClientRequest url r = fmap (\req -> req { C.requestHeaders = [("X-Added-Header", "XXX")] })
166+ (defaultMakeClientRequest url r)
159− let clientEnv = (mkClientEnv mgr baseUrl) { makeClientRequest = createClientRequest }
167+ clientEnv = (mkClientEnv mgr baseUrl) { makeClientRequest = createClientRequest }
160 res <- runClientM (getRawSuccessPassHeaders HTTP.methodGet) clientEnv
168 res <- runClientM (getRawSuccessPassHeaders HTTP.methodGet) clientEnv
161 case res of
169 case res of
162 Left e ->
170 Left e ->
@@ -191,3 +199,10 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
191 case eitherResponse of
199 case eitherResponse of
192 Left clientError -> fail $ show clientError
200 Left clientError -> fail $ show clientError
193 Right response -> matchUnion response `shouldBe` Just (WithStatus @201 carol)
201 Right response -> matchUnion response `shouldBe` Just (WithStatus @201 carol)
202+
203+ it "encodes URL pieces following ToHttpApiData instance" $ \(_, baseUrl) -> do
204+ let textOrig = "*"
205+ eitherResponse <- runClient (captureVerbatim $ Verbatim $ encodeUtf8 textOrig) baseUrl
206+ case eitherResponse of
207+ Left clientError -> fail $ show clientError
208+ Right textBack -> textBack `shouldBe` textOrig
servant-conduit/servant-conduit.cabal+6−6
@@ -1,4 +1,4 @@
1−cabal-version: >=1.10
1+cabal-version: 2.2
2name: servant-conduit
2name: servant-conduit
3version: 0.15.1
3version: 0.15.1
4
4
@@ -10,7 +10,7 @@ description: Servant Stream support for conduit.
10
10
11homepage: http://docs.servant.dev/
11homepage: http://docs.servant.dev/
12bug-reports: http://github.com/haskell-servant/servant/issues
12bug-reports: http://github.com/haskell-servant/servant/issues
13−license: BSD3
13+license: BSD-3-Clause
14license-file: LICENSE
14license-file: LICENSE
15author: Servant Contributors
15author: Servant Contributors
16maintainer: haskell-servant-maintainers@googlegroups.com
16maintainer: haskell-servant-maintainers@googlegroups.com
@@ -23,7 +23,7 @@ extra-source-files:
23
23
24source-repository head
24source-repository head
25 type: git
25 type: git
26− location: http://github.com/haskell-servant/servant-conduit.git
26+ location: http://github.com/haskell-servant/servant.git
27
27
28library
28library
29 exposed-modules: Servant.Conduit
29 exposed-modules: Servant.Conduit
@@ -33,7 +33,7 @@ library
33 , conduit >=1.3.1 && <1.4
33 , conduit >=1.3.1 && <1.4
34 , mtl >=2.2.2 && <2.3
34 , mtl >=2.2.2 && <2.3
35 , resourcet >=1.2.2 && <1.3
35 , resourcet >=1.2.2 && <1.3
36− , servant >=0.15 && <0.19
36+ , servant >=0.15 && <0.20
37 , unliftio-core >=0.1.2.0 && <0.3
37 , unliftio-core >=0.1.2.0 && <0.3
38 hs-source-dirs: src
38 hs-source-dirs: src
39 default-language: Haskell2010
39 default-language: Haskell2010
@@ -54,8 +54,8 @@ test-suite example
54 , resourcet
54 , resourcet
55 , servant
55 , servant
56 , servant-conduit
56 , servant-conduit
57− , servant-server >=0.15 && <0.19
57+ , servant-server >=0.15 && <0.20
58− , servant-client >=0.15 && <0.19
58+ , servant-client >=0.15 && <0.20
59 , wai >=3.2.1.2 && <3.3
59 , wai >=3.2.1.2 && <3.3
60 , warp >=3.2.25 && <3.4
60 , warp >=3.2.25 && <3.4
61 , http-client
61 , http-client
servant-docs/CHANGELOG.md+9
@@ -1,6 +1,15 @@
1[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-docs/CHANGELOG.md)
1[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-docs/CHANGELOG.md)
2[Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)
2[Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)
3
3
4+0.12
5+----
6+
7+### Significant changes
8+
9+- Generate sample cURL requests
10+ ([#1401](https://github.com/haskell-servant/servant/pull/1401/files)).
11+ Breaking change: requires sample header values to be supplied with `headers`.
12+
40.11.9
130.11.9
5------
14------
6
15
servant-docs/servant-docs.cabal+10−10
@@ -1,6 +1,6 @@
1−cabal-version: >=1.10
1+cabal-version: 2.2
2name: servant-docs
2name: servant-docs
3−version: 0.11.9
3+version: 0.12
4
4
5synopsis: generate API docs for your servant webservice
5synopsis: generate API docs for your servant webservice
6category: Servant, Web
6category: Servant, Web
@@ -13,7 +13,7 @@ description:
13
13
14homepage: http://docs.servant.dev/
14homepage: http://docs.servant.dev/
15bug-reports: http://github.com/haskell-servant/servant/issues
15bug-reports: http://github.com/haskell-servant/servant/issues
16−license: BSD3
16+license: BSD-3-Clause
17license-file: LICENSE
17license-file: LICENSE
18author: Servant Contributors
18author: Servant Contributors
19maintainer: haskell-servant-maintainers@googlegroups.com
19maintainer: haskell-servant-maintainers@googlegroups.com
@@ -41,25 +41,25 @@ library
41 --
41 --
42 -- note: mtl lower bound is so low because of GHC-7.8
42 -- note: mtl lower bound is so low because of GHC-7.8
43 build-depends:
43 build-depends:
44− base >= 4.9 && < 4.16
44+ base >= 4.9 && < 4.17
45 , bytestring >= 0.10.8.1 && < 0.12
45 , bytestring >= 0.10.8.1 && < 0.12
46− , text >= 1.2.3.0 && < 1.3
46+ , text >= 1.2.3.0 && < 2.1
47
47
48 -- Servant dependencies
48 -- Servant dependencies
49 build-depends:
49 build-depends:
50− servant >= 0.18 && <0.19
50+ servant >= 0.18 && <0.20
51
51
52 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.
52 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.
53 -- Here can be exceptions if we really need features from the newer versions.
53 -- Here can be exceptions if we really need features from the newer versions.
54 build-depends:
54 build-depends:
55− aeson >= 1.4.1.0 && < 1.6
55+ aeson >= 1.4.1.0 && < 3
56 , aeson-pretty >= 0.8.5 && < 0.9
56 , aeson-pretty >= 0.8.5 && < 0.9
57− , base-compat >= 0.10.5 && < 0.12
57+ , base-compat >= 0.10.5 && < 0.13
58 , case-insensitive >= 1.2.0.11 && < 1.3
58 , case-insensitive >= 1.2.0.11 && < 1.3
59− , hashable >= 1.2.7.0 && < 1.4
59+ , hashable >= 1.2.7.0 && < 1.5
60 , http-media >= 0.7.1.3 && < 0.9
60 , http-media >= 0.7.1.3 && < 0.9
61 , http-types >= 0.12.2 && < 0.13
61 , http-types >= 0.12.2 && < 0.13
62− , lens >= 4.17 && < 5.1
62+ , lens >= 4.17 && < 5.2
63 , string-conversions >= 0.4.0.1 && < 0.5
63 , string-conversions >= 0.4.0.1 && < 0.5
64 , universe-base >= 1.1.1 && < 1.2
64 , universe-base >= 1.1.1 && < 1.2
65 , unordered-containers >= 0.2.9.0 && < 0.3
65 , unordered-containers >= 0.2.9.0 && < 0.3
servant-docs/src/Servant/Docs/Internal.hs+5−3
@@ -32,9 +32,7 @@ import Data.ByteString.Lazy.Char8
32 (ByteString)
32 (ByteString)
33import qualified Data.CaseInsensitive as CI
33import qualified Data.CaseInsensitive as CI
34import Data.Foldable
34import Data.Foldable
35− (toList)
35+ (fold, toList)
36−import Data.Foldable
37− (fold)
38import Data.Hashable
36import Data.Hashable
39 (Hashable)
37 (Hashable)
40import Data.HashMap.Strict
38import Data.HashMap.Strict
@@ -64,6 +62,7 @@ import GHC.TypeLits
64import Servant.API
62import Servant.API
65import Servant.API.ContentTypes
63import Servant.API.ContentTypes
66import Servant.API.TypeLevel
64import Servant.API.TypeLevel
65+import Servant.API.Generic
67
66
68import qualified Data.Universe.Helpers as U
67import qualified Data.Universe.Helpers as U
69
68
@@ -1152,6 +1151,9 @@ instance (ToAuthInfo (BasicAuth realm usr), HasDocs api) => HasDocs (BasicAuth r
1152 authProxy = Proxy :: Proxy (BasicAuth realm usr)
1151 authProxy = Proxy :: Proxy (BasicAuth realm usr)
1153 action' = over authInfo (|> toAuthInfo authProxy) action
1152 action' = over authInfo (|> toAuthInfo authProxy) action
1154
1153
1154+instance HasDocs (ToServantApi api) => HasDocs (NamedRoutes api) where
1155+ docsFor Proxy = docsFor (Proxy :: Proxy (ToServantApi api))
1156+
1155-- ToSample instances for simple types
1157-- ToSample instances for simple types
1156instance ToSample NoContent
1158instance ToSample NoContent
1157instance ToSample Bool
1159instance ToSample Bool
servant-docs/src/Servant/Docs/Internal/Pretty.hs+19
@@ -18,6 +18,7 @@ import Data.Proxy
18import Network.HTTP.Media
18import Network.HTTP.Media
19 ((//))
19 ((//))
20import Servant.API
20import Servant.API
21+import Servant.API.Verbs
21
22
22-- | PrettyJSON content type.
23-- | PrettyJSON content type.
23data PrettyJSON
24data PrettyJSON
@@ -46,6 +47,24 @@ type family Pretty (api :: k) :: k where
46 Pretty (Put cs r) = Put (Pretty cs) r
47 Pretty (Put cs r) = Put (Pretty cs) r
47 Pretty (Delete cs r) = Delete (Pretty cs) r
48 Pretty (Delete cs r) = Delete (Pretty cs) r
48 Pretty (Patch cs r) = Patch (Pretty cs) r
49 Pretty (Patch cs r) = Patch (Pretty cs) r
50+ Pretty (GetPartialContent cs r) = GetPartialContent (Pretty cs) r
51+ Pretty (PutResetContent cs r) = PutResetContent (Pretty cs) r
52+ Pretty (PatchResetContent cs r) = PatchResetContent (Pretty cs) r
53+ Pretty (DeleteResetContent cs r) = DeleteResetContent (Pretty cs) r
54+ Pretty (PostResetContent cs r) = PostResetContent (Pretty cs) r
55+ Pretty (GetResetContent cs r) = GetResetContent (Pretty cs) r
56+ Pretty (PutNonAuthoritative cs r) = PutNonAuthoritative (Pretty cs) r
57+ Pretty (PatchNonAuthoritative cs r) = PatchNonAuthoritative (Pretty cs) r
58+ Pretty (DeleteNonAuthoritative cs r) = DeleteNonAuthoritative (Pretty cs) r
59+ Pretty (PostNonAuthoritative cs r) = PostNonAuthoritative (Pretty cs) r
60+ Pretty (GetNonAuthoritative cs r) = GetNonAuthoritative (Pretty cs) r
61+ Pretty (PutAccepted cs r) = PutAccepted (Pretty cs) r
62+ Pretty (PatchAccepted cs r) = PatchAccepted (Pretty cs) r
63+ Pretty (DeleteAccepted cs r) = DeleteAccepted (Pretty cs) r
64+ Pretty (PostAccepted cs r) = PostAccepted (Pretty cs) r
65+ Pretty (GetAccepted cs r) = GetAccepted (Pretty cs) r
66+ Pretty (PutCreated cs r) = PutCreated (Pretty cs) r
67+ Pretty (PostCreated cs r) = PostCreated (Pretty cs) r
49 Pretty (ReqBody cs r) = ReqBody (Pretty cs) r
68 Pretty (ReqBody cs r) = ReqBody (Pretty cs) r
50 Pretty (JSON ': xs) = PrettyJSON ': xs
69 Pretty (JSON ': xs) = PrettyJSON ': xs
51 Pretty (x ': xs) = x ': Pretty xs
70 Pretty (x ': xs) = x ': Pretty xs
servant-foreign/servant-foreign.cabal+9−9
@@ -1,4 +1,4 @@
1−cabal-version: >=1.10
1+cabal-version: 2.2
2name: servant-foreign
2name: servant-foreign
3version: 0.15.4
3version: 0.15.4
4
4
@@ -15,7 +15,7 @@ description:
15
15
16homepage: http://docs.servant.dev/
16homepage: http://docs.servant.dev/
17bug-reports: http://github.com/haskell-servant/servant/issues
17bug-reports: http://github.com/haskell-servant/servant/issues
18−license: BSD3
18+license: BSD-3-Clause
19license-file: LICENSE
19license-file: LICENSE
20author: Servant Contributors
20author: Servant Contributors
21maintainer: haskell-servant-maintainers@googlegroups.com
21maintainer: haskell-servant-maintainers@googlegroups.com
@@ -41,18 +41,18 @@ library
41 --
41 --
42 -- note: mtl lower bound is so low because of GHC-7.8
42 -- note: mtl lower bound is so low because of GHC-7.8
43 build-depends:
43 build-depends:
44− base >= 4.9 && < 4.16
44+ base >= 4.9 && < 4.17
45− , text >= 1.2.3.0 && < 1.3
45+ , text >= 1.2.3.0 && < 2.1
46
46
47 -- Servant dependencies
47 -- Servant dependencies
48 build-depends:
48 build-depends:
49− servant >=0.18 && <0.19
49+ servant >=0.18 && <0.20
50
50
51 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.
51 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.
52 -- Here can be exceptions if we really need features from the newer versions.
52 -- Here can be exceptions if we really need features from the newer versions.
53 build-depends:
53 build-depends:
54− base-compat >= 0.10.5 && < 0.12
54+ base-compat >= 0.10.5 && < 0.13
55− , lens >= 4.17 && < 5.1
55+ , lens >= 4.17 && < 5.2
56 , http-types >= 0.12.2 && < 0.13
56 , http-types >= 0.12.2 && < 0.13
57
57
58 hs-source-dirs: src
58 hs-source-dirs: src
@@ -74,7 +74,7 @@ test-suite spec
74
74
75 -- Additional dependencies
75 -- Additional dependencies
76 build-depends:
76 build-depends:
77− hspec >= 2.6.0 && <2.9
77+ hspec >= 2.6.0 && <2.10
78 build-tool-depends:
78 build-tool-depends:
79− hspec-discover:hspec-discover >=2.6.0 && <2.9
79+ hspec-discover:hspec-discover >=2.6.0 && <2.10
80 default-language: Haskell2010
80 default-language: Haskell2010
servant-http-streams/CHANGELOG.md+10
@@ -1,6 +1,16 @@
1 [The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-http-streams/CHANGELOG.md)
1 [The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-http-streams/CHANGELOG.md)
2[Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)
2[Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)
3
3
4+0.18.4
5+------
6+
7+### Significant changes
8+
9+- *servant-client* / *servant-client-core* / *servant-http-streams*:
10+ Fix erroneous behavior, where only 2XX status codes would be considered
11+ successful, irrelevant of the status parameter specified by the verb
12+ combinator. ([#1469](https://github.com/haskell-servant/servant/pull/1469))
13+
40.18.3
140.18.3
5------
15------
6
16
servant-http-streams/servant-http-streams.cabal+15−15
@@ -1,6 +1,6 @@
1−cabal-version: >=1.10
1+cabal-version: 2.2
2name: servant-http-streams
2name: servant-http-streams
3−version: 0.18.3
3+version: 0.18.4
4
4
5synopsis: Automatic derivation of querying functions for servant
5synopsis: Automatic derivation of querying functions for servant
6category: Servant, Web
6category: Servant, Web
@@ -14,7 +14,7 @@ description:
14
14
15homepage: http://docs.servant.dev/
15homepage: http://docs.servant.dev/
16bug-reports: http://github.com/haskell-servant/servant/issues
16bug-reports: http://github.com/haskell-servant/servant/issues
17−license: BSD3
17+license: BSD-3-Clause
18license-file: LICENSE
18license-file: LICENSE
19author: Servant Contributors
19author: Servant Contributors
20maintainer: haskell-servant-maintainers@googlegroups.com
20maintainer: haskell-servant-maintainers@googlegroups.com
@@ -38,13 +38,13 @@ library
38 -- Bundled with GHC: Lower bound to not force re-installs
38 -- Bundled with GHC: Lower bound to not force re-installs
39 -- text and mtl are bundled starting with GHC-8.4
39 -- text and mtl are bundled starting with GHC-8.4
40 build-depends:
40 build-depends:
41− base >= 4.9 && < 4.16
41+ base >= 4.9 && < 4.17
42 , bytestring >= 0.10.8.1 && < 0.12
42 , bytestring >= 0.10.8.1 && < 0.12
43 , containers >= 0.5.7.1 && < 0.7
43 , containers >= 0.5.7.1 && < 0.7
44 , deepseq >= 1.4.2.0 && < 1.5
44 , deepseq >= 1.4.2.0 && < 1.5
45 , mtl >= 2.2.2 && < 2.3
45 , mtl >= 2.2.2 && < 2.3
46− , text >= 1.2.3.0 && < 1.3
46+ , text >= 1.2.3.0 && < 2.1
47− , time >= 1.6.0.1 && < 1.10
47+ , time >= 1.6.0.1 && < 1.12
48 , transformers >= 0.5.2.0 && < 0.6
48 , transformers >= 0.5.2.0 && < 0.6
49
49
50 if !impl(ghc >= 8.2)
50 if !impl(ghc >= 8.2)
@@ -54,25 +54,25 @@ library
54 -- Servant dependencies.
54 -- Servant dependencies.
55 -- Strict dependency on `servant-client-core` as we re-export things.
55 -- Strict dependency on `servant-client-core` as we re-export things.
56 build-depends:
56 build-depends:
57− servant == 0.18.*
57+ servant >= 0.18 && < 0.20
58− , servant-client-core >= 0.18.3 && <0.18.4
58+ , servant-client-core >= 0.18.3 && <0.20
59
59
60 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.
60 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.
61 -- Here can be exceptions if we really need features from the newer versions.
61 -- Here can be exceptions if we really need features from the newer versions.
62 build-depends:
62 build-depends:
63− base-compat >= 0.10.5 && < 0.12
63+ base-compat >= 0.10.5 && < 0.13
64 , case-insensitive
64 , case-insensitive
65 , http-streams >= 0.8.6.1 && < 0.9
65 , http-streams >= 0.8.6.1 && < 0.9
66 , http-media >= 0.7.1.3 && < 0.9
66 , http-media >= 0.7.1.3 && < 0.9
67 , io-streams >= 1.5.0.1 && < 1.6
67 , io-streams >= 1.5.0.1 && < 1.6
68 , http-types >= 0.12.2 && < 0.13
68 , http-types >= 0.12.2 && < 0.13
69− , http-common >= 0.8.2.0 && < 0.8.3
69+ , http-common >= 0.8.2.0 && < 0.9
70 , exceptions >= 0.10.0 && < 0.11
70 , exceptions >= 0.10.0 && < 0.11
71 , kan-extensions >= 5.2 && < 5.3
71 , kan-extensions >= 5.2 && < 5.3
72 , monad-control >= 1.0.2.3 && < 1.1
72 , monad-control >= 1.0.2.3 && < 1.1
73 , semigroupoids >= 5.3.1 && < 5.4
73 , semigroupoids >= 5.3.1 && < 5.4
74 , transformers-base >= 0.4.5.2 && < 0.5
74 , transformers-base >= 0.4.5.2 && < 0.5
75− , transformers-compat >= 0.6.2 && < 0.7
75+ , transformers-compat >= 0.6.2 && < 0.8
76
76
77 hs-source-dirs: src
77 hs-source-dirs: src
78 default-language: Haskell2010
78 default-language: Haskell2010
@@ -112,16 +112,16 @@ test-suite spec
112 -- Additional dependencies
112 -- Additional dependencies
113 build-depends:
113 build-depends:
114 entropy >= 0.4.1.3 && < 0.5
114 entropy >= 0.4.1.3 && < 0.5
115− , hspec >= 2.6.0 && < 2.9
115+ , hspec >= 2.6.0 && < 2.10
116 , HUnit >= 1.6.0.0 && < 1.7
116 , HUnit >= 1.6.0.0 && < 1.7
117 , network >= 2.8.0.0 && < 3.2
117 , network >= 2.8.0.0 && < 3.2
118 , QuickCheck >= 2.12.6.1 && < 2.15
118 , QuickCheck >= 2.12.6.1 && < 2.15
119− , servant == 0.18.*
119+ , servant == 0.19.*
120− , servant-server == 0.18.*
120+ , servant-server == 0.19.*
121 , tdigest >= 0.2 && < 0.3
121 , tdigest >= 0.2 && < 0.3
122
122
123 build-tool-depends:
123 build-tool-depends:
124− hspec-discover:hspec-discover >= 2.6.0 && < 2.9
124+ hspec-discover:hspec-discover >= 2.6.0 && < 2.10
125
125
126test-suite readme
126test-suite readme
127 type: exitcode-stdio-1.0
127 type: exitcode-stdio-1.0
servant-http-streams/src/Servant/HttpStreams/Internal.hs+6−6
@@ -57,7 +57,7 @@ import GHC.Generics
57import Network.HTTP.Media
57import Network.HTTP.Media
58 (renderHeader)
58 (renderHeader)
59import Network.HTTP.Types
59import Network.HTTP.Types
60− (Status (..), hContentType, http11, renderQuery)
60+ (Status (..), hContentType, http11, renderQuery, statusIsSuccessful)
61import Servant.Client.Core
61import Servant.Client.Core
62
62
63import qualified Network.Http.Client as Client
63import qualified Network.Http.Client as Client
@@ -160,12 +160,12 @@ performRequest acceptStatus req = do
160 x <- ClientM $ lift $ lift $ Codensity $ \k -> do
160 x <- ClientM $ lift $ lift $ Codensity $ \k -> do
161 Client.sendRequest conn req' body
161 Client.sendRequest conn req' body
162 Client.receiveResponse conn $ \res' body' -> do
162 Client.receiveResponse conn $ \res' body' -> do
163− let sc = Client.getStatusCode res'
163+ let status = toEnum $ Client.getStatusCode res'
164 lbs <- BSL.fromChunks <$> Streams.toList body'
164 lbs <- BSL.fromChunks <$> Streams.toList body'
165 let res'' = clientResponseToResponse res' lbs
165 let res'' = clientResponseToResponse res' lbs
166 goodStatus = case acceptStatus of
166 goodStatus = case acceptStatus of
167− Nothing -> sc >= 200 && sc < 300
167+ Nothing -> statusIsSuccessful status
168− Just good -> sc `elem` (statusCode <$> good)
168+ Just good -> status `elem` good
169 if goodStatus
169 if goodStatus
170 then k (Right res'')
170 then k (Right res'')
171 else k (Left (mkFailureResponse burl req res''))
171 else k (Left (mkFailureResponse burl req res''))
@@ -180,8 +180,8 @@ performWithStreamingRequest req k = do
180 Client.sendRequest conn req' body
180 Client.sendRequest conn req' body
181 Client.receiveResponseRaw conn $ \res' body' -> do
181 Client.receiveResponseRaw conn $ \res' body' -> do
182 -- check status code
182 -- check status code
183− let sc = Client.getStatusCode res'
183+ let status = toEnum $ Client.getStatusCode res'
184− unless (sc >= 200 && sc < 300) $ do
184+ unless (statusIsSuccessful status) $ do
185 lbs <- BSL.fromChunks <$> Streams.toList body'
185 lbs <- BSL.fromChunks <$> Streams.toList body'
186 throwIO $ mkFailureResponse burl req (clientResponseToResponse res' lbs)
186 throwIO $ mkFailureResponse burl req (clientResponseToResponse res' lbs)
187
187
servant-machines/servant-machines.cabal+6−6
@@ -1,4 +1,4 @@
1−cabal-version: >=1.10
1+cabal-version: 2.2
2name: servant-machines
2name: servant-machines
3version: 0.15.1
3version: 0.15.1
4
4
@@ -10,7 +10,7 @@ description: Servant Stream support for machines.
10
10
11homepage: http://docs.servant.dev/
11homepage: http://docs.servant.dev/
12bug-reports: http://github.com/haskell-servant/servant/issues
12bug-reports: http://github.com/haskell-servant/servant/issues
13−license: BSD3
13+license: BSD-3-Clause
14license-file: LICENSE
14license-file: LICENSE
15author: Servant Contributors
15author: Servant Contributors
16maintainer: haskell-servant-maintainers@googlegroups.com
16maintainer: haskell-servant-maintainers@googlegroups.com
@@ -23,7 +23,7 @@ extra-source-files:
23
23
24source-repository head
24source-repository head
25 type: git
25 type: git
26− location: http://github.com/haskell-servant/servant-machines.git
26+ location: http://github.com/haskell-servant/servant.git
27
27
28library
28library
29 exposed-modules: Servant.Machines
29 exposed-modules: Servant.Machines
@@ -32,7 +32,7 @@ library
32 , bytestring >=0.10.8.1 && <0.12
32 , bytestring >=0.10.8.1 && <0.12
33 , machines >=0.6.4 && <0.8
33 , machines >=0.6.4 && <0.8
34 , mtl >=2.2.2 && <2.3
34 , mtl >=2.2.2 && <2.3
35− , servant >=0.15 && <0.19
35+ , servant >=0.15 && <0.20
36 hs-source-dirs: src
36 hs-source-dirs: src
37 default-language: Haskell2010
37 default-language: Haskell2010
38 ghc-options: -Wall
38 ghc-options: -Wall
@@ -51,8 +51,8 @@ test-suite example
51 , servant
51 , servant
52 , machines
52 , machines
53 , servant-machines
53 , servant-machines
54− , servant-server >=0.15 && <0.19
54+ , servant-server >=0.15 && <0.20
55− , servant-client >=0.15 && <0.19
55+ , servant-client >=0.15 && <0.20
56 , wai >=3.2.1.2 && <3.3
56 , wai >=3.2.1.2 && <3.3
57 , warp >=3.2.25 && <3.4
57 , warp >=3.2.25 && <3.4
58 , http-client
58 , http-client
servant-pipes/servant-pipes.cabal+7−7
@@ -1,4 +1,4 @@
1−cabal-version: >=1.10
1+cabal-version: 2.2
2name: servant-pipes
2name: servant-pipes
3version: 0.15.3
3version: 0.15.3
4
4
@@ -10,7 +10,7 @@ description: Servant Stream support for pipes.
10
10
11homepage: http://docs.servant.dev/
11homepage: http://docs.servant.dev/
12bug-reports: http://github.com/haskell-servant/servant/issues
12bug-reports: http://github.com/haskell-servant/servant/issues
13−license: BSD3
13+license: BSD-3-Clause
14license-file: LICENSE
14license-file: LICENSE
15author: Servant Contributors
15author: Servant Contributors
16maintainer: haskell-servant-maintainers@googlegroups.com
16maintainer: haskell-servant-maintainers@googlegroups.com
@@ -23,7 +23,7 @@ extra-source-files:
23
23
24source-repository head
24source-repository head
25 type: git
25 type: git
26− location: http://github.com/haskell-servant/servant-pipes.git
26+ location: http://github.com/haskell-servant/servant.git
27
27
28library
28library
29 exposed-modules: Servant.Pipes
29 exposed-modules: Servant.Pipes
@@ -34,7 +34,7 @@ library
34 , pipes-safe >=2.3.1 && <2.4
34 , pipes-safe >=2.3.1 && <2.4
35 , mtl >=2.2.2 && <2.3
35 , mtl >=2.2.2 && <2.3
36 , monad-control >=1.0.2.3 && <1.1
36 , monad-control >=1.0.2.3 && <1.1
37− , servant >=0.15 && <0.19
37+ , servant >=0.15 && <0.20
38 hs-source-dirs: src
38 hs-source-dirs: src
39 default-language: Haskell2010
39 default-language: Haskell2010
40 ghc-options: -Wall
40 ghc-options: -Wall
@@ -51,12 +51,12 @@ test-suite example
51 , bytestring
51 , bytestring
52 , http-media
52 , http-media
53 , servant
53 , servant
54− , pipes
54+ , pipes
55 , pipes-safe
55 , pipes-safe
56 , servant-pipes
56 , servant-pipes
57 , pipes-bytestring >=2.1.6 && <2.2
57 , pipes-bytestring >=2.1.6 && <2.2
58− , servant-server >=0.15 && <0.19
58+ , servant-server >=0.15 && <0.20
59− , servant-client >=0.15 && <0.19
59+ , servant-client >=0.15 && <0.20
60 , wai >=3.2.1.2 && <3.3
60 , wai >=3.2.1.2 && <3.3
61 , warp >=3.2.25 && <3.4
61 , warp >=3.2.25 && <3.4
62 , http-client
62 , http-client
servant-server/CHANGELOG.md+24
@@ -1,6 +1,30 @@
1[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-server/CHANGELOG.md)
1[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-server/CHANGELOG.md)
2[Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)
2[Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)
3
3
4+Package versions follow the [Package Versioning Policy](https://pvp.haskell.org/): in A.B.C, bumps to either A or B represent major versions.
5+
6+0.19.1
7+------
8+
9+- Add `MonadFail` instance for `Handler` wrt [#1545](https://github.com/haskell-servant/servant/issues/1545)
10+- Support GHC 9.2 [#1525](https://github.com/haskell-servant/servant/issues/1525)
11+
12+0.19
13+----
14+
15+### Significant changes
16+
17+- Drop support for GHC < 8.6.
18+- Support GHC 9.0 (GHC 9.2 should work as well, but isn't fully tested yet).
19+- Support Aeson 2 ([#1475](https://github.com/haskell-servant/servant/pull/1475)),
20+ which fixes a [DOS vulnerability](https://github.com/haskell/aeson/issues/864)
21+ related to hash collisions.
22+- Add `NamedRoutes` combinator, making support for records first-class in Servant
23+ ([#1388](https://github.com/haskell-servant/servant/pull/1388)).
24+- Add custom type errors for partially applied combinators
25+ ([#1289](https://github.com/haskell-servant/servant/pull/1289),
26+ [#1486](https://github.com/haskell-servant/servant/pull/1486)).
27+
40.18.3
280.18.3
5------
29------
6
30
servant-server/example/greet.hs+16−2
@@ -1,5 +1,6 @@
1{-# LANGUAGE DataKinds #-}
1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DeriveGeneric #-}
2{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE RecordWildCards #-}
3{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE PolyKinds #-}
5{-# LANGUAGE PolyKinds #-}
5{-# LANGUAGE TypeFamilies #-}
6{-# LANGUAGE TypeFamilies #-}
@@ -16,6 +17,7 @@ import Network.Wai
16import Network.Wai.Handler.Warp
17import Network.Wai.Handler.Warp
17
18
18import Servant
19import Servant
20+import Servant.Server.Generic ()
19
21
20-- * Example
22-- * Example
21
23
@@ -38,6 +40,14 @@ type TestApi =
38 -- DELETE /greet/:greetid
40 -- DELETE /greet/:greetid
39 :<|> "greet" :> Capture "greetid" Text :> Delete '[JSON] NoContent
41 :<|> "greet" :> Capture "greetid" Text :> Delete '[JSON] NoContent
40
42
43+ :<|> NamedRoutes OtherRoutes
44+
45+data OtherRoutes mode = OtherRoutes
46+ { version :: mode :- Get '[JSON] Int
47+ , bye :: mode :- "bye" :> Capture "name" Text :> Get '[JSON] Text
48+ }
49+ deriving Generic
50+
41testApi :: Proxy TestApi
51testApi :: Proxy TestApi
42testApi = Proxy
52testApi = Proxy
43
53
@@ -48,9 +58,13 @@ testApi = Proxy
48--
58--
49-- Each handler runs in the 'Handler' monad.
59-- Each handler runs in the 'Handler' monad.
50server :: Server TestApi
60server :: Server TestApi
51−server = helloH :<|> postGreetH :<|> deleteGreetH
61+server = helloH :<|> postGreetH :<|> deleteGreetH :<|> otherRoutes
62+ where otherRoutes = OtherRoutes {..}
63+
64+ bye name = pure $ "Bye, " <> name <> " !"
65+ version = pure 42
52
66
53− where helloH name Nothing = helloH name (Just False)
67+ helloH name Nothing = helloH name (Just False)
54 helloH name (Just False) = return . Greet $ "Hello, " <> name
68 helloH name (Just False) = return . Greet $ "Hello, " <> name
55 helloH name (Just True) = return . Greet . toUpper $ "Hello, " <> name
69 helloH name (Just True) = return . Greet . toUpper $ "Hello, " <> name
56
70
servant-server/servant-server.cabal+12−11
@@ -1,6 +1,6 @@
1−cabal-version: >=1.10
1+cabal-version: 2.2
2name: servant-server
2name: servant-server
3−version: 0.18.3
3+version: 0.19.1
4
4
5synopsis: A family of combinators for defining webservices APIs and serving them
5synopsis: A family of combinators for defining webservices APIs and serving them
6category: Servant, Web
6category: Servant, Web
@@ -17,7 +17,7 @@ description:
17
17
18homepage: http://docs.servant.dev/
18homepage: http://docs.servant.dev/
19bug-reports: http://github.com/haskell-servant/servant/issues
19bug-reports: http://github.com/haskell-servant/servant/issues
20−license: BSD3
20+license: BSD-3-Clause
21license-file: LICENSE
21license-file: LICENSE
22author: Servant Contributors
22author: Servant Contributors
23maintainer: haskell-servant-maintainers@googlegroups.com
23maintainer: haskell-servant-maintainers@googlegroups.com
@@ -60,24 +60,25 @@ library
60 -- Bundled with GHC: Lower bound to not force re-installs
60 -- Bundled with GHC: Lower bound to not force re-installs
61 -- text and mtl are bundled starting with GHC-8.4
61 -- text and mtl are bundled starting with GHC-8.4
62 build-depends:
62 build-depends:
63− base >= 4.9 && < 4.16
63+ base >= 4.9 && < 4.17
64 , bytestring >= 0.10.8.1 && < 0.12
64 , bytestring >= 0.10.8.1 && < 0.12
65+ , constraints >= 0.2 && < 0.14
65 , containers >= 0.5.7.1 && < 0.7
66 , containers >= 0.5.7.1 && < 0.7
66 , mtl >= 2.2.2 && < 2.3
67 , mtl >= 2.2.2 && < 2.3
67− , text >= 1.2.3.0 && < 1.3
68+ , text >= 1.2.3.0 && < 2.1
68 , transformers >= 0.5.2.0 && < 0.6
69 , transformers >= 0.5.2.0 && < 0.6
69 , filepath >= 1.4.1.1 && < 1.5
70 , filepath >= 1.4.1.1 && < 1.5
70
71
71 -- Servant dependencies
72 -- Servant dependencies
72 -- strict dependency as we re-export 'servant' things.
73 -- strict dependency as we re-export 'servant' things.
73 build-depends:
74 build-depends:
74− servant >= 0.18.3 && < 0.18.4
75+ servant >= 0.19 && < 0.20
75 , http-api-data >= 0.4.1 && < 0.4.4
76 , http-api-data >= 0.4.1 && < 0.4.4
76
77
77 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.
78 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.
78 -- Here can be exceptions if we really need features from the newer versions.
79 -- Here can be exceptions if we really need features from the newer versions.
79 build-depends:
80 build-depends:
80− base-compat >= 0.10.5 && < 0.12
81+ base-compat >= 0.10.5 && < 0.13
81 , base64-bytestring >= 1.0.0.1 && < 1.3
82 , base64-bytestring >= 1.0.0.1 && < 1.3
82 , exceptions >= 0.10.0 && < 0.11
83 , exceptions >= 0.10.0 && < 0.11
83 , http-media >= 0.7.1.3 && < 0.9
84 , http-media >= 0.7.1.3 && < 0.9
@@ -113,7 +114,7 @@ executable greet
113 , text
114 , text
114
115
115 build-depends:
116 build-depends:
116− aeson >= 1.4.1.0 && < 1.6
117+ aeson >= 1.4.1.0 && < 3
117 , warp >= 3.2.25 && < 3.4
118 , warp >= 3.2.25 && < 3.4
118
119
119test-suite spec
120test-suite spec
@@ -156,9 +157,9 @@ test-suite spec
156
157
157 -- Additional dependencies
158 -- Additional dependencies
158 build-depends:
159 build-depends:
159− aeson >= 1.4.1.0 && < 1.6
160+ aeson >= 1.4.1.0 && < 3
160 , directory >= 1.3.0.0 && < 1.4
161 , directory >= 1.3.0.0 && < 1.4
161− , hspec >= 2.6.0 && < 2.9
162+ , hspec >= 2.6.0 && < 2.10
162 , hspec-wai >= 0.10.1 && < 0.12
163 , hspec-wai >= 0.10.1 && < 0.12
163 , QuickCheck >= 2.12.6.1 && < 2.15
164 , QuickCheck >= 2.12.6.1 && < 2.15
164 , should-not-typecheck >= 2.1.0 && < 2.2
165 , should-not-typecheck >= 2.1.0 && < 2.2
@@ -166,4 +167,4 @@ test-suite spec
166 , wai-extra >= 3.0.24.3 && < 3.2
167 , wai-extra >= 3.0.24.3 && < 3.2
167
168
168 build-tool-depends:
169 build-tool-depends:
169− hspec-discover:hspec-discover >= 2.6.0 && <2.9
170+ hspec-discover:hspec-discover >= 2.6.0 && <2.10
servant-server/src/Servant/Server.hs+3−2
@@ -235,7 +235,7 @@ hoistServer p = hoistServerWithContext p (Proxy :: Proxy '[])
235-- > │ └─ e/
235-- > │ └─ e/
236-- > │ └─•
236-- > │ └─•
237-- > ├─ b/
237-- > ├─ b/
238−-- > │ └─ <capture>/
238+-- > │ └─ <x::Int>/
239-- > │ ├─•
239-- > │ ├─•
240-- > │ ┆
240-- > │ ┆
241-- > │ └─•
241-- > │ └─•
@@ -252,7 +252,8 @@ hoistServer p = hoistServerWithContext p (Proxy :: Proxy '[])
252--
252--
253-- [@─•@] Leaves reflect endpoints.
253-- [@─•@] Leaves reflect endpoints.
254--
254--
255−-- [@\<capture\>/@] This is a delayed capture of a path component.
255+-- [@\<x::Int\>/@] This is a delayed capture of a single
256+-- path component named @x@, of expected type @Int@.
256--
257--
257-- [@\<raw\>@] This is a part of the API we do not know anything about.
258-- [@\<raw\>@] This is a part of the API we do not know anything about.
258--
259--
servant-server/src/Servant/Server/Generic.hs+11−18
@@ -1,12 +1,10 @@
1−{-# LANGUAGE ConstraintKinds #-}
2−{-# LANGUAGE DataKinds #-}
1+{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE FlexibleContexts #-}
4−{-# LANGUAGE KindSignatures #-}
5−{-# LANGUAGE RankNTypes #-}
3+{-# LANGUAGE RankNTypes #-}
6−{-# LANGUAGE ScopedTypeVariables #-}
4+{-# LANGUAGE ScopedTypeVariables #-}
7−{-# LANGUAGE TypeFamilies #-}
5+{-# LANGUAGE TypeFamilies #-}
8−{-# LANGUAGE TypeOperators #-}
6+{-# LANGUAGE TypeOperators #-}
9−{-# LANGUAGE UndecidableInstances #-}
7+
10-- | @since 0.14.1
8-- | @since 0.14.1
11module Servant.Server.Generic (
9module Servant.Server.Generic (
12 AsServerT,
10 AsServerT,
@@ -15,21 +13,15 @@ module Servant.Server.Generic (
15 genericServeT,
13 genericServeT,
16 genericServeTWithContext,
14 genericServeTWithContext,
17 genericServer,
15 genericServer,
18− genericServerT,
16+ genericServerT
19 ) where
17 ) where
20
18
21import Data.Proxy
19import Data.Proxy
22 (Proxy (..))
20 (Proxy (..))
23
21
24−import Servant.API.Generic
25import Servant.Server
22import Servant.Server
26−
23+import Servant.API.Generic
27−-- | A type that specifies that an API record contains a server implementation.
24+import Servant.Server.Internal
28−data AsServerT (m :: * -> *)
29−instance GenericMode (AsServerT m) where
30− type AsServerT m :- api = ServerT api m
31−
32−type AsServer = AsServerT Handler
33
25
34-- | Transform a record of routes into a WAI 'Application'.
26-- | Transform a record of routes into a WAI 'Application'.
35genericServe
27genericServe
@@ -97,3 +89,4 @@ genericServerT
97 => routes (AsServerT m)
89 => routes (AsServerT m)
98 -> ToServant routes (AsServerT m)
90 -> ToServant routes (AsServerT m)
99genericServerT = toServant
91genericServerT = toServant
92+
servant-server/src/Servant/Server/Internal.hs+107−53
@@ -1,23 +1,22 @@
1−{-# LANGUAGE CPP #-}
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE ConstraintKinds #-}
3{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE DataKinds #-}
4{-# LANGUAGE DeriveDataTypeable #-}
4{-# LANGUAGE DeriveDataTypeable #-}
5{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE FlexibleContexts #-}
6{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE FlexibleInstances #-}
7+{-# LANGUAGE InstanceSigs #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE OverloadedStrings #-}
9{-# LANGUAGE OverloadedStrings #-}
9{-# LANGUAGE PolyKinds #-}
10{-# LANGUAGE PolyKinds #-}
11+{-# LANGUAGE QuantifiedConstraints #-}
10{-# LANGUAGE RankNTypes #-}
12{-# LANGUAGE RankNTypes #-}
11{-# LANGUAGE ScopedTypeVariables #-}
13{-# LANGUAGE ScopedTypeVariables #-}
12{-# LANGUAGE TupleSections #-}
14{-# LANGUAGE TupleSections #-}
15+{-# LANGUAGE TypeApplications #-}
13{-# LANGUAGE TypeFamilies #-}
16{-# LANGUAGE TypeFamilies #-}
14{-# LANGUAGE TypeOperators #-}
17{-# LANGUAGE TypeOperators #-}
15{-# LANGUAGE UndecidableInstances #-}
18{-# LANGUAGE UndecidableInstances #-}
16
19
17−#if MIN_VERSION_base(4,9,0) && __GLASGOW_HASKELL__ >= 802
18−#define HAS_TYPE_ERROR
19−#endif
20−
21module Servant.Server.Internal
20module Servant.Server.Internal
22 ( module Servant.Server.Internal
21 ( module Servant.Server.Internal
23 , module Servant.Server.Internal.BasicAuth
22 , module Servant.Server.Internal.BasicAuth
@@ -42,6 +41,7 @@ import qualified Data.ByteString as B
42import qualified Data.ByteString.Builder as BB
41import qualified Data.ByteString.Builder as BB
43import qualified Data.ByteString.Char8 as BC8
42import qualified Data.ByteString.Char8 as BC8
44import qualified Data.ByteString.Lazy as BL
43import qualified Data.ByteString.Lazy as BL
44+import Data.Constraint (Constraint, Dict(..))
45import Data.Either
45import Data.Either
46 (partitionEithers)
46 (partitionEithers)
47import Data.Maybe
47import Data.Maybe
@@ -54,8 +54,9 @@ import Data.Tagged
54 (Tagged (..), retag, untag)
54 (Tagged (..), retag, untag)
55import qualified Data.Text as T
55import qualified Data.Text as T
56import Data.Typeable
56import Data.Typeable
57+import GHC.Generics
57import GHC.TypeLits
58import GHC.TypeLits
58− (KnownNat, KnownSymbol, natVal, symbolVal)
59+ (KnownNat, KnownSymbol, TypeError, symbolVal)
59import qualified Network.HTTP.Media as NHM
60import qualified Network.HTTP.Media as NHM
60import Network.HTTP.Types hiding
61import Network.HTTP.Types hiding
61 (Header, ResponseHeaders)
62 (Header, ResponseHeaders)
@@ -75,7 +76,8 @@ import Servant.API
75 QueryParam', QueryParams, Raw, ReflectMethod (reflectMethod),
76 QueryParam', QueryParams, Raw, ReflectMethod (reflectMethod),
76 RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO,
77 RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO,
77 Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb,
78 Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb,
78− WithNamedContext)
79+ WithNamedContext, NamedRoutes)
80+import Servant.API.Generic (GenericMode(..), ToServant, ToServantApi, GServantProduct, toServant, fromServant)
79import Servant.API.ContentTypes
81import Servant.API.ContentTypes
80 (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),
82 (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),
81 AllMime, MimeRender (..), MimeUnrender (..), NoContent,
83 AllMime, MimeRender (..), MimeUnrender (..), NoContent,
@@ -85,7 +87,10 @@ import Servant.API.Modifiers
85 unfoldRequestArgument)
87 unfoldRequestArgument)
86import Servant.API.ResponseHeaders
88import Servant.API.ResponseHeaders
87 (GetHeaders, Headers, getHeaders, getResponse)
89 (GetHeaders, Headers, getHeaders, getResponse)
90+import Servant.API.Status
91+ (statusFromNat)
88import qualified Servant.Types.SourceT as S
92import qualified Servant.Types.SourceT as S
93+import Servant.API.TypeErrors
89import Web.HttpApiData
94import Web.HttpApiData
90 (FromHttpApiData, parseHeader, parseQueryParam, parseUrlPiece,
95 (FromHttpApiData, parseHeader, parseQueryParam, parseUrlPiece,
91 parseUrlPieces)
96 parseUrlPieces)
@@ -101,12 +106,10 @@ import Servant.Server.Internal.RouteResult
101import Servant.Server.Internal.RoutingApplication
106import Servant.Server.Internal.RoutingApplication
102import Servant.Server.Internal.ServerError
107import Servant.Server.Internal.ServerError
103
108
104−#ifdef HAS_TYPE_ERROR
105import GHC.TypeLits
109import GHC.TypeLits
106 (ErrorMessage (..), TypeError)
110 (ErrorMessage (..), TypeError)
107import Servant.API.TypeLevel
111import Servant.API.TypeLevel
108 (AtLeastOneFragment, FragmentUnique)
112 (AtLeastOneFragment, FragmentUnique)
109−#endif
110
113
111class HasServer api context where
114class HasServer api context where
112 type ServerT api (m :: * -> *) :: *
115 type ServerT api (m :: * -> *) :: *
@@ -170,7 +173,7 @@ instance (HasServer a context, HasServer b context) => HasServer (a :<|> b) cont
170-- > server = getBook
173-- > server = getBook
171-- > where getBook :: Text -> Handler Book
174-- > where getBook :: Text -> Handler Book
172-- > getBook isbn = ...
175-- > getBook isbn = ...
173−instance (KnownSymbol capture, FromHttpApiData a
176+instance (KnownSymbol capture, FromHttpApiData a, Typeable a
174 , HasServer api context, SBoolI (FoldLenient mods)
177 , HasServer api context, SBoolI (FoldLenient mods)
175 , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
178 , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
176 )
179 )
@@ -182,7 +185,7 @@ instance (KnownSymbol capture, FromHttpApiData a
182 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
185 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
183
186
184 route Proxy context d =
187 route Proxy context d =
185− CaptureRouter $
188+ CaptureRouter [hint] $
186 route (Proxy :: Proxy api)
189 route (Proxy :: Proxy api)
187 context
190 context
188 (addCapture d $ \ txt -> withRequest $ \ request ->
191 (addCapture d $ \ txt -> withRequest $ \ request ->
@@ -194,6 +197,7 @@ instance (KnownSymbol capture, FromHttpApiData a
194 where
197 where
195 rep = typeRep (Proxy :: Proxy Capture')
198 rep = typeRep (Proxy :: Proxy Capture')
196 formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
199 formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
200+ hint = CaptureHint (T.pack $ symbolVal $ Proxy @capture) (typeRep (Proxy :: Proxy a))
197
201
198-- | If you use 'CaptureAll' in one of the endpoints for your API,
202-- | If you use 'CaptureAll' in one of the endpoints for your API,
199-- this automatically requires your server-side handler to be a
203-- this automatically requires your server-side handler to be a
@@ -212,7 +216,7 @@ instance (KnownSymbol capture, FromHttpApiData a
212-- > server = getSourceFile
216-- > server = getSourceFile
213-- > where getSourceFile :: [Text] -> Handler Book
217-- > where getSourceFile :: [Text] -> Handler Book
214-- > getSourceFile pathSegments = ...
218-- > getSourceFile pathSegments = ...
215−instance (KnownSymbol capture, FromHttpApiData a
219+instance (KnownSymbol capture, FromHttpApiData a, Typeable a
216 , HasServer api context
220 , HasServer api context
217 , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
221 , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
218 )
222 )
@@ -224,7 +228,7 @@ instance (KnownSymbol capture, FromHttpApiData a
224 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
228 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
225
229
226 route Proxy context d =
230 route Proxy context d =
227− CaptureAllRouter $
231+ CaptureAllRouter [hint] $
228 route (Proxy :: Proxy api)
232 route (Proxy :: Proxy api)
229 context
233 context
230 (addCapture d $ \ txts -> withRequest $ \ request ->
234 (addCapture d $ \ txts -> withRequest $ \ request ->
@@ -235,6 +239,7 @@ instance (KnownSymbol capture, FromHttpApiData a
235 where
239 where
236 rep = typeRep (Proxy :: Proxy CaptureAll)
240 rep = typeRep (Proxy :: Proxy CaptureAll)
237 formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
241 formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
242+ hint = CaptureHint (T.pack $ symbolVal $ Proxy @capture) (typeRep (Proxy :: Proxy [a]))
238
243
239allowedMethodHead :: Method -> Request -> Bool
244allowedMethodHead :: Method -> Request -> Bool
240allowedMethodHead method request = method == methodGet && requestMethod request == methodHead
245allowedMethodHead method request = method == methodGet && requestMethod request == methodHead
@@ -298,7 +303,7 @@ instance {-# OVERLAPPABLE #-}
298
303
299 route Proxy _ = methodRouter ([],) method (Proxy :: Proxy ctypes) status
304 route Proxy _ = methodRouter ([],) method (Proxy :: Proxy ctypes) status
300 where method = reflectMethod (Proxy :: Proxy method)
305 where method = reflectMethod (Proxy :: Proxy method)
301− status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
306+ status = statusFromNat (Proxy :: Proxy status)
302
307
303instance {-# OVERLAPPING #-}
308instance {-# OVERLAPPING #-}
304 ( AllCTRender ctypes a, ReflectMethod method, KnownNat status
309 ( AllCTRender ctypes a, ReflectMethod method, KnownNat status
@@ -310,7 +315,7 @@ instance {-# OVERLAPPING #-}
310
315
311 route Proxy _ = methodRouter (\x -> (getHeaders x, getResponse x)) method (Proxy :: Proxy ctypes) status
316 route Proxy _ = methodRouter (\x -> (getHeaders x, getResponse x)) method (Proxy :: Proxy ctypes) status
312 where method = reflectMethod (Proxy :: Proxy method)
317 where method = reflectMethod (Proxy :: Proxy method)
313− status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
318+ status = statusFromNat (Proxy :: Proxy status)
314
319
315instance (ReflectMethod method) =>
320instance (ReflectMethod method) =>
316 HasServer (NoContentVerb method) context where
321 HasServer (NoContentVerb method) context where
@@ -331,7 +336,7 @@ instance {-# OVERLAPPABLE #-}
331
336
332 route Proxy _ = streamRouter ([],) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)
337 route Proxy _ = streamRouter ([],) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)
333 where method = reflectMethod (Proxy :: Proxy method)
338 where method = reflectMethod (Proxy :: Proxy method)
334− status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
339+ status = statusFromNat (Proxy :: Proxy status)
335
340
336
341
337instance {-# OVERLAPPING #-}
342instance {-# OVERLAPPING #-}
@@ -345,7 +350,7 @@ instance {-# OVERLAPPING #-}
345
350
346 route Proxy _ = streamRouter (\x -> (getHeaders x, getResponse x)) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)
351 route Proxy _ = streamRouter (\x -> (getHeaders x, getResponse x)) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)
347 where method = reflectMethod (Proxy :: Proxy method)
352 where method = reflectMethod (Proxy :: Proxy method)
348− status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
353+ status = statusFromNat (Proxy :: Proxy status)
349
354
350
355
351streamRouter :: forall ctype a c chunk env framing. (MimeRender ctype chunk, FramingRender framing, ToSourceIO chunk a) =>
356streamRouter :: forall ctype a c chunk env framing. (MimeRender ctype chunk, FramingRender framing, ToSourceIO chunk a) =>
@@ -784,7 +789,7 @@ instance ( KnownSymbol realm
784-- * helpers
789-- * helpers
785
790
786ct_wildcard :: B.ByteString
791ct_wildcard :: B.ByteString
787−ct_wildcard = "*" <> "/" <> "*" -- Because CPP
792+ct_wildcard = "*" <> "/" <> "*"
788
793
789getAcceptHeader :: Request -> AcceptHeader
794getAcceptHeader :: Request -> AcceptHeader
790getAcceptHeader = AcceptHeader . fromMaybe ct_wildcard . lookup hAccept . requestHeaders
795getAcceptHeader = AcceptHeader . fromMaybe ct_wildcard . lookup hAccept . requestHeaders
@@ -812,39 +817,15 @@ instance (HasContextEntry context (NamedContext name subContext), HasServer subA
812 hoistServerWithContext _ _ nt s = hoistServerWithContext (Proxy :: Proxy subApi) (Proxy :: Proxy subContext) nt s
817 hoistServerWithContext _ _ nt s = hoistServerWithContext (Proxy :: Proxy subApi) (Proxy :: Proxy subContext) nt s
813
818
814-------------------------------------------------------------------------------
819-------------------------------------------------------------------------------
815−-- TypeError helpers
820+-- Custom type errors
816-------------------------------------------------------------------------------
821-------------------------------------------------------------------------------
817
822
818−#ifdef HAS_TYPE_ERROR
823+-- Erroring instance for 'HasServer' when a combinator is not fully applied
819−-- | This instance catches mistakes when there are non-saturated
820−-- type applications on LHS of ':>'.
821−--
822−-- >>> serve (Proxy :: Proxy (Capture "foo" :> Get '[JSON] Int)) (error "...")
823−-- ...
824−-- ...Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'.
825−-- ...Maybe you haven't applied enough arguments to
826−-- ...Capture' '[] "foo"
827−-- ...
828−--
829−-- >>> undefined :: Server (Capture "foo" :> Get '[JSON] Int)
830−-- ...
831−-- ...Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'.
832−-- ...Maybe you haven't applied enough arguments to
833−-- ...Capture' '[] "foo"
834−-- ...
835−--
836−instance TypeError (HasServerArrowKindError arr) => HasServer ((arr :: k -> l) :> api) context
824+instance TypeError (PartialApplication HasServer arr) => HasServer ((arr :: a -> b) :> sub) context
837 where
825 where
838− type ServerT (arr :> api) m = TypeError (HasServerArrowKindError arr)
826+ type ServerT (arr :> sub) _ = TypeError (PartialApplication (HasServer :: * -> [*] -> Constraint) arr)
839− -- it doesn't really matter what sub route we peak
827+ route = error "unreachable"
840− route _ _ _ = error "servant-server panic: impossible happened in HasServer (arr :> api)"
841− hoistServerWithContext _ _ _ = id
828+ hoistServerWithContext _ _ _ _ = error "unreachable"
842−
843−-- Cannot have TypeError here, otherwise use of this symbol will error :)
844−type HasServerArrowKindError arr =
845− 'Text "Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'."
846− ':$$: 'Text "Maybe you haven't applied enough arguments to"
847− ':$$: 'ShowType arr
848
829
849-- | This instance prevents from accidentally using '->' instead of ':>'
830-- | This instance prevents from accidentally using '->' instead of ':>'
850--
831--
@@ -878,7 +859,15 @@ type HasServerArrowTypeError a b =
878 ':$$: 'ShowType a
859 ':$$: 'ShowType a
879 ':$$: 'Text "and"
860 ':$$: 'Text "and"
880 ':$$: 'ShowType b
861 ':$$: 'ShowType b
881−#endif
862+
863+-- Erroring instances for 'HasServer' for unknown API combinators
864+
865+-- XXX: This omits the @context@ parameter, e.g.:
866+--
867+-- "There is no instance for HasServer (Bool :> …)". Do we care ?
868+instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub HasServer ty) => HasServer (ty :> sub) context
869+
870+instance {-# OVERLAPPABLE #-} TypeError (NoInstanceFor (HasServer api context)) => HasServer api context
882
871
883-- | Ignore @'Fragment'@ in server handlers.
872-- | Ignore @'Fragment'@ in server handlers.
884-- See <https://ietf.org/rfc/rfc2616.html#section-15.1.3> for more details.
873-- See <https://ietf.org/rfc/rfc2616.html#section-15.1.3> for more details.
@@ -891,11 +880,7 @@ type HasServerArrowTypeError a b =
891-- > server = getBooks
880-- > server = getBooks
892-- > where getBooks :: Handler [Book]
881-- > where getBooks :: Handler [Book]
893-- > getBooks = ...return all books...
882-- > getBooks = ...return all books...
894−#ifdef HAS_TYPE_ERROR
895instance (AtLeastOneFragment api, FragmentUnique (Fragment a1 :> api), HasServer api context)
883instance (AtLeastOneFragment api, FragmentUnique (Fragment a1 :> api), HasServer api context)
896−#else
897−instance (HasServer api context)
898−#endif
899 => HasServer (Fragment a1 :> api) context where
884 => HasServer (Fragment a1 :> api) context where
900 type ServerT (Fragment a1 :> api) m = ServerT api m
885 type ServerT (Fragment a1 :> api) m = ServerT api m
901
886
@@ -905,3 +890,72 @@ instance (HasServer api context)
905
890
906-- $setup
891-- $setup
907-- >>> import Servant
892-- >>> import Servant
893+
894+-- | A type that specifies that an API record contains a server implementation.
895+data AsServerT (m :: * -> *)
896+instance GenericMode (AsServerT m) where
897+ type AsServerT m :- api = ServerT api m
898+
899+type AsServer = AsServerT Handler
900+
901+
902+-- | Set of constraints required to convert to / from vanilla server types.
903+type GServerConstraints api m =
904+ ( ToServant api (AsServerT m) ~ ServerT (ToServantApi api) m
905+ , GServantProduct (Rep (api (AsServerT m)))
906+ )
907+
908+-- | This class is a necessary evil: in the implementation of 'HasServer' for
909+-- @'NamedRoutes' api@, we essentially need the quantified constraint @forall
910+-- m. 'GServerConstraints' m@ to hold.
911+--
912+-- We cannot require do that directly as the definition of 'GServerConstraints'
913+-- contains type family applications ('Rep' and 'ServerT'). The trick is to hide
914+-- those type family applications behind a typeclass providing evidence for
915+-- @'GServerConstraints' api m@ in the form of a dictionary, and require that
916+-- @forall m. 'GServer' api m@ instead.
917+--
918+-- Users shouldn't have to worry about this class, as the only possible instance
919+-- is provided in this module for all record APIs.
920+
921+class GServer (api :: * -> *) (m :: * -> *) where
922+ gServerProof :: Dict (GServerConstraints api m)
923+
924+instance
925+ ( ToServant api (AsServerT m) ~ ServerT (ToServantApi api) m
926+ , GServantProduct (Rep (api (AsServerT m)))
927+ ) => GServer api m where
928+ gServerProof = Dict
929+
930+instance
931+ ( HasServer (ToServantApi api) context
932+ , forall m. Generic (api (AsServerT m))
933+ , forall m. GServer api m
934+ ) => HasServer (NamedRoutes api) context where
935+
936+ type ServerT (NamedRoutes api) m = api (AsServerT m)
937+
938+ route
939+ :: Proxy (NamedRoutes api)
940+ -> Context context
941+ -> Delayed env (api (AsServerT Handler))
942+ -> Router env
943+ route _ ctx delayed =
944+ case gServerProof @api @Handler of
945+ Dict -> route (Proxy @(ToServantApi api)) ctx (toServant <$> delayed)
946+
947+ hoistServerWithContext
948+ :: forall m n. Proxy (NamedRoutes api)
949+ -> Proxy context
950+ -> (forall x. m x -> n x)
951+ -> api (AsServerT m)
952+ -> api (AsServerT n)
953+ hoistServerWithContext _ pctx nat server =
954+ case (gServerProof @api @m, gServerProof @api @n) of
955+ (Dict, Dict) ->
956+ fromServant servantSrvN
957+ where
958+ servantSrvM :: ServerT (ToServantApi api) m =
959+ toServant server
960+ servantSrvN :: ServerT (ToServantApi api) n =
961+ hoistServerWithContext (Proxy @(ToServantApi api)) pctx nat servantSrvM
servant-server/src/Servant/Server/Internal/Handler.hs+7−2
@@ -13,17 +13,19 @@ import Control.Monad.Base
13import Control.Monad.Catch
13import Control.Monad.Catch
14 (MonadCatch, MonadMask, MonadThrow)
14 (MonadCatch, MonadMask, MonadThrow)
15import Control.Monad.Error.Class
15import Control.Monad.Error.Class
16− (MonadError)
16+ (MonadError, throwError)
17import Control.Monad.IO.Class
17import Control.Monad.IO.Class
18 (MonadIO)
18 (MonadIO)
19import Control.Monad.Trans.Control
19import Control.Monad.Trans.Control
20 (MonadBaseControl (..))
20 (MonadBaseControl (..))
21import Control.Monad.Trans.Except
21import Control.Monad.Trans.Except
22 (ExceptT, runExceptT)
22 (ExceptT, runExceptT)
23+import Data.String
24+ (fromString)
23import GHC.Generics
25import GHC.Generics
24 (Generic)
26 (Generic)
25import Servant.Server.Internal.ServerError
27import Servant.Server.Internal.ServerError
26− (ServerError)
28+ (ServerError, errBody, err500)
27
29
28newtype Handler a = Handler { runHandler' :: ExceptT ServerError IO a }
30newtype Handler a = Handler { runHandler' :: ExceptT ServerError IO a }
29 deriving
31 deriving
@@ -32,6 +34,9 @@ newtype Handler a = Handler { runHandler' :: ExceptT ServerError IO a }
32 , MonadThrow, MonadCatch, MonadMask
34 , MonadThrow, MonadCatch, MonadMask
33 )
35 )
34
36
37+instance MonadFail Handler where
38+ fail str = throwError err500 { errBody = fromString str }
39+
35instance MonadBase IO Handler where
40instance MonadBase IO Handler where
36 liftBase = Handler . liftBase
41 liftBase = Handler . liftBase
37
42
servant-server/src/Servant/Server/Internal/Router.hs+31−14
@@ -9,12 +9,16 @@ import Prelude.Compat
9
9
10import Data.Function
10import Data.Function
11 (on)
11 (on)
12+import Data.List
13+ (nub)
12import Data.Map
14import Data.Map
13 (Map)
15 (Map)
14import qualified Data.Map as M
16import qualified Data.Map as M
15import Data.Text
17import Data.Text
16 (Text)
18 (Text)
17import qualified Data.Text as T
19import qualified Data.Text as T
20+import Data.Typeable
21+ (TypeRep)
18import Network.Wai
22import Network.Wai
19 (Response, pathInfo)
23 (Response, pathInfo)
20import Servant.Server.Internal.ErrorFormatter
24import Servant.Server.Internal.ErrorFormatter
@@ -24,6 +28,18 @@ import Servant.Server.Internal.ServerError
24
28
25type Router env = Router' env RoutingApplication
29type Router env = Router' env RoutingApplication
26
30
31+data CaptureHint = CaptureHint
32+ { captureName :: Text
33+ , captureType :: TypeRep
34+ }
35+ deriving (Show, Eq)
36+
37+toCaptureTag :: CaptureHint -> Text
38+toCaptureTag hint = captureName hint <> "::" <> (T.pack . show) (captureType hint)
39+
40+toCaptureTags :: [CaptureHint] -> Text
41+toCaptureTags hints = "<" <> T.intercalate "|" (map toCaptureTag hints) <> ">"
42+
27-- | Internal representation of a router.
43-- | Internal representation of a router.
28--
44--
29-- The first argument describes an environment type that is
45-- The first argument describes an environment type that is
@@ -36,10 +52,10 @@ data Router' env a =
36 -- ^ the map contains routers for subpaths (first path component used
52 -- ^ the map contains routers for subpaths (first path component used
37 -- for lookup and removed afterwards), the list contains handlers
53 -- for lookup and removed afterwards), the list contains handlers
38 -- for the empty path, to be tried in order
54 -- for the empty path, to be tried in order
39− | CaptureRouter (Router' (Text, env) a)
55+ | CaptureRouter [CaptureHint] (Router' (Text, env) a)
40 -- ^ first path component is passed to the child router in its
56 -- ^ first path component is passed to the child router in its
41 -- environment and removed afterwards
57 -- environment and removed afterwards
42− | CaptureAllRouter (Router' ([Text], env) a)
58+ | CaptureAllRouter [CaptureHint] (Router' ([Text], env) a)
43 -- ^ all path components are passed to the child router in its
59 -- ^ all path components are passed to the child router in its
44 -- environment and are removed afterwards
60 -- environment and are removed afterwards
45 | RawRouter (env -> a)
61 | RawRouter (env -> a)
@@ -69,8 +85,8 @@ leafRouter l = StaticRouter M.empty [l]
69choice :: Router' env a -> Router' env a -> Router' env a
85choice :: Router' env a -> Router' env a -> Router' env a
70choice (StaticRouter table1 ls1) (StaticRouter table2 ls2) =
86choice (StaticRouter table1 ls1) (StaticRouter table2 ls2) =
71 StaticRouter (M.unionWith choice table1 table2) (ls1 ++ ls2)
87 StaticRouter (M.unionWith choice table1 table2) (ls1 ++ ls2)
72−choice (CaptureRouter router1) (CaptureRouter router2) =
88+choice (CaptureRouter hints1 router1) (CaptureRouter hints2 router2) =
73− CaptureRouter (choice router1 router2)
89+ CaptureRouter (nub $ hints1 ++ hints2) (choice router1 router2)
74choice router1 (Choice router2 router3) = Choice (choice router1 router2) router3
90choice router1 (Choice router2 router3) = Choice (choice router1 router2) router3
75choice router1 router2 = Choice router1 router2
91choice router1 router2 = Choice router1 router2
76
92
@@ -84,7 +100,7 @@ choice router1 router2 = Choice router1 router2
84--
100--
85data RouterStructure =
101data RouterStructure =
86 StaticRouterStructure (Map Text RouterStructure) Int
102 StaticRouterStructure (Map Text RouterStructure) Int
87− | CaptureRouterStructure RouterStructure
103+ | CaptureRouterStructure [CaptureHint] RouterStructure
88 | RawRouterStructure
104 | RawRouterStructure
89 | ChoiceStructure RouterStructure RouterStructure
105 | ChoiceStructure RouterStructure RouterStructure
90 deriving (Eq, Show)
106 deriving (Eq, Show)
@@ -98,11 +114,11 @@ data RouterStructure =
98routerStructure :: Router' env a -> RouterStructure
114routerStructure :: Router' env a -> RouterStructure
99routerStructure (StaticRouter m ls) =
115routerStructure (StaticRouter m ls) =
100 StaticRouterStructure (fmap routerStructure m) (length ls)
116 StaticRouterStructure (fmap routerStructure m) (length ls)
101−routerStructure (CaptureRouter router) =
117+routerStructure (CaptureRouter hints router) =
102− CaptureRouterStructure $
118+ CaptureRouterStructure hints $
103 routerStructure router
119 routerStructure router
104−routerStructure (CaptureAllRouter router) =
120+routerStructure (CaptureAllRouter hints router) =
105− CaptureRouterStructure $
121+ CaptureRouterStructure hints $
106 routerStructure router
122 routerStructure router
107routerStructure (RawRouter _) =
123routerStructure (RawRouter _) =
108 RawRouterStructure
124 RawRouterStructure
@@ -114,8 +130,8 @@ routerStructure (Choice r1 r2) =
114-- | Compare the structure of two routers.
130-- | Compare the structure of two routers.
115--
131--
116sameStructure :: Router' env a -> Router' env b -> Bool
132sameStructure :: Router' env a -> Router' env b -> Bool
117−sameStructure r1 r2 =
133+sameStructure router1 router2 =
118− routerStructure r1 == routerStructure r2
134+ routerStructure router1 == routerStructure router2
119
135
120-- | Provide a textual representation of the
136-- | Provide a textual representation of the
121-- structure of a router.
137-- structure of a router.
@@ -126,7 +142,8 @@ routerLayout router =
126 where
142 where
127 mkRouterLayout :: Bool -> RouterStructure -> [Text]
143 mkRouterLayout :: Bool -> RouterStructure -> [Text]
128 mkRouterLayout c (StaticRouterStructure m n) = mkSubTrees c (M.toList m) n
144 mkRouterLayout c (StaticRouterStructure m n) = mkSubTrees c (M.toList m) n
129− mkRouterLayout c (CaptureRouterStructure r) = mkSubTree c "<capture>" (mkRouterLayout False r)
145+ mkRouterLayout c (CaptureRouterStructure hints r) =
146+ mkSubTree c (toCaptureTags hints) (mkRouterLayout False r)
130 mkRouterLayout c RawRouterStructure =
147 mkRouterLayout c RawRouterStructure =
131 if c then ["├─ <raw>"] else ["└─ <raw>"]
148 if c then ["├─ <raw>"] else ["└─ <raw>"]
132 mkRouterLayout c (ChoiceStructure r1 r2) =
149 mkRouterLayout c (ChoiceStructure r1 r2) =
@@ -169,7 +186,7 @@ runRouterEnv fmt router env request respond =
169 -> let request' = request { pathInfo = rest }
186 -> let request' = request { pathInfo = rest }
170 in runRouterEnv fmt router' env request' respond
187 in runRouterEnv fmt router' env request' respond
171 _ -> respond $ Fail $ fmt request
188 _ -> respond $ Fail $ fmt request
172− CaptureRouter router' ->
189+ CaptureRouter _ router' ->
173 case pathInfo request of
190 case pathInfo request of
174 [] -> respond $ Fail $ fmt request
191 [] -> respond $ Fail $ fmt request
175 -- This case is to handle trailing slashes.
192 -- This case is to handle trailing slashes.
@@ -177,7 +194,7 @@ runRouterEnv fmt router env request respond =
177 first : rest
194 first : rest
178 -> let request' = request { pathInfo = rest }
195 -> let request' = request { pathInfo = rest }
179 in runRouterEnv fmt router' (first, env) request' respond
196 in runRouterEnv fmt router' (first, env) request' respond
180− CaptureAllRouter router' ->
197+ CaptureAllRouter _ router' ->
181 let segments = pathInfo request
198 let segments = pathInfo request
182 request' = request { pathInfo = [] }
199 request' = request { pathInfo = [] }
183 in runRouterEnv fmt router' (segments, env) request' respond
200 in runRouterEnv fmt router' (segments, env) request' respond
servant-server/src/Servant/Server/Internal/ServerError.hs+1−1
@@ -187,7 +187,7 @@ err403 = ServerError { errHTTPCode = 403
187-- Example:
187-- Example:
188--
188--
189-- > failingHandler :: Handler ()
189-- > failingHandler :: Handler ()
190−-- > failingHandler = throwError $ err404 { errBody = "(╯°□°)╯︵ ┻━┻)." }
190+-- > failingHandler = throwError $ err404 { errBody = "Are you lost?" }
191--
191--
192err404 :: ServerError
192err404 :: ServerError
193err404 = ServerError { errHTTPCode = 404
193err404 = ServerError { errHTTPCode = 404
servant-server/test/Servant/Server/RouterSpec.hs+127−6
@@ -9,7 +9,9 @@ import Control.Monad
9import Data.Proxy
9import Data.Proxy
10 (Proxy (..))
10 (Proxy (..))
11import Data.Text
11import Data.Text
12− (unpack)
12+ (Text, unpack)
13+import Data.Typeable
14+ (typeRep)
13import Network.HTTP.Types
15import Network.HTTP.Types
14 (Status (..))
16 (Status (..))
15import Network.Wai
17import Network.Wai
@@ -27,6 +29,7 @@ spec :: Spec
27spec = describe "Servant.Server.Internal.Router" $ do
29spec = describe "Servant.Server.Internal.Router" $ do
28 routerSpec
30 routerSpec
29 distributivitySpec
31 distributivitySpec
32+ serverLayoutSpec
30
33
31routerSpec :: Spec
34routerSpec :: Spec
32routerSpec = do
35routerSpec = do
@@ -51,7 +54,7 @@ routerSpec = do
51 toApp = toApplication . runRouter (const err404)
54 toApp = toApplication . runRouter (const err404)
52
55
53 cap :: Router ()
56 cap :: Router ()
54− cap = CaptureRouter $
57+ cap = CaptureRouter [hint] $
55 let delayed = addCapture (emptyDelayed $ Route pure) (const $ delayedFail err400)
58 let delayed = addCapture (emptyDelayed $ Route pure) (const $ delayedFail err400)
56 in leafRouter
59 in leafRouter
57 $ \env req res ->
60 $ \env req res ->
@@ -59,6 +62,9 @@ routerSpec = do
59 . const
62 . const
60 $ Route success
63 $ Route success
61
64
65+ hint :: CaptureHint
66+ hint = CaptureHint "anything" $ typeRep (Proxy :: Proxy ())
67+
62 router :: Router ()
68 router :: Router ()
63 router = leafRouter (\_ _ res -> res $ Route success)
69 router = leafRouter (\_ _ res -> res $ Route success)
64 `Choice` cap
70 `Choice` cap
@@ -98,12 +104,30 @@ distributivitySpec =
98 it "properly handles mixing static paths at different levels" $ do
104 it "properly handles mixing static paths at different levels" $ do
99 level `shouldHaveSameStructureAs` levelRef
105 level `shouldHaveSameStructureAs` levelRef
100
106
107+serverLayoutSpec :: Spec
108+serverLayoutSpec =
109+ describe "serverLayout" $ do
110+ it "correctly represents the example API" $ do
111+ exampleLayout `shouldHaveLayout` expectedExampleLayout
112+ it "aggregates capture hints when different" $ do
113+ captureDifferentTypes `shouldHaveLayout` expectedCaptureDifferentTypes
114+ it "nubs capture hints when equal" $ do
115+ captureSameType `shouldHaveLayout` expectedCaptureSameType
116+ it "properly displays CaptureAll hints" $ do
117+ captureAllLayout `shouldHaveLayout` expectedCaptureAllLayout
118+
101shouldHaveSameStructureAs ::
119shouldHaveSameStructureAs ::
102 (HasServer api1 '[], HasServer api2 '[]) => Proxy api1 -> Proxy api2 -> Expectation
120 (HasServer api1 '[], HasServer api2 '[]) => Proxy api1 -> Proxy api2 -> Expectation
103shouldHaveSameStructureAs p1 p2 =
121shouldHaveSameStructureAs p1 p2 =
104 unless (sameStructure (makeTrivialRouter p1) (makeTrivialRouter p2)) $
122 unless (sameStructure (makeTrivialRouter p1) (makeTrivialRouter p2)) $
105 expectationFailure ("expected:\n" ++ unpack (layout p2) ++ "\nbut got:\n" ++ unpack (layout p1))
123 expectationFailure ("expected:\n" ++ unpack (layout p2) ++ "\nbut got:\n" ++ unpack (layout p1))
106
124
125+shouldHaveLayout ::
126+ (HasServer api '[]) => Proxy api -> Text -> Expectation
127+shouldHaveLayout p l =
128+ unless (routerLayout (makeTrivialRouter p) == l) $
129+ expectationFailure ("expected:\n" ++ unpack l ++ "\nbut got:\n" ++ unpack (layout p))
130+
107makeTrivialRouter :: (HasServer layout '[]) => Proxy layout -> Router ()
131makeTrivialRouter :: (HasServer layout '[]) => Proxy layout -> Router ()
108makeTrivialRouter p =
132makeTrivialRouter p =
109 route p EmptyContext (emptyDelayed (FailFatal err501))
133 route p EmptyContext (emptyDelayed (FailFatal err501))
@@ -144,12 +168,12 @@ staticRef = Proxy
144-- structure:
168-- structure:
145
169
146type Dynamic =
170type Dynamic =
147− "a" :> Capture "foo" Int :> "b" :> End
171+ "a" :> Capture "foo" Int :> "b" :> End
148− :<|> "a" :> Capture "bar" Bool :> "c" :> End
172+ :<|> "a" :> Capture "foo" Int :> "c" :> End
149− :<|> "a" :> Capture "baz" Char :> "d" :> End
173+ :<|> "a" :> Capture "foo" Int :> "d" :> End
150
174
151type DynamicRef =
175type DynamicRef =
152− "a" :> Capture "anything" () :>
176+ "a" :> Capture "foo" Int :>
153 ("b" :> End :<|> "c" :> End :<|> "d" :> End)
177 ("b" :> End :<|> "c" :> End :<|> "d" :> End)
154
178
155dynamic :: Proxy Dynamic
179dynamic :: Proxy Dynamic
@@ -339,3 +363,100 @@ level = Proxy
339
363
340levelRef :: Proxy LevelRef
364levelRef :: Proxy LevelRef
341levelRef = Proxy
365levelRef = Proxy
366+
367+-- The example API for the 'layout' function.
368+-- Should get factorized by the 'choice' smart constructor.
369+type ExampleLayout =
370+ "a" :> "d" :> Get '[JSON] NoContent
371+ :<|> "b" :> Capture "x" Int :> Get '[JSON] Bool
372+ :<|> "c" :> Put '[JSON] Bool
373+ :<|> "a" :> "e" :> Get '[JSON] Int
374+ :<|> "b" :> Capture "x" Int :> Put '[JSON] Bool
375+ :<|> Raw
376+
377+exampleLayout :: Proxy ExampleLayout
378+exampleLayout = Proxy
379+
380+-- The expected representation of the example API layout
381+--
382+expectedExampleLayout :: Text
383+expectedExampleLayout =
384+ "/\n\
385+ \├─ a/\n\
386+ \│ ├─ d/\n\
387+ \│ │ └─•\n\
388+ \│ └─ e/\n\
389+ \│ └─•\n\
390+ \├─ b/\n\
391+ \│ └─ <x::Int>/\n\
392+ \│ ├─•\n\
393+ \│ ┆\n\
394+ \│ └─•\n\
395+ \├─ c/\n\
396+ \│ └─•\n\
397+ \┆\n\
398+ \└─ <raw>\n"
399+
400+-- A capture API with all capture types being the same
401+--
402+type CaptureSameType =
403+ "a" :> Capture "foo" Int :> "b" :> End
404+ :<|> "a" :> Capture "foo" Int :> "c" :> End
405+ :<|> "a" :> Capture "foo" Int :> "d" :> End
406+
407+captureSameType :: Proxy CaptureSameType
408+captureSameType = Proxy
409+
410+-- The expected representation of the CaptureSameType API layout.
411+--
412+expectedCaptureSameType :: Text
413+expectedCaptureSameType =
414+ "/\n\
415+ \└─ a/\n\
416+ \ └─ <foo::Int>/\n\
417+ \ ├─ b/\n\
418+ \ │ └─•\n\
419+ \ ├─ c/\n\
420+ \ │ └─•\n\
421+ \ └─ d/\n\
422+ \ └─•\n"
423+
424+-- A capture API capturing different types
425+--
426+type CaptureDifferentTypes =
427+ "a" :> Capture "foo" Int :> "b" :> End
428+ :<|> "a" :> Capture "bar" Bool :> "c" :> End
429+ :<|> "a" :> Capture "baz" Char :> "d" :> End
430+
431+captureDifferentTypes :: Proxy CaptureDifferentTypes
432+captureDifferentTypes = Proxy
433+
434+-- The expected representation of the CaptureDifferentTypes API layout.
435+--
436+expectedCaptureDifferentTypes :: Text
437+expectedCaptureDifferentTypes =
438+ "/\n\
439+ \└─ a/\n\
440+ \ └─ <foo::Int|bar::Bool|baz::Char>/\n\
441+ \ ├─ b/\n\
442+ \ │ └─•\n\
443+ \ ├─ c/\n\
444+ \ │ └─•\n\
445+ \ └─ d/\n\
446+ \ └─•\n"
447+
448+-- An API with a CaptureAll part
449+
450+type CaptureAllLayout = "a" :> CaptureAll "foos" Int :> End
451+
452+captureAllLayout :: Proxy CaptureAllLayout
453+captureAllLayout = Proxy
454+
455+-- The expected representation of the CaptureAllLayout API.
456+--
457+expectedCaptureAllLayout :: Text
458+expectedCaptureAllLayout =
459+ "/\n\
460+ \└─ a/\n\
461+ \ └─ <foos::[Int]>/\n\
462+ \ └─•\n"
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+cabal-version: 2.2
2+name: example
3+version: 1.0
4+synopsis: servant-swagger demonstration
5+description: servant-swagger demonstration
6+license: BSD-3-Clause
7+license-file: LICENSE
8+author: David Johnson, Nickolay Kudasov
9+maintainer: nickolay.kudasov@gmail.com
10+copyright: (c) 2015-2016, Servant contributors
11+category: Web
12+build-type: Simple
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+127
@@ -0,0 +1,127 @@
1+cabal-version: 2.2
2+name: servant-swagger
3+version: 1.1.11
4+synopsis: Generate a Swagger/OpenAPI/OAS 2.0 specification for your servant API.
5+description:
6+ Swagger is a project used to describe and document RESTful APIs. The core of the
7+ project is the [OpenAPI Specification (OAS)](https://swagger.io/docs/specification/about/).
8+ This library implements v2.0 of the spec. Unlike Servant it is language-agnostic and thus is
9+ quite popular among developers in different languages. It has also existed for a longer time
10+ and has more helpful tooling.
11+ .
12+ This package provides means to generate a Swagger/OAS specification for a Servant API
13+ and also to partially test whether an API conforms with its specification.
14+ .
15+ Generated Swagger specification then can be used for many things such as
16+ .
17+ * displaying interactive documentation using [Swagger UI](http://swagger.io/swagger-ui/);
18+ .
19+ * generating clients and servers in many languages using [Swagger Codegen](http://swagger.io/swagger-codegen/);
20+ .
21+ * and [many others](http://swagger.io/open-source-integrations/).
22+homepage: https://github.com/haskell-servant/servant/tree/master/servant-swagger#readme
23+bug-reports: https://github.com/haskell-servant/servant/issues
24+license: BSD-3-Clause
25+license-file: LICENSE
26+author: Servant Contributors
27+maintainer: haskell-servant-maintainers@googlegroups.com
28+copyright: (c) 2015-2018, Servant contributors
29+category: Web, Servant, Swagger
30+build-type: Custom
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 >= 1.24,
54+ cabal-doctest >=1.0.6 && <1.1
55+
56+library
57+ ghc-options: -Wall
58+ exposed-modules:
59+ Servant.Swagger
60+ Servant.Swagger.Test
61+ Servant.Swagger.TypeLevel
62+
63+ -- Internal modules
64+ Servant.Swagger.Internal
65+ Servant.Swagger.Internal.Orphans
66+ Servant.Swagger.Internal.Test
67+ Servant.Swagger.Internal.TypeLevel
68+ Servant.Swagger.Internal.TypeLevel.API
69+ Servant.Swagger.Internal.TypeLevel.Every
70+ Servant.Swagger.Internal.TypeLevel.TMap
71+ hs-source-dirs: src
72+ build-depends: aeson >=1.4.2.0 && <3
73+ , aeson-pretty >=0.8.7 && <0.9
74+ , base >=4.9.1.0 && <5
75+ , base-compat >=0.10.5 && <0.13
76+ , bytestring >=0.10.8.1 && <0.12
77+ , http-media >=0.7.1.3 && <0.9
78+ , insert-ordered-containers >=0.2.1.0 && <0.3
79+ , lens >=4.17 && <6
80+ , servant >=0.18.2 && <0.20
81+ , singleton-bool >=0.1.4 && <0.2
82+ , swagger2 >=2.3.0.1 && <3
83+ , text >=1.2.3.0 && <2.1
84+ , unordered-containers >=0.2.9.0 && <0.3
85+
86+ , hspec
87+ , QuickCheck
88+ default-language: Haskell2010
89+
90+test-suite doctests
91+ ghc-options: -Wall
92+ build-depends:
93+ base,
94+ directory >= 1.0,
95+ doctest >= 0.17 && <0.21,
96+ servant,
97+ QuickCheck,
98+ filepath
99+ default-language: Haskell2010
100+ hs-source-dirs: test
101+ main-is: doctests.hs
102+ type: exitcode-stdio-1.0
103+
104+test-suite spec
105+ ghc-options: -Wall
106+ type: exitcode-stdio-1.0
107+ hs-source-dirs: test
108+ main-is: Spec.hs
109+ build-tool-depends: hspec-discover:hspec-discover >=2.6.0 && <2.10
110+ build-depends: base
111+ , base-compat
112+ , aeson >=1.4.2.0 && <3
113+ , hspec >=2.6.0 && <2.10
114+ , QuickCheck
115+ , lens
116+ , lens-aeson >=1.0.2 && <1.3
117+ , servant
118+ , servant-swagger
119+ , swagger2
120+ , text
121+ , template-haskell
122+ , utf8-string >=1.0.1.1 && <1.1
123+ , time
124+ , vector
125+ other-modules:
126+ Servant.SwaggerSpec
127+ default-language: Haskell2010
servant-swagger/src/Servant/Swagger.hsnew file+188
@@ -0,0 +1,188 @@
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 System.Environment
59+-- >>> import Test.Hspec
60+-- >>> import Test.QuickCheck
61+-- >>> import qualified Data.ByteString.Lazy.Char8 as BSL8
62+-- >>> :set -XDataKinds
63+-- >>> :set -XDeriveDataTypeable
64+-- >>> :set -XDeriveGeneric
65+-- >>> :set -XGeneralizedNewtypeDeriving
66+-- >>> :set -XOverloadedStrings
67+-- >>> :set -XTypeOperators
68+-- >>> setEnv "HSPEC_COLOR" "no"
69+-- >>> data User = User { name :: String, age :: Int } deriving (Show, Generic, Typeable)
70+-- >>> newtype UserId = UserId Integer deriving (Show, Generic, Typeable, ToJSON)
71+-- >>> instance ToJSON User
72+-- >>> instance ToSchema User
73+-- >>> instance ToSchema UserId
74+-- >>> instance ToParamSchema UserId
75+-- >>> type GetUsers = Get '[JSON] [User]
76+-- >>> type GetUser = Capture "user_id" UserId :> Get '[JSON] User
77+-- >>> type PostUser = ReqBody '[JSON] User :> Post '[JSON] UserId
78+-- >>> type UserAPI = GetUsers :<|> GetUser :<|> PostUser
79+-- >>> orderedKeys = encodePretty' (defConfig { confCompare = compare, confIndent = Spaces 0 })
80+
81+-- $howto
82+--
83+-- This section explains how to use this library to generate Swagger specification,
84+-- modify it and run automatic tests for a servant API.
85+--
86+-- For the purposes of this section we will use this servant API:
87+--
88+-- >>> data User = User { name :: String, age :: Int } deriving (Show, Generic, Typeable)
89+-- >>> newtype UserId = UserId Integer deriving (Show, Generic, Typeable, ToJSON)
90+-- >>> instance ToJSON User
91+-- >>> instance ToSchema User
92+-- >>> instance ToSchema UserId
93+-- >>> instance ToParamSchema UserId
94+-- >>> type GetUsers = Get '[JSON] [User]
95+-- >>> type GetUser = Capture "user_id" UserId :> Get '[JSON] User
96+-- >>> type PostUser = ReqBody '[JSON] User :> Post '[JSON] UserId
97+-- >>> type UserAPI = GetUsers :<|> GetUser :<|> PostUser
98+--
99+-- Here we define a user API with three endpoints. @GetUsers@ endpoint returns a list of all users.
100+-- @GetUser@ returns a user given his\/her ID. @PostUser@ creates a new user and returns his\/her ID.
101+
102+-- $generate
103+-- In order to generate @'Swagger'@ specification for a servant API, just use @'toSwagger'@:
104+--
105+-- >>> BSL8.putStrLn . orderedKeys $ toSwagger (Proxy :: Proxy UserAPI)
106+-- {"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"}
107+--
108+-- By default @'toSwagger'@ will generate specification for all API routes, parameters, headers, responses and data schemas.
109+--
110+-- For some parameters it will also add 400 responses with a description mentioning parameter name.
111+--
112+-- Data schemas come from @'ToParamSchema'@ and @'ToSchema'@ classes.
113+
114+-- $annotate
115+-- While initially generated @'Swagger'@ looks good, it lacks some information it can't get from a servant API.
116+--
117+-- We can add this information using field lenses from @"Data.Swagger"@:
118+--
119+-- >>> :{
120+-- BSL8.putStrLn $ orderedKeys $ toSwagger (Proxy :: Proxy UserAPI)
121+-- & info.title .~ "User API"
122+-- & info.version .~ "1.0"
123+-- & info.description ?~ "This is an API for the Users service"
124+-- & info.license ?~ "MIT"
125+-- & host ?~ "example.com"
126+-- :}
127+-- {"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"}
128+--
129+-- It is also useful to annotate or modify certain endpoints.
130+-- @'subOperations'@ provides a convenient way to zoom into a part of an API.
131+--
132+-- @'subOperations' sub api@ traverses all operations of the @api@ which are also present in @sub@.
133+-- Furthermore, @sub@ is required to be an exact sub API of @api. Otherwise it will not typecheck.
134+--
135+-- @"Data.Swagger.Operation"@ provides some useful helpers that can be used with @'subOperations'@.
136+-- One example is applying tags to certain endpoints:
137+--
138+-- >>> let getOps = subOperations (Proxy :: Proxy (GetUsers :<|> GetUser)) (Proxy :: Proxy UserAPI)
139+-- >>> let postOps = subOperations (Proxy :: Proxy PostUser) (Proxy :: Proxy UserAPI)
140+-- >>> :{
141+-- BSL8.putStrLn $ orderedKeys $ toSwagger (Proxy :: Proxy UserAPI)
142+-- & applyTagsFor getOps ["get" & description ?~ "GET operations"]
143+-- & applyTagsFor postOps ["post" & description ?~ "POST operations"]
144+-- :}
145+-- {"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"}]}
146+--
147+-- This applies @\"get\"@ tag to the @GET@ endpoints and @\"post\"@ tag to the @POST@ endpoint of the User API.
148+
149+-- $test
150+-- Automatic generation of data schemas uses @'ToSchema'@ instances for the types
151+-- used in a servant API. But to encode/decode actual data servant uses different classes.
152+-- For instance in @UserAPI@ @User@ is always encoded/decoded using @'ToJSON'@ and @'FromJSON'@ instances.
153+--
154+-- To be sure your Haskell server/client handles data properly you need to check
155+-- that @'ToJSON'@ instance always generates values that satisfy schema produced
156+-- by @'ToSchema'@ instance.
157+--
158+-- With @'validateEveryToJSON'@ it is possible to test all those instances automatically,
159+-- without having to write down every type:
160+--
161+-- >>> instance Arbitrary User where arbitrary = User <$> arbitrary <*> arbitrary
162+-- >>> instance Arbitrary UserId where arbitrary = UserId <$> arbitrary
163+-- >>> hspec $ validateEveryToJSON (Proxy :: Proxy UserAPI)
164+-- <BLANKLINE>
165+-- [User]...
166+-- ...
167+-- User...
168+-- ...
169+-- UserId...
170+-- ...
171+-- Finished in ... seconds
172+-- 3 examples, 0 failures
173+--
174+-- Although servant is great, chances are that your API clients don't use Haskell.
175+-- In many cases @swagger.json@ serves as a specification, not a Haskell type.
176+--
177+-- In this cases it is a good idea to store generated and annotated @'Swagger'@ in a @swagger.json@ file
178+-- under a version control system (such as Git, Subversion, Mercurial, etc.).
179+--
180+-- It is also recommended to version API based on changes to the @swagger.json@ rather than changes
181+-- to the Haskell API.
182+--
183+-- See <example/test/TodoSpec.hs TodoSpec.hs> for an example of a complete test suite for a swagger specification.
184+
185+-- $serve
186+-- If you're implementing a server for an API, you might also want to serve its @'Swagger'@ specification.
187+--
188+-- See <example/src/Todo.hs Todo.hs> for an example of a server.
servant-swagger/src/Servant/Swagger/Internal.hsnew file+488
@@ -0,0 +1,488 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE ConstraintKinds #-}
3+{-# LANGUAGE DataKinds #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE OverloadedLists #-}
7+{-# LANGUAGE OverloadedStrings #-}
8+{-# LANGUAGE PolyKinds #-}
9+{-# LANGUAGE RankNTypes #-}
10+{-# LANGUAGE ScopedTypeVariables #-}
11+{-# LANGUAGE TypeOperators #-}
12+{-# LANGUAGE TypeFamilies #-}
13+#if __GLASGOW_HASKELL__ >= 806
14+{-# LANGUAGE UndecidableInstances #-}
15+#endif
16+module Servant.Swagger.Internal where
17+
18+import Prelude ()
19+import Prelude.Compat
20+
21+import Control.Applicative ((<|>))
22+import Control.Lens
23+import Data.Aeson
24+import Data.HashMap.Strict.InsOrd (InsOrdHashMap)
25+import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
26+import Data.Foldable (toList)
27+import Data.Proxy
28+import Data.Typeable
29+import Data.Singletons.Bool
30+import Data.Swagger hiding (Header)
31+import qualified Data.Swagger as Swagger
32+import Data.Swagger.Declare
33+import Data.Text (Text)
34+import qualified Data.Text as Text
35+import GHC.Generics (D1, Meta(..), Rep)
36+import GHC.TypeLits
37+import Network.HTTP.Media (MediaType)
38+import Servant.API
39+import Servant.API.Description (FoldDescription,
40+ reflectDescription)
41+import Servant.API.Generic (ToServantApi, AsApi)
42+import Servant.API.Modifiers (FoldRequired)
43+
44+import Servant.Swagger.Internal.TypeLevel.API
45+
46+-- | Generate a Swagger specification for a servant API.
47+--
48+-- To generate Swagger specification, your data types need
49+-- @'ToParamSchema'@ and/or @'ToSchema'@ instances.
50+--
51+-- @'ToParamSchema'@ is used for @'Capture'@, @'QueryParam'@ and @'Header'@.
52+-- @'ToSchema'@ is used for @'ReqBody'@ and response data types.
53+--
54+-- You can easily derive those instances via @Generic@.
55+-- For more information, refer to <http://hackage.haskell.org/package/swagger2/docs/Data-Swagger.html swagger2 documentation>.
56+--
57+-- Example:
58+--
59+-- @
60+-- newtype Username = Username String deriving (Generic, ToText)
61+--
62+-- instance ToParamSchema Username
63+--
64+-- data User = User
65+-- { username :: Username
66+-- , fullname :: String
67+-- } deriving (Generic)
68+--
69+-- instance ToJSON User
70+-- instance ToSchema User
71+--
72+-- type MyAPI = QueryParam "username" Username :> Get '[JSON] User
73+--
74+-- mySwagger :: Swagger
75+-- mySwagger = toSwagger (Proxy :: Proxy MyAPI)
76+-- @
77+class HasSwagger api where
78+ -- | Generate a Swagger specification for a servant API.
79+ toSwagger :: Proxy api -> Swagger
80+
81+instance HasSwagger Raw where
82+ toSwagger _ = mempty & paths . at "/" ?~ mempty
83+
84+instance HasSwagger EmptyAPI where
85+ toSwagger _ = mempty
86+
87+-- | All operations of sub API.
88+-- This is similar to @'operationsOf'@ but ensures that operations
89+-- indeed belong to the API at compile time.
90+subOperations :: (IsSubAPI sub api, HasSwagger sub) =>
91+ Proxy sub -- ^ Part of a servant API.
92+ -> Proxy api -- ^ The whole servant API.
93+ -> Traversal' Swagger Operation
94+subOperations sub _ = operationsOf (toSwagger sub)
95+
96+-- | Make a singleton Swagger spec (with only one endpoint).
97+-- For endpoints with no content see 'mkEndpointNoContent'.
98+mkEndpoint :: forall a cs hs proxy method status.
99+ (ToSchema a, AllAccept cs, AllToResponseHeader hs, SwaggerMethod method, KnownNat status)
100+ => FilePath -- ^ Endpoint path.
101+ -> proxy (Verb method status cs (Headers hs a)) -- ^ Method, content-types, headers and response.
102+ -> Swagger
103+mkEndpoint path proxy
104+ = mkEndpointWithSchemaRef (Just ref) path proxy
105+ & definitions .~ defs
106+ where
107+ (defs, ref) = runDeclare (declareSchemaRef (Proxy :: Proxy a)) mempty
108+
109+-- | Make a singletone 'Swagger' spec (with only one endpoint) and with no content schema.
110+mkEndpointNoContent :: forall nocontent cs hs proxy method status.
111+ (AllAccept cs, AllToResponseHeader hs, SwaggerMethod method, KnownNat status)
112+ => FilePath -- ^ Endpoint path.
113+ -> proxy (Verb method status cs (Headers hs nocontent)) -- ^ Method, content-types, headers and response.
114+ -> Swagger
115+mkEndpointNoContent path proxy
116+ = mkEndpointWithSchemaRef Nothing path proxy
117+
118+-- | Like @'mkEndpoint'@ but with explicit schema reference.
119+-- Unlike @'mkEndpoint'@ this function does not update @'definitions'@.
120+mkEndpointWithSchemaRef :: forall cs hs proxy method status a.
121+ (AllAccept cs, AllToResponseHeader hs, SwaggerMethod method, KnownNat status)
122+ => Maybe (Referenced Schema)
123+ -> FilePath
124+ -> proxy (Verb method status cs (Headers hs a))
125+ -> Swagger
126+mkEndpointWithSchemaRef mref path _ = mempty
127+ & paths.at path ?~
128+ (mempty & method ?~ (mempty
129+ & produces ?~ MimeList responseContentTypes
130+ & at code ?~ Inline (mempty
131+ & schema .~ mref
132+ & headers .~ responseHeaders)))
133+ where
134+ method = swaggerMethod (Proxy :: Proxy method)
135+ code = fromIntegral (natVal (Proxy :: Proxy status))
136+ responseContentTypes = allContentType (Proxy :: Proxy cs)
137+ responseHeaders = toAllResponseHeaders (Proxy :: Proxy hs)
138+
139+mkEndpointNoContentVerb :: forall proxy method.
140+ (SwaggerMethod method)
141+ => FilePath -- ^ Endpoint path.
142+ -> proxy (NoContentVerb method) -- ^ Method
143+ -> Swagger
144+mkEndpointNoContentVerb path _ = mempty
145+ & paths.at path ?~
146+ (mempty & method ?~ (mempty
147+ & at code ?~ Inline mempty))
148+ where
149+ method = swaggerMethod (Proxy :: Proxy method)
150+ code = 204 -- hardcoded in servant-server
151+
152+-- | Add parameter to every operation in the spec.
153+addParam :: Param -> Swagger -> Swagger
154+addParam param = allOperations.parameters %~ (Inline param :)
155+
156+-- | Add a tag to every operation in the spec.
157+addTag :: Text -> Swagger -> Swagger
158+addTag tag = allOperations.tags %~ ([tag] <>)
159+
160+-- | Add accepted content types to every operation in the spec.
161+addConsumes :: [MediaType] -> Swagger -> Swagger
162+addConsumes cs = allOperations.consumes %~ (<> Just (MimeList cs))
163+
164+-- | Format given text as inline code in Markdown.
165+markdownCode :: Text -> Text
166+markdownCode s = "`" <> s <> "`"
167+
168+addDefaultResponse400 :: ParamName -> Swagger -> Swagger
169+addDefaultResponse400 pname = setResponseWith (\old _new -> alter400 old) 400 (return response400)
170+ where
171+ sname = markdownCode pname
172+ description400 = "Invalid " <> sname
173+ alter400 = description %~ (<> (" or " <> sname))
174+ response400 = mempty & description .~ description400
175+
176+-- | Methods, available for Swagger.
177+class SwaggerMethod method where
178+ swaggerMethod :: proxy method -> Lens' PathItem (Maybe Operation)
179+
180+instance SwaggerMethod 'GET where swaggerMethod _ = get
181+instance SwaggerMethod 'PUT where swaggerMethod _ = put
182+instance SwaggerMethod 'POST where swaggerMethod _ = post
183+instance SwaggerMethod 'DELETE where swaggerMethod _ = delete
184+instance SwaggerMethod 'OPTIONS where swaggerMethod _ = options
185+instance SwaggerMethod 'HEAD where swaggerMethod _ = head_
186+instance SwaggerMethod 'PATCH where swaggerMethod _ = patch
187+
188+instance HasSwagger (UVerb method cs '[]) where
189+ toSwagger _ = mempty
190+
191+-- | @since <TODO>
192+instance
193+ {-# OVERLAPPABLE #-}
194+ ( ToSchema a,
195+ HasStatus a,
196+ AllAccept cs,
197+ SwaggerMethod method,
198+ HasSwagger (UVerb method cs as)
199+ ) =>
200+ HasSwagger (UVerb method cs (a ': as))
201+ where
202+ toSwagger _ =
203+ toSwagger (Proxy :: Proxy (Verb method (StatusOf a) cs a))
204+ `combineSwagger` toSwagger (Proxy :: Proxy (UVerb method cs as))
205+
206+-- ATTENTION: do not remove this instance!
207+-- A similar instance above will always use the more general
208+-- polymorphic -- HasSwagger instance and will result in a type error
209+-- since 'NoContent' does not have a 'ToSchema' instance.
210+instance
211+ ( KnownNat status,
212+ AllAccept cs,
213+ SwaggerMethod method,
214+ HasSwagger (UVerb method cs as)
215+ ) =>
216+ HasSwagger (UVerb method cs (WithStatus status NoContent ': as))
217+ where
218+ toSwagger _ =
219+ toSwagger (Proxy :: Proxy (Verb method status cs NoContent))
220+ `combineSwagger` toSwagger (Proxy :: Proxy (UVerb method cs as))
221+
222+
223+-- workaround for https://github.com/GetShopTV/swagger2/issues/218
224+-- We'd like to juse use (<>) but the instances are wrong
225+combinePathItem :: PathItem -> PathItem -> PathItem
226+combinePathItem s t = PathItem
227+ { _pathItemGet = _pathItemGet s <> _pathItemGet t
228+ , _pathItemPut = _pathItemPut s <> _pathItemPut t
229+ , _pathItemPost = _pathItemPost s <> _pathItemPost t
230+ , _pathItemDelete = _pathItemDelete s <> _pathItemDelete t
231+ , _pathItemOptions = _pathItemOptions s <> _pathItemOptions t
232+ , _pathItemHead = _pathItemHead s <> _pathItemHead t
233+ , _pathItemPatch = _pathItemPatch s <> _pathItemPatch t
234+ , _pathItemParameters = _pathItemParameters s <> _pathItemParameters t
235+ }
236+
237+combineSwagger :: Swagger -> Swagger -> Swagger
238+combineSwagger s t = Swagger
239+ { _swaggerInfo = _swaggerInfo s <> _swaggerInfo t
240+ , _swaggerHost = _swaggerHost s <|> _swaggerHost t
241+ , _swaggerBasePath = _swaggerBasePath s <|> _swaggerBasePath t
242+ , _swaggerSchemes = _swaggerSchemes s <> _swaggerSchemes t
243+ , _swaggerConsumes = _swaggerConsumes s <> _swaggerConsumes t
244+ , _swaggerProduces = _swaggerProduces s <> _swaggerProduces t
245+ , _swaggerPaths = InsOrdHashMap.unionWith combinePathItem (_swaggerPaths s) (_swaggerPaths t)
246+ , _swaggerDefinitions = _swaggerDefinitions s <> _swaggerDefinitions t
247+ , _swaggerParameters = _swaggerParameters s <> _swaggerParameters t
248+ , _swaggerResponses = _swaggerResponses s <> _swaggerResponses t
249+ , _swaggerSecurityDefinitions = _swaggerSecurityDefinitions s <> _swaggerSecurityDefinitions t
250+ , _swaggerSecurity = _swaggerSecurity s <> _swaggerSecurity t
251+ , _swaggerTags = _swaggerTags s <> _swaggerTags t
252+ , _swaggerExternalDocs = _swaggerExternalDocs s <|> _swaggerExternalDocs t
253+ }
254+
255+instance {-# OVERLAPPABLE #-} (ToSchema a, AllAccept cs, KnownNat status, SwaggerMethod method) => HasSwagger (Verb method status cs a) where
256+ toSwagger _ = toSwagger (Proxy :: Proxy (Verb method status cs (Headers '[] a)))
257+
258+-- | @since 1.1.7
259+instance (ToSchema a, Accept ct, KnownNat status, SwaggerMethod method) => HasSwagger (Stream method status fr ct a) where
260+ toSwagger _ = toSwagger (Proxy :: Proxy (Verb method status '[ct] (Headers '[] a)))
261+
262+instance {-# OVERLAPPABLE #-} (ToSchema a, AllAccept cs, AllToResponseHeader hs, KnownNat status, SwaggerMethod method)
263+ => HasSwagger (Verb method status cs (Headers hs a)) where
264+ toSwagger = mkEndpoint "/"
265+
266+-- ATTENTION: do not remove this instance!
267+-- A similar instance above will always use the more general
268+-- polymorphic -- HasSwagger instance and will result in a type error
269+-- since 'NoContent' does not have a 'ToSchema' instance.
270+instance (AllAccept cs, KnownNat status, SwaggerMethod method) => HasSwagger (Verb method status cs NoContent) where
271+ toSwagger _ = toSwagger (Proxy :: Proxy (Verb method status cs (Headers '[] NoContent)))
272+
273+instance (AllAccept cs, AllToResponseHeader hs, KnownNat status, SwaggerMethod method)
274+ => HasSwagger (Verb method status cs (Headers hs NoContent)) where
275+ toSwagger = mkEndpointNoContent "/"
276+
277+instance (SwaggerMethod method) => HasSwagger (NoContentVerb method) where
278+ toSwagger = mkEndpointNoContentVerb "/"
279+
280+instance (HasSwagger a, HasSwagger b) => HasSwagger (a :<|> b) where
281+ toSwagger _ = toSwagger (Proxy :: Proxy a) <> toSwagger (Proxy :: Proxy b)
282+
283+-- | @'Vault'@ combinator does not change our specification at all.
284+instance (HasSwagger sub) => HasSwagger (Vault :> sub) where
285+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
286+
287+-- | @'IsSecure'@ combinator does not change our specification at all.
288+instance (HasSwagger sub) => HasSwagger (IsSecure :> sub) where
289+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
290+
291+-- | @'RemoteHost'@ combinator does not change our specification at all.
292+instance (HasSwagger sub) => HasSwagger (RemoteHost :> sub) where
293+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
294+
295+-- | @'Fragment'@ combinator does not change our specification at all.
296+instance HasSwagger sub => HasSwagger (Fragment a :> sub) where
297+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
298+
299+-- | @'HttpVersion'@ combinator does not change our specification at all.
300+instance (HasSwagger sub) => HasSwagger (HttpVersion :> sub) where
301+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
302+
303+-- | @'WithNamedContext'@ combinator does not change our specification at all.
304+instance (HasSwagger sub) => HasSwagger (WithNamedContext x c sub) where
305+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
306+
307+instance (KnownSymbol sym, HasSwagger sub) => HasSwagger (sym :> sub) where
308+ toSwagger _ = prependPath piece (toSwagger (Proxy :: Proxy sub))
309+ where
310+ piece = symbolVal (Proxy :: Proxy sym)
311+
312+instance (KnownSymbol sym, Typeable a, ToParamSchema a, HasSwagger sub, KnownSymbol (FoldDescription mods)) => HasSwagger (Capture' mods sym a :> sub) where
313+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
314+ & addParam param
315+ & prependPath capture
316+ & addDefaultResponse400 tname
317+ where
318+ symbol = symbolVal (Proxy :: Proxy sym)
319+ pname = if symbol == ""
320+ then camelTo2 '-' . tyConName . typeRepTyCon $ typeRep (Proxy :: Proxy a)
321+ else symbol
322+ tname = Text.pack pname
323+ transDesc "" = Nothing
324+ transDesc desc = Just (Text.pack desc)
325+ capture = "{" <> pname <> "}"
326+ param = mempty
327+ & name .~ tname
328+ & description .~ transDesc (reflectDescription (Proxy :: Proxy mods))
329+ & required ?~ True
330+ & schema .~ ParamOther (mempty
331+ & in_ .~ ParamPath
332+ & paramSchema .~ toParamSchema (Proxy :: Proxy a))
333+
334+-- | Swagger Spec doesn't have a notion of CaptureAll, this instance is the best effort.
335+instance (KnownSymbol sym, Typeable a, ToParamSchema a, HasSwagger sub) => HasSwagger (CaptureAll sym a :> sub) where
336+ toSwagger _ = toSwagger (Proxy :: Proxy (Capture sym a :> sub))
337+
338+instance (KnownSymbol desc, HasSwagger api) => HasSwagger (Description desc :> api) where
339+ toSwagger _ = toSwagger (Proxy :: Proxy api)
340+ & allOperations.description %~ (Just (Text.pack (symbolVal (Proxy :: Proxy desc))) <>)
341+
342+instance (KnownSymbol desc, HasSwagger api) => HasSwagger (Summary desc :> api) where
343+ toSwagger _ = toSwagger (Proxy :: Proxy api)
344+ & allOperations.summary %~ (Just (Text.pack (symbolVal (Proxy :: Proxy desc))) <>)
345+
346+instance (KnownSymbol sym, ToParamSchema a, HasSwagger sub, SBoolI (FoldRequired mods), KnownSymbol (FoldDescription mods)) => HasSwagger (QueryParam' mods sym a :> sub) where
347+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
348+ & addParam param
349+ & addDefaultResponse400 tname
350+ where
351+ tname = Text.pack (symbolVal (Proxy :: Proxy sym))
352+ transDesc "" = Nothing
353+ transDesc desc = Just (Text.pack desc)
354+ param = mempty
355+ & name .~ tname
356+ & description .~ transDesc (reflectDescription (Proxy :: Proxy mods))
357+ & required ?~ reflectBool (Proxy :: Proxy (FoldRequired mods))
358+ & schema .~ ParamOther sch
359+ sch = mempty
360+ & in_ .~ ParamQuery
361+ & paramSchema .~ toParamSchema (Proxy :: Proxy a)
362+
363+instance (KnownSymbol sym, ToParamSchema a, HasSwagger sub) => HasSwagger (QueryParams sym a :> sub) where
364+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
365+ & addParam param
366+ & addDefaultResponse400 tname
367+ where
368+ tname = Text.pack (symbolVal (Proxy :: Proxy sym))
369+ param = mempty
370+ & name .~ tname
371+ & schema .~ ParamOther sch
372+ sch = mempty
373+ & in_ .~ ParamQuery
374+ & paramSchema .~ pschema
375+ pschema = mempty
376+#if MIN_VERSION_swagger2(2,4,0)
377+ & type_ ?~ SwaggerArray
378+#else
379+ & type_ .~ SwaggerArray
380+#endif
381+ & items ?~ SwaggerItemsPrimitive (Just CollectionMulti) (toParamSchema (Proxy :: Proxy a))
382+
383+instance (KnownSymbol sym, HasSwagger sub) => HasSwagger (QueryFlag sym :> sub) where
384+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
385+ & addParam param
386+ & addDefaultResponse400 tname
387+ where
388+ tname = Text.pack (symbolVal (Proxy :: Proxy sym))
389+ param = mempty
390+ & name .~ tname
391+ & schema .~ ParamOther (mempty
392+ & in_ .~ ParamQuery
393+ & allowEmptyValue ?~ True
394+ & paramSchema .~ (toParamSchema (Proxy :: Proxy Bool)
395+ & default_ ?~ toJSON False))
396+
397+instance (KnownSymbol sym, ToParamSchema a, HasSwagger sub, SBoolI (FoldRequired mods), KnownSymbol (FoldDescription mods)) => HasSwagger (Header' mods sym a :> sub) where
398+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
399+ & addParam param
400+ & addDefaultResponse400 tname
401+ where
402+ tname = Text.pack (symbolVal (Proxy :: Proxy sym))
403+ transDesc "" = Nothing
404+ transDesc desc = Just (Text.pack desc)
405+ param = mempty
406+ & name .~ tname
407+ & description .~ transDesc (reflectDescription (Proxy :: Proxy mods))
408+ & required ?~ reflectBool (Proxy :: Proxy (FoldRequired mods))
409+ & schema .~ ParamOther (mempty
410+ & in_ .~ ParamHeader
411+ & paramSchema .~ toParamSchema (Proxy :: Proxy a))
412+
413+instance (ToSchema a, AllAccept cs, HasSwagger sub, KnownSymbol (FoldDescription mods)) => HasSwagger (ReqBody' mods cs a :> sub) where
414+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
415+ & addParam param
416+ & addConsumes (allContentType (Proxy :: Proxy cs))
417+ & addDefaultResponse400 tname
418+ & definitions %~ (<> defs)
419+ where
420+ tname = "body"
421+ transDesc "" = Nothing
422+ transDesc desc = Just (Text.pack desc)
423+ (defs, ref) = runDeclare (declareSchemaRef (Proxy :: Proxy a)) mempty
424+ param = mempty
425+ & name .~ tname
426+ & description .~ transDesc (reflectDescription (Proxy :: Proxy mods))
427+ & required ?~ True
428+ & schema .~ ParamBody ref
429+
430+-- | This instance is an approximation.
431+--
432+-- @since 1.1.7
433+instance (ToSchema a, Accept ct, HasSwagger sub, KnownSymbol (FoldDescription mods)) => HasSwagger (StreamBody' mods fr ct a :> sub) where
434+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
435+ & addParam param
436+ & addConsumes (toList (contentTypes (Proxy :: Proxy ct)))
437+ & addDefaultResponse400 tname
438+ & definitions %~ (<> defs)
439+ where
440+ tname = "body"
441+ transDesc "" = Nothing
442+ transDesc desc = Just (Text.pack desc)
443+ (defs, ref) = runDeclare (declareSchemaRef (Proxy :: Proxy a)) mempty
444+ param = mempty
445+ & name .~ tname
446+ & description .~ transDesc (reflectDescription (Proxy :: Proxy mods))
447+ & required ?~ True
448+ & schema .~ ParamBody ref
449+
450+instance (HasSwagger (ToServantApi routes), KnownSymbol datatypeName, Rep (routes AsApi) ~ D1 ('MetaData datatypeName moduleName packageName isNewtype) f) => HasSwagger (NamedRoutes routes) where
451+ toSwagger _ = addTag (Text.pack $ symbolVal (Proxy :: Proxy datatypeName)) (toSwagger (Proxy :: Proxy (ToServantApi routes)))
452+
453+-- =======================================================================
454+-- Below are the definitions that should be in Servant.API.ContentTypes
455+-- =======================================================================
456+
457+class AllAccept cs where
458+ allContentType :: Proxy cs -> [MediaType]
459+
460+instance AllAccept '[] where
461+ allContentType _ = []
462+
463+instance (Accept c, AllAccept cs) => AllAccept (c ': cs) where
464+ allContentType _ = contentType (Proxy :: Proxy c) : allContentType (Proxy :: Proxy cs)
465+
466+class ToResponseHeader h where
467+ toResponseHeader :: Proxy h -> (HeaderName, Swagger.Header)
468+
469+instance (KnownSymbol sym, ToParamSchema a) => ToResponseHeader (Header sym a) where
470+ toResponseHeader _ = (hname, Swagger.Header Nothing hschema)
471+ where
472+ hname = Text.pack (symbolVal (Proxy :: Proxy sym))
473+ hschema = toParamSchema (Proxy :: Proxy a)
474+
475+class AllToResponseHeader hs where
476+ toAllResponseHeaders :: Proxy hs -> InsOrdHashMap HeaderName Swagger.Header
477+
478+instance AllToResponseHeader '[] where
479+ toAllResponseHeaders _ = mempty
480+
481+instance (ToResponseHeader h, AllToResponseHeader hs) => AllToResponseHeader (h ': hs) where
482+ toAllResponseHeaders _ = InsOrdHashMap.insert headerName headerBS hdrs
483+ where
484+ (headerName, headerBS) = toResponseHeader (Proxy :: Proxy h)
485+ hdrs = toAllResponseHeaders (Proxy :: Proxy hs)
486+
487+instance AllToResponseHeader hs => AllToResponseHeader (HList hs) where
488+ 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+207
@@ -0,0 +1,207 @@
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+-- >>> import System.Environment (setEnv)
33+-- >>> :set -XDeriveGeneric
34+-- >>> :set -XGeneralizedNewtypeDeriving
35+-- >>> :set -XDataKinds
36+-- >>> :set -XTypeOperators
37+-- >>> setEnv "HSPEC_COLOR" "no"
38+
39+-- | Verify that every type used with @'JSON'@ content type in a servant API
40+-- has compatible @'ToJSON'@ and @'ToSchema'@ instances using @'validateToJSON'@.
41+--
42+-- /NOTE:/ @'validateEveryToJSON'@ does not perform string pattern validation.
43+-- See @'validateEveryToJSONWithPatternChecker'@.
44+--
45+-- @'validateEveryToJSON'@ will produce one @'prop'@ specification for every type in the API.
46+-- Each type only gets one test, even if it occurs multiple times in the API.
47+--
48+-- >>> data User = User { name :: String, age :: Maybe Int } deriving (Show, Generic, Typeable)
49+-- >>> newtype UserId = UserId String deriving (Show, Generic, Typeable, ToJSON, Arbitrary)
50+-- >>> instance ToJSON User
51+-- >>> instance ToSchema User
52+-- >>> instance ToSchema UserId
53+-- >>> instance Arbitrary User where arbitrary = User <$> arbitrary <*> arbitrary
54+-- >>> type UserAPI = (Capture "user_id" UserId :> Get '[JSON] User) :<|> (ReqBody '[JSON] User :> Post '[JSON] UserId)
55+--
56+-- >>> hspec $ context "ToJSON matches ToSchema" $ validateEveryToJSON (Proxy :: Proxy UserAPI)
57+-- <BLANKLINE>
58+-- ToJSON matches ToSchema...
59+-- User...
60+-- ...
61+-- UserId...
62+-- ...
63+-- Finished in ... seconds
64+-- 2 examples, 0 failures
65+--
66+-- For the test to compile all body types should have the following instances:
67+--
68+-- * @'ToJSON'@ and @'ToSchema'@ are used to perform the validation;
69+-- * @'Typeable'@ is used to name the test for each type;
70+-- * @'Show'@ is used to display value for which @'ToJSON'@ does not satisfy @'ToSchema'@.
71+-- * @'Arbitrary'@ is used to arbitrarily generate values.
72+--
73+-- If any of the instances is missing, you'll get a descriptive type error:
74+--
75+-- >>> data Contact = Contact { fullname :: String, phone :: Integer } deriving (Show, Generic)
76+-- >>> instance ToJSON Contact
77+-- >>> instance ToSchema Contact
78+-- >>> type ContactAPI = Get '[JSON] Contact
79+-- >>> hspec $ validateEveryToJSON (Proxy :: Proxy ContactAPI)
80+-- ...
81+-- ...No instance for (Arbitrary Contact)
82+-- ... arising from a use of ‘validateEveryToJSON’
83+-- ...
84+validateEveryToJSON
85+ :: forall proxy api .
86+ TMap (Every [Typeable, Show, Arbitrary, ToJSON, ToSchema])
87+ (BodyTypes JSON api)
88+ => proxy api -- ^ Servant API.
89+ -> Spec
90+validateEveryToJSON _ = props
91+ (Proxy :: Proxy [ToJSON, ToSchema])
92+ (maybeCounterExample . prettyValidateWith validateToJSON)
93+ (Proxy :: Proxy (BodyTypes JSON api))
94+
95+-- | Verify that every type used with @'JSON'@ content type in a servant API
96+-- has compatible @'ToJSON'@ and @'ToSchema'@ instances using @'validateToJSONWithPatternChecker'@.
97+--
98+-- For validation without patterns see @'validateEveryToJSON'@.
99+validateEveryToJSONWithPatternChecker :: forall proxy api. TMap (Every [Typeable, Show, Arbitrary, ToJSON, ToSchema]) (BodyTypes JSON api) =>
100+ (Pattern -> Text -> Bool) -- ^ @'Pattern'@ checker.
101+ -> proxy api -- ^ Servant API.
102+ -> Spec
103+validateEveryToJSONWithPatternChecker checker _ = props
104+ (Proxy :: Proxy [ToJSON, ToSchema])
105+ (maybeCounterExample . prettyValidateWith (validateToJSONWithPatternChecker checker))
106+ (Proxy :: Proxy (BodyTypes JSON api))
107+
108+-- * QuickCheck-related stuff
109+
110+-- | Construct property tests for each type in a list.
111+-- The name for each property is the name of the corresponding type.
112+--
113+-- >>> :{
114+-- hspec $
115+-- context "read . show == id" $
116+-- props
117+-- (Proxy :: Proxy [Eq, Show, Read])
118+-- (\x -> read (show x) === x)
119+-- (Proxy :: Proxy [Bool, Int, String])
120+-- :}
121+-- <BLANKLINE>
122+-- read . show == id
123+-- Bool...
124+-- ...
125+-- Int...
126+-- ...
127+-- [Char]...
128+-- ...
129+-- Finished in ... seconds
130+-- 3 examples, 0 failures
131+props :: forall p p'' cs xs. TMap (Every (Typeable ': Show ': Arbitrary ': cs)) xs =>
132+ p cs -- ^ A list of constraints.
133+ -> (forall x. EveryTF cs x => x -> Property) -- ^ Property predicate.
134+ -> p'' xs -- ^ A list of types.
135+ -> Spec
136+props _ f px = sequence_ specs
137+ where
138+ specs :: [Spec]
139+ specs = tmapEvery (Proxy :: Proxy (Typeable ': Show ': Arbitrary ': cs)) aprop px
140+
141+ aprop :: forall p' a. (EveryTF cs a, Typeable a, Show a, Arbitrary a) => p' a -> Spec
142+ aprop _ = prop (show (typeOf (undefined :: a))) (f :: a -> Property)
143+
144+-- | Pretty print validation errors
145+-- together with actual JSON and Swagger Schema
146+-- (using 'encodePretty').
147+--
148+-- >>> import Data.Aeson
149+-- >>> import Data.Foldable (traverse_)
150+-- >>> data Person = Person { name :: String, phone :: Integer } deriving (Generic)
151+-- >>> instance ToJSON Person where toJSON p = object [ "name" .= name p ]
152+-- >>> instance ToSchema Person
153+-- >>> let person = Person { name = "John", phone = 123456 }
154+-- >>> traverse_ putStrLn $ prettyValidateWith validateToJSON person
155+-- Validation against the schema fails:
156+-- * property "phone" is required, but not found in "{\"name\":\"John\"}"
157+-- <BLANKLINE>
158+-- JSON value:
159+-- {
160+-- "name": "John"
161+-- }
162+-- <BLANKLINE>
163+-- Swagger Schema:
164+-- {
165+-- "properties": {
166+-- "name": {
167+-- "type": "string"
168+-- },
169+-- "phone": {
170+-- "type": "integer"
171+-- }
172+-- },
173+-- "required": [
174+-- "name",
175+-- "phone"
176+-- ],
177+-- "type": "object"
178+-- }
179+-- <BLANKLINE>
180+--
181+-- FIXME: this belongs in "Data.Swagger.Schema.Validation" (in @swagger2@).
182+prettyValidateWith
183+ :: forall a. (ToJSON a, ToSchema a)
184+ => (a -> [ValidationError]) -> a -> Maybe String
185+prettyValidateWith f x =
186+ case f x of
187+ [] -> Nothing
188+ errors -> Just $ unlines
189+ [ "Validation against the schema fails:"
190+ , unlines (map (" * " ++) errors)
191+ , "JSON value:"
192+ , ppJSONString json
193+ , ""
194+ , "Swagger Schema:"
195+ , ppJSONString (toJSON schema)
196+ ]
197+ where
198+ ppJSONString = TL.unpack . TL.decodeUtf8 . encodePretty' ppCfg
199+ ppCfg = defConfig { confCompare = compare }
200+
201+ json = toJSON x
202+ schema = toSchema (Proxy :: Proxy a)
203+
204+-- | Provide a counterexample if there is any.
205+maybeCounterExample :: Maybe String -> Property
206+maybeCounterExample Nothing = property True
207+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/CHANGELOG.md+116
@@ -1,5 +1,121 @@
1[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)
1[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)
2
2
3+Package versions follow the [Package Versioning Policy](https://pvp.haskell.org/): in A.B.C, bumps to either A or B represent major versions.
4+
5+0.19
6+----
7+
8+### Significant changes
9+
10+- Drop support for GHC < 8.6.
11+- Support GHC 9.0 (GHC 9.2 should work as well, but isn't fully tested yet).
12+- Support Aeson 2 ([#1475](https://github.com/haskell-servant/servant/pull/1475)),
13+ which fixes a [DOS vulnerability](https://github.com/haskell/aeson/issues/864)
14+ related to hash collisions.
15+- Add `NamedRoutes` combinator, making support for records first-class in Servant
16+ ([#1388](https://github.com/haskell-servant/servant/pull/1388)).
17+
18+ Users can now directly mark part as an API as defined by a record, instead of
19+ using `(:<|>)` to combine routes. Concretely, the anonymous:
20+
21+ ```haskell
22+ type API =
23+ "version" :> Get '[JSON] String :<|>
24+ "products" :> Get '[JSON] [Product]
25+ ```
26+
27+ can be replaced with the explicitly-named:
28+
29+ ```haskell
30+ type API = NamedRoutes NamedAPI
31+ data NamedAPI mode = NamedAPI
32+ { version :: mode :- "version" :> Get '[JSON] String
33+ , products :: mode :- "products" :> Get '[JSON] [Product]
34+ }
35+ ```
36+
37+ `NamedRoutes` builds upon `servant-generic`, but improves usability by freeing
38+ users from the need to perform `toServant` / `fromServant` conversions
39+ manually. Serving `NamedRoutes NamedAPI` is now done directly by providing a
40+ record of handlers, and servant generates clients directly as records as well.
41+ In particular, it makes it much more practical to work with nested hierarchies
42+ of named routes.
43+
44+ Two convenience functions, `(//)` and `(/:)`, have been added to make the
45+ usage of named route hierarchies more pleasant:
46+
47+ ```haskell
48+ rootClient :: RootApi (AsClientT ClientM)
49+ rootClient = client (Proxy @API)
50+
51+ helloClient :: String -> ClientM String
52+ helloClient name = rootClient // hello /: name
53+
54+ endpointClient :: ClientM Person
55+ endpointClient = rootClient // subApi /: "foobar123" // endpoint
56+
57+ type Api = NamedRoutes RootApi
58+
59+ data RootApi mode = RootApi
60+ { subApi :: mode :- Capture "token" String :> NamedRoutes SubApi
61+ , hello :: mode :- Capture "name" String :> Get '[JSON] String
62+ , …
63+ } deriving Generic
64+
65+ data SubApi mode = SubApi
66+ { endpoint :: mode :- Get '[JSON] Person
67+ , …
68+ } deriving Generic
69+ ```
70+
71+- Add custom type errors for partially applied combinators
72+ ([#1289](https://github.com/haskell-servant/servant/pull/1289),
73+ [#1486](https://github.com/haskell-servant/servant/pull/1486)).
74+
75+ For example, forgetting to document the expected type for a query parameter,
76+ as in:
77+
78+ ``` haskell
79+ type API = QueryParam "param" :> Get '[JSON] NoContent
80+ ```
81+
82+ will raise to the following error when trying to serve the API:
83+
84+ ```
85+ • There is no instance for HasServer (QueryParam'
86+ '[Optional, Strict] "param" :> ...)
87+ QueryParam' '[Optional, Strict] "1" expects 1 more arguments
88+ ```
89+
90+ As a consequence of this change, unsaturated types are now forbidden before `(:>)`.
91+
92+- Add a `HeadNoContent` verb ([#1502](https://github.com/haskell-servant/servant/pull/1502)).
93+
94+- *servant-client* / *servant-client-core* / *servant-http-streams*:
95+ Fix erroneous behavior, where only 2XX status codes would be considered
96+ successful, irrelevant of the status parameter specified by the verb
97+ combinator. ([#1469](https://github.com/haskell-servant/servant/pull/1469))
98+
99+- *servant-client* / *servant-client-core*: Fix `Show` instance for
100+ `Servant.Client.Core.Request`.
101+
102+
103+- *servant-client* / *servant-client-core*: Allow passing arbitrary binary data
104+ in Query parameters.
105+ ([#1432](https://github.com/haskell-servant/servant/pull/1432)).
106+
107+- *servant-docs*: Generate sample cURL requests
108+ ([#1401](https://github.com/haskell-servant/servant/pull/1401/files)).
109+
110+ Breaking change: requires sample header values to be supplied with `headers`.
111+
112+### Other changes
113+
114+- Various bit rotten cookbooks have been updated and re-introduced on
115+ [docs.servant.dev](https://docs.servant.dev).
116+
117+- Various version bumps.
118+
30.18.3
1190.18.3
4------
120------
5
121
servant/servant.cabal+13−10
@@ -1,6 +1,6 @@
1−cabal-version: >=1.10
1+cabal-version: 2.2
2name: servant
2name: servant
3−version: 0.18.3
3+version: 0.19
4
4
5synopsis: A family of combinators for defining webservices APIs
5synopsis: A family of combinators for defining webservices APIs
6category: Servant, Web
6category: Servant, Web
@@ -13,7 +13,7 @@ description:
13
13
14homepage: http://docs.servant.dev/
14homepage: http://docs.servant.dev/
15bug-reports: http://github.com/haskell-servant/servant/issues
15bug-reports: http://github.com/haskell-servant/servant/issues
16−license: BSD3
16+license: BSD-3-Clause
17license-file: LICENSE
17license-file: LICENSE
18author: Servant Contributors
18author: Servant Contributors
19maintainer: haskell-servant-maintainers@googlegroups.com
19maintainer: haskell-servant-maintainers@googlegroups.com
@@ -46,6 +46,7 @@ library
46 Servant.API.HttpVersion
46 Servant.API.HttpVersion
47 Servant.API.IsSecure
47 Servant.API.IsSecure
48 Servant.API.Modifiers
48 Servant.API.Modifiers
49+ Servant.API.NamedRoutes
49 Servant.API.QueryParam
50 Servant.API.QueryParam
50 Servant.API.Raw
51 Servant.API.Raw
51 Servant.API.RemoteHost
52 Servant.API.RemoteHost
@@ -54,6 +55,7 @@ library
54 Servant.API.Status
55 Servant.API.Status
55 Servant.API.Stream
56 Servant.API.Stream
56 Servant.API.Sub
57 Servant.API.Sub
58+ Servant.API.TypeErrors
57 Servant.API.TypeLevel
59 Servant.API.TypeLevel
58 Servant.API.UVerb
60 Servant.API.UVerb
59 Servant.API.UVerb.Union
61 Servant.API.UVerb.Union
@@ -78,12 +80,13 @@ library
78 --
80 --
79 -- note: mtl lower bound is so low because of GHC-7.8
81 -- note: mtl lower bound is so low because of GHC-7.8
80 build-depends:
82 build-depends:
81− base >= 4.9 && < 4.16
83+ base >= 4.9 && < 4.17
82 , bytestring >= 0.10.8.1 && < 0.12
84 , bytestring >= 0.10.8.1 && < 0.12
85+ , constraints >= 0.2
83 , mtl >= 2.2.2 && < 2.3
86 , mtl >= 2.2.2 && < 2.3
84 , sop-core >= 0.4.0.0 && < 0.6
87 , sop-core >= 0.4.0.0 && < 0.6
85 , transformers >= 0.5.2.0 && < 0.6
88 , transformers >= 0.5.2.0 && < 0.6
86− , text >= 1.2.3.0 && < 1.3
89+ , text >= 1.2.3.0 && < 2.1
87
90
88
91
89 -- We depend (heavily) on the API of these packages:
92 -- We depend (heavily) on the API of these packages:
@@ -95,15 +98,15 @@ library
95 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.
98 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.
96 -- Here can be exceptions if we really need features from the newer versions.
99 -- Here can be exceptions if we really need features from the newer versions.
97 build-depends:
100 build-depends:
98− base-compat >= 0.10.5 && < 0.12
101+ base-compat >= 0.10.5 && < 0.13
99− , aeson >= 1.4.1.0 && < 1.6
102+ , aeson >= 1.4.1.0 && < 3
100 , attoparsec >= 0.13.2.2 && < 0.15
103 , attoparsec >= 0.13.2.2 && < 0.15
101 , bifunctors >= 5.5.3 && < 5.6
104 , bifunctors >= 5.5.3 && < 5.6
102 , case-insensitive >= 1.2.0.11 && < 1.3
105 , case-insensitive >= 1.2.0.11 && < 1.3
103 , deepseq >= 1.4.2.0 && < 1.5
106 , deepseq >= 1.4.2.0 && < 1.5
104 , http-media >= 0.7.1.3 && < 0.9
107 , http-media >= 0.7.1.3 && < 0.9
105 , http-types >= 0.12.2 && < 0.13
108 , http-types >= 0.12.2 && < 0.13
106− , mmorph >= 1.1.2 && < 1.2
109+ , mmorph >= 1.1.2 && < 1.3
107 , network-uri >= 2.6.1.0 && < 2.7
110 , network-uri >= 2.6.1.0 && < 2.7
108 , QuickCheck >= 2.12.6.1 && < 2.15
111 , QuickCheck >= 2.12.6.1 && < 2.15
109 , string-conversions >= 0.4.0.1 && < 0.5
112 , string-conversions >= 0.4.0.1 && < 0.5
@@ -163,9 +166,9 @@ test-suite spec
163
166
164 -- Additional dependencies
167 -- Additional dependencies
165 build-depends:
168 build-depends:
166− hspec >= 2.6.0 && < 2.9
169+ hspec >= 2.6.0 && < 2.10
167 , QuickCheck >= 2.12.6.1 && < 2.15
170 , QuickCheck >= 2.12.6.1 && < 2.15
168 , quickcheck-instances >= 0.3.19 && < 0.4
171 , quickcheck-instances >= 0.3.19 && < 0.4
169
172
170 build-tool-depends:
173 build-tool-depends:
171− hspec-discover:hspec-discover >= 2.6.0 && < 2.9
174+ hspec-discover:hspec-discover >= 2.6.0 && < 2.10
servant/src/Servant/API.hs+9
@@ -36,6 +36,10 @@ module Servant.API (
36 module Servant.API.Verbs,
36 module Servant.API.Verbs,
37 module Servant.API.UVerb,
37 module Servant.API.UVerb,
38
38
39+ -- * Sub-APIs defined as records of routes
40+ module Servant.API.NamedRoutes,
41+ module Servant.API.Generic,
42+
39 -- * Streaming endpoints, distinguished by HTTP method
43 -- * Streaming endpoints, distinguished by HTTP method
40 module Servant.API.Stream,
44 module Servant.API.Stream,
41
45
@@ -99,6 +103,9 @@ import Servant.API.Fragment
99 (Fragment)
103 (Fragment)
100import Servant.API.Header
104import Servant.API.Header
101 (Header, Header')
105 (Header, Header')
106+import Servant.API.Generic
107+ (GenericMode ((:-)), AsApi, ToServant, ToServantApi, GServantProduct,
108+ GenericServant, fromServant, toServant, genericApi)
102import Servant.API.HttpVersion
109import Servant.API.HttpVersion
103 (HttpVersion (..))
110 (HttpVersion (..))
104import Servant.API.IsSecure
111import Servant.API.IsSecure
@@ -130,6 +137,8 @@ import Servant.API.UVerb
130 Unique, WithStatus (..), inject, statusOf)
137 Unique, WithStatus (..), inject, statusOf)
131import Servant.API.Vault
138import Servant.API.Vault
132 (Vault)
139 (Vault)
140+import Servant.API.NamedRoutes
141+ (NamedRoutes)
133import Servant.API.Verbs
142import Servant.API.Verbs
134 (Delete, DeleteAccepted, DeleteNoContent,
143 (Delete, DeleteAccepted, DeleteNoContent,
135 DeleteNonAuthoritative, Get, GetAccepted, GetNoContent,
144 DeleteNonAuthoritative, Get, GetAccepted, GetNoContent,
servant/src/Servant/API/ContentTypes.hs+1−1
@@ -295,7 +295,7 @@ instance {-# OVERLAPPABLE #-}
295-- then this would be taken care of. However there is no more specific instance
295-- then this would be taken care of. However there is no more specific instance
296-- between that and 'MimeRender JSON a', so we do this instead
296-- between that and 'MimeRender JSON a', so we do this instead
297instance {-# OVERLAPPING #-} ( Accept ctyp ) => AllMimeRender '[ctyp] NoContent where
297instance {-# OVERLAPPING #-} ( Accept ctyp ) => AllMimeRender '[ctyp] NoContent where
298− allMimeRender _ _ = map (, "") $ NE.toList $ contentTypes pctyp
298+ allMimeRender _ NoContent = map (, "") $ NE.toList $ contentTypes pctyp
299 where
299 where
300 pctyp = Proxy :: Proxy ctyp
300 pctyp = Proxy :: Proxy ctyp
301
301
servant/src/Servant/API/NamedRoutes.hsnew file+10
@@ -0,0 +1,10 @@
1+{-# LANGUAGE KindSignatures #-}
2+{-# OPTIONS_HADDOCK not-home #-}
3+
4+module Servant.API.NamedRoutes (
5+ -- * NamedRoutes combinator
6+ NamedRoutes
7+ ) where
8+
9+-- | Combinator for embedding a record of named routes into a Servant API type.
10+data NamedRoutes (api :: * -> *)
servant/src/Servant/API/ResponseHeaders.hs+6−11
@@ -3,10 +3,8 @@
3{-# LANGUAGE DeriveFunctor #-}
3{-# LANGUAGE DeriveFunctor #-}
4{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE FlexibleInstances #-}
6−{-# LANGUAGE FunctionalDependencies #-}
7{-# LANGUAGE GADTs #-}
6{-# LANGUAGE GADTs #-}
8−{-# LANGUAGE KindSignatures #-}
7+{-# LANGUAGE FunctionalDependencies #-}
9−{-# LANGUAGE MultiParamTypeClasses #-}
10{-# LANGUAGE PolyKinds #-}
8{-# LANGUAGE PolyKinds #-}
11{-# LANGUAGE ScopedTypeVariables #-}
9{-# LANGUAGE ScopedTypeVariables #-}
12{-# LANGUAGE TypeFamilies #-}
10{-# LANGUAGE TypeFamilies #-}
@@ -51,9 +49,6 @@ import Web.HttpApiData
51
49
52import Prelude ()
50import Prelude ()
53import Prelude.Compat
51import Prelude.Compat
54−import Servant.API.ContentTypes
55− (JSON, PlainText, FormUrlEncoded, OctetStream,
56− MimeRender(..))
57import Servant.API.Header
52import Servant.API.Header
58 (Header)
53 (Header)
59
54
@@ -117,7 +112,7 @@ instance {-# OVERLAPPABLE #-} ( FromHttpApiData v, BuildHeadersTo xs, KnownSymbo
117 `HCons` buildHeadersTo headers
112 `HCons` buildHeadersTo headers
118 Right h -> Header h `HCons` buildHeadersTo headers
113 Right h -> Header h `HCons` buildHeadersTo headers
119
114
120−-- * Getting
115+-- * Getting headers
121
116
122class GetHeaders ls where
117class GetHeaders ls where
123 getHeaders :: ls -> [HTTP.Header]
118 getHeaders :: ls -> [HTTP.Header]
@@ -158,20 +153,20 @@ instance (KnownSymbol h, GetHeadersFromHList rest, ToHttpApiData v)
158 where
153 where
159 getHeaders' hs = getHeadersFromHList $ getHeadersHList hs
154 getHeaders' hs = getHeadersFromHList $ getHeadersHList hs
160
155
161−-- * Adding
156+-- * Adding headers
162
157
163-- We need all these fundeps to save type inference
158-- We need all these fundeps to save type inference
164class AddHeader h v orig new
159class AddHeader h v orig new
165 | h v orig -> new, new -> h, new -> v, new -> orig where
160 | h v orig -> new, new -> h, new -> v, new -> orig where
166 addOptionalHeader :: ResponseHeader h v -> orig -> new -- ^ N.B.: The same header can't be added multiple times
161 addOptionalHeader :: ResponseHeader h v -> orig -> new -- ^ N.B.: The same header can't be added multiple times
167
162
168−
163+-- In this instance, we add a Header on top of something that is already decorated with some headers
169instance {-# OVERLAPPING #-} ( KnownSymbol h, ToHttpApiData v )
164instance {-# OVERLAPPING #-} ( KnownSymbol h, ToHttpApiData v )
170 => AddHeader h v (Headers (fst ': rest) a) (Headers (Header h v ': fst ': rest) a) where
165 => AddHeader h v (Headers (fst ': rest) a) (Headers (Header h v ': fst ': rest) a) where
171 addOptionalHeader hdr (Headers resp heads) = Headers resp (HCons hdr heads)
166 addOptionalHeader hdr (Headers resp heads) = Headers resp (HCons hdr heads)
172
167
168+-- In this instance, 'a' parameter is decorated with a Header.
173−instance {-# OVERLAPPABLE #-} ( KnownSymbol h, ToHttpApiData v
169+instance {-# OVERLAPPABLE #-} ( KnownSymbol h, ToHttpApiData v , new ~ Headers '[Header h v] a)
174− , new ~ (Headers '[Header h v] a) )
175 => AddHeader h v a new where
170 => AddHeader h v a new where
176 addOptionalHeader hdr resp = Headers resp (HCons hdr HNil)
171 addOptionalHeader hdr resp = Headers resp (HCons hdr HNil)
177
172
servant/src/Servant/API/Status.hs+6−1
@@ -1,10 +1,15 @@
1{-# LANGUAGE DataKinds #-}
1{-# LANGUAGE DataKinds #-}
2-- Flexible instances is necessary on GHC 8.4 and earlier
2-- Flexible instances is necessary on GHC 8.4 and earlier
3{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE ScopedTypeVariables #-}
4module Servant.API.Status where
5module Servant.API.Status where
5
6
7+import GHC.TypeLits (KnownNat, natVal)
6import Network.HTTP.Types.Status
8import Network.HTTP.Types.Status
7−import GHC.TypeLits
9+
10+-- | Retrieve a known or unknown Status from a KnownNat
11+statusFromNat :: forall a proxy. KnownNat a => proxy a -> Status
12+statusFromNat = toEnum . fromInteger . natVal
8
13
9-- | Witness that a type-level natural number corresponds to a HTTP status code
14-- | Witness that a type-level natural number corresponds to a HTTP status code
10class KnownNat n => KnownStatus n where
15class KnownNat n => KnownStatus n where
servant/src/Servant/API/TypeErrors.hsnew file+40
@@ -0,0 +1,40 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE PolyKinds #-}
3+{-# LANGUAGE TypeFamilies #-}
4+{-# LANGUAGE TypeOperators #-}
5+{-# LANGUAGE UndecidableInstances #-}
6+
7+-- | This module defines the error messages used in type-level errors.
8+-- Type-level errors can signal non-existing instances, for instance when
9+-- a combinator is not applied to the correct number of arguments.
10+
11+module Servant.API.TypeErrors (
12+ PartialApplication,
13+ NoInstanceFor,
14+ NoInstanceForSub,
15+) where
16+
17+import Data.Kind
18+import GHC.TypeLits
19+
20+-- | No instance exists for @tycls (expr :> ...)@ because
21+-- @expr@ is not recognised.
22+type NoInstanceForSub (tycls :: k) (expr :: k') =
23+ Text "There is no instance for " :<>: ShowType tycls
24+ :<>: Text " (" :<>: ShowType expr :<>: Text " :> ...)"
25+
26+-- | No instance exists for @expr@.
27+type NoInstanceFor (expr :: k) =
28+ Text "There is no instance for " :<>: ShowType expr
29+
30+-- | No instance exists for @tycls (expr :> ...)@ because @expr@ is not fully saturated.
31+type PartialApplication (tycls :: k) (expr :: k') =
32+ NoInstanceForSub tycls expr
33+ :$$: ShowType expr :<>: Text " expects " :<>: ShowType (Arity expr) :<>: Text " more arguments"
34+
35+-- The arity of a combinator, i.e. the number of required arguments.
36+type Arity (ty :: k) = Arity' k
37+
38+type family Arity' (ty :: k) :: Nat where
39+ Arity' (_ -> ty) = 1 + Arity' ty
40+ Arity' _ = 0
servant/src/Servant/API/Verbs.hs+2−1
@@ -128,7 +128,8 @@ type DeleteNoContent = NoContentVerb 'DELETE
128type PatchNoContent = NoContentVerb 'PATCH
128type PatchNoContent = NoContentVerb 'PATCH
129-- | 'PUT' with 204 status code.
129-- | 'PUT' with 204 status code.
130type PutNoContent = NoContentVerb 'PUT
130type PutNoContent = NoContentVerb 'PUT
131−
131+-- | 'HEAD' with 204 status code.
132+type HeadNoContent = NoContentVerb 'HEAD
132
133
133-- ** 205 Reset Content
134-- ** 205 Reset Content
134--
135--
servant/src/Servant/Links.hs+49−1
@@ -1,13 +1,18 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
1{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE FunctionalDependencies #-}
6{-# LANGUAGE FunctionalDependencies #-}
7+{-# LANGUAGE InstanceSigs #-}
6{-# LANGUAGE PolyKinds #-}
8{-# LANGUAGE PolyKinds #-}
9+{-# LANGUAGE QuantifiedConstraints #-}
7{-# LANGUAGE ScopedTypeVariables #-}
10{-# LANGUAGE ScopedTypeVariables #-}
11+{-# LANGUAGE TypeApplications #-}
8{-# LANGUAGE TypeFamilies #-}
12{-# LANGUAGE TypeFamilies #-}
9{-# LANGUAGE TypeOperators #-}
13{-# LANGUAGE TypeOperators #-}
10{-# LANGUAGE UndecidableInstances #-}
14{-# LANGUAGE UndecidableInstances #-}
15+
11{-# OPTIONS_HADDOCK not-home #-}
16{-# OPTIONS_HADDOCK not-home #-}
12
17
13-- | Type safe generation of internal links.
18-- | Type safe generation of internal links.
@@ -125,6 +130,7 @@ module Servant.Links (
125) where
130) where
126
131
127import Data.List
132import Data.List
133+import Data.Constraint
128import Data.Proxy
134import Data.Proxy
129 (Proxy (..))
135 (Proxy (..))
130import Data.Singletons.Bool
136import Data.Singletons.Bool
@@ -134,7 +140,7 @@ import qualified Data.Text.Encoding as TE
134import Data.Type.Bool
140import Data.Type.Bool
135 (If)
141 (If)
136import GHC.TypeLits
142import GHC.TypeLits
137− (KnownSymbol, symbolVal)
143+ (KnownSymbol, TypeError, symbolVal)
138import Network.URI
144import Network.URI
139 (URI (..), escapeURIString, isUnreserved)
145 (URI (..), escapeURIString, isUnreserved)
140import Prelude ()
146import Prelude ()
@@ -163,6 +169,8 @@ import Servant.API.IsSecure
163 (IsSecure)
169 (IsSecure)
164import Servant.API.Modifiers
170import Servant.API.Modifiers
165 (FoldRequired)
171 (FoldRequired)
172+import Servant.API.NamedRoutes
173+ (NamedRoutes)
166import Servant.API.QueryParam
174import Servant.API.QueryParam
167 (QueryFlag, QueryParam', QueryParams)
175 (QueryFlag, QueryParam', QueryParams)
168import Servant.API.Raw
176import Servant.API.Raw
@@ -175,6 +183,7 @@ import Servant.API.Stream
175 (Stream, StreamBody')
183 (Stream, StreamBody')
176import Servant.API.Sub
184import Servant.API.Sub
177 (type (:>))
185 (type (:>))
186+import Servant.API.TypeErrors
178import Servant.API.TypeLevel
187import Servant.API.TypeLevel
179import Servant.API.UVerb
188import Servant.API.UVerb
180import Servant.API.Vault
189import Servant.API.Vault
@@ -579,6 +588,34 @@ instance HasLink (Stream m status fr ct a) where
579instance HasLink (UVerb m ct a) where
588instance HasLink (UVerb m ct a) where
580 type MkLink (UVerb m ct a) r = r
589 type MkLink (UVerb m ct a) r = r
581 toLink toA _ = toA
590 toLink toA _ = toA
591+-- Instance for NamedRoutes combinator
592+
593+type GLinkConstraints routes a =
594+ ( MkLink (ToServant routes AsApi) a ~ ToServant routes (AsLink a)
595+ , GenericServant routes (AsLink a)
596+ )
597+
598+class GLink (routes :: * -> *) (a :: *) where
599+ gLinkProof :: Dict (GLinkConstraints routes a)
600+
601+instance GLinkConstraints routes a => GLink routes a where
602+ gLinkProof = Dict
603+
604+instance
605+ ( HasLink (ToServantApi routes)
606+ , forall a. GLink routes a
607+ ) => HasLink (NamedRoutes routes) where
608+
609+ type MkLink (NamedRoutes routes) a = routes (AsLink a)
610+
611+ toLink
612+ :: forall a. (Link -> a)
613+ -> Proxy (NamedRoutes routes)
614+ -> Link
615+ -> routes (AsLink a)
616+
617+ toLink toA _ l = case gLinkProof @routes @a of
618+ Dict -> fromServant $ toLink toA (Proxy @(ToServantApi routes)) l
582
619
583-- AuthProtext instances
620-- AuthProtext instances
584instance HasLink sub => HasLink (AuthProtect tag :> sub) where
621instance HasLink sub => HasLink (AuthProtect tag :> sub) where
@@ -608,3 +645,14 @@ simpleToLink _ toA _ = toLink toA (Proxy :: Proxy sub)
608-- $setup
645-- $setup
609-- >>> import Servant.API
646-- >>> import Servant.API
610-- >>> import Data.Text (Text)
647-- >>> import Data.Text (Text)
648+
649+-- Erroring instance for 'HasLink' when a combinator is not fully applied
650+instance TypeError (PartialApplication HasLink arr) => HasLink ((arr :: a -> b) :> sub)
651+ where
652+ type MkLink (arr :> sub) _ = TypeError (PartialApplication (HasLink :: * -> Constraint) arr)
653+ toLink = error "unreachable"
654+
655+-- Erroring instances for 'HasLink' for unknown API combinators
656+instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub HasLink ty) => HasLink (ty :> sub)
657+
658+instance {-# OVERLAPPABLE #-} TypeError (NoInstanceFor (HasLink api)) => HasLink api
servant/src/Servant/Types/SourceT.hs+1−1
@@ -319,7 +319,7 @@ fromActionStep stop action = loop where
319-- | Read file.
319-- | Read file.
320--
320--
321-- >>> foreach fail BS.putStr (readFile "servant.cabal")
321-- >>> foreach fail BS.putStr (readFile "servant.cabal")
322−-- cabal-version: >=1.10
322+-- cabal-version: 2.2
323-- name: servant
323-- name: servant
324-- ...
324-- ...
325--
325--
servant/test/Servant/API/ContentTypesSpec.hs+11
@@ -33,6 +33,8 @@ import Data.String.Conversions
33import qualified Data.Text as TextS
33import qualified Data.Text as TextS
34import qualified Data.Text.Encoding as TextSE
34import qualified Data.Text.Encoding as TextSE
35import qualified Data.Text.Lazy as TextL
35import qualified Data.Text.Lazy as TextL
36+import Control.Exception
37+ (evaluate)
36import GHC.Generics
38import GHC.Generics
37import Test.Hspec
39import Test.Hspec
38import Test.QuickCheck
40import Test.QuickCheck
@@ -78,6 +80,15 @@ spec = describe "Servant.API.ContentTypes" $ do
78 it "has mimeUnrender reverse mimeRender for valid top-level json " $ do
80 it "has mimeUnrender reverse mimeRender for valid top-level json " $ do
79 property $ \x -> mimeUnrender p (mimeRender p x) == Right (x::SomeData)
81 property $ \x -> mimeUnrender p (mimeRender p x) == Right (x::SomeData)
80
82
83+ describe "The NoContent Content-Type type" $ do
84+ let p = Proxy :: Proxy '[JSON]
85+
86+ it "does not render any content" $
87+ allMimeRender p NoContent `shouldSatisfy` (all (BSL8.null . snd))
88+
89+ it "evaluates the NoContent value" $
90+ evaluate (allMimeRender p (undefined :: NoContent)) `shouldThrow` anyErrorCall
91+
81 describe "The PlainText Content-Type type" $ do
92 describe "The PlainText Content-Type type" $ do
82 let p = Proxy :: Proxy PlainText
93 let p = Proxy :: Proxy PlainText
83
94
stack.yaml+1
@@ -11,6 +11,7 @@ packages:
11- servant-conduit
11- servant-conduit
12- servant-machines/
12- servant-machines/
13- servant-pipes/
13- servant-pipes/
14+- servant-swagger/
14
15
15# allow-newer: true # ignores all bounds, that's a sledgehammer
16# allow-newer: true # ignores all bounds, that's a sledgehammer
16# - doc/tutorial/
17# - doc/tutorial/