git.iko.soy/servant
on master help sign in
swap
aaeee88206 ahead, 0 behind
.github/run-ghcjs-tests.shnew file+14
since splitsnapshots
unifiedsplit
@@ -0,0 +1,14 @@
1+#!/usr/bin/env bash
2+#
3+# cabal v2-test does not work with GHCJS
4+# See: https://github.com/haskell/cabal/issues/6175
5+#
6+# This invokes cabal-plan to figure out test binaries, and invokes them with node.
7+
8+cabal-plan list-bins '*:test:*' | while read -r line
9+do
10+ testpkg=$(echo "$line" | perl -pe 's/:.*//')
11+ testexe=$(echo "$line" | awk '{ print $2 }')
12+ echo "testing $textexe in package $textpkg"
13+ (cd "$testpkg" && node "$testexe".jsexe/all.js)
14+done
.github/workflows/master.yml+66−100
@@ -13,15 +13,14 @@ 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.0.2"
19− - "8.2.2"
20− - "8.4.4"
21 - "8.6.5"
18 - "8.6.5"
22 - "8.8.4"
19 - "8.8.4"
23− - "8.10.4"
20+ - "8.10.7"
24− - "9.0.1"
21+ - "9.0.2"
22+ - "9.2.2"
23+ - "9.4.2"
25
24
26 steps:
25 steps:
27 - uses: actions/checkout@v2
26 - uses: actions/checkout@v2
@@ -50,10 +49,7 @@ jobs:
50
49
51 - name: Configure
50 - name: Configure
52 run: |
51 run: |
53− # Using separate store-dir because default one already has 'ghc-paths' package installed
54− # with hardcoded path to ghcup's GHC path (which it was built with). This leads to failure in
55− # doctest, as it tries to invoke that GHC, and it doesn't exist here.
56− cabal --store-dir /tmp/cabal-store install --ignore-project -j2 doctest --constraint='doctest ^>=0.18'
52+ cabal install --ignore-project -j2 doctest --constraint='doctest ^>=0.20'
57
53
58 - name: Build
54 - name: Build
59 run: |
55 run: |
@@ -64,95 +60,74 @@ jobs:
64 cabal test all
60 cabal test all
65
61
66 - name: Run doctests
62 - name: Run doctests
67− # doctests are broken on GHC 9 due to compiler bug:
68− # https://gitlab.haskell.org/ghc/ghc/-/issues/19460
69− continue-on-error: ${{ matrix.ghc == '9.0.1' }}
70 run: |
63 run: |
71 # Necessary for doctest to be found in $PATH
64 # Necessary for doctest to be found in $PATH
72 export PATH="$HOME/.cabal/bin:$PATH"
65 export PATH="$HOME/.cabal/bin:$PATH"
73
66
74− # Filter out base-compat-batteries from .ghc.environment.*, as its modules
67+ DOCTEST="cabal repl --with-ghc=doctest --ghc-options=-w"
75− # conflict with those of base-compat.
76− #
77− # FIXME: This is an ugly hack. Ultimately, we'll want to use cabal-doctest
78− # (or cabal v2-doctest, if it ever lands) to provide a clean GHC environment.
79− # This might allow running doctests in GHCJS build as well.
80− perl -i -e 'while (<ARGV>) { print unless /package-id\s+(base-compat-batteries)-\d+(\.\d+)*/; }' .ghc.environment.*
81−
82− (cd servant && doctest src)
68+ (cd servant && eval $DOCTEST)
83− (cd servant-client && doctest src)
69+ (cd servant-client && eval $DOCTEST)
84− (cd servant-client-core && doctest src)
70+ (cd servant-client-core && eval $DOCTEST)
85− (cd servant-http-streams && doctest src)
71+ (cd servant-http-streams && eval $DOCTEST)
86− (cd servant-docs && doctest src)
72+ (cd servant-docs && eval $DOCTEST)
87− (cd servant-foreign && doctest src)
73+ (cd servant-foreign && eval $DOCTEST)
88− (cd servant-server && doctest src)
74+ (cd servant-server && eval $DOCTEST)
89− (cd servant-machines && doctest src)
75+ (cd servant-machines && eval $DOCTEST)
90− (cd servant-conduit && doctest src)
76+ (cd servant-conduit && eval $DOCTEST)
91− (cd servant-pipes && doctest src)
77+ (cd servant-pipes && eval $DOCTEST)
92−
78+
93− stack:
79+ # stack:
94− name: stack / ghc ${{ matrix.ghc }}
80+ # name: stack / ghc ${{ matrix.ghc }}
95− runs-on: ubuntu-latest
81+ # runs-on: ubuntu-latest
96− strategy:
82+ # strategy:
97− matrix:
83+ # matrix:
98− stack: ["2.3.1"]
84+ # stack: ["2.7.5"]
99− ghc: ["8.8.4"]
85+ # ghc: ["8.10.7"]
100−
86+
101− steps:
87+ # steps:
102− - uses: actions/checkout@v2
88+ # - uses: actions/checkout@v2
103−
89+
104− - uses: haskell/actions/setup@v1
90+ # - uses: haskell/actions/setup@v1
105− name: Setup Haskell Stack
91+ # name: Setup Haskell Stack
106− with:
92+ # with:
107− ghc-version: ${{ matrix.ghc }}
93+ # ghc-version: ${{ matrix.ghc }}
108− stack-version: ${{ matrix.stack }}
94+ # stack-version: ${{ matrix.stack }}
109−
95+
110− - uses: actions/cache@v2.1.3
96+ # - uses: actions/cache@v2.1.3
111− name: Cache ~/.stack
97+ # name: Cache ~/.stack
112− with:
98+ # with:
113− path: ~/.stack
99+ # path: ~/.stack
114− key: ${{ runner.os }}-${{ matrix.ghc }}-stack
100+ # key: ${{ runner.os }}-${{ matrix.ghc }}-stack
115−
101+
116− - name: Install dependencies
102+ # - name: Install dependencies
117− run: |
103+ # run: |
118− stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks --only-dependencies
104+ # stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks --only-dependencies
119−
105+
120− - name: Build
106+ # - name: Build
121− run: |
107+ # run: |
122− stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks
108+ # stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks
123−
109+
124− - name: Test
110+ # - name: Test
125− run: |
111+ # run: |
126− stack test --system-ghc
112+ # stack test --system-ghc
127
113
128 ghcjs:
114 ghcjs:
129− name: ubuntu-18.04 / ghcjs 8.4
115+ name: ubuntu-latest / ghcjs 8.6
130− runs-on: "ubuntu-18.04"
116+ runs-on: "ubuntu-latest"
131
117
132 steps:
118 steps:
133 - uses: actions/checkout@v2
119 - uses: actions/checkout@v2
134−
120+ - uses: cachix/install-nix-action@v13
135− - name: "Setup PATH"
121+ with:
136− run: |
122+ extra_nix_config: |
137− echo "PATH=$HOME/.cabal/bin:/opt/ghcjs/8.4/bin:$PATH" >> $GITHUB_ENV
123+ trusted-public-keys = ryantrinkle.com-1:JJiAKaRv9mWgpVAz8dwewnZe0AzzEAzPkagE9SP5NWI=1aba6f367982bd6dd78ec2fda75ab246a62d32c5 cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY=
138−
124+ substituters = https://nixcache.reflex-frp.org https://cache.nixos.org/
139− - name: Install ghcjs and cabal
125+ - name: Setup
140 run: |
126 run: |
141− # Default GitHub image dropped ppa:hvr/ghc, so we add it ourselves
142− sudo add-apt-repository ppa:hvr/ghc
143− sudo add-apt-repository ppa:hvr/ghcjs
144− sudo apt-get update -y
145− sudo apt-get install ghcjs-8.4
146− sudo apt-get install cabal-install
147−
148 # Override cabal.project with the lightweight GHCJS one
127 # Override cabal.project with the lightweight GHCJS one
149 cp cabal.ghcjs.project cabal.project
128 cp cabal.ghcjs.project cabal.project
150 cat cabal.project
129 cat cabal.project
151−
152− - name: Cabal update and freeze
153− run: |
154− cabal v2-update
130+ nix-shell ghcjs.nix --run "cabal v2-update && cabal v2-freeze"
155− cabal v2-freeze
156
131
157 - uses: actions/cache@v2.1.3
132 - uses: actions/cache@v2.1.3
158 name: Cache ~/.cabal/store and dist-newstyle
133 name: Cache ~/.cabal/store and dist-newstyle
@@ -160,23 +135,14 @@ jobs:
160 path: |
135 path: |
161 ~/.cabal/store
136 ~/.cabal/store
162 dist-newstyle
137 dist-newstyle
163− key: ubuntu-18.04-ghcjs8.4-${{ hashFiles('cabal.project.freeze') }}
138+ key: ${{ runner.os }}-ghcjs8.6-${{ hashFiles('cabal.project.freeze') }}
164 restore-keys: |
139 restore-keys: |
165− ubuntu-18.04-ghcjs8.4-
140+ ${{ runner.os }}-ghcjs8.6-
166−
167− - name: Install cabal-plan and hspec-discover
168− run: |
169− cabal v2-install -w /opt/ghc/8.4.4/bin/ghc --ignore-project cabal-plan --constraint='cabal-plan ^>=0.6.0.0' --constraint='cabal-plan +exe'
170− cabal v2-install -w /opt/ghc/8.4.4/bin/ghc --ignore-project hspec-discover
171
141
172 - name: Build
142 - name: Build
173 run: |
143 run: |
174− cabal v2-build --ghcjs -w /opt/ghcjs/8.4/bin/ghcjs --enable-tests --enable-benchmarks all
144+ nix-shell ghcjs.nix --run "cabal v2-build --ghcjs --enable-tests --enable-benchmarks all"
175
145
176− - name: Run tests
146+ - name: Tests
177 run: |
147 run: |
178− # cabal v2-test does not work with GHCJS
148+ nix-shell ghcjs.nix --run ".github/run-ghcjs-tests.sh"
179− # See: https://github.com/haskell/cabal/issues/6175
180− #
181− # This invokes cabal-plan to figure out test binaries, and invokes them with node.
182− cabal-plan list-bins '*:test:*' | while read -r line; do testpkg=$(echo "$line" | perl -pe 's/:.*//'); testexe=$(echo "$line" | awk '{ print $2 }'); echo "testing $textexe in package $textpkg"; (cd "$(pkgdir $testpkg)" && nodejs "$testexe".jsexe/all.js); done
.gitignore+2
@@ -30,6 +30,8 @@ doc/_build
30doc/venv
30doc/venv
31doc/tutorial/static/api.js
31doc/tutorial/static/api.js
32doc/tutorial/static/jq.js
32doc/tutorial/static/jq.js
33+shell.nix
34+.hspec-failures
33
35
34# nix
36# nix
35result*
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
Makefiledeleted−32
@@ -1,32 +0,0 @@
1−# With common maintenance tasks
2−
3−HC ?= ghc-8.4.4
4−
5−all :
6− @echo "Don't try to make all at once!"
7−
8−really-all :
9− $(MAKE) build-ghc
10− $(MAKE) build-ghc HC=ghc-8.0.2
11− $(MAKE) build-ghc HC=ghc-8.2.2
12− $(MAKE) build-ghc HC=ghc-8.6.5
13− $(MAKE) build-ghcjs
14−
15−build-ghc :
16− cabal v2-build -w $(HC) all
17−
18−build-ghcjs :
19− cabal v2-build --builddir=dist-newstyle-ghcjs --project-file=cabal.ghcjs.project all
20−
21−packdeps :
22− packdeps */*.cabal
23−
24−doctest : doctest-servant doctest-servant-server
25− perl -i -e 'while (<ARGV>) { print unless /package-id\s+base-compat-\d+(\.\d+)*/; }' .ghc.environment.*
26−
27−doctest-servant :
28− (cd servant && doctest src)
29− (cd servant && doctest test/Servant/LinksSpec.hs)
30−
31−doctest-servant-server :
32− (cd servant-server && doctest src)
cabal.ghcjs.project+5
@@ -2,8 +2,13 @@
2
2
3packages:
3packages:
4 servant/
4 servant/
5+ servant-client/
5 servant-client-core/
6 servant-client-core/
6
7
7-- we need to tell cabal we are using GHCJS
8-- we need to tell cabal we are using GHCJS
8compiler: ghcjs
9compiler: ghcjs
9tests: True
10tests: True
11+
12+-- Constraints so that reflex-platform provided packages are selected.
13+constraints: attoparsec == 0.13.2.2
14+constraints: hashable == 1.3.0.0
cabal.project+11−28
@@ -1,11 +1,18 @@
1packages:
1packages:
2 servant/
2 servant/
3+ servant-auth/servant-auth
4+ servant-auth/servant-auth-client
5+ servant-auth/servant-auth-docs
6+ servant-auth/servant-auth-server
7+ servant-auth/servant-auth-swagger
8+
3 servant-client/
9 servant-client/
4 servant-client-core/
10 servant-client-core/
5 servant-http-streams/
11 servant-http-streams/
6 servant-docs/
12 servant-docs/
7 servant-foreign/
13 servant-foreign/
8 servant-server/
14 servant-server/
15+ servant-swagger/
9 doc/tutorial/
16 doc/tutorial/
10
17
11-- servant streaming
18-- servant streaming
@@ -25,47 +32,23 @@ packages:
25 doc/cookbook/custom-errors
32 doc/cookbook/custom-errors
26 doc/cookbook/basic-streaming
33 doc/cookbook/basic-streaming
27 doc/cookbook/db-postgres-pool
34 doc/cookbook/db-postgres-pool
28− --doc/cookbook/db-sqlite-simple
35+ doc/cookbook/db-sqlite-simple
29− -- ^ BROKEN blaze-textual
30 doc/cookbook/file-upload
36 doc/cookbook/file-upload
31 doc/cookbook/generic
37 doc/cookbook/generic
32 doc/cookbook/hoist-server-with-context
38 doc/cookbook/hoist-server-with-context
33 doc/cookbook/https
39 doc/cookbook/https
34− -- doc/cookbook/jwt-and-basic-auth/
40+ doc/cookbook/jwt-and-basic-auth
35 doc/cookbook/pagination
41 doc/cookbook/pagination
36 -- doc/cookbook/sentry
42 -- doc/cookbook/sentry
37 -- Commented out because servant-quickcheck currently doesn't build.
43 -- Commented out because servant-quickcheck currently doesn't build.
38 -- doc/cookbook/testing
44 -- doc/cookbook/testing
39− --doc/cookbook/uverb
45+ doc/cookbook/uverb
40− -- ^ BROKEN servant-swagger -> optics-th
41 doc/cookbook/structuring-apis
46 doc/cookbook/structuring-apis
42 doc/cookbook/using-custom-monad
47 doc/cookbook/using-custom-monad
43 doc/cookbook/using-free-client
48 doc/cookbook/using-free-client
44 -- doc/cookbook/open-id-connect
49 -- doc/cookbook/open-id-connect
50+ doc/cookbook/managed-resource
45
51
46tests: True
52tests: True
47optimization: False
53optimization: False
48-- reorder-goals: True
54-- reorder-goals: True
49−
50−constraints:
51− -- see https://github.com/haskell-infra/hackage-trustees/issues/119
52− foundation >=0.0.14,
53− memory <0.14.12 || >0.14.12
54−
55−constraints: base-compat ^>=0.11
56−constraints: semigroups ^>=0.19
57−
58−-- allow-newer: sqlite-simple-0.4.16.0:semigroups
59−-- allow-newer: direct-sqlite-2.3.24:semigroups
60−
61−-- needed for doctests
62−write-ghc-environment-files: always
63−
64−-- https://github.com/chordify/haskell-servant-pagination/pull/12
65−allow-newer: servant-pagination-2.2.2:servant
66−allow-newer: servant-pagination-2.2.2:servant-server
67−
68−allow-newer: servant-js:servant
69−
70−-- ghc 9
71−allow-newer: tdigest:base
changelog.d/1432new file+9
@@ -0,0 +1,9 @@
1+synopsis: Fixes encoding of URL parameters in servant-client
2+prs: #1432
3+issues: #1418
4+description: {
5+Some applications use query parameters to pass arbitrary (non-unicode) binary
6+data. This change modifies how servant-client handles query parameters, so
7+that application developers can use `ToHttpApiData` to marshal binary data into
8+query parameters.
9+}
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/1477new file+9
@@ -0,0 +1,9 @@
1+synopsis: Enable FlexibleContexts in Servant.API.ContentTypes
2+prs: #1477
3+
4+description: {
5+
6+Starting with GHC 9.2, UndecidableInstances no longer implies FlexibleContexts.
7+Add this extension where it's needed to make compilation succeed.
8+
9+}
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/1571new file+10
@@ -0,0 +1,10 @@
1+synopsis: Support UVerb in servant-auth-server
2+prs: #1571
3+issues: #1570
4+description: {
5+UVerb endpoints are now supported by servant-auth-server and can be used under the
6+Auth combinator when writing servers. It is still unsupported by
7+servant-auth-client.
8+
9+This PR also brings Headers support in UVerb responses
10+}
changelog.d/1573new file+2
@@ -0,0 +1,2 @@
1+synopsis: Add API docs for ServerT
2+prs: #1573
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
changelog.d/1606new file+10
@@ -0,0 +1,10 @@
1+synopsis: Handle Cookies correctly for RunStreamingClient
2+prs: #1606
3+issues: #1605
4+
5+description: {
6+
7+Makes performWithStreamingRequest take into consideration the
8+CookieJar, which it previously didn't.
9+
10+}
changelog.d/1638new file+2
@@ -0,0 +1,2 @@
1+synopsis: Add Functor instance to AuthHandler.
2+prs: #1638
changelog.d/1649new file+8
@@ -0,0 +1,8 @@
1+synopsis: Add HasStatus instance for Headers (that defers StatusOf to underlying value)
2+prs: #1649
3+
4+description: {
5+
6+Adds a new HasStatus (Headers hs a) instance (StatusOf (Headers hs a) = StatusOf a)
7+
8+}
changelog.d/servant-docs-curlnew file+16
@@ -0,0 +1,16 @@
1+synopsis: Add sample cURL requests to generated documentation
2+prs: #1401
3+
4+description: {
5+
6+Add sample cURL requests to generated documentation.
7+
8+Those supplying changes to the Request `header` field manually using
9+lenses will need to add a sample bytestring value.
10+
11+`headers <>~ ["unicorn"]`
12+
13+becomes
14+
15+`headers <>~ [("unicorn", "sample value")]`
16+}
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+3−3
@@ -1,14 +1,14 @@
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
11−tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.3, GHC ==8.10.1
11+tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
12
12
13executable cookbook-basic-auth
13executable cookbook-basic-auth
14 main-is: BasicAuth.lhs
14 main-is: BasicAuth.lhs
doc/cookbook/basic-streaming/basic-streaming.cabal+3−3
@@ -1,14 +1,14 @@
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
11−tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.3, GHC ==8.10.1
11+tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
12
12
13executable cookbook-basic-streaming
13executable cookbook-basic-streaming
14 main-is: Streaming.lhs
14 main-is: Streaming.lhs
doc/cookbook/curl-mock/CurlMock.lhs−1
@@ -24,7 +24,6 @@ Language extensions and imports:
24import Control.Lens ((^.))
24import Control.Lens ((^.))
25import Data.Aeson
25import Data.Aeson
26import Data.Aeson.Text
26import Data.Aeson.Text
27−import Data.Monoid ((<>))
28import Data.Proxy (Proxy (Proxy))
27import Data.Proxy (Proxy (Proxy))
29import Data.Text (Text)
28import Data.Text (Text)
30import Data.Text.Encoding (decodeUtf8)
29import Data.Text.Encoding (decodeUtf8)
doc/cookbook/curl-mock/curl-mock.cabal+6−3
@@ -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
11−tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.3, GHC ==8.10.1
11+tested-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/CustomErrors.lhs−1
@@ -20,7 +20,6 @@ Extensions and imports:
20import Data.Aeson
20import Data.Aeson
21import Data.Proxy
21import Data.Proxy
22import Data.Text
22import Data.Text
23−import Data.Semigroup
24import GHC.Generics
23import GHC.Generics
25import Network.Wai
24import Network.Wai
26import Network.Wai.Handler.Warp
25import Network.Wai.Handler.Warp
doc/cookbook/custom-errors/custom-errors.cabal+3−3
@@ -1,14 +1,14 @@
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
11−tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.3, GHC ==8.10.1
11+tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
12
12
13executable cookbook-custom-errors
13executable cookbook-custom-errors
14 main-is: CustomErrors.lhs
14 main-is: CustomErrors.lhs
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+3−3
@@ -1,14 +1,14 @@
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
11−tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.3, GHC ==8.10.1
11+tested-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
14 main-is: PostgresPool.lhs
14 main-is: PostgresPool.lhs
doc/cookbook/db-sqlite-simple/db-sqlite-simple.cabal+3−3
@@ -1,14 +1,14 @@
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
11−tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.3, GHC ==8.10.1
11+tested-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
14 main-is: DBConnection.lhs
14 main-is: DBConnection.lhs
doc/cookbook/file-upload/file-upload.cabal+3−3
@@ -1,14 +1,14 @@
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
11−tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.3, GHC ==8.10.1
11+tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
12
12
13executable cookbook-file-upload
13executable cookbook-file-upload
14 main-is: FileUpload.lhs
14 main-is: FileUpload.lhs
doc/cookbook/generic/generic.cabal+3−3
@@ -1,14 +1,14 @@
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
11−tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.3, GHC ==8.10.1
11+tested-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
14 main-is: Generic.lhs
14 main-is: Generic.lhs
doc/cookbook/hoist-server-with-context/hoist-server-with-context.cabal+3−5
@@ -1,17 +1,17 @@
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
14−tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.3, GHC ==8.10.1
14+tested-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
17 main-is: HoistServerWithContext.lhs
17 main-is: HoistServerWithContext.lhs
@@ -32,8 +32,6 @@ executable cookbook-hoist-server-with-context
32 , http-types >= 0.12
32 , http-types >= 0.12
33 , bytestring >= 0.10.4
33 , bytestring >= 0.10.4
34 , mtl
34 , mtl
35− if impl(ghc < 8.2.1)
36− buildable: False
37 default-language: Haskell2010
35 default-language: Haskell2010
38 ghc-options: -Wall -pgmL markdown-unlit
36 ghc-options: -Wall -pgmL markdown-unlit
39 build-tool-depends: markdown-unlit:markdown-unlit
37 build-tool-depends: markdown-unlit:markdown-unlit
doc/cookbook/https/https.cabal+3−3
@@ -1,14 +1,14 @@
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
11−tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.3, GHC ==8.10.1
11+tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
12
12
13executable cookbook-https
13executable cookbook-https
14 main-is: Https.lhs
14 main-is: Https.lhs
doc/cookbook/index.rst+3−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,
@@ -37,3 +37,4 @@ you name it!
37 sentry/Sentry.lhs
37 sentry/Sentry.lhs
38 testing/Testing.lhs
38 testing/Testing.lhs
39 open-id-connect/OpenIdConnect.lhs
39 open-id-connect/OpenIdConnect.lhs
40+ managed-resource/ManagedResource.lhs
doc/cookbook/jwt-and-basic-auth/jwt-and-basic-auth.cabal+4−4
@@ -1,17 +1,17 @@
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
14−tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.3, GHC ==8.10.1
14+tested-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
17 main-is: JWTAndBasicAuth.lhs
17 main-is: JWTAndBasicAuth.lhs
@@ -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/managed-resource/ManagedResource.lhsnew file+114
@@ -0,0 +1,114 @@
1+# Request-lifetime Managed Resources
2+
3+Let's see how we can write a handle that uses a resource managed by Servant. The resource is created automatically by Servant when the server recieves a request, and the resource is automatically destroyed when the server is finished handling a request.
4+
5+As usual, we start with a little bit of throat clearing.
6+
7+
8+``` haskell
9+{-# LANGUAGE DataKinds #-}
10+{-# LANGUAGE TypeOperators #-}
11+import Control.Concurrent
12+import Control.Exception (bracket, throwIO)
13+import Control.Monad.IO.Class
14+import Control.Monad.Trans.Resource
15+import Data.Acquire
16+import Network.HTTP.Client (newManager, defaultManagerSettings)
17+import Network.Wai.Handler.Warp
18+import Servant
19+import Servant.Client
20+import System.IO
21+```
22+
23+Here we define an API type that uses the `WithResource` combinator. The server handler for an endpoint with a `WithResource res` component will receive a value of that type as an argument.
24+
25+``` haskell
26+type API = WithResource Handle :> ReqBody '[PlainText] String :> Post '[JSON] NoContent
27+
28+api :: Proxy API
29+api = Proxy
30+```
31+
32+But this resource value has to come from somewhere. Servant obtains the value using an Acquire provided in the context. The Acquire knows how to both create and destroy resources of a particular type.
33+
34+``` haskell
35+appContext :: Context '[Acquire Handle]
36+appContext = acquireHandle :. EmptyContext
37+
38+acquireHandle :: Acquire Handle
39+acquireHandle = mkAcquire newHandle closeHandle
40+
41+newHandle :: IO Handle
42+newHandle = do
43+ putStrLn "opening file"
44+ h <- openFile "test.txt" AppendMode
45+ putStrLn "opened file"
46+ return h
47+
48+closeHandle :: Handle -> IO ()
49+closeHandle h = do
50+ putStrLn "closing file"
51+ hClose h
52+ putStrLn "closed file"
53+```
54+
55+Now we create the handler which will use this resource. This handler will write the request message to the System.IO.Handle which was provided to us. In some situations the handler will succeed, but in some in will fail. In either case, Servant will clean up the resource for us.
56+
57+``` haskell
58+server :: Server API
59+server = writeToFile
60+
61+ where writeToFile :: (ReleaseKey, Handle) -> String -> Handler NoContent
62+ writeToFile (_, h) msg = case msg of
63+ "illegal" -> error "wait, that's illegal!"
64+ legalMsg -> liftIO $ do
65+ putStrLn "writing file"
66+ hPutStrLn h legalMsg
67+ putStrLn "wrote file"
68+ return NoContent
69+```
70+
71+Finally we run the server in the background while we post messages to it.
72+
73+``` haskell
74+runApp :: IO ()
75+runApp = run 8080 (serveWithContext api appContext $ server)
76+
77+postMsg :: String -> ClientM NoContent
78+postMsg = client api
79+
80+main :: IO ()
81+main = do
82+ mgr <- newManager defaultManagerSettings
83+ bracket (forkIO $ runApp) killThread $ \_ -> do
84+ ms <- flip runClientM (mkClientEnv mgr (BaseUrl Http "localhost" 8080 "")) $ do
85+ liftIO $ putStrLn "sending hello message"
86+ _ <- postMsg "hello"
87+ liftIO $ putStrLn "sending illegal message"
88+ _ <- postMsg "illegal"
89+ liftIO $ putStrLn "done"
90+ print ms
91+```
92+
93+This program prints
94+
95+```
96+sending hello message
97+opening file
98+opened file
99+writing file
100+wrote file
101+closing file
102+closed file
103+sending illegal message
104+opening file
105+opened file
106+closing file
107+closed file
108+wait, that's illegal!
109+CallStack (from HasCallStack):
110+ error, called at ManagedResource.lhs:63:24 in main:Main
111+Left (FailureResponse (Request {requestPath = (BaseUrl {baseUrlScheme = Http, baseUrlHost = "localhost", baseUrlPort = 8080, baseUrlPath = ""},""), requestQueryString = fromList [], requestBody = Just ((),text/plain;charset=utf-8), requestAccept = fromList [], requestHeaders = fromList [], requestHttpVersion = HTTP/1.1, requestMethod = "POST"}) (Response {responseStatusCode = Status {statusCode = 500, statusMessage = "Internal Server Error"}, responseHeaders = fromList [("Transfer-Encoding","chunked"),("Date","Thu, 24 Nov 2022 21:04:47 GMT"),("Server","Warp/3.3.23"),("Content-Type","text/plain; charset=utf-8")], responseHttpVersion = HTTP/1.1, responseBody = "Something went wrong"}))
112+```
113+
114+and appends to a file called `test.txt`. We can see from the output that when a legal message is sent, the file is opened, written to, and closed. We can also see that when an illegal message is sent, the file is opened but not written to. Crucially, it is still closed even though the handler threw an exception.
doc/cookbook/managed-resource/managed-resource.cabalnew file+30
@@ -0,0 +1,30 @@
1+cabal-version: 2.2
2+name: cookbook-managed-resource
3+version: 0.1
4+synopsis: Simple managed resource cookbook example
5+homepage: http://docs.servant.dev/
6+license: BSD-3-Clause
7+license-file: ../../../servant/LICENSE
8+author: Servant Contributors
9+maintainer: haskell-servant-maintainers@googlegroups.com
10+build-type: Simple
11+tested-with: GHC==9.4.2
12+
13+executable cookbook-managed-resource
14+ main-is: ManagedResource.lhs
15+ build-depends: base == 4.*
16+ , text >= 1.2
17+ , aeson >= 1.2
18+ , servant
19+ , servant-client
20+ , servant-server
21+ , warp >= 3.2
22+ , wai >= 3.2
23+ , http-types >= 0.12
24+ , markdown-unlit >= 0.4
25+ , http-client >= 0.5
26+ , transformers
27+ , resourcet
28+ default-language: Haskell2010
29+ ghc-options: -Wall -pgmL markdown-unlit
30+ build-tool-depends: markdown-unlit:markdown-unlit
doc/cookbook/open-id-connect/OpenIdConnect.cabal+3−3
@@ -1,14 +1,14 @@
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
11−tested-with: GHC==8.4.4, GHC==8.6.5
11+tested-with: GHC==8.6.5
12
12
13executable cookbook-openidconnect
13executable cookbook-openidconnect
14 main-is: OpenIdConnect.lhs
14 main-is: OpenIdConnect.lhs
doc/cookbook/open-id-connect/OpenIdConnect.lhs+1−1
@@ -330,7 +330,7 @@ data Customer = Customer {
330```
330```
331
331
332Here is the code that displays the homepage.
332Here is the code that displays the homepage.
333−It should contain a link to the the `/login` URL.
333+It should contain a link to the `/login` URL.
334When the user clicks on this link it will be redirected to Google login page
334When the user clicks on this link it will be redirected to Google login page
335with some generated information.
335with some generated information.
336
336
doc/cookbook/pagination/pagination.cabal+3−3
@@ -1,14 +1,14 @@
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
11−tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.3, GHC ==8.10.1
11+tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
12
12
13executable cookbook-pagination
13executable cookbook-pagination
14 main-is: Pagination.lhs
14 main-is: Pagination.lhs
doc/cookbook/sentry/sentry.cabal+3−3
@@ -1,14 +1,14 @@
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
11−tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.3, GHC ==8.10.1
11+tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
12
12
13executable cookbook-sentry
13executable cookbook-sentry
14 main-is: Sentry.lhs
14 main-is: Sentry.lhs
doc/cookbook/structuring-apis/structuring-apis.cabal+3−3
@@ -1,14 +1,14 @@
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
11−tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.3, GHC ==8.10.1
11+tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
12
12
13executable cookbook-structuring-apis
13executable cookbook-structuring-apis
14 main-is: StructuringApis.lhs
14 main-is: StructuringApis.lhs
doc/cookbook/testing/testing.cabal+3−3
@@ -1,16 +1,16 @@
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
13−tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.3, GHC ==8.10.1
13+tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
14
14
15executable cookbook-testing
15executable cookbook-testing
16 main-is: Testing.lhs
16 main-is: Testing.lhs
doc/cookbook/using-custom-monad/using-custom-monad.cabal+3−3
@@ -1,14 +1,14 @@
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
11−tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.3, GHC ==8.10.1
11+tested-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
14 main-is: UsingCustomMonad.lhs
14 main-is: UsingCustomMonad.lhs
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+3−3
@@ -1,14 +1,14 @@
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
11−tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.3, GHC ==8.10.1
11+tested-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
14 main-is: UsingFreeClient.lhs
14 main-is: UsingFreeClient.lhs
doc/cookbook/uverb/UVerb.lhs+1−1
@@ -199,7 +199,7 @@ parsers in the hope that the ones that should will always error out so
199you can try until the right one returns a value.)
199you can try until the right one returns a value.)
200
200
201[servant-exceptions](https://github.com/ch1bo/servant-exceptions) is
201[servant-exceptions](https://github.com/ch1bo/servant-exceptions) is
202−another shot at at the problem. It is inspired by
202+another shot at the problem. It is inspired by
203servant-checked-exceptions, so it may be worth taking a closer look.
203servant-checked-exceptions, so it may be worth taking a closer look.
204The README claims that
204The README claims that
205[cardano-sl](https://github.com/input-output-hk/cardano-sl) also has
205[cardano-sl](https://github.com/input-output-hk/cardano-sl) also has
doc/cookbook/uverb/uverb.cabal+5−5
@@ -1,16 +1,16 @@
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
13−tested-with: GHC==8.6.5, GHC==8.8.4, GHC==8.10.1
13+tested-with: GHC==8.6.5, GHC==8.8.4, GHC==8.10.7
14
14
15executable cookbook-uverb
15executable cookbook-uverb
16 main-is: UVerb.lhs
16 main-is: UVerb.lhs
@@ -28,8 +28,8 @@ executable cookbook-uverb
28 , swagger2
28 , swagger2
29 , wai
29 , wai
30 , warp
30 , warp
31− if impl(ghc < 8.6.1)
31+ if impl(ghc >= 9)
32− buildable: False
32+ buildable: False
33 default-language: Haskell2010
33 default-language: Haskell2010
34 ghc-options: -Wall -pgmL markdown-unlit
34 ghc-options: -Wall -pgmL markdown-unlit
35 build-tool-depends: markdown-unlit:markdown-unlit
35 build-tool-depends: markdown-unlit:markdown-unlit
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/requirements.txt+1
@@ -1,3 +1,4 @@
1recommonmark==0.5.0
1recommonmark==0.5.0
2Sphinx==1.8.4
2Sphinx==1.8.4
3sphinx_rtd_theme>=0.4.2
3sphinx_rtd_theme>=0.4.2
4+jinja2<3.1.0
doc/tutorial/ApiType.lhs+27
@@ -389,3 +389,30 @@ One example for this is if you want to serve a directory of static files along
389with the rest of your API. But you can plug in everything that is an
389with the rest of your API. But you can plug in everything that is an
390`Application`, e.g. a whole web application written in any of the web
390`Application`, e.g. a whole web application written in any of the web
391frameworks that support `wai`.
391frameworks that support `wai`.
392+
393+Be mindful! The `servant-server`'s router works by pattern-matching the
394+different routes that are composed using `:<|>`. `Raw`, as an escape hatch,
395+matches any route that hasn't been matched by previous patterns. Therefore,
396+any subsequent route will be silently ignored.
397+
398+``` haskell
399+type UserAPI14 = Raw
400+ :<|> "users" :> Get '[JSON] [User]
401+ -- In this situation, the /users endpoint
402+ -- will not be reachable because the Raw
403+ -- endpoint matches requests before
404+```
405+A simple way to avoid this pitfall is to either use `Raw` as the last
406+definition, or to always have it under a static path.
407+
408+``` haskell
409+type UserAPI15 = "files" :> Raw
410+ -- The raw endpoint is under the /files
411+ -- static path, so it won't match /users.
412+ :<|> "users" :> Get '[JSON] [User]
413+
414+type UserAPI16 = "users" :> Get '[JSON] [User]
415+ :<|> Raw
416+ -- The Raw endpoint is matched last, so
417+ -- it won't overlap another endpoint.
418+```
doc/tutorial/Authentication.lhs+1−2
@@ -47,7 +47,6 @@ module Authentication where
47import Data.Aeson (ToJSON)
47import Data.Aeson (ToJSON)
48import Data.ByteString (ByteString)
48import Data.ByteString (ByteString)
49import Data.Map (Map, fromList)
49import Data.Map (Map, fromList)
50−import Data.Monoid ((<>))
51import qualified Data.Map as Map
50import qualified Data.Map as Map
52import Data.Proxy (Proxy (Proxy))
51import Data.Proxy (Proxy (Proxy))
53import Data.Text (Text)
52import Data.Text (Text)
@@ -133,7 +132,7 @@ combinator. Using `Context`, we can supply a function of type
133handler. This will allow the handler to check authentication and return a `User`
132handler. This will allow the handler to check authentication and return a `User`
134to downstream handlers if successful.
133to downstream handlers if successful.
135
134
136−In practice we wrap `BasicAuthData -> Handler` into a slightly
135+In practice we wrap `BasicAuthData -> Handler User` into a slightly
137different function to better capture the semantics of basic authentication:
136different function to better capture the semantics of basic authentication:
138
137
139``` haskell ignore
138``` haskell ignore
doc/tutorial/index.rst+1−37
@@ -6,46 +6,10 @@ This is an introductory tutorial to **servant**. Whilst browsing is fine, it mak
6Any comments, issues or feedback about the tutorial can be submitted
6Any comments, issues or feedback about the tutorial can be submitted
7to `servant's issue tracker <http://github.com/haskell-servant/servant/issues>`_.
7to `servant's issue tracker <http://github.com/haskell-servant/servant/issues>`_.
8
8
9−cabal-install
10−--------
11−
12−The whole tutorial is a `cabal <https://cabal.readthedocs.io/en/latest/>`_
13−project and can be built locally as follows:
14−
15−.. code-block:: bash
16−
17− $ git clone https://github.com/haskell-servant/servant.git
18− $ cd servant
19− # build
20− $ cabal new-build tutorial
21− # load in ghci to play with it
22− $ cabal new-repl tutorial
23−
24−stack
25−--------
26−
27−The servant `stack <https://docs.haskellstack.org/en/stable/README/>`_ template includes the working tutorial. To initialize this template, run:
28−
29−.. code-block:: bash
30−
31− $ stack new myproj servant
32− $ cd myproj
33− # build
34− $ stack build
35− # start server
36− $ stack exec myproj-exe
37−
38−The code can be found in the `*.lhs` files under `doc/tutorial/` in the
39−repository. Feel free to edit it while you're reading this documentation and
40−see the effect of your changes.
41−
42−`Nix <https://nixos.org/nix/>`_ users should feel free to take a look at
43−the `nix/shell.nix` file in the repository and use it to provision a suitable
44−environment to build and run the examples.
45−
46.. toctree::
9.. toctree::
47 :maxdepth: 1
10 :maxdepth: 1
48
11
12+ install.rst
49 ApiType.lhs
13 ApiType.lhs
50 Server.lhs
14 Server.lhs
51 Client.lhs
15 Client.lhs
doc/tutorial/install.rstnew file+68
@@ -0,0 +1,68 @@
1+Install
2+========
3+
4+cabal-install
5+--------
6+
7+The whole tutorial is a `cabal <https://cabal.readthedocs.io/en/latest/>`_
8+project and can be built locally as follows:
9+
10+.. code-block:: bash
11+
12+ $ git clone https://github.com/haskell-servant/servant.git
13+ $ cd servant
14+ # build
15+ $ cabal new-build tutorial
16+ # load in ghci to play with it
17+ $ cabal new-repl tutorial
18+
19+stack
20+--------
21+
22+The servant `stack <https://docs.haskellstack.org/en/stable/README/>`_ template includes the working tutorial. To initialize this template, run:
23+
24+.. code-block:: bash
25+
26+ $ stack new myproj servant
27+ $ cd myproj
28+ # build
29+ $ stack build
30+ # start server
31+ $ stack exec myproj-exe
32+
33+The code can be found in the `*.lhs` files under `doc/tutorial/` in the
34+repository. Feel free to edit it while you're reading this documentation and
35+see the effect of your changes.
36+
37+nix
38+--------
39+
40+`Nix <https://nixos.org/nix/>`_ users should feel free to take a look at
41+the `nix/shell.nix` file in the repository and use it to provision a suitable
42+environment 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+4−7
@@ -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,18 +7,14 @@ 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.0.2
17− GHC==8.2.2
18− GHC==8.4.4
19 GHC==8.6.5
16 GHC==8.6.5
20− GHC==8.8.3, GHC ==8.10.1
17+ GHC==8.8.3, GHC ==8.10.7
21extra-source-files:
18extra-source-files:
22 static/index.html
19 static/index.html
23 static/ui.js
20 static/ui.js
@@ -67,7 +64,7 @@ library
67 , blaze-markup >= 0.8.0.0 && < 0.9
64 , blaze-markup >= 0.8.0.0 && < 0.9
68 , cookie >= 0.4.3 && < 0.5
65 , cookie >= 0.4.3 && < 0.5
69 , js-jquery >= 3.3.1 && < 3.4
66 , js-jquery >= 3.3.1 && < 3.4
70− , lucid >= 2.9.11 && < 2.10
67+ , lucid >= 2.9.11 && < 2.12
71 , random >= 1.1 && < 1.3
68 , random >= 1.1 && < 1.3
72 , servant-js >= 0.9 && < 0.10
69 , servant-js >= 0.9 && < 0.10
73 , time >= 1.6.0.1 && < 1.13
70 , time >= 1.6.0.1 && < 1.13
ghcjs.nixnew file+22
@@ -0,0 +1,22 @@
1+let reflex-platform = import (builtins.fetchTarball
2+ { name = "reflex-platform";
3+ url = "https://github.com/reflex-frp/reflex-platform/archive/1aba6f367982bd6dd78ec2fda75ab246a62d32c5.tar.gz";
4+ }) {};
5+ pkgs = import ./nix/nixpkgs.nix; in
6+
7+pkgs.stdenv.mkDerivation {
8+ name = "ghcjs-shell";
9+ buildInputs =
10+ [ (reflex-platform.ghcjs.ghcWithPackages (p: with p; [
11+ attoparsec
12+ hashable
13+ ]))
14+ pkgs.cabal-install
15+ pkgs.gmp
16+ pkgs.haskellPackages.cabal-plan
17+ pkgs.haskellPackages.hspec-discover
18+ pkgs.nodejs
19+ pkgs.perl
20+ pkgs.zlib
21+ ];
22+}
nix/README.md+15−3
@@ -23,7 +23,19 @@ $ nix-shell nix/shell.nix --argstr compiler ghcHEAD
23```
23```
24
24
25**Possible GHC versions**
25**Possible GHC versions**
26−- `ghc822Binary`
26+- `ghc865Binary`
27−- `ghc865`
28- `ghc884`
27- `ghc884`
29−- `ghc8102` - default
28+- `ghc8104` - default
29+- `ghc901`
30+
31+### Cabal users
32+
33+GHC version can be chosen via the nix-shell parameter
34+
35+`cabal build all`
36+
37+### Stack version
38+
39+Since the ghc version is set by the LTS version, it is preferable to use the `ghc8104` version parameter for the nix-shell.
40+
41+`stack --no-nix --system-ghc <command>`
nix/nixpkgs.nixnew file+4
@@ -0,0 +1,4 @@
1+import (builtins.fetchTarball {
2+ url = "https://github.com/NixOS/nixpkgs/archive/refs/tags/21.05.tar.gz";
3+ sha256 = "sha256:1ckzhh24mgz6jd1xhfgx0i9mijk6xjqxwsshnvq789xsavrmsc36";
4+}) {}
nix/shell.nix+3−8
@@ -1,11 +1,6 @@
1−let nixos = fetchTarball {
2− url = "https://releases.nixos.org/nixos/20.09/nixos-20.09.3505.12d9950bf47/nixexprs.tar.xz";
3− sha256 = "0fsl8bsdb8i536pfs4wrp0826h5l84xqlwx32sbz66jg4ykqp9lr";
4−}; in
5−
6−{ compiler ? "ghc8102"
1+{ compiler ? "ghc8104"
7, tutorial ? false
2, tutorial ? false
8−, pkgs ? import nixos { config = {}; }
3+, pkgs ? import ./nixpkgs.nix
9}:
4}:
10
5
11 with pkgs;
6 with pkgs;
@@ -16,7 +11,7 @@ let nixos = fetchTarball {
16 in
11 in
17 stdenv.mkDerivation {
12 stdenv.mkDerivation {
18 name = "servant-dev";
13 name = "servant-dev";
19− buildInputs = [ ghc zlib python3 wget cabal-install postgresql openssl ]
14+ buildInputs = [ ghc zlib python3 wget cabal-install postgresql openssl stack haskellPackages.hspec-discover ]
20 ++ (if tutorial then [docstuffs postgresql] else []);
15 ++ (if tutorial then [docstuffs postgresql] else []);
21 shellHook = ''
16 shellHook = ''
22 eval $(grep export ${ghc}/bin/ghc)
17 eval $(grep export ${ghc}/bin/ghc)
servant-auth/README.mdnew file+1
@@ -0,0 +1 @@
1+servant-auth-server/README.lhs
servant-auth/servant-auth-client/.ghcinew file+1
@@ -0,0 +1 @@
1+:set -isrc -itest -idoctest/ghci-wrapper/src
servant-auth/servant-auth-client/CHANGELOG.mdnew file+26
@@ -0,0 +1,26 @@
1+# Changelog
2+
3+All notable changes to this project will be documented in this file.
4+
5+The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/)
6+and this project adheres to [PVP Versioning](https://pvp.haskell.org/).
7+
8+## [Unreleased]
9+
10+## [0.4.1.0] - 2020-10-06
11+
12+- Support generic Bearer token auth
13+
14+## [0.4.0.0] - 2019-03-08
15+
16+## Changed
17+
18+- #145 Support servant-0.16 in tests @domenkozar
19+- #145 Drop GHC 7.10 support @domenkozar
20+
21+## [0.3.3.0] - 2018-06-18
22+
23+### Added
24+- Support for GHC 8.4 by @phadej
25+- Support for servant-0.14 by @phadej
26+- Changelog by @domenkozar
servant-auth/servant-auth-client/LICENSEnew file+31
@@ -0,0 +1,31 @@
1+Copyright Julian K. Arni (c) 2015
2+
3+All rights reserved.
4+
5+Redistribution and use in source and binary forms, with or without
6+modification, are permitted provided that the following conditions are met:
7+
8+ * Redistributions of source code must retain the above copyright
9+ notice, this list of conditions and the following disclaimer.
10+
11+ * Redistributions in binary form must reproduce the above
12+ copyright notice, this list of conditions and the following
13+ disclaimer in the documentation and/or other materials provided
14+ with the distribution.
15+
16+ * Neither the name of Julian K. Arni nor the names of other
17+ contributors may be used to endorse or promote products derived
18+ from this software without specific prior written permission.
19+
20+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31+
servant-auth/servant-auth-client/Setup.hsnew file+2
@@ -0,0 +1,2 @@
1+import Distribution.Simple
2+main = defaultMain
servant-auth/servant-auth-client/servant-auth-client.cabalnew file+80
@@ -0,0 +1,80 @@
1+cabal-version: 2.2
2+name: servant-auth-client
3+version: 0.4.1.0
4+synopsis: servant-client/servant-auth compatibility
5+description: This package provides instances that allow generating clients from
6+ <https://hackage.haskell.org/package/servant servant>
7+ APIs that use
8+ <https://hackage.haskell.org/package/servant-auth servant-auth's> @Auth@ combinator.
9+ .
10+ For a quick overview of the usage, see the <https://github.com/haskell-servant/servant/tree/master/servant-auth#readme README>.
11+category: Web, Servant, Authentication
12+homepage: https://github.com/haskell-servant/servant/tree/master/servant-auth#readme
13+bug-reports: https://github.com/haskell-servant/servant/issues
14+author: Julian K. Arni
15+maintainer: jkarni@gmail.com
16+copyright: (c) Julian K. Arni
17+license: BSD-3-Clause
18+license-file: LICENSE
19+tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1
20+build-type: Simple
21+extra-source-files:
22+ CHANGELOG.md
23+
24+source-repository head
25+ type: git
26+ location: https://github.com/haskell-servant/servant
27+
28+library
29+ hs-source-dirs:
30+ src
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
33+ build-depends:
34+ base >= 4.10 && < 4.18
35+ , bytestring >= 0.10.6.0 && < 0.12
36+ , containers >= 0.5.6.2 && < 0.7
37+ , servant-auth == 0.4.*
38+ , servant >= 0.13 && < 0.20
39+ , servant-client-core >= 0.13 && < 0.20
40+
41+ exposed-modules:
42+ Servant.Auth.Client
43+ Servant.Auth.Client.Internal
44+ default-language: Haskell2010
45+
46+test-suite spec
47+ type: exitcode-stdio-1.0
48+ main-is: Spec.hs
49+ hs-source-dirs:
50+ test
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
53+ build-tool-depends: hspec-discover:hspec-discover >=2.5.5 && <2.10
54+
55+ -- dependencies with bounds inherited from the library stanza
56+ build-depends:
57+ base
58+ , servant-client
59+ , servant-auth
60+ , servant
61+ , servant-auth-client
62+
63+ -- test dependencies
64+ build-depends:
65+ hspec >= 2.5.5 && < 2.10
66+ , QuickCheck >= 2.11.3 && < 2.15
67+ , aeson >= 1.3.1.1 && < 3
68+ , bytestring >= 0.10.6.0 && < 0.12
69+ , http-client >= 0.5.13.1 && < 0.8
70+ , http-types >= 0.12.2 && < 0.13
71+ , servant-auth-server >= 0.4.2.0 && < 0.5
72+ , servant-server >= 0.13 && < 0.20
73+ , time >= 1.5.0.1 && < 1.13
74+ , transformers >= 0.4.2.0 && < 0.6
75+ , wai >= 3.2.1.2 && < 3.3
76+ , warp >= 3.2.25 && < 3.4
77+ , jose >= 0.10 && < 0.11
78+ other-modules:
79+ Servant.Auth.ClientSpec
80+ default-language: Haskell2010
servant-auth/servant-auth-client/src/Servant/Auth/Client.hsnew file+3
@@ -0,0 +1,3 @@
1+module Servant.Auth.Client (Token(..), Bearer) where
2+
3+import Servant.Auth.Client.Internal (Bearer, Token(..))
servant-auth/servant-auth-client/src/Servant/Auth/Client/Internal.hsnew file+64
@@ -0,0 +1,64 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3+{-# LANGUAGE UndecidableInstances #-}
4+{-# OPTIONS_GHC -fno-warn-orphans #-}
5+#if __GLASGOW_HASKELL__ == 800
6+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
7+#endif
8+module Servant.Auth.Client.Internal where
9+
10+import qualified Data.ByteString as BS
11+import Data.Monoid
12+import Data.Proxy (Proxy (..))
13+import Data.String (IsString)
14+import GHC.Exts (Constraint)
15+import GHC.Generics (Generic)
16+import Servant.API ((:>))
17+import Servant.Auth
18+
19+import Servant.Client.Core
20+import Data.Sequence ((<|))
21+
22+-- | A simple bearer token.
23+newtype Token = Token { getToken :: BS.ByteString }
24+ deriving (Eq, Show, Read, Generic, IsString)
25+
26+type family HasBearer xs :: Constraint where
27+ HasBearer (Bearer ': xs) = ()
28+ HasBearer (JWT ': xs) = ()
29+ HasBearer (x ': xs) = HasBearer xs
30+ HasBearer '[] = BearerAuthNotEnabled
31+
32+class BearerAuthNotEnabled
33+
34+-- | @'HasBearer' auths@ is nominally a redundant constraint, but ensures we're not
35+-- trying to send a token to an API that doesn't accept them.
36+instance (HasBearer auths, HasClient m api) => HasClient m (Auth auths a :> api) where
37+ type Client m (Auth auths a :> api) = Token -> Client m api
38+
39+ clientWithRoute m _ req (Token token)
40+ = clientWithRoute m (Proxy :: Proxy api)
41+ $ req { requestHeaders = ("Authorization", headerVal) <| requestHeaders req }
42+ where
43+ headerVal = "Bearer " <> token
44+
45+#if MIN_VERSION_servant_client_core(0,14,0)
46+ hoistClientMonad pm _ nt cl = hoistClientMonad pm (Proxy :: Proxy api) nt . cl
47+#endif
48+
49+
50+-- * Authentication combinators
51+
52+-- | A Bearer token in the Authorization header:
53+--
54+-- @Authorization: Bearer <token>@
55+--
56+-- This can be any token recognized by the server, for example,
57+-- a JSON Web Token (JWT).
58+--
59+-- Note that, since the exact way the token is validated is not specified,
60+-- this combinator can only be used in the client. The server would not know
61+-- how to validate it, while the client does not care.
62+-- If you want to implement Bearer authentication in your server, you have to
63+-- choose a specific combinator, such as 'JWT'.
64+data Bearer
servant-auth/servant-auth-client/test/Servant/Auth/ClientSpec.hsnew file+161
@@ -0,0 +1,161 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DeriveAnyClass #-}
3+module Servant.Auth.ClientSpec (spec) where
4+
5+import Crypto.JOSE (JWK,
6+ KeyMaterialGenParam (OctGenParam),
7+ genJWK)
8+import Data.Aeson (FromJSON (..), ToJSON (..))
9+import qualified Data.ByteString.Lazy as BSL
10+import Data.Time (UTCTime, defaultTimeLocale,
11+ parseTimeOrError)
12+import GHC.Generics (Generic)
13+import Network.HTTP.Client (Manager, defaultManagerSettings,
14+ newManager)
15+import Network.HTTP.Types (status401)
16+import Network.Wai.Handler.Warp (testWithApplication)
17+import Servant
18+import Servant.Client (BaseUrl (..), Scheme (Http),
19+ ClientError (FailureResponse),
20+#if MIN_VERSION_servant_client(0,16,0)
21+ ResponseF(..),
22+#elif MIN_VERSION_servant_client(0,13,0)
23+ GenResponse(..),
24+#elif MIN_VERSION_servant_client(0,12,0)
25+ Response(..),
26+#endif
27+ client)
28+import System.IO.Unsafe (unsafePerformIO)
29+import Test.Hspec
30+import Test.QuickCheck
31+
32+#if MIN_VERSION_servant_client(0,13,0)
33+import Servant.Client (mkClientEnv, runClientM)
34+#elif MIN_VERSION_servant_client(0,9,0)
35+import Servant.Client (ClientEnv (..), runClientM)
36+#else
37+import Control.Monad.Trans.Except (runExceptT)
38+#endif
39+#if !MIN_VERSION_servant_server(0,16,0)
40+#define ClientError ServantError
41+#endif
42+
43+import Servant.Auth.Client
44+import Servant.Auth.Server
45+import Servant.Auth.Server.SetCookieOrphan ()
46+
47+spec :: Spec
48+spec = describe "The JWT combinator" $ do
49+ hasClientSpec
50+
51+
52+------------------------------------------------------------------------------
53+-- * HasClient {{{
54+
55+hasClientSpec :: Spec
56+hasClientSpec = describe "HasClient" $ around (testWithApplication $ return app) $ do
57+
58+ let mkTok :: User -> Maybe UTCTime -> IO Token
59+ mkTok user mexp = do
60+ Right tok <- makeJWT user jwtCfg mexp
61+ return $ Token $ BSL.toStrict tok
62+
63+ it "succeeds when the token does not have expiry" $ \port -> property $ \user -> do
64+ tok <- mkTok user Nothing
65+ v <- getIntClient tok mgr (BaseUrl Http "localhost" port "")
66+ v `shouldBe` Right (length $ name user)
67+
68+ it "succeeds when the token is not expired" $ \port -> property $ \user -> do
69+ tok <- mkTok user (Just future)
70+ v <- getIntClient tok mgr (BaseUrl Http "localhost" port "")
71+ v `shouldBe` Right (length $ name user)
72+
73+ it "fails when token is expired" $ \port -> property $ \user -> do
74+ tok <- mkTok user (Just past)
75+#if MIN_VERSION_servant_client(0,16,0)
76+ Left (FailureResponse _ (Response stat _ _ _))
77+#elif MIN_VERSION_servant_client(0,12,0)
78+ Left (FailureResponse (Response stat _ _ _))
79+#elif MIN_VERSION_servant_client(0,11,0)
80+ Left (FailureResponse _ stat _ _)
81+#else
82+ Left (FailureResponse stat _ _)
83+#endif
84+ <- getIntClient tok mgr (BaseUrl Http "localhost" port "")
85+ stat `shouldBe` status401
86+
87+
88+getIntClient :: Token -> Manager -> BaseUrl -> IO (Either ClientError Int)
89+#if MIN_VERSION_servant(0,13,0)
90+getIntClient tok m burl = runClientM (client api tok) (mkClientEnv m burl)
91+#elif MIN_VERSION_servant(0,9,0)
92+getIntClient tok m burl = runClientM (client api tok) (ClientEnv m burl)
93+#else
94+getIntClient tok m burl = runExceptT $ client api tok m burl
95+#endif
96+-- }}}
97+------------------------------------------------------------------------------
98+-- * API and Server {{{
99+
100+type API = Auth '[JWT] User :> Get '[JSON] Int
101+
102+api :: Proxy API
103+api = Proxy
104+
105+theKey :: JWK
106+theKey = unsafePerformIO . genJWK $ OctGenParam 256
107+{-# NOINLINE theKey #-}
108+
109+mgr :: Manager
110+mgr = unsafePerformIO $ newManager defaultManagerSettings
111+{-# NOINLINE mgr #-}
112+
113+app :: Application
114+app = serveWithContext api ctx server
115+ where
116+ ctx = cookieCfg :. jwtCfg :. EmptyContext
117+
118+jwtCfg :: JWTSettings
119+jwtCfg = defaultJWTSettings theKey
120+
121+cookieCfg :: CookieSettings
122+cookieCfg = defaultCookieSettings
123+
124+
125+server :: Server API
126+server = getInt
127+ where
128+ getInt :: AuthResult User -> Handler Int
129+ getInt (Authenticated u) = return . length $ name u
130+ getInt _ = throwAll err401
131+
132+
133+-- }}}
134+------------------------------------------------------------------------------
135+-- * Utils {{{
136+
137+past :: UTCTime
138+past = parseTimeOrError True defaultTimeLocale "%Y-%m-%d" "1970-01-01"
139+
140+future :: UTCTime
141+future = parseTimeOrError True defaultTimeLocale "%Y-%m-%d" "2070-01-01"
142+
143+
144+-- }}}
145+------------------------------------------------------------------------------
146+-- * Types {{{
147+
148+data User = User
149+ { name :: String
150+ , _id :: String
151+ } deriving (Eq, Show, Read, Generic)
152+
153+instance FromJWT User
154+instance ToJWT User
155+instance FromJSON User
156+instance ToJSON User
157+
158+instance Arbitrary User where
159+ arbitrary = User <$> arbitrary <*> arbitrary
160+
161+-- }}}
servant-auth/servant-auth-client/test/Spec.hsnew file+1
@@ -0,0 +1 @@
1+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
servant-auth/servant-auth-docs/.ghcinew file+1
@@ -0,0 +1 @@
1+:set -isrc -itest -idoctest/ghci-wrapper/src
servant-auth/servant-auth-docs/CHANGELOG.mdnew file+14
@@ -0,0 +1,14 @@
1+# Changelog
2+
3+All notable changes to this project will be documented in this file.
4+
5+The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/)
6+and this project adheres to [PVP Versioning](https://pvp.haskell.org/).
7+
8+## [Unreleased]
9+
10+## [0.2.10.0] - 2018-06-18
11+
12+### Added
13+- Support for GHC 8.4 by @phadej
14+- Changelog by @domenkozar
servant-auth/servant-auth-docs/LICENSEnew file+31
@@ -0,0 +1,31 @@
1+Copyright Julian K. Arni (c) 2015
2+
3+All rights reserved.
4+
5+Redistribution and use in source and binary forms, with or without
6+modification, are permitted provided that the following conditions are met:
7+
8+ * Redistributions of source code must retain the above copyright
9+ notice, this list of conditions and the following disclaimer.
10+
11+ * Redistributions in binary form must reproduce the above
12+ copyright notice, this list of conditions and the following
13+ disclaimer in the documentation and/or other materials provided
14+ with the distribution.
15+
16+ * Neither the name of Julian K. Arni nor the names of other
17+ contributors may be used to endorse or promote products derived
18+ from this software without specific prior written permission.
19+
20+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31+
servant-auth/servant-auth-docs/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-auth/servant-auth-docs/servant-auth-docs.cabalnew file+84
@@ -0,0 +1,84 @@
1+cabal-version: 2.2
2+name: servant-auth-docs
3+version: 0.2.10.0
4+synopsis: servant-docs/servant-auth compatibility
5+description: This package provides instances that allow generating docs from
6+ <https://hackage.haskell.org/package/servant servant>
7+ APIs that use
8+ <https://hackage.haskell.org/package/servant-auth servant-auth's> @Auth@ combinator.
9+ .
10+ For a quick overview of the usage, see the <https://github.com/haskell-servant/servant/tree/master/servant-auth#readme README>.
11+category: Web, Servant, Authentication
12+homepage: https://github.com/haskell-servant/servant/tree/master/servant-auth#readme
13+bug-reports: https://github.com/haskell-servant/servant/issues
14+author: Julian K. Arni
15+maintainer: jkarni@gmail.com
16+copyright: (c) Julian K. Arni
17+license: BSD-3-Clause
18+license-file: LICENSE
19+tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1
20+build-type: Custom
21+extra-source-files:
22+ CHANGELOG.md
23+
24+custom-setup
25+ setup-depends:
26+ base, Cabal, cabal-doctest >=1.0.6 && <1.1
27+
28+source-repository head
29+ type: git
30+ location: https://github.com/haskell-servant/servant
31+
32+library
33+ hs-source-dirs:
34+ src
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
37+ build-depends:
38+ base >= 4.10 && < 4.18
39+ , servant-docs >= 0.11.2 && < 0.13
40+ , servant >= 0.13 && < 0.20
41+ , servant-auth == 0.4.*
42+ , lens >= 4.16.1 && <5.3
43+ exposed-modules:
44+ Servant.Auth.Docs
45+ default-language: Haskell2010
46+
47+test-suite doctests
48+ type: exitcode-stdio-1.0
49+ main-is: doctests.hs
50+ build-depends:
51+ base,
52+ servant-auth-docs,
53+ doctest >= 0.16 && < 0.21,
54+ QuickCheck >= 2.11.3 && < 2.15,
55+ template-haskell
56+ ghc-options: -Wall -threaded
57+ hs-source-dirs: test
58+ default-language: Haskell2010
59+
60+test-suite spec
61+ type: exitcode-stdio-1.0
62+ main-is: Spec.hs
63+ hs-source-dirs:
64+ test
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
67+ build-tool-depends: hspec-discover:hspec-discover >=2.5.5 && <2.10
68+
69+ -- dependencies with bounds inherited from the library stanza
70+ build-depends:
71+ base
72+ , text
73+ , servant-docs
74+ , servant
75+ , servant-auth
76+ , lens
77+
78+ -- test dependencies
79+ build-depends:
80+ servant-auth-docs
81+ , hspec >= 2.5.5 && < 2.10
82+ , QuickCheck >= 2.11.3 && < 2.15
83+
84+ default-language: Haskell2010
servant-auth/servant-auth-docs/src/Servant/Auth/Docs.hsnew file+96
@@ -0,0 +1,96 @@
1+{-# OPTIONS_GHC -fno-warn-orphans #-}
2+module Servant.Auth.Docs
3+ (
4+ -- | The purpose of this package is provide the instance for 'servant-auth'
5+ -- combinators needed for 'servant-docs' documentation generation.
6+ --
7+ -- >>> type API = Auth '[JWT, Cookie, BasicAuth] Int :> Get '[JSON] Int
8+ -- >>> putStr $ markdown $ docs (Proxy :: Proxy API)
9+ -- ## GET /
10+ -- ...
11+ -- ... Authentication
12+ -- ...
13+ -- This part of the API is protected by the following authentication mechanisms:
14+ -- ...
15+ -- * JSON Web Tokens ([JWTs](https://en.wikipedia.org/wiki/JSON_Web_Token))
16+ -- * [Cookies](https://en.wikipedia.org/wiki/HTTP_cookie)
17+ -- * [Basic Authentication](https://en.wikipedia.org/wiki/Basic_access_authentication)
18+ -- ...
19+ -- Clients must supply the following data
20+ -- ...
21+ -- One of the following:
22+ -- ...
23+ -- * A JWT Token signed with this server's key
24+ -- * Cookies automatically set by browsers, plus a header
25+ -- * Cookies automatically set by browsers, plus a header
26+ -- ...
27+
28+ -- * Re-export
29+ JWT
30+ , BasicAuth
31+ , Cookie
32+ , Auth
33+ ) where
34+
35+import Control.Lens ((%~), (&), (|>))
36+import Data.List (intercalate)
37+import Data.Monoid
38+import Data.Proxy (Proxy (Proxy))
39+import Servant.API hiding (BasicAuth)
40+import Servant.Auth
41+import Servant.Docs hiding (pretty)
42+import Servant.Docs.Internal (DocAuthentication (..), authInfo)
43+
44+instance (AllDocs auths, HasDocs api) => HasDocs (Auth auths r :> api) where
45+ docsFor _ (endpoint, action) =
46+ docsFor (Proxy :: Proxy api) (endpoint, action & authInfo %~ (|> info))
47+ where
48+ (intro, reqData) = pretty $ allDocs (Proxy :: Proxy auths)
49+ info = DocAuthentication intro reqData
50+
51+
52+pretty :: [(String, String)] -> (String, String)
53+pretty [] = error "shouldn't happen"
54+pretty [(i, d)] =
55+ ( "This part of the API is protected by " <> i
56+ , d
57+ )
58+pretty rs =
59+ ( "This part of the API is protected by the following authentication mechanisms:\n\n"
60+ ++ " * " <> intercalate "\n * " (fst <$> rs)
61+ , "\nOne of the following:\n\n"
62+ ++ " * " <> intercalate "\n * " (snd <$> rs)
63+ )
64+
65+
66+class AllDocs (x :: [*]) where
67+ allDocs :: proxy x
68+ -- intro, req
69+ -> [(String, String)]
70+
71+instance (OneDoc a, AllDocs as) => AllDocs (a ': as) where
72+ allDocs _ = oneDoc (Proxy :: Proxy a) : allDocs (Proxy :: Proxy as)
73+
74+instance AllDocs '[] where
75+ allDocs _ = []
76+
77+class OneDoc a where
78+ oneDoc :: proxy a -> (String, String)
79+
80+instance OneDoc JWT where
81+ oneDoc _ =
82+ ("JSON Web Tokens ([JWTs](https://en.wikipedia.org/wiki/JSON_Web_Token))"
83+ , "A JWT Token signed with this server's key")
84+
85+instance OneDoc Cookie where
86+ oneDoc _ =
87+ ("[Cookies](https://en.wikipedia.org/wiki/HTTP_cookie)"
88+ , "Cookies automatically set by browsers, plus a header")
89+
90+instance OneDoc BasicAuth where
91+ oneDoc _ =
92+ ( "[Basic Authentication](https://en.wikipedia.org/wiki/Basic_access_authentication)"
93+ , "Cookies automatically set by browsers, plus a header")
94+
95+-- $setup
96+-- >>> instance ToSample Int where toSamples _ = singleSample 1729
servant-auth/servant-auth-docs/test/Spec.hsnew file+1
@@ -0,0 +1 @@
1+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
servant-auth/servant-auth-docs/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-auth/servant-auth-server/.ghcinew file+1
@@ -0,0 +1 @@
1+:set -isrc -itest -idoctest/ghci-wrapper/src
servant-auth/servant-auth-server/CHANGELOG.mdnew file+130
@@ -0,0 +1,130 @@
1+# Changelog
2+
3+All notable changes to this project will be documented in this file.
4+
5+The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/)
6+and this project adheres to [PVP Versioning](https://pvp.haskell.org/).
7+
8+## [Unreleased]
9+
10+## [0.4.6.0] - 2020-10-06
11+
12+## Changed
13+
14+- expose verifyJWT and use it in two places [@domenkozar]
15+- support GHC 8.10 [@domenkozar]
16+- move ToJWT/FromJWT to servant-auth [@erewok]
17+- #165 fix AnySite with Cookie 3.5.0 [@odr]
18+
19+## [0.4.5.1] - 2020-02-06
20+
21+## Changed
22+
23+- #158 servant 0.17 support [@phadej]
24+
25+## [0.4.5.0] - 2019-12-28
26+
27+## Changed
28+- #144 servant 0.16 support and drop GHC 7.10 support [@domenkozar]
29+- #148 removed unused constaint in HasServer instance for Auth
30+- #154 GHC 8.8 support [@phadej]
31+
32+### Added
33+- #141 Support Stream combinator [@domenkozar]
34+- #143 Allow servant-0.16 [@phadej]
35+
36+## [0.4.4.0] - 2019-03-02
37+
38+### Added
39+- #141 Support Stream combinator [@domenkozar]
40+- #143 Allow servant-0.16 [@phadej]
41+
42+## [0.4.3.0] - 2019-01-17
43+
44+## Changed
45+- #117 Avoid running auth checks unnecessarily [@sopvop]
46+- #110 Get rid of crypto-api dependency [@domenkozar]
47+- #130 clearSession: improve cross-browser compatibility [@domenkozar]
48+- #136 weed out bytestring-conversion [@stephenirl]
49+
50+## [0.4.2.0] - 2018-11-05
51+
52+### Added
53+- `Headers hs a` instance for AddSetCookieApi [@domenkozar]
54+- GHC 8.6.x support [@domenkozar]
55+
56+## [0.4.1.0] - 2018-10-05
57+
58+### Added
59+- #125 Allow setting domain name for a cookie [@domenkozar]
60+
61+## Changed
62+- bump http-api-data to 0.3.10 that includes Cookie orphan instances previously located in servant-auth-server [@phadej]
63+- #114 Export `HasSecurity` typeclass [@rockbmb]
64+
65+## [0.4.0.1] - 2018-09-23
66+
67+### Security
68+- #123 Session cookie did not apply SameSite attribute [@domenkozar]
69+
70+### Added
71+- #112 HasLink instance for Auth combinator [@adetokunbo]
72+- #111 Documentation for using hoistServer [@mschristiansen]
73+- #107 Add utility functions for reading and writing a key to a file [@mschristiansen]
74+
75+## [0.4.0.0] - 2018-06-17
76+
77+### Added
78+- Support GHC 8.4 by @phadej and @domenkozar
79+- Support for servant-0.14 by @phadej
80+- #96 Support for jose-0.7 by @xaviershay
81+- #92 add `clearSession` for logout by @plredmond and @3noch
82+- #95 makeJWT: allow setting Alg via defaultJWTSettings by @domenkozar
83+- #89 Validate JWT against a JWKSet instead of JWK by @sopvop
84+
85+### Changed
86+- #92 Rename CSRF to XSRF by @plredmond and @3noch
87+- #92 extract 'XsrfCookieSettings' from 'CookieSettings' and make XSRF checking optional
88+ by @plredmond and @3noch
89+- #69 export SameSite by @domenkozar
90+- #102 Reuse Servant.Api.IsSecure instead of duplicating ADT by @domenkozar
91+
92+### Deprecated
93+- #92 Renamed 'makeCsrfCookie' to 'makeXsrfCookie' and marked the former as deprecated
94+ by @plredmond and @3noc
95+- #92 Made several changes to the structure of 'CookieSettings' which will require
96+ attention by users who have modified the XSRF settings by @plredmond and @3noch
97+
98+### Security
99+- #94 Force cookie expiration on serverside by @karshan
100+
101+## [0.3.2.0] - 2018-02-21
102+
103+### Added
104+- #76 Export wwwAuthenticatedErr and elaborate its annotation by @defanor
105+- Support for servant-0.14 by @phadej
106+
107+### Changed
108+- Disable the readme executable for ghcjs builds by @hamishmack
109+- #84 Make AddSetCookieApi type family open by @qnikst
110+- #79 Make CSRF checks optional for GET requests by @harendra-kumar
111+
112+## [0.3.1.0] - 2017-11-08
113+
114+### Added
115+- Support for servant-0.12 by @phadej
116+
117+## [0.3.0.0] - 2017-11-07
118+
119+### Changed
120+- #47 'cookiePath' and 'xsrfCookiePath' added to 'CookieSettings' by @mchaver
121+
122+## [0.2.8.0] - 2017-05-26
123+
124+### Added
125+- #45 Support for servant-0.11 by @phadej
126+
127+## [0.2.7.0] - 2017-02-11
128+
129+### Changed
130+- #27 #41 'acceptLogin' and 'makeCsrfCookie' functions by @bts
servant-auth/servant-auth-server/LICENSEnew file+31
@@ -0,0 +1,31 @@
1+Copyright Julian K. Arni (c) 2015
2+
3+All rights reserved.
4+
5+Redistribution and use in source and binary forms, with or without
6+modification, are permitted provided that the following conditions are met:
7+
8+ * Redistributions of source code must retain the above copyright
9+ notice, this list of conditions and the following disclaimer.
10+
11+ * Redistributions in binary form must reproduce the above
12+ copyright notice, this list of conditions and the following
13+ disclaimer in the documentation and/or other materials provided
14+ with the distribution.
15+
16+ * Neither the name of Julian K. Arni nor the names of other
17+ contributors may be used to endorse or promote products derived
18+ from this software without specific prior written permission.
19+
20+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31+
servant-auth/servant-auth-server/README.lhsnew file+291
@@ -0,0 +1,291 @@
1+# servant-auth
2+
3+These packages provides safe and easy-to-use authentication options for
4+`servant`. The same API can be protected via:
5+- basicauth
6+- cookies
7+- JWT tokens
8+
9+
10+| Package | Hackage |
11+| -------------------- | ----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- |
12+| servant-auth | [![servant-auth](https://img.shields.io/hackage/v/servant-auth?style=flat-square&logo=haskell&label&labelColor=5D4F85)](https://hackage.haskell.org/package/servant-auth) |
13+| servant-auth-server | [![servant-auth-server](https://img.shields.io/hackage/v/servant-auth-server.svg?style=flat-square&logo=haskell&label&labelColor=5D4F85)](https://hackage.haskell.org/package/servant-auth-server) |
14+| servant-auth-client | [![servant-auth-client](https://img.shields.io/hackage/v/servant-auth-client.svg?style=flat-square&logo=haskell&label&labelColor=5D4F85)](https://hackage.haskell.org/package/servant-auth-client) |
15+| servant-auth-swagger | [![servant-auth-swagger](https://img.shields.io/hackage/v/servant-auth-swagger.svg?style=flat-square&logo=haskell&label&labelColor=5D4F85)](https://hackage.haskell.org/package/servant-auth-swagger) |
16+| servant-auth-docs | [![servant-auth-docs](https://img.shields.io/hackage/v/servant-auth-docs.svg?style=flat-square&logo=haskell&label&labelColor=5D4F85)](https://hackage.haskell.org/package/servant-auth-docs) |
17+
18+## How it works
19+
20+First some imports:
21+
22+~~~ haskell
23+{-# OPTIONS_GHC -fno-warn-unused-binds #-}
24+{-# OPTIONS_GHC -fno-warn-deprecations #-}
25+import Control.Concurrent (forkIO)
26+import Control.Monad (forever)
27+import Control.Monad.Trans (liftIO)
28+import Data.Aeson (FromJSON, ToJSON)
29+import GHC.Generics (Generic)
30+import Network.Wai.Handler.Warp (run)
31+import System.Environment (getArgs)
32+import Servant
33+import Servant.Auth.Server
34+import Servant.Auth.Server.SetCookieOrphan ()
35+~~~
36+
37+`servant-auth` library introduces a combinator `Auth`:
38+
39+~~~ haskell
40+data Auth (auths :: [*]) val
41+~~~
42+
43+What `Auth [Auth1, Auth2] Something :> API` means is that `API` is protected by
44+*either* `Auth1` *or* `Auth2`, and the result of authentication will be of type
45+`AuthResult Something`, where :
46+
47+~~~ haskell
48+data AuthResult val
49+ = BadPassword
50+ | NoSuchUser
51+ | Authenticated val
52+ | Indefinite
53+~~~
54+
55+Your handlers will get a value of type `AuthResult Something`, and can decide
56+what to do with it.
57+
58+~~~ haskell
59+
60+data User = User { name :: String, email :: String }
61+ deriving (Eq, Show, Read, Generic)
62+
63+instance ToJSON User
64+instance ToJWT User
65+instance FromJSON User
66+instance FromJWT User
67+
68+data Login = Login { username :: String, password :: String }
69+ deriving (Eq, Show, Read, Generic)
70+
71+instance ToJSON Login
72+instance FromJSON Login
73+
74+type Protected
75+ = "name" :> Get '[JSON] String
76+ :<|> "email" :> Get '[JSON] String
77+
78+
79+-- | 'Protected' will be protected by 'auths', which we still have to specify.
80+protected :: Servant.Auth.Server.AuthResult User -> Server Protected
81+-- If we get an "Authenticated v", we can trust the information in v, since
82+-- it was signed by a key we trust.
83+protected (Servant.Auth.Server.Authenticated user) = return (name user) :<|> return (email user)
84+-- Otherwise, we return a 401.
85+protected _ = throwAll err401
86+
87+type Unprotected =
88+ "login"
89+ :> ReqBody '[JSON] Login
90+ :> Verb 'POST 204 '[JSON] (Headers '[ Header "Set-Cookie" SetCookie
91+ , Header "Set-Cookie" SetCookie]
92+ NoContent)
93+ :<|> Raw
94+
95+unprotected :: CookieSettings -> JWTSettings -> Server Unprotected
96+unprotected cs jwts = checkCreds cs jwts :<|> serveDirectory "example/static"
97+
98+type API auths = (Servant.Auth.Server.Auth auths User :> Protected) :<|> Unprotected
99+
100+server :: CookieSettings -> JWTSettings -> Server (API auths)
101+server cs jwts = protected :<|> unprotected cs jwts
102+
103+~~~
104+
105+The code is common to all authentications. In order to pick one or more specific
106+authentication methods, all we need to do is provide the expect configuration
107+parameters.
108+
109+## API tokens
110+
111+The following example illustrates how to protect an API with tokens.
112+
113+
114+~~~ haskell
115+-- In main, we fork the server, and allow new tokens to be created in the
116+-- command line for the specified user name and email.
117+mainWithJWT :: IO ()
118+mainWithJWT = do
119+ -- We generate the key for signing tokens. This would generally be persisted,
120+ -- and kept safely
121+ myKey <- generateKey
122+ -- Adding some configurations. All authentications require CookieSettings to
123+ -- be in the context.
124+ let jwtCfg = defaultJWTSettings myKey
125+ cfg = defaultCookieSettings :. jwtCfg :. EmptyContext
126+ --- Here we actually make concrete
127+ api = Proxy :: Proxy (API '[JWT])
128+ _ <- forkIO $ run 7249 $ serveWithContext api cfg (server defaultCookieSettings jwtCfg)
129+
130+ putStrLn "Started server on localhost:7249"
131+ putStrLn "Enter name and email separated by a space for a new token"
132+
133+ forever $ do
134+ xs <- words <$> getLine
135+ case xs of
136+ [name', email'] -> do
137+ etoken <- makeJWT (User name' email') jwtCfg Nothing
138+ case etoken of
139+ Left e -> putStrLn $ "Error generating token:t" ++ show e
140+ Right v -> putStrLn $ "New token:\t" ++ show v
141+ _ -> putStrLn "Expecting a name and email separated by spaces"
142+
143+~~~
144+
145+And indeed:
146+
147+~~~ bash
148+
149+./readme JWT
150+
151+ Started server on localhost:7249
152+ Enter name and email separated by a space for a new token
153+ alice alice@gmail.com
154+ New token: "eyJhbGciOiJIUzI1NiJ9.eyJkYXQiOnsiZW1haWwiOiJhbGljZUBnbWFpbC5jb20iLCJuYW1lIjoiYWxpY2UifX0.xzOIrx_A9VOKzVO-R1c1JYKBqK9risF625HOxpBzpzE"
155+
156+curl localhost:7249/name -v
157+
158+ * Hostname was NOT found in DNS cache
159+ * Trying 127.0.0.1...
160+ * Connected to localhost (127.0.0.1) port 7249 (#0)
161+ > GET /name HTTP/1.1
162+ > User-Agent: curl/7.35.0
163+ > Host: localhost:7249
164+ > Accept: */*
165+ >
166+ < HTTP/1.1 401 Unauthorized
167+ < Transfer-Encoding: chunked
168+ < Date: Wed, 07 Sep 2016 20:17:17 GMT
169+ * Server Warp/3.2.7 is not blacklisted
170+ < Server: Warp/3.2.7
171+ <
172+ * Connection #0 to host localhost left intact
173+
174+curl -H "Authorization: Bearer eyJhbGciOiJIUzI1NiJ9.eyJkYXQiOnsiZW1haWwiOiJhbGljZUBnbWFpbC5jb20iLCJuYW1lIjoiYWxpY2UifX0.xzOIrx_A9VOKzVO-R1c1JYKBqK9risF625HOxpBzpzE" \
175+ localhost:7249/name -v
176+
177+ * Hostname was NOT found in DNS cache
178+ * Trying 127.0.0.1...
179+ * Connected to localhost (127.0.0.1) port 7249 (#0)
180+ > GET /name HTTP/1.1
181+ > User-Agent: curl/7.35.0
182+ > Host: localhost:7249
183+ > Accept: */*
184+ > Authorization: Bearer eyJhbGciOiJIUzI1NiJ9.eyJkYXQiOnsiZW1haWwiOiJhbGljZUBnbWFpbC5jb20iLCJuYW1lIjoiYWxpY2UifX0.xzOIrx_A9VOKzVO-R1c1JYKBqK9risF625HOxpBzpzE
185+ >
186+ < HTTP/1.1 200 OK
187+ < Transfer-Encoding: chunked
188+ < Date: Wed, 07 Sep 2016 20:16:11 GMT
189+ * Server Warp/3.2.7 is not blacklisted
190+ < Server: Warp/3.2.7
191+ < Content-Type: application/json
192+ < Set-Cookie: JWT-Cookie=eyJhbGciOiJIUzI1NiJ9.eyJkYXQiOnsiZW1haWwiOiJhbGljZUBnbWFpbC5jb20iLCJuYW1lIjoiYWxpY2UifX0.xzOIrx_A9VOKzVO-R1c1JYKBqK9risF625HOxpBzpzE; HttpOnly; Secure
193+ < Set-Cookie: XSRF-TOKEN=TWcdPnHr2QHcVyTw/TTBLQ==; Secure
194+ <
195+ * Connection #0 to host localhost left intact
196+ "alice"%
197+
198+
199+~~~
200+
201+## Cookies
202+
203+What if, in addition to API tokens, we want to expose our API to browsers? All
204+we need to do is say so!
205+
206+~~~ haskell
207+mainWithCookies :: IO ()
208+mainWithCookies = do
209+ -- We *also* need a key to sign the cookies
210+ myKey <- generateKey
211+ -- Adding some configurations. 'Cookie' requires, in addition to
212+ -- CookieSettings, JWTSettings (for signing), so everything is just as before
213+ let jwtCfg = defaultJWTSettings myKey
214+ cfg = defaultCookieSettings :. jwtCfg :. EmptyContext
215+ --- Here is the actual change
216+ api = Proxy :: Proxy (API '[Cookie])
217+ run 7249 $ serveWithContext api cfg (server defaultCookieSettings jwtCfg)
218+
219+-- Here is the login handler
220+checkCreds :: CookieSettings
221+ -> JWTSettings
222+ -> Login
223+ -> Handler (Headers '[ Header "Set-Cookie" SetCookie
224+ , Header "Set-Cookie" SetCookie]
225+ NoContent)
226+checkCreds cookieSettings jwtSettings (Login "Ali Baba" "Open Sesame") = do
227+ -- Usually you would ask a database for the user info. This is just a
228+ -- regular servant handler, so you can follow your normal database access
229+ -- patterns (including using 'enter').
230+ let usr = User "Ali Baba" "ali@email.com"
231+ mApplyCookies <- liftIO $ acceptLogin cookieSettings jwtSettings usr
232+ case mApplyCookies of
233+ Nothing -> throwError err401
234+ Just applyCookies -> return $ applyCookies NoContent
235+checkCreds _ _ _ = throwError err401
236+~~~
237+
238+### XSRF and the frontend
239+
240+XSRF protection works by requiring that there be a header of the same value as
241+a distinguished cookie that is set by the server on each request. What the
242+cookie and header name are can be configured (see `xsrfCookieName` and
243+`xsrfHeaderName` in `CookieSettings`), but by default they are "XSRF-TOKEN" and
244+"X-XSRF-TOKEN". This means that, if your client is a browser and you're using
245+cookies, Javascript on the client must set the header of each request by
246+reading the cookie. For jQuery, and with the default values, that might be:
247+
248+~~~ javascript
249+
250+var token = (function() {
251+ r = document.cookie.match(new RegExp('XSRF-TOKEN=([^;]+)'))
252+ if (r) return r[1];
253+})();
254+
255+
256+$.ajaxPrefilter(function(opts, origOpts, xhr) {
257+ xhr.setRequestHeader('X-XSRF-TOKEN', token);
258+ }
259+
260+~~~
261+
262+I *believe* nothing at all needs to be done if you're using Angular's `$http`
263+directive, but I haven't tested this.
264+
265+XSRF protection can be disabled just for `GET` requests by setting
266+`xsrfExcludeGet = False`. You might want this if you're relying on the browser
267+to navigate between pages that require cookie authentication.
268+
269+XSRF protection can be completely disabled by setting `cookieXsrfSetting =
270+Nothing` in `CookieSettings`. This is not recommended! If your cookie
271+authenticated web application runs any javascript, it's recommended to send the
272+XSRF header. However, if your web application runs no javascript, disabling
273+XSRF entirely may be required.
274+
275+# Note on this README
276+
277+This README is a literate haskell file. Here is 'main', allowing you to pick
278+between the examples above.
279+
280+~~~ haskell
281+
282+main :: IO ()
283+main = do
284+ args <- getArgs
285+ let usage = "Usage: readme (JWT|Cookie)"
286+ case args of
287+ ["JWT"] -> mainWithJWT
288+ ["Cookie"] -> mainWithCookies
289+ e -> putStrLn $ "Arguments: \"" ++ unwords e ++ "\" not understood\n" ++ usage
290+
291+~~~
servant-auth/servant-auth-server/README.mdnew file+1
@@ -0,0 +1 @@
1+README.lhs
servant-auth/servant-auth-server/Setup.hsnew file+2
@@ -0,0 +1,2 @@
1+import Distribution.Simple
2+main = defaultMain
servant-auth/servant-auth-server/servant-auth-server.cabalnew file+135
@@ -0,0 +1,135 @@
1+cabal-version: 2.2
2+name: servant-auth-server
3+version: 0.4.7.0
4+synopsis: servant-server/servant-auth compatibility
5+description: This package provides the required instances for using the @Auth@ combinator
6+ in your 'servant' server.
7+ .
8+ Both cookie- and token- (REST API) based authentication is provided.
9+ .
10+ For a quick overview of the usage, see the <https://github.com/haskell-servant/servant/tree/master/servant-auth#readme README>.
11+category: Web, Servant, Authentication
12+homepage: https://github.com/haskell-servant/servant/tree/master/servant-auth#readme
13+bug-reports: https://github.com/haskell-servant/servant/issues
14+author: Julian K. Arni
15+maintainer: jkarni@gmail.com
16+copyright: (c) Julian K. Arni
17+license: BSD-3-Clause
18+license-file: LICENSE
19+tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1
20+build-type: Simple
21+extra-source-files:
22+ CHANGELOG.md
23+
24+source-repository head
25+ type: git
26+ location: https://github.com/haskell-servant/servant
27+
28+library
29+ hs-source-dirs:
30+ src
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
33+ build-depends:
34+ base >= 4.10 && < 4.18
35+ , aeson >= 1.0.0.1 && < 3
36+ , base64-bytestring >= 1.0.0.1 && < 2
37+ , blaze-builder >= 0.4.1.0 && < 0.5
38+ , bytestring >= 0.10.6.0 && < 0.12
39+ , case-insensitive >= 1.2.0.11 && < 1.3
40+ , cookie >= 0.4.4 && < 0.5
41+ , data-default-class >= 0.1.2.0 && < 0.2
42+ , entropy >= 0.4.1.3 && < 0.5
43+ , http-types >= 0.12.2 && < 0.13
44+ , jose >= 0.10 && < 0.11
45+ , lens >= 4.16.1 && < 5.3
46+ , memory >= 0.14.16 && < 0.19
47+ , monad-time >= 0.3.1.0 && < 0.4
48+ , mtl ^>= 2.2.2 || ^>= 2.3.1
49+ , servant >= 0.13 && < 0.20
50+ , servant-auth == 0.4.*
51+ , servant-server >= 0.13 && < 0.20
52+ , tagged >= 0.8.4 && < 0.9
53+ , text >= 1.2.3.0 && < 2.1
54+ , time >= 1.5.0.1 && < 1.13
55+ , unordered-containers >= 0.2.9.0 && < 0.3
56+ , wai >= 3.2.1.2 && < 3.3
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+
65+ exposed-modules:
66+ Servant.Auth.Server
67+ Servant.Auth.Server.Internal
68+ Servant.Auth.Server.Internal.AddSetCookie
69+ Servant.Auth.Server.Internal.BasicAuth
70+ Servant.Auth.Server.Internal.Class
71+ Servant.Auth.Server.Internal.ConfigTypes
72+ Servant.Auth.Server.Internal.Cookie
73+ Servant.Auth.Server.Internal.FormLogin
74+ Servant.Auth.Server.Internal.JWT
75+ Servant.Auth.Server.Internal.ThrowAll
76+ Servant.Auth.Server.Internal.Types
77+ Servant.Auth.Server.SetCookieOrphan
78+ default-language: Haskell2010
79+
80+test-suite readme
81+ type: exitcode-stdio-1.0
82+ main-is: README.lhs
83+ default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
84+ ghc-options: -Wall -pgmL markdown-unlit
85+ build-tool-depends: markdown-unlit:markdown-unlit
86+ build-depends:
87+ base
88+ , servant-auth
89+ , servant-auth-server
90+ , servant-server
91+ , aeson
92+ , mtl
93+ , warp
94+ default-language: Haskell2010
95+ if impl(ghcjs)
96+ buildable: False
97+
98+test-suite spec
99+ type: exitcode-stdio-1.0
100+ main-is: Spec.hs
101+ hs-source-dirs:
102+ test
103+ default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
104+ ghc-options: -Wall
105+ build-tool-depends: hspec-discover:hspec-discover >=2.5.5 && <2.10
106+
107+ -- dependencies with bounds inherited from the library stanza
108+ build-depends:
109+ base
110+ , aeson
111+ , bytestring
112+ , case-insensitive
113+ , jose
114+ , lens
115+ , mtl
116+ , time
117+ , http-types
118+ , wai
119+ , servant
120+ , servant-server
121+ , transformers
122+
123+ -- test dependencies
124+ build-depends:
125+ servant-auth-server
126+ , hspec >= 2.5.5 && < 2.10
127+ , QuickCheck >= 2.11.3 && < 2.15
128+ , http-client >= 0.5.13.1 && < 0.8
129+ , lens-aeson >= 1.0.2 && < 1.3
130+ , warp >= 3.2.25 && < 3.4
131+ , wreq >= 0.5.2.1 && < 0.6
132+ , text >= 1.2.3.0 && < 2.1
133+ other-modules:
134+ Servant.Auth.ServerSpec
135+ default-language: Haskell2010
servant-auth/servant-auth-server/src/Servant/Auth/Server.hsnew file+180
@@ -0,0 +1,180 @@
1+module Servant.Auth.Server
2+ (
3+ -- | This package provides implementations for some common authentication
4+ -- methods. Authentication yields a trustworthy (because generated by the
5+ -- server) value of an some arbitrary type:
6+ --
7+ -- > type MyApi = Protected
8+ -- >
9+ -- > type Protected = Auth '[JWT, Cookie] User :> Get '[JSON] UserAccountDetails
10+ -- >
11+ -- > server :: Server Protected
12+ -- > server (Authenticated usr) = ... -- here we know the client really is
13+ -- > -- who she claims to be
14+ -- > server _ = throwAll err401
15+ --
16+ -- Additional configuration happens via 'Context'.
17+ --
18+ -- == Example for Custom Handler
19+ -- To use a custom 'Servant.Server.Handler' it is necessary to use
20+ -- 'Servant.Server.hoistServerWithContext' instead of
21+ -- 'Servant.Server.hoistServer' and specify the 'Context'.
22+ --
23+ -- Below is an example of passing 'CookieSettings' and 'JWTSettings' in the
24+ -- 'Context' to create a specialized function equivalent to
25+ -- 'Servant.Server.hoistServer' for an API that includes cookie
26+ -- authentication.
27+ --
28+ -- > hoistServerWithAuth
29+ -- > :: HasServer api '[CookieSettings, JWTSettings]
30+ -- > => Proxy api
31+ -- > -> (forall x. m x -> n x)
32+ -- > -> ServerT api m
33+ -- > -> ServerT api n
34+ -- > hoistServerWithAuth api =
35+ -- > hoistServerWithContext api (Proxy :: Proxy '[CookieSettings, JWTSettings])
36+
37+ ----------------------------------------------------------------------------
38+ -- * Auth
39+ -- | Basic types
40+ Auth
41+ , AuthResult(..)
42+ , AuthCheck(..)
43+
44+ ----------------------------------------------------------------------------
45+ -- * JWT
46+ -- | JSON Web Tokens (JWT) are a compact and secure way of transferring
47+ -- information between parties. In this library, they are signed by the
48+ -- server (or by some other party posessing the relevant key), and used to
49+ -- indicate the bearer's identity or authorization.
50+ --
51+ -- Arbitrary information can be encoded - just declare instances for the
52+ -- 'FromJWT' and 'ToJWT' classes. Don't go overboard though - be aware that
53+ -- usually you'll be trasmitting this information on each request (and
54+ -- response!).
55+ --
56+ -- Note that, while the tokens are signed, they are not encrypted. Do not put
57+ -- any information you do not wish the client to know in them!
58+
59+ -- ** Combinator
60+ -- | Re-exported from 'servant-auth'
61+ , JWT
62+
63+ -- ** Classes
64+ , FromJWT(..)
65+ , ToJWT(..)
66+
67+ -- ** Related types
68+ , IsMatch(..)
69+
70+ -- ** Settings
71+ , JWTSettings(..)
72+ , defaultJWTSettings
73+
74+ -- ** Create check
75+ , jwtAuthCheck
76+
77+
78+ ----------------------------------------------------------------------------
79+ -- * Cookie
80+ -- | Cookies are also a method of identifying and authenticating a user. They
81+ -- are particular common when the client is a browser
82+
83+ -- ** Combinator
84+ -- | Re-exported from 'servant-auth'
85+ , Cookie
86+
87+ -- ** Settings
88+ , CookieSettings(..)
89+ , XsrfCookieSettings(..)
90+ , defaultCookieSettings
91+ , defaultXsrfCookieSettings
92+ , makeSessionCookie
93+ , makeSessionCookieBS
94+ , makeXsrfCookie
95+ , makeCsrfCookie
96+ , makeCookie
97+ , makeCookieBS
98+ , acceptLogin
99+ , clearSession
100+
101+
102+ -- ** Related types
103+ , IsSecure(..)
104+ , SameSite(..)
105+ , AreAuths
106+
107+ ----------------------------------------------------------------------------
108+ -- * BasicAuth
109+ -- ** Combinator
110+ -- | Re-exported from 'servant-auth'
111+ , BasicAuth
112+
113+ -- ** Classes
114+ , FromBasicAuthData(..)
115+
116+ -- ** Settings
117+ , BasicAuthCfg
118+
119+ -- ** Related types
120+ , BasicAuthData(..)
121+ , IsPasswordCorrect(..)
122+
123+ -- ** Authentication request
124+ , wwwAuthenticatedErr
125+
126+ ----------------------------------------------------------------------------
127+ -- * Utilies
128+ , ThrowAll(throwAll)
129+ , generateKey
130+ , generateSecret
131+ , fromSecret
132+ , writeKey
133+ , readKey
134+ , makeJWT
135+ , verifyJWT
136+
137+ -- ** Re-exports
138+ , Default(def)
139+ , SetCookie
140+ ) where
141+
142+import Prelude hiding (readFile, writeFile)
143+import Data.ByteString (ByteString, writeFile, readFile)
144+import Data.Default.Class (Default (def))
145+import Servant.Auth
146+import Servant.Auth.JWT
147+import Servant.Auth.Server.Internal ()
148+import Servant.Auth.Server.Internal.BasicAuth
149+import Servant.Auth.Server.Internal.Class
150+import Servant.Auth.Server.Internal.ConfigTypes
151+import Servant.Auth.Server.Internal.Cookie
152+import Servant.Auth.Server.Internal.JWT
153+import Servant.Auth.Server.Internal.ThrowAll
154+import Servant.Auth.Server.Internal.Types
155+
156+import Crypto.JOSE as Jose
157+import Servant (BasicAuthData (..))
158+import Web.Cookie (SetCookie)
159+
160+-- | Generate a key suitable for use with 'defaultConfig'.
161+generateKey :: IO Jose.JWK
162+generateKey = Jose.genJWK $ Jose.OctGenParam 256
163+
164+-- | Generate a bytestring suitable for use with 'fromSecret'.
165+generateSecret :: MonadRandom m => m ByteString
166+generateSecret = Jose.getRandomBytes 256
167+
168+-- | Restores a key from a bytestring.
169+fromSecret :: ByteString -> Jose.JWK
170+fromSecret = Jose.fromOctets
171+
172+-- | Writes a secret to a file. Can for instance be used from the REPL
173+-- to persist a key to a file, which can then be included with the
174+-- application. Restore the key using 'readKey'.
175+writeKey :: FilePath -> IO ()
176+writeKey fp = writeFile fp =<< generateSecret
177+
178+-- | Reads a key from a file.
179+readKey :: FilePath -> IO Jose.JWK
180+readKey fp = fromSecret <$> readFile fp
servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal.hsnew file+67
@@ -0,0 +1,67 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE UndecidableInstances #-}
3+{-# OPTIONS_GHC -fno-warn-orphans #-}
4+
5+module Servant.Auth.Server.Internal where
6+
7+import Control.Monad.Trans (liftIO)
8+import Servant ((:>), Handler, HasServer (..),
9+ Proxy (..),
10+ HasContextEntry(getContextEntry))
11+import Servant.Auth
12+import Servant.Auth.JWT (ToJWT)
13+
14+import Servant.Auth.Server.Internal.AddSetCookie
15+import Servant.Auth.Server.Internal.Class
16+import Servant.Auth.Server.Internal.Cookie
17+import Servant.Auth.Server.Internal.ConfigTypes
18+import Servant.Auth.Server.Internal.JWT
19+import Servant.Auth.Server.Internal.Types
20+
21+import Servant.Server.Internal (DelayedIO, addAuthCheck, withRequest)
22+
23+instance ( n ~ 'S ('S 'Z)
24+ , HasServer (AddSetCookiesApi n api) ctxs, AreAuths auths ctxs v
25+ , HasServer api ctxs -- this constraint is needed to implement hoistServer
26+ , AddSetCookies n (ServerT api Handler) (ServerT (AddSetCookiesApi n api) Handler)
27+ , ToJWT v
28+ , HasContextEntry ctxs CookieSettings
29+ , HasContextEntry ctxs JWTSettings
30+ ) => HasServer (Auth auths v :> api) ctxs where
31+ type ServerT (Auth auths v :> api) m = AuthResult v -> ServerT api m
32+
33+#if MIN_VERSION_servant_server(0,12,0)
34+ hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
35+#endif
36+
37+ route _ context subserver =
38+ route (Proxy :: Proxy (AddSetCookiesApi n api))
39+ context
40+ (fmap go subserver `addAuthCheck` authCheck)
41+
42+ where
43+ authCheck :: DelayedIO (AuthResult v, SetCookieList ('S ('S 'Z)))
44+ authCheck = withRequest $ \req -> liftIO $ do
45+ authResult <- runAuthCheck (runAuths (Proxy :: Proxy auths) context) req
46+ cookies <- makeCookies authResult
47+ return (authResult, cookies)
48+
49+ jwtSettings :: JWTSettings
50+ jwtSettings = getContextEntry context
51+
52+ cookieSettings :: CookieSettings
53+ cookieSettings = getContextEntry context
54+
55+ makeCookies :: AuthResult v -> IO (SetCookieList ('S ('S 'Z)))
56+ makeCookies authResult = do
57+ case authResult of
58+ (Authenticated v) -> do
59+ ejwt <- makeSessionCookie cookieSettings jwtSettings v
60+ xsrf <- makeXsrfCookie cookieSettings
61+ return $ Just xsrf `SetCookieCons` (ejwt `SetCookieCons` SetCookieNil)
62+ _ -> return $ Nothing `SetCookieCons` (Nothing `SetCookieCons` SetCookieNil)
63+
64+ go :: (AuthResult v -> ServerT api Handler)
65+ -> (AuthResult v, SetCookieList n)
66+ -> ServerT (AddSetCookiesApi n api) Handler
67+ go fn (authResult, cookies) = addSetCookies cookies $ fn authResult
servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/AddSetCookie.hsnew file+119
@@ -0,0 +1,119 @@
1+{-# LANGUAGE PolyKinds #-}
2+{-# LANGUAGE TupleSections #-}
3+{-# LANGUAGE UndecidableInstances #-}
4+{-# LANGUAGE CPP #-}
5+
6+module Servant.Auth.Server.Internal.AddSetCookie where
7+
8+import Blaze.ByteString.Builder (toByteString)
9+import qualified Data.ByteString as BS
10+import Data.Tagged (Tagged (..))
11+import qualified Network.HTTP.Types as HTTP
12+import Network.Wai (mapResponseHeaders)
13+import Servant
14+import Servant.API.UVerb.Union
15+import Servant.API.Generic
16+import Servant.Server.Generic
17+import Web.Cookie
18+
19+-- What are we doing here? Well, the idea is to add headers to the response,
20+-- but the headers come from the authentication check. In order to do that, we
21+-- tweak a little the general theme of recursing down the API tree; this time,
22+-- we recurse down a variation of it that adds headers to all the endpoints.
23+-- This involves the usual type-level checks.
24+--
25+-- TODO: If the endpoints already have headers, this will not work as is.
26+
27+data Nat = Z | S Nat
28+
29+type family AddSetCookiesApi (n :: Nat) a where
30+ AddSetCookiesApi ('S 'Z) a = AddSetCookieApi a
31+ AddSetCookiesApi ('S n) a = AddSetCookiesApi n (AddSetCookieApi a)
32+
33+type family AddSetCookieApiVerb a where
34+ AddSetCookieApiVerb (Headers ls a) = Headers (Header "Set-Cookie" SetCookie ': ls) a
35+ AddSetCookieApiVerb a = Headers '[Header "Set-Cookie" SetCookie] a
36+
37+#if MIN_VERSION_servant_server(0,18,1)
38+type family MapAddSetCookieApiVerb (as :: [*]) where
39+ MapAddSetCookieApiVerb '[] = '[]
40+ MapAddSetCookieApiVerb (a ': as) = (AddSetCookieApiVerb a ': MapAddSetCookieApiVerb as)
41+#endif
42+
43+type family AddSetCookieApi a :: *
44+type instance AddSetCookieApi (a :> b) = a :> AddSetCookieApi b
45+type instance AddSetCookieApi (a :<|> b) = AddSetCookieApi a :<|> AddSetCookieApi b
46+#if MIN_VERSION_servant_server(0,19,0)
47+type instance AddSetCookieApi (NamedRoutes api) = AddSetCookieApi (ToServantApi api)
48+#endif
49+type instance AddSetCookieApi (Verb method stat ctyps a)
50+ = Verb method stat ctyps (AddSetCookieApiVerb a)
51+#if MIN_VERSION_servant_server(0,18,1)
52+type instance AddSetCookieApi (UVerb method ctyps as)
53+ = UVerb method ctyps (MapAddSetCookieApiVerb as)
54+#endif
55+type instance AddSetCookieApi Raw = Raw
56+#if MIN_VERSION_servant_server(0,15,0)
57+type instance AddSetCookieApi (Stream method stat framing ctyps a)
58+ = Stream method stat framing ctyps (AddSetCookieApiVerb a)
59+#endif
60+type instance AddSetCookieApi (Headers hs a) = AddSetCookieApiVerb (Headers hs a)
61+
62+data SetCookieList (n :: Nat) :: * where
63+ SetCookieNil :: SetCookieList 'Z
64+ SetCookieCons :: Maybe SetCookie -> SetCookieList n -> SetCookieList ('S n)
65+
66+class AddSetCookies (n :: Nat) orig new where
67+ addSetCookies :: SetCookieList n -> orig -> new
68+
69+instance {-# OVERLAPS #-} AddSetCookies ('S n) oldb newb
70+ => AddSetCookies ('S n) (a -> oldb) (a -> newb) where
71+ addSetCookies cookies oldfn = addSetCookies cookies . oldfn
72+
73+instance (orig1 ~ orig2) => AddSetCookies 'Z orig1 orig2 where
74+ addSetCookies _ = id
75+
76+instance {-# OVERLAPPABLE #-}
77+ ( Functor m
78+ , AddSetCookies n (m old) (m cookied)
79+ , AddHeader "Set-Cookie" SetCookie cookied new
80+ ) => AddSetCookies ('S n) (m old) (m new) where
81+ addSetCookies (mCookie `SetCookieCons` rest) oldVal =
82+ case mCookie of
83+ Nothing -> noHeader <$> addSetCookies rest oldVal
84+ Just cookie -> addHeader cookie <$> addSetCookies rest oldVal
85+
86+instance {-# OVERLAPS #-}
87+ (AddSetCookies ('S n) a a', AddSetCookies ('S n) b b')
88+ => AddSetCookies ('S n) (a :<|> b) (a' :<|> b') where
89+ addSetCookies cookies (a :<|> b) = addSetCookies cookies a :<|> addSetCookies cookies b
90+
91+instance {-# OVERLAPS #-}
92+ ( AddSetCookies ('S n) (ServerT (ToServantApi api) m) cookiedApi
93+ , Generic (api (AsServerT m))
94+ , GServantProduct (Rep (api (AsServerT m)))
95+ , ToServant api (AsServerT m) ~ ServerT (ToServantApi api) m
96+ )
97+ => AddSetCookies ('S n) (api (AsServerT m)) cookiedApi where
98+ addSetCookies cookies = addSetCookies cookies . toServant
99+
100+-- | for @servant <0.11@
101+instance
102+ AddSetCookies ('S n) Application Application where
103+ addSetCookies cookies r request respond
104+ = r request $ respond . mapResponseHeaders (++ mkHeaders cookies)
105+
106+-- | for @servant >=0.11@
107+instance
108+ AddSetCookies ('S n) (Tagged m Application) (Tagged m Application) where
109+ addSetCookies cookies r = Tagged $ \request respond ->
110+ unTagged r request $ respond . mapResponseHeaders (++ mkHeaders cookies)
111+
112+mkHeaders :: SetCookieList x -> [HTTP.Header]
113+mkHeaders x = ("Set-Cookie",) <$> mkCookies x
114+ where
115+ mkCookies :: forall y. SetCookieList y -> [BS.ByteString]
116+ mkCookies SetCookieNil = []
117+ mkCookies (SetCookieCons Nothing rest) = mkCookies rest
118+ mkCookies (SetCookieCons (Just y) rest)
119+ = toByteString (renderSetCookie y) : mkCookies rest
servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/BasicAuth.hsnew file+59
@@ -0,0 +1,59 @@
1+{-# LANGUAGE CPP #-}
2+module Servant.Auth.Server.Internal.BasicAuth where
3+
4+#if !MIN_VERSION_servant_server(0,16,0)
5+#define ServerError ServantErr
6+#endif
7+
8+import qualified Data.ByteString as BS
9+import Servant (BasicAuthData (..),
10+ ServerError (..), err401)
11+import Servant.Server.Internal.BasicAuth (decodeBAHdr,
12+ mkBAChallengerHdr)
13+
14+import Servant.Auth.Server.Internal.Types
15+
16+-- | A 'ServerError' that asks the client to authenticate via Basic
17+-- Authentication, should be invoked by an application whenever
18+-- appropriate. The argument is the realm.
19+wwwAuthenticatedErr :: BS.ByteString -> ServerError
20+wwwAuthenticatedErr realm = err401 { errHeaders = [mkBAChallengerHdr realm] }
21+
22+-- | A type holding the configuration for Basic Authentication.
23+-- It is defined as a type family with no arguments, so that
24+-- it can be instantiated to whatever type you need to
25+-- authenticate your users (use @type instance BasicAuthCfg = ...@).
26+--
27+-- Note that the instantiation is application-wide,
28+-- i.e. there can be only one instance.
29+-- As a consequence, it should not be instantiated in a library.
30+--
31+-- Basic Authentication expects an element of type 'BasicAuthCfg'
32+-- to be in the 'Context'; that element is then passed automatically
33+-- to the instance of 'FromBasicAuthData' together with the
34+-- authentication data obtained from the client.
35+--
36+-- If you do not need a configuration for Basic Authentication,
37+-- you can use just @BasicAuthCfg = ()@, and recall to also
38+-- add @()@ to the 'Context'.
39+-- A basic but more interesting example is to take as 'BasicAuthCfg'
40+-- a list of authorised username/password pairs:
41+--
42+-- > deriving instance Eq BasicAuthData
43+-- > type instance BasicAuthCfg = [BasicAuthData]
44+-- > instance FromBasicAuthData User where
45+-- > fromBasicAuthData authData authCfg =
46+-- > if elem authData authCfg then ...
47+type family BasicAuthCfg
48+
49+class FromBasicAuthData a where
50+ -- | Whether the username exists and the password is correct.
51+ -- Note that, rather than passing a 'Pass' to the function, we pass a
52+ -- function that checks an 'EncryptedPass'. This is to make sure you don't
53+ -- accidentally do something untoward with the password, like store it.
54+ fromBasicAuthData :: BasicAuthData -> BasicAuthCfg -> IO (AuthResult a)
55+
56+basicAuthCheck :: FromBasicAuthData usr => BasicAuthCfg -> AuthCheck usr
57+basicAuthCheck cfg = AuthCheck $ \req -> case decodeBAHdr req of
58+ Nothing -> return Indefinite
59+ Just baData -> fromBasicAuthData baData cfg
servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/Class.hsnew file+72
@@ -0,0 +1,72 @@
1+{-# LANGUAGE UndecidableInstances #-}
2+module Servant.Auth.Server.Internal.Class where
3+
4+import Servant.Auth
5+import Data.Monoid
6+import Servant hiding (BasicAuth)
7+
8+import Servant.Auth.JWT
9+import Servant.Auth.Server.Internal.Types
10+import Servant.Auth.Server.Internal.ConfigTypes
11+import Servant.Auth.Server.Internal.BasicAuth
12+import Servant.Auth.Server.Internal.Cookie
13+import Servant.Auth.Server.Internal.JWT (jwtAuthCheck)
14+
15+-- | @IsAuth a ctx v@ indicates that @a@ is an auth type that expects all
16+-- elements of @ctx@ to be the in the Context and whose authentication check
17+-- returns an @AuthCheck v@.
18+class IsAuth a v where
19+ type family AuthArgs a :: [*]
20+ runAuth :: proxy a -> proxy v -> Unapp (AuthArgs a) (AuthCheck v)
21+
22+instance FromJWT usr => IsAuth Cookie usr where
23+ type AuthArgs Cookie = '[CookieSettings, JWTSettings]
24+ runAuth _ _ = cookieAuthCheck
25+
26+instance FromJWT usr => IsAuth JWT usr where
27+ type AuthArgs JWT = '[JWTSettings]
28+ runAuth _ _ = jwtAuthCheck
29+
30+instance FromBasicAuthData usr => IsAuth BasicAuth usr where
31+ type AuthArgs BasicAuth = '[BasicAuthCfg]
32+ runAuth _ _ = basicAuthCheck
33+
34+-- * Helper
35+
36+class AreAuths (as :: [*]) (ctxs :: [*]) v where
37+ runAuths :: proxy as -> Context ctxs -> AuthCheck v
38+
39+instance AreAuths '[] ctxs v where
40+ runAuths _ _ = mempty
41+
42+instance ( AuthCheck v ~ App (AuthArgs a) (Unapp (AuthArgs a) (AuthCheck v))
43+ , IsAuth a v
44+ , AreAuths as ctxs v
45+ , AppCtx ctxs (AuthArgs a) (Unapp (AuthArgs a) (AuthCheck v))
46+ ) => AreAuths (a ': as) ctxs v where
47+ runAuths _ ctxs = go <> runAuths (Proxy :: Proxy as) ctxs
48+ where
49+ go = appCtx (Proxy :: Proxy (AuthArgs a))
50+ ctxs
51+ (runAuth (Proxy :: Proxy a) (Proxy :: Proxy v))
52+
53+type family Unapp ls res where
54+ Unapp '[] res = res
55+ Unapp (arg1 ': rest) res = arg1 -> Unapp rest res
56+
57+type family App ls res where
58+ App '[] res = res
59+ App (arg1 ': rest) (arg1 -> res) = App rest res
60+
61+-- | @AppCtx@ applies the function @res@ to the arguments in @ls@ by taking the
62+-- values from the Context provided.
63+class AppCtx ctx ls res where
64+ appCtx :: proxy ls -> Context ctx -> res -> App ls res
65+
66+instance ( HasContextEntry ctxs ctx
67+ , AppCtx ctxs rest res
68+ ) => AppCtx ctxs (ctx ': rest) (ctx -> res) where
69+ appCtx _ ctx fn = appCtx (Proxy :: Proxy rest) ctx $ fn $ getContextEntry ctx
70+
71+instance AppCtx ctx '[] res where
72+ appCtx _ _ r = r
servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/ConfigTypes.hsnew file+127
@@ -0,0 +1,127 @@
1+module Servant.Auth.Server.Internal.ConfigTypes
2+ ( module Servant.Auth.Server.Internal.ConfigTypes
3+ , Servant.API.IsSecure(..)
4+ ) where
5+
6+import Crypto.JOSE as Jose
7+import Crypto.JWT as Jose
8+import qualified Data.ByteString as BS
9+import Data.Default.Class
10+import Data.Time
11+import GHC.Generics (Generic)
12+import Servant.API (IsSecure(..))
13+
14+data IsMatch = Matches | DoesNotMatch
15+ deriving (Eq, Show, Read, Generic, Ord)
16+
17+data IsPasswordCorrect = PasswordCorrect | PasswordIncorrect
18+ deriving (Eq, Show, Read, Generic, Ord)
19+
20+-- The @SameSite@ attribute of cookies determines whether cookies will be sent
21+-- on cross-origin requests.
22+--
23+-- See <https://tools.ietf.org/html/draft-west-first-party-cookies-07 this document>
24+-- for more information.
25+data SameSite = AnySite | SameSiteStrict | SameSiteLax
26+ deriving (Eq, Show, Read, Generic, Ord)
27+
28+-- | @JWTSettings@ are used to generate cookies, and to verify JWTs.
29+data JWTSettings = JWTSettings
30+ {
31+ -- | Key used to sign JWT.
32+ signingKey :: Jose.JWK
33+ -- | Algorithm used to sign JWT.
34+ , jwtAlg :: Maybe Jose.Alg
35+ -- | Keys used to validate JWT.
36+ , validationKeys :: IO Jose.JWKSet
37+ -- | An @aud@ predicate. The @aud@ is a string or URI that identifies the
38+ -- intended recipient of the JWT.
39+ , audienceMatches :: Jose.StringOrURI -> IsMatch
40+ } deriving (Generic)
41+
42+-- | A @JWTSettings@ where the audience always matches.
43+defaultJWTSettings :: Jose.JWK -> JWTSettings
44+defaultJWTSettings k = JWTSettings
45+ { signingKey = k
46+ , jwtAlg = Nothing
47+ , validationKeys = pure $ Jose.JWKSet [k]
48+ , audienceMatches = const Matches }
49+
50+-- | The policies to use when generating cookies.
51+--
52+-- If *both* 'cookieMaxAge' and 'cookieExpires' are @Nothing@, browsers will
53+-- treat the cookie as a *session cookie*. These will be deleted when the
54+-- browser is closed.
55+--
56+-- Note that having the setting @Secure@ may cause testing failures if you are
57+-- not testing over HTTPS.
58+data CookieSettings = CookieSettings
59+ {
60+ -- | 'Secure' means browsers will only send cookies over HTTPS. Default:
61+ -- @Secure@.
62+ cookieIsSecure :: !IsSecure
63+ -- | How long from now until the cookie expires. Default: @Nothing@.
64+ , cookieMaxAge :: !(Maybe DiffTime)
65+ -- | At what time the cookie expires. Default: @Nothing@.
66+ , cookieExpires :: !(Maybe UTCTime)
67+ -- | The URL path and sub-paths for which this cookie is used. Default: @Just "/"@.
68+ , cookiePath :: !(Maybe BS.ByteString)
69+ -- | Domain name, if set cookie also allows subdomains. Default: @Nothing@.
70+ , cookieDomain :: !(Maybe BS.ByteString)
71+ -- | 'SameSite' settings. Default: @SameSiteLax@.
72+ , cookieSameSite :: !SameSite
73+ -- | What name to use for the cookie used for the session.
74+ , sessionCookieName :: !BS.ByteString
75+ -- | The optional settings to use for XSRF protection. Default: @Just def@.
76+ , cookieXsrfSetting :: !(Maybe XsrfCookieSettings)
77+ } deriving (Eq, Show, Generic)
78+
79+instance Default CookieSettings where
80+ def = defaultCookieSettings
81+
82+defaultCookieSettings :: CookieSettings
83+defaultCookieSettings = CookieSettings
84+ { cookieIsSecure = Secure
85+ , cookieMaxAge = Nothing
86+ , cookieExpires = Nothing
87+ , cookiePath = Just "/"
88+ , cookieDomain = Nothing
89+ , cookieSameSite = SameSiteLax
90+ , sessionCookieName = "JWT-Cookie"
91+ , cookieXsrfSetting = Just def
92+ }
93+
94+-- | The policies to use when generating and verifying XSRF cookies
95+data XsrfCookieSettings = XsrfCookieSettings
96+ {
97+ -- | What name to use for the cookie used for XSRF protection.
98+ xsrfCookieName :: !BS.ByteString
99+ -- | What path to use for the cookie used for XSRF protection. Default @Just "/"@.
100+ , xsrfCookiePath :: !(Maybe BS.ByteString)
101+ -- | What name to use for the header used for XSRF protection.
102+ , xsrfHeaderName :: !BS.ByteString
103+ -- | Exclude GET request method from XSRF protection.
104+ , xsrfExcludeGet :: !Bool
105+ } deriving (Eq, Show, Generic)
106+
107+instance Default XsrfCookieSettings where
108+ def = defaultXsrfCookieSettings
109+
110+defaultXsrfCookieSettings :: XsrfCookieSettings
111+defaultXsrfCookieSettings = XsrfCookieSettings
112+ { xsrfCookieName = "XSRF-TOKEN"
113+ , xsrfCookiePath = Just "/"
114+ , xsrfHeaderName = "X-XSRF-TOKEN"
115+ , xsrfExcludeGet = False
116+ }
117+
118+------------------------------------------------------------------------------
119+-- Internal {{{
120+
121+jwtSettingsToJwtValidationSettings :: JWTSettings -> Jose.JWTValidationSettings
122+jwtSettingsToJwtValidationSettings s
123+ = defaultJWTValidationSettings (toBool <$> audienceMatches s)
124+ where
125+ toBool Matches = True
126+ toBool DoesNotMatch = False
127+-- }}}
servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/Cookie.hsnew file+183
@@ -0,0 +1,183 @@
1+{-# LANGUAGE CPP #-}
2+module Servant.Auth.Server.Internal.Cookie where
3+
4+import Blaze.ByteString.Builder (toByteString)
5+import Control.Monad (MonadPlus(..), guard)
6+import Control.Monad.Except
7+import Control.Monad.Reader
8+import qualified Crypto.JOSE as Jose
9+import qualified Crypto.JWT as Jose
10+import Data.ByteArray (constEq)
11+import qualified Data.ByteString as BS
12+import qualified Data.ByteString.Base64 as BS64
13+import qualified Data.ByteString.Lazy as BSL
14+import Data.CaseInsensitive (mk)
15+import Data.Maybe (fromMaybe)
16+import Data.Time.Calendar (Day(..))
17+import Data.Time.Clock (UTCTime(..), secondsToDiffTime)
18+import Network.HTTP.Types (methodGet)
19+import Network.HTTP.Types.Header(hCookie)
20+import Network.Wai (Request, requestHeaders, requestMethod)
21+import Servant (AddHeader, addHeader)
22+import System.Entropy (getEntropy)
23+import Web.Cookie
24+
25+import Servant.Auth.JWT (FromJWT (decodeJWT), ToJWT)
26+import Servant.Auth.Server.Internal.ConfigTypes
27+import Servant.Auth.Server.Internal.JWT (makeJWT, verifyJWT)
28+import Servant.Auth.Server.Internal.Types
29+
30+
31+cookieAuthCheck :: FromJWT usr => CookieSettings -> JWTSettings -> AuthCheck usr
32+cookieAuthCheck ccfg jwtSettings = do
33+ req <- ask
34+ jwtCookie <- maybe mempty return $ do
35+ cookies' <- lookup hCookie $ requestHeaders req
36+ let cookies = parseCookies cookies'
37+ -- Apply the XSRF check if enabled.
38+ guard $ fromMaybe True $ do
39+ xsrfCookieCfg <- xsrfCheckRequired ccfg req
40+ return $ xsrfCookieAuthCheck xsrfCookieCfg req cookies
41+ -- session cookie *must* be HttpOnly and Secure
42+ lookup (sessionCookieName ccfg) cookies
43+ verifiedJWT <- liftIO $ verifyJWT jwtSettings jwtCookie
44+ case verifiedJWT of
45+ Nothing -> mzero
46+ Just v -> return v
47+
48+xsrfCheckRequired :: CookieSettings -> Request -> Maybe XsrfCookieSettings
49+xsrfCheckRequired cookieSettings req = do
50+ xsrfCookieCfg <- cookieXsrfSetting cookieSettings
51+ let disableForGetReq = xsrfExcludeGet xsrfCookieCfg && requestMethod req == methodGet
52+ guard $ not disableForGetReq
53+ return xsrfCookieCfg
54+
55+xsrfCookieAuthCheck :: XsrfCookieSettings -> Request -> [(BS.ByteString, BS.ByteString)] -> Bool
56+xsrfCookieAuthCheck xsrfCookieCfg req cookies = fromMaybe False $ do
57+ xsrfCookie <- lookup (xsrfCookieName xsrfCookieCfg) cookies
58+ xsrfHeader <- lookup (mk $ xsrfHeaderName xsrfCookieCfg) $ requestHeaders req
59+ return $ xsrfCookie `constEq` xsrfHeader
60+
61+-- | Makes a cookie to be used for XSRF.
62+makeXsrfCookie :: CookieSettings -> IO SetCookie
63+makeXsrfCookie cookieSettings = case cookieXsrfSetting cookieSettings of
64+ Just xsrfCookieSettings -> makeRealCookie xsrfCookieSettings
65+ Nothing -> return $ noXsrfTokenCookie cookieSettings
66+ where
67+ makeRealCookie xsrfCookieSettings = do
68+ xsrfValue <- BS64.encode <$> getEntropy 32
69+ return
70+ $ applyXsrfCookieSettings xsrfCookieSettings
71+ $ applyCookieSettings cookieSettings
72+ $ def{ setCookieValue = xsrfValue }
73+
74+
75+-- | Alias for 'makeXsrfCookie'.
76+makeCsrfCookie :: CookieSettings -> IO SetCookie
77+makeCsrfCookie = makeXsrfCookie
78+{-# DEPRECATED makeCsrfCookie "Use makeXsrfCookie instead" #-}
79+
80+
81+-- | Makes a cookie with session information.
82+makeSessionCookie :: ToJWT v => CookieSettings -> JWTSettings -> v -> IO (Maybe SetCookie)
83+makeSessionCookie cookieSettings jwtSettings v = do
84+ ejwt <- makeJWT v jwtSettings (cookieExpires cookieSettings)
85+ case ejwt of
86+ Left _ -> return Nothing
87+ Right jwt -> return
88+ $ Just
89+ $ applySessionCookieSettings cookieSettings
90+ $ applyCookieSettings cookieSettings
91+ $ def{ setCookieValue = BSL.toStrict jwt }
92+
93+noXsrfTokenCookie :: CookieSettings -> SetCookie
94+noXsrfTokenCookie cookieSettings =
95+ applyCookieSettings cookieSettings $ def{ setCookieName = "NO-XSRF-TOKEN", setCookieValue = "" }
96+
97+applyCookieSettings :: CookieSettings -> SetCookie -> SetCookie
98+applyCookieSettings cookieSettings setCookie = setCookie
99+ { setCookieMaxAge = cookieMaxAge cookieSettings
100+ , setCookieExpires = cookieExpires cookieSettings
101+ , setCookiePath = cookiePath cookieSettings
102+ , setCookieDomain = cookieDomain cookieSettings
103+ , setCookieSecure = case cookieIsSecure cookieSettings of
104+ Secure -> True
105+ NotSecure -> False
106+ }
107+
108+applyXsrfCookieSettings :: XsrfCookieSettings -> SetCookie -> SetCookie
109+applyXsrfCookieSettings xsrfCookieSettings setCookie = setCookie
110+ { setCookieName = xsrfCookieName xsrfCookieSettings
111+ , setCookiePath = xsrfCookiePath xsrfCookieSettings
112+ , setCookieHttpOnly = False
113+ }
114+
115+applySessionCookieSettings :: CookieSettings -> SetCookie -> SetCookie
116+applySessionCookieSettings cookieSettings setCookie = setCookie
117+ { setCookieName = sessionCookieName cookieSettings
118+ , setCookieSameSite = case cookieSameSite cookieSettings of
119+ AnySite -> anySite
120+ SameSiteStrict -> Just sameSiteStrict
121+ SameSiteLax -> Just sameSiteLax
122+ , setCookieHttpOnly = True
123+ }
124+ where
125+#if MIN_VERSION_cookie(0,4,5)
126+ anySite = Just sameSiteNone
127+#else
128+ anySite = Nothing
129+#endif
130+
131+-- | For a JWT-serializable session, returns a function that decorates a
132+-- provided response object with XSRF and session cookies. This should be used
133+-- when a user successfully authenticates with credentials.
134+acceptLogin :: ( ToJWT session
135+ , AddHeader "Set-Cookie" SetCookie response withOneCookie
136+ , AddHeader "Set-Cookie" SetCookie withOneCookie withTwoCookies )
137+ => CookieSettings
138+ -> JWTSettings
139+ -> session
140+ -> IO (Maybe (response -> withTwoCookies))
141+acceptLogin cookieSettings jwtSettings session = do
142+ mSessionCookie <- makeSessionCookie cookieSettings jwtSettings session
143+ case mSessionCookie of
144+ Nothing -> pure Nothing
145+ Just sessionCookie -> do
146+ xsrfCookie <- makeXsrfCookie cookieSettings
147+ return $ Just $ addHeader sessionCookie . addHeader xsrfCookie
148+
149+-- | Arbitrary cookie expiry time set back in history after unix time 0
150+expireTime :: UTCTime
151+expireTime = UTCTime (ModifiedJulianDay 50000) 0
152+
153+-- | Adds headers to a response that clears all session cookies
154+-- | using max-age and expires cookie attributes.
155+clearSession :: ( AddHeader "Set-Cookie" SetCookie response withOneCookie
156+ , AddHeader "Set-Cookie" SetCookie withOneCookie withTwoCookies )
157+ => CookieSettings
158+ -> response
159+ -> withTwoCookies
160+clearSession cookieSettings = addHeader clearedSessionCookie . addHeader clearedXsrfCookie
161+ where
162+ -- According to RFC6265 max-age takes precedence, but IE/Edge ignore it completely so we set both
163+ cookieSettingsExpires = cookieSettings
164+ { cookieExpires = Just expireTime
165+ , cookieMaxAge = Just (secondsToDiffTime 0)
166+ }
167+ clearedSessionCookie = applySessionCookieSettings cookieSettingsExpires $ applyCookieSettings cookieSettingsExpires def
168+ clearedXsrfCookie = case cookieXsrfSetting cookieSettings of
169+ Just xsrfCookieSettings -> applyXsrfCookieSettings xsrfCookieSettings $ applyCookieSettings cookieSettingsExpires def
170+ Nothing -> noXsrfTokenCookie cookieSettingsExpires
171+
172+makeSessionCookieBS :: ToJWT v => CookieSettings -> JWTSettings -> v -> IO (Maybe BS.ByteString)
173+makeSessionCookieBS a b c = fmap (toByteString . renderSetCookie) <$> makeSessionCookie a b c
174+
175+-- | Alias for 'makeSessionCookie'.
176+makeCookie :: ToJWT v => CookieSettings -> JWTSettings -> v -> IO (Maybe SetCookie)
177+makeCookie = makeSessionCookie
178+{-# DEPRECATED makeCookie "Use makeSessionCookie instead" #-}
179+
180+-- | Alias for 'makeSessionCookieBS'.
181+makeCookieBS :: ToJWT v => CookieSettings -> JWTSettings -> v -> IO (Maybe BS.ByteString)
182+makeCookieBS = makeSessionCookieBS
183+{-# DEPRECATED makeCookieBS "Use makeSessionCookieBS instead" #-}
servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/FormLogin.hsnew file+3
@@ -0,0 +1,3 @@
1+module Servant.Auth.Server.Internal.FormLogin where
2+
3+
servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/JWT.hsnew file+68
@@ -0,0 +1,68 @@
1+module Servant.Auth.Server.Internal.JWT where
2+
3+import Control.Lens
4+import Control.Monad (MonadPlus(..), guard)
5+import Control.Monad.Reader
6+import qualified Crypto.JOSE as Jose
7+import qualified Crypto.JWT as Jose
8+import Data.ByteArray (constEq)
9+import qualified Data.ByteString as BS
10+import qualified Data.ByteString.Lazy as BSL
11+import Data.Maybe (fromMaybe)
12+import Data.Time (UTCTime)
13+import Network.Wai (requestHeaders)
14+
15+import Servant.Auth.JWT (FromJWT(..), ToJWT(..))
16+import Servant.Auth.Server.Internal.ConfigTypes
17+import Servant.Auth.Server.Internal.Types
18+
19+
20+-- | A JWT @AuthCheck@. You likely won't need to use this directly unless you
21+-- are protecting a @Raw@ endpoint.
22+jwtAuthCheck :: FromJWT usr => JWTSettings -> AuthCheck usr
23+jwtAuthCheck jwtSettings = do
24+ req <- ask
25+ token <- maybe mempty return $ do
26+ authHdr <- lookup "Authorization" $ requestHeaders req
27+ let bearer = "Bearer "
28+ (mbearer, rest) = BS.splitAt (BS.length bearer) authHdr
29+ guard (mbearer `constEq` bearer)
30+ return rest
31+ verifiedJWT <- liftIO $ verifyJWT jwtSettings token
32+ case verifiedJWT of
33+ Nothing -> mzero
34+ Just v -> return v
35+
36+-- | Creates a JWT containing the specified data. The data is stored in the
37+-- @dat@ claim. The 'Maybe UTCTime' argument indicates the time at which the
38+-- token expires.
39+makeJWT :: ToJWT a
40+ => a -> JWTSettings -> Maybe UTCTime -> IO (Either Jose.Error BSL.ByteString)
41+makeJWT v cfg expiry = Jose.runJOSE $ do
42+ bestAlg <- Jose.bestJWSAlg $ signingKey cfg
43+ let alg = fromMaybe bestAlg $ jwtAlg cfg
44+ ejwt <- Jose.signClaims (signingKey cfg)
45+ (Jose.newJWSHeader ((), alg))
46+ (addExp $ encodeJWT v)
47+
48+ return $ Jose.encodeCompact ejwt
49+ where
50+ addExp claims = case expiry of
51+ Nothing -> claims
52+ Just e -> claims & Jose.claimExp ?~ Jose.NumericDate e
53+
54+
55+verifyJWT :: FromJWT a => JWTSettings -> BS.ByteString -> IO (Maybe a)
56+verifyJWT jwtCfg input = do
57+ keys <- validationKeys jwtCfg
58+ verifiedJWT <- Jose.runJOSE $ do
59+ unverifiedJWT <- Jose.decodeCompact (BSL.fromStrict input)
60+ Jose.verifyClaims
61+ (jwtSettingsToJwtValidationSettings jwtCfg)
62+ keys
63+ unverifiedJWT
64+ return $ case verifiedJWT of
65+ Left (_ :: Jose.JWTError) -> Nothing
66+ Right v -> case decodeJWT v of
67+ Left _ -> Nothing
68+ Right v' -> Just v'
servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/ThrowAll.hsnew file+58
@@ -0,0 +1,58 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE UndecidableInstances #-}
3+module Servant.Auth.Server.Internal.ThrowAll where
4+
5+#if !MIN_VERSION_servant_server(0,16,0)
6+#define ServerError ServantErr
7+#endif
8+
9+import Control.Monad.Error.Class
10+import Data.Tagged (Tagged (..))
11+import Servant ((:<|>) (..), ServerError(..), NamedRoutes(..))
12+import Servant.API.Generic
13+import Servant.Server.Generic
14+import Servant.Server
15+import Network.HTTP.Types
16+import Network.Wai
17+
18+import qualified Data.ByteString.Char8 as BS
19+
20+class ThrowAll a where
21+ -- | 'throwAll' is a convenience function to throw errors across an entire
22+ -- sub-API
23+ --
24+ --
25+ -- > throwAll err400 :: Handler a :<|> Handler b :<|> Handler c
26+ -- > == throwError err400 :<|> throwError err400 :<|> err400
27+ throwAll :: ServerError -> a
28+
29+instance (ThrowAll a, ThrowAll b) => ThrowAll (a :<|> b) where
30+ throwAll e = throwAll e :<|> throwAll e
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+
38+-- Really this shouldn't be necessary - ((->) a) should be an instance of
39+-- MonadError, no?
40+instance {-# OVERLAPPING #-} ThrowAll b => ThrowAll (a -> b) where
41+ throwAll e = const $ throwAll e
42+
43+instance {-# OVERLAPPABLE #-} (MonadError ServerError m) => ThrowAll (m a) where
44+ throwAll = throwError
45+
46+-- | for @servant <0.11@
47+instance {-# OVERLAPPING #-} ThrowAll Application where
48+ throwAll e _req respond
49+ = respond $ responseLBS (mkStatus (errHTTPCode e) (BS.pack $ errReasonPhrase e))
50+ (errHeaders e)
51+ (errBody e)
52+
53+-- | for @servant >=0.11@
54+instance {-# OVERLAPPING #-} MonadError ServerError m => ThrowAll (Tagged m Application) where
55+ throwAll e = Tagged $ \_req respond ->
56+ respond $ responseLBS (mkStatus (errHTTPCode e) (BS.pack $ errReasonPhrase e))
57+ (errHeaders e)
58+ (errBody e)
servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/Types.hsnew file+113
@@ -0,0 +1,113 @@
1+{-# LANGUAGE CPP #-}
2+module Servant.Auth.Server.Internal.Types where
3+
4+import Control.Applicative
5+import Control.Monad (MonadPlus(..), ap)
6+import Control.Monad.Reader
7+import Control.Monad.Time
8+import Data.Monoid (Monoid (..))
9+import Data.Semigroup (Semigroup (..))
10+import Data.Time (getCurrentTime)
11+import GHC.Generics (Generic)
12+import Network.Wai (Request)
13+
14+import qualified Control.Monad.Fail as Fail
15+
16+-- | The result of an authentication attempt.
17+data AuthResult val
18+ = BadPassword
19+ | NoSuchUser
20+ -- | Authentication succeeded.
21+ | Authenticated val
22+ -- | If an authentication procedure cannot be carried out - if for example it
23+ -- expects a password and username in a header that is not present -
24+ -- @Indefinite@ is returned. This indicates that other authentication
25+ -- methods should be tried.
26+ | Indefinite
27+ deriving (Eq, Show, Read, Generic, Ord, Functor, Traversable, Foldable)
28+
29+instance Semigroup (AuthResult val) where
30+ Indefinite <> y = y
31+ x <> _ = x
32+
33+instance Monoid (AuthResult val) where
34+ mempty = Indefinite
35+ mappend = (<>)
36+
37+instance Applicative AuthResult where
38+ pure = return
39+ (<*>) = ap
40+
41+instance Monad AuthResult where
42+ return = Authenticated
43+ Authenticated v >>= f = f v
44+ BadPassword >>= _ = BadPassword
45+ NoSuchUser >>= _ = NoSuchUser
46+ Indefinite >>= _ = Indefinite
47+
48+instance Alternative AuthResult where
49+ empty = mzero
50+ (<|>) = mplus
51+
52+instance MonadPlus AuthResult where
53+ mzero = mempty
54+ mplus = (<>)
55+
56+
57+-- | An @AuthCheck@ is the function used to decide the authentication status
58+-- (the 'AuthResult') of a request. Different @AuthCheck@s may be combined as a
59+-- Monoid or Alternative; the semantics of this is that the *first*
60+-- non-'Indefinite' result from left to right is used and the rest are ignored.
61+newtype AuthCheck val = AuthCheck
62+ { runAuthCheck :: Request -> IO (AuthResult val) }
63+ deriving (Generic, Functor)
64+
65+instance Semigroup (AuthCheck val) where
66+ AuthCheck f <> AuthCheck g = AuthCheck $ \x -> do
67+ fx <- f x
68+ case fx of
69+ Indefinite -> g x
70+ r -> pure r
71+
72+instance Monoid (AuthCheck val) where
73+ mempty = AuthCheck $ const $ return mempty
74+ mappend = (<>)
75+
76+instance Applicative AuthCheck where
77+ pure = return
78+ (<*>) = ap
79+
80+instance Monad AuthCheck where
81+ return = AuthCheck . return . return . return
82+ AuthCheck ac >>= f = AuthCheck $ \req -> do
83+ aresult <- ac req
84+ case aresult of
85+ Authenticated usr -> runAuthCheck (f usr) req
86+ BadPassword -> return BadPassword
87+ NoSuchUser -> return NoSuchUser
88+ Indefinite -> return Indefinite
89+
90+#if !MIN_VERSION_base(4,13,0)
91+ fail = Fail.fail
92+#endif
93+
94+instance Fail.MonadFail AuthCheck where
95+ fail _ = AuthCheck . const $ return Indefinite
96+
97+instance MonadReader Request AuthCheck where
98+ ask = AuthCheck $ \x -> return (Authenticated x)
99+ local f (AuthCheck check) = AuthCheck $ \req -> check (f req)
100+
101+instance MonadIO AuthCheck where
102+ liftIO action = AuthCheck $ const $ Authenticated <$> action
103+
104+instance MonadTime AuthCheck where
105+ currentTime = liftIO getCurrentTime
106+
107+instance Alternative AuthCheck where
108+ empty = mzero
109+ (<|>) = mplus
110+
111+instance MonadPlus AuthCheck where
112+ mzero = mempty
113+ mplus = (<>)
servant-auth/servant-auth-server/src/Servant/Auth/Server/SetCookieOrphan.hsnew file+3
@@ -0,0 +1,3 @@
1+module Servant.Auth.Server.SetCookieOrphan
2+ {-# DEPRECATED "instance exists in http-api-data-0.3.9. This module will be removed in next major release." #-}
3+ () where
servant-auth/servant-auth-server/test/Servant/Auth/ServerSpec.hsnew file+634
@@ -0,0 +1,634 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE TypeApplications #-}
3+module Servant.Auth.ServerSpec (spec) where
4+
5+#if !MIN_VERSION_servant_server(0,16,0)
6+#define ServerError ServantErr
7+#endif
8+
9+import Control.Lens
10+import Control.Monad.IO.Class (liftIO)
11+import Crypto.JOSE (Alg (HS256, None), Error,
12+ JWK, JWSHeader,
13+ KeyMaterialGenParam (OctGenParam),
14+ ToCompact, encodeCompact,
15+ genJWK, newJWSHeader, runJOSE)
16+import Crypto.JWT (Audience (..), ClaimsSet,
17+ NumericDate (NumericDate),
18+ SignedJWT,
19+ claimAud, claimNbf,
20+ signClaims,
21+ emptyClaimsSet,
22+ unregisteredClaims)
23+import Data.Aeson (FromJSON, ToJSON, Value,
24+ toJSON, encode)
25+import Data.Aeson.Lens (_JSON)
26+import qualified Data.ByteString as BS
27+import qualified Data.ByteString.Lazy as BSL
28+import Data.Text (Text, pack)
29+import Data.CaseInsensitive (mk)
30+import Data.Foldable (find)
31+import Data.Monoid
32+import Data.Time
33+import Data.Time.Clock (getCurrentTime)
34+import GHC.Generics (Generic)
35+import Network.HTTP.Client (cookie_http_only,
36+ cookie_name, cookie_value,
37+ cookie_expiry_time,
38+ destroyCookieJar)
39+import Network.HTTP.Types (Status, status200,
40+ status401)
41+import Network.Wai (responseLBS)
42+import Network.Wai.Handler.Warp (testWithApplication)
43+import Network.Wreq (Options, auth, basicAuth,
44+ checkResponse,
45+ cookieExpiryTime, cookies,
46+ defaults, get, getWith, postWith,
47+ header, oauth2Bearer,
48+ responseBody,
49+ responseCookieJar,
50+ responseHeader,
51+ responseStatus)
52+import Network.Wreq.Types (Postable(..))
53+import Servant hiding (BasicAuth,
54+ IsSecure (..), header)
55+import Servant.API.Generic ((:-))
56+import Servant.Auth.Server
57+import Servant.Auth.Server.Internal.Cookie (expireTime)
58+import Servant.Auth.Server.SetCookieOrphan ()
59+#if MIN_VERSION_servant_server(0,15,0)
60+import qualified Servant.Types.SourceT as S
61+#endif
62+import System.IO.Unsafe (unsafePerformIO)
63+import Test.Hspec
64+import Test.QuickCheck
65+import qualified Network.HTTP.Client as HCli
66+
67+
68+
69+spec :: Spec
70+spec = do
71+ authSpec
72+ cookieAuthSpec
73+ jwtAuthSpec
74+ throwAllSpec
75+ basicAuthSpec
76+
77+------------------------------------------------------------------------------
78+-- * Auth {{{
79+
80+authSpec :: Spec
81+authSpec
82+ = describe "The Auth combinator"
83+ $ around (testWithApplication . return $ app jwtAndCookieApi) $ do
84+
85+ it "returns a 401 if all authentications are Indefinite" $ \port -> do
86+ get (url port) `shouldHTTPErrorWith` status401
87+
88+ it "succeeds if one authentication suceeds" $ \port -> property $
89+ \(user :: User) -> do
90+ jwt <- makeJWT user jwtCfg Nothing
91+ opts <- addJwtToHeader jwt
92+ resp <- getWith opts (url port)
93+ resp ^? responseBody . _JSON `shouldBe` Just (length $ name user)
94+
95+ it "fails (403) if one authentication fails" $ const $
96+ pendingWith "Authentications don't yet fail, only are Indefinite"
97+
98+ it "doesn't clobber pre-existing response headers" $ \port -> property $
99+ \(user :: User) -> do
100+ jwt <- makeJWT user jwtCfg Nothing
101+ opts <- addJwtToHeader jwt
102+ resp <- getWith opts (url port ++ "/header")
103+ resp ^. responseHeader "Blah" `shouldBe` "1797"
104+ resp ^. responseHeader "Set-Cookie" `shouldSatisfy` (/= "")
105+
106+ context "Raw" $ do
107+
108+ it "gets the response body" $ \port -> property $ \(user :: User) -> do
109+ jwt <- makeJWT user jwtCfg Nothing
110+ opts <- addJwtToHeader jwt
111+ resp <- getWith opts (url port ++ "/raw")
112+ resp ^. responseBody `shouldBe` "how are you?"
113+
114+ it "doesn't clobber pre-existing reponse headers" $ \port -> property $
115+ \(user :: User) -> do
116+ jwt <- makeJWT user jwtCfg Nothing
117+ opts <- addJwtToHeader jwt
118+ resp <- getWith opts (url port ++ "/raw")
119+ resp ^. responseHeader "hi" `shouldBe` "there"
120+ resp ^. responseHeader "Set-Cookie" `shouldSatisfy` (/= "")
121+
122+
123+ context "Setting cookies" $ do
124+
125+ it "sets cookies that it itself accepts" $ \port -> property $ \user -> do
126+ jwt <- createJWT theKey (newJWSHeader ((), HS256))
127+ (claims $ toJSON user)
128+ opts' <- addJwtToCookie cookieCfg jwt
129+ let opts = addCookie (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"])
130+ (xsrfField xsrfCookieName cookieCfg <> "=blah")
131+ resp <- getWith opts (url port)
132+ let (cookieJar:_) = resp ^.. responseCookieJar
133+ Just xxsrf = find (\x -> cookie_name x == xsrfField xsrfCookieName cookieCfg)
134+ $ destroyCookieJar cookieJar
135+ opts2 = defaults
136+ & cookies .~ Just cookieJar
137+ & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ [cookie_value xxsrf]
138+ resp2 <- getWith opts2 (url port)
139+ resp2 ^? responseBody . _JSON `shouldBe` Just (length $ name user)
140+
141+ it "uses the Expiry from the configuration" $ \port -> property $ \(user :: User) -> do
142+ jwt <- createJWT theKey (newJWSHeader ((), HS256))
143+ (claims $ toJSON user)
144+ opts' <- addJwtToCookie cookieCfg jwt
145+ let opts = addCookie (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"])
146+ (xsrfField xsrfCookieName cookieCfg <> "=blah")
147+ resp <- getWith opts (url port)
148+ let (cookieJar:_) = resp ^.. responseCookieJar
149+ Just xxsrf = find (\x -> cookie_name x == xsrfField xsrfCookieName cookieCfg)
150+ $ destroyCookieJar cookieJar
151+ xxsrf ^. cookieExpiryTime `shouldBe` future
152+
153+ it "sets the token cookie as HttpOnly" $ \port -> property $ \(user :: User) -> do
154+ jwt <- createJWT theKey (newJWSHeader ((), HS256))
155+ (claims $ toJSON user)
156+ opts' <- addJwtToCookie cookieCfg jwt
157+ let opts = addCookie (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"])
158+ (xsrfField xsrfCookieName cookieCfg <> "=blah")
159+ resp <- getWith opts (url port)
160+ let (cookieJar:_) = resp ^.. responseCookieJar
161+ Just token = find (\x -> cookie_name x == sessionCookieName cookieCfg)
162+ $ destroyCookieJar cookieJar
163+ cookie_http_only token `shouldBe` True
164+
165+
166+
167+-- }}}
168+------------------------------------------------------------------------------
169+-- * Cookie Auth {{{
170+
171+cookieAuthSpec :: Spec
172+cookieAuthSpec
173+ = describe "The Auth combinator" $ do
174+ describe "With XSRF check" $
175+ around (testWithApplication . return $ app cookieOnlyApi) $ do
176+
177+ it "fails if XSRF header and cookie don't match" $ \port -> property
178+ $ \(user :: User) -> do
179+ jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)
180+ opts' <- addJwtToCookie cookieCfg jwt
181+ let opts = addCookie (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"])
182+ (xsrfField xsrfCookieName cookieCfg <> "=blerg")
183+ getWith opts (url port) `shouldHTTPErrorWith` status401
184+
185+ it "fails with no XSRF header or cookie" $ \port -> property
186+ $ \(user :: User) -> do
187+ jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)
188+ opts' <- addJwtToCookie cookieCfg jwt
189+ let opts = opts' & checkResponse .~ Just mempty
190+ resp <- getWith opts (url port)
191+ resp ^. responseStatus `shouldBe` status401
192+ (resp ^. responseCookieJar) `shouldNotHaveCookies` ["XSRF-TOKEN"]
193+
194+ -- Validating that the XSRF cookie isn't added for UVerb routes either.
195+ -- These routes can return a 401 response directly without using throwError / throwAll,
196+ -- which revealed a bug:
197+ --
198+ -- https://github.com/haskell-servant/servant/issues/1570#issuecomment-1076374449
199+ resp <- getWith opts (url port ++ "/uverb")
200+ resp ^. responseStatus `shouldBe` status401
201+ (resp ^. responseCookieJar) `shouldNotHaveCookies` ["XSRF-TOKEN"]
202+
203+
204+ it "succeeds if XSRF header and cookie match, and JWT is valid" $ \port -> property
205+ $ \(user :: User) -> do
206+ jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)
207+ opts' <- addJwtToCookie cookieCfg jwt
208+ let opts = addCookie (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"])
209+ (xsrfField xsrfCookieName cookieCfg <> "=blah")
210+ resp <- getWith opts (url port)
211+ resp ^? responseBody . _JSON `shouldBe` Just (length $ name user)
212+
213+ it "sets and clears the right cookies" $ \port -> property
214+ $ \(user :: User) -> do
215+ let optsFromResp resp =
216+ let jar = resp ^. responseCookieJar
217+ Just xsrfCookieValue = cookie_value <$> find (\c -> cookie_name c == xsrfField xsrfCookieName cookieCfg) (destroyCookieJar jar)
218+ in defaults
219+ & cookies .~ Just jar -- real cookie jars aren't updated by being replaced
220+ & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ [xsrfCookieValue]
221+
222+ resp <- postWith defaults (url port ++ "/login") user
223+ (resp ^. responseCookieJar) `shouldMatchCookieNames`
224+ [ sessionCookieName cookieCfg
225+ , xsrfField xsrfCookieName cookieCfg
226+ ]
227+ let loggedInOpts = optsFromResp resp
228+
229+ resp <- getWith loggedInOpts (url port)
230+ resp ^? responseBody . _JSON `shouldBe` Just (length $ name user)
231+
232+ -- logout
233+ resp <- getWith loggedInOpts (url port ++ "/logout")
234+
235+ -- assert cookies were expired
236+ now <- getCurrentTime
237+ let assertCookie c = now >= cookie_expiry_time c
238+ all assertCookie (destroyCookieJar (resp ^. responseCookieJar)) `shouldBe` True
239+
240+ let loggedOutOpts = optsFromResp resp
241+ getWith loggedOutOpts (url port) `shouldHTTPErrorWith` status401
242+
243+ describe "With no XSRF check for GET requests" $ let
244+ noXsrfGet xsrfCfg = xsrfCfg { xsrfExcludeGet = True }
245+ cookieCfgNoXsrfGet = cookieCfg { cookieXsrfSetting = fmap noXsrfGet $ cookieXsrfSetting cookieCfg }
246+ in around (testWithApplication . return $ appWithCookie cookieOnlyApi cookieCfgNoXsrfGet) $ do
247+
248+ it "succeeds with no XSRF header or cookie for GET" $ \port -> property
249+ $ \(user :: User) -> do
250+ jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)
251+ opts <- addJwtToCookie cookieCfgNoXsrfGet jwt
252+ resp <- getWith opts (url port)
253+ resp ^? responseBody . _JSON `shouldBe` Just (length $ name user)
254+
255+ it "fails with no XSRF header or cookie for POST" $ \port -> property
256+ $ \(user :: User) number -> do
257+ jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)
258+ opts <- addJwtToCookie cookieCfgNoXsrfGet jwt
259+ postWith opts (url port) (toJSON (number :: Int)) `shouldHTTPErrorWith` status401
260+
261+ describe "With no XSRF check at all" $ let
262+ cookieCfgNoXsrf = cookieCfg { cookieXsrfSetting = Nothing }
263+ in around (testWithApplication . return $ appWithCookie cookieOnlyApi cookieCfgNoXsrf) $ do
264+
265+ it "succeeds with no XSRF header or cookie for GET" $ \port -> property
266+ $ \(user :: User) -> do
267+ jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)
268+ opts <- addJwtToCookie cookieCfgNoXsrf jwt
269+ resp <- getWith opts (url port)
270+ resp ^? responseBody . _JSON `shouldBe` Just (length $ name user)
271+
272+ it "succeeds with no XSRF header or cookie for POST" $ \port -> property
273+ $ \(user :: User) number -> do
274+ jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)
275+ opts <- addJwtToCookie cookieCfgNoXsrf jwt
276+ resp <- postWith opts (url port) $ toJSON (number :: Int)
277+ resp ^? responseBody . _JSON `shouldBe` Just number
278+
279+ it "sets and clears the right cookies" $ \port -> property
280+ $ \(user :: User) -> do
281+ let optsFromResp resp = defaults
282+ & cookies .~ Just (resp ^. responseCookieJar) -- real cookie jars aren't updated by being replaced
283+
284+ resp <- postWith defaults (url port ++ "/login") user
285+ (resp ^. responseCookieJar) `shouldMatchCookieNames`
286+ [ sessionCookieName cookieCfg
287+ , "NO-XSRF-TOKEN"
288+ ]
289+ let loggedInOpts = optsFromResp resp
290+
291+ resp <- getWith (loggedInOpts) (url port)
292+ resp ^? responseBody . _JSON `shouldBe` Just (length $ name user)
293+
294+ resp <- getWith loggedInOpts (url port ++ "/logout")
295+ (resp ^. responseCookieJar) `shouldMatchCookieNameValues`
296+ [ (sessionCookieName cookieCfg, "value")
297+ , ("NO-XSRF-TOKEN", "")
298+ ]
299+
300+ -- assert cookies were expired
301+ now <- getCurrentTime
302+ let assertCookie c = now >= cookie_expiry_time c
303+ all assertCookie (destroyCookieJar (resp ^. responseCookieJar)) `shouldBe` True
304+
305+ let loggedOutOpts = optsFromResp resp
306+
307+ getWith loggedOutOpts (url port) `shouldHTTPErrorWith` status401
308+
309+-- }}}
310+------------------------------------------------------------------------------
311+-- * JWT Auth {{{
312+
313+jwtAuthSpec :: Spec
314+jwtAuthSpec
315+ = describe "The JWT combinator"
316+ $ around (testWithApplication . return $ app jwtOnlyApi) $ do
317+
318+ it "fails if 'aud' does not match predicate" $ \port -> property $
319+ \(user :: User) -> do
320+ jwt <- createJWT theKey (newJWSHeader ((), HS256))
321+ (claims (toJSON user) & claimAud .~ Just (Audience ["boo"]))
322+ opts <- addJwtToHeader (jwt >>= (return . encodeCompact))
323+ getWith opts (url port) `shouldHTTPErrorWith` status401
324+
325+ it "succeeds if 'aud' does match predicate" $ \port -> property $
326+ \(user :: User) -> do
327+ jwt <- createJWT theKey (newJWSHeader ((), HS256))
328+ (claims (toJSON user) & claimAud .~ Just (Audience ["anythingElse"]))
329+ opts <- addJwtToHeader (jwt >>= (return . encodeCompact))
330+ resp <- getWith opts (url port)
331+ resp ^. responseStatus `shouldBe` status200
332+
333+ it "fails if 'nbf' is set to a future date" $ \port -> property $
334+ \(user :: User) -> do
335+ jwt <- createJWT theKey (newJWSHeader ((), HS256))
336+ (claims (toJSON user) & claimNbf .~ Just (NumericDate future))
337+ opts <- addJwtToHeader (jwt >>= (return . encodeCompact))
338+ getWith opts (url port) `shouldHTTPErrorWith` status401
339+
340+ it "fails if 'exp' is set to a past date" $ \port -> property $
341+ \(user :: User) -> do
342+ jwt <- makeJWT user jwtCfg (Just past)
343+ opts <- addJwtToHeader jwt
344+ getWith opts (url port) `shouldHTTPErrorWith` status401
345+
346+ it "succeeds if 'exp' is set to a future date" $ \port -> property $
347+ \(user :: User) -> do
348+ jwt <- makeJWT user jwtCfg (Just future)
349+ opts <- addJwtToHeader jwt
350+ resp <- getWith opts (url port)
351+ resp ^. responseStatus `shouldBe` status200
352+
353+ it "fails if JWT is not signed" $ \port -> property $ \(user :: User) -> do
354+ jwt <- createJWT theKey (newJWSHeader ((), None))
355+ (claims $ toJSON user)
356+ opts <- addJwtToHeader (jwt >>= (return . encodeCompact))
357+ getWith opts (url port) `shouldHTTPErrorWith` status401
358+
359+ it "fails if JWT does not use expected algorithm" $ const $
360+ pendingWith "Need https://github.com/frasertweedale/hs-jose/issues/19"
361+
362+ it "fails if data is not valid JSON" $ \port -> do
363+ jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims "{{")
364+ opts <- addJwtToHeader (jwt >>= (return .encodeCompact))
365+ getWith opts (url port) `shouldHTTPErrorWith` status401
366+
367+ it "suceeds as wreq's oauth2Bearer" $ \port -> property $ \(user :: User) -> do
368+ jwt <- createJWT theKey (newJWSHeader ((), HS256))
369+ (claims $ toJSON user)
370+ resp <- case jwt >>= (return . encodeCompact) of
371+ Left (e :: Error) -> fail $ show e
372+ Right v -> getWith (defaults & auth ?~ oauth2Bearer (BSL.toStrict v)) (url port)
373+ resp ^. responseStatus `shouldBe` status200
374+
375+-- }}}
376+------------------------------------------------------------------------------
377+-- * Basic Auth {{{
378+
379+basicAuthSpec :: Spec
380+basicAuthSpec = describe "The BasicAuth combinator"
381+ $ around (testWithApplication . return $ app basicAuthApi) $ do
382+
383+ it "succeeds with the correct password and username" $ \port -> do
384+ resp <- getWith (defaults & auth ?~ basicAuth "ali" "Open sesame") (url port)
385+ resp ^. responseStatus `shouldBe` status200
386+
387+ it "fails with non-existent user" $ \port -> do
388+ getWith (defaults & auth ?~ basicAuth "thief" "Open sesame") (url port)
389+ `shouldHTTPErrorWith` status401
390+
391+ it "fails with incorrect password" $ \port -> do
392+ getWith (defaults & auth ?~ basicAuth "ali" "phatic") (url port)
393+ `shouldHTTPErrorWith` status401
394+
395+ it "fails with no auth header" $ \port -> do
396+ get (url port) `shouldHTTPErrorWith` status401
397+
398+-- }}}
399+------------------------------------------------------------------------------
400+-- * ThrowAll {{{
401+
402+throwAllSpec :: Spec
403+throwAllSpec = describe "throwAll" $ do
404+
405+ it "works for plain values" $ do
406+ let t :: Either ServerError Int :<|> Either ServerError Bool :<|> Either ServerError String
407+ t = throwAll err401
408+ t `shouldBe` throwError err401 :<|> throwError err401 :<|> throwError err401
409+
410+ it "works for function types" $ property $ \i -> do
411+ let t :: Int -> (Either ServerError Bool :<|> Either ServerError String)
412+ t = throwAll err401
413+ expected _ = throwError err401 :<|> throwError err401
414+ t i `shouldBe` expected i
415+
416+-- }}}
417+------------------------------------------------------------------------------
418+-- * API and Server {{{
419+
420+type API auths
421+ = Auth auths User :>
422+ ( Get '[JSON] Int
423+ :<|> ReqBody '[JSON] Int :> Post '[JSON] Int
424+ :<|> "named" :> NamedRoutes DummyRoutes
425+ :<|> "header" :> Get '[JSON] (Headers '[Header "Blah" Int] Int)
426+#if MIN_VERSION_servant_server(0,15,0)
427+ :<|> "stream" :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString)
428+#endif
429+ :<|> "raw" :> Raw
430+ )
431+ :<|> "uverb" :> Auth auths User :> UVerb 'GET '[JSON] '[WithStatus 200 Int, WithStatus 401 Text, WithStatus 403 Text]
432+ :<|> "login" :> ReqBody '[JSON] User :> Post '[JSON] (Headers '[ Header "Set-Cookie" SetCookie
433+ , Header "Set-Cookie" SetCookie ] NoContent)
434+ :<|> "logout" :> Get '[JSON] (Headers '[ Header "Set-Cookie" SetCookie
435+ , Header "Set-Cookie" SetCookie ] NoContent)
436+
437+data DummyRoutes mode = DummyRoutes
438+ { dummyInt :: mode :- "dummy" :> Get '[JSON] Int
439+ } deriving Generic
440+
441+jwtOnlyApi :: Proxy (API '[Servant.Auth.Server.JWT])
442+jwtOnlyApi = Proxy
443+
444+cookieOnlyApi :: Proxy (API '[Cookie])
445+cookieOnlyApi = Proxy
446+
447+basicAuthApi :: Proxy (API '[BasicAuth])
448+basicAuthApi = Proxy
449+
450+jwtAndCookieApi :: Proxy (API '[Servant.Auth.Server.JWT, Cookie])
451+jwtAndCookieApi = Proxy
452+
453+theKey :: JWK
454+theKey = unsafePerformIO . genJWK $ OctGenParam 256
455+{-# NOINLINE theKey #-}
456+
457+
458+cookieCfg :: CookieSettings
459+cookieCfg = def
460+ { cookieExpires = Just future
461+ , cookieIsSecure = NotSecure
462+ , sessionCookieName = "RuncibleSpoon"
463+ , cookieXsrfSetting = pure $ def
464+ { xsrfCookieName = "TheyDinedOnMince"
465+ , xsrfHeaderName = "AndSlicesOfQuince"
466+ }
467+ }
468+xsrfField :: (XsrfCookieSettings -> a) -> CookieSettings -> a
469+xsrfField f = maybe (error "expected XsrfCookieSettings for test") f . cookieXsrfSetting
470+
471+jwtCfg :: JWTSettings
472+jwtCfg = (defaultJWTSettings theKey) { audienceMatches = \x ->
473+ if x == "boo" then DoesNotMatch else Matches }
474+
475+instance FromBasicAuthData User where
476+ fromBasicAuthData (BasicAuthData usr pwd) _
477+ = return $ if usr == "ali" && pwd == "Open sesame"
478+ then Authenticated $ User "ali" "ali@the-thieves-den.com"
479+ else Indefinite
480+
481+-- Could be anything, really, but since this is already in the cfg we don't
482+-- have to add it
483+type instance BasicAuthCfg = JWK
484+
485+appWithCookie :: AreAuths auths '[CookieSettings, JWTSettings, JWK] User
486+ => Proxy (API auths) -> CookieSettings -> Application
487+appWithCookie api ccfg = serveWithContext api ctx $ server ccfg
488+ where
489+ ctx = ccfg :. jwtCfg :. theKey :. EmptyContext
490+
491+-- | Takes a proxy parameter indicating which authentication systems to enable.
492+app :: AreAuths auths '[CookieSettings, JWTSettings, JWK] User
493+ => Proxy (API auths) -> Application
494+app api = appWithCookie api cookieCfg
495+
496+server :: CookieSettings -> Server (API auths)
497+server ccfg =
498+ (\authResult -> case authResult of
499+ Authenticated usr -> getInt usr
500+ :<|> postInt usr
501+ :<|> DummyRoutes { dummyInt = getInt usr }
502+ :<|> getHeaderInt
503+#if MIN_VERSION_servant_server(0,15,0)
504+ :<|> return (S.source ["bytestring"])
505+#endif
506+ :<|> raw
507+ Indefinite -> throwAll err401
508+ _ -> throwAll err403
509+ ) :<|>
510+ (\authResult -> case authResult of
511+ Authenticated usr -> respond (WithStatus @200 (42 :: Int))
512+ Indefinite -> respond (WithStatus @401 $ pack "Authentication required")
513+ _ -> respond (WithStatus @403 $ pack "Forbidden")
514+ )
515+ :<|> getLogin
516+ :<|> getLogout
517+ where
518+ getInt :: User -> Handler Int
519+ getInt usr = return . length $ name usr
520+
521+ postInt :: User -> Int -> Handler Int
522+ postInt _ = return
523+
524+ getHeaderInt :: Handler (Headers '[Header "Blah" Int] Int)
525+ getHeaderInt = return $ addHeader 1797 17
526+
527+ getLogin :: User -> Handler (Headers '[ Header "Set-Cookie" SetCookie
528+ , Header "Set-Cookie" SetCookie ] NoContent)
529+ getLogin user = do
530+ maybeApplyCookies <- liftIO $ acceptLogin ccfg jwtCfg user
531+ case maybeApplyCookies of
532+ Just applyCookies -> return $ applyCookies NoContent
533+ Nothing -> error "cookies failed to apply"
534+
535+ getLogout :: Handler (Headers '[ Header "Set-Cookie" SetCookie
536+ , Header "Set-Cookie" SetCookie ] NoContent)
537+ getLogout = return $ clearSession ccfg NoContent
538+
539+ raw :: Server Raw
540+ raw =
541+#if MIN_VERSION_servant_server(0,11,0)
542+ Tagged $
543+#endif
544+ \_req respond ->
545+ respond $ responseLBS status200 [("hi", "there")] "how are you?"
546+
547+-- }}}
548+------------------------------------------------------------------------------
549+-- * Utils {{{
550+
551+past :: UTCTime
552+past = parseTimeOrError True defaultTimeLocale "%Y-%m-%d" "1970-01-01"
553+
554+future :: UTCTime
555+future = parseTimeOrError True defaultTimeLocale "%Y-%m-%d" "2070-01-01"
556+
557+addJwtToHeader :: Either Error BSL.ByteString -> IO Options
558+addJwtToHeader jwt = case jwt of
559+ Left e -> fail $ show e
560+ Right v -> return
561+ $ defaults & header "Authorization" .~ ["Bearer " <> BSL.toStrict v]
562+
563+createJWT :: JWK -> JWSHeader () -> ClaimsSet -> IO (Either Error Crypto.JWT.SignedJWT)
564+createJWT k a b = runJOSE $ signClaims k a b
565+
566+addJwtToCookie :: ToCompact a => CookieSettings -> Either Error a -> IO Options
567+addJwtToCookie ccfg jwt = case jwt >>= (return . encodeCompact) of
568+ Left e -> fail $ show e
569+ Right v -> return
570+ $ defaults & header "Cookie" .~ [sessionCookieName ccfg <> "=" <> BSL.toStrict v]
571+
572+addCookie :: Options -> BS.ByteString -> Options
573+addCookie opts cookie' = opts & header "Cookie" %~ \c -> case c of
574+ [h] -> [cookie' <> "; " <> h]
575+ [] -> [cookie']
576+ _ -> error "expecting single cookie header"
577+
578+
579+shouldHTTPErrorWith :: IO a -> Status -> Expectation
580+shouldHTTPErrorWith act stat = act `shouldThrow` \e -> case e of
581+#if MIN_VERSION_http_client(0,5,0)
582+ HCli.HttpExceptionRequest _ (HCli.StatusCodeException resp _)
583+ -> HCli.responseStatus resp == stat
584+#else
585+ HCli.StatusCodeException x _ _ -> x == stat
586+#endif
587+ _ -> False
588+
589+shouldMatchCookieNames :: HCli.CookieJar -> [BS.ByteString] -> Expectation
590+shouldMatchCookieNames cj patterns
591+ = fmap cookie_name (destroyCookieJar cj)
592+ `shouldMatchList` patterns
593+
594+shouldNotHaveCookies :: HCli.CookieJar -> [BS.ByteString] -> Expectation
595+shouldNotHaveCookies cj patterns =
596+ sequence_ $ (\cookieName -> cookieNames `shouldNotContain` [cookieName]) <$> patterns
597+ where cookieNames :: [BS.ByteString]
598+ cookieNames = cookie_name <$> destroyCookieJar cj
599+
600+shouldMatchCookieNameValues :: HCli.CookieJar -> [(BS.ByteString, BS.ByteString)] -> Expectation
601+shouldMatchCookieNameValues cj patterns
602+ = fmap ((,) <$> cookie_name <*> cookie_value) (destroyCookieJar cj)
603+ `shouldMatchList` patterns
604+
605+url :: Int -> String
606+url port = "http://localhost:" <> show port
607+
608+claims :: Value -> ClaimsSet
609+claims val = emptyClaimsSet & unregisteredClaims . at "dat" .~ Just val
610+-- }}}
611+------------------------------------------------------------------------------
612+-- * Types {{{
613+
614+data User = User
615+ { name :: String
616+ , _id :: String
617+ } deriving (Eq, Show, Read, Generic)
618+
619+instance FromJWT User
620+instance ToJWT User
621+instance FromJSON User
622+instance ToJSON User
623+
624+instance Arbitrary User where
625+ arbitrary = User <$> arbitrary <*> arbitrary
626+
627+instance Postable User where
628+ postPayload user request = return $ request
629+ { HCli.requestBody = HCli.RequestBodyLBS $ encode user
630+ , HCli.requestHeaders = (mk "Content-Type", "application/json") : HCli.requestHeaders request
631+ }
632+
633+
634+-- }}}
servant-auth/servant-auth-server/test/Spec.hsnew file+1
@@ -0,0 +1 @@
1+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
servant-auth/servant-auth-swagger/.ghcinew file+1
@@ -0,0 +1 @@
1+:set -isrc -itest -idoctest/ghci-wrapper/src
servant-auth/servant-auth-swagger/CHANGELOG.mdnew file+24
@@ -0,0 +1,24 @@
1+# Changelog
2+
3+All notable changes to this project will be documented in this file.
4+
5+The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/)
6+and this project adheres to [PVP Versioning](https://pvp.haskell.org/).
7+
8+## [Unreleased]
9+
10+## [0.2.10.1] - 2020-10-06
11+
12+### Changed
13+
14+- Support GHC 8.10 @domenkozar
15+- Fix build with swagger 2.5.x @domenkozar
16+
17+## [0.2.10.0] - 2018-06-18
18+
19+### Added
20+
21+- Support for GHC 8.4 by @phadej
22+- Changelog by @domenkozar
23+- #93: Add Cookie in SwaggerSpec API by @domenkozar
24+- #42: Add dummy AllHasSecurity Cookie instance by @sordina
servant-auth/servant-auth-swagger/LICENSEnew file+31
@@ -0,0 +1,31 @@
1+Copyright Julian K. Arni (c) 2015
2+
3+All rights reserved.
4+
5+Redistribution and use in source and binary forms, with or without
6+modification, are permitted provided that the following conditions are met:
7+
8+ * Redistributions of source code must retain the above copyright
9+ notice, this list of conditions and the following disclaimer.
10+
11+ * Redistributions in binary form must reproduce the above
12+ copyright notice, this list of conditions and the following
13+ disclaimer in the documentation and/or other materials provided
14+ with the distribution.
15+
16+ * Neither the name of Julian K. Arni nor the names of other
17+ contributors may be used to endorse or promote products derived
18+ from this software without specific prior written permission.
19+
20+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31+
servant-auth/servant-auth-swagger/Setup.hsnew file+2
@@ -0,0 +1,2 @@
1+import Distribution.Simple
2+main = defaultMain
servant-auth/servant-auth-swagger/servant-auth-swagger.cabalnew file+70
@@ -0,0 +1,70 @@
1+cabal-version: 2.2
2+name: servant-auth-swagger
3+version: 0.2.10.1
4+synopsis: servant-swagger/servant-auth compatibility
5+description: This package provides instances that allow generating swagger2 schemas from
6+ <https://hackage.haskell.org/package/servant servant>
7+ APIs that use
8+ <https://hackage.haskell.org/package/servant-auth servant-auth's> @Auth@ combinator.
9+ .
10+ For a quick overview of the usage, see the <https://github.com/haskell-servant/servant/tree/master/servant-auth#readme README>.
11+category: Web, Servant, Authentication
12+homepage: https://github.com/haskell-servant/servant/tree/master/servant-auth#readme
13+bug-reports: https://github.com/haskell-servant/servant/issues
14+author: Julian K. Arni
15+maintainer: jkarni@gmail.com
16+copyright: (c) Julian K. Arni
17+license: BSD-3-Clause
18+license-file: LICENSE
19+tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4
20+build-type: Simple
21+extra-source-files:
22+ CHANGELOG.md
23+
24+source-repository head
25+ type: git
26+ location: https://github.com/haskell-servant/servant
27+
28+library
29+ hs-source-dirs:
30+ src
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
33+ build-depends:
34+ base >= 4.10 && < 4.18
35+ , text >= 1.2.3.0 && < 2.1
36+ , servant-swagger >= 1.1.5 && < 2
37+ , swagger2 >= 2.2.2 && < 3
38+ , servant >= 0.13 && < 0.20
39+ , servant-auth == 0.4.*
40+ , lens >= 4.16.1 && < 5.3
41+ exposed-modules:
42+ Servant.Auth.Swagger
43+ default-language: Haskell2010
44+
45+test-suite spec
46+ type: exitcode-stdio-1.0
47+ main-is: Spec.hs
48+ hs-source-dirs:
49+ test
50+ default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
51+ ghc-options: -Wall
52+ build-tool-depends: hspec-discover:hspec-discover >= 2.5.5 && <2.10
53+ -- dependencies with bounds inherited from the library stanza
54+ build-depends:
55+ base
56+ , text
57+ , servant-swagger
58+ , swagger2
59+ , servant
60+ , servant-auth
61+ , lens
62+
63+ -- test dependencies
64+ build-depends:
65+ servant-auth-swagger
66+ , hspec >= 2.5.5 && < 2.10
67+ , QuickCheck >= 2.11.3 && < 2.15
68+ other-modules:
69+ Servant.Auth.SwaggerSpec
70+ default-language: Haskell2010
servant-auth/servant-auth-swagger/src/Servant/Auth/Swagger.hsnew file+87
@@ -0,0 +1,87 @@
1+{-# OPTIONS_GHC -fno-warn-orphans #-}
2+{-# LANGUAGE CPP #-}
3+module Servant.Auth.Swagger
4+ (
5+ -- | The purpose of this package is provide the instance for 'servant-auth'
6+ -- combinators needed for 'servant-swagger' documentation generation.
7+ --
8+ -- Currently only JWT and BasicAuth are supported.
9+
10+ -- * Re-export
11+ JWT
12+ , BasicAuth
13+ , Auth
14+
15+ -- * Needed to define instances of @HasSwagger@
16+ , HasSecurity (..)
17+ ) where
18+
19+import Control.Lens ((&), (<>~))
20+import Data.Proxy (Proxy (Proxy))
21+import Data.Swagger (ApiKeyLocation (..), ApiKeyParams (..),
22+ SecurityRequirement (..), SecurityScheme (..),
23+#if MIN_VERSION_swagger2(2,6,0)
24+ SecurityDefinitions(..),
25+#endif
26+ SecuritySchemeType (..), allOperations, security,
27+ securityDefinitions)
28+import GHC.Exts (fromList)
29+import Servant.API hiding (BasicAuth)
30+import Servant.Auth
31+import Servant.Swagger
32+
33+import qualified Data.Text as T
34+
35+instance (AllHasSecurity xs, HasSwagger api) => HasSwagger (Auth xs r :> api) where
36+ toSwagger _
37+ = toSwagger (Proxy :: Proxy api)
38+ & securityDefinitions <>~ mkSec (fromList secs)
39+ & allOperations.security <>~ secReqs
40+ where
41+ secs = securities (Proxy :: Proxy xs)
42+ secReqs = [ SecurityRequirement (fromList [(s,[])]) | (s,_) <- secs]
43+ mkSec =
44+#if MIN_VERSION_swagger2(2,6,0)
45+ SecurityDefinitions
46+#else
47+ id
48+#endif
49+
50+
51+class HasSecurity x where
52+ securityName :: Proxy x -> T.Text
53+ securityScheme :: Proxy x -> SecurityScheme
54+
55+instance HasSecurity BasicAuth where
56+ securityName _ = "BasicAuth"
57+ securityScheme _ = SecurityScheme type_ (Just desc)
58+ where
59+ type_ = SecuritySchemeBasic
60+ desc = "Basic access authentication"
61+
62+instance HasSecurity JWT where
63+ securityName _ = "JwtSecurity"
64+ securityScheme _ = SecurityScheme type_ (Just desc)
65+ where
66+ type_ = SecuritySchemeApiKey (ApiKeyParams "Authorization" ApiKeyHeader)
67+ desc = "JSON Web Token-based API key"
68+
69+class AllHasSecurity (x :: [*]) where
70+ securities :: Proxy x -> [(T.Text,SecurityScheme)]
71+
72+instance {-# OVERLAPPABLE #-} (HasSecurity x, AllHasSecurity xs) => AllHasSecurity (x ': xs) where
73+ securities _ = (securityName px, securityScheme px) : securities pxs
74+ where
75+ px :: Proxy x
76+ px = Proxy
77+ pxs :: Proxy xs
78+ pxs = Proxy
79+
80+instance {-# OVERLAPPING #-} AllHasSecurity xs => AllHasSecurity (Cookie ': xs) where
81+ securities _ = securities pxs
82+ where
83+ pxs :: Proxy xs
84+ pxs = Proxy
85+
86+instance AllHasSecurity '[] where
87+ securities _ = []
servant-auth/servant-auth-swagger/test/Servant/Auth/SwaggerSpec.hsnew file+38
@@ -0,0 +1,38 @@
1+{-# LANGUAGE CPP #-}
2+module Servant.Auth.SwaggerSpec (spec) where
3+
4+import Control.Lens
5+import Data.Proxy
6+import Servant.API
7+import Servant.Auth
8+import Servant.Auth.Swagger
9+import Data.Swagger
10+import Servant.Swagger
11+import Test.Hspec
12+
13+spec :: Spec
14+spec = describe "HasSwagger instance" $ do
15+
16+ let swag = toSwagger (Proxy :: Proxy API)
17+
18+ it "adds security definitions at the top level" $ do
19+#if MIN_VERSION_swagger2(2,6,0)
20+ let (SecurityDefinitions secDefs) = swag ^. securityDefinitions
21+#else
22+ let secDefs = swag ^. securityDefinitions
23+#endif
24+ length secDefs `shouldSatisfy` (> 0)
25+
26+ it "adds security at sub-apis" $ do
27+ swag ^. security `shouldBe` []
28+ show (swag ^. paths . at "/secure") `shouldContain` "JwtSecurity"
29+ show (swag ^. paths . at "/insecure") `shouldNotContain` "JwtSecurity"
30+
31+-- * API
32+
33+type API = "secure" :> Auth '[JWT, Cookie] Int :> SecureAPI
34+ :<|> "insecure" :> InsecureAPI
35+
36+type SecureAPI = Get '[JSON] Int :<|> ReqBody '[JSON] Int :> Post '[JSON] Int
37+
38+type InsecureAPI = SecureAPI
servant-auth/servant-auth-swagger/test/Spec.hsnew file+1
@@ -0,0 +1 @@
1+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
servant-auth/servant-auth/.ghcinew file+1
@@ -0,0 +1 @@
1+:set -isrc -itest -idoctest/ghci-wrapper/src
servant-auth/servant-auth/CHANGELOG.mdnew file+20
@@ -0,0 +1,20 @@
1+# Changelog
2+
3+All notable changes to this project will be documented in this file.
4+
5+The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/)
6+and this project adheres to [PVP Versioning](https://pvp.haskell.org/).
7+
8+## [Unreleased]
9+
10+## [0.4.0.0] - 2020-10-06
11+
12+- Support for GHC 8.10 by @domenkozar
13+- Support servant 0.18 by @domenkozar
14+- Move `ToJWT/FromJWT` from servant-auth-server
15+
16+## [0.3.2.0] - 2018-06-18
17+
18+### Added
19+- Support for GHC 8.4 by @phadej
20+- Changelog by @domenkozar
servant-auth/servant-auth/LICENSEnew file+31
@@ -0,0 +1,31 @@
1+Copyright Julian K. Arni (c) 2015
2+
3+All rights reserved.
4+
5+Redistribution and use in source and binary forms, with or without
6+modification, are permitted provided that the following conditions are met:
7+
8+ * Redistributions of source code must retain the above copyright
9+ notice, this list of conditions and the following disclaimer.
10+
11+ * Redistributions in binary form must reproduce the above
12+ copyright notice, this list of conditions and the following
13+ disclaimer in the documentation and/or other materials provided
14+ with the distribution.
15+
16+ * Neither the name of Julian K. Arni nor the names of other
17+ contributors may be used to endorse or promote products derived
18+ from this software without specific prior written permission.
19+
20+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31+
servant-auth/servant-auth/Setup.hsnew file+2
@@ -0,0 +1,2 @@
1+import Distribution.Simple
2+main = defaultMain
servant-auth/servant-auth/servant-auth.cabalnew file+47
@@ -0,0 +1,47 @@
1+cabal-version: 2.2
2+name: servant-auth
3+version: 0.4.1.0
4+synopsis: Authentication combinators for servant
5+description: This package provides an @Auth@ combinator for 'servant'. This combinator
6+ allows using different authentication schemes in a straightforward way,
7+ and possibly in conjunction with one another.
8+ .
9+ 'servant-auth' additionally provides concrete authentication schemes, such
10+ as Basic Access Authentication, JSON Web Tokens, and Cookies.
11+ .
12+ For more details on how to use this, see the <https://github.com/haskell-servant/servant/tree/master/servant-auth#readme README>.
13+category: Web, Servant, Authentication
14+homepage: https://github.com/haskell-servant/servant/tree/master/servant-auth#readme
15+bug-reports: https://github.com/haskell-servant/servant/issues
16+author: Julian K. Arni
17+maintainer: jkarni@gmail.com
18+copyright: (c) Julian K. Arni
19+license: BSD-3-Clause
20+license-file: LICENSE
21+tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1
22+build-type: Simple
23+extra-source-files:
24+ CHANGELOG.md
25+
26+source-repository head
27+ type: git
28+ location: https://github.com/haskell-servant/servant
29+
30+library
31+ hs-source-dirs:
32+ src
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
35+ build-depends:
36+ base >= 4.10 && < 4.18
37+ , containers >= 0.6 && < 0.7
38+ , aeson >= 1.3.1.1 && < 3
39+ , jose >= 0.10 && < 0.11
40+ , lens >= 4.16.1 && < 5.3
41+ , servant >= 0.15 && < 0.20
42+ , text >= 1.2.3.0 && < 2.1
43+ , unordered-containers >= 0.2.9.0 && < 0.3
44+ exposed-modules:
45+ Servant.Auth
46+ Servant.Auth.JWT
47+ default-language: Haskell2010
servant-auth/servant-auth/src/Servant/Auth.hsnew file+54
@@ -0,0 +1,54 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4+{-# LANGUAGE TypeFamilies #-}
5+{-# LANGUAGE TypeOperators #-}
6+module Servant.Auth where
7+
8+import Data.Proxy (Proxy(..))
9+import Servant.API ((:>))
10+import Servant.Links (HasLink (..))
11+
12+-- * Authentication
13+
14+-- | @Auth [auth1, auth2] val :> api@ represents an API protected *either* by
15+-- @auth1@ or @auth2@
16+data Auth (auths :: [*]) val
17+
18+-- | A @HasLink@ instance for @Auth@
19+instance HasLink sub => HasLink (Auth (tag :: [*]) value :> sub) where
20+#if MIN_VERSION_servant(0,14,0)
21+ type MkLink (Auth (tag :: [*]) value :> sub) a = MkLink sub a
22+ toLink toA _ = toLink toA (Proxy :: Proxy sub)
23+#else
24+ type MkLink (Auth (tag :: [*]) value :> sub) = MkLink sub
25+ toLink _ = toLink (Proxy :: Proxy sub)
26+#endif
27+
28+-- ** Combinators
29+
30+-- | A JSON Web Token (JWT) in the Authorization header:
31+--
32+-- @Authorization: Bearer \<token\>@
33+--
34+-- Note that while the token is signed, it is not encrypted. Therefore do not
35+-- keep in it any information you would not like the client to know.
36+--
37+-- JWTs are described in IETF's <https://tools.ietf.org/html/rfc7519 RFC 7519>
38+data JWT
39+
40+-- | A cookie. The content cookie itself is a JWT. Another cookie is also used,
41+-- the contents of which are expected to be send back to the server in a
42+-- header, for XSRF protection.
43+data Cookie
44+
45+
46+-- We could use 'servant''s BasicAuth, but then we don't get control over the
47+-- documentation, and we'd have to polykind everything. (Also, we don't
48+-- currently depend on servant!)
49+--
50+-- | Basic Auth.
51+data BasicAuth
52+
53+-- | Login via a form.
54+data FormLogin form
servant-auth/servant-auth/src/Servant/Auth/JWT.hsnew file+40
@@ -0,0 +1,40 @@
1+{-# LANGUAGE CPP #-}
2+
3+module Servant.Auth.JWT where
4+
5+import Control.Lens ((^.))
6+import qualified Crypto.JWT as Jose
7+import Data.Aeson (FromJSON, Result (..), ToJSON, fromJSON,
8+ toJSON)
9+#if MIN_VERSION_aeson(2,0,0)
10+import qualified Data.Map as KM
11+#else
12+import qualified Data.HashMap.Strict as KM
13+#endif
14+
15+import qualified Data.Text as T
16+
17+
18+-- This should probably also be from ClaimSet
19+--
20+-- | How to decode data from a JWT.
21+--
22+-- The default implementation assumes the data is stored in the unregistered
23+-- @dat@ claim, and uses the @FromJSON@ instance to decode value from there.
24+class FromJWT a where
25+ decodeJWT :: Jose.ClaimsSet -> Either T.Text a
26+ default decodeJWT :: FromJSON a => Jose.ClaimsSet -> Either T.Text a
27+ decodeJWT m = case KM.lookup "dat" (m ^. Jose.unregisteredClaims) of
28+ Nothing -> Left "Missing 'dat' claim"
29+ Just v -> case fromJSON v of
30+ Error e -> Left $ T.pack e
31+ Success a -> Right a
32+
33+-- | How to encode data from a JWT.
34+--
35+-- The default implementation stores data in the unregistered @dat@ claim, and
36+-- uses the type's @ToJSON@ instance to encode the data.
37+class ToJWT a where
38+ encodeJWT :: a -> Jose.ClaimsSet
39+ default encodeJWT :: ToJSON a => a -> Jose.ClaimsSet
40+ encodeJWT a = Jose.addClaim "dat" (toJSON a) Jose.emptyClaimsSet
servant-auth/servant-auth/test/Spec.hsnew file+1
@@ -0,0 +1 @@
1+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
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+15−14
@@ -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,14 +10,14 @@ 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
17copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors
17copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors
18build-type: Simple
18build-type: Simple
19−tested-with: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1
19+tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1
20− , GHCJS == 8.4
20+ , GHCJS ==8.6.0.1
21
21
22extra-source-files:
22extra-source-files:
23 CHANGELOG.md
23 CHANGELOG.md
@@ -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.18
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.7
59− , template-haskell >= 2.11.1.0 && < 2.18
60+ , template-haskell >= 2.11.1.0 && < 2.20
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/BasicAuth.hs−2
@@ -9,8 +9,6 @@ module Servant.Client.Core.BasicAuth (
9
9
10import Data.ByteString.Base64
10import Data.ByteString.Base64
11 (encode)
11 (encode)
12−import Data.Monoid
13− ((<>))
14import Data.Text.Encoding
12import Data.Text.Encoding
15 (decodeUtf8)
13 (decodeUtf8)
16import Servant.API.BasicAuth
14import Servant.API.BasicAuth
servant-client-core/src/Servant/Client/Core/HasClient.hs+191−33
@@ -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
@@ -33,9 +32,11 @@ import Control.Arrow
33 (left, (+++))
32 (left, (+++))
34import Control.Monad
33import Control.Monad
35 (unless)
34 (unless)
36−import qualified Data.ByteString.Lazy as BL
35+import qualified Data.ByteString as BS
36+import qualified Data.ByteString.Lazy as BL
37import Data.Either
37import Data.Either
38 (partitionEithers)
38 (partitionEithers)
39+import Data.Constraint (Dict(..))
39import Data.Foldable
40import Data.Foldable
40 (toList)
41 (toList)
41import Data.List
42import Data.List
@@ -44,7 +45,8 @@ import Data.Sequence
44 (fromList)
45 (fromList)
45import qualified Data.Text as T
46import qualified Data.Text as T
46import Network.HTTP.Media
47import Network.HTTP.Media
47− (MediaType, matches, parseAccept, (//))
48+ (MediaType, matches, parseAccept)
49+import qualified Network.HTTP.Media as Media
48import qualified Data.Sequence as Seq
50import qualified Data.Sequence as Seq
49import Data.SOP.BasicFunctors
51import Data.SOP.BasicFunctors
50 (I (I), (:.:) (Comp))
52 (I (I), (:.:) (Comp))
@@ -61,7 +63,7 @@ import Data.Text
61import Data.Proxy
63import Data.Proxy
62 (Proxy (Proxy))
64 (Proxy (Proxy))
63import GHC.TypeLits
65import GHC.TypeLits
64− (KnownSymbol, symbolVal)
66+ (KnownNat, KnownSymbol, TypeError, symbolVal)
65import Network.HTTP.Types
67import Network.HTTP.Types
66 (Status)
68 (Status)
67import qualified Network.HTTP.Types as H
69import qualified Network.HTTP.Types as H
@@ -72,16 +74,22 @@ import Servant.API
72 FromSourceIO (..), Header', Headers (..), HttpVersion,
74 FromSourceIO (..), Header', Headers (..), HttpVersion,
73 IsSecure, MimeRender (mimeRender),
75 IsSecure, MimeRender (mimeRender),
74 MimeUnrender (mimeUnrender), NoContent (NoContent),
76 MimeUnrender (mimeUnrender), NoContent (NoContent),
75− NoContentVerb, QueryFlag, QueryParam', QueryParams, Raw,
77+ NoContentVerb, QueryFlag, QueryParam', QueryParams, Raw, RawM,
76 ReflectMethod (..), RemoteHost, ReqBody', SBoolI, Stream,
78 ReflectMethod (..), RemoteHost, ReqBody', SBoolI, Stream,
77 StreamBody', Summary, ToHttpApiData, ToSourceIO (..), Vault,
79 StreamBody', Summary, ToHttpApiData, ToSourceIO (..), Vault,
78− Verb, WithNamedContext, WithStatus (..), contentType, getHeadersHList,
80+ Verb, WithNamedContext, WithResource, WithStatus (..), contentType, getHeadersHList,
79− getResponse, toQueryParam, toUrlPiece)
81+ getResponse, toEncodedUrlPiece, toUrlPiece, NamedRoutes)
82+import Servant.API.Generic
83+ (GenericMode(..), ToServant, ToServantApi
84+ , GenericServant, toServant, fromServant)
80import Servant.API.ContentTypes
85import Servant.API.ContentTypes
81 (contentTypes, AllMime (allMime), AllMimeUnrender (allMimeUnrender))
86 (contentTypes, AllMime (allMime), AllMimeUnrender (allMimeUnrender))
87+import Servant.API.Status
88+ (statusFromNat)
82import Servant.API.TypeLevel (FragmentUnique, AtLeastOneFragment)
89import Servant.API.TypeLevel (FragmentUnique, AtLeastOneFragment)
83import Servant.API.Modifiers
90import Servant.API.Modifiers
84 (FoldRequired, RequiredArgument, foldRequiredArgument)
91 (FoldRequired, RequiredArgument, foldRequiredArgument)
92+import Servant.API.TypeErrors
85import Servant.API.UVerb
93import Servant.API.UVerb
86 (HasStatus, HasStatuses (Statuses, statuses), UVerb, Union, Unique, inject, statusOf, foldMapUnion, matchUnion)
94 (HasStatus, HasStatuses (Statuses, statuses), UVerb, Union, Unique, inject, statusOf, foldMapUnion, matchUnion)
87
95
@@ -200,7 +208,7 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m api)
200 clientWithRoute pm (Proxy :: Proxy api)
208 clientWithRoute pm (Proxy :: Proxy api)
201 (appendToPath p req)
209 (appendToPath p req)
202
210
203− where p = (toUrlPiece val)
211+ where p = toEncodedUrlPiece val
204
212
205 hoistClientMonad pm _ f cl = \a ->
213 hoistClientMonad pm _ f cl = \a ->
206 hoistClientMonad pm (Proxy :: Proxy api) f (cl a)
214 hoistClientMonad pm (Proxy :: Proxy api) f (cl a)
@@ -235,7 +243,7 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m sublayout)
235 clientWithRoute pm (Proxy :: Proxy sublayout)
243 clientWithRoute pm (Proxy :: Proxy sublayout)
236 (foldl' (flip appendToPath) req ps)
244 (foldl' (flip appendToPath) req ps)
237
245
238− where ps = map (toUrlPiece) vals
246+ where ps = map toEncodedUrlPiece vals
239
247
240 hoistClientMonad pm _ f cl = \as ->
248 hoistClientMonad pm _ f cl = \as ->
241 hoistClientMonad pm (Proxy :: Proxy sublayout) f (cl as)
249 hoistClientMonad pm (Proxy :: Proxy sublayout) f (cl as)
@@ -243,10 +251,11 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m sublayout)
243instance {-# OVERLAPPABLE #-}
251instance {-# OVERLAPPABLE #-}
244 -- Note [Non-Empty Content Types]
252 -- Note [Non-Empty Content Types]
245 ( RunClient m, MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)
253 ( RunClient m, MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)
254+ , KnownNat status
246 ) => HasClient m (Verb method status cts' a) where
255 ) => HasClient m (Verb method status cts' a) where
247 type Client m (Verb method status cts' a) = m a
256 type Client m (Verb method status cts' a) = m a
248 clientWithRoute _pm Proxy req = do
257 clientWithRoute _pm Proxy req = do
249− response <- runRequest req
258+ response <- runRequestAcceptStatus (Just [status]) req
250 { requestAccept = fromList $ toList accept
259 { requestAccept = fromList $ toList accept
251 , requestMethod = method
260 , requestMethod = method
252 }
261 }
@@ -254,18 +263,20 @@ instance {-# OVERLAPPABLE #-}
254 where
263 where
255 accept = contentTypes (Proxy :: Proxy ct)
264 accept = contentTypes (Proxy :: Proxy ct)
256 method = reflectMethod (Proxy :: Proxy method)
265 method = reflectMethod (Proxy :: Proxy method)
266+ status = statusFromNat (Proxy :: Proxy status)
257
267
258 hoistClientMonad _ _ f ma = f ma
268 hoistClientMonad _ _ f ma = f ma
259
269
260instance {-# OVERLAPPING #-}
270instance {-# OVERLAPPING #-}
261− ( RunClient m, ReflectMethod method
271+ ( RunClient m, ReflectMethod method, KnownNat status
262 ) => HasClient m (Verb method status cts NoContent) where
272 ) => HasClient m (Verb method status cts NoContent) where
263 type Client m (Verb method status cts NoContent)
273 type Client m (Verb method status cts NoContent)
264 = m NoContent
274 = m NoContent
265 clientWithRoute _pm Proxy req = do
275 clientWithRoute _pm Proxy req = do
266− _response <- runRequest req { requestMethod = method }
276+ _response <- runRequestAcceptStatus (Just [status]) req { requestMethod = method }
267 return NoContent
277 return NoContent
268 where method = reflectMethod (Proxy :: Proxy method)
278 where method = reflectMethod (Proxy :: Proxy method)
279+ status = statusFromNat (Proxy :: Proxy status)
269
280
270 hoistClientMonad _ _ f ma = f ma
281 hoistClientMonad _ _ f ma = f ma
271
282
@@ -282,13 +293,13 @@ instance (RunClient m, ReflectMethod method) =>
282
293
283instance {-# OVERLAPPING #-}
294instance {-# OVERLAPPING #-}
284 -- Note [Non-Empty Content Types]
295 -- Note [Non-Empty Content Types]
285− ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls
296+ ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls, KnownNat status
286 , ReflectMethod method, cts' ~ (ct ': cts)
297 , ReflectMethod method, cts' ~ (ct ': cts)
287 ) => HasClient m (Verb method status cts' (Headers ls a)) where
298 ) => HasClient m (Verb method status cts' (Headers ls a)) where
288 type Client m (Verb method status cts' (Headers ls a))
299 type Client m (Verb method status cts' (Headers ls a))
289 = m (Headers ls a)
300 = m (Headers ls a)
290 clientWithRoute _pm Proxy req = do
301 clientWithRoute _pm Proxy req = do
291− response <- runRequest req
302+ response <- runRequestAcceptStatus (Just [status]) req
292 { requestMethod = method
303 { requestMethod = method
293 , requestAccept = fromList $ toList accept
304 , requestAccept = fromList $ toList accept
294 }
305 }
@@ -296,22 +307,26 @@ instance {-# OVERLAPPING #-}
296 return $ Headers { getResponse = val
307 return $ Headers { getResponse = val
297 , getHeadersHList = buildHeadersTo . toList $ responseHeaders response
308 , getHeadersHList = buildHeadersTo . toList $ responseHeaders response
298 }
309 }
310+ where
299− where method = reflectMethod (Proxy :: Proxy method)
311+ method = reflectMethod (Proxy :: Proxy method)
300− accept = contentTypes (Proxy :: Proxy ct)
312+ accept = contentTypes (Proxy :: Proxy ct)
313+ status = statusFromNat (Proxy :: Proxy status)
301
314
302 hoistClientMonad _ _ f ma = f ma
315 hoistClientMonad _ _ f ma = f ma
303
316
304instance {-# OVERLAPPING #-}
317instance {-# OVERLAPPING #-}
305− ( RunClient m, BuildHeadersTo ls, ReflectMethod method
318+ ( RunClient m, BuildHeadersTo ls, ReflectMethod method, KnownNat status
306 ) => HasClient m (Verb method status cts (Headers ls NoContent)) where
319 ) => HasClient m (Verb method status cts (Headers ls NoContent)) where
307 type Client m (Verb method status cts (Headers ls NoContent))
320 type Client m (Verb method status cts (Headers ls NoContent))
308 = m (Headers ls NoContent)
321 = m (Headers ls NoContent)
309 clientWithRoute _pm Proxy req = do
322 clientWithRoute _pm Proxy req = do
310− let method = reflectMethod (Proxy :: Proxy method)
311− response <- runRequest req { requestMethod = method }
323+ response <- runRequestAcceptStatus (Just [status]) req { requestMethod = method }
312 return $ Headers { getResponse = NoContent
324 return $ Headers { getResponse = NoContent
313 , getHeadersHList = buildHeadersTo . toList $ responseHeaders response
325 , getHeadersHList = buildHeadersTo . toList $ responseHeaders response
314 }
326 }
327+ where
328+ method = reflectMethod (Proxy :: Proxy method)
329+ status = statusFromNat (Proxy :: Proxy status)
315
330
316 hoistClientMonad _ _ f ma = f ma
331 hoistClientMonad _ _ f ma = f ma
317
332
@@ -554,7 +569,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequire
554 (Proxy :: Proxy mods) add (maybe req add) mparam
569 (Proxy :: Proxy mods) add (maybe req add) mparam
555 where
570 where
556 add :: a -> Request
571 add :: a -> Request
557− add param = appendToQueryString pname (Just $ toQueryParam param) req
572+ add param = appendToQueryString pname (Just $ encodeQueryParamValue param) req
558
573
559 pname :: Text
574 pname :: Text
560 pname = pack $ symbolVal (Proxy :: Proxy sym)
575 pname = pack $ symbolVal (Proxy :: Proxy sym)
@@ -603,7 +618,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api)
603 )
618 )
604
619
605 where pname = pack $ symbolVal (Proxy :: Proxy sym)
620 where pname = pack $ symbolVal (Proxy :: Proxy sym)
606− paramlist' = map (Just . toQueryParam) paramlist
621+ paramlist' = map (Just . encodeQueryParamValue) paramlist
607
622
608 hoistClientMonad pm _ f cl = \as ->
623 hoistClientMonad pm _ f cl = \as ->
609 hoistClientMonad pm (Proxy :: Proxy api) f (cl as)
624 hoistClientMonad pm (Proxy :: Proxy api) f (cl as)
@@ -659,6 +674,16 @@ instance RunClient m => HasClient m Raw where
659
674
660 hoistClientMonad _ _ f cl = \meth -> f (cl meth)
675 hoistClientMonad _ _ f cl = \meth -> f (cl meth)
661
676
677+instance RunClient m => HasClient m RawM where
678+ type Client m RawM
679+ = H.Method -> m Response
680+
681+ clientWithRoute :: Proxy m -> Proxy RawM -> Request -> Client m RawM
682+ clientWithRoute _pm Proxy req httpMethod = do
683+ runRequest req { requestMethod = httpMethod }
684+
685+ hoistClientMonad _ _ f cl = \meth -> f (cl meth)
686+
662-- | If you use a 'ReqBody' in one of your endpoints in your API,
687-- | If you use a 'ReqBody' in one of your endpoints in your API,
663-- the corresponding querying function will automatically take
688-- the corresponding querying function will automatically take
664-- an additional argument of the type specified by your 'ReqBody'.
689-- an additional argument of the type specified by your 'ReqBody'.
@@ -725,7 +750,7 @@ instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where
725 clientWithRoute pm (Proxy :: Proxy api)
750 clientWithRoute pm (Proxy :: Proxy api)
726 (appendToPath p req)
751 (appendToPath p req)
727
752
728− where p = pack $ symbolVal (Proxy :: Proxy path)
753+ where p = toEncodedUrlPiece $ pack $ symbolVal (Proxy :: Proxy path)
729
754
730 hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
755 hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
731
756
@@ -761,6 +786,14 @@ instance HasClient m subapi =>
761
786
762 hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy subapi) f cl
787 hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy subapi) f cl
763
788
789+instance HasClient m subapi =>
790+ HasClient m (WithResource res :> subapi) where
791+
792+ type Client m (WithResource res :> subapi) = Client m subapi
793+ clientWithRoute pm Proxy = clientWithRoute pm (Proxy :: Proxy subapi)
794+
795+ hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy subapi) f cl
796+
764instance ( HasClient m api
797instance ( HasClient m api
765 ) => HasClient m (AuthProtect tag :> api) where
798 ) => HasClient m (AuthProtect tag :> api) where
766 type Client m (AuthProtect tag :> api)
799 type Client m (AuthProtect tag :> api)
@@ -774,7 +807,7 @@ instance ( HasClient m api
774
807
775-- | Ignore @'Fragment'@ in client functions.
808-- | Ignore @'Fragment'@ in client functions.
776-- See <https://ietf.org/rfc/rfc2616.html#section-15.1.3> for more details.
809-- See <https://ietf.org/rfc/rfc2616.html#section-15.1.3> for more details.
777−--
810+--
778-- Example:
811-- Example:
779--
812--
780-- > type MyApi = "books" :> Fragment Text :> Get '[JSON] [Book]
813-- > type MyApi = "books" :> Fragment Text :> Get '[JSON] [Book]
@@ -786,16 +819,12 @@ instance ( HasClient m api
786-- > getBooks = client myApi
819-- > getBooks = client myApi
787-- > -- then you can just use "getBooksBy" to query that endpoint.
820-- > -- then you can just use "getBooksBy" to query that endpoint.
788-- > -- 'getBooks' for all books.
821-- > -- 'getBooks' for all books.
789−#ifdef HAS_TYPE_ERROR
790instance (AtLeastOneFragment api, FragmentUnique (Fragment a :> api), HasClient m api
822instance (AtLeastOneFragment api, FragmentUnique (Fragment a :> api), HasClient m api
791−#else
792−instance ( HasClient m api
793−#endif
794 ) => HasClient m (Fragment a :> api) where
823 ) => HasClient m (Fragment a :> api) where
795
824
796 type Client m (Fragment a :> api) = Client m api
825 type Client m (Fragment a :> api) = Client m api
797
826
798− clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api)
827+ clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api)
799
828
800 hoistClientMonad pm _ = hoistClientMonad pm (Proxy :: Proxy api)
829 hoistClientMonad pm _ = hoistClientMonad pm (Proxy :: Proxy api)
801
830
@@ -810,6 +839,119 @@ instance HasClient m api => HasClient m (BasicAuth realm usr :> api) where
810 hoistClientMonad pm _ f cl = \bauth ->
839 hoistClientMonad pm _ f cl = \bauth ->
811 hoistClientMonad pm (Proxy :: Proxy api) f (cl bauth)
840 hoistClientMonad pm (Proxy :: Proxy api) f (cl bauth)
812
841
842+-- | A type that specifies that an API record contains a client implementation.
843+data AsClientT (m :: * -> *)
844+instance GenericMode (AsClientT m) where
845+ type AsClientT m :- api = Client m api
846+
847+
848+type GClientConstraints api m =
849+ ( GenericServant api (AsClientT m)
850+ , Client m (ToServantApi api) ~ ToServant api (AsClientT m)
851+ )
852+
853+class GClient (api :: * -> *) m where
854+ gClientProof :: Dict (GClientConstraints api m)
855+
856+instance GClientConstraints api m => GClient api m where
857+ gClientProof = Dict
858+
859+instance
860+ ( forall n. GClient api n
861+ , HasClient m (ToServantApi api)
862+ , RunClient m
863+ )
864+ => HasClient m (NamedRoutes api) where
865+ type Client m (NamedRoutes api) = api (AsClientT m)
866+
867+ clientWithRoute :: Proxy m -> Proxy (NamedRoutes api) -> Request -> Client m (NamedRoutes api)
868+ clientWithRoute pm _ request =
869+ case gClientProof @api @m of
870+ Dict -> fromServant $ clientWithRoute pm (Proxy @(ToServantApi api)) request
871+
872+ hoistClientMonad
873+ :: forall ma mb.
874+ Proxy m
875+ -> Proxy (NamedRoutes api)
876+ -> (forall x. ma x -> mb x)
877+ -> Client ma (NamedRoutes api)
878+ -> Client mb (NamedRoutes api)
879+ hoistClientMonad _ _ nat clientA =
880+ case (gClientProof @api @ma, gClientProof @api @mb) of
881+ (Dict, Dict) ->
882+ fromServant @api @(AsClientT mb) $
883+ hoistClientMonad @m @(ToServantApi api) @ma @mb Proxy Proxy nat $
884+ toServant @api @(AsClientT ma) clientA
885+
886+infixl 1 //
887+infixl 2 /:
888+
889+-- | Helper to make code using records of clients more readable.
890+--
891+-- Can be mixed with (/:) for supplying arguments.
892+--
893+-- Example:
894+--
895+-- @
896+-- type Api = NamedRoutes RootApi
897+--
898+-- data RootApi mode = RootApi
899+-- { subApi :: mode :- NamedRoutes SubApi
900+-- , …
901+-- } deriving Generic
902+--
903+-- data SubApi mode = SubApi
904+-- { endpoint :: mode :- Get '[JSON] Person
905+-- , …
906+-- } deriving Generic
907+--
908+-- api :: Proxy API
909+-- api = Proxy
910+--
911+-- rootClient :: RootApi (AsClientT ClientM)
912+-- rootClient = client api
913+--
914+-- endpointClient :: ClientM Person
915+-- endpointClient = client \/\/ subApi \/\/ endpoint
916+-- @
917+(//) :: a -> (a -> b) -> b
918+x // f = f x
919+
920+-- | Convenience function for supplying arguments to client functions when
921+-- working with records of clients.
922+--
923+-- Intended to be used in conjunction with '(//)'.
924+--
925+-- Example:
926+--
927+-- @
928+-- type Api = NamedRoutes RootApi
929+--
930+-- data RootApi mode = RootApi
931+-- { subApi :: mode :- Capture "token" String :> NamedRoutes SubApi
932+-- , hello :: mode :- Capture "name" String :> Get '[JSON] String
933+-- , …
934+-- } deriving Generic
935+--
936+-- data SubApi mode = SubApi
937+-- { endpoint :: mode :- Get '[JSON] Person
938+-- , …
939+-- } deriving Generic
940+--
941+-- api :: Proxy API
942+-- api = Proxy
943+--
944+-- rootClient :: RootApi (AsClientT ClientM)
945+-- rootClient = client api
946+--
947+-- hello :: String -> ClientM String
948+-- hello name = rootClient \/\/ hello \/: name
949+--
950+-- endpointClient :: ClientM Person
951+-- endpointClient = client \/\/ subApi \/: "foobar123" \/\/ endpoint
952+-- @
953+(/:) :: (a -> b -> c) -> b -> a -> c
954+(/:) = flip
813
955
814
956
815{- Note [Non-Empty Content Types]
957{- Note [Non-Empty Content Types]
@@ -835,7 +977,7 @@ for empty and one for non-empty lists).
835checkContentTypeHeader :: RunClient m => Response -> m MediaType
977checkContentTypeHeader :: RunClient m => Response -> m MediaType
836checkContentTypeHeader response =
978checkContentTypeHeader response =
837 case lookup "Content-Type" $ toList $ responseHeaders response of
979 case lookup "Content-Type" $ toList $ responseHeaders response of
838− Nothing -> return $ "application"//"octet-stream"
980+ Nothing -> return $ "application" Media.// "octet-stream"
839 Just t -> case parseAccept t of
981 Just t -> case parseAccept t of
840 Nothing -> throwClientError $ InvalidContentTypeHeader response
982 Nothing -> throwClientError $ InvalidContentTypeHeader response
841 Just t' -> return t'
983 Just t' -> return t'
@@ -851,3 +993,19 @@ decodedAs response ct = do
851 Right val -> return val
993 Right val -> return val
852 where
994 where
853 accept = toList $ contentTypes ct
995 accept = toList $ contentTypes ct
996+
997+-------------------------------------------------------------------------------
998+-- Custom type errors
999+-------------------------------------------------------------------------------
1000+
1001+-- Erroring instance for HasClient' when a combinator is not fully applied
1002+instance (RunClient m, TypeError (PartialApplication HasClient arr)) => HasClient m ((arr :: a -> b) :> sub)
1003+ where
1004+ type Client m (arr :> sub) = TypeError (PartialApplication HasClient arr)
1005+ clientWithRoute _ _ _ = error "unreachable"
1006+ hoistClientMonad _ _ _ _ = error "unreachable"
1007+
1008+-- Erroring instances for 'HasClient' for unknown API combinators
1009+instance {-# OVERLAPPABLE #-} (RunClient m, TypeError (NoInstanceForSub (HasClient m) ty)) => HasClient m (ty :> sub)
1010+
1011+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+23−9
@@ -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,10 +34,10 @@ 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
38−import Data.Semigroup
39− ((<>))
40import qualified Data.Sequence as Seq
41import qualified Data.Sequence as Seq
41import Data.Text
42import Data.Text
42 (Text)
43 (Text)
@@ -80,12 +81,13 @@ instance (Show a, Show b) =>
80 . showString ", requestAccept = "
81 . showString ", requestAccept = "
81 . showsPrec 0 (requestAccept req)
82 . showsPrec 0 (requestAccept req)
82 . showString ", requestHeaders = "
83 . showString ", requestHeaders = "
83− . showsPrec 0 (redactSensitiveHeader <$> requestHeaders req))
84+ . showsPrec 0 (redactSensitiveHeader <$> requestHeaders req)
84 . showString ", requestHttpVersion = "
85 . showString ", requestHttpVersion = "
85 . showsPrec 0 (requestHttpVersion req)
86 . showsPrec 0 (requestHttpVersion req)
86 . showString ", requestMethod = "
87 . showString ", requestMethod = "
87 . showsPrec 0 (requestMethod req)
88 . showsPrec 0 (requestMethod req)
88 . showString "}"
89 . showString "}"
90+ )
89 where
91 where
90 redactSensitiveHeader :: Header -> Header
92 redactSensitiveHeader :: Header -> Header
91 redactSensitiveHeader ("Authorization", _) = ("Authorization", "<REDACTED>")
93 redactSensitiveHeader ("Authorization", _) = ("Authorization", "<REDACTED>")
@@ -112,7 +114,7 @@ instance (NFData path, NFData body) => NFData (RequestF body path) where
112 rnfB Nothing = ()
114 rnfB Nothing = ()
113 rnfB (Just (b, mt)) = rnf b `seq` mediaTypeRnf mt
115 rnfB (Just (b, mt)) = rnf b `seq` mediaTypeRnf mt
114
116
115−type Request = RequestF RequestBody Builder.Builder
117+type Request = RequestF RequestBody Builder
116
118
117-- | The request body. R replica of the @http-client@ @RequestBody@.
119-- | The request body. R replica of the @http-client@ @RequestBody@.
118data RequestBody
120data RequestBody
@@ -143,18 +145,30 @@ defaultRequest = Request
143 , requestMethod = methodGet
145 , requestMethod = methodGet
144 }
146 }
145
147
148+-- | Append extra path to the request being constructed.
149+--
150+-- Warning: This function assumes that the path fragment is already URL-encoded.
146−appendToPath :: Text -> Request -> Request
151+appendToPath :: Builder -> Request -> Request
147appendToPath p req
152appendToPath p req
148− = req { requestPath = requestPath req <> "/" <> toEncodedUrlPiece p }
153+ = req { requestPath = requestPath req <> "/" <> p }
149
154
155+-- | Append a query parameter to the request being constructed.
156+--
150−appendToQueryString :: Text -- ^ param name
157+appendToQueryString :: Text -- ^ query param name
151− -> Maybe Text -- ^ param value
158+ -> Maybe BS.ByteString -- ^ query param value
152 -> Request
159 -> Request
153 -> Request
160 -> Request
154appendToQueryString pname pvalue req
161appendToQueryString pname pvalue req
155 = req { requestQueryString = requestQueryString req
162 = req { requestQueryString = requestQueryString req
156− Seq.|> (encodeUtf8 pname, encodeUtf8 <$> pvalue)}
163+ Seq.|> (encodeUtf8 pname, pvalue)}
157
164
165+-- | Encode a query parameter value.
166+--
167+encodeQueryParamValue :: ToHttpApiData a => a -> BS.ByteString
168+encodeQueryParamValue = LBS.toStrict . Builder.toLazyByteString . toEncodedUrlPiece
169+
170+-- | Add header to the request being constructed.
171+--
158addHeader :: ToHttpApiData a => HeaderName -> a -> Request -> Request
172addHeader :: ToHttpApiData a => HeaderName -> a -> Request -> Request
159addHeader name val req
173addHeader name val req
160 = req { requestHeaders = requestHeaders req Seq.|> (name, toHeader val)}
174 = 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+6−6
@@ -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
@@ -48,7 +48,7 @@ library
48 , http-media >=0.6.2 && <0.9
48 , http-media >=0.6.2 && <0.9
49 , http-types >=0.12 && <0.13
49 , http-types >=0.12 && <0.13
50 , monad-control >=1.0.0.4 && <1.1
50 , monad-control >=1.0.0.4 && <1.1
51− , mtl >=2.2.2 && <2.3
51+ , mtl ^>=2.2.2 || ^>=2.3.1
52 , semigroupoids >=5.3 && <5.4
52 , semigroupoids >=5.3 && <5.4
53 , string-conversions >=0.3 && <0.5
53 , string-conversions >=0.3 && <0.5
54 , transformers >=0.3 && <0.6
54 , transformers >=0.3 && <0.6
@@ -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+24−17
@@ -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,13 +14,14 @@ 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
21copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors
21copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors
22build-type: Simple
22build-type: Simple
23−tested-with: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1
23+tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1
24+ , GHCJS ==8.6.0.1
24
25
25extra-source-files:
26extra-source-files:
26 CHANGELOG.md
27 CHANGELOG.md
@@ -40,15 +41,15 @@ library
40 -- Bundled with GHC: Lower bound to not force re-installs
41 -- Bundled with GHC: Lower bound to not force re-installs
41 -- text and mtl are bundled starting with GHC-8.4
42 -- text and mtl are bundled starting with GHC-8.4
42 build-depends:
43 build-depends:
43− base >= 4.9 && < 4.16
44+ base >= 4.9 && < 4.18
44 , bytestring >= 0.10.8.1 && < 0.12
45 , bytestring >= 0.10.8.1 && < 0.12
45 , containers >= 0.5.7.1 && < 0.7
46 , containers >= 0.5.7.1 && < 0.7
46 , deepseq >= 1.4.2.0 && < 1.5
47 , deepseq >= 1.4.2.0 && < 1.5
47− , mtl >= 2.2.2 && < 2.3
48+ , mtl ^>= 2.2.2 || ^>= 2.3.1
48 , stm >= 2.4.5.1 && < 2.6
49 , stm >= 2.4.5.1 && < 2.6
49− , text >= 1.2.3.0 && < 1.3
50+ , text >= 1.2.3.0 && < 2.1
50− , time >= 1.6.0.1 && < 1.10
51+ , time >= 1.6.0.1 && < 1.13
51− , transformers >= 0.5.2.0 && < 0.6
52+ , transformers >= 0.5.2.0 && < 0.7
52
53
53 if !impl(ghc >= 8.2)
54 if !impl(ghc >= 8.2)
54 build-depends:
55 build-depends:
@@ -57,13 +58,13 @@ library
57 -- Servant dependencies.
58 -- Servant dependencies.
58 -- Strict dependency on `servant-client-core` as we re-export things.
59 -- Strict dependency on `servant-client-core` as we re-export things.
59 build-depends:
60 build-depends:
60− servant == 0.18.*
61+ servant >= 0.18 && < 0.20
61− , servant-client-core >= 0.18.3 && <0.18.4
62+ , servant-client-core >= 0.19 && < 0.19.1
62
63
63 -- 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.
64 -- 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.
65 build-depends:
66 build-depends:
66− base-compat >= 0.10.5 && < 0.12
67+ base-compat >= 0.10.5 && < 0.13
67 , http-client >= 0.5.13.1 && < 0.8
68 , http-client >= 0.5.13.1 && < 0.8
68 , http-media >= 0.7.1.3 && < 0.9
69 , http-media >= 0.7.1.3 && < 0.9
69 , http-types >= 0.12.2 && < 0.13
70 , http-types >= 0.12.2 && < 0.13
@@ -72,7 +73,7 @@ library
72 , monad-control >= 1.0.2.3 && < 1.1
73 , monad-control >= 1.0.2.3 && < 1.1
73 , semigroupoids >= 5.3.1 && < 5.4
74 , semigroupoids >= 5.3.1 && < 5.4
74 , transformers-base >= 0.4.5.2 && < 0.5
75 , transformers-base >= 0.4.5.2 && < 0.5
75− , transformers-compat >= 0.6.2 && < 0.7
76+ , transformers-compat >= 0.6.2 && < 0.8
76
77
77 hs-source-dirs: src
78 hs-source-dirs: src
78 default-language: Haskell2010
79 default-language: Haskell2010
@@ -82,14 +83,18 @@ test-suite spec
82 type: exitcode-stdio-1.0
83 type: exitcode-stdio-1.0
83 ghc-options: -Wall -rtsopts -threaded "-with-rtsopts=-T -N2"
84 ghc-options: -Wall -rtsopts -threaded "-with-rtsopts=-T -N2"
84 default-language: Haskell2010
85 default-language: Haskell2010
86+ if impl(ghcjs)
87+ buildable: False
85 hs-source-dirs: test
88 hs-source-dirs: test
86 main-is: Spec.hs
89 main-is: Spec.hs
87 other-modules:
90 other-modules:
88 Servant.BasicAuthSpec
91 Servant.BasicAuthSpec
92+ Servant.BrokenSpec
89 Servant.ClientTestUtils
93 Servant.ClientTestUtils
90 Servant.ConnectionErrorSpec
94 Servant.ConnectionErrorSpec
91 Servant.FailSpec
95 Servant.FailSpec
92 Servant.GenAuthSpec
96 Servant.GenAuthSpec
97+ Servant.GenericSpec
93 Servant.HoistClientSpec
98 Servant.HoistClientSpec
94 Servant.StreamSpec
99 Servant.StreamSpec
95 Servant.SuccessSpec
100 Servant.SuccessSpec
@@ -119,16 +124,16 @@ test-suite spec
119 -- Additional dependencies
124 -- Additional dependencies
120 build-depends:
125 build-depends:
121 entropy >= 0.4.1.3 && < 0.5
126 entropy >= 0.4.1.3 && < 0.5
122− , hspec >= 2.6.0 && < 2.9
127+ , hspec >= 2.6.0 && < 2.10
123 , HUnit >= 1.6.0.0 && < 1.7
128 , HUnit >= 1.6.0.0 && < 1.7
124 , network >= 2.8.0.0 && < 3.2
129 , network >= 2.8.0.0 && < 3.2
125 , QuickCheck >= 2.12.6.1 && < 2.15
130 , QuickCheck >= 2.12.6.1 && < 2.15
126− , servant == 0.18.*
131+ , servant == 0.19.*
127− , servant-server == 0.18.*
132+ , servant-server == 0.19.*
128 , tdigest >= 0.2 && < 0.3
133 , tdigest >= 0.2 && < 0.3
129
134
130 build-tool-depends:
135 build-tool-depends:
131− hspec-discover:hspec-discover >= 2.6.0 && < 2.9
136+ hspec-discover:hspec-discover >= 2.6.0 && < 2.10
132
137
133test-suite readme
138test-suite readme
134 type: exitcode-stdio-1.0
139 type: exitcode-stdio-1.0
@@ -137,3 +142,5 @@ test-suite readme
137 build-tool-depends: markdown-unlit:markdown-unlit
142 build-tool-depends: markdown-unlit:markdown-unlit
138 ghc-options: -pgmL markdown-unlit
143 ghc-options: -pgmL markdown-unlit
139 default-language: Haskell2010
144 default-language: Haskell2010
145+ if impl(ghcjs)
146+ buildable: False
servant-client/src/Servant/Client/Internal/HttpClient.hs+19−14
@@ -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
@@ -46,15 +46,13 @@ import qualified Data.ByteString.Lazy as BSL
46import Data.Either
46import Data.Either
47 (either)
47 (either)
48import Data.Foldable
48import Data.Foldable
49− (toList)
49+ (foldl',toList)
50import Data.Functor.Alt
50import Data.Functor.Alt
51 (Alt (..))
51 (Alt (..))
52import Data.Maybe
52import Data.Maybe
53 (maybe, maybeToList)
53 (maybe, maybeToList)
54import Data.Proxy
54import Data.Proxy
55 (Proxy (..))
55 (Proxy (..))
56−import Data.Semigroup
57− ((<>))
58import Data.Sequence
56import Data.Sequence
59 (fromList)
57 (fromList)
60import Data.String
58import Data.String
@@ -65,7 +63,7 @@ import GHC.Generics
65import Network.HTTP.Media
63import Network.HTTP.Media
66 (renderHeader)
64 (renderHeader)
67import Network.HTTP.Types
65import Network.HTTP.Types
68− (hContentType, renderQuery, statusCode, Status)
66+ (hContentType, renderQuery, statusIsSuccessful, urlEncode, Status)
69import Servant.Client.Core
67import Servant.Client.Core
70
68
71import qualified Network.HTTP.Client as Client
69import qualified Network.HTTP.Client as Client
@@ -82,7 +80,7 @@ data ClientEnv
82 { manager :: Client.Manager
80 { manager :: Client.Manager
83 , baseUrl :: BaseUrl
81 , baseUrl :: BaseUrl
84 , cookieJar :: Maybe (TVar Client.CookieJar)
82 , cookieJar :: Maybe (TVar Client.CookieJar)
85− , makeClientRequest :: BaseUrl -> Request -> Client.Request
83+ , makeClientRequest :: BaseUrl -> Request -> IO Client.Request
86 -- ^ 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'
87 -- Note that:
85 -- Note that:
88 -- 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,
@@ -138,7 +136,7 @@ newtype ClientM a = ClientM
138 { unClientM :: ReaderT ClientEnv (ExceptT ClientError IO) a }
136 { unClientM :: ReaderT ClientEnv (ExceptT ClientError IO) a }
139 deriving ( Functor, Applicative, Monad, MonadIO, Generic
137 deriving ( Functor, Applicative, Monad, MonadIO, Generic
140 , MonadReader ClientEnv, MonadError ClientError, MonadThrow
138 , MonadReader ClientEnv, MonadError ClientError, MonadThrow
141− , MonadCatch)
139+ , MonadCatch, MonadMask)
142
140
143instance MonadBase IO ClientM where
141instance MonadBase IO ClientM where
144 liftBase = ClientM . liftBase
142 liftBase = ClientM . liftBase
@@ -164,7 +162,7 @@ runClientM cm env = runExceptT $ flip runReaderT env $ unClientM cm
164performRequest :: Maybe [Status] -> Request -> ClientM Response
162performRequest :: Maybe [Status] -> Request -> ClientM Response
165performRequest acceptStatus req = do
163performRequest acceptStatus req = do
166 ClientEnv m burl cookieJar' createClientRequest <- ask
164 ClientEnv m burl cookieJar' createClientRequest <- ask
167− let clientRequest = createClientRequest burl req
165+ clientRequest <- liftIO $ createClientRequest burl req
168 request <- case cookieJar' of
166 request <- case cookieJar' of
169 Nothing -> pure clientRequest
167 Nothing -> pure clientRequest
170 Just cj -> liftIO $ do
168 Just cj -> liftIO $ do
@@ -181,10 +179,9 @@ performRequest acceptStatus req = do
181
179
182 response <- maybe (requestWithoutCookieJar m request) (requestWithCookieJar m request) cookieJar'
180 response <- maybe (requestWithoutCookieJar m request) (requestWithCookieJar m request) cookieJar'
183 let status = Client.responseStatus response
181 let status = Client.responseStatus response
184− status_code = statusCode status
185 ourResponse = clientResponseToResponse id response
182 ourResponse = clientResponseToResponse id response
186 goodStatus = case acceptStatus of
183 goodStatus = case acceptStatus of
187− Nothing -> status_code >= 200 && status_code < 300
184+ Nothing -> statusIsSuccessful status
188 Just good -> status `elem` good
185 Just good -> status `elem` good
189 unless goodStatus $ do
186 unless goodStatus $ do
190 throwError $ mkFailureResponse burl req ourResponse
187 throwError $ mkFailureResponse burl req ourResponse
@@ -232,15 +229,15 @@ clientResponseToResponse f r = Response
232-- | Create a @http-client@ 'Client.Request' from a @servant@ 'Request'
229-- | Create a @http-client@ 'Client.Request' from a @servant@ 'Request'
233-- 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'
234-- 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'
235−defaultMakeClientRequest :: BaseUrl -> Request -> Client.Request
232+defaultMakeClientRequest :: BaseUrl -> Request -> IO Client.Request
236−defaultMakeClientRequest burl r = Client.defaultRequest
233+defaultMakeClientRequest burl r = return Client.defaultRequest
237 { Client.method = requestMethod r
234 { Client.method = requestMethod r
238 , Client.host = fromString $ baseUrlHost burl
235 , Client.host = fromString $ baseUrlHost burl
239 , Client.port = baseUrlPort burl
236 , Client.port = baseUrlPort burl
240 , Client.path = BSL.toStrict
237 , Client.path = BSL.toStrict
241 $ fromString (baseUrlPath burl)
238 $ fromString (baseUrlPath burl)
242 <> toLazyByteString (requestPath r)
239 <> toLazyByteString (requestPath r)
243− , Client.queryString = renderQuery True . toList $ requestQueryString r
240+ , Client.queryString = buildQueryString . toList $ requestQueryString r
244 , Client.requestHeaders =
241 , Client.requestHeaders =
245 maybeToList acceptHdr ++ maybeToList contentTypeHdr ++ headers
242 maybeToList acceptHdr ++ maybeToList contentTypeHdr ++ headers
246 , Client.requestBody = body
243 , Client.requestBody = body
@@ -249,7 +246,7 @@ defaultMakeClientRequest burl r = Client.defaultRequest
249 where
246 where
250 -- Content-Type and Accept are specified by requestBody and requestAccept
247 -- Content-Type and Accept are specified by requestBody and requestAccept
251 headers = filter (\(h, _) -> h /= "Accept" && h /= "Content-Type") $
248 headers = filter (\(h, _) -> h /= "Accept" && h /= "Content-Type") $
252− toList $requestHeaders r
249+ toList $ requestHeaders r
253
250
254 acceptHdr
251 acceptHdr
255 | null hs = Nothing
252 | null hs = Nothing
@@ -291,6 +288,14 @@ defaultMakeClientRequest burl r = Client.defaultRequest
291 Http -> False
288 Http -> False
292 Https -> True
289 Https -> True
293
290
291+ -- Query string builder which does not do any encoding
292+ buildQueryString [] = mempty
293+ buildQueryString qps = "?" <> foldl' addQueryParam mempty qps
294+
295+ addQueryParam qs (k, v) =
296+ qs <> (if BS.null qs then mempty else "&") <> urlEncode True k <> foldMap ("=" <>) v
297+
298+
294catchConnectionError :: IO a -> IO (Either ClientError a)
299catchConnectionError :: IO a -> IO (Either ClientError a)
295catchConnectionError action =
300catchConnectionError action =
296 catch (Right <$> action) $ \e ->
301 catch (Right <$> action) $ \e ->
servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs+21−11
@@ -24,7 +24,8 @@ import Control.DeepSeq
24 (NFData, force)
24 (NFData, force)
25import Control.Exception
25import Control.Exception
26 (evaluate, throwIO)
26 (evaluate, throwIO)
27−import Control.Monad ()
27+import Control.Monad
28+ (unless)
28import Control.Monad.Base
29import Control.Monad.Base
29 (MonadBase (..))
30 (MonadBase (..))
30import Control.Monad.Codensity
31import Control.Monad.Codensity
@@ -47,7 +48,7 @@ import Data.Time.Clock
47 (getCurrentTime)
48 (getCurrentTime)
48import GHC.Generics
49import GHC.Generics
49import Network.HTTP.Types
50import Network.HTTP.Types
50− (Status, statusCode)
51+ (Status, statusIsSuccessful)
51
52
52import qualified Network.HTTP.Client as Client
53import qualified Network.HTTP.Client as Client
53
54
@@ -140,7 +141,7 @@ performRequest :: Maybe [Status] -> Request -> ClientM Response
140performRequest acceptStatus req = do
141performRequest acceptStatus req = do
141 -- TODO: should use Client.withResponse here too
142 -- TODO: should use Client.withResponse here too
142 ClientEnv m burl cookieJar' createClientRequest <- ask
143 ClientEnv m burl cookieJar' createClientRequest <- ask
143− let clientRequest = createClientRequest burl req
144+ clientRequest <- liftIO $ createClientRequest burl req
144 request <- case cookieJar' of
145 request <- case cookieJar' of
145 Nothing -> pure clientRequest
146 Nothing -> pure clientRequest
146 Just cj -> liftIO $ do
147 Just cj -> liftIO $ do
@@ -163,10 +164,9 @@ performRequest acceptStatus req = do
163 now' <- getCurrentTime
164 now' <- getCurrentTime
164 atomically $ modifyTVar' cj (fst . Client.updateCookieJar response request now')
165 atomically $ modifyTVar' cj (fst . Client.updateCookieJar response request now')
165 let status = Client.responseStatus response
166 let status = Client.responseStatus response
166− status_code = statusCode status
167 ourResponse = clientResponseToResponse id response
167 ourResponse = clientResponseToResponse id response
168 goodStatus = case acceptStatus of
168 goodStatus = case acceptStatus of
169− Nothing -> status_code >= 200 && status_code < 300
169+ Nothing -> statusIsSuccessful status
170 Just good -> status `elem` good
170 Just good -> status `elem` good
171 unless goodStatus $ do
171 unless goodStatus $ do
172 throwError $ mkFailureResponse burl req ourResponse
172 throwError $ mkFailureResponse burl req ourResponse
@@ -175,17 +175,27 @@ performRequest acceptStatus req = do
175-- | TODO: support UVerb ('acceptStatus' argument, like in 'performRequest' above).
175-- | TODO: support UVerb ('acceptStatus' argument, like in 'performRequest' above).
176performWithStreamingRequest :: Request -> (StreamingResponse -> IO a) -> ClientM a
176performWithStreamingRequest :: Request -> (StreamingResponse -> IO a) -> ClientM a
177performWithStreamingRequest req k = do
177performWithStreamingRequest req k = do
178− m <- asks manager
178+ ClientEnv m burl cookieJar' createClientRequest <- ask
179− burl <- asks baseUrl
179+ clientRequest <- liftIO $ createClientRequest burl req
180− createClientRequest <- asks makeClientRequest
180+ request <- case cookieJar' of
181− let request = createClientRequest burl req
181+ Nothing -> pure clientRequest
182+ Just cj -> liftIO $ do
183+ now <- getCurrentTime
184+ atomically $ do
185+ oldCookieJar <- readTVar cj
186+ let (newRequest, newCookieJar) =
187+ Client.insertCookiesIntoRequest
188+ clientRequest
189+ oldCookieJar
190+ now
191+ writeTVar cj newCookieJar
192+ pure newRequest
182 ClientM $ lift $ lift $ Codensity $ \k1 ->
193 ClientM $ lift $ lift $ Codensity $ \k1 ->
183 Client.withResponse request m $ \res -> do
194 Client.withResponse request m $ \res -> do
184 let status = Client.responseStatus res
195 let status = Client.responseStatus res
185− status_code = statusCode status
186
196
187 -- we throw FailureResponse in IO :(
197 -- we throw FailureResponse in IO :(
188− unless (status_code >= 200 && status_code < 300) $ do
198+ unless (statusIsSuccessful status) $ do
189 b <- BSL.fromChunks <$> Client.brConsume (Client.responseBody res)
199 b <- BSL.fromChunks <$> Client.brConsume (Client.responseBody res)
190 throwIO $ mkFailureResponse burl req (clientResponseToResponse (const b) res)
200 throwIO $ mkFailureResponse burl req (clientResponseToResponse (const b) res)
191
201
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+78−6
@@ -24,9 +24,15 @@ import Prelude.Compat
24
24
25import Control.Concurrent
25import Control.Concurrent
26 (ThreadId, forkIO, killThread)
26 (ThreadId, forkIO, killThread)
27+import Control.Monad
28+ (join)
27import Control.Monad.Error.Class
29import Control.Monad.Error.Class
28 (throwError)
30 (throwError)
29import Data.Aeson
31import Data.Aeson
32+import Data.ByteString
33+ (ByteString)
34+import Data.ByteString.Builder
35+ (byteString)
30import qualified Data.ByteString.Lazy as LazyByteString
36import qualified Data.ByteString.Lazy as LazyByteString
31import Data.Char
37import Data.Char
32 (chr, isPrint)
38 (chr, isPrint)
@@ -54,11 +60,12 @@ import Web.FormUrlEncoded
54import Servant.API
60import Servant.API
55 ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth,
61 ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth,
56 BasicAuthData (..), Capture, CaptureAll, DeleteNoContent,
62 BasicAuthData (..), Capture, CaptureAll, DeleteNoContent,
57− EmptyAPI, FormUrlEncoded, Fragment, Get, Header, Headers,
63+ EmptyAPI, FormUrlEncoded, Fragment, FromHttpApiData (..), Get, Header, Headers,
58 JSON, MimeRender (mimeRender), MimeUnrender (mimeUnrender),
64 JSON, MimeRender (mimeRender), MimeUnrender (mimeUnrender),
59 NoContent (NoContent), PlainText, Post, QueryFlag, QueryParam,
65 NoContent (NoContent), PlainText, Post, QueryFlag, QueryParam,
60− QueryParams, Raw, ReqBody, StdMethod (GET), UVerb, Union,
66+ QueryParams, Raw, ReqBody, StdMethod (GET), ToHttpApiData (..), UVerb, Union,
61− WithStatus (WithStatus), addHeader)
67+ Verb, WithStatus (WithStatus), NamedRoutes, addHeader)
68+import Servant.API.Generic ((:-))
62import Servant.Client
69import Servant.Client
63import qualified Servant.Client.Core.Auth as Auth
70import qualified Servant.Client.Core.Auth as Auth
64import Servant.Server
71import Servant.Server
@@ -101,14 +108,35 @@ carol = Person "Carol" 17
101
108
102type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]
109type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]
103
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+
104type Api =
124type Api =
105 Get '[JSON] Person
125 Get '[JSON] Person
106 :<|> "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
107 :<|> "deleteEmpty" :> DeleteNoContent
131 :<|> "deleteEmpty" :> DeleteNoContent
108 :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person
132 :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person
109 :<|> "captureAll" :> CaptureAll "names" String :> Get '[JSON] [Person]
133 :<|> "captureAll" :> CaptureAll "names" String :> Get '[JSON] [Person]
110 :<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person
134 :<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person
111 :<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person
135 :<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person
136+ -- This endpoint makes use of a 'Raw' server because it is not currently
137+ -- possible to handle arbitrary binary query param values with
138+ -- @servant-server@
139+ :<|> "param-binary" :> QueryParam "payload" UrlEncodedByteString :> Raw
112 :<|> "params" :> QueryParams "names" String :> Get '[JSON] [Person]
140 :<|> "params" :> QueryParams "names" String :> Get '[JSON] [Person]
113 :<|> "flag" :> QueryFlag "flag" :> Get '[JSON] Bool
141 :<|> "flag" :> QueryFlag "flag" :> Get '[JSON] Bool
114 :<|> "fragment" :> Fragment String :> Get '[JSON] Person
142 :<|> "fragment" :> Fragment String :> Get '[JSON] Person
@@ -131,18 +159,21 @@ type Api =
131 UVerb 'GET '[PlainText] '[WithStatus 200 Person,
159 UVerb 'GET '[PlainText] '[WithStatus 200 Person,
132 WithStatus 301 Text]
160 WithStatus 301 Text]
133 :<|> "uverb-get-created" :> UVerb 'GET '[PlainText] '[WithStatus 201 Person]
161 :<|> "uverb-get-created" :> UVerb 'GET '[PlainText] '[WithStatus 201 Person]
134−
162+ :<|> NamedRoutes RecordRoutes
163+ :<|> "captureVerbatim" :> Capture "someString" Verbatim :> Get '[PlainText] Text
135
164
136api :: Proxy Api
165api :: Proxy Api
137api = Proxy
166api = Proxy
138
167
139getRoot :: ClientM Person
168getRoot :: ClientM Person
140getGet :: ClientM Person
169getGet :: ClientM Person
170+getGet307 :: ClientM Text
141getDeleteEmpty :: ClientM NoContent
171getDeleteEmpty :: ClientM NoContent
142getCapture :: String -> ClientM Person
172getCapture :: String -> ClientM Person
143getCaptureAll :: [String] -> ClientM [Person]
173getCaptureAll :: [String] -> ClientM [Person]
144getBody :: Person -> ClientM Person
174getBody :: Person -> ClientM Person
145getQueryParam :: Maybe String -> ClientM Person
175getQueryParam :: Maybe String -> ClientM Person
176+getQueryParamBinary :: Maybe UrlEncodedByteString -> HTTP.Method -> ClientM Response
146getQueryParams :: [String] -> ClientM [Person]
177getQueryParams :: [String] -> ClientM [Person]
147getQueryFlag :: Bool -> ClientM Bool
178getQueryFlag :: Bool -> ClientM Bool
148getFragment :: ClientM Person
179getFragment :: ClientM Person
@@ -159,14 +190,17 @@ uverbGetSuccessOrRedirect :: Bool
159 -> ClientM (Union '[WithStatus 200 Person,
190 -> ClientM (Union '[WithStatus 200 Person,
160 WithStatus 301 Text])
191 WithStatus 301 Text])
161uverbGetCreated :: ClientM (Union '[WithStatus 201 Person])
192uverbGetCreated :: ClientM (Union '[WithStatus 201 Person])
193+recordRoutes :: RecordRoutes (AsClientT ClientM)
162
194
163getRoot
195getRoot
164 :<|> getGet
196 :<|> getGet
197+ :<|> getGet307
165 :<|> getDeleteEmpty
198 :<|> getDeleteEmpty
166 :<|> getCapture
199 :<|> getCapture
167 :<|> getCaptureAll
200 :<|> getCaptureAll
168 :<|> getBody
201 :<|> getBody
169 :<|> getQueryParam
202 :<|> getQueryParam
203+ :<|> getQueryParamBinary
170 :<|> getQueryParams
204 :<|> getQueryParams
171 :<|> getQueryFlag
205 :<|> getQueryFlag
172 :<|> getFragment
206 :<|> getFragment
@@ -180,12 +214,15 @@ getRoot
180 :<|> getRedirectWithCookie
214 :<|> getRedirectWithCookie
181 :<|> EmptyClient
215 :<|> EmptyClient
182 :<|> uverbGetSuccessOrRedirect
216 :<|> uverbGetSuccessOrRedirect
183− :<|> uverbGetCreated = client api
217+ :<|> uverbGetCreated
218+ :<|> recordRoutes
219+ :<|> captureVerbatim = client api
184
220
185server :: Application
221server :: Application
186server = serve api (
222server = serve api (
187 return carol
223 return carol
188 :<|> return alice
224 :<|> return alice
225+ :<|> return "redirecting"
189 :<|> return NoContent
226 :<|> return NoContent
190 :<|> (\ name -> return $ Person name 0)
227 :<|> (\ name -> return $ Person name 0)
191 :<|> (\ names -> return (zipWith Person names [0..]))
228 :<|> (\ names -> return (zipWith Person names [0..]))
@@ -194,6 +231,13 @@ server = serve api (
194 Just "alice" -> return alice
231 Just "alice" -> return alice
195 Just n -> throwError $ ServerError 400 (n ++ " not found") "" []
232 Just n -> throwError $ ServerError 400 (n ++ " not found") "" []
196 Nothing -> throwError $ ServerError 400 "missing parameter" "" [])
233 Nothing -> throwError $ ServerError 400 "missing parameter" "" [])
234+ :<|> const (Tagged $ \request respond ->
235+ respond . maybe (Wai.responseLBS HTTP.notFound404 [] "Missing: payload")
236+ (Wai.responseLBS HTTP.ok200 [] . LazyByteString.fromStrict)
237+ . join
238+ . lookup "payload"
239+ $ Wai.queryString request
240+ )
197 :<|> (\ names -> return (zipWith Person names [0..]))
241 :<|> (\ names -> return (zipWith Person names [0..]))
198 :<|> return
242 :<|> return
199 :<|> return alice
243 :<|> return alice
@@ -210,8 +254,18 @@ server = serve api (
210 then respond (WithStatus @301 ("redirecting" :: Text))
254 then respond (WithStatus @301 ("redirecting" :: Text))
211 else respond (WithStatus @200 alice ))
255 else respond (WithStatus @200 alice ))
212 :<|> 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
213 )
265 )
214
266
267+-- * api for testing failures
268+
215type FailApi =
269type FailApi =
216 "get" :> Raw
270 "get" :> Raw
217 :<|> "capture" :> Capture "name" String :> Raw
271 :<|> "capture" :> Capture "name" String :> Raw
@@ -226,7 +280,7 @@ failServer = serve failApi (
226 :<|> (\ _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")] "")
227 :<|> (Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "fooooo")] "")
281 :<|> (Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "fooooo")] "")
228 :<|> (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")] "")
229− )
283+ )
230
284
231-- * basic auth stuff
285-- * basic auth stuff
232
286
@@ -310,3 +364,21 @@ pathGen = fmap NonEmpty path
310 filter (not . (`elem` ("?%[]/#;" :: String))) $
364 filter (not . (`elem` ("?%[]/#;" :: String))) $
311 filter isPrint $
365 filter isPrint $
312 map chr [0..127]
366 map chr [0..127]
367+
368+newtype UrlEncodedByteString = UrlEncodedByteString { unUrlEncodedByteString :: ByteString }
369+
370+instance ToHttpApiData UrlEncodedByteString where
371+ toEncodedUrlPiece = byteString . HTTP.urlEncode True . unUrlEncodedByteString
372+ toUrlPiece = decodeUtf8 . HTTP.urlEncode True . unUrlEncodedByteString
373+
374+instance FromHttpApiData UrlEncodedByteString where
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−5
@@ -21,8 +21,6 @@ import Prelude ()
21import Prelude.Compat
21import Prelude.Compat
22
22
23import Data.Monoid ()
23import Data.Monoid ()
24−import Data.Semigroup
25− ((<>))
26import qualified Network.HTTP.Types as HTTP
24import qualified Network.HTTP.Types as HTTP
27import Test.Hspec
25import Test.Hspec
28
26
@@ -40,14 +38,14 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
40
38
41 context "client returns errors appropriately" $ do
39 context "client returns errors appropriately" $ do
42 it "reports FailureResponse" $ \(_, baseUrl) -> do
40 it "reports FailureResponse" $ \(_, baseUrl) -> do
43− let (_ :<|> _ :<|> getDeleteEmpty :<|> _) = client api
41+ let (_ :<|> _ :<|> _ :<|> getDeleteEmpty :<|> _) = client api
44 Left res <- runClient getDeleteEmpty baseUrl
42 Left res <- runClient getDeleteEmpty baseUrl
45 case res of
43 case res of
46 FailureResponse _ r | responseStatusCode r == HTTP.status404 -> return ()
44 FailureResponse _ r | responseStatusCode r == HTTP.status404 -> return ()
47 _ -> fail $ "expected 404 response, but got " <> show res
45 _ -> fail $ "expected 404 response, but got " <> show res
48
46
49 it "reports DecodeFailure" $ \(_, baseUrl) -> do
47 it "reports DecodeFailure" $ \(_, baseUrl) -> do
50− let (_ :<|> _ :<|> _ :<|> getCapture :<|> _) = client api
48+ let (_ :<|> _ :<|> _ :<|> _ :<|> getCapture :<|> _) = client api
51 Left res <- runClient (getCapture "foo") baseUrl
49 Left res <- runClient (getCapture "foo") baseUrl
52 case res of
50 case res of
53 DecodeFailure _ _ -> return ()
51 DecodeFailure _ _ -> return ()
@@ -74,7 +72,7 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
74 _ -> fail $ "expected UnsupportedContentType, but got " <> show res
72 _ -> fail $ "expected UnsupportedContentType, but got " <> show res
75
73
76 it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do
74 it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do
77− let (_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api
75+ let (_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api
78 Left res <- runClient (getBody alice) baseUrl
76 Left res <- runClient (getBody alice) baseUrl
79 case res of
77 case res of
80 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+34−14
@@ -22,19 +22,22 @@ import Prelude ()
22import Prelude.Compat
22import Prelude.Compat
23
23
24import Control.Arrow
24import Control.Arrow
25− (left)
25+ ((+++), left)
26import Control.Concurrent.STM
26import Control.Concurrent.STM
27 (atomically)
27 (atomically)
28import Control.Concurrent.STM.TVar
28import Control.Concurrent.STM.TVar
29 (newTVar, readTVar)
29 (newTVar, readTVar)
30+import qualified Data.ByteString as BS
31+import qualified Data.ByteString.Lazy as BL
30import Data.Foldable
32import Data.Foldable
31 (forM_, toList)
33 (forM_, toList)
32import Data.Maybe
34import Data.Maybe
33 (listToMaybe)
35 (listToMaybe)
34import Data.Monoid ()
36import Data.Monoid ()
35−import Data.SOP (NS (..), I (..))
36import Data.Text
37import Data.Text
37 (Text)
38 (Text)
39+import Data.Text.Encoding
40+ (encodeUtf8)
38import qualified Network.HTTP.Client as C
41import qualified Network.HTTP.Client as C
39import qualified Network.HTTP.Types as HTTP
42import qualified Network.HTTP.Types as HTTP
40import Test.Hspec
43import Test.Hspec
@@ -43,11 +46,9 @@ import Test.HUnit
43import Test.QuickCheck
46import Test.QuickCheck
44
47
45import Servant.API
48import Servant.API
46− (NoContent (NoContent), WithStatus (WithStatus), getHeaders)
49+ (NoContent (NoContent), WithStatus (WithStatus), getHeaders, Headers(..))
47import Servant.Client
50import Servant.Client
48import qualified Servant.Client.Core.Request as Req
51import qualified Servant.Client.Core.Request as Req
49−import Servant.Client.Internal.HttpClient
50− (defaultMakeClientRequest)
51import Servant.ClientTestUtils
52import Servant.ClientTestUtils
52import Servant.Test.ComprehensiveAPI
53import Servant.Test.ComprehensiveAPI
53
54
@@ -60,11 +61,15 @@ spec = describe "Servant.SuccessSpec" $ do
60
61
61successSpec :: Spec
62successSpec :: Spec
62successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
63successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
63− it "Servant.API.Get root" $ \(_, baseUrl) -> do
64+ describe "Servant.API.Get" $ do
65+ it "get root endpoint" $ \(_, baseUrl) -> do
64− left show <$> runClient getRoot baseUrl `shouldReturn` Right carol
66+ left show <$> runClient getRoot baseUrl `shouldReturn` Right carol
65
67
66− it "Servant.API.Get" $ \(_, baseUrl) -> do
68+ it "get simple endpoint" $ \(_, baseUrl) -> do
67− 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"
68
73
69 describe "Servant.API.Delete" $ do
74 describe "Servant.API.Delete" $ do
70 it "allows empty content type" $ \(_, baseUrl) -> do
75 it "allows empty content type" $ \(_, baseUrl) -> do
@@ -96,6 +101,11 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
96 Left (FailureResponse _ r) <- runClient (getQueryParam (Just "bob")) baseUrl
101 Left (FailureResponse _ r) <- runClient (getQueryParam (Just "bob")) baseUrl
97 responseStatusCode r `shouldBe` HTTP.Status 400 "bob not found"
102 responseStatusCode r `shouldBe` HTTP.Status 400 "bob not found"
98
103
104+ it "Servant.API.QueryParam binary data" $ \(_, baseUrl) -> do
105+ let payload = BS.pack [0, 1, 2, 4, 8, 16, 32, 64, 128]
106+ apiCall = getQueryParamBinary (Just $ UrlEncodedByteString payload) HTTP.methodGet
107+ (show +++ responseBody) <$> runClient apiCall baseUrl `shouldReturn` Right (BL.fromStrict payload)
108+
99 it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do
109 it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do
100 left show <$> runClient (getQueryParams []) baseUrl `shouldReturn` Right []
110 left show <$> runClient (getQueryParams []) baseUrl `shouldReturn` Right []
101 left show <$> runClient (getQueryParams ["alice", "bob"]) baseUrl
111 left show <$> runClient (getQueryParams ["alice", "bob"]) baseUrl
@@ -107,6 +117,7 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
107
117
108 it "Servant.API.Fragment" $ \(_, baseUrl) -> do
118 it "Servant.API.Fragment" $ \(_, baseUrl) -> do
109 left id <$> runClient getFragment baseUrl `shouldReturn` Right alice
119 left id <$> runClient getFragment baseUrl `shouldReturn` Right alice
120+
110 it "Servant.API.Raw on success" $ \(_, baseUrl) -> do
121 it "Servant.API.Raw on success" $ \(_, baseUrl) -> do
111 res <- runClient (getRawSuccess HTTP.methodGet) baseUrl
122 res <- runClient (getRawSuccess HTTP.methodGet) baseUrl
112 case res of
123 case res of
@@ -134,9 +145,10 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
134 res <- runClient getUVerbRespHeaders baseUrl
145 res <- runClient getUVerbRespHeaders baseUrl
135 case res of
146 case res of
136 Left e -> assertFailure $ show e
147 Left e -> assertFailure $ show e
137− Right (Z (I (WithStatus val))) ->
148+ Right val -> case matchUnion val of
149+ Just (WithStatus val' :: WithStatus 200 (Headers TestHeaders Bool))
138− getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]
150+ -> getHeaders val' `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]
139− Right (S _) -> assertFailure "expected first alternative of union"
151+ Nothing -> assertFailure "unexpected alternative of union"
140
152
141 it "Stores Cookie in CookieJar after a redirect" $ \(_, baseUrl) -> do
153 it "Stores Cookie in CookieJar after a redirect" $ \(_, baseUrl) -> do
142 mgr <- C.newManager C.defaultManagerSettings
154 mgr <- C.newManager C.defaultManagerSettings
@@ -150,8 +162,9 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
150 mgr <- C.newManager C.defaultManagerSettings
162 mgr <- C.newManager C.defaultManagerSettings
151 -- 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.
152 -- 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
153− 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)
154− let clientEnv = (mkClientEnv mgr baseUrl) { makeClientRequest = createClientRequest }
167+ clientEnv = (mkClientEnv mgr baseUrl) { makeClientRequest = createClientRequest }
155 res <- runClientM (getRawSuccessPassHeaders HTTP.methodGet) clientEnv
168 res <- runClientM (getRawSuccessPassHeaders HTTP.methodGet) clientEnv
156 case res of
169 case res of
157 Left e ->
170 Left e ->
@@ -186,3 +199,10 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
186 case eitherResponse of
199 case eitherResponse of
187 Left clientError -> fail $ show clientError
200 Left clientError -> fail $ show clientError
188 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+9−9
@@ -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,20 +10,20 @@ 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
17copyright: 2018-2019 Servant Contributors
17copyright: 2018-2019 Servant Contributors
18build-type: Simple
18build-type: Simple
19−tested-with: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.2
19+tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2
20
20
21extra-source-files:
21extra-source-files:
22 CHANGELOG.md
22 CHANGELOG.md
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
@@ -31,9 +31,9 @@ library
31 base >=4.9 && <5
31 base >=4.9 && <5
32 , bytestring >=0.10.8.1 && <0.12
32 , bytestring >=0.10.8.1 && <0.12
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.1
35− , resourcet >=1.2.2 && <1.3
35+ , resourcet >=1.2.2 && <1.4
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/example/greet.hs+4−4
@@ -75,7 +75,7 @@ intro2 = DocIntro "This title is below the last"
75-- API specification
75-- API specification
76type TestApi =
76type TestApi =
77 -- GET /hello/:name?capital={true, false} returns a Greet as JSON or PlainText
77 -- GET /hello/:name?capital={true, false} returns a Greet as JSON or PlainText
78− "hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get '[JSON, PlainText] Greet
78+ "hello" :> Capture "name" Text :> Header "X-Num-Fairies" Int :> QueryParam "capital" Bool :> Get '[JSON, PlainText] Greet
79
79
80 -- POST /greet with a Greet as JSON in the request body,
80 -- POST /greet with a Greet as JSON in the request body,
81 -- returns a Greet as JSON
81 -- returns a Greet as JSON
@@ -93,9 +93,9 @@ testApi = Proxy
93extra :: ExtraInfo TestApi
93extra :: ExtraInfo TestApi
94extra =
94extra =
95 extraInfo (Proxy :: Proxy ("greet" :> Capture "greetid" Text :> Delete '[JSON] NoContent)) $
95 extraInfo (Proxy :: Proxy ("greet" :> Capture "greetid" Text :> Delete '[JSON] NoContent)) $
96− defAction & headers <>~ ["unicorns"]
96+ defAction & headers <>~ [("X-Num-Unicorns", "1")]
97 & notes <>~ [ DocNote "Title" ["This is some text"]
97 & notes <>~ [ DocNote "Title" ["This is some text"]
98− , DocNote "Second secton" ["And some more"]
98+ , DocNote "Second section" ["And some more"]
99 ]
99 ]
100
100
101-- Generate the data that lets us have API docs. This
101-- Generate the data that lets us have API docs. This
@@ -109,4 +109,4 @@ docsGreet :: API
109docsGreet = docsWith defaultDocOptions [intro1, intro2] extra testApi
109docsGreet = docsWith defaultDocOptions [intro1, intro2] extra testApi
110
110
111main :: IO ()
111main :: IO ()
112−main = putStrLn $ markdown docsGreet
112+main = putStrLn $ markdownWith (defRenderingOptions { _renderCurlBasePath = Just "http://localhost:80" }) docsGreet
servant-docs/example/greet.md+32−1
@@ -51,6 +51,15 @@ You'll also note that multiple intros are possible.
51"Hello, haskeller"
51"Hello, haskeller"
52```
52```
53
53
54+### Sample Request:
55+
56+```bash
57+curl -XPOST \
58+ -H "Content-Type: application/json;charset=utf-8" \
59+ -d "\"HELLO, HASKELLER\"" \
60+ http://localhost:80/greet
61+```
62+
54## DELETE /greet/:greetid
63## DELETE /greet/:greetid
55
64
56### Title
65### Title
@@ -67,7 +76,7 @@ And some more
67
76
68### Headers:
77### Headers:
69
78
70−- This endpoint is sensitive to the value of the **unicorns** HTTP header.
79+- This endpoint is sensitive to the value of the **X-Num-Unicorns** HTTP header.
71
80
72### Response:
81### Response:
73
82
@@ -85,12 +94,24 @@ And some more
85
94
86```
95```
87
96
97+### Sample Request:
98+
99+```bash
100+curl -XDELETE \
101+ -H "X-Num-Unicorns: 1" \
102+ http://localhost:80/greet/:greetid
103+```
104+
88## GET /hello/:name
105## GET /hello/:name
89
106
90### Captures:
107### Captures:
91
108
92- *name*: name of the person to greet
109- *name*: name of the person to greet
93
110
111+### Headers:
112+
113+- This endpoint is sensitive to the value of the **X-Num-Fairies** HTTP header.
114+
94### GET Parameters:
115### GET Parameters:
95
116
96- capital
117- capital
@@ -120,3 +141,13 @@ And some more
120```javascript
141```javascript
121"Hello, haskeller"
142"Hello, haskeller"
122```
143```
144+
145+### Sample Request:
146+
147+```bash
148+curl -XGET \
149+ -H "X-Num-Fairies: 1729" \
150+ http://localhost:80/hello/:name
151+```
152+
153+
servant-docs/golden/comprehensive.md+18
@@ -530,6 +530,24 @@
530
530
531```
531```
532
532
533+## GET /resource
534+
535+### Response:
536+
537+- Status code 200
538+- Headers: []
539+
540+- Supported content types are:
541+
542+ - `application/json;charset=utf-8`
543+ - `application/json`
544+
545+- Example (`application/json;charset=utf-8`, `application/json`):
546+
547+```javascript
548+
549+```
550+
533## GET /streaming
551## GET /streaming
534
552
535### Request:
553### Request:
servant-docs/servant-docs.cabal+12−12
@@ -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,13 +13,13 @@ 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
20copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors
20copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors
21build-type: Simple
21build-type: Simple
22−tested-with: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1
22+tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1
23
23
24extra-source-files:
24extra-source-files:
25 CHANGELOG.md
25 CHANGELOG.md
@@ -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.18
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.3
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
@@ -102,7 +102,7 @@ test-suite spec
102
102
103 -- Additional dependencies
103 -- Additional dependencies
104 build-depends:
104 build-depends:
105− tasty >= 1.1.0.4 && < 1.3,
105+ tasty >= 1.1.0.4 && < 1.5,
106 tasty-golden >= 2.3.2 && < 2.4,
106 tasty-golden >= 2.3.2 && < 2.4,
107 tasty-hunit >= 0.10.0.1 && < 0.11,
107 tasty-hunit >= 0.10.0.1 && < 0.11,
108 transformers >= 0.5.2.0 && < 0.6
108 transformers >= 0.5.2.0 && < 0.6
servant-docs/src/Servant/Docs/Internal.hs+65−23
@@ -25,16 +25,14 @@ import Control.Applicative
25import Control.Arrow
25import Control.Arrow
26 (second)
26 (second)
27import Control.Lens
27import Control.Lens
28− (makeLenses, mapped, over, set, traversed, view, (%~), (&),
28+ (makeLenses, mapped, each, over, set, to, toListOf, traversed, view,
29− (.~), (<>~), (^.), (|>))
29+ _1, (%~), (&), (.~), (<>~), (^.), (|>))
30import qualified Data.ByteString.Char8 as BSC
30import qualified Data.ByteString.Char8 as BSC
31import Data.ByteString.Lazy.Char8
31import 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
@@ -52,17 +50,19 @@ import Data.Ord
52 (comparing)
50 (comparing)
53import Data.Proxy
51import Data.Proxy
54 (Proxy (Proxy))
52 (Proxy (Proxy))
55−import Data.Semigroup
56− (Semigroup (..))
57import Data.String.Conversions
53import Data.String.Conversions
58 (cs)
54 (cs)
59import Data.Text
55import Data.Text
60 (Text, unpack)
56 (Text, unpack)
61import GHC.Generics
57import GHC.Generics
58+ (Generic, Rep, K1(K1), M1(M1), U1(U1), V1,
59+ (:*:)((:*:)), (:+:)(L1, R1))
60+import qualified GHC.Generics as G
62import GHC.TypeLits
61import GHC.TypeLits
63import Servant.API
62import Servant.API
64import Servant.API.ContentTypes
63import Servant.API.ContentTypes
65import Servant.API.TypeLevel
64import Servant.API.TypeLevel
65+import Servant.API.Generic
66
66
67import qualified Data.Universe.Helpers as U
67import qualified Data.Universe.Helpers as U
68
68
@@ -295,7 +295,7 @@ defResponse = Response
295data Action = Action
295data Action = Action
296 { _authInfo :: [DocAuthentication] -- user supplied info
296 { _authInfo :: [DocAuthentication] -- user supplied info
297 , _captures :: [DocCapture] -- type collected + user supplied info
297 , _captures :: [DocCapture] -- type collected + user supplied info
298− , _headers :: [Text] -- type collected
298+ , _headers :: [HTTP.Header] -- type collected
299 , _params :: [DocQueryParam] -- type collected + user supplied info
299 , _params :: [DocQueryParam] -- type collected + user supplied info
300 , _fragment :: Maybe DocFragment -- type collected + user supplied info
300 , _fragment :: Maybe DocFragment -- type collected + user supplied info
301 , _notes :: [DocNote] -- user supplied
301 , _notes :: [DocNote] -- user supplied
@@ -356,12 +356,14 @@ data ShowContentTypes = AllContentTypes -- ^ For each example, show each conten
356--
356--
357-- @since 0.11.1
357-- @since 0.11.1
358data RenderingOptions = RenderingOptions
358data RenderingOptions = RenderingOptions
359− { _requestExamples :: !ShowContentTypes
359+ { _requestExamples :: !ShowContentTypes
360 -- ^ How many content types to display for request body examples?
360 -- ^ How many content types to display for request body examples?
361− , _responseExamples :: !ShowContentTypes
361+ , _responseExamples :: !ShowContentTypes
362 -- ^ How many content types to display for response body examples?
362 -- ^ How many content types to display for response body examples?
363− , _notesHeading :: !(Maybe String)
363+ , _notesHeading :: !(Maybe String)
364 -- ^ Optionally group all 'notes' together under a common heading.
364 -- ^ Optionally group all 'notes' together under a common heading.
365+ , _renderCurlBasePath :: !(Maybe String)
366+ -- ^ Optionally render example curl requests under a common base path (e.g. `http://localhost:80`).
365 } deriving (Show)
367 } deriving (Show)
366
368
367-- | Default API generation options.
369-- | Default API generation options.
@@ -373,9 +375,10 @@ data RenderingOptions = RenderingOptions
373-- @since 0.11.1
375-- @since 0.11.1
374defRenderingOptions :: RenderingOptions
376defRenderingOptions :: RenderingOptions
375defRenderingOptions = RenderingOptions
377defRenderingOptions = RenderingOptions
376− { _requestExamples = AllContentTypes
378+ { _requestExamples = AllContentTypes
377− , _responseExamples = AllContentTypes
379+ , _responseExamples = AllContentTypes
378− , _notesHeading = Nothing
380+ , _notesHeading = Nothing
381+ , _renderCurlBasePath = Nothing
379 }
382 }
380
383
381-- gimme some lenses
384-- gimme some lenses
@@ -412,7 +415,7 @@ docsWithOptions p = docsFor p (defEndpoint, defAction)
412-- > extra :: ExtraInfo TestApi
415-- > extra :: ExtraInfo TestApi
413-- > extra =
416-- > extra =
414-- > extraInfo (Proxy :: Proxy ("greet" :> Capture "greetid" Text :> Delete)) $
417-- > extraInfo (Proxy :: Proxy ("greet" :> Capture "greetid" Text :> Delete)) $
415−-- > defAction & headers <>~ ["unicorns"]
418+-- > defAction & headers <>~ [("X-Num-Unicorns", 1)]
416-- > & notes <>~ [ DocNote "Title" ["This is some text"]
419-- > & notes <>~ [ DocNote "Title" ["This is some text"]
417-- > , DocNote "Second section" ["And some more"]
420-- > , DocNote "Second section" ["And some more"]
418-- > ]
421-- > ]
@@ -444,7 +447,7 @@ docsWith opts intros (ExtraInfo endpoints) p =
444 & apiEndpoints %~ HM.unionWith (flip combineAction) endpoints
447 & apiEndpoints %~ HM.unionWith (flip combineAction) endpoints
445
448
446
449
447−-- | Generate the docs for a given API that implements 'HasDocs' with with any
450+-- | Generate the docs for a given API that implements 'HasDocs' with any
448-- number of introduction(s)
451-- number of introduction(s)
449docsWithIntros :: HasDocs api => [DocIntro] -> Proxy api -> API
452docsWithIntros :: HasDocs api => [DocIntro] -> Proxy api -> API
450docsWithIntros intros = docsWith defaultDocOptions intros mempty
453docsWithIntros intros = docsWith defaultDocOptions intros mempty
@@ -507,7 +510,7 @@ samples = map ("",)
507
510
508-- | Default sample Generic-based inputs/outputs.
511-- | Default sample Generic-based inputs/outputs.
509defaultSamples :: forall a. (Generic a, GToSample (Rep a)) => Proxy a -> [(Text, a)]
512defaultSamples :: forall a. (Generic a, GToSample (Rep a)) => Proxy a -> [(Text, a)]
510−defaultSamples _ = second to <$> gtoSamples (Proxy :: Proxy (Rep a))
513+defaultSamples _ = second G.to <$> gtoSamples (Proxy :: Proxy (Rep a))
511
514
512-- | @'ToSample'@ for Generics.
515-- | @'ToSample'@ for Generics.
513--
516--
@@ -643,7 +646,7 @@ markdown = markdownWith defRenderingOptions
643--
646--
644-- @since 0.11.1
647-- @since 0.11.1
645markdownWith :: RenderingOptions -> API -> String
648markdownWith :: RenderingOptions -> API -> String
646−markdownWith RenderingOptions{..} api = unlines $
649+markdownWith RenderingOptions{..} api = unlines $
647 introsStr (api ^. apiIntros)
650 introsStr (api ^. apiIntros)
648 ++ (concatMap (uncurry printEndpoint) . sort . HM.toList $ api ^. apiEndpoints)
651 ++ (concatMap (uncurry printEndpoint) . sort . HM.toList $ api ^. apiEndpoints)
649
652
@@ -654,11 +657,12 @@ markdownWith RenderingOptions{..} api = unlines $
654 notesStr (action ^. notes) ++
657 notesStr (action ^. notes) ++
655 authStr (action ^. authInfo) ++
658 authStr (action ^. authInfo) ++
656 capturesStr (action ^. captures) ++
659 capturesStr (action ^. captures) ++
657− headersStr (action ^. headers) ++
660+ headersStr (toListOf (headers . each . _1 . to (T.pack . BSC.unpack . CI.original)) action) ++
658 paramsStr meth (action ^. params) ++
661 paramsStr meth (action ^. params) ++
659 fragmentStr (action ^. fragment) ++
662 fragmentStr (action ^. fragment) ++
660 rqbodyStr (action ^. rqtypes) (action ^. rqbody) ++
663 rqbodyStr (action ^. rqtypes) (action ^. rqbody) ++
661 responseStr (action ^. response) ++
664 responseStr (action ^. response) ++
665+ maybe [] (curlStr endpoint (action ^. headers) (action ^. rqbody)) _renderCurlBasePath ++
662 []
666 []
663
667
664 where str = "## " ++ BSC.unpack meth
668 where str = "## " ++ BSC.unpack meth
@@ -814,7 +818,6 @@ markdownWith RenderingOptions{..} api = unlines $
814 ("text", "css") -> "css"
818 ("text", "css") -> "css"
815 (_, _) -> ""
819 (_, _) -> ""
816
820
817−
818 contentStr mime_type body =
821 contentStr mime_type body =
819 "" :
822 "" :
820 "```" <> markdownForType mime_type :
823 "```" <> markdownForType mime_type :
@@ -839,6 +842,36 @@ markdownWith RenderingOptions{..} api = unlines $
839 xs ->
842 xs ->
840 formatBodies _responseExamples xs
843 formatBodies _responseExamples xs
841
844
845+ curlStr :: Endpoint -> [HTTP.Header] -> [(Text, M.MediaType, ByteString)] -> String -> [String]
846+ curlStr endpoint hdrs reqBodies basePath =
847+ [ "### Sample Request:"
848+ , ""
849+ , "```bash"
850+ , "curl -X" ++ BSC.unpack (endpoint ^. method) ++ " \\"
851+ ] <>
852+ maybe [] pure mbMediaTypeStr <>
853+ headersStrs <>
854+ maybe [] pure mbReqBodyStr <>
855+ [ " " ++ basePath ++ showPath (endpoint ^. path)
856+ , "```"
857+ , ""
858+ ]
859+
860+ where escapeQuotes :: String -> String
861+ escapeQuotes = concatMap $ \c -> case c of
862+ '\"' -> "\\\""
863+ _ -> [c]
864+ mbReqBody = listToMaybe reqBodies
865+ mbMediaTypeStr = mkMediaTypeStr <$> mbReqBody
866+ headersStrs = mkHeaderStr <$> hdrs
867+ mbReqBodyStr = mkReqBodyStr <$> mbReqBody
868+ mkMediaTypeStr (_, media_type, _) =
869+ " -H \"Content-Type: " ++ show media_type ++ "\" \\"
870+ mkHeaderStr (hdrName, hdrVal) =
871+ " -H \"" ++ escapeQuotes (cs (CI.original hdrName)) ++ ": " ++
872+ escapeQuotes (cs hdrVal) ++ "\" \\"
873+ mkReqBodyStr (_, _, body) = " -d \"" ++ escapeQuotes (cs body) ++ "\" \\"
874+
842-- * Instances
875-- * Instances
843
876
844-- | The generated docs for @a ':<|>' b@ just appends the docs
877-- | The generated docs for @a ':<|>' b@ just appends the docs
@@ -977,14 +1010,17 @@ instance {-# OVERLAPPING #-}
977 status = fromInteger $ natVal (Proxy :: Proxy status)
1010 status = fromInteger $ natVal (Proxy :: Proxy status)
978 p = Proxy :: Proxy a
1011 p = Proxy :: Proxy a
979
1012
980−instance (KnownSymbol sym, HasDocs api)
1013+instance (ToHttpApiData a, ToSample a, KnownSymbol sym, HasDocs api)
981 => HasDocs (Header' mods sym a :> api) where
1014 => HasDocs (Header' mods sym a :> api) where
982 docsFor Proxy (endpoint, action) =
1015 docsFor Proxy (endpoint, action) =
983 docsFor subApiP (endpoint, action')
1016 docsFor subApiP (endpoint, action')
984
1017
985 where subApiP = Proxy :: Proxy api
1018 where subApiP = Proxy :: Proxy api
986− action' = over headers (|> headername) action
1019+ action' = over headers (|> (headerName, headerVal)) action
987− headername = T.pack $ symbolVal (Proxy :: Proxy sym)
1020+ headerName = CI.mk . cs $ symbolVal (Proxy :: Proxy sym)
1021+ headerVal = case toSample (Proxy :: Proxy a) of
1022+ Just x -> cs $ toHeader x
1023+ Nothing -> "<no header sample provided>"
988
1024
989instance (KnownSymbol sym, ToParam (QueryParam' mods sym a), HasDocs api)
1025instance (KnownSymbol sym, ToParam (QueryParam' mods sym a), HasDocs api)
990 => HasDocs (QueryParam' mods sym a :> api) where
1026 => HasDocs (QueryParam' mods sym a :> api) where
@@ -1108,6 +1144,9 @@ instance HasDocs api => HasDocs (Vault :> api) where
1108instance HasDocs api => HasDocs (WithNamedContext name context api) where
1144instance HasDocs api => HasDocs (WithNamedContext name context api) where
1109 docsFor Proxy = docsFor (Proxy :: Proxy api)
1145 docsFor Proxy = docsFor (Proxy :: Proxy api)
1110
1146
1147+instance HasDocs api => HasDocs (WithResource res :> api) where
1148+ docsFor Proxy = docsFor (Proxy :: Proxy api)
1149+
1111instance (ToAuthInfo (BasicAuth realm usr), HasDocs api) => HasDocs (BasicAuth realm usr :> api) where
1150instance (ToAuthInfo (BasicAuth realm usr), HasDocs api) => HasDocs (BasicAuth realm usr :> api) where
1112 docsFor Proxy (endpoint, action) =
1151 docsFor Proxy (endpoint, action) =
1113 docsFor (Proxy :: Proxy api) (endpoint, action')
1152 docsFor (Proxy :: Proxy api) (endpoint, action')
@@ -1115,6 +1154,9 @@ instance (ToAuthInfo (BasicAuth realm usr), HasDocs api) => HasDocs (BasicAuth r
1115 authProxy = Proxy :: Proxy (BasicAuth realm usr)
1154 authProxy = Proxy :: Proxy (BasicAuth realm usr)
1116 action' = over authInfo (|> toAuthInfo authProxy) action
1155 action' = over authInfo (|> toAuthInfo authProxy) action
1117
1156
1157+instance HasDocs (ToServantApi api) => HasDocs (NamedRoutes api) where
1158+ docsFor Proxy = docsFor (Proxy :: Proxy (ToServantApi api))
1159+
1118-- ToSample instances for simple types
1160-- ToSample instances for simple types
1119instance ToSample NoContent
1161instance ToSample NoContent
1120instance ToSample Bool
1162instance 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-docs/test/Servant/DocsSpec.hs−1
@@ -130,7 +130,6 @@ spec = describe "Servant.Docs" $ do
130 md `shouldContain` "\"dt1field1\":\"field 1\""
130 md `shouldContain` "\"dt1field1\":\"field 1\""
131 it "contains response samples - dt1field2" $
131 it "contains response samples - dt1field2" $
132 md `shouldContain` "\"dt1field2\":13"
132 md `shouldContain` "\"dt1field2\":13"
133−
134 it "contains request body samples" $
133 it "contains request body samples" $
135 md `shouldContain` "17"
134 md `shouldContain` "17"
136
135
servant-foreign/CHANGELOG.md+12
@@ -1,6 +1,18 @@
1[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-foreign/CHANGELOG.md)
1[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-foreign/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.15.4
5+------
6+
7+### Significant changes
8+
9+- Documentation improvements.
10+
11+### Other changes
12+
13+- Support GHC-9.0.1.
14+- Bump `lens` and `hspec` dependencies.
15+
40.15.3
160.15.3
5------
17------
6
18
servant-foreign/servant-foreign.cabal+11−11
@@ -1,6 +1,6 @@
1−cabal-version: >=1.10
1+cabal-version: 2.2
2name: servant-foreign
2name: servant-foreign
3−version: 0.15.3
3+version: 0.15.4
4
4
5synopsis: Helpers for generating clients for servant APIs in any programming language
5synopsis: Helpers for generating clients for servant APIs in any programming language
6category: Servant, Web
6category: Servant, Web
@@ -15,13 +15,13 @@ 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
22copyright: 2015-2019 Servant Contributors
22copyright: 2015-2019 Servant Contributors
23build-type: Simple
23build-type: Simple
24−tested-with: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1
24+tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1
25
25
26extra-source-files:
26extra-source-files:
27 CHANGELOG.md
27 CHANGELOG.md
@@ -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.18
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.3
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-foreign/src/Servant/Foreign/Inflections.hs−1
@@ -13,7 +13,6 @@ module Servant.Foreign.Inflections
13import Control.Lens hiding
13import Control.Lens hiding
14 (cons)
14 (cons)
15import qualified Data.Char as C
15import qualified Data.Char as C
16−import Data.Monoid
17import Data.Text hiding
16import Data.Text hiding
18 (map)
17 (map)
19import Prelude hiding
18import Prelude hiding
servant-foreign/src/Servant/Foreign/Internal.hs+8−3
@@ -23,8 +23,6 @@ import Control.Lens
23import Data.Data
23import Data.Data
24 (Data)
24 (Data)
25import Data.Proxy
25import Data.Proxy
26−import Data.Semigroup
27− (Semigroup)
28import Data.String
26import Data.String
29import Data.Text
27import Data.Text
30import Data.Text.Encoding
28import Data.Text.Encoding
@@ -246,7 +244,7 @@ defReq = Req defUrl "GET" [] Nothing Nothing (FunctionName []) ReqBodyJSON
246-- >
244-- >
247-- > -- Or for example in case of lists
245-- > -- Or for example in case of lists
248-- > instance HasForeignType LangX Text a => HasForeignType LangX Text [a] where
246-- > instance HasForeignType LangX Text a => HasForeignType LangX Text [a] where
249−-- > typeFor lang type _ = "listX of " <> typeFor lang ftype (Proxy :: Proxy a)
247+-- > typeFor lang ftype _ = "listX of " <> typeFor lang ftype (Proxy :: Proxy a)
250--
248--
251-- Finally to generate list of information about all the endpoints for
249-- Finally to generate list of information about all the endpoints for
252-- an API you create a function of a form:
250-- an API you create a function of a form:
@@ -489,6 +487,13 @@ instance HasForeign lang ftype api =>
489
487
490 foreignFor lang ftype Proxy = foreignFor lang ftype (Proxy :: Proxy api)
488 foreignFor lang ftype Proxy = foreignFor lang ftype (Proxy :: Proxy api)
491
489
490+instance HasForeign lang ftype api =>
491+ HasForeign lang ftype (WithResource res :> api) where
492+
493+ type Foreign ftype (WithResource res :> api) = Foreign ftype api
494+
495+ foreignFor lang ftype Proxy = foreignFor lang ftype (Proxy :: Proxy api)
496+
492instance HasForeign lang ftype api
497instance HasForeign lang ftype api
493 => HasForeign lang ftype (HttpVersion :> api) where
498 => HasForeign lang ftype (HttpVersion :> api) where
494 type Foreign ftype (HttpVersion :> api) = Foreign ftype api
499 type Foreign ftype (HttpVersion :> api) = Foreign ftype api
servant-foreign/test/Servant/ForeignSpec.hs−2
@@ -11,8 +11,6 @@
11
11
12module Servant.ForeignSpec where
12module Servant.ForeignSpec where
13
13
14−import Data.Monoid
15− ((<>))
16import Data.Proxy
14import Data.Proxy
17import Servant.Foreign
15import Servant.Foreign
18import Servant.Test.ComprehensiveAPI
16import Servant.Test.ComprehensiveAPI
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+17−17
@@ -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,13 +14,13 @@ 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
21copyright: 2019 Servant Contributors
21copyright: 2019 Servant Contributors
22build-type: Simple
22build-type: Simple
23−tested-with: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1
23+tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1
24
24
25extra-source-files:
25extra-source-files:
26 CHANGELOG.md
26 CHANGELOG.md
@@ -38,14 +38,14 @@ 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.18
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.1
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.13
48− , transformers >= 0.5.2.0 && < 0.6
48+ , transformers >= 0.5.2.0 && < 0.7
49
49
50 if !impl(ghc >= 8.2)
50 if !impl(ghc >= 8.2)
51 build-depends:
51 build-depends:
@@ -54,13 +54,13 @@ 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
@@ -72,7 +72,7 @@ library
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−8
@@ -49,8 +49,6 @@ import Data.Maybe
49 (maybeToList)
49 (maybeToList)
50import Data.Proxy
50import Data.Proxy
51 (Proxy (..))
51 (Proxy (..))
52−import Data.Semigroup
53− ((<>))
54import Data.Sequence
52import Data.Sequence
55 (fromList)
53 (fromList)
56import Data.String
54import Data.String
@@ -59,7 +57,7 @@ import GHC.Generics
59import Network.HTTP.Media
57import Network.HTTP.Media
60 (renderHeader)
58 (renderHeader)
61import Network.HTTP.Types
59import Network.HTTP.Types
62− (Status (..), hContentType, http11, renderQuery)
60+ (Status (..), hContentType, http11, renderQuery, statusIsSuccessful)
63import Servant.Client.Core
61import Servant.Client.Core
64
62
65import qualified Network.Http.Client as Client
63import qualified Network.Http.Client as Client
@@ -162,12 +160,12 @@ performRequest acceptStatus req = do
162 x <- ClientM $ lift $ lift $ Codensity $ \k -> do
160 x <- ClientM $ lift $ lift $ Codensity $ \k -> do
163 Client.sendRequest conn req' body
161 Client.sendRequest conn req' body
164 Client.receiveResponse conn $ \res' body' -> do
162 Client.receiveResponse conn $ \res' body' -> do
165− let sc = Client.getStatusCode res'
163+ let status = toEnum $ Client.getStatusCode res'
166 lbs <- BSL.fromChunks <$> Streams.toList body'
164 lbs <- BSL.fromChunks <$> Streams.toList body'
167 let res'' = clientResponseToResponse res' lbs
165 let res'' = clientResponseToResponse res' lbs
168 goodStatus = case acceptStatus of
166 goodStatus = case acceptStatus of
169− Nothing -> sc >= 200 && sc < 300
167+ Nothing -> statusIsSuccessful status
170− Just good -> sc `elem` (statusCode <$> good)
168+ Just good -> status `elem` good
171 if goodStatus
169 if goodStatus
172 then k (Right res'')
170 then k (Right res'')
173 else k (Left (mkFailureResponse burl req res''))
171 else k (Left (mkFailureResponse burl req res''))
@@ -182,8 +180,8 @@ performWithStreamingRequest req k = do
182 Client.sendRequest conn req' body
180 Client.sendRequest conn req' body
183 Client.receiveResponseRaw conn $ \res' body' -> do
181 Client.receiveResponseRaw conn $ \res' body' -> do
184 -- check status code
182 -- check status code
185− let sc = Client.getStatusCode res'
183+ let status = toEnum $ Client.getStatusCode res'
186− unless (sc >= 200 && sc < 300) $ do
184+ unless (statusIsSuccessful status) $ do
187 lbs <- BSL.fromChunks <$> Streams.toList body'
185 lbs <- BSL.fromChunks <$> Streams.toList body'
188 throwIO $ mkFailureResponse burl req (clientResponseToResponse res' lbs)
186 throwIO $ mkFailureResponse burl req (clientResponseToResponse res' lbs)
189
187
servant-http-streams/test/Servant/ClientSpec.hs−2
@@ -44,8 +44,6 @@ import Data.Maybe
44 (isJust)
44 (isJust)
45import Data.Monoid ()
45import Data.Monoid ()
46import Data.Proxy
46import Data.Proxy
47−import Data.Semigroup
48− ((<>))
49import GHC.Generics
47import GHC.Generics
50 (Generic)
48 (Generic)
51import qualified Network.HTTP.Types as HTTP
49import qualified Network.HTTP.Types as HTTP
servant-machines/servant-machines.cabal+8−8
@@ -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,20 +10,20 @@ 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
17copyright: 2018-2019 Servant Contributors
17copyright: 2018-2019 Servant Contributors
18build-type: Simple
18build-type: Simple
19−tested-with: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.2
19+tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2
20
20
21extra-source-files:
21extra-source-files:
22 CHANGELOG.md
22 CHANGELOG.md
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
@@ -31,8 +31,8 @@ library
31 base >=4.9 && <5
31 base >=4.9 && <5
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.1
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+9−9
@@ -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,20 +10,20 @@ 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
17copyright: 2018-2019 Servant Contributors
17copyright: 2018-2019 Servant Contributors
18build-type: Simple
18build-type: Simple
19−tested-with: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.2
19+tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2
20
20
21extra-source-files:
21extra-source-files:
22 CHANGELOG.md
22 CHANGELOG.md
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
@@ -32,9 +32,9 @@ library
32 , bytestring >=0.10.8.1 && <0.12
32 , bytestring >=0.10.8.1 && <0.12
33 , pipes >=4.3.9 && <4.4
33 , pipes >=4.3.9 && <4.4
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.1
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+30
@@ -1,6 +1,36 @@
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.2
7+------
8+
9+Compatibility with GHC 9.4, see [PR #1592](https://github.com/haskell-servant/servant/pull/1592).
10+
11+0.19.1
12+------
13+
14+- Add `MonadFail` instance for `Handler` wrt [#1545](https://github.com/haskell-servant/servant/issues/1545)
15+- Support GHC 9.2 [#1525](https://github.com/haskell-servant/servant/issues/1525)
16+- Add capture hints in `Router` type for debug and display purposes [PR #1556] (https://github.com/haskell-servant/servant/pull/1556)
17+
18+0.19
19+----
20+
21+### Significant changes
22+
23+- Drop support for GHC < 8.6.
24+- Support GHC 9.0 (GHC 9.2 should work as well, but isn't fully tested yet).
25+- Support Aeson 2 ([#1475](https://github.com/haskell-servant/servant/pull/1475)),
26+ which fixes a [DOS vulnerability](https://github.com/haskell/aeson/issues/864)
27+ related to hash collisions.
28+- Add `NamedRoutes` combinator, making support for records first-class in Servant
29+ ([#1388](https://github.com/haskell-servant/servant/pull/1388)).
30+- Add custom type errors for partially applied combinators
31+ ([#1289](https://github.com/haskell-servant/servant/pull/1289),
32+ [#1486](https://github.com/haskell-servant/servant/pull/1486)).
33+
40.18.3
340.18.3
5------
35------
6
36
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+18−17
@@ -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.2
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,13 +17,13 @@ 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
24copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors
24copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors
25build-type: Simple
25build-type: Simple
26−tested-with: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1
26+tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.4 || ==9.4.3
27
27
28extra-source-files:
28extra-source-files:
29 CHANGELOG.md
29 CHANGELOG.md
@@ -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.18
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.1
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.7
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.5.1
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
@@ -87,10 +88,10 @@ library
87 , network >= 2.8 && < 3.2
88 , network >= 2.8 && < 3.2
88 , sop-core >= 0.4.0.0 && < 0.6
89 , sop-core >= 0.4.0.0 && < 0.6
89 , string-conversions >= 0.4.0.1 && < 0.5
90 , string-conversions >= 0.4.0.1 && < 0.5
90− , resourcet >= 1.2.2 && < 1.3
91+ , resourcet >= 1.2.2 && < 1.4
91 , tagged >= 0.8.6 && < 0.9
92 , tagged >= 0.8.6 && < 0.9
92 , transformers-base >= 0.4.5.2 && < 0.5
93 , transformers-base >= 0.4.5.2 && < 0.5
93− , wai >= 3.2.1.2 && < 3.3
94+ , wai >= 3.2.2.1 && < 3.3
94 , wai-app-static >= 3.1.6.2 && < 3.2
95 , wai-app-static >= 3.1.6.2 && < 3.2
95 , word8 >= 0.1.3 && < 0.2
96 , word8 >= 0.1.3 && < 0.2
96
97
@@ -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+34−11
@@ -1,9 +1,10 @@
1−{-# LANGUAGE ConstraintKinds #-}
1+{-# LANGUAGE ConstraintKinds #-}
2−{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE FlexibleContexts #-}
4−{-# LANGUAGE RankNTypes #-}
4+{-# LANGUAGE RankNTypes #-}
5+{-# LANGUAGE ScopedTypeVariables #-}
5−{-# LANGUAGE TypeFamilies #-}
6+{-# LANGUAGE TypeFamilies #-}
6−{-# LANGUAGE TypeOperators #-}
7+{-# LANGUAGE TypeOperators #-}
7
8
8-- | This module lets you implement 'Server's for defined APIs. You'll
9-- | This module lets you implement 'Server's for defined APIs. You'll
9-- most likely just need 'serve'.
10-- most likely just need 'serve'.
@@ -11,6 +12,8 @@ module Servant.Server
11 ( -- * Run a wai application from an API
12 ( -- * Run a wai application from an API
12 serve
13 serve
13 , serveWithContext
14 , serveWithContext
15+ , serveWithContextT
16+ , ServerContext
14
17
15 , -- * Construct a wai Application from an API
18 , -- * Construct a wai Application from an API
16 toApplication
19 toApplication
@@ -128,6 +131,15 @@ import Servant.Server.UVerb
128
131
129-- * Implementing Servers
132-- * Implementing Servers
130
133
134+-- | Constraints that need to be satisfied on a context for it to be passed to 'serveWithContext'.
135+--
136+-- Typically, this will add default context entries to the context. You shouldn't typically
137+-- need to worry about these constraints, but if you write a helper function that wraps
138+-- 'serveWithContext', you might need to include this constraint.
139+type ServerContext context =
140+ ( HasContextEntry (context .++ DefaultErrorFormatters) ErrorFormatters
141+ )
142+
131-- | 'serve' allows you to implement an API and produce a wai 'Application'.
143-- | 'serve' allows you to implement an API and produce a wai 'Application'.
132--
144--
133-- Example:
145-- Example:
@@ -157,11 +169,21 @@ serve p = serveWithContext p EmptyContext
157-- 'defaultErrorFormatters' will always be appended to the end of the passed context,
169-- 'defaultErrorFormatters' will always be appended to the end of the passed context,
158-- but if you pass your own formatter, it will override the default one.
170-- but if you pass your own formatter, it will override the default one.
159serveWithContext :: ( HasServer api context
171serveWithContext :: ( HasServer api context
160− , HasContextEntry (context .++ DefaultErrorFormatters) ErrorFormatters )
172+ , ServerContext context
173+ )
161 => Proxy api -> Context context -> Server api -> Application
174 => Proxy api -> Context context -> Server api -> Application
162−serveWithContext p context server =
175+serveWithContext p context = serveWithContextT p context id
176+
177+-- | A general 'serve' function that allows you to pass a custom context and hoisting function to
178+-- apply on all routes.
179+serveWithContextT ::
180+ forall api context m.
181+ (HasServer api context, ServerContext context) =>
182+ Proxy api -> Context context -> (forall x. m x -> Handler x) -> ServerT api m -> Application
183+serveWithContextT p context toHandler server =
163− toApplication (runRouter format404 (route p context (emptyDelayed (Route server))))
184+ toApplication (runRouter format404 (route p context (emptyDelayed router)))
164 where
185 where
186+ router = Route $ hoistServerWithContext p (Proxy :: Proxy context) toHandler server
165 format404 = notFoundErrorFormatter . getContextEntry . mkContextWithErrorFormatter $ context
187 format404 = notFoundErrorFormatter . getContextEntry . mkContextWithErrorFormatter $ context
166
188
167-- | Hoist server implementation.
189-- | Hoist server implementation.
@@ -213,7 +235,7 @@ hoistServer p = hoistServerWithContext p (Proxy :: Proxy '[])
213-- > │ └─ e/
235-- > │ └─ e/
214-- > │ └─•
236-- > │ └─•
215-- > ├─ b/
237-- > ├─ b/
216−-- > │ └─ <capture>/
238+-- > │ └─ <x::Int>/
217-- > │ ├─•
239-- > │ ├─•
218-- > │ ┆
240-- > │ ┆
219-- > │ └─•
241-- > │ └─•
@@ -230,7 +252,8 @@ hoistServer p = hoistServerWithContext p (Proxy :: Proxy '[])
230--
252--
231-- [@─•@] Leaves reflect endpoints.
253-- [@─•@] Leaves reflect endpoints.
232--
254--
233−-- [@\<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@.
234--
257--
235-- [@\<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.
236--
259--
servant-server/src/Servant/Server/Experimental/Auth.hs+2−1
@@ -1,5 +1,6 @@
1{-# OPTIONS_GHC -fno-warn-orphans #-}
1{-# OPTIONS_GHC -fno-warn-orphans #-}
2{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE DeriveDataTypeable #-}
3+{-# LANGUAGE DeriveFunctor #-}
3{-# LANGUAGE DeriveGeneric #-}
4{-# LANGUAGE DeriveGeneric #-}
4{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE FlexibleInstances #-}
@@ -44,7 +45,7 @@ type family AuthServerData a :: *
44-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE
45-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE
45newtype AuthHandler r usr = AuthHandler
46newtype AuthHandler r usr = AuthHandler
46 { unAuthHandler :: r -> Handler usr }
47 { unAuthHandler :: r -> Handler usr }
47− deriving (Generic, Typeable)
48+ deriving (Functor, Generic, Typeable)
48
49
49-- | NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE
50-- | NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE
50mkAuthHandler :: (r -> Handler usr) -> AuthHandler r usr
51mkAuthHandler :: (r -> Handler usr) -> AuthHandler r usr
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+192−58
@@ -1,23 +1,24 @@
1−{-# LANGUAGE CPP #-}
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE ConstraintKinds #-}
3+{-# LANGUAGE CPP #-}
3{-# LANGUAGE DataKinds #-}
4{-# LANGUAGE DataKinds #-}
4{-# LANGUAGE DeriveDataTypeable #-}
5{-# LANGUAGE DeriveDataTypeable #-}
5{-# LANGUAGE FlexibleContexts #-}
6{-# LANGUAGE FlexibleContexts #-}
6{-# LANGUAGE FlexibleInstances #-}
7{-# LANGUAGE FlexibleInstances #-}
8+{-# LANGUAGE InstanceSigs #-}
9+{-# LANGUAGE LambdaCase #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
10{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE OverloadedStrings #-}
11{-# LANGUAGE OverloadedStrings #-}
9{-# LANGUAGE PolyKinds #-}
12{-# LANGUAGE PolyKinds #-}
13+{-# LANGUAGE QuantifiedConstraints #-}
10{-# LANGUAGE RankNTypes #-}
14{-# LANGUAGE RankNTypes #-}
11{-# LANGUAGE ScopedTypeVariables #-}
15{-# LANGUAGE ScopedTypeVariables #-}
12{-# LANGUAGE TupleSections #-}
16{-# LANGUAGE TupleSections #-}
17+{-# LANGUAGE TypeApplications #-}
13{-# LANGUAGE TypeFamilies #-}
18{-# LANGUAGE TypeFamilies #-}
14{-# LANGUAGE TypeOperators #-}
19{-# LANGUAGE TypeOperators #-}
15{-# LANGUAGE UndecidableInstances #-}
20{-# LANGUAGE UndecidableInstances #-}
16
21
17−#if MIN_VERSION_base(4,9,0) && __GLASGOW_HASKELL__ >= 802
18−#define HAS_TYPE_ERROR
19−#endif
20−
21module Servant.Server.Internal
22module Servant.Server.Internal
22 ( module Servant.Server.Internal
23 ( module Servant.Server.Internal
23 , module Servant.Server.Internal.BasicAuth
24 , module Servant.Server.Internal.BasicAuth
@@ -35,19 +36,19 @@ module Servant.Server.Internal
35import Control.Monad
36import Control.Monad
36 (join, when)
37 (join, when)
37import Control.Monad.Trans
38import Control.Monad.Trans
38− (liftIO)
39+ (liftIO, lift)
39import Control.Monad.Trans.Resource
40import Control.Monad.Trans.Resource
40− (runResourceT)
41+ (runResourceT, ReleaseKey)
42+import Data.Acquire
41import qualified Data.ByteString as B
43import qualified Data.ByteString as B
42import qualified Data.ByteString.Builder as BB
44import qualified Data.ByteString.Builder as BB
43import qualified Data.ByteString.Char8 as BC8
45import qualified Data.ByteString.Char8 as BC8
44import qualified Data.ByteString.Lazy as BL
46import qualified Data.ByteString.Lazy as BL
47+import Data.Constraint (Constraint, Dict(..))
45import Data.Either
48import Data.Either
46 (partitionEithers)
49 (partitionEithers)
47import Data.Maybe
50import Data.Maybe
48 (fromMaybe, isNothing, mapMaybe, maybeToList)
51 (fromMaybe, isNothing, mapMaybe, maybeToList)
49−import Data.Semigroup
50− ((<>))
51import Data.String
52import Data.String
52 (IsString (..))
53 (IsString (..))
53import Data.String.Conversions
54import Data.String.Conversions
@@ -56,15 +57,16 @@ import Data.Tagged
56 (Tagged (..), retag, untag)
57 (Tagged (..), retag, untag)
57import qualified Data.Text as T
58import qualified Data.Text as T
58import Data.Typeable
59import Data.Typeable
60+import GHC.Generics
59import GHC.TypeLits
61import GHC.TypeLits
60− (KnownNat, KnownSymbol, natVal, symbolVal)
62+ (KnownNat, KnownSymbol, TypeError, symbolVal)
61import qualified Network.HTTP.Media as NHM
63import qualified Network.HTTP.Media as NHM
62import Network.HTTP.Types hiding
64import Network.HTTP.Types hiding
63 (Header, ResponseHeaders)
65 (Header, ResponseHeaders)
64import Network.Socket
66import Network.Socket
65 (SockAddr)
67 (SockAddr)
66import Network.Wai
68import Network.Wai
67− (Application, Request, httpVersion, isSecure, lazyRequestBody,
69+ (Application, Request, Response, ResponseReceived, httpVersion, isSecure, lazyRequestBody,
68 queryString, remoteHost, getRequestBodyChunk, requestHeaders,
70 queryString, remoteHost, getRequestBodyChunk, requestHeaders,
69 requestMethod, responseLBS, responseStream, vault)
71 requestMethod, responseLBS, responseStream, vault)
70import Prelude ()
72import Prelude ()
@@ -74,10 +76,11 @@ import Servant.API
74 CaptureAll, Description, EmptyAPI, Fragment,
76 CaptureAll, Description, EmptyAPI, Fragment,
75 FramingRender (..), FramingUnrender (..), FromSourceIO (..),
77 FramingRender (..), FramingUnrender (..), FromSourceIO (..),
76 Header', If, IsSecure (..), NoContentVerb, QueryFlag,
78 Header', If, IsSecure (..), NoContentVerb, QueryFlag,
77− QueryParam', QueryParams, Raw, ReflectMethod (reflectMethod),
79+ QueryParam', QueryParams, Raw, RawM, ReflectMethod (reflectMethod),
78 RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO,
80 RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO,
79 Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb,
81 Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb,
80− WithNamedContext)
82+ WithNamedContext, WithResource, NamedRoutes)
83+import Servant.API.Generic (GenericMode(..), ToServant, ToServantApi, GServantProduct, toServant, fromServant)
81import Servant.API.ContentTypes
84import Servant.API.ContentTypes
82 (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),
85 (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),
83 AllMime, MimeRender (..), MimeUnrender (..), NoContent,
86 AllMime, MimeRender (..), MimeUnrender (..), NoContent,
@@ -87,10 +90,15 @@ import Servant.API.Modifiers
87 unfoldRequestArgument)
90 unfoldRequestArgument)
88import Servant.API.ResponseHeaders
91import Servant.API.ResponseHeaders
89 (GetHeaders, Headers, getHeaders, getResponse)
92 (GetHeaders, Headers, getHeaders, getResponse)
93+import Servant.API.Status
94+ (statusFromNat)
90import qualified Servant.Types.SourceT as S
95import qualified Servant.Types.SourceT as S
96+import Servant.API.TypeErrors
91import Web.HttpApiData
97import Web.HttpApiData
92 (FromHttpApiData, parseHeader, parseQueryParam, parseUrlPiece,
98 (FromHttpApiData, parseHeader, parseQueryParam, parseUrlPiece,
93 parseUrlPieces)
99 parseUrlPieces)
100+import Data.Kind
101+ (Type)
94
102
95import Servant.Server.Internal.BasicAuth
103import Servant.Server.Internal.BasicAuth
96import Servant.Server.Internal.Context
104import Servant.Server.Internal.Context
@@ -103,14 +111,16 @@ import Servant.Server.Internal.RouteResult
103import Servant.Server.Internal.RoutingApplication
111import Servant.Server.Internal.RoutingApplication
104import Servant.Server.Internal.ServerError
112import Servant.Server.Internal.ServerError
105
113
106−#ifdef HAS_TYPE_ERROR
107import GHC.TypeLits
114import GHC.TypeLits
108 (ErrorMessage (..), TypeError)
115 (ErrorMessage (..), TypeError)
109import Servant.API.TypeLevel
116import Servant.API.TypeLevel
110 (AtLeastOneFragment, FragmentUnique)
117 (AtLeastOneFragment, FragmentUnique)
111−#endif
112
118
113class HasServer api context where
119class HasServer api context where
120+ -- | The type of a server for this API, given a monad to run effects in.
121+ --
122+ -- Note that the result kind is @*@, so it is /not/ a monad transformer, unlike
123+ -- what the @T@ in the name might suggest.
114 type ServerT api (m :: * -> *) :: *
124 type ServerT api (m :: * -> *) :: *
115
125
116 route ::
126 route ::
@@ -172,7 +182,7 @@ instance (HasServer a context, HasServer b context) => HasServer (a :<|> b) cont
172-- > server = getBook
182-- > server = getBook
173-- > where getBook :: Text -> Handler Book
183-- > where getBook :: Text -> Handler Book
174-- > getBook isbn = ...
184-- > getBook isbn = ...
175−instance (KnownSymbol capture, FromHttpApiData a
185+instance (KnownSymbol capture, FromHttpApiData a, Typeable a
176 , HasServer api context, SBoolI (FoldLenient mods)
186 , HasServer api context, SBoolI (FoldLenient mods)
177 , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
187 , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
178 )
188 )
@@ -184,7 +194,7 @@ instance (KnownSymbol capture, FromHttpApiData a
184 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
194 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
185
195
186 route Proxy context d =
196 route Proxy context d =
187− CaptureRouter $
197+ CaptureRouter [hint] $
188 route (Proxy :: Proxy api)
198 route (Proxy :: Proxy api)
189 context
199 context
190 (addCapture d $ \ txt -> withRequest $ \ request ->
200 (addCapture d $ \ txt -> withRequest $ \ request ->
@@ -196,6 +206,7 @@ instance (KnownSymbol capture, FromHttpApiData a
196 where
206 where
197 rep = typeRep (Proxy :: Proxy Capture')
207 rep = typeRep (Proxy :: Proxy Capture')
198 formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
208 formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
209+ hint = CaptureHint (T.pack $ symbolVal $ Proxy @capture) (typeRep (Proxy :: Proxy a))
199
210
200-- | If you use 'CaptureAll' in one of the endpoints for your API,
211-- | If you use 'CaptureAll' in one of the endpoints for your API,
201-- this automatically requires your server-side handler to be a
212-- this automatically requires your server-side handler to be a
@@ -214,7 +225,7 @@ instance (KnownSymbol capture, FromHttpApiData a
214-- > server = getSourceFile
225-- > server = getSourceFile
215-- > where getSourceFile :: [Text] -> Handler Book
226-- > where getSourceFile :: [Text] -> Handler Book
216-- > getSourceFile pathSegments = ...
227-- > getSourceFile pathSegments = ...
217−instance (KnownSymbol capture, FromHttpApiData a
228+instance (KnownSymbol capture, FromHttpApiData a, Typeable a
218 , HasServer api context
229 , HasServer api context
219 , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
230 , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
220 )
231 )
@@ -226,7 +237,7 @@ instance (KnownSymbol capture, FromHttpApiData a
226 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
237 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
227
238
228 route Proxy context d =
239 route Proxy context d =
229− CaptureAllRouter $
240+ CaptureAllRouter [hint] $
230 route (Proxy :: Proxy api)
241 route (Proxy :: Proxy api)
231 context
242 context
232 (addCapture d $ \ txts -> withRequest $ \ request ->
243 (addCapture d $ \ txts -> withRequest $ \ request ->
@@ -237,6 +248,43 @@ instance (KnownSymbol capture, FromHttpApiData a
237 where
248 where
238 rep = typeRep (Proxy :: Proxy CaptureAll)
249 rep = typeRep (Proxy :: Proxy CaptureAll)
239 formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
250 formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
251+ hint = CaptureHint (T.pack $ symbolVal $ Proxy @capture) (typeRep (Proxy :: Proxy [a]))
252+
253+-- | If you use 'WithResource' in one of the endpoints for your API Servant
254+-- will provide the handler for this endpoint an argument of the specified type.
255+-- The lifespan of this resource will be automatically managed by Servant. This
256+-- resource will be created before the handler starts and it will be destoyed
257+-- after it ends. A new resource is created for each request to the endpoint.
258+
259+-- The creation and destruction are done using a 'Data.Acquire.Acquire'
260+-- provided via server 'Context'.
261+--
262+-- Example
263+--
264+-- > type MyApi = WithResource Handle :> "writeToFile" :> Post '[JSON] NoContent
265+-- >
266+-- > server :: Server MyApi
267+-- > server = writeToFile
268+-- > where writeToFile :: (ReleaseKey, Handle) -> Handler NoContent
269+-- > writeToFile (_, h) = hPutStrLn h "message"
270+--
271+-- In addition to the resource, the handler will also receive a 'ReleaseKey'
272+-- which can be used to deallocate the resource before the end of the request
273+-- if desired.
274+
275+instance (HasServer api ctx, HasContextEntry ctx (Acquire a))
276+ => HasServer (WithResource a :> api) ctx where
277+
278+ type ServerT (WithResource a :> api) m = (ReleaseKey, a) -> ServerT api m
279+
280+ hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy @api) pc nt . s
281+
282+ route Proxy context d = route (Proxy @api) context (d `addParameterCheck` allocateResource)
283+ where
284+ allocateResource :: DelayedIO (ReleaseKey, a)
285+ allocateResource = DelayedIO $ lift $ allocateAcquire (getContextEntry context)
286+
287+
240
288
241allowedMethodHead :: Method -> Request -> Bool
289allowedMethodHead :: Method -> Request -> Bool
242allowedMethodHead method request = method == methodGet && requestMethod request == methodHead
290allowedMethodHead method request = method == methodGet && requestMethod request == methodHead
@@ -300,7 +348,7 @@ instance {-# OVERLAPPABLE #-}
300
348
301 route Proxy _ = methodRouter ([],) method (Proxy :: Proxy ctypes) status
349 route Proxy _ = methodRouter ([],) method (Proxy :: Proxy ctypes) status
302 where method = reflectMethod (Proxy :: Proxy method)
350 where method = reflectMethod (Proxy :: Proxy method)
303− status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
351+ status = statusFromNat (Proxy :: Proxy status)
304
352
305instance {-# OVERLAPPING #-}
353instance {-# OVERLAPPING #-}
306 ( AllCTRender ctypes a, ReflectMethod method, KnownNat status
354 ( AllCTRender ctypes a, ReflectMethod method, KnownNat status
@@ -312,7 +360,7 @@ instance {-# OVERLAPPING #-}
312
360
313 route Proxy _ = methodRouter (\x -> (getHeaders x, getResponse x)) method (Proxy :: Proxy ctypes) status
361 route Proxy _ = methodRouter (\x -> (getHeaders x, getResponse x)) method (Proxy :: Proxy ctypes) status
314 where method = reflectMethod (Proxy :: Proxy method)
362 where method = reflectMethod (Proxy :: Proxy method)
315− status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
363+ status = statusFromNat (Proxy :: Proxy status)
316
364
317instance (ReflectMethod method) =>
365instance (ReflectMethod method) =>
318 HasServer (NoContentVerb method) context where
366 HasServer (NoContentVerb method) context where
@@ -333,7 +381,7 @@ instance {-# OVERLAPPABLE #-}
333
381
334 route Proxy _ = streamRouter ([],) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)
382 route Proxy _ = streamRouter ([],) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)
335 where method = reflectMethod (Proxy :: Proxy method)
383 where method = reflectMethod (Proxy :: Proxy method)
336− status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
384+ status = statusFromNat (Proxy :: Proxy status)
337
385
338
386
339instance {-# OVERLAPPING #-}
387instance {-# OVERLAPPING #-}
@@ -347,7 +395,7 @@ instance {-# OVERLAPPING #-}
347
395
348 route Proxy _ = streamRouter (\x -> (getHeaders x, getResponse x)) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)
396 route Proxy _ = streamRouter (\x -> (getHeaders x, getResponse x)) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)
349 where method = reflectMethod (Proxy :: Proxy method)
397 where method = reflectMethod (Proxy :: Proxy method)
350− status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
398+ status = statusFromNat (Proxy :: Proxy status)
351
399
352
400
353streamRouter :: forall ctype a c chunk env framing. (MimeRender ctype chunk, FramingRender framing, ToSourceIO chunk a) =>
401streamRouter :: forall ctype a c chunk env framing. (MimeRender ctype chunk, FramingRender framing, ToSourceIO chunk a) =>
@@ -605,6 +653,35 @@ instance HasServer Raw context where
605 Fail a -> respond $ Fail a
653 Fail a -> respond $ Fail a
606 FailFatal e -> respond $ FailFatal e
654 FailFatal e -> respond $ FailFatal e
607
655
656+-- | Just pass the request to the underlying application and serve its response.
657+--
658+-- Example:
659+--
660+-- > type MyApi = "images" :> Raw
661+-- >
662+-- > server :: Server MyApi
663+-- > server = serveDirectory "/var/www/images"
664+instance HasServer RawM context where
665+ type ServerT RawM m = Request -> (Response -> IO ResponseReceived) -> m ResponseReceived
666+
667+ route
668+ :: Proxy RawM
669+ -> Context context
670+ -> Delayed env (Request -> (Response -> IO ResponseReceived) -> Handler ResponseReceived) -> Router env
671+ route _ _ handleDelayed = RawRouter $ \env request respond -> runResourceT $ do
672+ routeResult <- runDelayed handleDelayed env request
673+ let respond' = liftIO . respond
674+ liftIO $ case routeResult of
675+ Route handler -> runHandler (handler request (respond . Route)) >>=
676+ \case
677+ Left e -> respond' $ FailFatal e
678+ Right a -> pure a
679+ Fail e -> respond' $ Fail e
680+ FailFatal e -> respond' $ FailFatal e
681+
682+ hoistServerWithContext _ _ f srvM = \req respond -> f (srvM req respond)
683+
684+
608-- | If you use 'ReqBody' in one of the endpoints for your API,
685-- | If you use 'ReqBody' in one of the endpoints for your API,
609-- this automatically requires your server-side handler to be a function
686-- this automatically requires your server-side handler to be a function
610-- that takes an argument of the type specified by 'ReqBody'.
687-- that takes an argument of the type specified by 'ReqBody'.
@@ -786,7 +863,7 @@ instance ( KnownSymbol realm
786-- * helpers
863-- * helpers
787
864
788ct_wildcard :: B.ByteString
865ct_wildcard :: B.ByteString
789−ct_wildcard = "*" <> "/" <> "*" -- Because CPP
866+ct_wildcard = "*" <> "/" <> "*"
790
867
791getAcceptHeader :: Request -> AcceptHeader
868getAcceptHeader :: Request -> AcceptHeader
792getAcceptHeader = AcceptHeader . fromMaybe ct_wildcard . lookup hAccept . requestHeaders
869getAcceptHeader = AcceptHeader . fromMaybe ct_wildcard . lookup hAccept . requestHeaders
@@ -814,39 +891,19 @@ instance (HasContextEntry context (NamedContext name subContext), HasServer subA
814 hoistServerWithContext _ _ nt s = hoistServerWithContext (Proxy :: Proxy subApi) (Proxy :: Proxy subContext) nt s
891 hoistServerWithContext _ _ nt s = hoistServerWithContext (Proxy :: Proxy subApi) (Proxy :: Proxy subContext) nt s
815
892
816-------------------------------------------------------------------------------
893-------------------------------------------------------------------------------
817−-- TypeError helpers
894+-- Custom type errors
818-------------------------------------------------------------------------------
895-------------------------------------------------------------------------------
819
896
820−#ifdef HAS_TYPE_ERROR
897+-- Erroring instance for 'HasServer' when a combinator is not fully applied
821−-- | This instance catches mistakes when there are non-saturated
898+instance TypeError (PartialApplication
822−-- type applications on LHS of ':>'.
899+#if __GLASGOW_HASKELL__ >= 904
823−--
900+ @(Type -> [Type] -> Constraint)
824−-- >>> serve (Proxy :: Proxy (Capture "foo" :> Get '[JSON] Int)) (error "...")
901+#endif
825−-- ...
826−-- ...Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'.
827−-- ...Maybe you haven't applied enough arguments to
828−-- ...Capture' '[] "foo"
829−-- ...
830−--
831−-- >>> undefined :: Server (Capture "foo" :> Get '[JSON] Int)
832−-- ...
833−-- ...Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'.
834−-- ...Maybe you haven't applied enough arguments to
835−-- ...Capture' '[] "foo"
836−-- ...
837−--
838−instance TypeError (HasServerArrowKindError arr) => HasServer ((arr :: k -> l) :> api) context
902+ HasServer arr) => HasServer ((arr :: a -> b) :> sub) context
839 where
903 where
840− type ServerT (arr :> api) m = TypeError (HasServerArrowKindError arr)
904+ type ServerT (arr :> sub) _ = TypeError (PartialApplication (HasServer :: * -> [*] -> Constraint) arr)
841− -- it doesn't really matter what sub route we peak
905+ route = error "unreachable"
842− route _ _ _ = error "servant-server panic: impossible happened in HasServer (arr :> api)"
843− hoistServerWithContext _ _ _ = id
906+ hoistServerWithContext _ _ _ _ = error "unreachable"
844−
845−-- Cannot have TypeError here, otherwise use of this symbol will error :)
846−type HasServerArrowKindError arr =
847− 'Text "Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'."
848− ':$$: 'Text "Maybe you haven't applied enough arguments to"
849− ':$$: 'ShowType arr
850
907
851-- | This instance prevents from accidentally using '->' instead of ':>'
908-- | This instance prevents from accidentally using '->' instead of ':>'
852--
909--
@@ -880,7 +937,19 @@ type HasServerArrowTypeError a b =
880 ':$$: 'ShowType a
937 ':$$: 'ShowType a
881 ':$$: 'Text "and"
938 ':$$: 'Text "and"
882 ':$$: 'ShowType b
939 ':$$: 'ShowType b
940+
941+-- Erroring instances for 'HasServer' for unknown API combinators
942+
943+-- XXX: This omits the @context@ parameter, e.g.:
944+--
945+-- "There is no instance for HasServer (Bool :> …)". Do we care ?
946+instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub
947+#if __GLASGOW_HASKELL__ >= 904
948+ @(Type -> [Type] -> Constraint)
883#endif
949#endif
950+ HasServer ty) => HasServer (ty :> sub) context
951+
952+instance {-# OVERLAPPABLE #-} TypeError (NoInstanceFor (HasServer api context)) => HasServer api context
884
953
885-- | Ignore @'Fragment'@ in server handlers.
954-- | Ignore @'Fragment'@ in server handlers.
886-- See <https://ietf.org/rfc/rfc2616.html#section-15.1.3> for more details.
955-- See <https://ietf.org/rfc/rfc2616.html#section-15.1.3> for more details.
@@ -893,11 +962,7 @@ type HasServerArrowTypeError a b =
893-- > server = getBooks
962-- > server = getBooks
894-- > where getBooks :: Handler [Book]
963-- > where getBooks :: Handler [Book]
895-- > getBooks = ...return all books...
964-- > getBooks = ...return all books...
896−#ifdef HAS_TYPE_ERROR
897instance (AtLeastOneFragment api, FragmentUnique (Fragment a1 :> api), HasServer api context)
965instance (AtLeastOneFragment api, FragmentUnique (Fragment a1 :> api), HasServer api context)
898−#else
899−instance (HasServer api context)
900−#endif
901 => HasServer (Fragment a1 :> api) context where
966 => HasServer (Fragment a1 :> api) context where
902 type ServerT (Fragment a1 :> api) m = ServerT api m
967 type ServerT (Fragment a1 :> api) m = ServerT api m
903
968
@@ -907,3 +972,72 @@ instance (HasServer api context)
907
972
908-- $setup
973-- $setup
909-- >>> import Servant
974-- >>> import Servant
975+
976+-- | A type that specifies that an API record contains a server implementation.
977+data AsServerT (m :: * -> *)
978+instance GenericMode (AsServerT m) where
979+ type AsServerT m :- api = ServerT api m
980+
981+type AsServer = AsServerT Handler
982+
983+
984+-- | Set of constraints required to convert to / from vanilla server types.
985+type GServerConstraints api m =
986+ ( ToServant api (AsServerT m) ~ ServerT (ToServantApi api) m
987+ , GServantProduct (Rep (api (AsServerT m)))
988+ )
989+
990+-- | This class is a necessary evil: in the implementation of 'HasServer' for
991+-- @'NamedRoutes' api@, we essentially need the quantified constraint @forall
992+-- m. 'GServerConstraints' m@ to hold.
993+--
994+-- We cannot require do that directly as the definition of 'GServerConstraints'
995+-- contains type family applications ('Rep' and 'ServerT'). The trick is to hide
996+-- those type family applications behind a typeclass providing evidence for
997+-- @'GServerConstraints' api m@ in the form of a dictionary, and require that
998+-- @forall m. 'GServer' api m@ instead.
999+--
1000+-- Users shouldn't have to worry about this class, as the only possible instance
1001+-- is provided in this module for all record APIs.
1002+
1003+class GServer (api :: * -> *) (m :: * -> *) where
1004+ gServerProof :: Dict (GServerConstraints api m)
1005+
1006+instance
1007+ ( ToServant api (AsServerT m) ~ ServerT (ToServantApi api) m
1008+ , GServantProduct (Rep (api (AsServerT m)))
1009+ ) => GServer api m where
1010+ gServerProof = Dict
1011+
1012+instance
1013+ ( HasServer (ToServantApi api) context
1014+ , forall m. Generic (api (AsServerT m))
1015+ , forall m. GServer api m
1016+ ) => HasServer (NamedRoutes api) context where
1017+
1018+ type ServerT (NamedRoutes api) m = api (AsServerT m)
1019+
1020+ route
1021+ :: Proxy (NamedRoutes api)
1022+ -> Context context
1023+ -> Delayed env (api (AsServerT Handler))
1024+ -> Router env
1025+ route _ ctx delayed =
1026+ case gServerProof @api @Handler of
1027+ Dict -> route (Proxy @(ToServantApi api)) ctx (toServant <$> delayed)
1028+
1029+ hoistServerWithContext
1030+ :: forall m n. Proxy (NamedRoutes api)
1031+ -> Proxy context
1032+ -> (forall x. m x -> n x)
1033+ -> api (AsServerT m)
1034+ -> api (AsServerT n)
1035+ hoistServerWithContext _ pctx nat server =
1036+ case (gServerProof @api @m, gServerProof @api @n) of
1037+ (Dict, Dict) ->
1038+ fromServant servantSrvN
1039+ where
1040+ servantSrvM :: ServerT (ToServantApi api) m =
1041+ toServant server
1042+ servantSrvN :: ServerT (ToServantApi api) n =
1043+ hoistServerWithContext (Proxy @(ToServantApi api)) pctx nat servantSrvM
servant-server/src/Servant/Server/Internal/BasicAuth.hs−2
@@ -12,8 +12,6 @@ import Control.Monad.Trans
12import qualified Data.ByteString as BS
12import qualified Data.ByteString as BS
13import Data.ByteString.Base64
13import Data.ByteString.Base64
14 (decodeLenient)
14 (decodeLenient)
15−import Data.Monoid
16− ((<>))
17import Data.Typeable
15import Data.Typeable
18 (Typeable)
16 (Typeable)
19import Data.Word8
17import Data.Word8
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+50−15
@@ -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,21 @@ import Servant.Server.Internal.ServerError
24
28
25type Router env = Router' env RoutingApplication
29type Router env = Router' env RoutingApplication
26
30
31+-- | Holds information about pieces of url that are captured as variables.
32+data CaptureHint = CaptureHint
33+ { captureName :: Text
34+ -- ^ Holds the name of the captured variable
35+ , captureType :: TypeRep
36+ -- ^ Holds the type of the captured variable
37+ }
38+ deriving (Show, Eq)
39+
40+toCaptureTag :: CaptureHint -> Text
41+toCaptureTag hint = captureName hint <> "::" <> (T.pack . show) (captureType hint)
42+
43+toCaptureTags :: [CaptureHint] -> Text
44+toCaptureTags hints = "<" <> T.intercalate "|" (map toCaptureTag hints) <> ">"
45+
27-- | Internal representation of a router.
46-- | Internal representation of a router.
28--
47--
29-- The first argument describes an environment type that is
48-- The first argument describes an environment type that is
@@ -36,12 +55,23 @@ data Router' env a =
36 -- ^ the map contains routers for subpaths (first path component used
55 -- ^ the map contains routers for subpaths (first path component used
37 -- for lookup and removed afterwards), the list contains handlers
56 -- for lookup and removed afterwards), the list contains handlers
38 -- for the empty path, to be tried in order
57 -- for the empty path, to be tried in order
39− | CaptureRouter (Router' (Text, env) a)
58+ | CaptureRouter [CaptureHint] (Router' (Text, env) a)
40 -- ^ first path component is passed to the child router in its
59 -- ^ first path component is passed to the child router in its
41− -- environment and removed afterwards
60+ -- environment and removed afterwards.
61+ -- The first argument is a list of hints for all variables that can be
62+ -- captured by the router. The fact that it is a list is counter-intuitive,
63+ -- because the 'Capture' combinator only allows to capture a single varible,
64+ -- with a single name and a single type. However, the 'choice' smart
65+ -- constructor may merge two 'Capture' combinators with different hints, thus
66+ -- forcing the type to be '[CaptureHint]'.
67+ -- Because 'CaptureRouter' is built from a 'Capture' combinator, the list of
68+ -- hints should always be non-empty.
42− | CaptureAllRouter (Router' ([Text], env) a)
69+ | CaptureAllRouter [CaptureHint] (Router' ([Text], env) a)
43 -- ^ all path components are passed to the child router in its
70 -- ^ all path components are passed to the child router in its
44 -- environment and are removed afterwards
71 -- environment and are removed afterwards
72+ -- The first argument is a hint for the list of variables that can be
73+ -- captured by the router. Note that the 'captureType' field of the hint
74+ -- should always be '[a]' for some 'a'.
45 | RawRouter (env -> a)
75 | RawRouter (env -> a)
46 -- ^ to be used for routes we do not know anything about
76 -- ^ to be used for routes we do not know anything about
47 | Choice (Router' env a) (Router' env a)
77 | Choice (Router' env a) (Router' env a)
@@ -69,8 +99,8 @@ leafRouter l = StaticRouter M.empty [l]
69choice :: Router' env a -> Router' env a -> Router' env a
99choice :: Router' env a -> Router' env a -> Router' env a
70choice (StaticRouter table1 ls1) (StaticRouter table2 ls2) =
100choice (StaticRouter table1 ls1) (StaticRouter table2 ls2) =
71 StaticRouter (M.unionWith choice table1 table2) (ls1 ++ ls2)
101 StaticRouter (M.unionWith choice table1 table2) (ls1 ++ ls2)
72−choice (CaptureRouter router1) (CaptureRouter router2) =
102+choice (CaptureRouter hints1 router1) (CaptureRouter hints2 router2) =
73− CaptureRouter (choice router1 router2)
103+ CaptureRouter (nub $ hints1 ++ hints2) (choice router1 router2)
74choice router1 (Choice router2 router3) = Choice (choice router1 router2) router3
104choice router1 (Choice router2 router3) = Choice (choice router1 router2) router3
75choice router1 router2 = Choice router1 router2
105choice router1 router2 = Choice router1 router2
76
106
@@ -84,7 +114,11 @@ choice router1 router2 = Choice router1 router2
84--
114--
85data RouterStructure =
115data RouterStructure =
86 StaticRouterStructure (Map Text RouterStructure) Int
116 StaticRouterStructure (Map Text RouterStructure) Int
87− | CaptureRouterStructure RouterStructure
117+ | CaptureRouterStructure [CaptureHint] RouterStructure
118+ -- ^ The first argument holds information about variables
119+ -- that are captured by the router. There may be several hints
120+ -- if several routers have been aggregated by the 'choice'
121+ -- smart constructor.
88 | RawRouterStructure
122 | RawRouterStructure
89 | ChoiceStructure RouterStructure RouterStructure
123 | ChoiceStructure RouterStructure RouterStructure
90 deriving (Eq, Show)
124 deriving (Eq, Show)
@@ -98,11 +132,11 @@ data RouterStructure =
98routerStructure :: Router' env a -> RouterStructure
132routerStructure :: Router' env a -> RouterStructure
99routerStructure (StaticRouter m ls) =
133routerStructure (StaticRouter m ls) =
100 StaticRouterStructure (fmap routerStructure m) (length ls)
134 StaticRouterStructure (fmap routerStructure m) (length ls)
101−routerStructure (CaptureRouter router) =
135+routerStructure (CaptureRouter hints router) =
102− CaptureRouterStructure $
136+ CaptureRouterStructure hints $
103 routerStructure router
137 routerStructure router
104−routerStructure (CaptureAllRouter router) =
138+routerStructure (CaptureAllRouter hints router) =
105− CaptureRouterStructure $
139+ CaptureRouterStructure hints $
106 routerStructure router
140 routerStructure router
107routerStructure (RawRouter _) =
141routerStructure (RawRouter _) =
108 RawRouterStructure
142 RawRouterStructure
@@ -114,8 +148,8 @@ routerStructure (Choice r1 r2) =
114-- | Compare the structure of two routers.
148-- | Compare the structure of two routers.
115--
149--
116sameStructure :: Router' env a -> Router' env b -> Bool
150sameStructure :: Router' env a -> Router' env b -> Bool
117−sameStructure r1 r2 =
151+sameStructure router1 router2 =
118− routerStructure r1 == routerStructure r2
152+ routerStructure router1 == routerStructure router2
119
153
120-- | Provide a textual representation of the
154-- | Provide a textual representation of the
121-- structure of a router.
155-- structure of a router.
@@ -126,7 +160,8 @@ routerLayout router =
126 where
160 where
127 mkRouterLayout :: Bool -> RouterStructure -> [Text]
161 mkRouterLayout :: Bool -> RouterStructure -> [Text]
128 mkRouterLayout c (StaticRouterStructure m n) = mkSubTrees c (M.toList m) n
162 mkRouterLayout c (StaticRouterStructure m n) = mkSubTrees c (M.toList m) n
129− mkRouterLayout c (CaptureRouterStructure r) = mkSubTree c "<capture>" (mkRouterLayout False r)
163+ mkRouterLayout c (CaptureRouterStructure hints r) =
164+ mkSubTree c (toCaptureTags hints) (mkRouterLayout False r)
130 mkRouterLayout c RawRouterStructure =
165 mkRouterLayout c RawRouterStructure =
131 if c then ["├─ <raw>"] else ["└─ <raw>"]
166 if c then ["├─ <raw>"] else ["└─ <raw>"]
132 mkRouterLayout c (ChoiceStructure r1 r2) =
167 mkRouterLayout c (ChoiceStructure r1 r2) =
@@ -169,7 +204,7 @@ runRouterEnv fmt router env request respond =
169 -> let request' = request { pathInfo = rest }
204 -> let request' = request { pathInfo = rest }
170 in runRouterEnv fmt router' env request' respond
205 in runRouterEnv fmt router' env request' respond
171 _ -> respond $ Fail $ fmt request
206 _ -> respond $ Fail $ fmt request
172− CaptureRouter router' ->
207+ CaptureRouter _ router' ->
173 case pathInfo request of
208 case pathInfo request of
174 [] -> respond $ Fail $ fmt request
209 [] -> respond $ Fail $ fmt request
175 -- This case is to handle trailing slashes.
210 -- This case is to handle trailing slashes.
@@ -177,7 +212,7 @@ runRouterEnv fmt router env request respond =
177 first : rest
212 first : rest
178 -> let request' = request { pathInfo = rest }
213 -> let request' = request { pathInfo = rest }
179 in runRouterEnv fmt router' (first, env) request' respond
214 in runRouterEnv fmt router' (first, env) request' respond
180− CaptureAllRouter router' ->
215+ CaptureAllRouter _ router' ->
181 let segments = pathInfo request
216 let segments = pathInfo request
182 request' = request { pathInfo = [] }
217 request' = request { pathInfo = [] }
183 in runRouterEnv fmt router' (segments, env) request' respond
218 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/ErrorSpec.hs−2
@@ -12,8 +12,6 @@ import Data.Aeson
12 (encode)
12 (encode)
13import qualified Data.ByteString.Char8 as BC
13import qualified Data.ByteString.Char8 as BC
14import qualified Data.ByteString.Lazy.Char8 as BCL
14import qualified Data.ByteString.Lazy.Char8 as BCL
15−import Data.Monoid
16− ((<>))
17import Data.Proxy
15import Data.Proxy
18import Data.String.Conversions
16import Data.String.Conversions
19 (cs)
17 (cs)
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-server/test/Servant/ServerSpec.hs+57−10
@@ -7,6 +7,7 @@
7{-# LANGUAGE ScopedTypeVariables #-}
7{-# LANGUAGE ScopedTypeVariables #-}
8{-# LANGUAGE TypeFamilies #-}
8{-# LANGUAGE TypeFamilies #-}
9{-# LANGUAGE TypeOperators #-}
9{-# LANGUAGE TypeOperators #-}
10+{-# LANGUAGE TypeApplications #-}
10{-# OPTIONS_GHC -freduction-depth=100 #-}
11{-# OPTIONS_GHC -freduction-depth=100 #-}
11
12
12module Servant.ServerSpec where
13module Servant.ServerSpec where
@@ -16,10 +17,14 @@ import Prelude.Compat
16
17
17import Control.Monad
18import Control.Monad
18 (forM_, unless, when)
19 (forM_, unless, when)
20+import Control.Monad.Reader (runReaderT, ask)
19import Control.Monad.Error.Class
21import Control.Monad.Error.Class
20 (MonadError (..))
22 (MonadError (..))
23+import Control.Monad.IO.Class (MonadIO(..))
21import Data.Aeson
24import Data.Aeson
22 (FromJSON, ToJSON, decode', encode)
25 (FromJSON, ToJSON, decode', encode)
26+import Data.Acquire
27+ (Acquire, mkAcquire)
23import qualified Data.ByteString as BS
28import qualified Data.ByteString as BS
24import qualified Data.ByteString.Base64 as Base64
29import qualified Data.ByteString.Base64 as Base64
25import Data.Char
30import Data.Char
@@ -28,8 +33,6 @@ import Data.Maybe
28 (fromMaybe)
33 (fromMaybe)
29import Data.Proxy
34import Data.Proxy
30 (Proxy (Proxy))
35 (Proxy (Proxy))
31−import Data.SOP
32− (I (..), NS (..))
33import Data.String
36import Data.String
34 (fromString)
37 (fromString)
35import Data.String.Conversions
38import Data.String.Conversions
@@ -53,19 +56,19 @@ import Servant.API
53 Delete, EmptyAPI, Fragment, Get, HasStatus (StatusOf), Header,
56 Delete, EmptyAPI, Fragment, Get, HasStatus (StatusOf), Header,
54 Headers, HttpVersion, IsSecure (..), JSON, Lenient,
57 Headers, HttpVersion, IsSecure (..), JSON, Lenient,
55 NoContent (..), NoContentVerb, NoFraming, OctetStream, Patch,
58 NoContent (..), NoContentVerb, NoFraming, OctetStream, Patch,
56− PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw,
59+ PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw, RawM,
57 RemoteHost, ReqBody, SourceIO, StdMethod (..), Stream, Strict,
60 RemoteHost, ReqBody, SourceIO, StdMethod (..), Stream, Strict,
58 UVerb, Union, Verb, WithStatus (..), addHeader)
61 UVerb, Union, Verb, WithStatus (..), addHeader)
59import Servant.Server
62import Servant.Server
60− (Context ((:.), EmptyContext), Handler, Server, Tagged (..),
63+ (Context ((:.), EmptyContext), Handler, Server, ServerT, Tagged (..),
61− emptyServer, err401, err403, err404, respond, serve,
64+ emptyServer, err401, err403, err404, hoistServer, respond, serve,
62 serveWithContext)
65 serveWithContext)
63import Servant.Test.ComprehensiveAPI
66import Servant.Test.ComprehensiveAPI
64import qualified Servant.Types.SourceT as S
67import qualified Servant.Types.SourceT as S
65import Test.Hspec
68import Test.Hspec
66 (Spec, context, describe, it, shouldBe, shouldContain)
69 (Spec, context, describe, it, shouldBe, shouldContain)
67import Test.Hspec.Wai
70import Test.Hspec.Wai
68− (get, liftIO, matchHeaders, matchStatus, shouldRespondWith,
71+ (get, matchHeaders, matchStatus, shouldRespondWith,
69 with, (<:>))
72 with, (<:>))
70import qualified Test.Hspec.Wai as THW
73import qualified Test.Hspec.Wai as THW
71
74
@@ -82,8 +85,11 @@ import Servant.Server.Internal.Context
82-- This declaration simply checks that all instances are in place.
85-- This declaration simply checks that all instances are in place.
83_ = serveWithContext comprehensiveAPI comprehensiveApiContext
86_ = serveWithContext comprehensiveAPI comprehensiveApiContext
84
87
85−comprehensiveApiContext :: Context '[NamedContext "foo" '[]]
88+comprehensiveApiContext :: Context '[NamedContext "foo" '[], Acquire Int]
89+comprehensiveApiContext =
86−comprehensiveApiContext = NamedContext EmptyContext :. EmptyContext
90+ NamedContext EmptyContext :.
91+ mkAcquire (pure 10) (\_ -> pure ()) :.
92+ EmptyContext
87
93
88-- * Specs
94-- * Specs
89
95
@@ -98,6 +104,7 @@ spec = do
98 reqBodySpec
104 reqBodySpec
99 headerSpec
105 headerSpec
100 rawSpec
106 rawSpec
107+ rawMSpec
101 alternativeSpec
108 alternativeSpec
102 responseHeadersSpec
109 responseHeadersSpec
103 uverbResponseHeadersSpec
110 uverbResponseHeadersSpec
@@ -606,6 +613,46 @@ rawSpec = do
606
613
607-- }}}
614-- }}}
608------------------------------------------------------------------------------
615------------------------------------------------------------------------------
616+-- * rawMSpec {{{
617+------------------------------------------------------------------------------
618+
619+type RawMApi = "foo" :> RawM
620+
621+rawMApi :: Proxy RawMApi
622+rawMApi = Proxy
623+
624+rawMServer :: (Monad m, MonadIO m, Show a) => (Request -> m a) -> ServerT RawMApi m
625+rawMServer f req resp = liftIO . resp . responseLBS ok200 [] . cs . show =<< f req
626+
627+rawMSpec :: Spec
628+rawMSpec = do
629+ describe "Servant.API.RawM" $ do
630+ it "gives access to monadic context" $ do
631+ flip runSession (serve rawMApi
632+ (hoistServer rawMApi (flip runReaderT (42 :: Integer)) (rawMServer (const ask)))) $ do
633+ response <- Network.Wai.Test.request defaultRequest{
634+ pathInfo = ["foo"]
635+ }
636+ liftIO $ do
637+ simpleBody response `shouldBe` "42"
638+
639+ it "lets users throw servant errors" $ do
640+ flip runSession (serve rawMApi (rawMServer (const $ throwError err404 >> pure (42 :: Integer)))) $ do
641+ response <- Network.Wai.Test.request defaultRequest{
642+ pathInfo = ["foo"]
643+ }
644+ liftIO $ do
645+ statusCode (simpleStatus response) `shouldBe` 404
646+
647+ it "gets the pathInfo modified" $ do
648+ flip runSession (serve rawMApi (rawMServer (pure . pathInfo))) $ do
649+ response <- Network.Wai.Test.request defaultRequest{
650+ pathInfo = ["foo", "bar"]
651+ }
652+ liftIO $ do
653+ simpleBody response `shouldBe` cs (show ["bar" :: String])
654+-- }}}
655+------------------------------------------------------------------------------
609-- * alternativeSpec {{{
656-- * alternativeSpec {{{
610------------------------------------------------------------------------------
657------------------------------------------------------------------------------
611type AlternativeApi =
658type AlternativeApi =
@@ -699,8 +746,8 @@ type UVerbResponseHeadersApi =
699 Capture "ok" Bool :> UVerb 'GET '[JSON] UVerbHeaderResponse
746 Capture "ok" Bool :> UVerb 'GET '[JSON] UVerbHeaderResponse
700
747
701uverbResponseHeadersServer :: Server UVerbResponseHeadersApi
748uverbResponseHeadersServer :: Server UVerbResponseHeadersApi
702−uverbResponseHeadersServer True = pure . Z . I . WithStatus $ addHeader 5 "foo"
749+uverbResponseHeadersServer True = respond . WithStatus @200 . addHeader @"H1" (5 :: Int) $ ("foo" :: String)
703−uverbResponseHeadersServer False = pure . S . Z . I . WithStatus $ "bar"
750+uverbResponseHeadersServer False = respond . WithStatus @404 $ ("bar" :: String)
704
751
705uverbResponseHeadersSpec :: Spec
752uverbResponseHeadersSpec :: Spec
706uverbResponseHeadersSpec = describe "UVerbResponseHeaders" $ do
753uverbResponseHeadersSpec = describe "UVerbResponseHeaders" $ do
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.11
110+ build-depends: base
111+ , base-compat
112+ , aeson >=1.4.2.0 && <3
113+ , hspec >=2.6.0 && <2.11
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+492
@@ -0,0 +1,492 @@
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+-- | @'WithResource'@ combinator does not change our specification at all.
308+instance (HasSwagger sub) => HasSwagger (WithResource res :> sub) where
309+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
310+
311+instance (KnownSymbol sym, HasSwagger sub) => HasSwagger (sym :> sub) where
312+ toSwagger _ = prependPath piece (toSwagger (Proxy :: Proxy sub))
313+ where
314+ piece = symbolVal (Proxy :: Proxy sym)
315+
316+instance (KnownSymbol sym, Typeable a, ToParamSchema a, HasSwagger sub, KnownSymbol (FoldDescription mods)) => HasSwagger (Capture' mods sym a :> sub) where
317+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
318+ & addParam param
319+ & prependPath capture
320+ & addDefaultResponse400 tname
321+ where
322+ symbol = symbolVal (Proxy :: Proxy sym)
323+ pname = if symbol == ""
324+ then camelTo2 '-' . tyConName . typeRepTyCon $ typeRep (Proxy :: Proxy a)
325+ else symbol
326+ tname = Text.pack pname
327+ transDesc "" = Nothing
328+ transDesc desc = Just (Text.pack desc)
329+ capture = "{" <> pname <> "}"
330+ param = mempty
331+ & name .~ tname
332+ & description .~ transDesc (reflectDescription (Proxy :: Proxy mods))
333+ & required ?~ True
334+ & schema .~ ParamOther (mempty
335+ & in_ .~ ParamPath
336+ & paramSchema .~ toParamSchema (Proxy :: Proxy a))
337+
338+-- | Swagger Spec doesn't have a notion of CaptureAll, this instance is the best effort.
339+instance (KnownSymbol sym, Typeable a, ToParamSchema a, HasSwagger sub) => HasSwagger (CaptureAll sym a :> sub) where
340+ toSwagger _ = toSwagger (Proxy :: Proxy (Capture sym a :> sub))
341+
342+instance (KnownSymbol desc, HasSwagger api) => HasSwagger (Description desc :> api) where
343+ toSwagger _ = toSwagger (Proxy :: Proxy api)
344+ & allOperations.description %~ (Just (Text.pack (symbolVal (Proxy :: Proxy desc))) <>)
345+
346+instance (KnownSymbol desc, HasSwagger api) => HasSwagger (Summary desc :> api) where
347+ toSwagger _ = toSwagger (Proxy :: Proxy api)
348+ & allOperations.summary %~ (Just (Text.pack (symbolVal (Proxy :: Proxy desc))) <>)
349+
350+instance (KnownSymbol sym, ToParamSchema a, HasSwagger sub, SBoolI (FoldRequired mods), KnownSymbol (FoldDescription mods)) => HasSwagger (QueryParam' mods sym a :> sub) where
351+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
352+ & addParam param
353+ & addDefaultResponse400 tname
354+ where
355+ tname = Text.pack (symbolVal (Proxy :: Proxy sym))
356+ transDesc "" = Nothing
357+ transDesc desc = Just (Text.pack desc)
358+ param = mempty
359+ & name .~ tname
360+ & description .~ transDesc (reflectDescription (Proxy :: Proxy mods))
361+ & required ?~ reflectBool (Proxy :: Proxy (FoldRequired mods))
362+ & schema .~ ParamOther sch
363+ sch = mempty
364+ & in_ .~ ParamQuery
365+ & paramSchema .~ toParamSchema (Proxy :: Proxy a)
366+
367+instance (KnownSymbol sym, ToParamSchema a, HasSwagger sub) => HasSwagger (QueryParams sym a :> sub) where
368+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
369+ & addParam param
370+ & addDefaultResponse400 tname
371+ where
372+ tname = Text.pack (symbolVal (Proxy :: Proxy sym))
373+ param = mempty
374+ & name .~ tname
375+ & schema .~ ParamOther sch
376+ sch = mempty
377+ & in_ .~ ParamQuery
378+ & paramSchema .~ pschema
379+ pschema = mempty
380+#if MIN_VERSION_swagger2(2,4,0)
381+ & type_ ?~ SwaggerArray
382+#else
383+ & type_ .~ SwaggerArray
384+#endif
385+ & items ?~ SwaggerItemsPrimitive (Just CollectionMulti) (toParamSchema (Proxy :: Proxy a))
386+
387+instance (KnownSymbol sym, HasSwagger sub) => HasSwagger (QueryFlag sym :> sub) where
388+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
389+ & addParam param
390+ & addDefaultResponse400 tname
391+ where
392+ tname = Text.pack (symbolVal (Proxy :: Proxy sym))
393+ param = mempty
394+ & name .~ tname
395+ & schema .~ ParamOther (mempty
396+ & in_ .~ ParamQuery
397+ & allowEmptyValue ?~ True
398+ & paramSchema .~ (toParamSchema (Proxy :: Proxy Bool)
399+ & default_ ?~ toJSON False))
400+
401+instance (KnownSymbol sym, ToParamSchema a, HasSwagger sub, SBoolI (FoldRequired mods), KnownSymbol (FoldDescription mods)) => HasSwagger (Header' mods sym a :> sub) where
402+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
403+ & addParam param
404+ & addDefaultResponse400 tname
405+ where
406+ tname = Text.pack (symbolVal (Proxy :: Proxy sym))
407+ transDesc "" = Nothing
408+ transDesc desc = Just (Text.pack desc)
409+ param = mempty
410+ & name .~ tname
411+ & description .~ transDesc (reflectDescription (Proxy :: Proxy mods))
412+ & required ?~ reflectBool (Proxy :: Proxy (FoldRequired mods))
413+ & schema .~ ParamOther (mempty
414+ & in_ .~ ParamHeader
415+ & paramSchema .~ toParamSchema (Proxy :: Proxy a))
416+
417+instance (ToSchema a, AllAccept cs, HasSwagger sub, KnownSymbol (FoldDescription mods)) => HasSwagger (ReqBody' mods cs a :> sub) where
418+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
419+ & addParam param
420+ & addConsumes (allContentType (Proxy :: Proxy cs))
421+ & addDefaultResponse400 tname
422+ & definitions %~ (<> defs)
423+ where
424+ tname = "body"
425+ transDesc "" = Nothing
426+ transDesc desc = Just (Text.pack desc)
427+ (defs, ref) = runDeclare (declareSchemaRef (Proxy :: Proxy a)) mempty
428+ param = mempty
429+ & name .~ tname
430+ & description .~ transDesc (reflectDescription (Proxy :: Proxy mods))
431+ & required ?~ True
432+ & schema .~ ParamBody ref
433+
434+-- | This instance is an approximation.
435+--
436+-- @since 1.1.7
437+instance (ToSchema a, Accept ct, HasSwagger sub, KnownSymbol (FoldDescription mods)) => HasSwagger (StreamBody' mods fr ct a :> sub) where
438+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
439+ & addParam param
440+ & addConsumes (toList (contentTypes (Proxy :: Proxy ct)))
441+ & addDefaultResponse400 tname
442+ & definitions %~ (<> defs)
443+ where
444+ tname = "body"
445+ transDesc "" = Nothing
446+ transDesc desc = Just (Text.pack desc)
447+ (defs, ref) = runDeclare (declareSchemaRef (Proxy :: Proxy a)) mempty
448+ param = mempty
449+ & name .~ tname
450+ & description .~ transDesc (reflectDescription (Proxy :: Proxy mods))
451+ & required ?~ True
452+ & schema .~ ParamBody ref
453+
454+instance (HasSwagger (ToServantApi routes), KnownSymbol datatypeName, Rep (routes AsApi) ~ D1 ('MetaData datatypeName moduleName packageName isNewtype) f) => HasSwagger (NamedRoutes routes) where
455+ toSwagger _ = addTag (Text.pack $ symbolVal (Proxy :: Proxy datatypeName)) (toSwagger (Proxy :: Proxy (ToServantApi routes)))
456+
457+-- =======================================================================
458+-- Below are the definitions that should be in Servant.API.ContentTypes
459+-- =======================================================================
460+
461+class AllAccept cs where
462+ allContentType :: Proxy cs -> [MediaType]
463+
464+instance AllAccept '[] where
465+ allContentType _ = []
466+
467+instance (Accept c, AllAccept cs) => AllAccept (c ': cs) where
468+ allContentType _ = contentType (Proxy :: Proxy c) : allContentType (Proxy :: Proxy cs)
469+
470+class ToResponseHeader h where
471+ toResponseHeader :: Proxy h -> (HeaderName, Swagger.Header)
472+
473+instance (KnownSymbol sym, ToParamSchema a) => ToResponseHeader (Header sym a) where
474+ toResponseHeader _ = (hname, Swagger.Header Nothing hschema)
475+ where
476+ hname = Text.pack (symbolVal (Proxy :: Proxy sym))
477+ hschema = toParamSchema (Proxy :: Proxy a)
478+
479+class AllToResponseHeader hs where
480+ toAllResponseHeaders :: Proxy hs -> InsOrdHashMap HeaderName Swagger.Header
481+
482+instance AllToResponseHeader '[] where
483+ toAllResponseHeaders _ = mempty
484+
485+instance (ToResponseHeader h, AllToResponseHeader hs) => AllToResponseHeader (h ': hs) where
486+ toAllResponseHeaders _ = InsOrdHashMap.insert headerName headerBS hdrs
487+ where
488+ (headerName, headerBS) = toResponseHeader (Proxy :: Proxy h)
489+ hdrs = toAllResponseHeaders (Proxy :: Proxy hs)
490+
491+instance AllToResponseHeader hs => AllToResponseHeader (HList hs) where
492+ 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+121
@@ -1,5 +1,126 @@
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.1
6+------
7+
8+Compatibility with GHC 9.4, see [PR #1592](https://github.com/haskell-servant/servant/pull/1592).
9+
10+0.19
11+----
12+
13+### Significant changes
14+
15+- Drop support for GHC < 8.6.
16+- Support GHC 9.0 (GHC 9.2 should work as well, but isn't fully tested yet).
17+- Support Aeson 2 ([#1475](https://github.com/haskell-servant/servant/pull/1475)),
18+ which fixes a [DOS vulnerability](https://github.com/haskell/aeson/issues/864)
19+ related to hash collisions.
20+- Add `NamedRoutes` combinator, making support for records first-class in Servant
21+ ([#1388](https://github.com/haskell-servant/servant/pull/1388)).
22+
23+ Users can now directly mark part as an API as defined by a record, instead of
24+ using `(:<|>)` to combine routes. Concretely, the anonymous:
25+
26+ ```haskell
27+ type API =
28+ "version" :> Get '[JSON] String :<|>
29+ "products" :> Get '[JSON] [Product]
30+ ```
31+
32+ can be replaced with the explicitly-named:
33+
34+ ```haskell
35+ type API = NamedRoutes NamedAPI
36+ data NamedAPI mode = NamedAPI
37+ { version :: mode :- "version" :> Get '[JSON] String
38+ , products :: mode :- "products" :> Get '[JSON] [Product]
39+ }
40+ ```
41+
42+ `NamedRoutes` builds upon `servant-generic`, but improves usability by freeing
43+ users from the need to perform `toServant` / `fromServant` conversions
44+ manually. Serving `NamedRoutes NamedAPI` is now done directly by providing a
45+ record of handlers, and servant generates clients directly as records as well.
46+ In particular, it makes it much more practical to work with nested hierarchies
47+ of named routes.
48+
49+ Two convenience functions, `(//)` and `(/:)`, have been added to make the
50+ usage of named route hierarchies more pleasant:
51+
52+ ```haskell
53+ rootClient :: RootApi (AsClientT ClientM)
54+ rootClient = client (Proxy @API)
55+
56+ helloClient :: String -> ClientM String
57+ helloClient name = rootClient // hello /: name
58+
59+ endpointClient :: ClientM Person
60+ endpointClient = rootClient // subApi /: "foobar123" // endpoint
61+
62+ type Api = NamedRoutes RootApi
63+
64+ data RootApi mode = RootApi
65+ { subApi :: mode :- Capture "token" String :> NamedRoutes SubApi
66+ , hello :: mode :- Capture "name" String :> Get '[JSON] String
67+ , …
68+ } deriving Generic
69+
70+ data SubApi mode = SubApi
71+ { endpoint :: mode :- Get '[JSON] Person
72+ , …
73+ } deriving Generic
74+ ```
75+
76+- Add custom type errors for partially applied combinators
77+ ([#1289](https://github.com/haskell-servant/servant/pull/1289),
78+ [#1486](https://github.com/haskell-servant/servant/pull/1486)).
79+
80+ For example, forgetting to document the expected type for a query parameter,
81+ as in:
82+
83+ ``` haskell
84+ type API = QueryParam "param" :> Get '[JSON] NoContent
85+ ```
86+
87+ will raise to the following error when trying to serve the API:
88+
89+ ```
90+ • There is no instance for HasServer (QueryParam'
91+ '[Optional, Strict] "param" :> ...)
92+ QueryParam' '[Optional, Strict] "1" expects 1 more arguments
93+ ```
94+
95+ As a consequence of this change, unsaturated types are now forbidden before `(:>)`.
96+
97+- Add a `HeadNoContent` verb ([#1502](https://github.com/haskell-servant/servant/pull/1502)).
98+
99+- *servant-client* / *servant-client-core* / *servant-http-streams*:
100+ Fix erroneous behavior, where only 2XX status codes would be considered
101+ successful, irrelevant of the status parameter specified by the verb
102+ combinator. ([#1469](https://github.com/haskell-servant/servant/pull/1469))
103+
104+- *servant-client* / *servant-client-core*: Fix `Show` instance for
105+ `Servant.Client.Core.Request`.
106+
107+
108+- *servant-client* / *servant-client-core*: Allow passing arbitrary binary data
109+ in Query parameters.
110+ ([#1432](https://github.com/haskell-servant/servant/pull/1432)).
111+
112+- *servant-docs*: Generate sample cURL requests
113+ ([#1401](https://github.com/haskell-servant/servant/pull/1401/files)).
114+
115+ Breaking change: requires sample header values to be supplied with `headers`.
116+
117+### Other changes
118+
119+- Various bit rotten cookbooks have been updated and re-introduced on
120+ [docs.servant.dev](https://docs.servant.dev).
121+
122+- Various version bumps.
123+
30.18.3
1240.18.3
4------
125------
5
126
servant/servant.cabal+19−15
@@ -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.1
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,15 +13,15 @@ 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
20copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors
20copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors
21build-type: Simple
21build-type: Simple
22
22
23−tested-with: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1
23+tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1
24− , GHCJS == 8.4
24+ , GHCJS ==8.6.0.1
25
25
26extra-source-files:
26extra-source-files:
27 CHANGELOG.md
27 CHANGELOG.md
@@ -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,12 +55,14 @@ 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
60 Servant.API.Vault
62 Servant.API.Vault
61 Servant.API.Verbs
63 Servant.API.Verbs
62 Servant.API.WithNamedContext
64 Servant.API.WithNamedContext
65+ Servant.API.WithResource
63
66
64 -- Types
67 -- Types
65 exposed-modules:
68 exposed-modules:
@@ -78,32 +81,33 @@ library
78 --
81 --
79 -- note: mtl lower bound is so low because of GHC-7.8
82 -- note: mtl lower bound is so low because of GHC-7.8
80 build-depends:
83 build-depends:
81− base >= 4.9 && < 4.16
84+ base >= 4.9 && < 4.18
82 , bytestring >= 0.10.8.1 && < 0.12
85 , bytestring >= 0.10.8.1 && < 0.12
86+ , constraints >= 0.2
83− , mtl >= 2.2.2 && < 2.3
87+ , mtl ^>= 2.2.2 || ^>= 2.3.1
84 , sop-core >= 0.4.0.0 && < 0.6
88 , sop-core >= 0.4.0.0 && < 0.6
85− , transformers >= 0.5.2.0 && < 0.6
89+ , transformers >= 0.5.2.0 && < 0.7
86− , text >= 1.2.3.0 && < 1.3
90+ , text >= 1.2.3.0 && < 2.1
87
91
88
92
89 -- We depend (heavily) on the API of these packages:
93 -- We depend (heavily) on the API of these packages:
90 -- i.e. re-export, or allow using without direct dependency
94 -- i.e. re-export, or allow using without direct dependency
91 build-depends:
95 build-depends:
92− http-api-data >= 0.4.1 && < 0.4.4
96+ http-api-data >= 0.4.1 && < 0.5.1
93 , singleton-bool >= 0.1.4 && < 0.1.7
97 , singleton-bool >= 0.1.4 && < 0.1.7
94
98
95 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.
99 -- 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.
100 -- Here can be exceptions if we really need features from the newer versions.
97 build-depends:
101 build-depends:
98− base-compat >= 0.10.5 && < 0.12
102+ base-compat >= 0.10.5 && < 0.13
99− , aeson >= 1.4.1.0 && < 1.6
103+ , aeson >= 1.4.1.0 && < 3
100 , attoparsec >= 0.13.2.2 && < 0.15
104 , attoparsec >= 0.13.2.2 && < 0.15
101 , bifunctors >= 5.5.3 && < 5.6
105 , bifunctors >= 5.5.3 && < 5.6
102 , case-insensitive >= 1.2.0.11 && < 1.3
106 , case-insensitive >= 1.2.0.11 && < 1.3
103 , deepseq >= 1.4.2.0 && < 1.5
107 , deepseq >= 1.4.2.0 && < 1.5
104 , http-media >= 0.7.1.3 && < 0.9
108 , http-media >= 0.7.1.3 && < 0.9
105 , http-types >= 0.12.2 && < 0.13
109 , http-types >= 0.12.2 && < 0.13
106− , mmorph >= 1.1.2 && < 1.2
110+ , mmorph >= 1.1.2 && < 1.3
107 , network-uri >= 2.6.1.0 && < 2.7
111 , network-uri >= 2.6.1.0 && < 2.7
108 , QuickCheck >= 2.12.6.1 && < 2.15
112 , QuickCheck >= 2.12.6.1 && < 2.15
109 , string-conversions >= 0.4.0.1 && < 0.5
113 , string-conversions >= 0.4.0.1 && < 0.5
@@ -163,9 +167,9 @@ test-suite spec
163
167
164 -- Additional dependencies
168 -- Additional dependencies
165 build-depends:
169 build-depends:
166− hspec >= 2.6.0 && < 2.9
170+ hspec >= 2.6.0 && < 2.10
167 , QuickCheck >= 2.12.6.1 && < 2.15
171 , QuickCheck >= 2.12.6.1 && < 2.15
168 , quickcheck-instances >= 0.3.19 && < 0.4
172 , quickcheck-instances >= 0.3.19 && < 0.4
169
173
170 build-tool-depends:
174 build-tool-depends:
171− hspec-discover:hspec-discover >= 2.6.0 && < 2.9
175+ hspec-discover:hspec-discover >= 2.6.0 && < 2.10
servant/src/Servant/API.hs+14−1
@@ -31,11 +31,17 @@ module Servant.API (
31 -- | Access the location for arbitrary data to be shared by applications and middleware
31 -- | Access the location for arbitrary data to be shared by applications and middleware
32 module Servant.API.WithNamedContext,
32 module Servant.API.WithNamedContext,
33 -- | Access context entries in combinators in servant-server
33 -- | Access context entries in combinators in servant-server
34+ module Servant.API.WithResource,
35+ -- | Access a managed resource scoped to a single request
34
36
35 -- * Actual endpoints, distinguished by HTTP method
37 -- * Actual endpoints, distinguished by HTTP method
36 module Servant.API.Verbs,
38 module Servant.API.Verbs,
37 module Servant.API.UVerb,
39 module Servant.API.UVerb,
38
40
41+ -- * Sub-APIs defined as records of routes
42+ module Servant.API.NamedRoutes,
43+ module Servant.API.Generic,
44+
39 -- * Streaming endpoints, distinguished by HTTP method
45 -- * Streaming endpoints, distinguished by HTTP method
40 module Servant.API.Stream,
46 module Servant.API.Stream,
41
47
@@ -97,6 +103,9 @@ import Servant.API.Experimental.Auth
97 (AuthProtect)
103 (AuthProtect)
98import Servant.API.Fragment
104import Servant.API.Fragment
99 (Fragment)
105 (Fragment)
106+import Servant.API.Generic
107+ (AsApi, GServantProduct, GenericMode ((:-)), GenericServant,
108+ ToServant, ToServantApi, fromServant, genericApi, toServant)
100import Servant.API.Header
109import Servant.API.Header
101 (Header, Header')
110 (Header, Header')
102import Servant.API.HttpVersion
111import Servant.API.HttpVersion
@@ -105,10 +114,12 @@ import Servant.API.IsSecure
105 (IsSecure (..))
114 (IsSecure (..))
106import Servant.API.Modifiers
115import Servant.API.Modifiers
107 (Lenient, Optional, Required, Strict)
116 (Lenient, Optional, Required, Strict)
117+import Servant.API.NamedRoutes
118+ (NamedRoutes)
108import Servant.API.QueryParam
119import Servant.API.QueryParam
109 (QueryFlag, QueryParam, QueryParam', QueryParams)
120 (QueryFlag, QueryParam, QueryParam', QueryParams)
110import Servant.API.Raw
121import Servant.API.Raw
111− (Raw)
122+ (Raw, RawM)
112import Servant.API.RemoteHost
123import Servant.API.RemoteHost
113 (RemoteHost)
124 (RemoteHost)
114import Servant.API.ReqBody
125import Servant.API.ReqBody
@@ -141,6 +152,8 @@ import Servant.API.Verbs
141 ReflectMethod (reflectMethod), StdMethod (..), Verb)
152 ReflectMethod (reflectMethod), StdMethod (..), Verb)
142import Servant.API.WithNamedContext
153import Servant.API.WithNamedContext
143 (WithNamedContext)
154 (WithNamedContext)
155+import Servant.API.WithResource
156+ (WithResource)
144import Servant.Links
157import Servant.Links
145 (HasLink (..), IsElem, IsElem', Link, URI (..), safeLink)
158 (HasLink (..), IsElem, IsElem', Link, URI (..), safeLink)
146import Web.HttpApiData
159import Web.HttpApiData
servant/src/Servant/API/Alternative.hs−2
@@ -16,8 +16,6 @@ import Data.Bifunctor
16 (Bifunctor (..))
16 (Bifunctor (..))
17import Data.Bitraversable
17import Data.Bitraversable
18 (Bitraversable (..))
18 (Bitraversable (..))
19−import Data.Semigroup
20− (Semigroup (..))
21import Data.Typeable
19import Data.Typeable
22 (Typeable)
20 (Typeable)
23import Prelude ()
21import Prelude ()
servant/src/Servant/API/ContentTypes.hs+2−1
@@ -2,6 +2,7 @@
2{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE DeriveDataTypeable #-}
3{-# LANGUAGE DeriveDataTypeable #-}
4{-# LANGUAGE DeriveGeneric #-}
4{-# LANGUAGE DeriveGeneric #-}
5+{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE OverloadedStrings #-}
8{-# LANGUAGE OverloadedStrings #-}
@@ -294,7 +295,7 @@ instance {-# OVERLAPPABLE #-}
294-- 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
295-- between that and 'MimeRender JSON a', so we do this instead
296-- between that and 'MimeRender JSON a', so we do this instead
296instance {-# OVERLAPPING #-} ( Accept ctyp ) => AllMimeRender '[ctyp] NoContent where
297instance {-# OVERLAPPING #-} ( Accept ctyp ) => AllMimeRender '[ctyp] NoContent where
297− allMimeRender _ _ = map (, "") $ NE.toList $ contentTypes pctyp
298+ allMimeRender _ NoContent = map (, "") $ NE.toList $ contentTypes pctyp
298 where
299 where
299 pctyp = Proxy :: Proxy ctyp
300 pctyp = Proxy :: Proxy ctyp
300
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/Raw.hs+3
@@ -15,3 +15,6 @@ import Data.Typeable
15-- <https://hackage.haskell.org/package/servant-server/docs/Servant-Server-StaticFiles.html Servant.Server.StaticFiles>
15-- <https://hackage.haskell.org/package/servant-server/docs/Servant-Server-StaticFiles.html Servant.Server.StaticFiles>
16-- to serve static files stored in a particular directory on your filesystem
16-- to serve static files stored in a particular directory on your filesystem
17data Raw deriving Typeable
17data Raw deriving Typeable
18+
19+-- | Variant of 'Raw' that lets you access the underlying monadic context to process the request.
20+data RawM deriving Typeable
servant/src/Servant/API/ResponseHeaders.hs+29−11
@@ -3,13 +3,12 @@
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 #-}
11+{-# LANGUAGE TypeFamilyDependencies #-}
13{-# LANGUAGE TypeOperators #-}
12{-# LANGUAGE TypeOperators #-}
14{-# LANGUAGE UndecidableInstances #-}
13{-# LANGUAGE UndecidableInstances #-}
15{-# OPTIONS_HADDOCK not-home #-}
14{-# OPTIONS_HADDOCK not-home #-}
@@ -51,11 +50,11 @@ import Web.HttpApiData
51
50
52import Prelude ()
51import Prelude ()
53import Prelude.Compat
52import Prelude.Compat
54−import Servant.API.ContentTypes
55− (JSON, PlainText, FormUrlEncoded, OctetStream,
56− MimeRender(..))
57import Servant.API.Header
53import Servant.API.Header
58 (Header)
54 (Header)
55+import Servant.API.UVerb.Union
56+import qualified Data.SOP.BasicFunctors as SOP
57+import qualified Data.SOP.NS as SOP
59
58
60-- | Response Header objects. You should never need to construct one directly.
59-- | Response Header objects. You should never need to construct one directly.
61-- Instead, use 'addOptionalHeader'.
60-- Instead, use 'addOptionalHeader'.
@@ -117,7 +116,7 @@ instance {-# OVERLAPPABLE #-} ( FromHttpApiData v, BuildHeadersTo xs, KnownSymbo
117 `HCons` buildHeadersTo headers
116 `HCons` buildHeadersTo headers
118 Right h -> Header h `HCons` buildHeadersTo headers
117 Right h -> Header h `HCons` buildHeadersTo headers
119
118
120−-- * Getting
119+-- * Getting headers
121
120
122class GetHeaders ls where
121class GetHeaders ls where
123 getHeaders :: ls -> [HTTP.Header]
122 getHeaders :: ls -> [HTTP.Header]
@@ -158,23 +157,42 @@ instance (KnownSymbol h, GetHeadersFromHList rest, ToHttpApiData v)
158 where
157 where
159 getHeaders' hs = getHeadersFromHList $ getHeadersHList hs
158 getHeaders' hs = getHeadersFromHList $ getHeadersHList hs
160
159
161−-- * Adding
160+-- * Adding headers
162
161
163-- We need all these fundeps to save type inference
162-- We need all these fundeps to save type inference
164class AddHeader h v orig new
163class AddHeader h v orig new
165 | h v orig -> new, new -> h, new -> v, new -> orig where
164 | 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
165 addOptionalHeader :: ResponseHeader h v -> orig -> new -- ^ N.B.: The same header can't be added multiple times
167
166
168−
167+-- In this instance, we add a Header on top of something that is already decorated with some headers
169instance {-# OVERLAPPING #-} ( KnownSymbol h, ToHttpApiData v )
168instance {-# OVERLAPPING #-} ( KnownSymbol h, ToHttpApiData v )
170 => AddHeader h v (Headers (fst ': rest) a) (Headers (Header h v ': fst ': rest) a) where
169 => 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)
170 addOptionalHeader hdr (Headers resp heads) = Headers resp (HCons hdr heads)
172
171
172+-- In this instance, 'a' parameter is decorated with a Header.
173−instance {-# OVERLAPPABLE #-} ( KnownSymbol h, ToHttpApiData v
173+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
174 => AddHeader h v a new where
176 addOptionalHeader hdr resp = Headers resp (HCons hdr HNil)
175 addOptionalHeader hdr resp = Headers resp (HCons hdr HNil)
177
176
177+-- Instances to decorate all responses in a 'Union' with headers. The functional
178+-- dependencies force us to consider singleton lists as the base case in the
179+-- recursion (it is impossible to determine h and v otherwise from old / new
180+-- responses if the list is empty).
181+instance (AddHeader h v old new) => AddHeader h v (Union '[old]) (Union '[new]) where
182+ addOptionalHeader hdr resp =
183+ SOP.Z $ SOP.I $ addOptionalHeader hdr $ SOP.unI $ SOP.unZ $ resp
184+
185+instance
186+ ( AddHeader h v old new, AddHeader h v (Union oldrest) (Union newrest)
187+ -- This ensures that the remainder of the response list is _not_ empty
188+ -- It is necessary to prevent the two instances for union types from
189+ -- overlapping.
190+ , oldrest ~ (a ': as), newrest ~ (b ': bs))
191+ => AddHeader h v (Union (old ': (a ': as))) (Union (new ': (b ': bs))) where
192+ addOptionalHeader hdr resp = case resp of
193+ SOP.Z (SOP.I rHead) -> SOP.Z $ SOP.I $ addOptionalHeader hdr rHead
194+ SOP.S rOthers -> SOP.S $ addOptionalHeader hdr rOthers
195+
178-- | @addHeader@ adds a header to a response. Note that it changes the type of
196-- | @addHeader@ adds a header to a response. Note that it changes the type of
179-- the value in the following ways:
197-- the value in the following ways:
180--
198--
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/Stream.hs−2
@@ -47,8 +47,6 @@ import qualified Data.ByteString.Lazy as LBS
47import qualified Data.ByteString.Lazy.Char8 as LBS8
47import qualified Data.ByteString.Lazy.Char8 as LBS8
48import Data.List.NonEmpty
48import Data.List.NonEmpty
49 (NonEmpty (..))
49 (NonEmpty (..))
50−import Data.Monoid
51− ((<>))
52import Data.Proxy
50import Data.Proxy
53 (Proxy)
51 (Proxy)
54import Data.Typeable
52import Data.Typeable
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/TypeLevel.hs+3−3
@@ -110,7 +110,7 @@ type family IsElem' a s :: Constraint
110--
110--
111-- >>> ok (Proxy :: Proxy (IsElem ("bye" :> Get '[JSON] Int) SampleAPI))
111-- >>> ok (Proxy :: Proxy (IsElem ("bye" :> Get '[JSON] Int) SampleAPI))
112-- ...
112-- ...
113−-- ... Could not deduce...
113+-- ... Could not ...
114-- ...
114-- ...
115--
115--
116-- An endpoint is considered within an api even if it is missing combinators
116-- An endpoint is considered within an api even if it is missing combinators
@@ -151,7 +151,7 @@ type family IsElem endpoint api :: Constraint where
151--
151--
152-- >>> ok (Proxy :: Proxy (IsSubAPI (SampleAPI :<|> Get '[JSON] Int) SampleAPI))
152-- >>> ok (Proxy :: Proxy (IsSubAPI (SampleAPI :<|> Get '[JSON] Int) SampleAPI))
153-- ...
153-- ...
154−-- ... Could not deduce...
154+-- ... Could not ...
155-- ...
155-- ...
156--
156--
157-- This uses @IsElem@ for checking; thus the note there applies here.
157-- This uses @IsElem@ for checking; thus the note there applies here.
@@ -174,7 +174,7 @@ type family AllIsElem xs api :: Constraint where
174--
174--
175-- >>> ok (Proxy :: Proxy (IsIn (Get '[JSON] Int) (Header "h" Bool :> Get '[JSON] Int)))
175-- >>> ok (Proxy :: Proxy (IsIn (Get '[JSON] Int) (Header "h" Bool :> Get '[JSON] Int)))
176-- ...
176-- ...
177−-- ... Could not deduce...
177+-- ... Could not ...
178-- ...
178-- ...
179type family IsIn (endpoint :: *) (api :: *) :: Constraint where
179type family IsIn (endpoint :: *) (api :: *) :: Constraint where
180 IsIn e (sa :<|> sb) = Or (IsIn e sa) (IsIn e sb)
180 IsIn e (sa :<|> sb) = Or (IsIn e sa) (IsIn e sb)
servant/src/Servant/API/UVerb.hs+3
@@ -38,6 +38,7 @@ import GHC.TypeLits (Nat)
38import Network.HTTP.Types (Status, StdMethod)
38import Network.HTTP.Types (Status, StdMethod)
39import Servant.API.ContentTypes (JSON, PlainText, FormUrlEncoded, OctetStream, NoContent, MimeRender(mimeRender), MimeUnrender(mimeUnrender))
39import Servant.API.ContentTypes (JSON, PlainText, FormUrlEncoded, OctetStream, NoContent, MimeRender(mimeRender), MimeUnrender(mimeUnrender))
40import Servant.API.Status (KnownStatus, statusVal)
40import Servant.API.Status (KnownStatus, statusVal)
41+import Servant.API.ResponseHeaders (Headers)
41import Servant.API.UVerb.Union
42import Servant.API.UVerb.Union
42
43
43class KnownStatus (StatusOf a) => HasStatus (a :: *) where
44class KnownStatus (StatusOf a) => HasStatus (a :: *) where
@@ -86,6 +87,8 @@ newtype WithStatus (k :: Nat) a = WithStatus a
86instance KnownStatus n => HasStatus (WithStatus n a) where
87instance KnownStatus n => HasStatus (WithStatus n a) where
87 type StatusOf (WithStatus n a) = n
88 type StatusOf (WithStatus n a) = n
88
89
90+instance HasStatus a => HasStatus (Headers ls a) where
91+ type StatusOf (Headers ls a) = StatusOf a
89
92
90-- | A variant of 'Verb' that can have any of a number of response values and status codes.
93-- | A variant of 'Verb' that can have any of a number of response values and status codes.
91--
94--
servant/src/Servant/API/UVerb/Union.hs+2−2
@@ -128,9 +128,9 @@ type DuplicateElementError (rs :: [k]) =
128 ':$$: 'Text " " ':<>: 'ShowType rs
128 ':$$: 'Text " " ':<>: 'ShowType rs
129
129
130type family Elem (x :: k) (xs :: [k]) :: Bool where
130type family Elem (x :: k) (xs :: [k]) :: Bool where
131+ Elem x (x ': _) = 'True
132+ Elem x (_ ': xs) = Elem x xs
131 Elem _ '[] = 'False
133 Elem _ '[] = 'False
132− Elem x (x' ': xs) =
133− If (x == x') 'True (Elem x xs)
134
134
135type family Unique xs :: Constraint where
135type family Unique xs :: Constraint where
136 Unique xs = If (Nubbed xs == 'True) (() :: Constraint) (TypeError (DuplicateElementError xs))
136 Unique xs = If (Nubbed xs == 'True) (() :: Constraint) (TypeError (DuplicateElementError xs))
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/API/WithResource.hsnew file+3
@@ -0,0 +1,3 @@
1+module Servant.API.WithResource (WithResource) where
2+
3+data WithResource res
servant/src/Servant/Links.hs+72−5
@@ -1,13 +1,19 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
1{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE ConstraintKinds #-}
3+{-# LANGUAGE CPP #-}
2{-# LANGUAGE DataKinds #-}
4{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE FunctionalDependencies #-}
7{-# LANGUAGE FunctionalDependencies #-}
8+{-# LANGUAGE InstanceSigs #-}
6{-# LANGUAGE PolyKinds #-}
9{-# LANGUAGE PolyKinds #-}
10+{-# LANGUAGE QuantifiedConstraints #-}
7{-# LANGUAGE ScopedTypeVariables #-}
11{-# LANGUAGE ScopedTypeVariables #-}
12+{-# LANGUAGE TypeApplications #-}
8{-# LANGUAGE TypeFamilies #-}
13{-# LANGUAGE TypeFamilies #-}
9{-# LANGUAGE TypeOperators #-}
14{-# LANGUAGE TypeOperators #-}
10{-# LANGUAGE UndecidableInstances #-}
15{-# LANGUAGE UndecidableInstances #-}
16+
11{-# OPTIONS_HADDOCK not-home #-}
17{-# OPTIONS_HADDOCK not-home #-}
12
18
13-- | Type safe generation of internal links.
19-- | Type safe generation of internal links.
@@ -86,7 +92,7 @@
86-- >>> let bad_link = Proxy :: Proxy ("hello" :> Delete '[JSON] NoContent)
92-- >>> let bad_link = Proxy :: Proxy ("hello" :> Delete '[JSON] NoContent)
87-- >>> safeLink api bad_link
93-- >>> safeLink api bad_link
88-- ...
94-- ...
89−-- ...Could not deduce...
95+-- ...Could not ...
90-- ...
96-- ...
91--
97--
92-- This error is essentially saying that the type family couldn't find
98-- This error is essentially saying that the type family couldn't find
@@ -125,10 +131,9 @@ module Servant.Links (
125) where
131) where
126
132
127import Data.List
133import Data.List
134+import Data.Constraint
128import Data.Proxy
135import Data.Proxy
129 (Proxy (..))
136 (Proxy (..))
130−import Data.Semigroup
131− ((<>))
132import Data.Singletons.Bool
137import Data.Singletons.Bool
133 (SBool (..), SBoolI (..))
138 (SBool (..), SBoolI (..))
134import qualified Data.Text as Text
139import qualified Data.Text as Text
@@ -136,7 +141,7 @@ import qualified Data.Text.Encoding as TE
136import Data.Type.Bool
141import Data.Type.Bool
137 (If)
142 (If)
138import GHC.TypeLits
143import GHC.TypeLits
139− (KnownSymbol, symbolVal)
144+ (KnownSymbol, TypeError, symbolVal)
140import Network.URI
145import Network.URI
141 (URI (..), escapeURIString, isUnreserved)
146 (URI (..), escapeURIString, isUnreserved)
142import Prelude ()
147import Prelude ()
@@ -165,10 +170,12 @@ import Servant.API.IsSecure
165 (IsSecure)
170 (IsSecure)
166import Servant.API.Modifiers
171import Servant.API.Modifiers
167 (FoldRequired)
172 (FoldRequired)
173+import Servant.API.NamedRoutes
174+ (NamedRoutes)
168import Servant.API.QueryParam
175import Servant.API.QueryParam
169 (QueryFlag, QueryParam', QueryParams)
176 (QueryFlag, QueryParam', QueryParams)
170import Servant.API.Raw
177import Servant.API.Raw
171− (Raw)
178+ (Raw, RawM)
172import Servant.API.RemoteHost
179import Servant.API.RemoteHost
173 (RemoteHost)
180 (RemoteHost)
174import Servant.API.ReqBody
181import Servant.API.ReqBody
@@ -177,6 +184,7 @@ import Servant.API.Stream
177 (Stream, StreamBody')
184 (Stream, StreamBody')
178import Servant.API.Sub
185import Servant.API.Sub
179 (type (:>))
186 (type (:>))
187+import Servant.API.TypeErrors
180import Servant.API.TypeLevel
188import Servant.API.TypeLevel
181import Servant.API.UVerb
189import Servant.API.UVerb
182import Servant.API.Vault
190import Servant.API.Vault
@@ -185,7 +193,11 @@ import Servant.API.Verbs
185 (Verb, NoContentVerb)
193 (Verb, NoContentVerb)
186import Servant.API.WithNamedContext
194import Servant.API.WithNamedContext
187 (WithNamedContext)
195 (WithNamedContext)
196+import Servant.API.WithResource
197+ (WithResource)
188import Web.HttpApiData
198import Web.HttpApiData
199+import Data.Kind
200+ (Type)
189
201
190-- | A safe link datatype.
202-- | A safe link datatype.
191-- The only way of constructing a 'Link' is using 'safeLink', which means any
203-- The only way of constructing a 'Link' is using 'safeLink', which means any
@@ -548,6 +560,10 @@ instance HasLink sub => HasLink (WithNamedContext name context sub) where
548 type MkLink (WithNamedContext name context sub) a = MkLink sub a
560 type MkLink (WithNamedContext name context sub) a = MkLink sub a
549 toLink toA _ = toLink toA (Proxy :: Proxy sub)
561 toLink toA _ = toLink toA (Proxy :: Proxy sub)
550
562
563+instance HasLink sub => HasLink (WithResource res :> sub) where
564+ type MkLink (WithResource res :> sub) a = MkLink sub a
565+ toLink toA _ = toLink toA (Proxy :: Proxy sub)
566+
551instance HasLink sub => HasLink (RemoteHost :> sub) where
567instance HasLink sub => HasLink (RemoteHost :> sub) where
552 type MkLink (RemoteHost :> sub) a = MkLink sub a
568 type MkLink (RemoteHost :> sub) a = MkLink sub a
553 toLink = simpleToLink (Proxy :: Proxy sub)
569 toLink = simpleToLink (Proxy :: Proxy sub)
@@ -573,6 +589,10 @@ instance HasLink Raw where
573 type MkLink Raw a = a
589 type MkLink Raw a = a
574 toLink toA _ = toA
590 toLink toA _ = toA
575
591
592+instance HasLink RawM where
593+ type MkLink RawM a = a
594+ toLink toA _ = toA
595+
576instance HasLink (Stream m status fr ct a) where
596instance HasLink (Stream m status fr ct a) where
577 type MkLink (Stream m status fr ct a) r = r
597 type MkLink (Stream m status fr ct a) r = r
578 toLink toA _ = toA
598 toLink toA _ = toA
@@ -581,6 +601,34 @@ instance HasLink (Stream m status fr ct a) where
581instance HasLink (UVerb m ct a) where
601instance HasLink (UVerb m ct a) where
582 type MkLink (UVerb m ct a) r = r
602 type MkLink (UVerb m ct a) r = r
583 toLink toA _ = toA
603 toLink toA _ = toA
604+-- Instance for NamedRoutes combinator
605+
606+type GLinkConstraints routes a =
607+ ( MkLink (ToServant routes AsApi) a ~ ToServant routes (AsLink a)
608+ , GenericServant routes (AsLink a)
609+ )
610+
611+class GLink (routes :: * -> *) (a :: *) where
612+ gLinkProof :: Dict (GLinkConstraints routes a)
613+
614+instance GLinkConstraints routes a => GLink routes a where
615+ gLinkProof = Dict
616+
617+instance
618+ ( HasLink (ToServantApi routes)
619+ , forall a. GLink routes a
620+ ) => HasLink (NamedRoutes routes) where
621+
622+ type MkLink (NamedRoutes routes) a = routes (AsLink a)
623+
624+ toLink
625+ :: forall a. (Link -> a)
626+ -> Proxy (NamedRoutes routes)
627+ -> Link
628+ -> routes (AsLink a)
629+
630+ toLink toA _ l = case gLinkProof @routes @a of
631+ Dict -> fromServant $ toLink toA (Proxy @(ToServantApi routes)) l
584
632
585-- AuthProtext instances
633-- AuthProtext instances
586instance HasLink sub => HasLink (AuthProtect tag :> sub) where
634instance HasLink sub => HasLink (AuthProtect tag :> sub) where
@@ -610,3 +658,22 @@ simpleToLink _ toA _ = toLink toA (Proxy :: Proxy sub)
610-- $setup
658-- $setup
611-- >>> import Servant.API
659-- >>> import Servant.API
612-- >>> import Data.Text (Text)
660-- >>> import Data.Text (Text)
661+
662+-- Erroring instance for 'HasLink' when a combinator is not fully applied
663+instance TypeError (PartialApplication
664+#if __GLASGOW_HASKELL__ >= 904
665+ @(Type -> Constraint)
666+#endif
667+ HasLink arr) => HasLink ((arr :: a -> b) :> sub)
668+ where
669+ type MkLink (arr :> sub) _ = TypeError (PartialApplication (HasLink :: * -> Constraint) arr)
670+ toLink = error "unreachable"
671+
672+-- Erroring instances for 'HasLink' for unknown API combinators
673+instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub
674+#if __GLASGOW_HASKELL__ >= 904
675+ @(Type -> Constraint)
676+#endif
677+ HasLink ty) => HasLink (ty :> sub)
678+
679+instance {-# OVERLAPPABLE #-} TypeError (NoInstanceFor (HasLink api)) => HasLink api
servant/src/Servant/Test/ComprehensiveAPI.hs+1
@@ -72,6 +72,7 @@ type ComprehensiveAPIWithoutStreamingOrRaw' endpoint =
72 :<|> "description" :> Description "foo" :> GET
72 :<|> "description" :> Description "foo" :> GET
73 :<|> "alternative" :> ("left" :> GET :<|> "right" :> GET)
73 :<|> "alternative" :> ("left" :> GET :<|> "right" :> GET)
74 :<|> "fragment" :> Fragment Int :> GET
74 :<|> "fragment" :> Fragment Int :> GET
75+ :<|> "resource" :> WithResource Int :> GET
75 :<|> endpoint
76 :<|> endpoint
76
77
77type ComprehensiveAPIWithoutStreamingOrRaw = ComprehensiveAPIWithoutStreamingOrRaw' EmptyEndpoint
78type ComprehensiveAPIWithoutStreamingOrRaw = ComprehensiveAPIWithoutStreamingOrRaw' EmptyEndpoint
servant/src/Servant/Types/SourceT.hs+4−1
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
1{-# LANGUAGE DeriveFunctor #-}
2{-# LANGUAGE DeriveFunctor #-}
2{-# LANGUAGE GADTs #-}
3{-# LANGUAGE GADTs #-}
3{-# LANGUAGE RankNTypes #-}
4{-# LANGUAGE RankNTypes #-}
@@ -154,8 +155,10 @@ instance (Applicative m, Show1 m, Show a) => Show (StepT m a) where
154-- | >>> lift [1,2,3] :: StepT [] Int
155-- | >>> lift [1,2,3] :: StepT [] Int
155-- Effect [Yield 1 Stop,Yield 2 Stop,Yield 3 Stop]
156-- Effect [Yield 1 Stop,Yield 2 Stop,Yield 3 Stop]
156--
157--
158+#if !MIN_VERSION_transformers(0,6,0)
157instance MonadTrans StepT where
159instance MonadTrans StepT where
158 lift = Effect . fmap (`Yield` Stop)
160 lift = Effect . fmap (`Yield` Stop)
161+#endif
159
162
160instance MFunctor StepT where
163instance MFunctor StepT where
161 hoist f = go where
164 hoist f = go where
@@ -319,7 +322,7 @@ fromActionStep stop action = loop where
319-- | Read file.
322-- | Read file.
320--
323--
321-- >>> foreach fail BS.putStr (readFile "servant.cabal")
324-- >>> foreach fail BS.putStr (readFile "servant.cabal")
322−-- cabal-version: >=1.10
325+-- cabal-version: 2.2
323-- name: servant
326-- name: servant
324-- ...
327-- ...
325--
328--
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
servant/test/Servant/API/ResponseHeadersSpec.hs+11
@@ -2,10 +2,14 @@
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Servant.API.ResponseHeadersSpec where
3module Servant.API.ResponseHeadersSpec where
4
4
5+import Data.Proxy
6+import GHC.TypeLits
5import Test.Hspec
7import Test.Hspec
6
8
9+import Servant.API.ContentTypes
7import Servant.API.Header
10import Servant.API.Header
8import Servant.API.ResponseHeaders
11import Servant.API.ResponseHeaders
12+import Servant.API.UVerb
9
13
10spec :: Spec
14spec :: Spec
11spec = describe "Servant.API.ResponseHeaders" $ do
15spec = describe "Servant.API.ResponseHeaders" $ do
@@ -28,3 +32,10 @@ spec = describe "Servant.API.ResponseHeaders" $ do
28 it "does not add a header" $ do
32 it "does not add a header" $ do
29 let val = noHeader 5 :: Headers '[Header "test" Int] Int
33 let val = noHeader 5 :: Headers '[Header "test" Int] Int
30 getHeaders val `shouldBe` []
34 getHeaders val `shouldBe` []
35+
36+ describe "HasStatus Headers" $ do
37+
38+ it "gets the status from the underlying value" $ do
39+ natVal (Proxy :: Proxy (StatusOf (Headers '[Header "first" Int] NoContent))) `shouldBe` 204
40+ natVal (Proxy :: Proxy (StatusOf (Headers '[Header "first" Int] (WithStatus 503 ())))) `shouldBe` 503
41+
stack.yaml+2−1
@@ -1,4 +1,4 @@
1−resolver: lts-16.24
1+resolver: lts-18.5
2packages:
2packages:
3- servant-client-core/
3- servant-client-core/
4- servant-client/
4- servant-client/
@@ -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/
stack.yaml.locknew file+19
@@ -0,0 +1,19 @@
1+# This file was autogenerated by Stack.
2+# You should not edit this file by hand.
3+# For more information, please see the documentation at:
4+# https://docs.haskellstack.org/en/stable/lock_files
5+
6+packages:
7+- completed:
8+ hackage: hspec-wai-0.10.1@sha256:56dd9ec1d56f47ef1946f71f7cbf070e4c285f718cac1b158400ae5e7172ef47,2290
9+ pantry-tree:
10+ size: 809
11+ sha256: 17af1c2e709cd84bfda066b9ebb04cdde7f92660c51a1f7401a1e9f766524e93
12+ original:
13+ hackage: hspec-wai-0.10.1
14+snapshots:
15+- completed:
16+ size: 585817
17+ url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/5.yaml
18+ sha256: 22d24d0dacad9c1450b9a174c28d203f9bb482a2a8da9710a2f2a9f4afee2887
19+ original: lts-18.5