git.iko.soy/servant
on master help sign in
swap
aaeee88377 ahead, 0 behind
281 files changed+11624−2522
since splitsnapshots
unifiedsplit
.github/FUNDING.yml+1−1 .github/run-ghcjs-tests.sh+14 .github/workflows/master.yml+148 .gitignore+6 .travis.yml−349 CONTRIBUTING.md+5−3 Makefile−22 README.md+12−26 cabal.ghcjs.project+5−1 cabal.haskell-ci−22 cabal.project+16−40 changelog.d/1432+9 changelog.d/1469+11 changelog.d/1477+9 changelog.d/1529+10 changelog.d/1556+81 changelog.d/1569+13 changelog.d/1571+10 changelog.d/1573+2 changelog.d/1580+12 changelog.d/1589+2 changelog.d/1595+2 changelog.d/1606+10 changelog.d/1638+2 changelog.d/1649+8 changelog.d/config+2 changelog.d/issue1028−10 changelog.d/issue1200−10 changelog.d/issue1206−13 changelog.d/servant-docs-curl+16 changelog.d/todo−7 changelog.d/z-changelog-d−8 default.nix+38 doc/Makefile+1−1 doc/conf.py+1−2 doc/cookbook/basic-auth/basic-auth.cabal+3−3 doc/cookbook/basic-streaming/Streaming.lhs+4−1 doc/cookbook/basic-streaming/basic-streaming.cabal+3−3 doc/cookbook/curl-mock/CurlMock.lhs+8−21 doc/cookbook/curl-mock/curl-mock.cabal+6−3 doc/cookbook/custom-errors/CustomErrors.lhs+189 doc/cookbook/custom-errors/custom-errors.cabal+25 doc/cookbook/db-mysql-basics/MysqlBasics.lhs+1−1 doc/cookbook/db-mysql-basics/mysql-basics.cabal+2−2 doc/cookbook/db-postgres-pool/db-postgres-pool.cabal+3−3 doc/cookbook/db-sqlite-simple/db-sqlite-simple.cabal+4−4 doc/cookbook/file-upload/FileUpload.lhs+2−2 doc/cookbook/file-upload/file-upload.cabal+3−3 doc/cookbook/generic/Generic.lhs+3−3 doc/cookbook/generic/generic.cabal+3−3 doc/cookbook/hoist-server-with-context/HoistServerWithContext.lhs+2−2 doc/cookbook/hoist-server-with-context/hoist-server-with-context.cabal+4−4 doc/cookbook/https/Https.lhs+5−5 doc/cookbook/https/https.cabal+4−4 doc/cookbook/index.rst+5−2 doc/cookbook/jwt-and-basic-auth/jwt-and-basic-auth.cabal+4−4 doc/cookbook/managed-resource/ManagedResource.lhs+114 doc/cookbook/managed-resource/managed-resource.cabal+30 doc/cookbook/open-id-connect/OpenIdConnect.cabal+3−3 doc/cookbook/open-id-connect/OpenIdConnect.lhs+17−17 doc/cookbook/pagination/Pagination.lhs+8−8 doc/cookbook/pagination/pagination.cabal+3−3 doc/cookbook/sentry/Sentry.lhs+2−2 doc/cookbook/sentry/sentry.cabal+3−3 doc/cookbook/structuring-apis/StructuringApis.lhs+1−1 doc/cookbook/structuring-apis/structuring-apis.cabal+3−3 doc/cookbook/testing/testing.cabal+4−4 doc/cookbook/using-custom-monad/UsingCustomMonad.lhs+1−1 doc/cookbook/using-custom-monad/using-custom-monad.cabal+3−3 doc/cookbook/using-free-client/UsingFreeClient.lhs+6−6 doc/cookbook/using-free-client/using-free-client.cabal+3−3 doc/cookbook/uverb/UVerb.lhs+223 doc/cookbook/uverb/uverb.cabal+35 doc/links.rst+1−1 doc/requirements.txt+1 doc/tutorial/ApiType.lhs+27 doc/tutorial/Authentication.lhs+7−8 doc/tutorial/Client.lhs+2−2 doc/tutorial/Docs.lhs+2−2 doc/tutorial/Javascript.lhs+2−2 doc/tutorial/Server.lhs+9−9 doc/tutorial/index.rst+1−37 doc/tutorial/install.rst+68 doc/tutorial/test/Spec.hs+11−1 doc/tutorial/tutorial.cabal+6−11 ghcjs.nix+22 nix/README.md+18 nix/nixpkgs.json+4 nix/nixpkgs.nix+4 nix/shell.nix+17−18 servant-auth/README.md+1 servant-auth/servant-auth-client/.ghci+1 servant-auth/servant-auth-client/CHANGELOG.md+26 servant-jsaddle/LICENSE → servant-auth/servant-auth-client/LICENSE+3−2 servant-auth/servant-auth-client/Setup.hs+2 servant-auth/servant-auth-client/servant-auth-client.cabal+80 servant-auth/servant-auth-client/src/Servant/Auth/Client.hs+3 servant-auth/servant-auth-client/src/Servant/Auth/Client/Internal.hs+64 servant-auth/servant-auth-client/test/Servant/Auth/ClientSpec.hs+161 servant-auth/servant-auth-client/test/Spec.hs+1 servant-auth/servant-auth-docs/.ghci+1 servant-auth/servant-auth-docs/CHANGELOG.md+14 servant-auth/servant-auth-docs/LICENSE+31 servant-auth/servant-auth-docs/Setup.hs+33 servant-auth/servant-auth-docs/servant-auth-docs.cabal+84 servant-auth/servant-auth-docs/src/Servant/Auth/Docs.hs+96 servant-auth/servant-auth-docs/test/Spec.hs+1 servant-auth/servant-auth-docs/test/doctests.hs+12 servant-auth/servant-auth-server/.ghci+1 servant-auth/servant-auth-server/CHANGELOG.md+130 servant-auth/servant-auth-server/LICENSE+31 servant-auth/servant-auth-server/README.lhs+291 servant-auth/servant-auth-server/README.md+1 servant-auth/servant-auth-server/Setup.hs+2 servant-auth/servant-auth-server/servant-auth-server.cabal+135 servant-auth/servant-auth-server/src/Servant/Auth/Server.hs+180 servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal.hs+67 servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/AddSetCookie.hs+119 servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/BasicAuth.hs+59 servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/Class.hs+72 servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/ConfigTypes.hs+127 servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/Cookie.hs+183 servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/FormLogin.hs+3 servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/JWT.hs+68 servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/ThrowAll.hs+58 servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/Types.hs+113 servant-auth/servant-auth-server/src/Servant/Auth/Server/SetCookieOrphan.hs+3 servant-auth/servant-auth-server/test/Servant/Auth/ServerSpec.hs+634 servant-auth/servant-auth-server/test/Spec.hs+1 servant-auth/servant-auth-swagger/.ghci+1 servant-auth/servant-auth-swagger/CHANGELOG.md+24 servant-auth/servant-auth-swagger/LICENSE+31 servant-auth/servant-auth-swagger/Setup.hs+2 servant-auth/servant-auth-swagger/servant-auth-swagger.cabal+70 servant-auth/servant-auth-swagger/src/Servant/Auth/Swagger.hs+87 servant-auth/servant-auth-swagger/test/Servant/Auth/SwaggerSpec.hs+38 servant-auth/servant-auth-swagger/test/Spec.hs+1 servant-auth/servant-auth/.ghci+1 servant-auth/servant-auth/CHANGELOG.md+20 servant-auth/servant-auth/LICENSE+31 servant-auth/servant-auth/Setup.hs+2 servant-auth/servant-auth/servant-auth.cabal+47 servant-auth/servant-auth/src/Servant/Auth.hs+54 servant-auth/servant-auth/src/Servant/Auth/JWT.hs+40 servant-auth/servant-auth/test/Spec.hs+1 servant-client-core/CHANGELOG.md+110−1 servant-client-core/servant-client-core.cabal+21−23 servant-client-core/src/Servant/Client/Core.hs+3 servant-client-core/src/Servant/Client/Core/BasicAuth.hs−2 servant-client-core/src/Servant/Client/Core/HasClient.hs+328−30 servant-client-core/src/Servant/Client/Core/Reexport.hs+6 servant-client-core/src/Servant/Client/Core/Request.hs+47−9 servant-client-core/src/Servant/Client/Core/RunClient.hs+12−3 servant-client-core/src/Servant/Client/Generic.hs+8−11 servant-client-core/test/Servant/Client/Core/RequestSpec.hs+31 servant-client-ghcjs/servant-client-ghcjs.cabal+7−7 servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs+8−5 servant-client/CHANGELOG.md+118−1 servant-client/servant-client.cabal+29−26 servant-client/src/Servant/Client.hs+1 servant-client/src/Servant/Client/Internal/HttpClient.hs+42−20 servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs+33−18 servant-client/src/Servant/Client/Streaming.hs+1 servant-client/test/Servant/BrokenSpec.hs+71 servant-client/test/Servant/ClientTestUtils.hs+146−26 servant-client/test/Servant/FailSpec.hs+3−5 servant-client/test/Servant/GenericSpec.hs+37 servant-client/test/Servant/SuccessSpec.hs+92−24 servant-conduit/servant-conduit.cabal+13−19 servant-docs/CHANGELOG.md+80 servant-docs/README.md+44−11 servant-docs/example/greet.hs+4−4 servant-docs/example/greet.md+33−2 servant-docs/golden/comprehensive.md+42−2 servant-docs/servant-docs.cabal+14−20 servant-docs/src/Servant/Docs/Internal.hs+152−33 servant-docs/src/Servant/Docs/Internal/Pretty.hs+19 servant-docs/test/Servant/DocsSpec.hs+21−6 servant-foreign/CHANGELOG.md+87 servant-foreign/servant-foreign.cabal+12−19 servant-foreign/src/Servant/Foreign.hs+22−19 servant-foreign/src/Servant/Foreign/Inflections.hs+18−13 servant-foreign/src/Servant/Foreign/Internal.hs+141−32 servant-foreign/test/Servant/ForeignSpec.hs+7−4 servant-http-streams/CHANGELOG.md+86 servant-http-streams/servant-http-streams.cabal+20−25 servant-http-streams/src/Servant/HttpStreams/Internal.hs+11−10 servant-http-streams/test/Servant/ClientSpec.hs+4−6 servant-jsaddle/CHANGELOG.md−4 servant-jsaddle/README.md−15 servant-jsaddle/Setup.hs−2 servant-jsaddle/servant-jsaddle.cabal−125 servant-jsaddle/src/Servant/Client/Internal/JSaddleXhrClient.hs−311 servant-jsaddle/src/Servant/Client/JSaddle.hs−20 servant-jsaddle/test/Servant/Client/JSaddleSpec.hs−173 servant-jsaddle/test/Spec.hs−8 servant-machines/servant-machines.cabal+11−17 servant-pipes/CHANGELOG.md+11 servant-pipes/example/Main.hs+1−1 servant-pipes/servant-pipes.cabal+12−17 servant-server/CHANGELOG.md+117 servant-server/Setup.hs+1−32 servant-server/example/README.md+1−1 servant-server/example/greet.hs+16−2 servant-server/servant-server.cabal+32−50 servant-server/src/Servant/Server.hs+63−10 servant-server/src/Servant/Server/Experimental/Auth.hs+2−1 servant-server/src/Servant/Server/Generic.hs+18−20 servant-server/src/Servant/Server/Internal.hs+297−110 servant-server/src/Servant/Server/Internal/BasicAuth.hs+1−3 servant-server/src/Servant/Server/Internal/Context.hs+24−9 servant-server/src/Servant/Server/Internal/Delayed.hs+1−1 servant-server/src/Servant/Server/Internal/DelayedIO.hs+4−5 servant-server/src/Servant/Server/Internal/ErrorFormatter.hs+87 servant-server/src/Servant/Server/Internal/Handler.hs+7−2 servant-server/src/Servant/Server/Internal/Router.hs+69−33 servant-server/src/Servant/Server/Internal/ServerError.hs+1−1 servant-server/src/Servant/Server/UVerb.hs+116 servant-server/test/Servant/Server/ErrorSpec.hs+58−2 servant-server/test/Servant/Server/Internal/ContextSpec.hs+1−1 servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs+2−2 servant-server/test/Servant/Server/RouterSpec.hs+129−8 servant-server/test/Servant/ServerSpec.hs+310−126 servant-server/test/doctests.hs−27 servant-swagger/CHANGELOG.md+143 servant-swagger/LICENSE+28 servant-swagger/README.md+46 servant-swagger/Setup.hs+33 servant-swagger/example/LICENSE+28 servant-swagger/example/example.cabal+62 servant-swagger/example/server/Main.hs+11 servant-swagger/example/src/Todo.hs+73 servant-swagger/example/swagger.json+158 servant-swagger/example/test/Spec.hs+1 servant-swagger/example/test/TodoSpec.hs+28 servant-swagger/servant-swagger.cabal+127 servant-swagger/src/Servant/Swagger.hs+188 servant-swagger/src/Servant/Swagger/Internal.hs+492 servant-swagger/src/Servant/Swagger/Internal/Orphans.hs+27 servant-swagger/src/Servant/Swagger/Internal/Test.hs+207 servant-swagger/src/Servant/Swagger/Internal/TypeLevel.hs+9 servant-swagger/src/Servant/Swagger/Internal/TypeLevel/API.hs+86 servant-swagger/src/Servant/Swagger/Internal/TypeLevel/Every.hs+63 servant-swagger/src/Servant/Swagger/Internal/TypeLevel/TMap.hs+37 servant-swagger/src/Servant/Swagger/Test.hs+13 servant-swagger/src/Servant/Swagger/TypeLevel.hs+15 servant-swagger/test/Servant/SwaggerSpec.hs+489 servant-swagger/test/Spec.hs+1 servant-swagger/test/doctests.hs+12 servant/CHANGELOG.md+278−2 servant/Setup.hs+1−32 servant/servant.cabal+36−62 servant/src/Servant/API.hs+27−7 servant/src/Servant/API/Alternative.hs−2 servant/src/Servant/API/ContentTypes.hs+3−3 servant/src/Servant/API/Fragment.hs+25 servant/src/Servant/API/Header.hs+1−1 servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs−6 servant/src/Servant/API/Modifiers.hs−2 servant/src/Servant/API/NamedRoutes.hs+10 servant/src/Servant/API/Raw.hs+3 servant/src/Servant/API/ResponseHeaders.hs+30−9 servant/src/Servant/API/Status.hs+160 servant/src/Servant/API/Stream.hs−2 servant/src/Servant/API/TypeErrors.hs+40 servant/src/Servant/API/TypeLevel.hs+62−12 servant/src/Servant/API/UVerb.hs+127 servant/src/Servant/API/UVerb/Union.hs+147 servant/src/Servant/API/Verbs.hs+2−1 servant/src/Servant/API/WithResource.hs+3 servant/src/Servant/Links.hs+112−14 servant/src/Servant/Test/ComprehensiveAPI.hs+3−1 servant/src/Servant/Types/SourceT.hs+4−1 servant/src/Servant/Utils/Links.hs−6 servant/test/Servant/API/ContentTypesSpec.hs+11 servant/test/Servant/API/ResponseHeadersSpec.hs+11 servant/test/Servant/API/StreamSpec.hs+1−1 servant/test/Servant/LinksSpec.hs+18−1 servant/test/doctests.hs−27 stack.yaml+5−17 stack.yaml.lock+19
.github/FUNDING.yml+1−1
@@ -1,6 +1,6 @@
11# These are supported funding model platforms
22
3−github: # Replace with up to 4 GitHub Sponsors-enabled usernames e.g., [user1, user2]
3+github: [arianvp]
44patreon: # Replace with a single Patreon username
55open_collective: # Replace with a single Open Collective username
66ko_fi: # Replace with a single Ko-fi username
.github/run-ghcjs-tests.shnew file+14
@@ -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.ymlnew file+148
@@ -0,0 +1,148 @@
1+name: CI
2+
3+# Trigger the workflow on push or pull request, but only for the master branch
4+on:
5+ pull_request:
6+ push:
7+ branches: [master]
8+
9+jobs:
10+ cabal:
11+ name: ${{ matrix.os }} / ghc ${{ matrix.ghc }}
12+ runs-on: ${{ matrix.os }}
13+ strategy:
14+ matrix:
15+ os: [ubuntu-latest]
16+ cabal: ["3.6"]
17+ ghc:
18+ - "8.6.5"
19+ - "8.8.4"
20+ - "8.10.7"
21+ - "9.0.2"
22+ - "9.2.2"
23+ - "9.4.2"
24+
25+ steps:
26+ - uses: actions/checkout@v2
27+
28+ - uses: haskell/actions/setup@v1
29+ id: setup-haskell-cabal
30+ name: Setup Haskell
31+ with:
32+ ghc-version: ${{ matrix.ghc }}
33+ cabal-version: ${{ matrix.cabal }}
34+
35+ - name: Freeze
36+ run: |
37+ cabal configure --enable-tests --enable-benchmarks --test-show-details=direct
38+ cabal freeze
39+
40+ - uses: actions/cache@v2.1.3
41+ name: Cache ~/.cabal/store and dist-newstyle
42+ with:
43+ path: |
44+ ${{ steps.setup-haskell-cabal.outputs.cabal-store }}
45+ dist-newstyle
46+ key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }}
47+ restore-keys: |
48+ ${{ runner.os }}-${{ matrix.ghc }}-
49+
50+ - name: Configure
51+ run: |
52+ cabal install --ignore-project -j2 doctest --constraint='doctest ^>=0.20'
53+
54+ - name: Build
55+ run: |
56+ cabal build all
57+
58+ - name: Test
59+ run: |
60+ cabal test all
61+
62+ - name: Run doctests
63+ run: |
64+ # Necessary for doctest to be found in $PATH
65+ export PATH="$HOME/.cabal/bin:$PATH"
66+
67+ DOCTEST="cabal repl --with-ghc=doctest --ghc-options=-w"
68+ (cd servant && eval $DOCTEST)
69+ (cd servant-client && eval $DOCTEST)
70+ (cd servant-client-core && eval $DOCTEST)
71+ (cd servant-http-streams && eval $DOCTEST)
72+ (cd servant-docs && eval $DOCTEST)
73+ (cd servant-foreign && eval $DOCTEST)
74+ (cd servant-server && eval $DOCTEST)
75+ (cd servant-machines && eval $DOCTEST)
76+ (cd servant-conduit && eval $DOCTEST)
77+ (cd servant-pipes && eval $DOCTEST)
78+
79+ # stack:
80+ # name: stack / ghc ${{ matrix.ghc }}
81+ # runs-on: ubuntu-latest
82+ # strategy:
83+ # matrix:
84+ # stack: ["2.7.5"]
85+ # ghc: ["8.10.7"]
86+
87+ # steps:
88+ # - uses: actions/checkout@v2
89+
90+ # - uses: haskell/actions/setup@v1
91+ # name: Setup Haskell Stack
92+ # with:
93+ # ghc-version: ${{ matrix.ghc }}
94+ # stack-version: ${{ matrix.stack }}
95+
96+ # - uses: actions/cache@v2.1.3
97+ # name: Cache ~/.stack
98+ # with:
99+ # path: ~/.stack
100+ # key: ${{ runner.os }}-${{ matrix.ghc }}-stack
101+
102+ # - name: Install dependencies
103+ # run: |
104+ # stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks --only-dependencies
105+
106+ # - name: Build
107+ # run: |
108+ # stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks
109+
110+ # - name: Test
111+ # run: |
112+ # stack test --system-ghc
113+
114+ ghcjs:
115+ name: ubuntu-latest / ghcjs 8.6
116+ runs-on: "ubuntu-latest"
117+
118+ steps:
119+ - uses: actions/checkout@v2
120+ - uses: cachix/install-nix-action@v13
121+ with:
122+ extra_nix_config: |
123+ trusted-public-keys = ryantrinkle.com-1:JJiAKaRv9mWgpVAz8dwewnZe0AzzEAzPkagE9SP5NWI=1aba6f367982bd6dd78ec2fda75ab246a62d32c5 cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY=
124+ substituters = https://nixcache.reflex-frp.org https://cache.nixos.org/
125+ - name: Setup
126+ run: |
127+ # Override cabal.project with the lightweight GHCJS one
128+ cp cabal.ghcjs.project cabal.project
129+ cat cabal.project
130+ nix-shell ghcjs.nix --run "cabal v2-update && cabal v2-freeze"
131+
132+ - uses: actions/cache@v2.1.3
133+ name: Cache ~/.cabal/store and dist-newstyle
134+ with:
135+ path: |
136+ ~/.cabal/store
137+ dist-newstyle
138+ key: ${{ runner.os }}-ghcjs8.6-${{ hashFiles('cabal.project.freeze') }}
139+ restore-keys: |
140+ ${{ runner.os }}-ghcjs8.6-
141+
142+ - name: Build
143+ run: |
144+ nix-shell ghcjs.nix --run "cabal v2-build --ghcjs --enable-tests --enable-benchmarks all"
145+
146+ - name: Tests
147+ run: |
148+ nix-shell ghcjs.nix --run ".github/run-ghcjs-tests.sh"
.gitignore+6
@@ -1,4 +1,5 @@
11**/*/dist
2+*~
23dist-*
34.ghc.environment.*
45/bin
@@ -29,6 +30,11 @@ doc/_build
2930doc/venv
3031doc/tutorial/static/api.js
3132doc/tutorial/static/jq.js
33+shell.nix
34+.hspec-failures
35+
36+# nix
37+result*
3238
3339# local versions of things
3440servant-multipart
.travis.ymldeleted−349
@@ -1,349 +0,0 @@
1−# This Travis job script has been generated by a script via
2−#
3−# haskell-ci '--config=cabal.haskell-ci' '--output=.travis.yml' 'cabal.project'
4−#
5−# For more information, see https://github.com/haskell-CI/haskell-ci
6−#
7−# version: 0.9.20191209
8−#
9−version: ~> 1.0
10−language: c
11−os: linux
12−dist: bionic
13−git:
14− # whether to recursively clone submodules
15− submodules: false
16−branches:
17− only:
18− - master
19−addons:
20− google: stable
21−cache:
22− directories:
23− - $HOME/.cabal/packages
24− - $HOME/.cabal/store
25− - $HOME/.hlint
26−before_cache:
27− - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log
28− # remove files that are regenerated by 'cabal update'
29− - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.*
30− - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json
31− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache
32− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar
33− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx
34− - rm -rfv $CABALHOME/packages/head.hackage
35−jobs:
36− include:
37− - compiler: ghcjs-8.4
38− addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu bionic main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"},{"sourceline":"deb http://ppa.launchpad.net/hvr/ghcjs/ubuntu bionic main"},{"sourceline":"deb https://deb.nodesource.com/node_10.x bionic main","key_url":"https://deb.nodesource.com/gpgkey/nodesource.gpg.key"}],"packages":["ghcjs-8.4","cabal-install-3.0","ghc-8.4.4","nodejs"]}}
39− os: linux
40− - compiler: ghc-8.8.1
41− addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu bionic main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.8.1","cabal-install-3.0"]}}
42− os: linux
43− - compiler: ghc-8.6.5
44− addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu bionic main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.6.5","cabal-install-3.0"]}}
45− os: linux
46− - compiler: ghc-8.4.4
47− addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu bionic main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.4.4","cabal-install-3.0"]}}
48− os: linux
49− - compiler: ghc-8.2.2
50− addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu bionic main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.2.2","cabal-install-3.0"]}}
51− os: linux
52− - compiler: ghc-8.0.2
53− addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu bionic main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.0.2","cabal-install-3.0"]}}
54− os: linux
55−before_install:
56− - |
57− if echo $CC | grep -q ghcjs; then
58− GHCJS=true;
59− else
60− GHCJS=false;
61− fi
62− - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//')
63− - WITHCOMPILER="-w $HC"
64− - if $GHCJS ; then HC=${HC}js ; fi
65− - if $GHCJS ; then WITHCOMPILER="--ghcjs ${WITHCOMPILER}js" ; fi
66− - HADDOCK=$(echo "/opt/$CC/bin/haddock" | sed 's/-/\//')
67− - if $GHCJS ; then PATH="/opt/ghc/8.4.4/bin:$PATH" ; fi
68− - HCPKG="$HC-pkg"
69− - unset CC
70− - CABAL=/opt/ghc/bin/cabal
71− - CABALHOME=$HOME/.cabal
72− - export PATH="$CABALHOME/bin:$PATH"
73− - TOP=$(pwd)
74− - "HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\\d+)\\.(\\d+)\\.(\\d+)(\\.(\\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')"
75− - echo $HCNUMVER
76− - CABAL="$CABAL -vnormal+nowrap+markoutput"
77− - set -o pipefail
78− - |
79− echo 'function blue(s) { printf "\033[0;34m" s "\033[0m " }' >> .colorful.awk
80− echo 'BEGIN { state = "output"; }' >> .colorful.awk
81− echo '/^-----BEGIN CABAL OUTPUT-----$/ { state = "cabal" }' >> .colorful.awk
82− echo '/^-----END CABAL OUTPUT-----$/ { state = "output" }' >> .colorful.awk
83− echo '!/^(-----BEGIN CABAL OUTPUT-----|-----END CABAL OUTPUT-----)/ {' >> .colorful.awk
84− echo ' if (state == "cabal") {' >> .colorful.awk
85− echo ' print blue($0)' >> .colorful.awk
86− echo ' } else {' >> .colorful.awk
87− echo ' print $0' >> .colorful.awk
88− echo ' }' >> .colorful.awk
89− echo '}' >> .colorful.awk
90− - cat .colorful.awk
91− - |
92− color_cabal_output () {
93− awk -f $TOP/.colorful.awk
94− }
95− - echo text | color_cabal_output
96−install:
97− - ${CABAL} --version
98− - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"
99− - node --version
100− - echo $GHCJS
101− - TEST=--enable-tests
102− - BENCH=--enable-benchmarks
103− - HEADHACKAGE=false
104− - rm -f $CABALHOME/config
105− - |
106− echo "verbose: normal +nowrap +markoutput" >> $CABALHOME/config
107− echo "remote-build-reporting: anonymous" >> $CABALHOME/config
108− echo "write-ghc-environment-files: always" >> $CABALHOME/config
109− echo "remote-repo-cache: $CABALHOME/packages" >> $CABALHOME/config
110− echo "logs-dir: $CABALHOME/logs" >> $CABALHOME/config
111− echo "world-file: $CABALHOME/world" >> $CABALHOME/config
112− echo "extra-prog-path: $CABALHOME/bin" >> $CABALHOME/config
113− echo "symlink-bindir: $CABALHOME/bin" >> $CABALHOME/config
114− echo "installdir: $CABALHOME/bin" >> $CABALHOME/config
115− echo "build-summary: $CABALHOME/logs/build.log" >> $CABALHOME/config
116− echo "store-dir: $CABALHOME/store" >> $CABALHOME/config
117− echo "install-dirs user" >> $CABALHOME/config
118− echo " prefix: $CABALHOME" >> $CABALHOME/config
119− echo "repository hackage.haskell.org" >> $CABALHOME/config
120− echo " url: http://hackage.haskell.org/" >> $CABALHOME/config
121− echo " secure: True" >> $CABALHOME/config
122− echo " key-threshold: 3" >> $CABALHOME/config
123− echo " root-keys:" >> $CABALHOME/config
124− echo " fe331502606802feac15e514d9b9ea83fee8b6ffef71335479a2e68d84adc6b0" >> $CABALHOME/config
125− echo " 1ea9ba32c526d1cc91ab5e5bd364ec5e9e8cb67179a471872f6e26f0ae773d42" >> $CABALHOME/config
126− echo " 2c6c3627bd6c982990239487f1abd02e08a02e6cf16edb105a8012d444d870c3" >> $CABALHOME/config
127− echo " 0a5c7ea47cd1b15f01f5f51a33adda7e655bc0f0b0615baa8e271f4c3351e21d" >> $CABALHOME/config
128− echo " 51f0161b906011b52c6613376b1ae937670da69322113a246a09f807c62f6921" >> $CABALHOME/config
129− - GHCJOBS=-j2
130− - |
131− echo "program-default-options" >> $CABALHOME/config
132− echo " ghc-options: $GHCJOBS +RTS -M6G -RTS" >> $CABALHOME/config
133− - cat $CABALHOME/config
134− - rm -fv cabal.project cabal.project.local cabal.project.freeze
135− - travis_retry ${CABAL} v2-update -v
136− - if $GHCJS ; then (cd /tmp && ${CABAL} v2-install -w ghc-8.4.4 cabal-plan --constraint='cabal-plan ^>=0.6.0.0' --constraint='cabal-plan +exe' | color_cabal_output) ; fi
137− - if $GHCJS ; then (cd /tmp && ${CABAL} v2-install -w ghc-8.4.4 hspec-discover | color_cabal_output) ; fi
138− # Generate cabal.project
139− - rm -rf cabal.project cabal.project.local cabal.project.freeze
140− - touch cabal.project
141− - |
142− echo "packages: servant" >> cabal.project
143− if ! $GHCJS ; then echo "packages: servant-client" >> cabal.project ; fi
144− echo "packages: servant-client-core" >> cabal.project
145− if ! $GHCJS ; then echo "packages: servant-http-streams" >> cabal.project ; fi
146− if ! $GHCJS ; then echo "packages: servant-docs" >> cabal.project ; fi
147− if ! $GHCJS ; then echo "packages: servant-foreign" >> cabal.project ; fi
148− if ! $GHCJS ; then echo "packages: servant-server" >> cabal.project ; fi
149− if ! $GHCJS ; then echo "packages: doc/tutorial" >> cabal.project ; fi
150− if ! $GHCJS ; then echo "packages: servant-machines" >> cabal.project ; fi
151− if ! $GHCJS ; then echo "packages: servant-conduit" >> cabal.project ; fi
152− if ! $GHCJS ; then echo "packages: servant-pipes" >> cabal.project ; fi
153− if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: doc/cookbook/basic-auth" >> cabal.project ; fi
154− if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: doc/cookbook/curl-mock" >> cabal.project ; fi
155− if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: doc/cookbook/basic-streaming" >> cabal.project ; fi
156− if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: doc/cookbook/db-postgres-pool" >> cabal.project ; fi
157− if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: doc/cookbook/file-upload" >> cabal.project ; fi
158− if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: doc/cookbook/generic" >> cabal.project ; fi
159− if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: doc/cookbook/pagination" >> cabal.project ; fi
160− if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: doc/cookbook/testing" >> cabal.project ; fi
161− if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: doc/cookbook/structuring-apis" >> cabal.project ; fi
162− if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: doc/cookbook/using-custom-monad" >> cabal.project ; fi
163− if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: doc/cookbook/using-free-client" >> cabal.project ; fi
164− - |
165− echo "constraints: foundation >=0.0.14" >> cabal.project
166− echo "constraints: memory <0.14.12 || >0.14.12" >> cabal.project
167− echo "constraints: sqlite-simple < 0" >> cabal.project
168− echo "constraints: base-compat ^>=0.11" >> cabal.project
169− echo "allow-newer: aeson-pretty-0.8.7:base-compat" >> cabal.project
170− echo "allow-newer: vault-0.3.1.2:hashable" >> cabal.project
171− echo "allow-newer: psqueues-0.2.7.1:hashable" >> cabal.project
172− echo "allow-newer: sqlite-simple-0.4.16.0:semigroups" >> cabal.project
173− echo "allow-newer: direct-sqlite-2.3.24:semigroups" >> cabal.project
174− echo "allow-newer: io-streams-1.5.1.0:network" >> cabal.project
175− echo "allow-newer: io-streams-1.5.1.0:primitive" >> cabal.project
176− echo "allow-newer: openssl-streams-1.2.2.0:network" >> cabal.project
177− echo "allow-newer: jsaddle-0.9.6.0:lens" >> cabal.project
178− echo "allow-newer: jsaddle-0.9.6.0:primitive" >> cabal.project
179− echo "allow-newer: jsaddle-0.9.6.0:time" >> cabal.project
180− echo "allow-newer: jsaddle-dom-0.9.3.1:base" >> cabal.project
181− echo "allow-newer: jsaddle-dom-0.9.3.1:base-compat" >> cabal.project
182− echo "allow-newer: jsaddle-dom-0.9.3.1:Cabal" >> cabal.project
183− echo "allow-newer: jsaddle-dom-0.9.3.1:lens" >> cabal.project
184− echo "allow-newer: jsaddle-dom-0.9.3.2:base" >> cabal.project
185− echo "allow-newer: jsaddle-dom-0.9.3.2:base-compat" >> cabal.project
186− echo "allow-newer: jsaddle-dom-0.9.3.2:Cabal" >> cabal.project
187− echo "allow-newer: jsaddle-dom-0.9.3.2:lens" >> cabal.project
188− echo "allow-newer: jsaddle-warp-0.9.6.0:time" >> cabal.project
189− echo "optimization: False" >> cabal.project
190− - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(cookbook-basic-auth|cookbook-basic-streaming|cookbook-curl-mock|cookbook-db-postgres-pool|cookbook-file-upload|cookbook-generic|cookbook-pagination|cookbook-structuring-apis|cookbook-testing|cookbook-using-custom-monad|cookbook-using-free-client|servant|servant-client|servant-client-core|servant-conduit|servant-docs|servant-foreign|servant-http-streams|servant-machines|servant-pipes|servant-server|tutorial)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"
191− - cat cabal.project || true
192− - cat cabal.project.local || true
193− - if [ -f "servant/configure.ac" ]; then (cd "servant" && autoreconf -i); fi
194− - if [ -f "servant-client/configure.ac" ]; then (cd "servant-client" && autoreconf -i); fi
195− - if [ -f "servant-client-core/configure.ac" ]; then (cd "servant-client-core" && autoreconf -i); fi
196− - if [ -f "servant-http-streams/configure.ac" ]; then (cd "servant-http-streams" && autoreconf -i); fi
197− - if [ -f "servant-docs/configure.ac" ]; then (cd "servant-docs" && autoreconf -i); fi
198− - if [ -f "servant-foreign/configure.ac" ]; then (cd "servant-foreign" && autoreconf -i); fi
199− - if [ -f "servant-server/configure.ac" ]; then (cd "servant-server" && autoreconf -i); fi
200− - if [ -f "doc/tutorial/configure.ac" ]; then (cd "doc/tutorial" && autoreconf -i); fi
201− - if [ -f "servant-machines/configure.ac" ]; then (cd "servant-machines" && autoreconf -i); fi
202− - if [ -f "servant-conduit/configure.ac" ]; then (cd "servant-conduit" && autoreconf -i); fi
203− - if [ -f "servant-pipes/configure.ac" ]; then (cd "servant-pipes" && autoreconf -i); fi
204− - if [ -f "doc/cookbook/basic-auth/configure.ac" ]; then (cd "doc/cookbook/basic-auth" && autoreconf -i); fi
205− - if [ -f "doc/cookbook/curl-mock/configure.ac" ]; then (cd "doc/cookbook/curl-mock" && autoreconf -i); fi
206− - if [ -f "doc/cookbook/basic-streaming/configure.ac" ]; then (cd "doc/cookbook/basic-streaming" && autoreconf -i); fi
207− - if [ -f "doc/cookbook/db-postgres-pool/configure.ac" ]; then (cd "doc/cookbook/db-postgres-pool" && autoreconf -i); fi
208− - if [ -f "doc/cookbook/file-upload/configure.ac" ]; then (cd "doc/cookbook/file-upload" && autoreconf -i); fi
209− - if [ -f "doc/cookbook/generic/configure.ac" ]; then (cd "doc/cookbook/generic" && autoreconf -i); fi
210− - if [ -f "doc/cookbook/pagination/configure.ac" ]; then (cd "doc/cookbook/pagination" && autoreconf -i); fi
211− - if [ -f "doc/cookbook/testing/configure.ac" ]; then (cd "doc/cookbook/testing" && autoreconf -i); fi
212− - if [ -f "doc/cookbook/structuring-apis/configure.ac" ]; then (cd "doc/cookbook/structuring-apis" && autoreconf -i); fi
213− - if [ -f "doc/cookbook/using-custom-monad/configure.ac" ]; then (cd "doc/cookbook/using-custom-monad" && autoreconf -i); fi
214− - if [ -f "doc/cookbook/using-free-client/configure.ac" ]; then (cd "doc/cookbook/using-free-client" && autoreconf -i); fi
215− - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH} | color_cabal_output
216− - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'"
217− - rm cabal.project.freeze
218−script:
219− - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
220− # Packaging...
221− - echo 'Packaging...' && echo -en 'travis_fold:start:sdist\\r'
222− - ${CABAL} v2-sdist all | color_cabal_output
223− - echo -en 'travis_fold:end:sdist\\r'
224− # Unpacking...
225− - echo 'Unpacking...' && echo -en 'travis_fold:start:unpack\\r'
226− - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/
227− - cd ${DISTDIR} || false
228− - find . -maxdepth 1 -type f -name '*.tar.gz' -exec tar -xvf '{}' \;
229− - find . -maxdepth 1 -type f -name '*.tar.gz' -exec rm '{}' \;
230− - PKGDIR_servant="$(find . -maxdepth 1 -type d -regex '.*/servant-[0-9.]*')"
231− - PKGDIR_servant_client="$(find . -maxdepth 1 -type d -regex '.*/servant-client-[0-9.]*')"
232− - PKGDIR_servant_client_core="$(find . -maxdepth 1 -type d -regex '.*/servant-client-core-[0-9.]*')"
233− - PKGDIR_servant_http_streams="$(find . -maxdepth 1 -type d -regex '.*/servant-http-streams-[0-9.]*')"
234− - PKGDIR_servant_docs="$(find . -maxdepth 1 -type d -regex '.*/servant-docs-[0-9.]*')"
235− - PKGDIR_servant_foreign="$(find . -maxdepth 1 -type d -regex '.*/servant-foreign-[0-9.]*')"
236− - PKGDIR_servant_server="$(find . -maxdepth 1 -type d -regex '.*/servant-server-[0-9.]*')"
237− - PKGDIR_tutorial="$(find . -maxdepth 1 -type d -regex '.*/tutorial-[0-9.]*')"
238− - PKGDIR_servant_machines="$(find . -maxdepth 1 -type d -regex '.*/servant-machines-[0-9.]*')"
239− - PKGDIR_servant_conduit="$(find . -maxdepth 1 -type d -regex '.*/servant-conduit-[0-9.]*')"
240− - PKGDIR_servant_pipes="$(find . -maxdepth 1 -type d -regex '.*/servant-pipes-[0-9.]*')"
241− - PKGDIR_cookbook_basic_auth="$(find . -maxdepth 1 -type d -regex '.*/cookbook-basic-auth-[0-9.]*')"
242− - PKGDIR_cookbook_curl_mock="$(find . -maxdepth 1 -type d -regex '.*/cookbook-curl-mock-[0-9.]*')"
243− - PKGDIR_cookbook_basic_streaming="$(find . -maxdepth 1 -type d -regex '.*/cookbook-basic-streaming-[0-9.]*')"
244− - PKGDIR_cookbook_db_postgres_pool="$(find . -maxdepth 1 -type d -regex '.*/cookbook-db-postgres-pool-[0-9.]*')"
245− - PKGDIR_cookbook_file_upload="$(find . -maxdepth 1 -type d -regex '.*/cookbook-file-upload-[0-9.]*')"
246− - PKGDIR_cookbook_generic="$(find . -maxdepth 1 -type d -regex '.*/cookbook-generic-[0-9.]*')"
247− - PKGDIR_cookbook_pagination="$(find . -maxdepth 1 -type d -regex '.*/cookbook-pagination-[0-9.]*')"
248− - PKGDIR_cookbook_testing="$(find . -maxdepth 1 -type d -regex '.*/cookbook-testing-[0-9.]*')"
249− - PKGDIR_cookbook_structuring_apis="$(find . -maxdepth 1 -type d -regex '.*/cookbook-structuring-apis-[0-9.]*')"
250− - PKGDIR_cookbook_using_custom_monad="$(find . -maxdepth 1 -type d -regex '.*/cookbook-using-custom-monad-[0-9.]*')"
251− - PKGDIR_cookbook_using_free_client="$(find . -maxdepth 1 -type d -regex '.*/cookbook-using-free-client-[0-9.]*')"
252− # Generate cabal.project
253− - rm -rf cabal.project cabal.project.local cabal.project.freeze
254− - touch cabal.project
255− - |
256− echo "packages: ${PKGDIR_servant}" >> cabal.project
257− if ! $GHCJS ; then echo "packages: ${PKGDIR_servant_client}" >> cabal.project ; fi
258− echo "packages: ${PKGDIR_servant_client_core}" >> cabal.project
259− if ! $GHCJS ; then echo "packages: ${PKGDIR_servant_http_streams}" >> cabal.project ; fi
260− if ! $GHCJS ; then echo "packages: ${PKGDIR_servant_docs}" >> cabal.project ; fi
261− if ! $GHCJS ; then echo "packages: ${PKGDIR_servant_foreign}" >> cabal.project ; fi
262− if ! $GHCJS ; then echo "packages: ${PKGDIR_servant_server}" >> cabal.project ; fi
263− if ! $GHCJS ; then echo "packages: ${PKGDIR_tutorial}" >> cabal.project ; fi
264− if ! $GHCJS ; then echo "packages: ${PKGDIR_servant_machines}" >> cabal.project ; fi
265− if ! $GHCJS ; then echo "packages: ${PKGDIR_servant_conduit}" >> cabal.project ; fi
266− if ! $GHCJS ; then echo "packages: ${PKGDIR_servant_pipes}" >> cabal.project ; fi
267− if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: ${PKGDIR_cookbook_basic_auth}" >> cabal.project ; fi
268− if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: ${PKGDIR_cookbook_curl_mock}" >> cabal.project ; fi
269− if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: ${PKGDIR_cookbook_basic_streaming}" >> cabal.project ; fi
270− if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: ${PKGDIR_cookbook_db_postgres_pool}" >> cabal.project ; fi
271− if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: ${PKGDIR_cookbook_file_upload}" >> cabal.project ; fi
272− if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: ${PKGDIR_cookbook_generic}" >> cabal.project ; fi
273− if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: ${PKGDIR_cookbook_pagination}" >> cabal.project ; fi
274− if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: ${PKGDIR_cookbook_testing}" >> cabal.project ; fi
275− if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: ${PKGDIR_cookbook_structuring_apis}" >> cabal.project ; fi
276− if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: ${PKGDIR_cookbook_using_custom_monad}" >> cabal.project ; fi
277− if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: ${PKGDIR_cookbook_using_free_client}" >> cabal.project ; fi
278− - |
279− echo "constraints: foundation >=0.0.14" >> cabal.project
280− echo "constraints: memory <0.14.12 || >0.14.12" >> cabal.project
281− echo "constraints: sqlite-simple < 0" >> cabal.project
282− echo "constraints: base-compat ^>=0.11" >> cabal.project
283− echo "allow-newer: aeson-pretty-0.8.7:base-compat" >> cabal.project
284− echo "allow-newer: vault-0.3.1.2:hashable" >> cabal.project
285− echo "allow-newer: psqueues-0.2.7.1:hashable" >> cabal.project
286− echo "allow-newer: sqlite-simple-0.4.16.0:semigroups" >> cabal.project
287− echo "allow-newer: direct-sqlite-2.3.24:semigroups" >> cabal.project
288− echo "allow-newer: io-streams-1.5.1.0:network" >> cabal.project
289− echo "allow-newer: io-streams-1.5.1.0:primitive" >> cabal.project
290− echo "allow-newer: openssl-streams-1.2.2.0:network" >> cabal.project
291− echo "allow-newer: jsaddle-0.9.6.0:lens" >> cabal.project
292− echo "allow-newer: jsaddle-0.9.6.0:primitive" >> cabal.project
293− echo "allow-newer: jsaddle-0.9.6.0:time" >> cabal.project
294− echo "allow-newer: jsaddle-dom-0.9.3.1:base" >> cabal.project
295− echo "allow-newer: jsaddle-dom-0.9.3.1:base-compat" >> cabal.project
296− echo "allow-newer: jsaddle-dom-0.9.3.1:Cabal" >> cabal.project
297− echo "allow-newer: jsaddle-dom-0.9.3.1:lens" >> cabal.project
298− echo "allow-newer: jsaddle-dom-0.9.3.2:base" >> cabal.project
299− echo "allow-newer: jsaddle-dom-0.9.3.2:base-compat" >> cabal.project
300− echo "allow-newer: jsaddle-dom-0.9.3.2:Cabal" >> cabal.project
301− echo "allow-newer: jsaddle-dom-0.9.3.2:lens" >> cabal.project
302− echo "allow-newer: jsaddle-warp-0.9.6.0:time" >> cabal.project
303− echo "optimization: False" >> cabal.project
304− - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(cookbook-basic-auth|cookbook-basic-streaming|cookbook-curl-mock|cookbook-db-postgres-pool|cookbook-file-upload|cookbook-generic|cookbook-pagination|cookbook-structuring-apis|cookbook-testing|cookbook-using-custom-monad|cookbook-using-free-client|servant|servant-client|servant-client-core|servant-conduit|servant-docs|servant-foreign|servant-http-streams|servant-machines|servant-pipes|servant-server|tutorial)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"
305− - cat cabal.project || true
306− - cat cabal.project.local || true
307− - |
308− pkgdir() {
309− case $1 in
310− servant) echo ${PKGDIR_servant} ;;
311− servant-client) echo ${PKGDIR_servant_client} ;;
312− servant-client-core) echo ${PKGDIR_servant_client_core} ;;
313− servant-http-streams) echo ${PKGDIR_servant_http_streams} ;;
314− servant-docs) echo ${PKGDIR_servant_docs} ;;
315− servant-foreign) echo ${PKGDIR_servant_foreign} ;;
316− servant-server) echo ${PKGDIR_servant_server} ;;
317− tutorial) echo ${PKGDIR_tutorial} ;;
318− servant-machines) echo ${PKGDIR_servant_machines} ;;
319− servant-conduit) echo ${PKGDIR_servant_conduit} ;;
320− servant-pipes) echo ${PKGDIR_servant_pipes} ;;
321− cookbook-basic-auth) echo ${PKGDIR_cookbook_basic_auth} ;;
322− cookbook-curl-mock) echo ${PKGDIR_cookbook_curl_mock} ;;
323− cookbook-basic-streaming) echo ${PKGDIR_cookbook_basic_streaming} ;;
324− cookbook-db-postgres-pool) echo ${PKGDIR_cookbook_db_postgres_pool} ;;
325− cookbook-file-upload) echo ${PKGDIR_cookbook_file_upload} ;;
326− cookbook-generic) echo ${PKGDIR_cookbook_generic} ;;
327− cookbook-pagination) echo ${PKGDIR_cookbook_pagination} ;;
328− cookbook-testing) echo ${PKGDIR_cookbook_testing} ;;
329− cookbook-structuring-apis) echo ${PKGDIR_cookbook_structuring_apis} ;;
330− cookbook-using-custom-monad) echo ${PKGDIR_cookbook_using_custom_monad} ;;
331− cookbook-using-free-client) echo ${PKGDIR_cookbook_using_free_client} ;;
332− esac
333− }
334− - echo -en 'travis_fold:end:unpack\\r'
335− # Building with tests and benchmarks...
336− - echo 'Building with tests and benchmarks...' && echo -en 'travis_fold:start:build-everything\\r'
337− # build & run tests, build benchmarks
338− - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output
339− - echo -en 'travis_fold:end:build-everything\\r'
340− # Testing...
341− - if ! $GHCJS ; then ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output ; fi
342− - if $GHCJS ; then 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 ; fi
343− # haddock...
344− - echo 'haddock...' && echo -en 'travis_fold:start:haddock\\r'
345− - if ! $GHCJS ; then ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all | color_cabal_output ; fi
346− - echo -en 'travis_fold:end:haddock\\r'
347−
348−# REGENDATA ("0.9.20191209",["--config=cabal.haskell-ci","--output=.travis.yml","cabal.project"])
349−# EOF
CONTRIBUTING.md+5−3
@@ -79,8 +79,10 @@ not been a timely response to a PR, you can ping the Maintainers group (with
7979We encourage people to experiment with new combinators and instances - it is
8080one of the most powerful ways of using `servant`, and a wonderful way of
8181getting 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
83−issue with the `news` tag (which we will close when we read it).
82+know about it! Either hop on
83+[#haskell-servant on libera.chat](https://web.libera.chat/#haskell-servant) and
84+let us know, or open an issue with the `news` tag (which we will close when we
85+read it).
8486
8587As for adding them to the main repo: maintaining combinators can be expensive,
8688since official combinators must have instances for all classes (and new classes
@@ -103,7 +105,7 @@ the `news` label if you make a new package so we can know about it!
103105
104106## Release policy
105107
106−We are currently moving to a more aggresive release policy, so that you can get
108+We are currently moving to a more aggressive release policy, so that you can get
107109what you contribute from Hackage fairly soon. However, note that prior to major
108110releases it may take some time in between releases.
109111
Makefiledeleted−22
@@ -1,22 +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
README.md+12−26
@@ -9,11 +9,11 @@ introduces the core features of servant. After this article, you should be able
99to write your first servant webservices, learning the rest from the haddocks'
1010examples.
1111
12−The central documentation can be found [here](http://docs.servant.dev/).
12+The core documentation can be found [here](http://docs.servant.dev/).
1313Other blog posts, videos and slides can be found on the
1414[website](http://www.servant.dev/).
1515
16−If you need help, drop by the IRC channel (#servant on freenode) or [mailing
16+If you need help, drop by the IRC channel (#haskell-servant on libera.chat) or [mailing
1717list](https://groups.google.com/forum/#!forum/haskell-servant).
1818
1919## Contributing
@@ -32,7 +32,7 @@ See `CONTRIBUTING.md`
3232 - It's a good idea to separate these steps, as tests often pass, if they compile :)
3333 - See `cabal.project` to selectively `allow-newer`
3434 - If some packages are broken, on your discretisation there are two options:
35− - Fix them and make PRs: it's good idea to test against older `servant` version too.
35+ - Fix them and make PRs: it's a good idea to test against older `servant` version too.
3636 - Temporarily comment out broken package
3737 - If you make a commit for `servant-universe`, you can use it as submodule in private projects to test even more
3838- When ripples are cleared out:
@@ -40,29 +40,9 @@ See `CONTRIBUTING.md`
4040 - `git push --tags`
4141 - `cabal sdist` and `cabal upload`
4242
43−## travis
43+## TechEmpower framework benchmarks
4444
45−`.travis.yml` is generated using `make-travis-yml` tool, in
46−[multi-ghc-travis](https://github.com/haskell-hvr/multi-ghc-travis) repository.
47−
48−To regenerate the script use (*note:* atm you need to comment `doc/cookbook/` packages).
49−
50−```sh
51−runghc ~/Documents/other-haskell/multi-ghc-travis/make_travis_yml_2.hs regenerate
52−```
53−
54−In case Travis jobs fail due failing build of dependency, you can temporarily
55−add `constraints` to the `cabal.project`, and regenerate the `.travis.yml`.
56−For example, the following will disallow single `troublemaker-13.37` package version:
57−
58−```
59−constraints:
60− troublemaker <13.37 && > 13.37
61−```
62−
63−## TechEmpower framework bechmarks
64−
65−We develop & maintain the servant TFB entry in https://github.com/haskell-servant/FrameworkBenchmarks/
45+We develop and maintain the servant TFB entry in https://github.com/haskell-servant/FrameworkBenchmarks/
6646
6747To verify (i.e. compile and test that it works)
6848
@@ -82,4 +62,10 @@ To compare with `reitit` (Clojure framework)
8262./tfb --mode benchmark --test reitit reitit-async reitit-jdbc servant servant-beam servant-psql-simple --type json plaintext db fortune
8363```
8464
85−And visualise the results at https://www.techempower.com/benchmarks/#section=test
65+You can see the visualised results at https://www.techempower.com/benchmarks/#section=test
66+
67+## Nix
68+
69+A developer shell.nix file is provided in the `nix` directory
70+
71+See [nix/README.md](nix/README.md)
cabal.ghcjs.project+5−1
@@ -2,9 +2,13 @@
22
33packages:
44 servant/
5+ servant-client/
56 servant-client-core/
6− servant-jsaddle/
77
88-- we need to tell cabal we are using GHCJS
99compiler: ghcjs
1010tests: 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.haskell-cideleted−22
@@ -1,22 +0,0 @@
1−distribution: bionic
2−folds: all-but-test
3−branches: master
4−jobs-selection: any
5−google-chrome: True
6−ghcjs-tests: True
7−
8−-- https://github.com/haskell/cabal/issues/6176
9−ghcjs-tools: hspec-discover
10−
11−-- We have inplace packages (servant-js) so we skip installing dependencies in a separate step
12−install-dependencies: False
13−
14−-- this speed-ups the build a little, but we have to check these for release
15−no-tests-no-benchmarks: False
16−unconstrained: False
17−
18−-- Don't run cabal check, as cookbook examples won't pass it
19−cabal-check: False
20−
21−-- ghc-options: -j2
22−jobs: :2
cabal.project+16−40
@@ -1,11 +1,18 @@
11packages:
22 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+
39 servant-client/
410 servant-client-core/
511 servant-http-streams/
612 servant-docs/
713 servant-foreign/
814 servant-server/
15+ servant-swagger/
916 doc/tutorial/
1017
1118-- servant streaming
@@ -22,57 +29,26 @@ packages:
2229packages:
2330 doc/cookbook/basic-auth
2431 doc/cookbook/curl-mock
32+ doc/cookbook/custom-errors
2533 doc/cookbook/basic-streaming
2634 doc/cookbook/db-postgres-pool
27−-- doc/cookbook/db-sqlite-simple
35+ doc/cookbook/db-sqlite-simple
2836 doc/cookbook/file-upload
2937 doc/cookbook/generic
30− -- doc/cookbook/hoist-server-with-context
31−-- doc/cookbook/https
32− -- doc/cookbook/jwt-and-basic-auth/
38+ doc/cookbook/hoist-server-with-context
39+ doc/cookbook/https
40+ doc/cookbook/jwt-and-basic-auth
3341 doc/cookbook/pagination
3442 -- doc/cookbook/sentry
35− doc/cookbook/testing
43+ -- Commented out because servant-quickcheck currently doesn't build.
44+ -- doc/cookbook/testing
45+ doc/cookbook/uverb
3646 doc/cookbook/structuring-apis
3747 doc/cookbook/using-custom-monad
3848 doc/cookbook/using-free-client
3949 -- doc/cookbook/open-id-connect
50+ doc/cookbook/managed-resource
4051
4152tests: True
4253optimization: False
4354-- reorder-goals: True
44−
45−constraints:
46− -- see https://github.com/haskell-infra/hackage-trustees/issues/119
47− foundation >=0.0.14,
48− memory <0.14.12 || >0.14.12
49−
50−allow-newer: aeson-pretty-0.8.7:base-compat
51−
52−allow-newer: vault-0.3.1.2:hashable
53−allow-newer: psqueues-0.2.7.1:hashable
54−allow-newer: sqlite-simple-0.4.16.0:semigroups
55−allow-newer: direct-sqlite-2.3.24:semigroups
56−allow-newer: io-streams-1.5.1.0:network
57−allow-newer: io-streams-1.5.1.0:primitive
58−allow-newer: openssl-streams-1.2.2.0:network
59−
60−-- MonadFail
61−-- https://github.com/nurpax/sqlite-simple/issues/74
62−constraints: sqlite-simple < 0
63−
64−-- jsaddle
65−allow-newer: jsaddle-0.9.6.0:lens
66−allow-newer: jsaddle-0.9.6.0:primitive
67−allow-newer: jsaddle-0.9.6.0:time
68−allow-newer: jsaddle-dom-0.9.3.1:base
69−allow-newer: jsaddle-dom-0.9.3.1:base-compat
70−allow-newer: jsaddle-dom-0.9.3.1:Cabal
71−allow-newer: jsaddle-dom-0.9.3.1:lens
72−allow-newer: jsaddle-dom-0.9.3.2:base
73−allow-newer: jsaddle-dom-0.9.3.2:base-compat
74−allow-newer: jsaddle-dom-0.9.3.2:Cabal
75−allow-newer: jsaddle-dom-0.9.3.2:lens
76−allow-newer: jsaddle-warp-0.9.6.0:time
77−
78−constraints: base-compat ^>=0.11
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/confignew file+2
@@ -0,0 +1,2 @@
1+organization: haskell-servant
2+repository: servant
changelog.d/issue1028deleted−10
@@ -1,10 +0,0 @@
1−synopsis: Add NoContentVerb
2−prs: #1228 #1219
3−issues: #1028
4−significance: significant
5−
6−description: {
7−
8−TBW
9−
10−}
changelog.d/issue1200deleted−10
@@ -1,10 +0,0 @@
1−synopsis: Fix Verb with headers checking content type differently
2−prs: #1204
3−issues: #1200
4−packages: servant-client servant-client-core servant-http-streams
5−
6−description: {
7−
8−TBW
9−
10−}
changelog.d/issue1206deleted−13
@@ -1,13 +0,0 @@
1−synopsis: Fix broken links in Tutorial documentation.
2−issues: #1206
3−
4−description: {
5−
6− In servant/doc/tutorial/Client.lhs, several links point to an .lhs file,
7− which show as broken in the live web documentation. Changing the suffix to
8− .html displays the correct documentation.
9−
10− In servant/doc/tutorial/Authentication.lhs, a link to GHC documentation for
11− Type Families pointed to a 404'd page. A link to existing GHC documentation
12− was substituted.
13−}
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+}
changelog.d/tododeleted−7
@@ -1,7 +0,0 @@
1−synopsis: unclassified pull requests
2−prs: #1229 #1224 #1226 #1216 #1214 #1194
3−prs: #1194 #1201 #1198 #1197 #1190 #1188
4−prs: #1183 #1181 #1182 #1175 #1175 #1174
5−prs: #1173 #1171 #1154 #1162 #1157 #1159
6−prs: #1156
7−prs: #1233
changelog.d/z-changelog-ddeleted−8
@@ -1,8 +0,0 @@
1−synopsis: Try changelog-d for changelog management
2−prs: #1230
3−
4−description: {
5−
6−Check the [CONTRIBUTING.md](https://github.com/haskell-servant/servant/blob/master/CONTRIBUTING.md) for details
7−
8−}
default.nixnew file+38
@@ -0,0 +1,38 @@
1+with (builtins.fromJSON (builtins.readFile ./nix/nixpkgs.json));
2+{
3+ pkgs ? import (builtins.fetchTarball {
4+ url = "https://github.com/NixOS/nixpkgs/archive/${rev}.tar.gz";
5+ inherit sha256;
6+ }) {}
7+, compiler ? "ghc883"
8+}:
9+let
10+ overrides = self: super: {
11+ servant = self.callCabal2nix "servant" ./servant {};
12+ servant-docs = self.callCabal2nix "servant-docs" ./servant-docs {};
13+ servant-pipes = self.callCabal2nix "servant-pipes" ./servant-pipes {};
14+ servant-server = self.callCabal2nix "servant-server" ./servant-server {};
15+ servant-client = self.callCabal2nix "servant-client" ./servant-client {};
16+ servant-foreign = self.callCabal2nix "servant-foreign" ./servant-foreign {};
17+ servant-conduit = self.callCabal2nix "servant-conduit" ./servant-conduit {};
18+ servant-machines = self.callCabal2nix "servant-machines" ./servant-machines {};
19+ servant-client-core = self.callCabal2nix "servant-client-core" ./servant-client-core {};
20+ servant-http-streams = self.callCabal2nix "servant-http-streams" ./servant-http-streams {};
21+ };
22+ hPkgs = pkgs.haskell.packages.${compiler}.override { inherit overrides; };
23+in
24+ with hPkgs;
25+ {
26+ inherit
27+ servant
28+ servant-client
29+ servant-client-core
30+ servant-conduit
31+ servant-docs
32+ servant-foreign
33+ servant-http-streams
34+ servant-machines
35+ servant-pipes
36+ servant-server;
37+ }
38+
doc/Makefile+1−1
@@ -10,7 +10,7 @@ BUILDDIR = _build
1010
1111# Put it first so that "make" without argument is like "make help".
1212help:
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
1414 @if [ ! "z$$(which $(SPHINXBUILD))" = "z$$(pwd)/venv/bin/sphinx-build" ]; then echo "WARNING: Did you forgot to 'source venv/bin/activate'"; fi
1515 @$(SPHINXBUILD) -M help "$(SOURCEDIR)" "$(BUILDDIR)" $(SPHINXOPTS) $(O)
1616
doc/conf.py+1−2
@@ -46,7 +46,7 @@ master_doc = 'index'
4646
4747# General information about the project.
4848project = u'Servant'
49−copyright = u'2018, Servant Contributors'
49+copyright = u'2022, Servant Contributors'
5050author = u'Servant Contributors'
5151
5252# The version info for the project you're documenting, acts as replacement for
@@ -169,4 +169,3 @@ texinfo_documents = [
169169source_parsers = {
170170 '.lhs': CommonMarkParser,
171171}
172−
doc/cookbook/basic-auth/basic-auth.cabal+3−3
@@ -1,14 +1,14 @@
1+cabal-version: 2.2
12name: cookbook-basic-auth
23version: 0.1
34synopsis: Basic Authentication cookbook example
45homepage: http://docs.servant.dev/
5−license: BSD3
6+license: BSD-3-Clause
67license-file: ../../../servant/LICENSE
78author: Servant Contributors
89maintainer: haskell-servant-maintainers@googlegroups.com
910build-type: Simple
10−cabal-version: >=1.10
11−tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.1
11+tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
1212
1313executable cookbook-basic-auth
1414 main-is: BasicAuth.lhs
doc/cookbook/basic-streaming/Streaming.lhs+4−1
@@ -8,7 +8,10 @@ In other words, without streaming libraries.
88- Some basic usage doesn't require usage of streaming libraries,
99 like `conduit`, `pipes`, `machines` or `streaming`.
1010 We have bindings for them though.
11−- This is similar example file, which is bundled with each of the packages (TODO: links)
11+- Similar example is bundled with each of our streaming library interop packages (see
12+[servant-pipes](https://github.com/haskell-servant/servant/blob/master/servant-pipes/example/Main.hs),
13+[servant-conduit](https://github.com/haskell-servant/servant/blob/master/servant-conduit/example/Main.hs) and
14+[servant-machines](https://github.com/haskell-servant/servant/blob/master/servant-machines/example/Main.hs))
1215- `SourceT` doesn't have *Prelude* with handy combinators, so we have to write
1316 things ourselves. (Note to self: `mapM` and `foldM` would be handy to have).
1417
doc/cookbook/basic-streaming/basic-streaming.cabal+3−3
@@ -1,14 +1,14 @@
1+cabal-version: 2.2
12name: cookbook-basic-streaming
23version: 2.1
34synopsis: Streaming in servant without streaming libs
45homepage: http://docs.servant.dev/
5−license: BSD3
6+license: BSD-3-Clause
67license-file: ../../../servant/LICENSE
78author: Servant Contributors
89maintainer: haskell-servant-maintainers@googlegroups.com
910build-type: Simple
10−cabal-version: >=1.10
11−tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.1
11+tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
1212
1313executable cookbook-basic-streaming
1414 main-is: Streaming.lhs
doc/cookbook/curl-mock/CurlMock.lhs+8−21
@@ -1,7 +1,7 @@
11# Generating mock curl calls
22
33In this example we will generate curl requests with mock post data from a servant API.
4−This may be usefull for testing and development purposes.
4+This may be useful for testing and development purposes.
55Especially post requests with a request body are tedious to send manually.
66
77Also, we will learn how to use the servant-foreign library to generate stuff from servant APIs.
@@ -24,7 +24,6 @@ Language extensions and imports:
2424import Control.Lens ((^.))
2525import Data.Aeson
2626import Data.Aeson.Text
27−import Data.Monoid ((<>))
2827import Data.Proxy (Proxy (Proxy))
2928import Data.Text (Text)
3029import Data.Text.Encoding (decodeUtf8)
@@ -86,7 +85,7 @@ listFromAPI :: (HasForeign lang ftype api, GenerateList ftype (Foreign ftype api
8685```
8786
8887This looks a bit confusing...
89−[Here](https://hackage.haskell.org/package/servant-foreign-0.11.1/docs/Servant-Foreign.html#t:HasForeignType) is the documentation for the `HasForeign` typeclass.
88+[Here](https://hackage.haskell.org/package/servant-foreign/docs/Servant-Foreign.html#t:HasForeign) is the documentation for the `HasForeign` typeclass.
9089We will not go into details here, but this allows us to create a value of type `ftype` for any type `a` in our API.
9190
9291In our case we want to create a mock of every type `a`.
@@ -130,24 +129,12 @@ generateCurl :: (GenerateList Mocked (Foreign Mocked api), HasForeign NoLang Moc
130129generateCurl p host =
131130 fmap T.unlines body
132131 where
133− body = foldr (\endp curlCalls -> mCons (generateEndpoint host endp) curlCalls) (return [])
132+ body = mapM (generateEndpoint host)
134133 $ listFromAPI (Proxy :: Proxy NoLang) (Proxy :: Proxy Mocked) p
135134```
136135
137−To understand this function, better start at the end:
138−
139−`listFromAPI` gives us a list of endpoints. We iterate over them (`foldr`) and call `generateEndpoint` for every endpoint.
140−
141−As generate endpoint will not return `Text` but `IO Text` (remember we need some random bits to mock), we cannot just use the cons operator but need to build `IO [Text]` from `IO Text`s.
142−
143−``` haskell
144−mCons :: IO a -> IO [a] -> IO [a]
145−mCons ele list =
146− ele >>= \e -> list >>= \l -> return ( e : l )
147−```
148−
149−
150−Now comes the juicy part; accessing the endpoints data:
136+First, `listFromAPI` gives us a list of `Req Mocked`. Each `Req` describes one endpoint from the API type.
137+We generate a curl call for each of them using the following helper.
151138
152139``` haskell
153140generateEndpoint :: Text -> Req Mocked -> IO Text
@@ -169,7 +156,7 @@ generateEndpoint host req =
169156`servant-foreign` offers a multitude of lenses to be used with `Req`-values.
170157
171158`reqMethod` gives us a straigthforward `Network.HTTP.Types.Method`, `reqUrl` the url part and so on.
172−Just take a look at [the docs](https://hackage.haskell.org/package/servant-foreign-0.11.1/docs/Servant-Foreign.html).
159+Just take a look at [the docs](https://hackage.haskell.org/package/servant-foreign/docs/Servant-Foreign.html).
173160
174161But how do we get our mocked json string? This seems to be a bit to short to be true:
175162
@@ -201,7 +188,7 @@ And now, lets hook it all up in our main function:
201188``` haskell
202189main :: IO ()
203190main =
204− generateCurl api "localhost:8081" >>= (\v -> T.IO.putStrLn v)
191+ generateCurl api "localhost:8081" >>= T.IO.putStrLn
205192```
206193
207194Done:
@@ -213,6 +200,6 @@ curl -X POST -d '{"email":"wV򝣀_b򆎘:z񁊞򲙲!(3DM V","age":10,"name":"=|W"}
213200```
214201
215202This is of course no complete curl call mock generator, many things including path arguments are missing.
216−But it correctly generate mock calls for simple POST requests.
203+But it correctly generates mock calls for simple POST requests.
217204
218205Also, we now know how to use `HasForeignType` and `listFromAPI` to generate anything we want.
doc/cookbook/curl-mock/curl-mock.cabal+6−3
@@ -1,16 +1,19 @@
1+cabal-version: 2.2
12name: cookbook-curl-mock
23version: 0.1
34synopsis: Generate curl mock requests cookbook example
45homepage: http://docs.servant.dev
5−license: BSD3
6+license: BSD-3-Clause
67license-file: ../../../servant/LICENSE
78author: Servant Contributors
89maintainer: haskell-servant-maintainers@googlegroups.com
910build-type: Simple
10−cabal-version: >=1.10
11−tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.1
11+tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
1212
1313executable cookbock-curl-mock
14+ if impl(ghc >= 9.2)
15+ -- generic-arbitrary is incompatible
16+ buildable: False
1417 main-is: CurlMock.lhs
1518 build-depends: base == 4.*
1619 , aeson
doc/cookbook/custom-errors/CustomErrors.lhsnew file+189
@@ -0,0 +1,189 @@
1+# Customizing errors from Servant
2+
3+Servant handles a lot of parsing and validation of the input request. When it can't parse something: query
4+parameters, URL parts or request body, it will return appropriate HTTP codes like 400 Bad Request.
5+
6+These responses will contain the error message in their body without any formatting. However, it is often
7+desirable to be able to provide custom formatting for these error messages, for example, to wrap them in JSON.
8+
9+Recently Servant got a way to add such formatting. This Cookbook chapter demonstrates how to use it.
10+
11+Extensions and imports:
12+```haskell
13+{-# LANGUAGE DataKinds #-}
14+{-# LANGUAGE DeriveGeneric #-}
15+{-# LANGUAGE OverloadedStrings #-}
16+{-# LANGUAGE PolyKinds #-}
17+{-# LANGUAGE TypeFamilies #-}
18+{-# LANGUAGE TypeOperators #-}
19+
20+import Data.Aeson
21+import Data.Proxy
22+import Data.Text
23+import GHC.Generics
24+import Network.Wai
25+import Network.Wai.Handler.Warp
26+
27+import Servant
28+
29+import Data.String.Conversions
30+ (cs)
31+import Servant.API.ContentTypes
32+```
33+
34+The API (from `greet.hs` example in Servant sources):
35+
36+```haskell
37+-- | A greet message data type
38+newtype Greet = Greet { _msg :: Text }
39+ deriving (Generic, Show)
40+
41+instance FromJSON Greet
42+instance ToJSON Greet
43+
44+-- API specification
45+type TestApi =
46+ -- GET /hello/:name?capital={true, false} returns a Greet as JSON
47+ "hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get '[JSON] Greet
48+
49+ -- POST /greet with a Greet as JSON in the request body,
50+ -- returns a Greet as JSON
51+ :<|> "greet" :> ReqBody '[JSON] Greet :> Post '[JSON] Greet
52+
53+ -- DELETE /greet/:greetid
54+ :<|> "greet" :> Capture "greetid" Text :> Delete '[JSON] NoContent
55+
56+testApi :: Proxy TestApi
57+testApi = Proxy
58+
59+-- Server-side handlers.
60+--
61+-- There's one handler per endpoint, which, just like in the type
62+-- that represents the API, are glued together using :<|>.
63+--
64+-- Each handler runs in the 'Handler' monad.
65+server :: Server TestApi
66+server = helloH :<|> postGreetH :<|> deleteGreetH
67+
68+ where helloH name Nothing = helloH name (Just False)
69+ helloH name (Just False) = return . Greet $ "Hello, " <> name
70+ helloH name (Just True) = return . Greet . toUpper $ "Hello, " <> name
71+
72+ postGreetH greet = return greet
73+
74+ deleteGreetH _ = return NoContent
75+```
76+
77+## Error formatters
78+
79+`servant-server` provides an `ErrorFormatter` type to specify how the error message will be
80+formatted. A formatter is just a function accepting three parameters:
81+
82+- `TypeRep` from `Data.Typeable`: this is a runtime representation of the type of the combinator
83+ (like `Capture` or `ReqBody`) that generated the error. It can be used to display its name (with
84+ `show`) or even dynamically dispatch on the combinator type. See the docs for `Data.Typeable` and
85+ `Type.Reflection` modules.
86+- `Request`: full information for the request that led to the error.
87+- `String`: specific error message from the combinator.
88+
89+The formatter is expected to produce a `ServerError` which will be returned from the handler.
90+
91+Additionally, there is `NotFoundErrorFormatter`, which accepts only `Request` and can customize the
92+error in case when no route can be matched (HTTP 404).
93+
94+Let's make two formatters. First one will wrap our error in a JSON:
95+
96+```json
97+{
98+ "error": "ERROR MESSAGE",
99+ "combinator": "NAME OF THE COMBINATOR"
100+}
101+```
102+
103+Additionally, this formatter will examine the `Accept` header of the request and generate JSON
104+message only if client can accept it.
105+
106+```haskell
107+customFormatter :: ErrorFormatter
108+customFormatter tr req err =
109+ let
110+ -- aeson Value which will be sent to the client
111+ value = object ["combinator" .= show tr, "error" .= err]
112+ -- Accept header of the request
113+ accH = getAcceptHeader req
114+ in
115+ -- handleAcceptH is Servant's function that checks whether the client can accept a
116+ -- certain message type.
117+ -- In this case we call it with "Proxy '[JSON]" argument, meaning that we want to return a JSON.
118+ case handleAcceptH (Proxy :: Proxy '[JSON]) accH value of
119+ -- If client can't handle JSON, we just return the body the old way
120+ Nothing -> err400 { errBody = cs err }
121+ -- Otherwise, we return the JSON formatted body and set the "Content-Type" header.
122+ Just (ctypeH, body) -> err400
123+ { errBody = body
124+ , errHeaders = [("Content-Type", cs ctypeH)]
125+ }
126+
127+notFoundFormatter :: NotFoundErrorFormatter
128+notFoundFormatter req =
129+ err404 { errBody = cs $ "Not found path: " <> rawPathInfo req }
130+```
131+
132+If you don't need to react to the `Accept` header, you can just unconditionally return the JSON like
133+this (with `encode` from `Data.Aeson`):
134+
135+```
136+err400
137+ { errBody = encode body
138+ , errHeaders = [("Content-Type", "application/json")]
139+ }
140+```
141+
142+## Passing formatters to Servant
143+
144+Servant uses the Context to configure formatters. You only need to add a value of type
145+`ErrorFormatters` to your context. This is a record with the following fields:
146+
147+- `bodyParserErrorFormatter :: ErrorFormatter`
148+- `urlParseErrorFormatter :: ErrorFormatter`
149+- `headerParseErrorFormatter :: ErrorFormatter`
150+- `notFoundErrorFormatter :: NotFoundErrorFormatter`
151+
152+Default formatters are exported as `defaultErrorFormatters`, so you can use record update syntax to
153+set the only ones you need:
154+
155+```haskell
156+customFormatters :: ErrorFormatters
157+customFormatters = defaultErrorFormatters
158+ { bodyParserErrorFormatter = customFormatter
159+ , notFoundErrorFormatter = notFoundFormatter
160+ }
161+```
162+
163+And at last, use `serveWithContext` to run your server as usual:
164+
165+```haskell
166+app :: Application
167+app = serveWithContext testApi (customFormatters :. EmptyContext) server
168+
169+main :: IO ()
170+main = run 8000 app
171+```
172+
173+Now if we try to request something with a wrong body, we will get a nice error:
174+
175+```
176+$ http -j POST localhost:8000/greet 'foo=bar'
177+HTTP/1.1 400 Bad Request
178+Content-Type: application/json;charset=utf-8
179+Date: Fri, 17 Jul 2020 13:34:18 GMT
180+Server: Warp/3.3.12
181+Transfer-Encoding: chunked
182+
183+{
184+ "combinator": "ReqBody'",
185+ "error": "Error in $: parsing Main.Greet(Greet) failed, key \"_msg\" not found"
186+}
187+```
188+
189+Notice the `Content-Type` header set by our combinator.
doc/cookbook/custom-errors/custom-errors.cabalnew file+25
@@ -0,0 +1,25 @@
1+cabal-version: 2.2
2+name: cookbook-custom-errors
3+version: 0.1
4+synopsis: Return custom error messages from combinators
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==8.6.5, GHC==8.8.3, GHC ==8.10.7
12+
13+executable cookbook-custom-errors
14+ main-is: CustomErrors.lhs
15+ build-depends: base == 4.*
16+ , aeson
17+ , servant
18+ , servant-server
19+ , string-conversions
20+ , text
21+ , wai
22+ , warp
23+ default-language: Haskell2010
24+ ghc-options: -Wall -pgmL markdown-unlit
25+ build-tool-depends: markdown-unlit:markdown-unlit
doc/cookbook/db-mysql-basics/MysqlBasics.lhs+1−1
@@ -2,7 +2,7 @@
22
33This doc will walk through a single-module implementation of a servant API connecting to a MySQL database. It will also include some basic CRUD operations.
44
5−Once you can wrap your head around this implemenation, understanding more complex features like resource pools would be beneficial next steps.
5+Once you can wrap your head around this implementation, understanding more complex features like resource pools would be beneficial next steps.
66
77The only *prerequisite* is that you have a MySQL database open on port 3306 of your machine. Docker is an easy way to manage this.
88
doc/cookbook/db-mysql-basics/mysql-basics.cabal+2−2
@@ -1,13 +1,13 @@
1+cabal-version: 2.2
12name: mysql-basics
23version: 0.1.0.0
34synopsis: Simple MySQL API cookbook example
45homepage: http://docs.servant.dev/
5−license: BSD3
6+license: BSD-3-Clause
67license-file: ../../../servant/LICENSE
78author: Servant Contributors
89maintainer: haskell-servant-maintainers@googlegroups.com
910build-type: Simple
10−cabal-version: >=1.10
1111
1212executable run
1313 hs-source-dirs: .
doc/cookbook/db-postgres-pool/db-postgres-pool.cabal+3−3
@@ -1,14 +1,14 @@
1+cabal-version: 2.2
12name: cookbook-db-postgres-pool
23version: 0.1
34synopsis: Simple PostgreSQL connection pool cookbook example
45homepage: http://docs.servant.dev/
5−license: BSD3
6+license: BSD-3-Clause
67license-file: ../../../servant/LICENSE
78author: Servant Contributors
89maintainer: haskell-servant-maintainers@googlegroups.com
910build-type: Simple
10−cabal-version: >=1.10
11−tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.1
11+tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
1212
1313executable cookbook-db-postgres-pool
1414 main-is: PostgresPool.lhs
doc/cookbook/db-sqlite-simple/db-sqlite-simple.cabal+4−4
@@ -1,14 +1,14 @@
1+cabal-version: 2.2
12name: cookbook-db-sqlite-simple
23version: 0.1
34synopsis: Simple SQLite DB cookbook example
45homepage: http://docs.servant.dev/
5−license: BSD3
6+license: BSD-3-Clause
67license-file: ../../../servant/LICENSE
78author: Servant Contributors
89maintainer: haskell-servant-maintainers@googlegroups.com
910build-type: Simple
10−cabal-version: >=1.10
11−tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.1
11+tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
1212
1313executable cookbook-db-sqlite-simple
1414 main-is: DBConnection.lhs
@@ -23,7 +23,7 @@ executable cookbook-db-sqlite-simple
2323 , http-types >= 0.12
2424 , markdown-unlit >= 0.4
2525 , http-client >= 0.5
26− , sqlite-simple >= 0.4
26+ , sqlite-simple >= 0.4.5.0
2727 , transformers
2828 default-language: Haskell2010
2929 ghc-options: -Wall -pgmL markdown-unlit
doc/cookbook/file-upload/FileUpload.lhs+2−2
@@ -90,8 +90,8 @@ startServer = run 8080 (serve api upload)
9090
9191Finally, a main function that brings up our server and
9292sends some test request with `http-client` (and not
93−servant-client this time, has servant-multipart does not
94−yet have support for client generation.
93+servant-client this time, as servant-multipart does not
94+yet have support for client generation).
9595
9696``` haskell
9797main :: IO ()
doc/cookbook/file-upload/file-upload.cabal+3−3
@@ -1,14 +1,14 @@
1+cabal-version: 2.2
12name: cookbook-file-upload
23version: 0.1
34synopsis: File upload cookbook example
45homepage: http://docs.servant.dev/
5−license: BSD3
6+license: BSD-3-Clause
67license-file: ../../../servant/LICENSE
78author: Servant Contributors
89maintainer: haskell-servant-maintainers@googlegroups.com
910build-type: Simple
10−cabal-version: >=1.10
11−tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.1
11+tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
1212
1313executable cookbook-file-upload
1414 main-is: FileUpload.lhs
doc/cookbook/generic/Generic.lhs+3−3
@@ -43,13 +43,13 @@ api :: Proxy (ToServantApi Routes)
4343api = genericApi (Proxy :: Proxy Routes)
4444```
4545
46−It's recommented to use `genericApi` function, as then you'll get
46+It's recommended to use `genericApi` function, as then you'll get
4747better error message, for example if you forget to `derive Generic`.
4848
4949## Links
5050
5151The clear advantage of record-based generics approach, is that
52−we can get safe links very conviently. We don't need to define endpoint types,
52+we can get safe links very conveniently. We don't need to define endpoint types,
5353as field accessors work as proxies:
5454
5555```haskell
@@ -67,7 +67,7 @@ routesLinks = allFieldLinks
6767## Client
6868
6969Even more power starts to show when we generate a record of client functions.
70−Here we use `genericClientHoist` function, which let us simultaneously
70+Here we use `genericClientHoist` function, which lets us simultaneously
7171hoist the monad, in this case from `ClientM` to `IO`.
7272
7373```haskell
doc/cookbook/generic/generic.cabal+3−3
@@ -1,14 +1,14 @@
1+cabal-version: 2.2
12name: cookbook-generic
23version: 0.1
34synopsis: Using custom monad to pass a state between handlers
45homepage: http://docs.servant.dev/
5−license: BSD3
6+license: BSD-3-Clause
67license-file: ../../../servant/LICENSE
78author: Servant Contributors
89maintainer: haskell-servant-maintainers@googlegroups.com
910build-type: Simple
10−cabal-version: >=1.10
11−tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.1
11+tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
1212
1313executable cookbook-using-custom-monad
1414 main-is: Generic.lhs
doc/cookbook/hoist-server-with-context/HoistServerWithContext.lhs+2−2
@@ -254,7 +254,7 @@ loginHandler cookieSettings jwtSettings form = do
254254 liftIO $ pushLogStrLn logset $ toLogStr logMsg
255255 throwError err401
256256 Just applyCookies -> do
257− let successMsg = logMsg{message = "AdminUser succesfully authenticated!"}
257+ let successMsg = logMsg{message = "AdminUser successfully authenticated!"}
258258 liftIO $ pushLogStrLn logset $ toLogStr successMsg
259259 pure $ applyCookies successMsg
260260loginHandler _ _ _ = throwError err401
@@ -287,7 +287,7 @@ mkApp cfg cs jwts ctx =
287287 (flip runReaderT ctx) (adminServer cs jwts)
288288```
289289
290−One footenote: because we'd like our logs to be in JSON form, we'll also create a `Middleware` object
290+One footnote: because we'd like our logs to be in JSON form, we'll also create a `Middleware` object
291291so that `Warp` *also* will emit logs as JSON. This will ensure *all* logs are emitted as JSON:
292292
293293```haskell
doc/cookbook/hoist-server-with-context/hoist-server-with-context.cabal+4−4
@@ -1,17 +1,17 @@
1+cabal-version: 2.2
12name: cookbook-hoist-server-with-context
23version: 0.0.1
34synopsis: JWT and basic access authentication with a Custom Monad cookbook example
45description: Using servant-auth to support both JWT-based and basic
56 authentication.
67homepage: http://docs.servant.dev/
7−license: BSD3
8+license: BSD-3-Clause
89license-file: ../../../servant/LICENSE
910author: Servant Contributors
1011maintainer: haskell-servant-maintainers@googlegroups.com
1112category: Servant
1213build-type: Simple
13−cabal-version: >=1.10
14−tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.1
14+tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
1515
1616executable cookbook-hoist-server-with-context
1717 main-is: HoistServerWithContext.lhs
@@ -24,7 +24,7 @@ executable cookbook-hoist-server-with-context
2424 , servant
2525 , servant-server
2626 , servant-auth >= 0.3.2
27− , servant-auth-server
27+ , servant-auth-server >= 0.4.4.0
2828 , time
2929 , warp >= 3.2
3030 , wai >= 3.2
doc/cookbook/https/Https.lhs+5−5
@@ -34,16 +34,16 @@ app = serve api server
3434```
3535
3636It's now time to actually run the `Application`.
37−The [`warp-tls`](https://hackage.haskell.org/package/warp-tls-3.2.4/docs/Network-Wai-Handler-WarpTLS.html)
37+The [`warp-tls`](https://hackage.haskell.org/package/warp-tls/docs/Network-Wai-Handler-WarpTLS.html)
3838package provides two functions for running an `Application`, called
39−[`runTLS`](https://hackage.haskell.org/package/warp-tls-3.2.4/docs/Network-Wai-Handler-WarpTLS.html#v:runTLS)
40−and [`runTLSSocket`](https://hackage.haskell.org/package/warp-tls-3.2.4/docs/Network-Wai-Handler-WarpTLS.html#v:runTLSSocket).
39+[`runTLS`](https://hackage.haskell.org/package/warp-tls/docs/Network-Wai-Handler-WarpTLS.html#v:runTLS)
40+and [`runTLSSocket`](https://hackage.haskell.org/package/warp-tls/docs/Network-Wai-Handler-WarpTLS.html#v:runTLSSocket).
4141We will be using the first one.
4242
4343It takes two arguments,
44−[the TLS settings](https://hackage.haskell.org/package/warp-tls-3.2.4/docs/Network-Wai-Handler-WarpTLS.html#t:TLSSettings)
44+[the TLS settings](https://hackage.haskell.org/package/warp-tls/docs/Network-Wai-Handler-WarpTLS.html#t:TLSSettings)
4545(certificates, keys, ciphers, etc)
46−and [the warp settings](https://hackage.haskell.org/package/warp-3.2.12/docs/Network-Wai-Handler-Warp-Internal.html#t:Settings)
46+and [the warp settings](https://hackage.haskell.org/package/warp/docs/Network-Wai-Handler-Warp-Internal.html#t:Settings)
4747(port, logger, etc).
4848
4949We will be using very simple settings for this example but you are of
doc/cookbook/https/https.cabal+4−4
@@ -1,14 +1,14 @@
1+cabal-version: 2.2
12name: cookbook-https
23version: 0.1
34synopsis: HTTPS cookbook example
45homepage: http://docs.servant.dev/
5−license: BSD3
6+license: BSD-3-Clause
67license-file: ../../../servant/LICENSE
78author: Servant Contributors
89maintainer: haskell-servant-maintainers@googlegroups.com
910build-type: Simple
10−cabal-version: >=1.10
11−tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.1
11+tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
1212
1313executable cookbook-https
1414 main-is: Https.lhs
@@ -17,7 +17,7 @@ executable cookbook-https
1717 , servant-server
1818 , wai >= 3.2
1919 , warp >= 3.2
20− , warp-tls >= 3.2
20+ , warp-tls >= 3.2.9
2121 , markdown-unlit >= 0.4
2222 default-language: Haskell2010
2323 ghc-options: -Wall -pgmL markdown-unlit
doc/cookbook/index.rst+5−2
@@ -6,8 +6,8 @@ how to solve many common problems with servant. If you're
66interested in contributing examples of your own, feel free
77to open an issue or a pull request on
88`our github repository <https://github.com/haskell-servant/servant>`_
9−or even to just get in touch with us on the **#servant** IRC channel
10−on freenode or on
9+or even to just get in touch with us on the `**#haskell-servant** IRC channel
10+on libera.chat <https://web.libera.chat/#haskell-servant>_ or on
1111`the mailing list <https://groups.google.com/forum/#!forum/haskell-servant>`_.
1212
1313The scope is very wide. Simple and fancy authentication schemes,
@@ -25,6 +25,8 @@ you name it!
2525 db-postgres-pool/PostgresPool.lhs
2626 using-custom-monad/UsingCustomMonad.lhs
2727 using-free-client/UsingFreeClient.lhs
28+ custom-errors/CustomErrors.lhs
29+ uverb/UVerb.lhs
2830 basic-auth/BasicAuth.lhs
2931 basic-streaming/Streaming.lhs
3032 jwt-and-basic-auth/JWTAndBasicAuth.lhs
@@ -35,3 +37,4 @@ you name it!
3537 sentry/Sentry.lhs
3638 testing/Testing.lhs
3739 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
12name: cookbook-jwt-and-basic-auth
23version: 0.0.1
34synopsis: JWT and basic access authentication cookbook example
45description: Using servant-auth to support both JWT-based and basic
56 authentication.
67homepage: http://docs.servant.dev/
7−license: BSD3
8+license: BSD-3-Clause
89license-file: ../../../servant/LICENSE
910author: Servant Contributors
1011maintainer: haskell-servant-maintainers@googlegroups.com
1112category: Servant
1213build-type: Simple
13−cabal-version: >=1.10
14−tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.1
14+tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
1515
1616executable cookbook-jwt-and-basic-auth
1717 main-is: JWTAndBasicAuth.lhs
@@ -22,7 +22,7 @@ executable cookbook-jwt-and-basic-auth
2222 , servant
2323 , servant-client
2424 , servant-server
25− , servant-auth ==0.3.*
25+ , servant-auth == 0.4.*
2626 , servant-auth-server >= 0.3.1.0
2727 , warp >= 3.2
2828 , 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
12name: open-id-connect
23version: 0.1
34synopsis: OpenId Connect with Servant example
45homepage: http://haskell-servant.readthedocs.org/
5−license: BSD3
6+license: BSD-3-Clause
67license-file: ../../../servant/LICENSE
78author: Servant Contributors
89maintainer: haskell-servant-maintainers@googlegroups.com
910build-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
1212
1313executable cookbook-openidconnect
1414 main-is: OpenIdConnect.lhs
doc/cookbook/open-id-connect/OpenIdConnect.lhs+17−17
@@ -8,8 +8,8 @@ some login token would be saved in the user agent local storage.
88
99Workflow:
1010
11−1. user is presentend with a login button,
12−2. when the user click on the button it is redirected to the OIDC
11+1. user is presented with a login button,
12+2. when the user clicks on the button it is redirected to the OIDC
1313 provider,
14143. the user login in the OIDC provider,
15154. the OIDC provider will redirect the user and provide a `code`,
@@ -221,9 +221,9 @@ The `AuthInfo` is about the infos we can grab from OIDC provider.
221221
222222To be more precise, the user should come with a `code` (a token) and
223223POSTing that code to the correct OIDC provider endpoint should return a JSON
224−object. One of the field should be named `id_token` which should be a
225−JWT containing all the informations we need. Depending on the scopes we
226−asked we might get more informations.
224+object. One of the fields should be named `id_token` which should be a
225+JWT containing all the information we need. Depending on the scopes we
226+asked we might get more information.
227227
228228``` haskell
229229-- | @AuthInfo@
@@ -248,16 +248,16 @@ instance JSON.ToJSON AuthInfo where
248248type LoginHandler = AuthInfo -> IO (Either Text User)
249249```
250250
251−The `handleLoggedIn` is that part that will retrieve the informations from
251+The `handleLoggedIn` is that part that will retrieve the information from
252252the user once he is redirected from the OIDC Provider after login.
253253
254254If the user is redirected to the `redirect_uri` but with an `error` query
255−parameter then it means something goes wrong.
255+parameter then it means something went wrong.
256256If there is no error query param but a `code` query param it means the user
257−sucessfully logged in. From there we need to make a request to the token
258−endpoint of the OIDC provider. Its a POST that should contains the code
259−as well as the client id & secret.
260−This is the role of the `requestTokens` to make this HTTP POST.
257+successfully logged in. From there we need to make a request to the token
258+endpoint of the OIDC provider. It's a POST that should contain the code
259+as well as the client id and secret.
260+Making this HTTP POST is the responsibility of `requestTokens`.
261261
262262From there we extract the `claims` of the JWT contained in one of the value
263263of the JSON returned by the POST HTTP Request.
@@ -329,12 +329,12 @@ data Customer = Customer {
329329 }
330330```
331331
332−Here is the code that display the homepage.
333−It should contain a link to the the `/login` URL.
334−When the user will click on this link it will be redirected to Google login page
335−with some generated informations.
332+Here is the code that displays the homepage.
333+It should contain a link to the `/login` URL.
334+When the user clicks on this link it will be redirected to Google login page
335+with some generated information.
336336
337−The page also display the content of the local storage.
337+The page also displays the content of the local storage.
338338And in particular the items `api-key` and `user-id`.
339339Those items should be set after a successful login when the user is redirected to
340340`/login/cb`.
@@ -366,7 +366,7 @@ instance ToMarkup Homepage where
366366We need some helpers to generate random string for generating state and API Keys.
367367
368368``` haskell
369−-- | generate a random Bystestring, not necessarily extremely good randomness
369+-- | generate a random ByteString, not necessarily extremely good randomness
370370-- still the password will be long enough to be very difficult to crack
371371genRandomBS :: IO ByteString
372372genRandomBS = do
doc/cookbook/pagination/Pagination.lhs+8−8
@@ -18,7 +18,7 @@ For example: `Range: createdAt 2017-01-15T23:14:67.000Z; offset 5; order desc` i
1818the client is willing to retrieve the next batch of document in descending order that were
1919created after the fifteenth of January, skipping the first 5.
2020
21−As a response, the server may return the list of corresponding document, and augment the
21+As a response, the server may return the list of corresponding documents, and augment the
2222response with 3 headers:
2323
2424- `Accept-Ranges`: A comma-separated list of fields upon which a range can be defined
@@ -127,7 +127,7 @@ defaultRange =
127127 getDefaultRange (Proxy @Color)
128128```
129129
130−Note that `getFieldValue :: Proxy "name" -> Color -> String` is the minimal complete definintion
130+Note that `getFieldValue :: Proxy "name" -> Color -> String` is the minimal complete definition
131131of the class. Yet, you can define `getRangeOptions` to provide different parsing options (see
132132the last section of this guide). In the meantime, we've also defined a `defaultRange` as it will
133133come in handy when defining our handler.
@@ -148,7 +148,7 @@ type MyHeaders =
148148```
149149
150150`PageHeaders` is a type alias provided by the library to declare the necessary response headers
151−we mentionned in introduction. Expanding the alias boils down to the following:
151+we mentioned in introduction. Expanding the alias boils down to the following:
152152
153153``` haskell
154154-- type MyHeaders =
@@ -165,7 +165,7 @@ not, _servant-pagination_ provides an easy way to lift a collection of resources
165165#### Server
166166
167167Time to connect the last bits by defining the server implementation of our colorful API. The `Ranges`
168−type we've defined above (tight to the `Range` HTTP header) indicates the server to parse any `Range`
168+type we've defined above (tied to the `Range` HTTP header) indicates the server to parse any `Range`
169169header, looking for the format defined in introduction with fields and target types we have just declared.
170170If no such header is provided, we will end up receiving `Nothing`. Otherwise, it will be possible
171171to _extract_ a `Range` from our `Ranges`.
@@ -192,7 +192,7 @@ the format we defined, where `<field>` here can only be `name` and `<value>` mus
192192- `Range: <field> [<value>][; offset <o>][; limit <l>][; order <asc|desc>]`
193193
194194Beside the target field, everything is pretty much optional in the `Range` HTTP header. Missing parts
195−are deducted from the `RangeOptions` that are part of the `HasPagination` instance. Therefore, all
195+are deduced from the `RangeOptions` that are part of the `HasPagination` instance. Therefore, all
196196following examples are valid requests to send to our server:
197197
198198- 1 - `curl http://localhost:1442/colors -vH 'Range: name'`
@@ -219,7 +219,7 @@ The previous ranges reads as follows:
219219Note that in the simple above scenario, there's no ambiguity with `extractRange` and `returnRange`
220220because there's only one possible `Range` defined on our resource. Yet, as you've most probably
221221noticed, the `Ranges` combinator accepts a list of fields, each of which must declare a `HasPagination`
222−instance. Doing so will make the other helper functions more ambiguous and type annotation are
222+instance. Doing so will make the other helper functions more ambiguous and type annotations are
223223highly likely to be needed.
224224
225225
@@ -235,8 +235,8 @@ instance HasPagination Color "hex" where
235235#### Parsing Options
236236
237237By default, `servant-pagination` provides an implementation of `getRangeOptions` for each
238−`HasPagination` instance. However, this can be overwritten when defining the instance to provide
239−your own options. This options come into play when a `Range` header is received and isn't fully
238+`HasPagination` instance. However, this can be overridden when defining the instance to provide
239+your own options. These options come into play when a `Range` header is received and isn't fully
240240specified (`limit`, `offset`, `order` are all optional) to provide default fallback values for those.
241241
242242For instance, let's say we wanted to change the default limit to `5` in a new range on
doc/cookbook/pagination/pagination.cabal+3−3
@@ -1,14 +1,14 @@
1+cabal-version: 2.2
12name: cookbook-pagination
23version: 2.1
34synopsis: Pagination with Servant example
45homepage: http://docs.servant.dev/
5−license: BSD3
6+license: BSD-3-Clause
67license-file: ../../../servant/LICENSE
78author: Servant Contributors
89maintainer: haskell-servant-maintainers@googlegroups.com
910build-type: Simple
10−cabal-version: >=1.10
11−tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.1
11+tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
1212
1313executable cookbook-pagination
1414 main-is: Pagination.lhs
doc/cookbook/sentry/Sentry.lhs+2−2
@@ -79,14 +79,14 @@ It does three things. First it initializes the service which will communicate wi
7979
8080- the Sentry `DSN`, which is obtained when creating a new project on Sentry
8181- a default way to update sentry fields, where we use the identity function
82−- an event trasport, which generally would be `sendRecord`, an HTTPS capable trasport which uses http-conduit
82+- an event transport, which generally would be `sendRecord`, an HTTPS capable transport which uses http-conduit
8383- a fallback handler, which we choose to be `silentFallback` since later we are logging to the console anyway.
8484
8585In the second step it actually sends our message to Sentry with the `register` function. Its arguments are:
8686
8787- the configured Sentry service which we just created
8888- the name of the logger
89−- the error level (see [SentryLevel](https://hackage.haskell.org/package/raven-haskell-0.1.2.0/docs/System-Log-Raven-Types.html#t:SentryLevel) for the possible options)
89+- the error level (see [SentryLevel](https://hackage.haskell.org/package/raven-haskell/docs/System-Log-Raven-Types.html#t:SentryLevel) for the possible options)
9090- the message we want to send
9191- an update function to handle the specific `SentryRecord`
9292
doc/cookbook/sentry/sentry.cabal+3−3
@@ -1,14 +1,14 @@
1+cabal-version: 2.2
12name: cookbook-sentry
23version: 0.1
34synopsis: Collecting runtime exceptions using Sentry
45homepage: http://docs.servant.dev/
5−license: BSD3
6+license: BSD-3-Clause
67license-file: ../../../servant/LICENSE
78author: Servant Contributors
89maintainer: haskell-servant-maintainers@googlegroups.com
910build-type: Simple
10−cabal-version: >=1.10
11−tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.1
11+tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
1212
1313executable cookbook-sentry
1414 main-is: Sentry.lhs
doc/cookbook/structuring-apis/StructuringApis.lhs+1−1
@@ -144,7 +144,7 @@ simpleAPIServer
144144 :: m [a]
145145 -> (i -> m a)
146146 -> (a -> m NoContent)
147− -> Server (SimpleAPI name a i) m
147+ -> ServerT (SimpleAPI name a i) m
148148simpleAPIServer listAs getA postA =
149149 listAs :<|> getA :<|> postA
150150
doc/cookbook/structuring-apis/structuring-apis.cabal+3−3
@@ -1,14 +1,14 @@
1+cabal-version: 2.2
12name: cookbook-structuring-apis
23version: 0.1
34synopsis: Example that shows how APIs can be structured
45homepage: http://docs.servant.dev/
5−license: BSD3
6+license: BSD-3-Clause
67license-file: ../../../servant/LICENSE
78author: Servant Contributors
89maintainer: haskell-servant-maintainers@googlegroups.com
910build-type: Simple
10−cabal-version: >=1.10
11−tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.1
11+tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
1212
1313executable cookbook-structuring-apis
1414 main-is: StructuringApis.lhs
doc/cookbook/testing/testing.cabal+4−4
@@ -1,16 +1,16 @@
1+cabal-version: 2.2
12name: cookbook-testing
23version: 0.0.1
34synopsis: Common testing patterns in Servant apps
45description: This recipe includes various strategies for writing tests for Servant.
56homepage: http://docs.servant.dev/
6−license: BSD3
7+license: BSD-3-Clause
78license-file: ../../../servant/LICENSE
89author: Servant Contributors
910maintainer: haskell-servant-maintainers@googlegroups.com
1011category: Servant
1112build-type: Simple
12−cabal-version: >=1.10
13−tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.1
13+tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
1414
1515executable cookbook-testing
1616 main-is: Testing.lhs
@@ -23,7 +23,7 @@ executable cookbook-testing
2323 , servant
2424 , servant-client
2525 , servant-server
26− , servant-quickcheck
26+ , servant-quickcheck >= 0.0.10
2727 , http-client
2828 , http-types >= 0.12
2929 , hspec
doc/cookbook/using-custom-monad/UsingCustomMonad.lhs+1−1
@@ -1,6 +1,6 @@
11# Using a custom monad
22
3−In this section we will create and API for a book shelf without any backing DB storage.
3+In this section we will create an API for a book shelf without any backing DB storage.
44We will keep state in memory and share it between requests using `Reader` monad and `STM`.
55
66We start with a pretty standard set of imports and definition of the model:
doc/cookbook/using-custom-monad/using-custom-monad.cabal+3−3
@@ -1,14 +1,14 @@
1+cabal-version: 2.2
12name: cookbook-using-custom-monad
23version: 0.1
34synopsis: Using custom monad to pass a state between handlers
45homepage: http://docs.servant.dev/
5−license: BSD3
6+license: BSD-3-Clause
67license-file: ../../../servant/LICENSE
78author: Servant Contributors
89maintainer: haskell-servant-maintainers@googlegroups.com
910build-type: Simple
10−cabal-version: >=1.10
11−tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.1
11+tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
1212
1313executable cookbook-using-custom-monad
1414 main-is: UsingCustomMonad.lhs
doc/cookbook/using-free-client/UsingFreeClient.lhs+6−6
@@ -2,7 +2,7 @@
22
33or simply put: _a practical introduction to `Servant.Client.Free`_.
44
5−Someone asked on IRC how one could access the intermediate Requests (resp. Responses)
5+Someone asked on IRC how one could access the intermediate Requests (resp. Responses)
66produced (resp. received) by client functions derived using servant-client.
77My response to such inquiries is: to extend `servant-client` in an ad-hoc way (e.g for testing or debugging
88purposes), use `Servant.Client.Free`. This recipe shows how.
@@ -119,7 +119,7 @@ Now we can use `servant-client`'s internals to convert servant's `Request`
119119to http-client's `Request`, and we can inspect it:
120120
121121```haskell
122− let req' = I.requestToClientRequest burl req
122+ req' <- I.defaultMakeClientRequest burl req
123123 putStrLn $ "Making request: " ++ show req'
124124```
125125
@@ -136,12 +136,12 @@ and calling the continuation. We should get a `Pure` value.
136136
137137```haskell
138138 let res = I.clientResponseToResponse id res'
139−
139+
140140 case k res of
141141 Pure n ->
142142 putStrLn $ "Expected 1764, got " ++ show n
143− _ ->
144− putStrLn "ERROR: didn't got a response"
143+ _ ->
144+ putStrLn "ERROR: didn't get a response"
145145```
146146
147147So that's it. Using `Free` we can evaluate servant clients step-by-step, and
@@ -153,7 +153,7 @@ and responses available for us to inspect, since `RunClient` only gives us
153153access to one `Request` or `Response` at a time.
154154
155155On the other hand, a "batch collection" of requests and/or responses can be achieved
156−with both free clients and a custom `RunClient` instance rather easily, for example
156+with both free clients and a custom `RunClient` instance rather easily, for example
157157by using a `Writer [(Request, Response)]` monad.
158158
159159Here is an example of running our small `test` against a running server:
doc/cookbook/using-free-client/using-free-client.cabal+3−3
@@ -1,14 +1,14 @@
1+cabal-version: 2.2
12name: cookbook-using-free-client
23version: 0.1
34synopsis: Using Free client
45homepage: http://docs.servant.dev/
5−license: BSD3
6+license: BSD-3-Clause
67license-file: ../../../servant/LICENSE
78author: Servant Contributors
89maintainer: haskell-servant-maintainers@googlegroups.com
910build-type: Simple
10−cabal-version: >=1.10
11−tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.1
11+tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
1212
1313executable cookbook-using-free-client
1414 main-is: UsingFreeClient.lhs
doc/cookbook/uverb/UVerb.lhsnew file+223
@@ -0,0 +1,223 @@
1+# Listing alternative responses and exceptions in your API types
2+
3+Servant allows you to talk about the exceptions you throw in your API
4+types. This is not limited to actual exceptions, you can write
5+handlers that respond with arbitrary open unions of types.
6+
7+## Compatibility
8+
9+:warning: This cookbook is compatible with GHC 8.6.1 or higher :warning:
10+
11+## Preliminaries
12+
13+```haskell
14+{-# LANGUAGE ConstraintKinds #-}
15+{-# LANGUAGE DataKinds #-}
16+{-# LANGUAGE DeriveGeneric #-}
17+{-# LANGUAGE DerivingStrategies #-}
18+{-# LANGUAGE DeriveAnyClass #-}
19+{-# LANGUAGE DerivingVia #-}
20+{-# LANGUAGE FlexibleContexts #-}
21+{-# LANGUAGE FlexibleInstances #-}
22+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
23+{-# LANGUAGE InstanceSigs #-}
24+{-# LANGUAGE MultiParamTypeClasses #-}
25+{-# LANGUAGE OverloadedStrings #-}
26+{-# LANGUAGE ScopedTypeVariables #-}
27+{-# LANGUAGE StandaloneDeriving #-}
28+{-# LANGUAGE TypeApplications #-}
29+{-# LANGUAGE TypeFamilies #-}
30+{-# LANGUAGE TypeOperators #-}
31+{-# LANGUAGE UndecidableInstances #-}
32+{-# OPTIONS_GHC -Wall -Wno-orphans #-}
33+
34+import Control.Concurrent (threadDelay)
35+import Control.Concurrent.Async (async)
36+import Control.Monad (when)
37+import Control.Monad.Except (ExceptT (..), MonadError (..), MonadTrans (..), runExceptT)
38+import Data.Aeson (FromJSON (..), ToJSON (..))
39+import Data.Aeson.Encode.Pretty (encodePretty)
40+import Data.String.Conversions (cs)
41+import Data.Swagger (ToSchema)
42+import Data.Typeable (Proxy (Proxy))
43+import qualified GHC.Generics as GHC
44+import qualified Network.HTTP.Client as Client
45+import qualified Network.Wai.Handler.Warp as Warp
46+import Servant.API
47+import Servant.Client
48+import Servant.Server
49+import Servant.Swagger
50+```
51+
52+## The API
53+
54+This looks like a `Verb`-based routing table, except that `UVerb` has
55+no status, and carries a list of response types rather than a single
56+one. Each entry in the list carries its own response code.
57+
58+```haskell
59+type API =
60+ "fisx" :> Capture "bool" Bool
61+ :> UVerb 'GET '[JSON] '[FisxUser, WithStatus 303 String]
62+ :<|> "arian"
63+ :> UVerb 'GET '[JSON] '[WithStatus 201 ArianUser]
64+```
65+
66+Here are the details:
67+
68+```haskell
69+data FisxUser = FisxUser {name :: String}
70+ deriving (Eq, Show, GHC.Generic)
71+
72+instance ToJSON FisxUser
73+instance FromJSON FisxUser
74+instance ToSchema FisxUser
75+
76+-- | 'HasStatus' allows us to can get around 'WithStatus' if we want
77+-- to, and associate the status code with our resource types directly.
78+--
79+-- (To avoid orphan instances and make it more explicit what's in the
80+-- API and what isn't, we could even introduce a newtype 'Resource'
81+-- that wraps all the types we're using in our routing table, and then
82+-- define lots of 'HasStatus' instances for @Resource This@ and
83+-- @Resource That@.)
84+instance HasStatus FisxUser where
85+ type StatusOf FisxUser = 203
86+
87+data ArianUser = ArianUser
88+ deriving (Eq, Show, GHC.Generic)
89+
90+instance ToJSON ArianUser
91+instance FromJSON ArianUser
92+instance ToSchema ArianUser
93+```
94+
95+## Server, Client, Swagger
96+
97+You can just respond with any of the elements of the union in handlers.
98+
99+```haskell
100+fisx :: Bool -> Handler (Union '[FisxUser, WithStatus 303 String])
101+fisx True = respond (FisxUser "fisx")
102+fisx False = respond (WithStatus @303 ("still fisx" :: String))
103+
104+arian :: Handler (Union '[WithStatus 201 ArianUser])
105+arian = respond (WithStatus @201 ArianUser)
106+```
107+
108+You can create client functions like you're used to:
109+
110+```
111+fisxClient :: Bool -> ClientM (Union '[FisxUser, WithStatus 303 String])
112+arianClient :: ClientM (Union '[WithStatus 201 ArianUser])
113+(fisxClient :<|> arianClient) = client (Proxy @API)
114+```
115+
116+... and that's basically it! Here are a few sample commands that
117+show you how the swagger docs look like and how you can handle the
118+result unions in clients:
119+
120+```
121+main :: IO ()
122+main = do
123+ putStrLn . cs . encodePretty $ toSwagger (Proxy @API)
124+ _ <- async . Warp.run 8080 $ serve (Proxy @API) (fisx :<|> arian)
125+ threadDelay 50000
126+ mgr <- Client.newManager Client.defaultManagerSettings
127+ let cenv = mkClientEnv mgr (BaseUrl Http "localhost" 8080 "")
128+ result <- runClientM (fisxClient True) cenv
129+ print $ foldMapUnion (Proxy @Show) show <$> result
130+ print $ matchUnion @FisxUser <$> result
131+ print $ matchUnion @(WithStatus 303 String) <$> result
132+ pure ()
133+```
134+
135+## Idiomatic exceptions
136+
137+Since `UVerb` (probably) will mostly be used for error-like responses, it may be desirable to be able to early abort handler, like with current servant one would use `throwError` with `ServerError`.
138+
139+```haskell
140+newtype UVerbT xs m a = UVerbT { unUVerbT :: ExceptT (Union xs) m a }
141+ deriving (Functor, Applicative, Monad, MonadTrans)
142+
143+-- | Deliberately hide 'ExceptT's 'MonadError' instance to be able to use
144+-- underlying monad's instance.
145+instance MonadError e m => MonadError e (UVerbT xs m) where
146+ throwError = lift . throwError
147+ catchError (UVerbT act) h = UVerbT $ ExceptT $
148+ runExceptT act `catchError` (runExceptT . unUVerbT . h)
149+
150+-- | This combinator runs 'UVerbT'. It applies 'respond' internally, so the handler
151+-- may use the usual 'return'.
152+runUVerbT :: (Monad m, HasStatus x, IsMember x xs) => UVerbT xs m x -> m (Union xs)
153+runUVerbT (UVerbT act) = either id id <$> runExceptT (act >>= respond)
154+
155+-- | Short-circuit 'UVerbT' computation returning one of the response types.
156+throwUVerb :: (Monad m, HasStatus x, IsMember x xs) => x -> UVerbT xs m a
157+throwUVerb = UVerbT . ExceptT . fmap Left . respond
158+```
159+
160+Example usage:
161+
162+```haskell
163+data Foo = Foo Int Int Int
164+ deriving (Show, Eq, GHC.Generic, ToJSON)
165+ deriving HasStatus via WithStatus 200 Foo
166+
167+data Bar = Bar
168+ deriving (Show, Eq, GHC.Generic)
169+
170+instance ToJSON Bar
171+
172+h :: Handler (Union '[Foo, WithStatus 400 Bar])
173+h = runUVerbT $ do
174+ when ({- something bad -} True) $
175+ throwUVerb $ WithStatus @400 Bar
176+
177+ when ({- really bad -} False) $
178+ throwError $ err500
179+
180+ -- a lot of code here...
181+
182+ return $ Foo 1 2 3
183+```
184+
185+## Related Work
186+
187+There is the [issue from
188+2017](https://github.com/haskell-servant/servant/issues/841) that was
189+resolved by the introduction of `UVerb`, with a long discussion on
190+alternative designs.
191+
192+[servant-checked-exceptions](https://hackage.haskell.org/package/servant-checked-exceptions)
193+is a good solution to the problem, but it restricts the user to JSON
194+and a very specific envelop encoding for the union type, which is
195+often not acceptable. (One good reason for this design choice is that
196+it makes writing clients easier, where you need to get to the union
197+type from one representative, and you don't want to run several
198+parsers in the hope that the ones that should will always error out so
199+you can try until the right one returns a value.)
200+
201+[servant-exceptions](https://github.com/ch1bo/servant-exceptions) is
202+another shot at the problem. It is inspired by
203+servant-checked-exceptions, so it may be worth taking a closer look.
204+The README claims that
205+[cardano-sl](https://github.com/input-output-hk/cardano-sl) also has
206+some code for generalized error handling.
207+
208+In an earier version of the `UVerb` implementation, we have used some
209+code from
210+[world-peace](https://hackage.haskell.org/package/world-peace), but
211+that package itself wasn't flexible enough, and we had to use
212+[sop-core](https://hackage.haskell.org/package/sop-core) to implement
213+the `HasServer` instance.
214+
215+Here is a blog post we found on the subject:
216+https://lukwagoallan.com/posts/unifying-servant-server-error-responses
217+
218+(If you have anything else, please add it here or let us know.)
219+
220+```haskell
221+main :: IO ()
222+main = return ()
223+```
doc/cookbook/uverb/uverb.cabalnew file+35
@@ -0,0 +1,35 @@
1+cabal-version: 2.2
2+name: cookbook-uverb
3+version: 0.0.1
4+synopsis: How to use the 'UVerb' type.
5+description: Listing alternative responses and exceptions in your API types.
6+homepage: http://docs.servant.dev/
7+license: BSD-3-Clause
8+license-file: ../../../servant/LICENSE
9+author: Servant Contributors
10+maintainer: haskell-servant-maintainers@googlegroups.com
11+category: Servant
12+build-type: Simple
13+tested-with: GHC==8.6.5, GHC==8.8.4, GHC==8.10.7
14+
15+executable cookbook-uverb
16+ main-is: UVerb.lhs
17+ build-depends: base == 4.*
18+ , aeson >= 1.2
19+ , aeson-pretty >= 0.8.8
20+ , async
21+ , http-client
22+ , mtl
23+ , servant
24+ , servant-client
25+ , servant-server
26+ , servant-swagger
27+ , string-conversions
28+ , swagger2
29+ , wai
30+ , warp
31+ if impl(ghc >= 9)
32+ buildable: False
33+ default-language: Haskell2010
34+ ghc-options: -Wall -pgmL markdown-unlit
35+ build-tool-depends: markdown-unlit:markdown-unlit
doc/links.rst+1−1
@@ -12,7 +12,7 @@ Helpful Links
1212 `https://github.com/haskell-servant/servant/issues <https://github.com/haskell-servant/servant/issues>`_
1313
1414- the irc channel:
15− ``#servant`` on freenode
15+ `#haskell-servant on libera.chat <https://web.libera.chat/#haskell-servant>`_
1616
1717- the mailing list:
1818 `groups.google.com/forum/#!forum/haskell-servant <https://groups.google.com/forum/#!forum/haskell-servant>`_
doc/requirements.txt+1
@@ -1,3 +1,4 @@
11recommonmark==0.5.0
22Sphinx==1.8.4
33sphinx_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
389389with the rest of your API. But you can plug in everything that is an
390390`Application`, e.g. a whole web application written in any of the web
391391frameworks 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+7−8
@@ -47,7 +47,6 @@ module Authentication where
4747import Data.Aeson (ToJSON)
4848import Data.ByteString (ByteString)
4949import Data.Map (Map, fromList)
50−import Data.Monoid ((<>))
5150import qualified Data.Map as Map
5251import Data.Proxy (Proxy (Proxy))
5352import Data.Text (Text)
@@ -108,7 +107,7 @@ API with "private." Additionally, the private parts of our API use the
108107realm for this authentication is `"foo-realm"`).
109108
110109Unfortunately we're not done. When someone makes a request to our `"private"`
111−API, we're going to need to provide to servant the logic for validifying
110+API, we're going to need to provide to servant the logic for validating
112111usernames and passwords. This adds a certain conceptual wrinkle in servant's
113112design that we'll briefly discuss. If you want the **TL;DR**: we supply a lookup
114113function to servant's new `Context` primitive.
@@ -133,7 +132,7 @@ combinator. Using `Context`, we can supply a function of type
133132handler. This will allow the handler to check authentication and return a `User`
134133to downstream handlers if successful.
135134
136−In practice we wrap `BasicAuthData -> Handler` into a slightly
135+In practice we wrap `BasicAuthData -> Handler User` into a slightly
137136different function to better capture the semantics of basic authentication:
138137
139138``` haskell ignore
@@ -260,7 +259,7 @@ this.
260259
261260Let's implement a trivial authentication scheme. We will protect our API by
262261looking for a cookie named `"servant-auth-cookie"`. This cookie's value will
263−contain a key from which we can lookup a `Account`.
262+contain a key from which we can lookup an `Account`.
264263
265264```haskell
266265-- | An account type that we "fetch from the database" after
@@ -274,7 +273,7 @@ database = fromList [ ("key1", Account "Anne Briggs")
274273 , ("key3", Account "Ghédalia Tazartès")
275274 ]
276275
277−-- | A method that, when given a password, will return a Account.
276+-- | A method that, when given a password, will return an Account.
278277-- This is our bespoke (and bad) authentication logic.
279278lookupAccount :: ByteString -> Handler Account
280279lookupAccount key = case Map.lookup key database of
@@ -346,7 +345,7 @@ genAuthServerContext = authHandler :. EmptyContext
346345
347346-- | Our API, where we provide all the author-supplied handlers for each end
348347-- point. Note that 'privateDataFunc' is a function that takes 'Account' as an
349−-- argument. We dont' worry about the authentication instrumentation here,
348+-- argument. We don't worry about the authentication instrumentation here,
350349-- that is taken care of by supplying context
351350genAuthServer :: Server AuthGenAPI
352351genAuthServer =
@@ -385,11 +384,11 @@ Creating a generalized, ad-hoc authentication scheme was fairly straight
385384forward:
386385
3873861. use the `AuthProtect` combinator to protect your API.
388−2. choose a application-specific data type used by your server when
387+2. choose an application-specific data type used by your server when
389388authentication is successful (in our case this was `Account`).
3903893. Create a value of `AuthHandler Request Account` which encapsulates the
391390authentication logic (`Request -> Handler Account`). This function
392−will be executed everytime a request matches a protected route.
391+will be executed every time a request matches a protected route.
3933924. Provide an instance of the `AuthServerData` type family, specifying your
394393application-specific data type returned when authentication is successful (in
395394our case this was `Account`).
doc/tutorial/Client.lhs+2−2
@@ -161,7 +161,7 @@ The types of the arguments for the functions are the same as for (server-side) r
161161## Changing the monad the client functions live in
162162
163163Just like `hoistServer` allows us to change the monad in which request handlers
164−of a web application live in, we also have `hoistClient` for changing the monad
164+of a web application live, we also have `hoistClient` for changing the monad
165165in which _client functions_ live. Consider the following trivial API:
166166
167167``` haskell
@@ -173,7 +173,7 @@ hoistClientAPI = Proxy
173173
174174We already know how to derive client functions for this API, and as we have
175175seen above they all return results in the `ClientM` monad when using `servant-client`.
176−However, `ClientM` rarely (or never) is the actual monad we need to use the client
176+However, `ClientM` is rarely (or never) the actual monad we need to use the client
177177functions in. Sometimes we need to run them in IO, sometimes in a custom monad
178178stack. `hoistClient` is a very simple solution to the problem of "changing" the monad
179179the clients run in.
doc/tutorial/Docs.lhs+2−2
@@ -77,7 +77,7 @@ instance ToSample HelloMessage where
7777 [ ("When a value is provided for 'name'", HelloMessage "Hello, Alp")
7878 , ("When 'name' is not specified", HelloMessage "Hello, anonymous coward")
7979 ]
80− -- mutliple examples to display this time
80+ -- multiple examples to display this time
8181
8282ci :: ClientInfo
8383ci = ClientInfo "Alp" "alp@foo.com" 26 ["haskell", "mathematics"]
@@ -108,7 +108,7 @@ apiDocs = docs exampleAPI
108108markdown :: API -> String
109109```
110110
111−That lets us see what our API docs look down in markdown, by looking at `markdown apiDocs`.
111+That lets us see what our API docs look like in markdown, by looking at `markdown apiDocs`.
112112
113113````````` text
114114## GET /hello
doc/tutorial/Javascript.lhs+2−2
@@ -228,13 +228,13 @@ data CommonGeneratorOptions = CommonGeneratorOptions
228228 {
229229 -- | function generating function names
230230 functionNameBuilder :: FunctionName -> Text
231− -- | name used when a user want to send the request body (to let you redefine it)
231+ -- | name used when a user wants to send the request body (to let you redefine it)
232232 , requestBody :: Text
233233 -- | name of the callback parameter when the request was successful
234234 , successCallback :: Text
235235 -- | name of the callback parameter when the request reported an error
236236 , errorCallback :: Text
237− -- | namespace on which we define the js function (empty mean local var)
237+ -- | namespace on which we define the js function (empty means local var)
238238 , moduleName :: Text
239239 -- | a prefix that should be prepended to the URL in the generated JS
240240 , urlPrefix :: Text
doc/tutorial/Server.lhs+9−9
@@ -183,7 +183,7 @@ users2 = [isaac, albert]
183183
184184Now, just like we separate the various endpoints in `UserAPI` with `:<|>`, we
185185are going to separate the handlers with `:<|>` too! They must be provided in
186−the same order as in in the API type.
186+the same order as in the API type.
187187
188188``` haskell
189189server2 :: Server UserAPI2
@@ -313,8 +313,8 @@ For reference, here's a list of some combinators from **servant**:
313313## The `FromHttpApiData`/`ToHttpApiData` classes
314314
315315Wait... How does **servant** know how to decode the `Int`s from the URL? Or how
316−to decode a `ClientInfo` value from the request body? This is what this and the
317−following two sections address.
316+to decode a `ClientInfo` value from the request body? The following three sections will
317+help us answer these questions.
318318
319319`Capture`s and `QueryParam`s are represented by some textual value in URLs.
320320`Header`s are similarly represented by a pair of a header name and a
@@ -620,7 +620,7 @@ In short, this means that a handler of type `Handler a` is simply
620620equivalent to a computation of type `IO (Either ServerError a)`, that is, an IO
621621action that either returns an error or a result.
622622
623−The module [`Control.Monad.Except`](https://hackage.haskell.org/package/mtl-2.2.1/docs/Control-Monad-Except.html#t:ExceptT)
623+The module [`Control.Monad.Except`](https://hackage.haskell.org/package/mtl/docs/Control-Monad-Except.html#t:ExceptT)
624624from which `ExceptT` comes is worth looking at.
625625Perhaps most importantly, `ExceptT` and `Handler` are instances of `MonadError`, so
626626`throwError` can be used to return an error from your handler (whereas `return`
@@ -634,7 +634,7 @@ kind and abort early. The next two sections cover how to do just that.
634634
635635Other important instances from the list above are `MonadIO m => MonadIO
636636(ExceptT e m)`, and therefore also `MonadIO Handler` as there is a `MonadIO IO` instance.
637−[`MonadIO`](http://hackage.haskell.org/package/transformers-0.4.3.0/docs/Control-Monad-IO-Class.html)
637+[`MonadIO`](http://hackage.haskell.org/package/base/docs/Control-Monad-IO-Class.html#t:MonadIO)
638638is a class from the **transformers** package defined as:
639639
640640``` haskell ignore
@@ -716,7 +716,7 @@ $ curl --verbose http://localhost:8081/myfile.txt
716716>
717717< HTTP/1.1 404 Not Found
718718[snip]
719−myfile.txt just isnt there, please leave this server alone.
719+myfile.txt just isn't there, please leave this server alone.
720720
721721$ echo Hello > myfile.txt
722722
@@ -818,7 +818,7 @@ If it doesn't exist, the handler will fail with a `404` status code.
818818
819819`serveDirectoryWebApp` uses some standard settings that fit the use case of
820820serving static files for most web apps. You can find out about the other
821−options in the documentation of the `Servant.Utils.StaticFiles` module.
821+options in the documentation of the `Servant.Server.StaticFiles` module.
822822
823823## Nested APIs
824824
@@ -1135,7 +1135,7 @@ true
11351135### An arrow is a reader too.
11361136
11371137In previous versions of `servant` we had an `enter` to do what `hoistServer`
1138−does now. `enter` had a ambitious design goals, but was problematic in practice.
1138+does now. `enter` had an ambitious design goals, but was problematic in practice.
11391139
11401140One problematic situation was when the source monad was `(->) r`, yet it's
11411141handy in practice, because `(->) r` is isomorphic to `Reader r`.
@@ -1166,7 +1166,7 @@ back a *stream* of results, served one at a time. Stream endpoints only provide
11661166a single content type, and also specify what framing strategy is used to
11671167delineate the results. To serve these results, we need to give back a stream
11681168producer. Adapters can be written to *Pipes*, *Conduit* and the like, or
1169−written directly as `SourceIO`s. SourceIO builts upon servant's own `SourceT`
1169+written directly as `SourceIO`s. SourceIO builds upon servant's own `SourceT`
11701170stream type (it's simpler than *Pipes* or *Conduit*).
11711171The API of a streaming endpoint needs to explicitly specify which sort of
11721172generator it produces. Note that the generator itself is returned by a
doc/tutorial/index.rst+1−37
@@ -6,46 +6,10 @@ This is an introductory tutorial to **servant**. Whilst browsing is fine, it mak
66Any comments, issues or feedback about the tutorial can be submitted
77to `servant's issue tracker <http://github.com/haskell-servant/servant/issues>`_.
88
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−
469.. toctree::
4710 :maxdepth: 1
4811
12+ install.rst
4913 ApiType.lhs
5014 Server.lhs
5115 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/test/Spec.hs+11−1
@@ -1 +1,11 @@
1−{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
1+module Main where
2+
3+import qualified JavascriptSpec
4+
5+import Test.Hspec (Spec, hspec, describe)
6+
7+main :: IO ()
8+main = hspec spec
9+
10+spec :: Spec
11+spec = describe "Javascript" JavascriptSpec.spec
doc/tutorial/tutorial.cabal+6−11
@@ -1,3 +1,4 @@
1+cabal-version: 2.2
12name: tutorial
23version: 0.10
34synopsis: The servant tutorial
@@ -6,18 +7,14 @@ description:
67 <http://docs.servant.dev/>
78homepage: http://docs.servant.dev/
89category: Servant, Documentation
9−license: BSD3
10+license: BSD-3-Clause
1011license-file: LICENSE
1112author: Servant Contributors
1213maintainer: haskell-servant-maintainers@googlegroups.com
1314build-type: Simple
14−cabal-version: >=1.10
1515tested-with:
16− GHC==8.0.2
17− GHC==8.2.2
18− GHC==8.4.4
1916 GHC==8.6.5
20− GHC==8.8.1
17+ GHC==8.8.3, GHC ==8.10.7
2118extra-source-files:
2219 static/index.html
2320 static/ui.js
@@ -67,10 +64,10 @@ library
6764 , blaze-markup >= 0.8.0.0 && < 0.9
6865 , cookie >= 0.4.3 && < 0.5
6966 , js-jquery >= 3.3.1 && < 3.4
70− , lucid >= 2.9.11 && < 2.10
71− , random >= 1.1 && < 1.2
67+ , lucid >= 2.9.11 && < 2.12
68+ , random >= 1.1 && < 1.3
7269 , servant-js >= 0.9 && < 0.10
73− , time >= 1.6.0.1 && < 1.10
70+ , time >= 1.6.0.1 && < 1.13
7471
7572 -- For legacy tools, we need to specify build-depends too
7673 build-depends: markdown-unlit >= 0.5.0 && <0.6
@@ -83,8 +80,6 @@ test-suite spec
8380 hs-source-dirs: test
8481 main-is: Spec.hs
8582 other-modules: JavascriptSpec
86− build-tool-depends:
87− hspec-discover:hspec-discover
8883 build-depends: base
8984 , tutorial
9085 , hspec
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+18
@@ -21,3 +21,21 @@ a particular ghc version, e.g:
2121``` sh
2222$ nix-shell nix/shell.nix --argstr compiler ghcHEAD
2323```
24+
25+**Possible GHC versions**
26+- `ghc865Binary`
27+- `ghc884`
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.jsonnew file+4
@@ -0,0 +1,4 @@
1+{
2+ "rev" : "05f0934825c2a0750d4888c4735f9420c906b388",
3+ "sha256" : "1g8c2w0661qn89ajp44znmwfmghbbiygvdzq0rzlvlpdiz28v6gy"
4+}
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+17−18
@@ -1,21 +1,20 @@
1−{ pkgs ? import <nixpkgs> {}
2−, compiler ? "ghc822"
1+{ compiler ? "ghc8104"
32, tutorial ? false
3+, pkgs ? import ./nixpkgs.nix
44}:
5+
6+ with pkgs;
57
6−with pkgs;
7−
8−let
9− ghc = haskell.packages.${compiler}.ghcWithPackages (_: []);
10− docstuffs = python3.withPackages (ps: with ps; [ recommonmark sphinx sphinx_rtd_theme ]);
11−in
12−
13−stdenv.mkDerivation {
14− name = "servant-dev";
15− buildInputs = [ ghc zlib python3 wget ]
16− ++ (if tutorial then [docstuffs postgresql] else []);
17− shellHook = ''
18− eval $(grep export ${ghc}/bin/ghc)
19− export LD_LIBRARY_PATH="${zlib}/lib";
20− '';
21−}
8+ let
9+ ghc = haskell.packages.${compiler}.ghcWithPackages (_: []);
10+ docstuffs = python3.withPackages (ps: with ps; [ recommonmark sphinx sphinx_rtd_theme ]);
11+ in
12+ stdenv.mkDerivation {
13+ name = "servant-dev";
14+ buildInputs = [ ghc zlib python3 wget cabal-install postgresql openssl stack haskellPackages.hspec-discover ]
15+ ++ (if tutorial then [docstuffs postgresql] else []);
16+ shellHook = ''
17+ eval $(grep export ${ghc}/bin/ghc)
18+ export LD_LIBRARY_PATH=$LD_LIBRARY_PATH:"${zlib}/lib";
19+ '';
20+ }
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-jsaddle/LICENSE → servant-auth/servant-auth-client/LICENSErenamed+3−2
@@ -1,4 +1,4 @@
1−Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, Servant Contributors
1+Copyright Julian K. Arni (c) 2015
22
33All rights reserved.
44
@@ -13,7 +13,7 @@ modification, are permitted provided that the following conditions are met:
1313 disclaimer in the documentation and/or other materials provided
1414 with the distribution.
1515
16− * Neither the name of Zalora South East Asia Pte Ltd nor the names of other
16+ * Neither the name of Julian K. Arni nor the names of other
1717 contributors may be used to endorse or promote products derived
1818 from this software without specific prior written permission.
1919
@@ -28,3 +28,4 @@ DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
2828THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
2929(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
3030OF 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+110−1
@@ -1,6 +1,115 @@
11[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-client-core/CHANGELOG.md)
22[Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)
33
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+
35+0.18.3
36+------
37+
38+### Significant changes
39+
40+- Add response header support to UVerb (#1420)
41+
42+### Other changes
43+
44+- Support GHC-9.0.1.
45+- Bump `bytestring`, `hspec`, `base64-bytestring` and `QuickCheck` dependencies.
46+
47+0.18.2
48+------
49+
50+### Significant changes
51+
52+- Support `Fragment` combinator.
53+
54+0.18.1
55+------
56+
57+### Significant changes
58+
59+- Union verbs
60+
61+### Other changes
62+
63+- Bump "tested-with" ghc versions
64+- Loosen bound on base16-bytestring
65+
66+0.18
67+----
68+
69+### Significant changes
70+
71+- Support for ghc8.8 (#1318, #1326, #1327)
72+
73+
74+0.17
75+----
76+
77+### Significant changes
78+
79+- Add NoContentVerb [#1028](https://github.com/haskell-servant/servant/issues/1028) [#1219](https://github.com/haskell-servant/servant/pull/1219) [#1228](https://github.com/haskell-servant/servant/pull/1228)
80+
81+ The `NoContent` API endpoints should now use `NoContentVerb` combinator.
82+ The API type changes are usually of the kind
83+
84+ ```diff
85+ - :<|> PostNoContent '[JSON] NoContent
86+ + :<|> PostNoContent
87+ ```
88+
89+ i.e. one doesn't need to specify the content-type anymore. There is no content.
90+
91+- `Capture` can be `Lenient` [#1155](https://github.com/haskell-servant/servant/issues/1155) [#1156](https://github.com/haskell-servant/servant/pull/1156)
92+
93+ You can specify a lenient capture as
94+
95+ ```haskell
96+ :<|> "capture-lenient" :> Capture' '[Lenient] "foo" Int :> GET
97+ ```
98+
99+ which will make the capture always succeed. Handlers will be of the
100+ type `Either String CapturedType`, where `Left err` represents
101+ the possible parse failure.
102+
103+### Other changes
104+
105+- *servant-client* *servant-client-core* *servant-http-streams* Fix Verb with headers checking content type differently [#1200](https://github.com/haskell-servant/servant/issues/1200) [#1204](https://github.com/haskell-servant/servant/pull/1204)
106+
107+ For `Verb`s with response `Headers`, the implementation didn't check
108+ for the content-type of the response. Now it does.
109+
110+- *servant-client* *servant-http-streams* `HasClient` instance for `Stream` with `Headers` [#1170](https://github.com/haskell-servant/servant/issues/1170) [#1197](https://github.com/haskell-servant/servant/pull/1197)
111+- *servant-client* Redact the authorization header in Show and exceptions [#1238](https://github.com/haskell-servant/servant/pull/1238)
112+
41130.16
5114----
6115
@@ -166,7 +275,7 @@
166275
167276- *servant-client-core* Add `hoistClient` to `HasClient`.
168277 Just like `hoistServer` allows us to change the monad in which request handlers
169− of a web application live in, we also have `hoistClient` for changing the monad
278+ of a web application live, we also have `hoistClient` for changing the monad
170279 in which *client functions* live.
171280 Read [tutorial section for more information](https://docs.servant.dev/en/release-0.14/tutorial/Client.html#changing-the-monad-the-client-functions-live-in).
172281 ([#936](https://github.com/haskell-servant/servant/pull/936))
servant-client-core/servant-client-core.cabal+21−23
@@ -1,6 +1,6 @@
1−cabal-version: >=1.10
1+cabal-version: 2.2
22name: servant-client-core
3−version: 0.16
3+version: 0.19
44
55synopsis: Core functionality and class for client function generation for servant APIs
66category: Servant, Web
@@ -10,19 +10,14 @@ description:
1010
1111homepage: http://docs.servant.dev/
1212bug-reports: http://github.com/haskell-servant/servant/issues
13−license: BSD3
13+license: BSD-3-Clause
1414license-file: LICENSE
1515author: Servant Contributors
1616maintainer: haskell-servant-maintainers@googlegroups.com
1717copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors
1818build-type: Simple
19−tested-with:
20− GHC ==8.0.2
21− || ==8.2.2
22− || ==8.4.4
23− || ==8.6.5
24− || ==8.8.1
25− , GHCJS == 8.4
19+tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1
20+ , GHCJS ==8.6.0.1
2621
2722extra-source-files:
2823 CHANGELOG.md
@@ -55,13 +50,14 @@ library
5550 --
5651 -- note: mtl lower bound is so low because of GHC-7.8
5752 build-depends:
58− base >= 4.9 && < 4.14
59− , bytestring >= 0.10.8.1 && < 0.11
53+ base >= 4.9 && < 4.18
54+ , bytestring >= 0.10.8.1 && < 0.12
55+ , constraints >= 0.2 && < 0.14
6056 , containers >= 0.5.7.1 && < 0.7
6157 , deepseq >= 1.4.2.0 && < 1.5
62− , text >= 1.2.3.0 && < 1.3
63− , transformers >= 0.5.2.0 && < 0.6
64− , template-haskell >= 2.11.1.0 && < 2.16
58+ , text >= 1.2.3.0 && < 2.1
59+ , transformers >= 0.5.2.0 && < 0.7
60+ , template-haskell >= 2.11.1.0 && < 2.20
6561
6662 if !impl(ghc >= 8.2)
6763 build-depends:
@@ -69,20 +65,21 @@ library
6965
7066 -- Servant dependencies
7167 build-depends:
72− servant >= 0.16 && <0.17
68+ servant >= 0.19
7369
7470 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.
7571 -- Here can be exceptions if we really need features from the newer versions.
7672 build-depends:
77− aeson >= 1.4.1.0 && < 1.5
78− , base-compat >= 0.10.5 && < 0.12
79− , base64-bytestring >= 1.0.0.1 && < 1.1
73+ aeson >= 1.4.1.0 && < 3
74+ , base-compat >= 0.10.5 && < 0.13
75+ , base64-bytestring >= 1.0.0.1 && < 1.3
8076 , exceptions >= 0.10.0 && < 0.11
8177 , free >= 5.1 && < 5.2
8278 , http-media >= 0.7.1.3 && < 0.9
8379 , http-types >= 0.12.2 && < 0.13
8480 , network-uri >= 2.6.1.0 && < 2.7
8581 , safe >= 0.3.17 && < 0.4
82+ , sop-core >= 0.4.0.0 && < 0.6
8683
8784 hs-source-dirs: src
8885 default-language: Haskell2010
@@ -96,6 +93,7 @@ test-suite spec
9693 main-is: Spec.hs
9794 other-modules:
9895 Servant.Client.Core.Internal.BaseUrlSpec
96+ Servant.Client.Core.RequestSpec
9997
10098 -- Dependencies inherited from the library. No need to specify bounds.
10199 build-depends:
@@ -103,11 +101,11 @@ test-suite spec
103101 , base-compat
104102 , servant-client-core
105103
106− -- Additonal dependencies
104+ -- Additional dependencies
107105 build-depends:
108106 deepseq >= 1.4.2.0 && < 1.5
109− , hspec >= 2.6.0 && < 2.8
110− , QuickCheck >= 2.12.6.1 && < 2.14
107+ , hspec >= 2.6.0 && < 2.10
108+ , QuickCheck >= 2.12.6.1 && < 2.15
111109
112110 build-tool-depends:
113− hspec-discover:hspec-discover >= 2.6.0 && <2.8
111+ hspec-discover:hspec-discover >= 2.6.0 && <2.10
servant-client-core/src/Servant/Client/Core.hs+3
@@ -18,6 +18,8 @@ module Servant.Client.Core
1818 -- * Client generation
1919 clientIn
2020 , HasClient(..)
21+ , foldMapUnion
22+ , matchUnion
2123
2224 -- * Request
2325 , Request
@@ -57,6 +59,7 @@ module Servant.Client.Core
5759 , appendToPath
5860 , setRequestBodyLBS
5961 , setRequestBody
62+ , encodeQueryParamValue
6063 ) where
6164import Servant.Client.Core.Auth
6265import Servant.Client.Core.BaseUrl
servant-client-core/src/Servant/Client/Core/BasicAuth.hs−2
@@ -9,8 +9,6 @@ module Servant.Client.Core.BasicAuth (
99
1010import Data.ByteString.Base64
1111 (encode)
12−import Data.Monoid
13− ((<>))
1412import Data.Text.Encoding
1513 (decodeUtf8)
1614import Servant.API.BasicAuth
servant-client-core/src/Servant/Client/Core/HasClient.hs+328−30
@@ -1,3 +1,4 @@
1+{-# LANGUAGE ConstraintKinds #-}
12{-# LANGUAGE DataKinds #-}
23{-# LANGUAGE FlexibleContexts #-}
34{-# LANGUAGE FlexibleInstances #-}
@@ -5,8 +6,10 @@
56{-# LANGUAGE MultiParamTypeClasses #-}
67{-# LANGUAGE OverloadedStrings #-}
78{-# LANGUAGE PolyKinds #-}
9+{-# LANGUAGE QuantifiedConstraints #-}
810{-# LANGUAGE RankNTypes #-}
911{-# LANGUAGE ScopedTypeVariables #-}
12+{-# LANGUAGE TypeApplications #-}
1013{-# LANGUAGE TypeFamilies #-}
1114{-# LANGUAGE TypeOperators #-}
1215{-# LANGUAGE UndecidableInstances #-}
@@ -15,48 +18,80 @@ module Servant.Client.Core.HasClient (
1518 clientIn,
1619 HasClient (..),
1720 EmptyClient (..),
21+ AsClientT,
22+ (//),
23+ (/:),
24+ foldMapUnion,
25+ matchUnion,
1826 ) where
1927
2028import Prelude ()
2129import Prelude.Compat
2230
31+import Control.Arrow
32+ (left, (+++))
2333import Control.Monad
2434 (unless)
25−import qualified Data.ByteString.Lazy as BL
35+import qualified Data.ByteString as BS
36+import qualified Data.ByteString.Lazy as BL
37+import Data.Either
38+ (partitionEithers)
39+import Data.Constraint (Dict(..))
2640import Data.Foldable
2741 (toList)
2842import Data.List
2943 (foldl')
30−import Data.Proxy
31− (Proxy (Proxy))
3244import Data.Sequence
3345 (fromList)
3446import qualified Data.Text as T
3547import Network.HTTP.Media
36− (MediaType, matches, parseAccept, (//))
48+ (MediaType, matches, parseAccept)
49+import qualified Network.HTTP.Media as Media
50+import qualified Data.Sequence as Seq
51+import Data.SOP.BasicFunctors
52+ (I (I), (:.:) (Comp))
53+import Data.SOP.Constraint
54+ (All)
55+import Data.SOP.NP
56+ (NP (..), cpure_NP)
57+import Data.SOP.NS
58+ (NS (S))
3759import Data.String
3860 (fromString)
3961import Data.Text
4062 (Text, pack)
63+import Data.Proxy
64+ (Proxy (Proxy))
4165import GHC.TypeLits
42− (KnownSymbol, symbolVal)
66+ (KnownNat, KnownSymbol, TypeError, symbolVal)
67+import Network.HTTP.Types
68+ (Status)
4369import qualified Network.HTTP.Types as H
4470import Servant.API
4571 ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, BasicAuthData,
4672 BuildHeadersTo (..), Capture', CaptureAll, Description,
47− EmptyAPI, FramingRender (..), FramingUnrender (..),
73+ EmptyAPI, Fragment, FramingRender (..), FramingUnrender (..),
4874 FromSourceIO (..), Header', Headers (..), HttpVersion,
4975 IsSecure, MimeRender (mimeRender),
50− MimeUnrender (mimeUnrender), NoContent (NoContent), QueryFlag,
51− QueryParam', QueryParams, Raw, ReflectMethod (..), RemoteHost,
52− ReqBody', SBoolI, Stream, StreamBody', Summary, ToHttpApiData,
53− ToSourceIO (..), Vault, Verb, NoContentVerb, WithNamedContext,
54− contentType, getHeadersHList, getResponse, toQueryParam,
55− toUrlPiece)
76+ MimeUnrender (mimeUnrender), NoContent (NoContent),
77+ NoContentVerb, QueryFlag, QueryParam', QueryParams, Raw, RawM,
78+ ReflectMethod (..), RemoteHost, ReqBody', SBoolI, Stream,
79+ StreamBody', Summary, ToHttpApiData, ToSourceIO (..), Vault,
80+ Verb, WithNamedContext, WithResource, WithStatus (..), contentType, getHeadersHList,
81+ getResponse, toEncodedUrlPiece, toUrlPiece, NamedRoutes)
82+import Servant.API.Generic
83+ (GenericMode(..), ToServant, ToServantApi
84+ , GenericServant, toServant, fromServant)
5685import Servant.API.ContentTypes
57− (contentTypes)
86+ (contentTypes, AllMime (allMime), AllMimeUnrender (allMimeUnrender))
87+import Servant.API.Status
88+ (statusFromNat)
89+import Servant.API.TypeLevel (FragmentUnique, AtLeastOneFragment)
5890import Servant.API.Modifiers
5991 (FoldRequired, RequiredArgument, foldRequiredArgument)
92+import Servant.API.TypeErrors
93+import Servant.API.UVerb
94+ (HasStatus, HasStatuses (Statuses, statuses), UVerb, Union, Unique, inject, statusOf, foldMapUnion, matchUnion)
6095
6196import Servant.Client.Core.Auth
6297import Servant.Client.Core.BasicAuth
@@ -173,7 +208,7 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m api)
173208 clientWithRoute pm (Proxy :: Proxy api)
174209 (appendToPath p req)
175210
176− where p = (toUrlPiece val)
211+ where p = toEncodedUrlPiece val
177212
178213 hoistClientMonad pm _ f cl = \a ->
179214 hoistClientMonad pm (Proxy :: Proxy api) f (cl a)
@@ -208,7 +243,7 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m sublayout)
208243 clientWithRoute pm (Proxy :: Proxy sublayout)
209244 (foldl' (flip appendToPath) req ps)
210245
211− where ps = map (toUrlPiece) vals
246+ where ps = map toEncodedUrlPiece vals
212247
213248 hoistClientMonad pm _ f cl = \as ->
214249 hoistClientMonad pm (Proxy :: Proxy sublayout) f (cl as)
@@ -216,10 +251,11 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m sublayout)
216251instance {-# OVERLAPPABLE #-}
217252 -- Note [Non-Empty Content Types]
218253 ( RunClient m, MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)
254+ , KnownNat status
219255 ) => HasClient m (Verb method status cts' a) where
220256 type Client m (Verb method status cts' a) = m a
221257 clientWithRoute _pm Proxy req = do
222− response <- runRequest req
258+ response <- runRequestAcceptStatus (Just [status]) req
223259 { requestAccept = fromList $ toList accept
224260 , requestMethod = method
225261 }
@@ -227,18 +263,20 @@ instance {-# OVERLAPPABLE #-}
227263 where
228264 accept = contentTypes (Proxy :: Proxy ct)
229265 method = reflectMethod (Proxy :: Proxy method)
266+ status = statusFromNat (Proxy :: Proxy status)
230267
231268 hoistClientMonad _ _ f ma = f ma
232269
233270instance {-# OVERLAPPING #-}
234− ( RunClient m, ReflectMethod method
271+ ( RunClient m, ReflectMethod method, KnownNat status
235272 ) => HasClient m (Verb method status cts NoContent) where
236273 type Client m (Verb method status cts NoContent)
237274 = m NoContent
238275 clientWithRoute _pm Proxy req = do
239− _response <- runRequest req { requestMethod = method }
276+ _response <- runRequestAcceptStatus (Just [status]) req { requestMethod = method }
240277 return NoContent
241278 where method = reflectMethod (Proxy :: Proxy method)
279+ status = statusFromNat (Proxy :: Proxy status)
242280
243281 hoistClientMonad _ _ f ma = f ma
244282
@@ -255,13 +293,13 @@ instance (RunClient m, ReflectMethod method) =>
255293
256294instance {-# OVERLAPPING #-}
257295 -- Note [Non-Empty Content Types]
258− ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls
296+ ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls, KnownNat status
259297 , ReflectMethod method, cts' ~ (ct ': cts)
260298 ) => HasClient m (Verb method status cts' (Headers ls a)) where
261299 type Client m (Verb method status cts' (Headers ls a))
262300 = m (Headers ls a)
263301 clientWithRoute _pm Proxy req = do
264− response <- runRequest req
302+ response <- runRequestAcceptStatus (Just [status]) req
265303 { requestMethod = method
266304 , requestAccept = fromList $ toList accept
267305 }
@@ -269,25 +307,115 @@ instance {-# OVERLAPPING #-}
269307 return $ Headers { getResponse = val
270308 , getHeadersHList = buildHeadersTo . toList $ responseHeaders response
271309 }
272− where method = reflectMethod (Proxy :: Proxy method)
273− accept = contentTypes (Proxy :: Proxy ct)
310+ where
311+ method = reflectMethod (Proxy :: Proxy method)
312+ accept = contentTypes (Proxy :: Proxy ct)
313+ status = statusFromNat (Proxy :: Proxy status)
274314
275315 hoistClientMonad _ _ f ma = f ma
276316
277317instance {-# OVERLAPPING #-}
278− ( RunClient m, BuildHeadersTo ls, ReflectMethod method
318+ ( RunClient m, BuildHeadersTo ls, ReflectMethod method, KnownNat status
279319 ) => HasClient m (Verb method status cts (Headers ls NoContent)) where
280320 type Client m (Verb method status cts (Headers ls NoContent))
281321 = m (Headers ls NoContent)
282322 clientWithRoute _pm Proxy req = do
283− let method = reflectMethod (Proxy :: Proxy method)
284− response <- runRequest req { requestMethod = method }
323+ response <- runRequestAcceptStatus (Just [status]) req { requestMethod = method }
285324 return $ Headers { getResponse = NoContent
286325 , getHeadersHList = buildHeadersTo . toList $ responseHeaders response
287326 }
327+ where
328+ method = reflectMethod (Proxy :: Proxy method)
329+ status = statusFromNat (Proxy :: Proxy status)
288330
289331 hoistClientMonad _ _ f ma = f ma
290332
333+data ClientParseError = ClientParseError MediaType String | ClientStatusMismatch | ClientNoMatchingStatus
334+ deriving (Eq, Show)
335+
336+class UnrenderResponse (cts :: [*]) (a :: *) where
337+ unrenderResponse :: Seq.Seq H.Header -> BL.ByteString -> Proxy cts
338+ -> [Either (MediaType, String) a]
339+
340+instance {-# OVERLAPPABLE #-} AllMimeUnrender cts a => UnrenderResponse cts a where
341+ unrenderResponse _ body = map parse . allMimeUnrender
342+ where parse (mediaType, parser) = left ((,) mediaType) (parser body)
343+
344+instance {-# OVERLAPPING #-} forall cts a h . (UnrenderResponse cts a, BuildHeadersTo h)
345+ => UnrenderResponse cts (Headers h a) where
346+ unrenderResponse hs body = (map . fmap) setHeaders . unrenderResponse hs body
347+ where
348+ setHeaders :: a -> Headers h a
349+ setHeaders x = Headers x (buildHeadersTo (toList hs))
350+
351+instance {-# OVERLAPPING #-} UnrenderResponse cts a
352+ => UnrenderResponse cts (WithStatus n a) where
353+ unrenderResponse hs body = (map . fmap) WithStatus . unrenderResponse hs body
354+
355+instance {-# OVERLAPPING #-}
356+ ( RunClient m,
357+ contentTypes ~ (contentType ': otherContentTypes),
358+ -- ('otherContentTypes' should be '_', but even -XPartialTypeSignatures does not seem
359+ -- allow this in instance types as of 8.8.3.)
360+ as ~ (a ': as'),
361+ AllMime contentTypes,
362+ ReflectMethod method,
363+ All (UnrenderResponse contentTypes) as,
364+ All HasStatus as, HasStatuses as',
365+ Unique (Statuses as)
366+ ) =>
367+ HasClient m (UVerb method contentTypes as)
368+ where
369+ type Client m (UVerb method contentTypes as) = m (Union as)
370+
371+ clientWithRoute _ _ request = do
372+ let accept = Seq.fromList . allMime $ Proxy @contentTypes
373+ -- offering to accept all mime types listed in the api gives best compatibility. eg.,
374+ -- we might not own the server implementation, and the server may choose to support
375+ -- only part of the api.
376+
377+ method = reflectMethod $ Proxy @method
378+ acceptStatus = statuses (Proxy @as)
379+ response <- runRequestAcceptStatus (Just acceptStatus) request {requestMethod = method, requestAccept = accept}
380+ responseContentType <- checkContentTypeHeader response
381+ unless (any (matches responseContentType) accept) $ do
382+ throwClientError $ UnsupportedContentType responseContentType response
383+
384+ let status = responseStatusCode response
385+ body = responseBody response
386+ headers = responseHeaders response
387+ res = tryParsers status $ mimeUnrenders (Proxy @contentTypes) headers body
388+ case res of
389+ Left errors -> throwClientError $ DecodeFailure (T.pack (show errors)) response
390+ Right x -> return x
391+ where
392+ -- | Given a list of parsers of 'mkres', returns the first one that succeeds and all the
393+ -- failures it encountered along the way
394+ -- TODO; better name, rewrite haddocs.
395+ tryParsers :: forall xs. All HasStatus xs => Status -> NP ([] :.: Either (MediaType, String)) xs -> Either [ClientParseError] (Union xs)
396+ tryParsers _ Nil = Left [ClientNoMatchingStatus]
397+ tryParsers status (Comp x :* xs)
398+ | status == statusOf (Comp x) =
399+ case partitionEithers x of
400+ (err', []) -> (map (uncurry ClientParseError) err' ++) +++ S $ tryParsers status xs
401+ (_, (res : _)) -> Right . inject . I $ res
402+ | otherwise = -- no reason to parse in the first place. This ain't the one we're looking for
403+ (ClientStatusMismatch :) +++ S $ tryParsers status xs
404+
405+ -- | Given a list of types, parses the given response body as each type
406+ mimeUnrenders ::
407+ forall cts xs.
408+ All (UnrenderResponse cts) xs =>
409+ Proxy cts ->
410+ Seq.Seq H.Header ->
411+ BL.ByteString ->
412+ NP ([] :.: Either (MediaType, String)) xs
413+ mimeUnrenders ctp headers body = cpure_NP
414+ (Proxy @(UnrenderResponse cts))
415+ (Comp . unrenderResponse headers body $ ctp)
416+
417+ hoistClientMonad _ _ nt s = nt s
418+
291419instance {-# OVERLAPPABLE #-}
292420 ( RunStreamingClient m, MimeUnrender ct chunk, ReflectMethod method,
293421 FramingUnrender framing, FromSourceIO chunk a
@@ -441,7 +569,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequire
441569 (Proxy :: Proxy mods) add (maybe req add) mparam
442570 where
443571 add :: a -> Request
444− add param = appendToQueryString pname (Just $ toQueryParam param) req
572+ add param = appendToQueryString pname (Just $ encodeQueryParamValue param) req
445573
446574 pname :: Text
447575 pname = pack $ symbolVal (Proxy :: Proxy sym)
@@ -490,7 +618,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api)
490618 )
491619
492620 where pname = pack $ symbolVal (Proxy :: Proxy sym)
493− paramlist' = map (Just . toQueryParam) paramlist
621+ paramlist' = map (Just . encodeQueryParamValue) paramlist
494622
495623 hoistClientMonad pm _ f cl = \as ->
496624 hoistClientMonad pm (Proxy :: Proxy api) f (cl as)
@@ -546,6 +674,16 @@ instance RunClient m => HasClient m Raw where
546674
547675 hoistClientMonad _ _ f cl = \meth -> f (cl meth)
548676
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+
549687-- | If you use a 'ReqBody' in one of your endpoints in your API,
550688-- the corresponding querying function will automatically take
551689-- an additional argument of the type specified by your 'ReqBody'.
@@ -612,7 +750,7 @@ instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where
612750 clientWithRoute pm (Proxy :: Proxy api)
613751 (appendToPath p req)
614752
615− where p = pack $ symbolVal (Proxy :: Proxy path)
753+ where p = toEncodedUrlPiece $ pack $ symbolVal (Proxy :: Proxy path)
616754
617755 hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
618756
@@ -648,6 +786,14 @@ instance HasClient m subapi =>
648786
649787 hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy subapi) f cl
650788
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+
651797instance ( HasClient m api
652798 ) => HasClient m (AuthProtect tag :> api) where
653799 type Client m (AuthProtect tag :> api)
@@ -659,6 +805,29 @@ instance ( HasClient m api
659805 hoistClientMonad pm _ f cl = \authreq ->
660806 hoistClientMonad pm (Proxy :: Proxy api) f (cl authreq)
661807
808+-- | Ignore @'Fragment'@ in client functions.
809+-- See <https://ietf.org/rfc/rfc2616.html#section-15.1.3> for more details.
810+--
811+-- Example:
812+--
813+-- > type MyApi = "books" :> Fragment Text :> Get '[JSON] [Book]
814+-- >
815+-- > myApi :: Proxy MyApi
816+-- > myApi = Proxy
817+-- >
818+-- > getBooks :: ClientM [Book]
819+-- > getBooks = client myApi
820+-- > -- then you can just use "getBooksBy" to query that endpoint.
821+-- > -- 'getBooks' for all books.
822+instance (AtLeastOneFragment api, FragmentUnique (Fragment a :> api), HasClient m api
823+ ) => HasClient m (Fragment a :> api) where
824+
825+ type Client m (Fragment a :> api) = Client m api
826+
827+ clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api)
828+
829+ hoistClientMonad pm _ = hoistClientMonad pm (Proxy :: Proxy api)
830+
662831-- * Basic Authentication
663832
664833instance HasClient m api => HasClient m (BasicAuth realm usr :> api) where
@@ -670,6 +839,119 @@ instance HasClient m api => HasClient m (BasicAuth realm usr :> api) where
670839 hoistClientMonad pm _ f cl = \bauth ->
671840 hoistClientMonad pm (Proxy :: Proxy api) f (cl bauth)
672841
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
673955
674956
675957{- Note [Non-Empty Content Types]
@@ -695,7 +977,7 @@ for empty and one for non-empty lists).
695977checkContentTypeHeader :: RunClient m => Response -> m MediaType
696978checkContentTypeHeader response =
697979 case lookup "Content-Type" $ toList $ responseHeaders response of
698− Nothing -> return $ "application"//"octet-stream"
980+ Nothing -> return $ "application" Media.// "octet-stream"
699981 Just t -> case parseAccept t of
700982 Nothing -> throwClientError $ InvalidContentTypeHeader response
701983 Just t' -> return t'
@@ -710,4 +992,20 @@ decodedAs response ct = do
710992 Left err -> throwClientError $ DecodeFailure (T.pack err) response
711993 Right val -> return val
712994 where
713− 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+6
@@ -5,6 +5,11 @@ module Servant.Client.Core.Reexport
55 (
66 -- * HasClient
77 HasClient(..)
8+ , foldMapUnion
9+ , matchUnion
10+ , AsClientT
11+ , (//)
12+ , (/:)
813
914 -- * Response (for @Raw@)
1015 , Response
@@ -21,6 +26,7 @@ module Servant.Client.Core.Reexport
2126 , showBaseUrl
2227 , parseBaseUrl
2328 , InvalidBaseUrlException
29+
2430 ) where
2531
2632
servant-client-core/src/Servant/Client/Core/Request.hs+47−9
@@ -17,6 +17,7 @@ module Servant.Client.Core.Request (
1717 addHeader,
1818 appendToPath,
1919 appendToQueryString,
20+ encodeQueryParamValue,
2021 setRequestBody,
2122 setRequestBodyLBS,
2223 ) where
@@ -33,10 +34,10 @@ import Data.Bifunctor
3334import Data.Bitraversable
3435 (Bitraversable (..), bifoldMapDefault, bimapDefault)
3536import qualified Data.ByteString as BS
37+import Data.ByteString.Builder
38+ (Builder)
3639import qualified Data.ByteString.Builder as Builder
3740import qualified Data.ByteString.Lazy as LBS
38−import Data.Semigroup
39− ((<>))
4041import qualified Data.Sequence as Seq
4142import Data.Text
4243 (Text)
@@ -64,8 +65,33 @@ data RequestF body path = Request
6465 , requestHeaders :: Seq.Seq Header
6566 , requestHttpVersion :: HttpVersion
6667 , requestMethod :: Method
67− } deriving (Generic, Typeable, Eq, Show, Functor, Foldable, Traversable)
68+ } deriving (Generic, Typeable, Eq, Functor, Foldable, Traversable)
6869
70+instance (Show a, Show b) =>
71+ Show (Servant.Client.Core.Request.RequestF a b) where
72+ showsPrec p req
73+ = showParen
74+ (p >= 11)
75+ ( showString "Request {requestPath = "
76+ . showsPrec 0 (requestPath req)
77+ . showString ", requestQueryString = "
78+ . showsPrec 0 (requestQueryString req)
79+ . showString ", requestBody = "
80+ . showsPrec 0 (requestBody req)
81+ . showString ", requestAccept = "
82+ . showsPrec 0 (requestAccept req)
83+ . showString ", requestHeaders = "
84+ . showsPrec 0 (redactSensitiveHeader <$> requestHeaders req)
85+ . showString ", requestHttpVersion = "
86+ . showsPrec 0 (requestHttpVersion req)
87+ . showString ", requestMethod = "
88+ . showsPrec 0 (requestMethod req)
89+ . showString "}"
90+ )
91+ where
92+ redactSensitiveHeader :: Header -> Header
93+ redactSensitiveHeader ("Authorization", _) = ("Authorization", "<REDACTED>")
94+ redactSensitiveHeader h = h
6995instance Bifunctor RequestF where bimap = bimapDefault
7096instance Bifoldable RequestF where bifoldMap = bifoldMapDefault
7197instance Bitraversable RequestF where
@@ -88,7 +114,7 @@ instance (NFData path, NFData body) => NFData (RequestF body path) where
88114 rnfB Nothing = ()
89115 rnfB (Just (b, mt)) = rnf b `seq` mediaTypeRnf mt
90116
91−type Request = RequestF RequestBody Builder.Builder
117+type Request = RequestF RequestBody Builder
92118
93119-- | The request body. R replica of the @http-client@ @RequestBody@.
94120data RequestBody
@@ -119,18 +145,30 @@ defaultRequest = Request
119145 , requestMethod = methodGet
120146 }
121147
122−appendToPath :: Text -> Request -> Request
148+-- | Append extra path to the request being constructed.
149+--
150+-- Warning: This function assumes that the path fragment is already URL-encoded.
151+appendToPath :: Builder -> Request -> Request
123152appendToPath p req
124− = req { requestPath = requestPath req <> "/" <> toEncodedUrlPiece p }
153+ = req { requestPath = requestPath req <> "/" <> p }
125154
126−appendToQueryString :: Text -- ^ param name
127− -> Maybe Text -- ^ param value
155+-- | Append a query parameter to the request being constructed.
156+--
157+appendToQueryString :: Text -- ^ query param name
158+ -> Maybe BS.ByteString -- ^ query param value
128159 -> Request
129160 -> Request
130161appendToQueryString pname pvalue req
131162 = req { requestQueryString = requestQueryString req
132− Seq.|> (encodeUtf8 pname, encodeUtf8 <$> pvalue)}
163+ Seq.|> (encodeUtf8 pname, pvalue)}
133164
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+--
134172addHeader :: ToHttpApiData a => HeaderName -> a -> Request -> Request
135173addHeader name val req
136174 = req { requestHeaders = requestHeaders req Seq.|> (name, toHeader val)}
servant-client-core/src/Servant/Client/Core/RunClient.hs+12−3
@@ -7,6 +7,7 @@
77-- | Types for possible backends to run client-side `Request` queries
88module Servant.Client.Core.RunClient (
99 RunClient (..),
10+ runRequest,
1011 RunStreamingClient (..),
1112 ClientF (..),
1213 ) where
@@ -14,6 +15,8 @@ module Servant.Client.Core.RunClient (
1415import Prelude ()
1516import Prelude.Compat
1617
18+import Network.HTTP.Types.Status
19+ (Status)
1720import Control.Monad.Free
1821 (Free (..), liftF)
1922
@@ -22,10 +25,15 @@ import Servant.Client.Core.Request
2225import Servant.Client.Core.Response
2326
2427class Monad m => RunClient m where
25− -- | How to make a request.
26− runRequest :: Request -> m Response
28+ -- | How to make a request, with an optional list of status codes to not throw exceptions
29+ -- for (default: [200..299]).
30+ runRequestAcceptStatus :: Maybe [Status] -> Request -> m Response
2731 throwClientError :: ClientError -> m a
2832
33+-- | How to make a request.
34+runRequest :: RunClient m => Request -> m Response
35+runRequest = runRequestAcceptStatus Nothing
36+
2937class RunClient m => RunStreamingClient m where
3038 withStreamingRequest :: Request -> (StreamingResponse -> IO a) -> m a
3139
@@ -41,6 +49,7 @@ data ClientF a
4149 | Throw ClientError
4250 deriving (Functor)
4351
52+-- TODO: honour the accept-status argument.
4453instance ClientF ~ f => RunClient (Free f) where
45− runRequest req = liftF (RunRequest req id)
54+ runRequestAcceptStatus _ req = liftF (RunRequest req id)
4655 throwClientError = liftF . Throw
servant-client-core/src/Servant/Client/Generic.hs+8−11
@@ -1,9 +1,10 @@
1−{-# LANGUAGE ConstraintKinds #-}
2−{-# LANGUAGE FlexibleContexts #-}
3−{-# LANGUAGE KindSignatures #-}
4−{-# LANGUAGE RankNTypes #-}
5−{-# LANGUAGE ScopedTypeVariables #-}
6−{-# LANGUAGE TypeFamilies #-}
1+{-# OPTIONS_GHC -fno-warn-orphans #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE KindSignatures #-}
4+{-# LANGUAGE RankNTypes #-}
5+{-# LANGUAGE ScopedTypeVariables #-}
6+{-# LANGUAGE TypeFamilies #-}
7+
78module Servant.Client.Generic (
89 AsClientT,
910 genericClient,
@@ -15,11 +16,7 @@ import Data.Proxy
1516
1617import Servant.API.Generic
1718import Servant.Client.Core
18−
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
19+import Servant.Client.Core.HasClient (AsClientT)
2320
2421-- | Generate a record of client functions.
2522genericClient
servant-client-core/test/Servant/Client/Core/RequestSpec.hsnew file+31
@@ -0,0 +1,31 @@
1+{-# OPTIONS_GHC -fno-warn-orphans #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Servant.Client.Core.RequestSpec (spec) where
4+
5+
6+import Prelude ()
7+import Prelude.Compat
8+import Control.Monad
9+import Data.List (isInfixOf)
10+import Servant.Client.Core.Request
11+import Test.Hspec
12+
13+newtype DataWithRequest = DataWithRequest (RequestF RequestBody ())
14+ deriving Show
15+
16+spec :: Spec
17+spec = do
18+ describe "Request" $ 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\"})"
29+ it "redacts the authorization header" $ do
30+ let request = void $ defaultRequest { requestHeaders = pure ("authorization", "secret") }
31+ isInfixOf "secret" (show request) `shouldBe` False
servant-client-ghcjs/servant-client-ghcjs.cabal+7−7
@@ -1,4 +1,4 @@
1−cabal-version: >=1.10
1+cabal-version: 2.2
22name: servant-client-ghcjs
33version: 0.16
44synopsis:
@@ -15,7 +15,7 @@ description:
1515
1616homepage: http://docs.servant.dev/
1717bug-reports: http://github.com/haskell-servant/servant/issues
18−license: BSD3
18+license: BSD-3-Clause
1919license-file: LICENSE
2020author: Servant Contributors
2121maintainer: haskell-servant-maintainers@googlegroups.com
@@ -38,8 +38,8 @@ library
3838 Servant.Client.Internal.XhrClient
3939
4040 build-depends:
41− base >=4.11 && <4.12
42− , bytestring >=0.10 && <0.11
41+ base >=4.11 && <5
42+ , bytestring >=0.10 && <0.12
4343 , case-insensitive >=1.2.0.0 && <1.3.0.0
4444 , containers >=0.5 && <0.7
4545 , exceptions >=0.8 && <0.11
@@ -48,7 +48,7 @@ library
4848 , http-media >=0.6.2 && <0.9
4949 , http-types >=0.12 && <0.13
5050 , monad-control >=1.0.0.4 && <1.1
51− , mtl >=2.2.2 && <2.3
51+ , mtl ^>=2.2.2 || ^>=2.3.1
5252 , semigroupoids >=5.3 && <5.4
5353 , string-conversions >=0.3 && <0.5
5454 , transformers >=0.3 && <0.6
@@ -56,8 +56,8 @@ library
5656
5757 -- strict, as we re-export stuff
5858 build-depends:
59− servant >=0.16 && <0.17
60− , servant-client-core >=0.16 && <0.16.1
59+ servant >=0.16 && <0.20
60+ , servant-client-core >=0.16 && <0.20
6161
6262 hs-source-dirs: src
6363 default-language: Haskell2010
servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs+8−5
@@ -120,7 +120,7 @@ instance Exception StreamingNotSupportedException where
120120 displayException _ = "streamingRequest: streaming is not supported!"
121121
122122instance RunClient ClientM where
123− runRequest = performRequest
123+ runRequestAcceptStatus = performRequest
124124 throwClientError = throwError
125125
126126runClientMOrigin :: ClientM a -> ClientEnv -> IO (Either ClientError a)
@@ -152,15 +152,18 @@ runClientM m = do
152152
153153 runClientMOrigin m (ClientEnv (BaseUrl protocol hostname port ""))
154154
155−performRequest :: Request -> ClientM Response
156−performRequest req = do
155+performRequest :: Maybe [Status] -> Request -> ClientM Response
156+performRequest acceptStatus req = do
157157 xhr <- liftIO initXhr
158158 burl <- asks baseUrl
159159 liftIO $ performXhr xhr burl req
160160 resp <- toResponse xhr
161161
162− let status = statusCode (responseStatusCode resp)
163− unless (status >= 200 && status < 300) $ do
162+ let status = responseStatusCode resp
163+ goodStatus = case acceptStatus of
164+ Nothing -> statusIsSuccessful status
165+ Just good -> status `elem` good
166+ unless goodStatus $ do
164167 let f b = (burl, BL.toStrict $ toLazyByteString b)
165168 throwError $ FailureResponse (bimap (const ()) f req) resp
166169
servant-client/CHANGELOG.md+118−1
@@ -1,6 +1,123 @@
11[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-client/CHANGELOG.md)
22[Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)
33
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+
35+0.18.3
36+------
37+
38+### Significant changes
39+
40+- Add response header support to UVerb (#1420)
41+
42+### Other changes
43+
44+- Support GHC-9.0.1.
45+- Bump `bytestring`, `hspec`, `http-client` and `QuickCheck` dependencies.
46+
47+0.18.2
48+------
49+
50+### Significant changes
51+
52+- Support `Fragment` combinator.
53+
54+0.18.1
55+------
56+
57+### Significant changes
58+
59+- Union verbs
60+
61+### Other changes
62+
63+- Bump "tested-with" ghc versions
64+
65+0.18
66+----
67+
68+### Significant changes
69+
70+- Support for ghc8.8 (#1318, #1326, #1327)
71+
72+
73+0.17
74+----
75+
76+### Significant changes
77+
78+- Add NoContentVerb [#1028](https://github.com/haskell-servant/servant/issues/1028) [#1219](https://github.com/haskell-servant/servant/pull/1219) [#1228](https://github.com/haskell-servant/servant/pull/1228)
79+
80+ The `NoContent` API endpoints should now use `NoContentVerb` combinator.
81+ The API type changes are usually of the kind
82+
83+ ```diff
84+ - :<|> PostNoContent '[JSON] NoContent
85+ + :<|> PostNoContent
86+ ```
87+
88+ i.e. one doesn't need to specify the content-type anymore. There is no content.
89+
90+- `Capture` can be `Lenient` [#1155](https://github.com/haskell-servant/servant/issues/1155) [#1156](https://github.com/haskell-servant/servant/pull/1156)
91+
92+ You can specify a lenient capture as
93+
94+ ```haskell
95+ :<|> "capture-lenient" :> Capture' '[Lenient] "foo" Int :> GET
96+ ```
97+
98+ which will make the capture always succeed. Handlers will be of the
99+ type `Either String CapturedType`, where `Left err` represents
100+ the possible parse failure.
101+
102+- *servant-client* Added a function to create Client.Request in ClientEnv [#1213](https://github.com/haskell-servant/servant/pull/1213) [#1255](https://github.com/haskell-servant/servant/pull/1255)
103+
104+ The new member `makeClientRequest` of `ClientEnv` is used to create
105+ `http-client` `Request` from `servant-client-core` `Request`.
106+ This functionality can be used for example to set
107+ dynamic timeouts for each request.
108+
109+### Other changes
110+
111+- *servant-client* *servant-client-core* *servant-http-streams* Fix Verb with headers checking content type differently [#1200](https://github.com/haskell-servant/servant/issues/1200) [#1204](https://github.com/haskell-servant/servant/pull/1204)
112+
113+ For `Verb`s with response `Headers`, the implementation didn't check
114+ for the content-type of the response. Now it does.
115+
116+- *servant-client* *servant-http-streams* `HasClient` instance for `Stream` with `Headers` [#1170](https://github.com/haskell-servant/servant/issues/1170) [#1197](https://github.com/haskell-servant/servant/pull/1197)
117+- *servant-client* Redact the authorization header in Show and exceptions [#1238](https://github.com/haskell-servant/servant/pull/1238)
118+
119+
120+
41210.16.0.1
5122--------
6123
@@ -150,7 +267,7 @@
150267
151268- *servant-client-core* Add `hoistClient` to `HasClient`.
152269 Just like `hoistServer` allows us to change the monad in which request handlers
153− of a web application live in, we also have `hoistClient` for changing the monad
270+ of a web application live, we also have `hoistClient` for changing the monad
154271 in which *client functions* live.
155272 Read [tutorial section for more information](https://docs.servant.dev/en/release-0.14/tutorial/Client.html#changing-the-monad-the-client-functions-live-in).
156273 ([#936](https://github.com/haskell-servant/servant/pull/936))
servant-client/servant-client.cabal+29−26
@@ -1,6 +1,6 @@
1−cabal-version: >=1.10
1+cabal-version: 2.2
22name: servant-client
3−version: 0.16.0.1
3+version: 0.19
44
55synopsis: Automatic derivation of querying functions for servant
66category: Servant, Web
@@ -14,18 +14,14 @@ description:
1414
1515homepage: http://docs.servant.dev/
1616bug-reports: http://github.com/haskell-servant/servant/issues
17−license: BSD3
17+license: BSD-3-Clause
1818license-file: LICENSE
1919author: Servant Contributors
2020maintainer: haskell-servant-maintainers@googlegroups.com
2121copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors
2222build-type: Simple
23−tested-with:
24− GHC ==8.0.2
25− || ==8.2.2
26− || ==8.4.4
27− || ==8.6.5
28− || ==8.8.1
23+tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1
24+ , GHCJS ==8.6.0.1
2925
3026extra-source-files:
3127 CHANGELOG.md
@@ -45,15 +41,15 @@ library
4541 -- Bundled with GHC: Lower bound to not force re-installs
4642 -- text and mtl are bundled starting with GHC-8.4
4743 build-depends:
48− base >= 4.9 && < 4.14
49− , bytestring >= 0.10.8.1 && < 0.11
44+ base >= 4.9 && < 4.18
45+ , bytestring >= 0.10.8.1 && < 0.12
5046 , containers >= 0.5.7.1 && < 0.7
5147 , deepseq >= 1.4.2.0 && < 1.5
52− , mtl >= 2.2.2 && < 2.3
48+ , mtl ^>= 2.2.2 || ^>= 2.3.1
5349 , stm >= 2.4.5.1 && < 2.6
54− , text >= 1.2.3.0 && < 1.3
55− , time >= 1.6.0.1 && < 1.10
56− , transformers >= 0.5.2.0 && < 0.6
50+ , text >= 1.2.3.0 && < 2.1
51+ , time >= 1.6.0.1 && < 1.13
52+ , transformers >= 0.5.2.0 && < 0.7
5753
5854 if !impl(ghc >= 8.2)
5955 build-depends:
@@ -62,14 +58,14 @@ library
6258 -- Servant dependencies.
6359 -- Strict dependency on `servant-client-core` as we re-export things.
6460 build-depends:
65− servant == 0.16.*
66− , servant-client-core >= 0.16 && <0.16.1
61+ servant >= 0.18 && < 0.20
62+ , servant-client-core >= 0.19 && < 0.19.1
6763
6864 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.
6965 -- Here can be exceptions if we really need features from the newer versions.
7066 build-depends:
71− base-compat >= 0.10.5 && < 0.12
72− , http-client >= 0.5.13.1 && < 0.7
67+ base-compat >= 0.10.5 && < 0.13
68+ , http-client >= 0.5.13.1 && < 0.8
7369 , http-media >= 0.7.1.3 && < 0.9
7470 , http-types >= 0.12.2 && < 0.13
7571 , exceptions >= 0.10.0 && < 0.11
@@ -77,7 +73,7 @@ library
7773 , monad-control >= 1.0.2.3 && < 1.1
7874 , semigroupoids >= 5.3.1 && < 5.4
7975 , transformers-base >= 0.4.5.2 && < 0.5
80− , transformers-compat >= 0.6.2 && < 0.7
76+ , transformers-compat >= 0.6.2 && < 0.8
8177
8278 hs-source-dirs: src
8379 default-language: Haskell2010
@@ -87,14 +83,18 @@ test-suite spec
8783 type: exitcode-stdio-1.0
8884 ghc-options: -Wall -rtsopts -threaded "-with-rtsopts=-T -N2"
8985 default-language: Haskell2010
86+ if impl(ghcjs)
87+ buildable: False
9088 hs-source-dirs: test
9189 main-is: Spec.hs
9290 other-modules:
9391 Servant.BasicAuthSpec
92+ Servant.BrokenSpec
9493 Servant.ClientTestUtils
9594 Servant.ConnectionErrorSpec
9695 Servant.FailSpec
9796 Servant.GenAuthSpec
97+ Servant.GenericSpec
9898 Servant.HoistClientSpec
9999 Servant.StreamSpec
100100 Servant.SuccessSpec
@@ -113,6 +113,7 @@ test-suite spec
113113 , kan-extensions
114114 , servant-client
115115 , servant-client-core
116+ , sop-core
116117 , stm
117118 , text
118119 , transformers
@@ -120,19 +121,19 @@ test-suite spec
120121 , wai
121122 , warp
122123
123− -- Additonal dependencies
124+ -- Additional dependencies
124125 build-depends:
125126 entropy >= 0.4.1.3 && < 0.5
126− , hspec >= 2.6.0 && < 2.8
127+ , hspec >= 2.6.0 && < 2.10
127128 , HUnit >= 1.6.0.0 && < 1.7
128129 , network >= 2.8.0.0 && < 3.2
129− , QuickCheck >= 2.12.6.1 && < 2.14
130− , servant == 0.16.*
131− , servant-server == 0.16.*
130+ , QuickCheck >= 2.12.6.1 && < 2.15
131+ , servant == 0.19.*
132+ , servant-server == 0.19.*
132133 , tdigest >= 0.2 && < 0.3
133134
134135 build-tool-depends:
135− hspec-discover:hspec-discover >= 2.6.0 && < 2.8
136+ hspec-discover:hspec-discover >= 2.6.0 && < 2.10
136137
137138test-suite readme
138139 type: exitcode-stdio-1.0
@@ -141,3 +142,5 @@ test-suite readme
141142 build-tool-depends: markdown-unlit:markdown-unlit
142143 ghc-options: -pgmL markdown-unlit
143144 default-language: Haskell2010
145+ if impl(ghcjs)
146+ buildable: False
servant-client/src/Servant/Client.hs+1
@@ -9,6 +9,7 @@ module Servant.Client
99 , runClientM
1010 , ClientEnv(..)
1111 , mkClientEnv
12+ , defaultMakeClientRequest
1213 , hoistClient
1314 , module Servant.Client.Core.Reexport
1415 ) where
servant-client/src/Servant/Client/Internal/HttpClient.hs+42−20
@@ -24,7 +24,7 @@ import Control.Monad
2424import Control.Monad.Base
2525 (MonadBase (..))
2626import Control.Monad.Catch
27− (MonadCatch, MonadThrow)
27+ (MonadCatch, MonadThrow, MonadMask)
2828import Control.Monad.Error.Class
2929 (MonadError (..))
3030import Control.Monad.IO.Class
@@ -46,15 +46,13 @@ import qualified Data.ByteString.Lazy as BSL
4646import Data.Either
4747 (either)
4848import Data.Foldable
49− (toList)
49+ (foldl',toList)
5050import Data.Functor.Alt
5151 (Alt (..))
5252import Data.Maybe
5353 (maybe, maybeToList)
5454import Data.Proxy
5555 (Proxy (..))
56−import Data.Semigroup
57− ((<>))
5856import Data.Sequence
5957 (fromList)
6058import Data.String
@@ -65,23 +63,34 @@ import GHC.Generics
6563import Network.HTTP.Media
6664 (renderHeader)
6765import Network.HTTP.Types
68− (hContentType, renderQuery, statusCode)
66+ (hContentType, renderQuery, statusIsSuccessful, urlEncode, Status)
6967import Servant.Client.Core
7068
7169import qualified Network.HTTP.Client as Client
7270import qualified Servant.Types.SourceT as S
7371
7472-- | The environment in which a request is run.
73+-- The 'baseUrl' and 'makeClientRequest' function are used to create a @http-client@ request.
74+-- Cookies are then added to that request if a 'CookieJar' is set on the environment.
75+-- Finally the request is executed with the 'manager'.
76+-- The 'makeClientRequest' function can be used to modify the request to execute and set values which
77+-- are not specified on a @servant@ 'Request' like 'responseTimeout' or 'redirectCount'
7578data ClientEnv
7679 = ClientEnv
7780 { manager :: Client.Manager
7881 , baseUrl :: BaseUrl
7982 , cookieJar :: Maybe (TVar Client.CookieJar)
83+ , makeClientRequest :: BaseUrl -> Request -> IO Client.Request
84+ -- ^ this function can be used to customize the creation of @http-client@ requests from @servant@ requests. Default value: 'defaultMakeClientRequest'
85+ -- Note that:
86+ -- 1. 'makeClientRequest' exists to allow overriding operational semantics e.g. 'responseTimeout' per request,
87+ -- If you need global modifications, you should use 'managerModifyRequest'
88+ -- 2. the 'cookieJar', if defined, is being applied after 'makeClientRequest' is called.
8089 }
8190
8291-- | 'ClientEnv' smart constructor.
8392mkClientEnv :: Client.Manager -> BaseUrl -> ClientEnv
84−mkClientEnv mgr burl = ClientEnv mgr burl Nothing
93+mkClientEnv mgr burl = ClientEnv mgr burl Nothing defaultMakeClientRequest
8594
8695-- | Generates a set of client functions for an API.
8796--
@@ -127,7 +136,7 @@ newtype ClientM a = ClientM
127136 { unClientM :: ReaderT ClientEnv (ExceptT ClientError IO) a }
128137 deriving ( Functor, Applicative, Monad, MonadIO, Generic
129138 , MonadReader ClientEnv, MonadError ClientError, MonadThrow
130− , MonadCatch)
139+ , MonadCatch, MonadMask)
131140
132141instance MonadBase IO ClientM where
133142 liftBase = ClientM . liftBase
@@ -144,16 +153,16 @@ instance Alt ClientM where
144153 a <!> b = a `catchError` \_ -> b
145154
146155instance RunClient ClientM where
147− runRequest = performRequest
156+ runRequestAcceptStatus = performRequest
148157 throwClientError = throwError
149158
150159runClientM :: ClientM a -> ClientEnv -> IO (Either ClientError a)
151160runClientM cm env = runExceptT $ flip runReaderT env $ unClientM cm
152161
153−performRequest :: Request -> ClientM Response
154−performRequest req = do
155− ClientEnv m burl cookieJar' <- ask
156− let clientRequest = requestToClientRequest burl req
162+performRequest :: Maybe [Status] -> Request -> ClientM Response
163+performRequest acceptStatus req = do
164+ ClientEnv m burl cookieJar' createClientRequest <- ask
165+ clientRequest <- liftIO $ createClientRequest burl req
157166 request <- case cookieJar' of
158167 Nothing -> pure clientRequest
159168 Just cj -> liftIO $ do
@@ -162,7 +171,7 @@ performRequest req = do
162171 oldCookieJar <- readTVar cj
163172 let (newRequest, newCookieJar) =
164173 Client.insertCookiesIntoRequest
165− (requestToClientRequest burl req)
174+ clientRequest
166175 oldCookieJar
167176 now
168177 writeTVar cj newCookieJar
@@ -170,10 +179,12 @@ performRequest req = do
170179
171180 response <- maybe (requestWithoutCookieJar m request) (requestWithCookieJar m request) cookieJar'
172181 let status = Client.responseStatus response
173− status_code = statusCode status
174182 ourResponse = clientResponseToResponse id response
175− unless (status_code >= 200 && status_code < 300) $
176− throwError $ mkFailureResponse burl req ourResponse
183+ goodStatus = case acceptStatus of
184+ Nothing -> statusIsSuccessful status
185+ Just good -> status `elem` good
186+ unless goodStatus $ do
187+ throwError $ mkFailureResponse burl req ourResponse
177188 return ourResponse
178189 where
179190 requestWithoutCookieJar :: Client.Manager -> Client.Request -> ClientM (Client.Response BSL.ByteString)
@@ -215,15 +226,18 @@ clientResponseToResponse f r = Response
215226 , responseHttpVersion = Client.responseVersion r
216227 }
217228
218−requestToClientRequest :: BaseUrl -> Request -> Client.Request
219−requestToClientRequest burl r = Client.defaultRequest
229+-- | Create a @http-client@ 'Client.Request' from a @servant@ 'Request'
230+-- The 'Client.host', 'Client.path' and 'Client.port' fields are extracted from the 'BaseUrl'
231+-- otherwise the body, headers and query string are derived from the @servant@ 'Request'
232+defaultMakeClientRequest :: BaseUrl -> Request -> IO Client.Request
233+defaultMakeClientRequest burl r = return Client.defaultRequest
220234 { Client.method = requestMethod r
221235 , Client.host = fromString $ baseUrlHost burl
222236 , Client.port = baseUrlPort burl
223237 , Client.path = BSL.toStrict
224238 $ fromString (baseUrlPath burl)
225239 <> toLazyByteString (requestPath r)
226− , Client.queryString = renderQuery True . toList $ requestQueryString r
240+ , Client.queryString = buildQueryString . toList $ requestQueryString r
227241 , Client.requestHeaders =
228242 maybeToList acceptHdr ++ maybeToList contentTypeHdr ++ headers
229243 , Client.requestBody = body
@@ -232,7 +246,7 @@ requestToClientRequest burl r = Client.defaultRequest
232246 where
233247 -- Content-Type and Accept are specified by requestBody and requestAccept
234248 headers = filter (\(h, _) -> h /= "Accept" && h /= "Content-Type") $
235− toList $requestHeaders r
249+ toList $ requestHeaders r
236250
237251 acceptHdr
238252 | null hs = Nothing
@@ -274,6 +288,14 @@ requestToClientRequest burl r = Client.defaultRequest
274288 Http -> False
275289 Https -> True
276290
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+
277299catchConnectionError :: IO a -> IO (Either ClientError a)
278300catchConnectionError action =
279301 catch (Right <$> action) $ \e ->
servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs+33−18
@@ -12,7 +12,7 @@ module Servant.Client.Internal.HttpClient.Streaming (
1212 ClientEnv (..),
1313 mkClientEnv,
1414 clientResponseToResponse,
15− requestToClientRequest,
15+ defaultMakeClientRequest,
1616 catchConnectionError,
1717 ) where
1818
@@ -24,7 +24,8 @@ import Control.DeepSeq
2424 (NFData, force)
2525import Control.Exception
2626 (evaluate, throwIO)
27−import Control.Monad ()
27+import Control.Monad
28+ (unless)
2829import Control.Monad.Base
2930 (MonadBase (..))
3031import Control.Monad.Codensity
@@ -47,7 +48,7 @@ import Data.Time.Clock
4748 (getCurrentTime)
4849import GHC.Generics
4950import Network.HTTP.Types
50− (statusCode)
51+ (Status, statusIsSuccessful)
5152
5253import qualified Network.HTTP.Client as Client
5354
@@ -55,7 +56,7 @@ import Servant.Client.Core
5556import Servant.Client.Internal.HttpClient
5657 (ClientEnv (..), catchConnectionError,
5758 clientResponseToResponse, mkClientEnv, mkFailureResponse,
58− requestToClientRequest)
59+ defaultMakeClientRequest)
5960import qualified Servant.Types.SourceT as S
6061
6162
@@ -112,7 +113,7 @@ instance Alt ClientM where
112113 a <!> b = a `catchError` \_ -> b
113114
114115instance RunClient ClientM where
115− runRequest = performRequest
116+ runRequestAcceptStatus = performRequest
116117 throwClientError = throwError
117118
118119instance RunStreamingClient ClientM where
@@ -130,17 +131,17 @@ withClientM cm env k =
130131-- streaming response types ('SourceT', 'Conduit', pipes 'Proxy' or 'Machine').
131132-- For those you have to use 'withClientM'.
132133--
133−-- /Note:/ we 'force' the result, so the likehood of accidentally leaking a
134+-- /Note:/ we 'force' the result, so the likelihood of accidentally leaking a
134135-- connection is smaller. Use with care.
135136--
136137runClientM :: NFData a => ClientM a -> ClientEnv -> IO (Either ClientError a)
137138runClientM cm env = withClientM cm env (evaluate . force)
138139
139−performRequest :: Request -> ClientM Response
140−performRequest req = do
140+performRequest :: Maybe [Status] -> Request -> ClientM Response
141+performRequest acceptStatus req = do
141142 -- TODO: should use Client.withResponse here too
142− ClientEnv m burl cookieJar' <- ask
143− let clientRequest = requestToClientRequest burl req
143+ ClientEnv m burl cookieJar' createClientRequest <- ask
144+ clientRequest <- liftIO $ createClientRequest burl req
144145 request <- case cookieJar' of
145146 Nothing -> pure clientRequest
146147 Just cj -> liftIO $ do
@@ -149,7 +150,7 @@ performRequest req = do
149150 oldCookieJar <- readTVar cj
150151 let (newRequest, newCookieJar) =
151152 Client.insertCookiesIntoRequest
152− (requestToClientRequest burl req)
153+ clientRequest
153154 oldCookieJar
154155 now
155156 writeTVar cj newCookieJar
@@ -163,24 +164,38 @@ performRequest req = do
163164 now' <- getCurrentTime
164165 atomically $ modifyTVar' cj (fst . Client.updateCookieJar response request now')
165166 let status = Client.responseStatus response
166− status_code = statusCode status
167167 ourResponse = clientResponseToResponse id response
168− unless (status_code >= 200 && status_code < 300) $
168+ goodStatus = case acceptStatus of
169+ Nothing -> statusIsSuccessful status
170+ Just good -> status `elem` good
171+ unless goodStatus $ do
169172 throwError $ mkFailureResponse burl req ourResponse
170173 return ourResponse
171174
175+-- | TODO: support UVerb ('acceptStatus' argument, like in 'performRequest' above).
172176performWithStreamingRequest :: Request -> (StreamingResponse -> IO a) -> ClientM a
173177performWithStreamingRequest req k = do
174− m <- asks manager
175− burl <- asks baseUrl
176− let request = requestToClientRequest burl req
178+ ClientEnv m burl cookieJar' createClientRequest <- ask
179+ clientRequest <- liftIO $ createClientRequest burl req
180+ request <- case cookieJar' of
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
177193 ClientM $ lift $ lift $ Codensity $ \k1 ->
178194 Client.withResponse request m $ \res -> do
179195 let status = Client.responseStatus res
180− status_code = statusCode status
181196
182197 -- we throw FailureResponse in IO :(
183− unless (status_code >= 200 && status_code < 300) $ do
198+ unless (statusIsSuccessful status) $ do
184199 b <- BSL.fromChunks <$> Client.brConsume (Client.responseBody res)
185200 throwIO $ mkFailureResponse burl req (clientResponseToResponse (const b) res)
186201
servant-client/src/Servant/Client/Streaming.hs+1
@@ -10,6 +10,7 @@ module Servant.Client.Streaming
1010 , runClientM
1111 , ClientEnv(..)
1212 , mkClientEnv
13+ , defaultMakeClientRequest
1314 , hoistClient
1415 , module Servant.Client.Core.Reexport
1516 ) where
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+146−26
@@ -1,17 +1,18 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE ConstraintKinds #-}
3−{-# LANGUAGE DataKinds #-}
4−{-# LANGUAGE DeriveGeneric #-}
5−{-# LANGUAGE FlexibleContexts #-}
6−{-# LANGUAGE FlexibleInstances #-}
7−{-# LANGUAGE GADTs #-}
8−{-# LANGUAGE MultiParamTypeClasses #-}
9−{-# LANGUAGE OverloadedStrings #-}
10−{-# LANGUAGE PolyKinds #-}
11−{-# LANGUAGE ScopedTypeVariables #-}
12−{-# LANGUAGE TypeFamilies #-}
13−{-# LANGUAGE TypeOperators #-}
14−{-# LANGUAGE UndecidableInstances #-}
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE ConstraintKinds #-}
3+{-# LANGUAGE DataKinds #-}
4+{-# LANGUAGE DeriveGeneric #-}
5+{-# LANGUAGE FlexibleContexts #-}
6+{-# LANGUAGE FlexibleInstances #-}
7+{-# LANGUAGE GADTs #-}
8+{-# LANGUAGE MultiParamTypeClasses #-}
9+{-# LANGUAGE OverloadedStrings #-}
10+{-# LANGUAGE PolyKinds #-}
11+{-# LANGUAGE ScopedTypeVariables #-}
12+{-# LANGUAGE TypeApplications #-}
13+{-# LANGUAGE TypeFamilies #-}
14+{-# LANGUAGE TypeOperators #-}
15+{-# LANGUAGE UndecidableInstances #-}
1516{-# OPTIONS_GHC -freduction-depth=100 #-}
1617{-# OPTIONS_GHC -fno-warn-orphans #-}
1718{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
@@ -23,19 +24,32 @@ import Prelude.Compat
2324
2425import Control.Concurrent
2526 (ThreadId, forkIO, killThread)
27+import Control.Monad
28+ (join)
2629import Control.Monad.Error.Class
2730 (throwError)
2831import Data.Aeson
32+import Data.ByteString
33+ (ByteString)
34+import Data.ByteString.Builder
35+ (byteString)
36+import qualified Data.ByteString.Lazy as LazyByteString
2937import Data.Char
3038 (chr, isPrint)
3139import Data.Monoid ()
3240import Data.Proxy
41+import Data.SOP
42+import Data.Text
43+ (Text)
44+import qualified Data.Text as Text
45+import Data.Text.Encoding
46+ (decodeUtf8, encodeUtf8)
3347import GHC.Generics
3448 (Generic)
35−import qualified Network.HTTP.Client as C
36−import qualified Network.HTTP.Types as HTTP
49+import qualified Network.HTTP.Client as C
50+import qualified Network.HTTP.Types as HTTP
3751import Network.Socket
38−import qualified Network.Wai as Wai
52+import qualified Network.Wai as Wai
3953import Network.Wai.Handler.Warp
4054import System.IO.Unsafe
4155 (unsafePerformIO)
@@ -45,12 +59,15 @@ import Web.FormUrlEncoded
4559
4660import Servant.API
4761 ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth,
48− BasicAuthData (..), Capture, CaptureAll,
49− DeleteNoContent, EmptyAPI, FormUrlEncoded, Get, Header,
50− Headers, JSON, NoContent (NoContent), Post, QueryFlag,
51− QueryParam, QueryParams, Raw, ReqBody, addHeader)
62+ BasicAuthData (..), Capture, CaptureAll, DeleteNoContent,
63+ EmptyAPI, FormUrlEncoded, Fragment, FromHttpApiData (..), Get, Header, Headers,
64+ JSON, MimeRender (mimeRender), MimeUnrender (mimeUnrender),
65+ NoContent (NoContent), PlainText, Post, QueryFlag, QueryParam,
66+ QueryParams, Raw, ReqBody, StdMethod (GET), ToHttpApiData (..), UVerb, Union,
67+ Verb, WithStatus (WithStatus), NamedRoutes, addHeader)
68+import Servant.API.Generic ((:-))
5269import Servant.Client
53−import qualified Servant.Client.Core.Auth as Auth
70+import qualified Servant.Client.Core.Auth as Auth
5471import Servant.Server
5572import Servant.Server.Experimental.Auth
5673import Servant.Test.ComprehensiveAPI
@@ -63,7 +80,7 @@ _ = client comprehensiveAPIWithoutStreaming
6380data Person = Person
6481 { _name :: String
6582 , _age :: Integer
66− } deriving (Eq, Show, Generic)
83+ } deriving (Eq, Show, Read, Generic)
6784
6885instance ToJSON Person
6986instance FromJSON Person
@@ -74,6 +91,15 @@ instance FromForm Person
7491instance Arbitrary Person where
7592 arbitrary = Person <$> arbitrary <*> arbitrary
7693
94+instance MimeRender PlainText Person where
95+ mimeRender _ = LazyByteString.fromStrict . encodeUtf8 . Text.pack . show
96+
97+instance MimeUnrender PlainText Person where
98+ mimeUnrender _ =
99+ -- This does not handle any errors, but it should be fine for tests
100+ Right . read . Text.unpack . decodeUtf8 . LazyByteString.toStrict
101+
102+
77103alice :: Person
78104alice = Person "Alice" 42
79105
@@ -82,17 +108,40 @@ carol = Person "Carol" 17
82108
83109type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]
84110
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+
85124type Api =
86125 Get '[JSON] Person
87126 :<|> "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
88131 :<|> "deleteEmpty" :> DeleteNoContent
89132 :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person
90133 :<|> "captureAll" :> CaptureAll "names" String :> Get '[JSON] [Person]
91134 :<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person
92135 :<|> "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
93140 :<|> "params" :> QueryParams "names" String :> Get '[JSON] [Person]
94141 :<|> "flag" :> QueryFlag "flag" :> Get '[JSON] Bool
142+ :<|> "fragment" :> Fragment String :> Get '[JSON] Person
95143 :<|> "rawSuccess" :> Raw
144+ :<|> "rawSuccessPassHeaders" :> Raw
96145 :<|> "rawFailure" :> Raw
97146 :<|> "multiple" :>
98147 Capture "first" String :>
@@ -101,51 +150,79 @@ type Api =
101150 ReqBody '[JSON] [(String, [Rational])] :>
102151 Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])])
103152 :<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool)
153+ :<|> "uverb-headers" :> UVerb 'GET '[JSON] '[ WithStatus 200 (Headers TestHeaders Bool), WithStatus 204 String ]
104154 :<|> "deleteContentType" :> DeleteNoContent
105155 :<|> "redirectWithCookie" :> Raw
106156 :<|> "empty" :> EmptyAPI
157+ :<|> "uverb-success-or-redirect" :>
158+ Capture "bool" Bool :>
159+ UVerb 'GET '[PlainText] '[WithStatus 200 Person,
160+ WithStatus 301 Text]
161+ :<|> "uverb-get-created" :> UVerb 'GET '[PlainText] '[WithStatus 201 Person]
162+ :<|> NamedRoutes RecordRoutes
163+ :<|> "captureVerbatim" :> Capture "someString" Verbatim :> Get '[PlainText] Text
107164
108165api :: Proxy Api
109166api = Proxy
110167
111168getRoot :: ClientM Person
112169getGet :: ClientM Person
170+getGet307 :: ClientM Text
113171getDeleteEmpty :: ClientM NoContent
114172getCapture :: String -> ClientM Person
115173getCaptureAll :: [String] -> ClientM [Person]
116174getBody :: Person -> ClientM Person
117175getQueryParam :: Maybe String -> ClientM Person
176+getQueryParamBinary :: Maybe UrlEncodedByteString -> HTTP.Method -> ClientM Response
118177getQueryParams :: [String] -> ClientM [Person]
119178getQueryFlag :: Bool -> ClientM Bool
179+getFragment :: ClientM Person
120180getRawSuccess :: HTTP.Method -> ClientM Response
181+getRawSuccessPassHeaders :: HTTP.Method -> ClientM Response
121182getRawFailure :: HTTP.Method -> ClientM Response
122183getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]
123184 -> ClientM (String, Maybe Int, Bool, [(String, [Rational])])
124185getRespHeaders :: ClientM (Headers TestHeaders Bool)
186+getUVerbRespHeaders :: ClientM (Union '[ WithStatus 200 (Headers TestHeaders Bool), WithStatus 204 String ])
125187getDeleteContentType :: ClientM NoContent
126188getRedirectWithCookie :: HTTP.Method -> ClientM Response
189+uverbGetSuccessOrRedirect :: Bool
190+ -> ClientM (Union '[WithStatus 200 Person,
191+ WithStatus 301 Text])
192+uverbGetCreated :: ClientM (Union '[WithStatus 201 Person])
193+recordRoutes :: RecordRoutes (AsClientT ClientM)
127194
128195getRoot
129196 :<|> getGet
197+ :<|> getGet307
130198 :<|> getDeleteEmpty
131199 :<|> getCapture
132200 :<|> getCaptureAll
133201 :<|> getBody
134202 :<|> getQueryParam
203+ :<|> getQueryParamBinary
135204 :<|> getQueryParams
136205 :<|> getQueryFlag
206+ :<|> getFragment
137207 :<|> getRawSuccess
208+ :<|> getRawSuccessPassHeaders
138209 :<|> getRawFailure
139210 :<|> getMultiple
140211 :<|> getRespHeaders
212+ :<|> getUVerbRespHeaders
141213 :<|> getDeleteContentType
142214 :<|> getRedirectWithCookie
143− :<|> EmptyClient = client api
215+ :<|> EmptyClient
216+ :<|> uverbGetSuccessOrRedirect
217+ :<|> uverbGetCreated
218+ :<|> recordRoutes
219+ :<|> captureVerbatim = client api
144220
145221server :: Application
146222server = serve api (
147223 return carol
148224 :<|> return alice
225+ :<|> return "redirecting"
149226 :<|> return NoContent
150227 :<|> (\ name -> return $ Person name 0)
151228 :<|> (\ names -> return (zipWith Person names [0..]))
@@ -154,15 +231,40 @@ server = serve api (
154231 Just "alice" -> return alice
155232 Just n -> throwError $ ServerError 400 (n ++ " not found") "" []
156233 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+ )
157241 :<|> (\ names -> return (zipWith Person names [0..]))
158242 :<|> return
243+ :<|> return alice
159244 :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "rawSuccess")
245+ :<|> (Tagged $ \ request respond -> (respond $ Wai.responseLBS HTTP.ok200 (Wai.requestHeaders $ request) "rawSuccess"))
160246 :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.badRequest400 [] "rawFailure")
161247 :<|> (\ a b c d -> return (a, b, c, d))
162248 :<|> (return $ addHeader 1729 $ addHeader "eg2" True)
249+ :<|> (pure . Z . I . WithStatus $ addHeader 1729 $ addHeader "eg2" True)
163250 :<|> return NoContent
164251 :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.found302 [("Location", "testlocation"), ("Set-Cookie", "testcookie=test")] "")
165− :<|> emptyServer)
252+ :<|> emptyServer
253+ :<|> (\shouldRedirect -> if shouldRedirect
254+ then respond (WithStatus @301 ("redirecting" :: Text))
255+ else respond (WithStatus @200 alice ))
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
265+ )
266+
267+-- * api for testing failures
166268
167269type FailApi =
168270 "get" :> Raw
@@ -178,7 +280,7 @@ failServer = serve failApi (
178280 :<|> (\ _capture -> Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "application/json")] "")
179281 :<|> (Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "fooooo")] "")
180282 :<|> (Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "application/x-www-form-urlencoded"), ("X-Example1", "1"), ("X-Example2", "foo")] "")
181− )
283+ )
182284
183285-- * basic auth stuff
184286
@@ -262,3 +364,21 @@ pathGen = fmap NonEmpty path
262364 filter (not . (`elem` ("?%[]/#;" :: String))) $
263365 filter isPrint $
264366 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 ()
2121import Prelude.Compat
2222
2323import Data.Monoid ()
24−import Data.Semigroup
25− ((<>))
2624import qualified Network.HTTP.Types as HTTP
2725import Test.Hspec
2826
@@ -40,14 +38,14 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
4038
4139 context "client returns errors appropriately" $ do
4240 it "reports FailureResponse" $ \(_, baseUrl) -> do
43− let (_ :<|> _ :<|> getDeleteEmpty :<|> _) = client api
41+ let (_ :<|> _ :<|> _ :<|> getDeleteEmpty :<|> _) = client api
4442 Left res <- runClient getDeleteEmpty baseUrl
4543 case res of
4644 FailureResponse _ r | responseStatusCode r == HTTP.status404 -> return ()
4745 _ -> fail $ "expected 404 response, but got " <> show res
4846
4947 it "reports DecodeFailure" $ \(_, baseUrl) -> do
50− let (_ :<|> _ :<|> _ :<|> getCapture :<|> _) = client api
48+ let (_ :<|> _ :<|> _ :<|> _ :<|> getCapture :<|> _) = client api
5149 Left res <- runClient (getCapture "foo") baseUrl
5250 case res of
5351 DecodeFailure _ _ -> return ()
@@ -74,7 +72,7 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
7472 _ -> fail $ "expected UnsupportedContentType, but got " <> show res
7573
7674 it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do
77− let (_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api
75+ let (_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api
7876 Left res <- runClient (getBody alice) baseUrl
7977 case res of
8078 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+92−24
@@ -1,16 +1,17 @@
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 #-}
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 TypeApplications #-}
12+{-# LANGUAGE TypeFamilies #-}
13+{-# LANGUAGE TypeOperators #-}
14+{-# LANGUAGE UndecidableInstances #-}
1415{-# OPTIONS_GHC -freduction-depth=100 #-}
1516{-# OPTIONS_GHC -fno-warn-orphans #-}
1617{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
@@ -21,29 +22,35 @@ import Prelude ()
2122import Prelude.Compat
2223
2324import Control.Arrow
24− (left)
25+ ((+++), left)
2526import Control.Concurrent.STM
2627 (atomically)
2728import Control.Concurrent.STM.TVar
2829 (newTVar, readTVar)
30+import qualified Data.ByteString as BS
31+import qualified Data.ByteString.Lazy as BL
2932import Data.Foldable
3033 (forM_, toList)
3134import Data.Maybe
3235 (listToMaybe)
3336import Data.Monoid ()
34−import qualified Network.HTTP.Client as C
35−import qualified Network.HTTP.Types as HTTP
37+import Data.Text
38+ (Text)
39+import Data.Text.Encoding
40+ (encodeUtf8)
41+import qualified Network.HTTP.Client as C
42+import qualified Network.HTTP.Types as HTTP
3643import Test.Hspec
3744import Test.Hspec.QuickCheck
3845import Test.HUnit
3946import Test.QuickCheck
4047
4148import Servant.API
42− (NoContent (NoContent), getHeaders)
49+ (NoContent (NoContent), WithStatus (WithStatus), getHeaders, Headers(..))
4350import Servant.Client
44−import qualified Servant.Client.Core.Request as Req
45−import Servant.Test.ComprehensiveAPI
51+import qualified Servant.Client.Core.Request as Req
4652import Servant.ClientTestUtils
53+import Servant.Test.ComprehensiveAPI
4754
4855-- This declaration simply checks that all instances are in place.
4956_ = client comprehensiveAPIWithoutStreaming
@@ -54,11 +61,15 @@ spec = describe "Servant.SuccessSpec" $ do
5461
5562successSpec :: Spec
5663successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
57− it "Servant.API.Get root" $ \(_, baseUrl) -> do
58− left show <$> runClient getRoot baseUrl `shouldReturn` Right carol
64+ describe "Servant.API.Get" $ do
65+ it "get root endpoint" $ \(_, baseUrl) -> do
66+ left show <$> runClient getRoot baseUrl `shouldReturn` Right carol
67+
68+ it "get simple endpoint" $ \(_, baseUrl) -> do
69+ left show <$> runClient getGet baseUrl `shouldReturn` Right alice
5970
60− it "Servant.API.Get" $ \(_, baseUrl) -> do
61− left show <$> runClient getGet baseUrl `shouldReturn` Right alice
71+ it "get redirection endpoint" $ \(_, baseUrl) -> do
72+ left show <$> runClient getGet307 baseUrl `shouldReturn` Right "redirecting"
6273
6374 describe "Servant.API.Delete" $ do
6475 it "allows empty content type" $ \(_, baseUrl) -> do
@@ -90,6 +101,11 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
90101 Left (FailureResponse _ r) <- runClient (getQueryParam (Just "bob")) baseUrl
91102 responseStatusCode r `shouldBe` HTTP.Status 400 "bob not found"
92103
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+
93109 it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do
94110 left show <$> runClient (getQueryParams []) baseUrl `shouldReturn` Right []
95111 left show <$> runClient (getQueryParams ["alice", "bob"]) baseUrl
@@ -99,6 +115,9 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
99115 forM_ [False, True] $ \ flag -> it (show flag) $ \(_, baseUrl) -> do
100116 left show <$> runClient (getQueryFlag flag) baseUrl `shouldReturn` Right flag
101117
118+ it "Servant.API.Fragment" $ \(_, baseUrl) -> do
119+ left id <$> runClient getFragment baseUrl `shouldReturn` Right alice
120+
102121 it "Servant.API.Raw on success" $ \(_, baseUrl) -> do
103122 res <- runClient (getRawSuccess HTTP.methodGet) baseUrl
104123 case res of
@@ -122,14 +141,37 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
122141 Left e -> assertFailure $ show e
123142 Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]
124143
144+ it "Returns headers on UVerb requests" $ \(_, baseUrl) -> do
145+ res <- runClient getUVerbRespHeaders baseUrl
146+ case res of
147+ Left e -> assertFailure $ show e
148+ Right val -> case matchUnion val of
149+ Just (WithStatus val' :: WithStatus 200 (Headers TestHeaders Bool))
150+ -> getHeaders val' `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]
151+ Nothing -> assertFailure "unexpected alternative of union"
152+
125153 it "Stores Cookie in CookieJar after a redirect" $ \(_, baseUrl) -> do
126154 mgr <- C.newManager C.defaultManagerSettings
127155 cj <- atomically . newTVar $ C.createCookieJar []
128− _ <- runClientM (getRedirectWithCookie HTTP.methodGet) (ClientEnv mgr baseUrl (Just cj))
156+ _ <- runClientM (getRedirectWithCookie HTTP.methodGet) (ClientEnv mgr baseUrl (Just cj) defaultMakeClientRequest)
129157 cookie <- listToMaybe . C.destroyCookieJar <$> atomically (readTVar cj)
130158 C.cookie_name <$> cookie `shouldBe` Just "testcookie"
131159 C.cookie_value <$> cookie `shouldBe` Just "test"
132160
161+ it "Can modify the outgoing Request using the ClientEnv" $ \(_, baseUrl) -> do
162+ mgr <- C.newManager C.defaultManagerSettings
163+ -- In proper situation, extra headers should probably be visible in API type.
164+ -- However, testing for response timeout is difficult, so we test with something which is easy to observe
165+ let createClientRequest url r = fmap (\req -> req { C.requestHeaders = [("X-Added-Header", "XXX")] })
166+ (defaultMakeClientRequest url r)
167+ clientEnv = (mkClientEnv mgr baseUrl) { makeClientRequest = createClientRequest }
168+ res <- runClientM (getRawSuccessPassHeaders HTTP.methodGet) clientEnv
169+ case res of
170+ Left e ->
171+ assertFailure $ show e
172+ Right r ->
173+ ("X-Added-Header", "XXX") `elem` toList (responseHeaders r) `shouldBe` True
174+
133175 modifyMaxSuccess (const 20) $ do
134176 it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \(_, baseUrl) ->
135177 property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->
@@ -138,3 +180,29 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
138180 return $
139181 result === Right (cap, num, flag, body)
140182
183+ context "With a route that can either return success or redirect" $ do
184+ it "Redirects when appropriate" $ \(_, baseUrl) -> do
185+ eitherResponse <- runClient (uverbGetSuccessOrRedirect True) baseUrl
186+ case eitherResponse of
187+ Left clientError -> fail $ show clientError
188+ Right response -> matchUnion response `shouldBe` Just (WithStatus @301 @Text "redirecting")
189+
190+ it "Returns a proper response when appropriate" $ \(_, baseUrl) -> do
191+ eitherResponse <- runClient (uverbGetSuccessOrRedirect False) baseUrl
192+ case eitherResponse of
193+ Left clientError -> fail $ show clientError
194+ Right response -> matchUnion response `shouldBe` Just (WithStatus @200 alice)
195+
196+ context "with a route that uses uverb but only has a single response" $
197+ it "returns the expected response" $ \(_, baseUrl) -> do
198+ eitherResponse <- runClient (uverbGetCreated) baseUrl
199+ case eitherResponse of
200+ Left clientError -> fail $ show clientError
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+13−19
@@ -1,7 +1,6 @@
1−cabal-version: >=1.10
1+cabal-version: 2.2
22name: servant-conduit
3−version: 0.15
4−x-revision: 1
3+version: 0.15.1
54
65synopsis: Servant Stream support for conduit.
76category: Servant, Web, Enumerator
@@ -11,36 +10,31 @@ description: Servant Stream support for conduit.
1110
1211homepage: http://docs.servant.dev/
1312bug-reports: http://github.com/haskell-servant/servant/issues
14−license: BSD3
13+license: BSD-3-Clause
1514license-file: LICENSE
1615author: Servant Contributors
1716maintainer: haskell-servant-maintainers@googlegroups.com
1817copyright: 2018-2019 Servant Contributors
1918build-type: Simple
20−tested-with:
21− GHC ==8.0.2
22− || ==8.2.2
23− || ==8.4.4
24− || ==8.6.5
25− || ==8.8.1
19+tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2
2620
2721extra-source-files:
2822 CHANGELOG.md
2923
3024source-repository head
3125 type: git
32− location: http://github.com/haskell-servant/servant-conduit.git
26+ location: http://github.com/haskell-servant/servant.git
3327
3428library
3529 exposed-modules: Servant.Conduit
3630 build-depends:
3731 base >=4.9 && <5
38− , bytestring >=0.10.8.1 && <0.11
32+ , bytestring >=0.10.8.1 && <0.12
3933 , conduit >=1.3.1 && <1.4
40− , mtl >=2.2.2 && <2.3
41− , resourcet >=1.2.2 && <1.3
42− , servant >=0.15 && <0.17
43− , unliftio-core >=0.1.2.0 && <0.2
34+ , mtl ^>=2.2.2 || ^>=2.3.1
35+ , resourcet >=1.2.2 && <1.4
36+ , servant >=0.15 && <0.20
37+ , unliftio-core >=0.1.2.0 && <0.3
4438 hs-source-dirs: src
4539 default-language: Haskell2010
4640 ghc-options: -Wall
@@ -60,9 +54,9 @@ test-suite example
6054 , resourcet
6155 , servant
6256 , servant-conduit
63− , servant-server >=0.15 && <0.17
64− , servant-client >=0.15 && <0.17
57+ , servant-server >=0.15 && <0.20
58+ , servant-client >=0.15 && <0.20
6559 , wai >=3.2.1.2 && <3.3
66− , warp >=3.2.25 && <3.3
60+ , warp >=3.2.25 && <3.4
6761 , http-client
6862 default-language: Haskell2010
servant-docs/CHANGELOG.md+80
@@ -1,6 +1,86 @@
11[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-docs/CHANGELOG.md)
22[Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)
33
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+
13+0.11.9
14+------
15+
16+### Significant changes
17+
18+- Use Capture Description if available (#1423).
19+
20+### Other changes
21+
22+- Support GHC-9.0.1.
23+- Bump `bytestring` and `lens` dependencies.
24+
25+0.11.8
26+------
27+
28+### Significant changes
29+
30+- Support `Fragment` combinator.
31+
32+0.11.7
33+------
34+
35+### Significant changes
36+
37+- Add instance for ToSample NonEmpty
38+
39+### Other changes
40+
41+- Bump "tested-with" ghc versions
42+- Fix servant-docs code sample in README
43+
44+0.11.5
45+----
46+
47+
48+- Add NoContentVerb [#1028](https://github.com/haskell-servant/servant/issues/1028) [#1219](https://github.com/haskell-servant/servant/pull/1219) [#1228](https://github.com/haskell-servant/servant/pull/1228)
49+
50+ The `NoContent` API endpoints should now use `NoContentVerb` combinator.
51+ The API type changes are usually of the kind
52+
53+ ```diff
54+ - :<|> PostNoContent '[JSON] NoContent
55+ + :<|> PostNoContent
56+ ```
57+
58+ i.e. one doesn't need to specify the content-type anymore. There is no content.
59+
60+- `Capture` can be `Lenient` [#1155](https://github.com/haskell-servant/servant/issues/1155) [#1156](https://github.com/haskell-servant/servant/pull/1156)
61+
62+ You can specify a lenient capture as
63+
64+ ```haskell
65+ :<|> "capture-lenient" :> Capture' '[Lenient] "foo" Int :> GET
66+ ```
67+
68+ which will make the capture always succeed. Handlers will be of the
69+ type `Either String CapturedType`, where `Left err` represents
70+ the possible parse failure.
71+
72+- *servant-docs* Merge documentation from duplicate routes [#1240](https://github.com/haskell-servant/servant/issues/1240) [#1241](https://github.com/haskell-servant/servant/pull/1241)
73+
74+ Servant supports defining the same route multiple times with different
75+ content-types and result-types, but servant-docs was only documenting
76+ the first of copy of such duplicated routes. It now combines the
77+ documentation from all the copies.
78+
79+ Unfortunately, it is not yet possible for the documentation to specify
80+ multiple status codes.
81+
82+- *servant-docs* Prevent race-conditions in testing [#1194](https://github.com/haskell-servant/servant/pull/1194)
83+
4840.11.4
585------
686
servant-docs/README.md+44−11
@@ -2,24 +2,56 @@
22
33![servant](https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png)
44
5−Generate API docs for your *servant* webservice. Feel free to also take a look at [servant-pandoc](https://github.com/mpickering/servant-pandoc) which uses this package to target a broad range of output formats using the excellent **pandoc**.
5+Generate API docs for your _servant_ webservice. Feel free to also take a look at [servant-pandoc](https://github.com/mpickering/servant-pandoc) which uses this package to target a broad range of output formats using the excellent **pandoc**.
66
77## Example
88
99See [here](https://github.com/haskell-servant/servant/blob/master/servant-docs/example/greet.md) for the output of the following program.
1010
11−``` haskell
11+```haskell
1212{-# LANGUAGE DataKinds #-}
13−{-# LANGUAGE PolyKinds #-}
14−{-# LANGUAGE TypeFamilies #-}
1513{-# LANGUAGE DeriveGeneric #-}
16−{-# LANGUAGE TypeOperators #-}
1714{-# LANGUAGE FlexibleInstances #-}
15+{-# LANGUAGE MultiParamTypeClasses #-}
1816{-# LANGUAGE OverloadedStrings #-}
17+{-# LANGUAGE PolyKinds #-}
18+{-# LANGUAGE TypeFamilies #-}
19+{-# LANGUAGE TypeOperators #-}
1920
20−import Data.Proxy
21−import Data.Text
21+import Data.Aeson (FromJSON, ToJSON)
22+import Data.Proxy (Proxy (..))
23+import Data.String.Conversions (cs)
24+import Data.Text (Text)
25+import GHC.Generics (Generic)
26+import Servant.API
27+ ( (:<|>),
28+ (:>),
29+ Capture,
30+ Delete,
31+ Get,
32+ JSON,
33+ MimeRender,
34+ PlainText,
35+ Post,
36+ QueryParam,
37+ ReqBody,
38+ mimeRender,
39+ )
2240import Servant.Docs
41+ ( API,
42+ DocCapture (..),
43+ DocQueryParam (..),
44+ ParamKind (..),
45+ ToCapture,
46+ ToParam,
47+ ToSample,
48+ docs,
49+ markdown,
50+ singleSample,
51+ toCapture,
52+ toParam,
53+ toSamples,
54+ )
2355
2456-- our type for a Greeting message
2557data Greet = Greet { _msg :: Text }
@@ -29,6 +61,7 @@ data Greet = Greet { _msg :: Text }
2961-- 'MimeRender' instance for 'JSON'.
3062instance FromJSON Greet
3163instance ToJSON Greet
64+instance ToSample ()
3265
3366-- We can also implement 'MimeRender' explicitly for additional formats.
3467instance MimeRender PlainText Greet where
@@ -36,8 +69,7 @@ instance MimeRender PlainText Greet where
3669
3770-- we provide a sample value for the 'Greet' type
3871instance ToSample Greet where
39− toSample = Just g
40−
72+ toSamples _ = singleSample g
4173 where g = Greet "Hello, haskeller!"
4274
4375instance ToParam (QueryParam "capital" Bool) where
@@ -45,6 +77,7 @@ instance ToParam (QueryParam "capital" Bool) where
4577 DocQueryParam "capital"
4678 ["true", "false"]
4779 "Get the greeting message in uppercase (true) or not (false). Default is false."
80+ Normal
4881
4982instance ToCapture (Capture "name" Text) where
5083 toCapture _ = DocCapture "name" "name of the person to greet"
@@ -55,8 +88,8 @@ instance ToCapture (Capture "greetid" Text) where
5588-- API specification
5689type TestApi =
5790 "hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get '[JSON,PlainText] Greet
58− :<|> "greet" :> RQBody '[JSON] Greet :> Post '[JSON] Greet
59− :<|> "delete" :> Capture "greetid" Text :> Delete '[] ()
91+ :<|> "greet" :> ReqBody '[JSON] Greet :> Post '[JSON] Greet
92+ :<|> "delete" :> Capture "greetid" Text :> Delete '[JSON] ()
6093
6194testApi :: Proxy TestApi
6295testApi = Proxy
servant-docs/example/greet.hs+4−4
@@ -75,7 +75,7 @@ intro2 = DocIntro "This title is below the last"
7575-- API specification
7676type TestApi =
7777 -- 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
7979
8080 -- POST /greet with a Greet as JSON in the request body,
8181 -- returns a Greet as JSON
@@ -93,9 +93,9 @@ testApi = Proxy
9393extra :: ExtraInfo TestApi
9494extra =
9595 extraInfo (Proxy :: Proxy ("greet" :> Capture "greetid" Text :> Delete '[JSON] NoContent)) $
96− defAction & headers <>~ ["unicorns"]
96+ defAction & headers <>~ [("X-Num-Unicorns", "1")]
9797 & notes <>~ [ DocNote "Title" ["This is some text"]
98− , DocNote "Second secton" ["And some more"]
98+ , DocNote "Second section" ["And some more"]
9999 ]
100100
101101-- Generate the data that lets us have API docs. This
@@ -109,4 +109,4 @@ docsGreet :: API
109109docsGreet = docsWith defaultDocOptions [intro1, intro2] extra testApi
110110
111111main :: IO ()
112−main = putStrLn $ markdown docsGreet
112+main = putStrLn $ markdownWith (defRenderingOptions { _renderCurlBasePath = Just "http://localhost:80" }) docsGreet
servant-docs/example/greet.md+33−2
@@ -51,13 +51,22 @@ You'll also note that multiple intros are possible.
5151"Hello, haskeller"
5252```
5353
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+
5463## DELETE /greet/:greetid
5564
5665### Title
5766
5867This is some text
5968
60−### Second secton
69+### Second section
6170
6271And some more
6372
@@ -67,7 +76,7 @@ And some more
6776
6877### Headers:
6978
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.
7180
7281### Response:
7382
@@ -85,12 +94,24 @@ And some more
8594
8695```
8796
97+### Sample Request:
98+
99+```bash
100+curl -XDELETE \
101+ -H "X-Num-Unicorns: 1" \
102+ http://localhost:80/greet/:greetid
103+```
104+
88105## GET /hello/:name
89106
90107### Captures:
91108
92109- *name*: name of the person to greet
93110
111+### Headers:
112+
113+- This endpoint is sensitive to the value of the **X-Num-Fairies** HTTP header.
114+
94115### GET Parameters:
95116
96117- capital
@@ -120,3 +141,13 @@ And some more
120141```javascript
121142"Hello, haskeller"
122143```
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+42−2
@@ -52,11 +52,11 @@
5252
5353```
5454
55−## GET /capture/:foo
55+## GET /capture/:bar
5656
5757### Captures:
5858
59−- *foo*: Capture foo Int
59+- *bar*: example description
6060
6161### Response:
6262
@@ -182,6 +182,28 @@
182182
183183```
184184
185+## GET /fragment
186+
187+### Fragment:
188+
189+- *foo*: Fragment Int
190+
191+### Response:
192+
193+- Status code 200
194+- Headers: []
195+
196+- Supported content types are:
197+
198+ - `application/json;charset=utf-8`
199+ - `application/json`
200+
201+- Example (`application/json;charset=utf-8`, `application/json`):
202+
203+```javascript
204+
205+```
206+
185207## GET /get-int
186208
187209### Response:
@@ -508,6 +530,24 @@
508530
509531```
510532
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+
511551## GET /streaming
512552
513553### Request:
servant-docs/servant-docs.cabal+14−20
@@ -1,6 +1,6 @@
1−cabal-version: >=1.10
1+cabal-version: 2.2
22name: servant-docs
3−version: 0.11.4
3+version: 0.12
44
55synopsis: generate API docs for your servant webservice
66category: Servant, Web
@@ -13,18 +13,13 @@ description:
1313
1414homepage: http://docs.servant.dev/
1515bug-reports: http://github.com/haskell-servant/servant/issues
16−license: BSD3
16+license: BSD-3-Clause
1717license-file: LICENSE
1818author: Servant Contributors
1919maintainer: haskell-servant-maintainers@googlegroups.com
2020copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors
2121build-type: Simple
22−tested-with:
23− GHC ==8.0.2
24− || ==8.2.2
25− || ==8.4.4
26− || ==8.6.5
27− || ==8.8.1
22+tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1
2823
2924extra-source-files:
3025 CHANGELOG.md
@@ -46,25 +41,25 @@ library
4641 --
4742 -- note: mtl lower bound is so low because of GHC-7.8
4843 build-depends:
49− base >= 4.9 && < 4.14
50− , bytestring >= 0.10.8.1 && < 0.11
51− , text >= 1.2.3.0 && < 1.3
44+ base >= 4.9 && < 4.18
45+ , bytestring >= 0.10.8.1 && < 0.12
46+ , text >= 1.2.3.0 && < 2.1
5247
5348 -- Servant dependencies
5449 build-depends:
55− servant >= 0.15 && <0.17
50+ servant >= 0.18 && <0.20
5651
5752 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.
5853 -- Here can be exceptions if we really need features from the newer versions.
5954 build-depends:
60− aeson >= 1.4.1.0 && < 1.5
55+ aeson >= 1.4.1.0 && < 3
6156 , aeson-pretty >= 0.8.5 && < 0.9
62− , base-compat >= 0.10.5 && < 0.12
57+ , base-compat >= 0.10.5 && < 0.13
6358 , case-insensitive >= 1.2.0.11 && < 1.3
64− , hashable >= 1.2.7.0 && < 1.4
59+ , hashable >= 1.2.7.0 && < 1.5
6560 , http-media >= 0.7.1.3 && < 0.9
6661 , http-types >= 0.12.2 && < 0.13
67− , lens >= 4.17 && < 4.19
62+ , lens >= 4.17 && < 5.3
6863 , string-conversions >= 0.4.0.1 && < 0.5
6964 , universe-base >= 1.1.1 && < 1.2
7065 , unordered-containers >= 0.2.9.0 && < 0.3
@@ -105,10 +100,9 @@ test-suite spec
105100 , servant-docs
106101 , string-conversions
107102
108− -- Additonal dependencies
103+ -- Additional dependencies
109104 build-depends:
110− tasty >= 1.1.0.4 && < 1.3,
105+ tasty >= 1.1.0.4 && < 1.5,
111106 tasty-golden >= 2.3.2 && < 2.4,
112107 tasty-hunit >= 0.10.0.1 && < 0.11,
113108 transformers >= 0.5.2.0 && < 0.6
114−
servant-docs/src/Servant/Docs/Internal.hs+152−33
@@ -25,16 +25,14 @@ import Control.Applicative
2525import Control.Arrow
2626 (second)
2727import Control.Lens
28− (makeLenses, mapped, over, traversed, view, (%~), (&), (.~),
29− (<>~), (^.), (|>))
28+ (makeLenses, mapped, each, over, set, to, toListOf, traversed, view,
29+ _1, (%~), (&), (.~), (<>~), (^.), (|>))
3030import qualified Data.ByteString.Char8 as BSC
3131import Data.ByteString.Lazy.Char8
3232 (ByteString)
3333import qualified Data.CaseInsensitive as CI
3434import Data.Foldable
35− (toList)
36−import Data.Foldable
37− (fold)
35+ (fold, toList)
3836import Data.Hashable
3937 (Hashable)
4038import Data.HashMap.Strict
@@ -52,19 +50,21 @@ import Data.Ord
5250 (comparing)
5351import Data.Proxy
5452 (Proxy (Proxy))
55−import Data.Semigroup
56− (Semigroup (..))
5753import Data.String.Conversions
5854 (cs)
5955import Data.Text
6056 (Text, unpack)
6157import GHC.Generics
58+ (Generic, Rep, K1(K1), M1(M1), U1(U1), V1,
59+ (:*:)((:*:)), (:+:)(L1, R1))
60+import qualified GHC.Generics as G
6261import GHC.TypeLits
6362import Servant.API
6463import Servant.API.ContentTypes
6564import Servant.API.TypeLevel
65+import Servant.API.Generic
6666
67−import qualified Data.Universe.Helpers as U
67+import qualified Data.Universe.Helpers as U
6868
6969import qualified Data.HashMap.Strict as HM
7070import qualified Data.Text as T
@@ -131,7 +131,8 @@ instance Semigroup API where
131131 (<>) = mappend
132132
133133instance Monoid API where
134− API a1 b1 `mappend` API a2 b2 = API (a1 `mappend` a2) (b1 `mappend` b2)
134+ API a1 b1 `mappend` API a2 b2 = API (a1 `mappend` a2)
135+ (HM.unionWith combineAction b1 b2)
135136 mempty = API mempty mempty
136137
137138-- | An empty 'API'
@@ -160,6 +161,20 @@ data DocQueryParam = DocQueryParam
160161 , _paramKind :: ParamKind
161162 } deriving (Eq, Ord, Show)
162163
164+-- | A type to represent fragment. Holds the name of the fragment and its description.
165+--
166+-- Write a 'ToFragment' instance for your fragment types.
167+data DocFragment = DocFragment
168+ { _fragSymbol :: String -- type supplied
169+ , _fragDesc :: String -- user supplied
170+ } deriving (Eq, Ord, Show)
171+
172+-- | There should be at most one 'Fragment' per API endpoint.
173+-- So here we are keeping the first occurrence.
174+combineFragment :: Maybe DocFragment -> Maybe DocFragment -> Maybe DocFragment
175+Nothing `combineFragment` mdocFragment = mdocFragment
176+Just docFragment `combineFragment` _ = Just docFragment
177+
163178-- | An introductory paragraph for your documentation. You can pass these to
164179-- 'docsWithIntros'.
165180data DocIntro = DocIntro
@@ -240,6 +255,15 @@ data Response = Response
240255 , _respHeaders :: [HTTP.Header]
241256 } deriving (Eq, Ord, Show)
242257
258+-- | Combine two Responses, we can't make a monoid because merging Status breaks
259+-- the laws.
260+--
261+-- As such, we invent a non-commutative, left associative operation
262+-- 'combineResponse' to mush two together taking the status from the very left.
263+combineResponse :: Response -> Response -> Response
264+Response s ts bs hs `combineResponse` Response _ ts' bs' hs'
265+ = Response s (ts <> ts') (bs <> bs') (hs <> hs')
266+
243267-- | Default response: status code 200, no response body.
244268--
245269-- Can be tweaked with four lenses.
@@ -271,8 +295,9 @@ defResponse = Response
271295data Action = Action
272296 { _authInfo :: [DocAuthentication] -- user supplied info
273297 , _captures :: [DocCapture] -- type collected + user supplied info
274− , _headers :: [Text] -- type collected
298+ , _headers :: [HTTP.Header] -- type collected
275299 , _params :: [DocQueryParam] -- type collected + user supplied info
300+ , _fragment :: Maybe DocFragment -- type collected + user supplied info
276301 , _notes :: [DocNote] -- user supplied
277302 , _mxParams :: [(String, [DocQueryParam])] -- type collected + user supplied info
278303 , _rqtypes :: [M.MediaType] -- type collected
@@ -284,11 +309,11 @@ data Action = Action
284309-- laws.
285310--
286311-- As such, we invent a non-commutative, left associative operation
287−-- 'combineAction' to mush two together taking the response, body and content
288−-- types from the very left.
312+-- 'combineAction' to mush two together taking the response from the very left.
289313combineAction :: Action -> Action -> Action
290−Action a c h p n m ts body resp `combineAction` Action a' c' h' p' n' m' _ _ _ =
291− Action (a <> a') (c <> c') (h <> h') (p <> p') (n <> n') (m <> m') ts body resp
314+Action a c h p f n m ts body resp
315+ `combineAction` Action a' c' h' p' f' n' m' ts' body' resp' =
316+ Action (a <> a') (c <> c') (h <> h') (p <> p') (f `combineFragment` f') (n <> n') (m <> m') (ts <> ts') (body <> body') (resp `combineResponse` resp')
292317
293318-- | Default 'Action'. Has no 'captures', no query 'params', expects
294319-- no request body ('rqbody') and the typical response is 'defResponse'.
@@ -296,10 +321,10 @@ Action a c h p n m ts body resp `combineAction` Action a' c' h' p' n' m' _ _ _ =
296321-- Tweakable with lenses.
297322--
298323-- >>> defAction
299−-- Action {_authInfo = [], _captures = [], _headers = [], _params = [], _notes = [], _mxParams = [], _rqtypes = [], _rqbody = [], _response = Response {_respStatus = 200, _respTypes = [], _respBody = [], _respHeaders = []}}
324+-- Action {_authInfo = [], _captures = [], _headers = [], _params = [], _fragment = Nothing, _notes = [], _mxParams = [], _rqtypes = [], _rqbody = [], _response = Response {_respStatus = 200, _respTypes = [], _respBody = [], _respHeaders = []}}
300325--
301326-- >>> defAction & response.respStatus .~ 201
302−-- Action {_authInfo = [], _captures = [], _headers = [], _params = [], _notes = [], _mxParams = [], _rqtypes = [], _rqbody = [], _response = Response {_respStatus = 201, _respTypes = [], _respBody = [], _respHeaders = []}}
327+-- Action {_authInfo = [], _captures = [], _headers = [], _params = [], _fragment = Nothing, _notes = [], _mxParams = [], _rqtypes = [], _rqbody = [], _response = Response {_respStatus = 201, _respTypes = [], _respBody = [], _respHeaders = []}}
303328--
304329defAction :: Action
305330defAction =
@@ -307,6 +332,7 @@ defAction =
307332 []
308333 []
309334 []
335+ Nothing
310336 []
311337 []
312338 []
@@ -330,12 +356,14 @@ data ShowContentTypes = AllContentTypes -- ^ For each example, show each conten
330356--
331357-- @since 0.11.1
332358data RenderingOptions = RenderingOptions
333− { _requestExamples :: !ShowContentTypes
359+ { _requestExamples :: !ShowContentTypes
334360 -- ^ How many content types to display for request body examples?
335− , _responseExamples :: !ShowContentTypes
361+ , _responseExamples :: !ShowContentTypes
336362 -- ^ How many content types to display for response body examples?
337− , _notesHeading :: !(Maybe String)
363+ , _notesHeading :: !(Maybe String)
338364 -- ^ 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`).
339367 } deriving (Show)
340368
341369-- | Default API generation options.
@@ -347,9 +375,10 @@ data RenderingOptions = RenderingOptions
347375-- @since 0.11.1
348376defRenderingOptions :: RenderingOptions
349377defRenderingOptions = RenderingOptions
350− { _requestExamples = AllContentTypes
351− , _responseExamples = AllContentTypes
352− , _notesHeading = Nothing
378+ { _requestExamples = AllContentTypes
379+ , _responseExamples = AllContentTypes
380+ , _notesHeading = Nothing
381+ , _renderCurlBasePath = Nothing
353382 }
354383
355384-- gimme some lenses
@@ -359,6 +388,7 @@ makeLenses ''API
359388makeLenses ''Endpoint
360389makeLenses ''DocCapture
361390makeLenses ''DocQueryParam
391+makeLenses ''DocFragment
362392makeLenses ''DocIntro
363393makeLenses ''DocNote
364394makeLenses ''Response
@@ -385,9 +415,9 @@ docsWithOptions p = docsFor p (defEndpoint, defAction)
385415-- > extra :: ExtraInfo TestApi
386416-- > extra =
387417-- > extraInfo (Proxy :: Proxy ("greet" :> Capture "greetid" Text :> Delete)) $
388−-- > defAction & headers <>~ ["unicorns"]
418+-- > defAction & headers <>~ [("X-Num-Unicorns", 1)]
389419-- > & notes <>~ [ DocNote "Title" ["This is some text"]
390−-- > , DocNote "Second secton" ["And some more"]
420+-- > , DocNote "Second section" ["And some more"]
391421-- > ]
392422
393423extraInfo :: (IsIn endpoint api, HasLink endpoint, HasDocs endpoint)
@@ -417,7 +447,7 @@ docsWith opts intros (ExtraInfo endpoints) p =
417447 & apiEndpoints %~ HM.unionWith (flip combineAction) endpoints
418448
419449
420−-- | 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
421451-- number of introduction(s)
422452docsWithIntros :: HasDocs api => [DocIntro] -> Proxy api -> API
423453docsWithIntros intros = docsWith defaultDocOptions intros mempty
@@ -480,7 +510,7 @@ samples = map ("",)
480510
481511-- | Default sample Generic-based inputs/outputs.
482512defaultSamples :: forall a. (Generic a, GToSample (Rep a)) => Proxy a -> [(Text, a)]
483−defaultSamples _ = second to <$> gtoSamples (Proxy :: Proxy (Rep a))
513+defaultSamples _ = second G.to <$> gtoSamples (Proxy :: Proxy (Rep a))
484514
485515-- | @'ToSample'@ for Generics.
486516--
@@ -578,6 +608,15 @@ class ToCapture c where
578608class ToAuthInfo a where
579609 toAuthInfo :: Proxy a -> DocAuthentication
580610
611+-- | The class that helps us get documentation for URL fragments.
612+--
613+-- Example of an instance:
614+--
615+-- > instance ToFragment (Fragment a) where
616+-- > toFragment _ = DocFragment "fragment" "fragment description"
617+class ToFragment t where
618+ toFragment :: Proxy t -> DocFragment
619+
581620-- | Generate documentation in Markdown format for
582621-- the given 'API'.
583622--
@@ -607,7 +646,7 @@ markdown = markdownWith defRenderingOptions
607646--
608647-- @since 0.11.1
609648markdownWith :: RenderingOptions -> API -> String
610−markdownWith RenderingOptions{..} api = unlines $
649+markdownWith RenderingOptions{..} api = unlines $
611650 introsStr (api ^. apiIntros)
612651 ++ (concatMap (uncurry printEndpoint) . sort . HM.toList $ api ^. apiEndpoints)
613652
@@ -618,10 +657,12 @@ markdownWith RenderingOptions{..} api = unlines $
618657 notesStr (action ^. notes) ++
619658 authStr (action ^. authInfo) ++
620659 capturesStr (action ^. captures) ++
621− headersStr (action ^. headers) ++
660+ headersStr (toListOf (headers . each . _1 . to (T.pack . BSC.unpack . CI.original)) action) ++
622661 paramsStr meth (action ^. params) ++
662+ fragmentStr (action ^. fragment) ++
623663 rqbodyStr (action ^. rqtypes) (action ^. rqbody) ++
624664 responseStr (action ^. response) ++
665+ maybe [] (curlStr endpoint (action ^. headers) (action ^. rqbody)) _renderCurlBasePath ++
625666 []
626667
627668 where str = "## " ++ BSC.unpack meth
@@ -721,6 +762,14 @@ markdownWith RenderingOptions{..} api = unlines $
721762
722763 where values = param ^. paramValues
723764
765+ fragmentStr :: Maybe DocFragment -> [String]
766+ fragmentStr Nothing = []
767+ fragmentStr (Just frag) =
768+ [ "### Fragment:", ""
769+ , "- *" ++ (frag ^. fragSymbol) ++ "*: " ++ (frag ^. fragDesc)
770+ , ""
771+ ]
772+
724773 rqbodyStr :: [M.MediaType] -> [(Text, M.MediaType, ByteString)]-> [String]
725774 rqbodyStr [] [] = []
726775 rqbodyStr types s =
@@ -769,7 +818,6 @@ markdownWith RenderingOptions{..} api = unlines $
769818 ("text", "css") -> "css"
770819 (_, _) -> ""
771820
772−
773821 contentStr mime_type body =
774822 "" :
775823 "```" <> markdownForType mime_type :
@@ -794,6 +842,36 @@ markdownWith RenderingOptions{..} api = unlines $
794842 xs ->
795843 formatBodies _responseExamples xs
796844
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+
797875-- * Instances
798876
799877-- | The generated docs for @a ':<|>' b@ just appends the docs
@@ -817,7 +895,7 @@ instance HasDocs EmptyAPI where
817895-- | @"books" :> 'Capture' "isbn" Text@ will appear as
818896-- @/books/:isbn@ in the docs.
819897instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs api)
820− => HasDocs (Capture' mods sym a :> api) where
898+ => HasDocs (Capture' '[] sym a :> api) where
821899
822900 docsFor Proxy (endpoint, action) =
823901 docsFor subApiP (endpoint', action')
@@ -829,6 +907,28 @@ instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs api)
829907 endpoint' = over path (\p -> p ++ [":" ++ symbolVal symP]) endpoint
830908 symP = Proxy :: Proxy sym
831909
910+instance (KnownSymbol descr, KnownSymbol sym, HasDocs api)
911+ => HasDocs (Capture' (Description descr ': mods) sym a :> api) where
912+
913+ docsFor Proxy (endpoint, action) =
914+ docsFor subApiP (endpoint', action')
915+
916+ where subApiP = Proxy :: Proxy api
917+
918+ docCapture = DocCapture (symbolVal symP) (symbolVal descrP)
919+ action' = over captures (|> docCapture) action
920+ endpoint' = over path (\p -> p ++ [":" ++ symbolVal symP]) endpoint
921+ descrP = Proxy :: Proxy descr
922+ symP = Proxy :: Proxy sym
923+
924+instance {-# OVERLAPPABLE #-} HasDocs (Capture' mods sym a :> api)
925+ => HasDocs (Capture' (mod ': mods) sym a :> api) where
926+
927+ docsFor Proxy =
928+ docsFor apiP
929+
930+ where apiP = Proxy :: Proxy (Capture' mods sym a :> api)
931+
832932
833933-- | @"books" :> 'CaptureAll' "isbn" Text@ will appear as
834934-- @/books/:isbn@ in the docs.
@@ -910,14 +1010,17 @@ instance {-# OVERLAPPING #-}
9101010 status = fromInteger $ natVal (Proxy :: Proxy status)
9111011 p = Proxy :: Proxy a
9121012
913−instance (KnownSymbol sym, HasDocs api)
1013+instance (ToHttpApiData a, ToSample a, KnownSymbol sym, HasDocs api)
9141014 => HasDocs (Header' mods sym a :> api) where
9151015 docsFor Proxy (endpoint, action) =
9161016 docsFor subApiP (endpoint, action')
9171017
9181018 where subApiP = Proxy :: Proxy api
919− action' = over headers (|> headername) action
920− headername = T.pack $ symbolVal (Proxy :: Proxy sym)
1019+ action' = over headers (|> (headerName, headerVal)) action
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>"
9211024
9221025instance (KnownSymbol sym, ToParam (QueryParam' mods sym a), HasDocs api)
9231026 => HasDocs (QueryParam' mods sym a :> api) where
@@ -950,6 +1053,15 @@ instance (KnownSymbol sym, ToParam (QueryFlag sym), HasDocs api)
9501053 paramP = Proxy :: Proxy (QueryFlag sym)
9511054 action' = over params (|> toParam paramP) action
9521055
1056+instance (ToFragment (Fragment a), HasDocs api)
1057+ => HasDocs (Fragment a :> api) where
1058+
1059+ docsFor Proxy (endpoint, action) =
1060+ docsFor subApiP (endpoint, action')
1061+
1062+ where subApiP = Proxy :: Proxy api
1063+ fragmentP = Proxy :: Proxy (Fragment a)
1064+ action' = set fragment (Just (toFragment fragmentP)) action
9531065
9541066instance HasDocs Raw where
9551067 docsFor _proxy (endpoint, action) _ =
@@ -1032,6 +1144,9 @@ instance HasDocs api => HasDocs (Vault :> api) where
10321144instance HasDocs api => HasDocs (WithNamedContext name context api) where
10331145 docsFor Proxy = docsFor (Proxy :: Proxy api)
10341146
1147+instance HasDocs api => HasDocs (WithResource res :> api) where
1148+ docsFor Proxy = docsFor (Proxy :: Proxy api)
1149+
10351150instance (ToAuthInfo (BasicAuth realm usr), HasDocs api) => HasDocs (BasicAuth realm usr :> api) where
10361151 docsFor Proxy (endpoint, action) =
10371152 docsFor (Proxy :: Proxy api) (endpoint, action')
@@ -1039,6 +1154,9 @@ instance (ToAuthInfo (BasicAuth realm usr), HasDocs api) => HasDocs (BasicAuth r
10391154 authProxy = Proxy :: Proxy (BasicAuth realm usr)
10401155 action' = over authInfo (|> toAuthInfo authProxy) action
10411156
1157+instance HasDocs (ToServantApi api) => HasDocs (NamedRoutes api) where
1158+ docsFor Proxy = docsFor (Proxy :: Proxy (ToServantApi api))
1159+
10421160-- ToSample instances for simple types
10431161instance ToSample NoContent
10441162instance ToSample Bool
@@ -1055,6 +1173,7 @@ instance (ToSample a, ToSample b, ToSample c, ToSample d, ToSample e, ToSample f
10551173instance ToSample a => ToSample (Maybe a)
10561174instance (ToSample a, ToSample b) => ToSample (Either a b)
10571175instance ToSample a => ToSample [a]
1176+instance ToSample a => ToSample (NonEmpty a)
10581177
10591178-- ToSample instances for Control.Applicative types
10601179instance ToSample a => ToSample (Const a b)
servant-docs/src/Servant/Docs/Internal/Pretty.hs+19
@@ -18,6 +18,7 @@ import Data.Proxy
1818import Network.HTTP.Media
1919 ((//))
2020import Servant.API
21+import Servant.API.Verbs
2122
2223-- | PrettyJSON content type.
2324data PrettyJSON
@@ -46,6 +47,24 @@ type family Pretty (api :: k) :: k where
4647 Pretty (Put cs r) = Put (Pretty cs) r
4748 Pretty (Delete cs r) = Delete (Pretty cs) r
4849 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
4968 Pretty (ReqBody cs r) = ReqBody (Pretty cs) r
5069 Pretty (JSON ': xs) = PrettyJSON ': xs
5170 Pretty (x ': xs) = x ': Pretty xs
servant-docs/test/Servant/DocsSpec.hs+21−6
@@ -58,6 +58,8 @@ instance ToCapture (Capture "foo" Int) where
5858 toCapture _ = DocCapture "foo" "Capture foo Int"
5959instance ToCapture (CaptureAll "foo" Int) where
6060 toCapture _ = DocCapture "foo" "Capture all foo Int"
61+instance ToFragment (Fragment Int) where
62+ toFragment _ = DocFragment "foo" "Fragment Int"
6163
6264-- * specs
6365
@@ -66,8 +68,10 @@ spec = describe "Servant.Docs" $ do
6668 golden "comprehensive API" "golden/comprehensive.md" (markdown comprehensiveDocs)
6769
6870 describe "markdown" $ do
69− let md = markdown (docs (Proxy :: Proxy TestApi1))
70− tests md
71+ let md1 = markdown (docs (Proxy :: Proxy TestApi1))
72+ tests1 md1
73+ let md2 = markdown (docs (Proxy :: Proxy TestApi2))
74+ tests2 md2
7175
7276 describe "markdown with extra info" $ do
7377 let
@@ -79,7 +83,7 @@ spec = describe "Servant.Docs" $ do
7983 (Proxy :: Proxy (ReqBody '[JSON] String :> Post '[JSON] Datatype1))
8084 (defAction & notes <>~ [DocNote "Post data" ["Posts some Json data"]])
8185 md = markdown (docsWith defaultDocOptions [] extra (Proxy :: Proxy TestApi1))
82− tests md
86+ tests1 md
8387 it "contains the extra info provided" $ do
8488 md `shouldContain` "Get an Integer"
8589 md `shouldContain` "Post data"
@@ -107,7 +111,7 @@ spec = describe "Servant.Docs" $ do
107111
108112
109113 where
110− tests md = do
114+ tests1 md = do
111115 it "mentions supported content-types" $ do
112116 md `shouldContain` "application/json"
113117 md `shouldContain` "text/plain;charset=utf-8"
@@ -122,14 +126,21 @@ spec = describe "Servant.Docs" $ do
122126 it "mentions headers" $ do
123127 md `shouldContain` "- This endpoint is sensitive to the value of the **X-Test** HTTP header."
124128
125− it "contains response samples" $
126− md `shouldContain` "{\"dt1field1\":\"field 1\",\"dt1field2\":13}"
129+ it "contains response samples - dt1field1" $
130+ md `shouldContain` "\"dt1field1\":\"field 1\""
131+ it "contains response samples - dt1field2" $
132+ md `shouldContain` "\"dt1field2\":13"
127133 it "contains request body samples" $
128134 md `shouldContain` "17"
129135
130136 it "does not generate any docs mentioning the 'empty-api' path" $
131137 md `shouldNotContain` "empty-api"
132138
139+ tests2 md = do
140+ it "mentions the content-types from both copies of the route" $ do
141+ md `shouldContain` "application/json"
142+ md `shouldContain` "text/plain;charset=utf-8"
143+
133144
134145-- * APIs
135146
@@ -156,6 +167,10 @@ type TestApi1 = Get '[JSON, PlainText] (Headers '[Header "Location" String] Int)
156167 :<|> Header "X-Test" Int :> Put '[JSON] Int
157168 :<|> "empty-api" :> EmptyAPI
158169
170+type TestApi2 = "duplicate-endpoint" :> Get '[JSON] Datatype1
171+ :<|> "duplicate-endpoint" :> Get '[PlainText] Int
172+
173+
159174data TT = TT1 | TT2 deriving (Show, Eq)
160175data UT = UT1 | UT2 deriving (Show, Eq)
161176
servant-foreign/CHANGELOG.md+87
@@ -1,6 +1,93 @@
11[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-foreign/CHANGELOG.md)
22[Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)
33
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+
16+0.15.3
17+------
18+
19+### Significant changes
20+
21+- Support `Fragment` combinator.
22+
23+0.15.2
24+------
25+
26+* Support `servant-0.18`.
27+
28+0.15.1
29+------
30+
31+* Support `servant-0.17`
32+
33+0.15
34+----
35+
36+- *servant-foreign* Add support so `HasForeign` can be implemented for
37+ `MultipartForm` from [`servant-multipart`](http://hackage.haskell.org/package/servant-multipart)
38+ [#1035](https://github.com/haskell-servant/servant/pull/1035)
39+
40+- Drop support for GHC older than 8.0
41+ [#1008](https://github.com/haskell-servant/servant/pull/1008)
42+ [#1009](https://github.com/haskell-servant/servant/pull/1009)
43+
44+
45+0.11.1
46+------
47+
48+- Add missing `Semigroup` instances
49+
50+0.11
51+----
52+
53+### Breaking changes
54+
55+- *servant* Add `Servant.API.Modifiers`
56+ ([#873](https://github.com/haskell-servant/servant/pull/873))
57+- Make foreign client Header arguments have the representation of 'Maybe' in those languages
58+ ([#843](https://github.com/haskell-servant/servant/pull/843))
59+
60+0.10.2
61+------
62+
63+### Changes
64+
65+* Add instances for `Description` and `Summary` combinators
66+ ([#767](https://github.com/haskell-servant/servant/pull/767))
67+* Derive Data for all types
68+ ([#809](https://github.com/haskell-servant/servant/pull/809))
69+
70+0.10.1
71+------
72+
73+### Changes
74+
75+* Don't drop samples in `HasDocs ReqBody` instance
76+ ([#755](https://github.com/haskell-servant/servant/pull/755/files)).
77+ *Breaking change in an `Internal` module*.
78+
79+0.10
80+----
81+
82+### Breaking changes
83+
84+* Do not apply JavaScript specific mangling to the names.
85+ ([#191](https://github.com/haskell-servant/servant/issues/191))
86+
87+0.7.1
88+-----
89+
90+* Support GHC 8.0
4910.15
592----
693
servant-foreign/servant-foreign.cabal+12−19
@@ -1,7 +1,6 @@
1−cabal-version: >=1.10
1+cabal-version: 2.2
22name: servant-foreign
3−version: 0.15
4−x-revision: 1
3+version: 0.15.4
54
65synopsis: Helpers for generating clients for servant APIs in any programming language
76category: Servant, Web
@@ -16,18 +15,13 @@ description:
1615
1716homepage: http://docs.servant.dev/
1817bug-reports: http://github.com/haskell-servant/servant/issues
19−license: BSD3
18+license: BSD-3-Clause
2019license-file: LICENSE
2120author: Servant Contributors
2221maintainer: haskell-servant-maintainers@googlegroups.com
2322copyright: 2015-2019 Servant Contributors
2423build-type: Simple
25−tested-with:
26− GHC ==8.0.2
27− || ==8.2.2
28− || ==8.4.4
29− || ==8.6.5
30− || ==8.8.1
24+tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1
3125
3226extra-source-files:
3327 CHANGELOG.md
@@ -47,18 +41,18 @@ library
4741 --
4842 -- note: mtl lower bound is so low because of GHC-7.8
4943 build-depends:
50− base >= 4.9 && < 4.14
51− , text >= 1.2.3.0 && < 1.3
44+ base >= 4.9 && < 4.18
45+ , text >= 1.2.3.0 && < 2.1
5246
5347 -- Servant dependencies
5448 build-depends:
55− servant >=0.15 && <0.17
49+ servant >=0.18 && <0.20
5650
5751 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.
5852 -- Here can be exceptions if we really need features from the newer versions.
5953 build-depends:
60− base-compat >= 0.10.5 && < 0.12
61− , lens >= 4.17 && < 4.19
54+ base-compat >= 0.10.5 && < 0.13
55+ , lens >= 4.17 && < 5.3
6256 , http-types >= 0.12.2 && < 0.13
6357
6458 hs-source-dirs: src
@@ -78,10 +72,9 @@ test-suite spec
7872 , servant
7973 , servant-foreign
8074
81− -- Additonal dependencies
75+ -- Additional dependencies
8276 build-depends:
83− hspec >= 2.6.0 && <2.8
84−
77+ hspec >= 2.6.0 && <2.10
8578 build-tool-depends:
86− hspec-discover:hspec-discover >=2.6.0 && <2.8
79+ hspec-discover:hspec-discover >=2.6.0 && <2.10
8780 default-language: Haskell2010
servant-foreign/src/Servant/Foreign.hs+22−19
@@ -1,20 +1,32 @@
11-- | Generalizes all the data needed to make code generation work with
22-- arbitrary programming languages.
3+--
4+-- See documentation of 'HasForeignType' for a simple example. 'listFromAPI' returns a list of all your endpoints and their foreign types, given a mapping from Haskell types to foreign types (conventionally called `ftypes` below).
35module Servant.Foreign
4− ( ArgType(..)
5− , HeaderArg(..)
6− , QueryArg(..)
6+ (
7+ -- * Main API
8+ listFromAPI
79 , Req(..)
8− , ReqBodyContentType(..)
9− , Segment(..)
10− , SegmentType(..)
10+ , defReq
11+ , HasForeignType(..)
12+ , GenerateList(..)
13+ , HasForeign(..)
14+ , NoTypes
15+ -- * Subtypes of 'Req'
1116 , Url(..)
12− -- aliases
1317 , Path
18+ , Segment(..)
19+ , SegmentType(..)
20+ , isCapture
21+ , captureArg
22+ , QueryArg(..)
23+ , ArgType(..)
24+ , HeaderArg(..)
1425 , Arg(..)
1526 , FunctionName(..)
27+ , ReqBodyContentType(..)
1628 , PathSegment(..)
17− -- lenses
29+ -- * Lenses
1830 , argName
1931 , argType
2032 , argPath
@@ -30,7 +42,7 @@ module Servant.Foreign
3042 , queryArgName
3143 , queryArgType
3244 , headerArg
33− -- prisms
45+ -- * Prisms
3446 , _PathSegment
3547 , _HeaderArg
3648 , _ReplaceHeaderArg
@@ -39,16 +51,7 @@ module Servant.Foreign
3951 , _Normal
4052 , _Flag
4153 , _List
42− -- rest of it
43− , HasForeign(..)
44− , HasForeignType(..)
45− , GenerateList(..)
46− , NoTypes
47− , captureArg
48− , isCapture
49− , defReq
50− , listFromAPI
51− -- re-exports
54+ -- * Re-exports
5255 , module Servant.API
5356 , module Servant.Foreign.Inflections
5457 ) where
servant-foreign/src/Servant/Foreign/Inflections.hs+18−13
@@ -13,27 +13,37 @@ module Servant.Foreign.Inflections
1313import Control.Lens hiding
1414 (cons)
1515import qualified Data.Char as C
16−import Data.Monoid
1716import Data.Text hiding
1817 (map)
1918import Prelude hiding
2019 (head, tail)
2120import Servant.Foreign.Internal
2221
22+-- | Simply concat each part of the FunctionName together.
23+--
24+-- @[ "get", "documents", "by", "id" ] → "getdocumentsbyid"@
25+concatCase :: FunctionName -> Text
26+concatCase = view concatCaseL
27+
2328concatCaseL :: Getter FunctionName Text
2429concatCaseL = _FunctionName . to mconcat
2530
26−-- | Function name builder that simply concat each part together
27−concatCase :: FunctionName -> Text
28−concatCase = view concatCaseL
31+-- | Use the snake_case convention.
32+-- Each part is separated by a single underscore character.
33+--
34+-- @[ "get", "documents", "by", "id" ] → "get_documents_by_id"@
35+snakeCase :: FunctionName -> Text
36+snakeCase = view snakeCaseL
2937
3038snakeCaseL :: Getter FunctionName Text
3139snakeCaseL = _FunctionName . to (intercalate "_")
3240
33−-- | Function name builder using the snake_case convention.
34−-- each part is separated by a single underscore character.
35−snakeCase :: FunctionName -> Text
36−snakeCase = view snakeCaseL
41+-- | Use the camelCase convention.
42+-- The first part is lower case, every other part starts with an upper case character.
43+--
44+-- @[ "get", "documents", "by", "id" ] → "getDocumentsById"@
45+camelCase :: FunctionName -> Text
46+camelCase = view camelCaseL
3747
3848camelCaseL :: Getter FunctionName Text
3949camelCaseL = _FunctionName . to convert
@@ -42,8 +52,3 @@ camelCaseL = _FunctionName . to convert
4252 convert (p:ps) = mconcat $ p : map capitalize ps
4353 capitalize "" = ""
4454 capitalize name = C.toUpper (head name) `cons` tail name
45−
46−-- | Function name builder using the CamelCase convention.
47−-- each part begins with an upper case character.
48−camelCase :: FunctionName -> Text
49−camelCase = view camelCaseL
servant-foreign/src/Servant/Foreign/Internal.hs+141−32
@@ -13,8 +13,6 @@
1313{-# LANGUAGE TypeOperators #-}
1414{-# LANGUAGE UndecidableInstances #-}
1515
16−-- | Generalizes all the data needed to make code generation work with
17−-- arbitrary programming languages.
1816module Servant.Foreign.Internal where
1917
2018import Prelude ()
@@ -25,8 +23,6 @@ import Control.Lens
2523import Data.Data
2624 (Data)
2725import Data.Proxy
28−import Data.Semigroup
29− (Semigroup)
3026import Data.String
3127import Data.Text
3228import Data.Text.Encoding
@@ -40,50 +36,75 @@ import Servant.API.Modifiers
4036 (RequiredArgument)
4137import Servant.API.TypeLevel
4238
39+-- | Canonical name of the endpoint, can be used to generate a function name.
40+--
41+-- You can use the functions in "Servant.Foreign.Inflections", like 'Servant.Foreign.Inflections.camelCase' to transform to `Text`.
4342newtype FunctionName = FunctionName { unFunctionName :: [Text] }
4443 deriving (Data, Show, Eq, Semigroup, Monoid, Typeable)
4544
4645makePrisms ''FunctionName
4746
47+-- | See documentation of 'Arg'
4848newtype PathSegment = PathSegment { unPathSegment :: Text }
4949 deriving (Data, Show, Eq, IsString, Semigroup, Monoid, Typeable)
5050
5151makePrisms ''PathSegment
5252
53−data Arg f = Arg
53+-- | Maps a name to the foreign type that belongs to the annotated value.
54+--
55+-- Used for header args, query args, and capture args.
56+data Arg ftype = Arg
5457 { _argName :: PathSegment
55− , _argType :: f }
58+ -- ^ The name to be captured.
59+ --
60+ -- Only for capture args it really denotes a path segment.
61+ , _argType :: ftype
62+ -- ^ Foreign type the associated value will have
63+ }
5664 deriving (Data, Eq, Show, Typeable)
5765
5866makeLenses ''Arg
5967
60−argPath :: Getter (Arg f) Text
68+argPath :: Getter (Arg ftype) Text
6169argPath = argName . _PathSegment
6270
63−data SegmentType f
71+data SegmentType ftype
6472 = Static PathSegment
65− -- ^ a static path segment. like "/foo"
66− | Cap (Arg f)
67− -- ^ a capture. like "/:userid"
73+ -- ^ Static path segment.
74+ --
75+ -- @"foo\/bar\/baz"@
76+ --
77+ -- contains the static segments @"foo"@, @"bar"@ and @"baz"@.
78+ | Cap (Arg ftype)
79+ -- ^ A capture.
80+ --
81+ -- @"user\/{userid}\/name"@
82+ --
83+ -- would capture the arg @userid@ with type @ftype@.
6884 deriving (Data, Eq, Show, Typeable)
6985
7086makePrisms ''SegmentType
7187
72−newtype Segment f = Segment { unSegment :: SegmentType f }
88+-- | A part of the Url’s path.
89+newtype Segment ftype = Segment { unSegment :: SegmentType ftype }
7390 deriving (Data, Eq, Show, Typeable)
7491
7592makePrisms ''Segment
7693
77−isCapture :: Segment f -> Bool
94+-- | Whether a segment is a 'Cap'.
95+isCapture :: Segment ftype -> Bool
7896isCapture (Segment (Cap _)) = True
7997isCapture _ = False
8098
81−captureArg :: Segment f -> Arg f
99+-- | Crashing Arg extraction from segment, TODO: remove
100+captureArg :: Segment ftype -> Arg ftype
82101captureArg (Segment (Cap s)) = s
83102captureArg _ = error "captureArg called on non capture"
84103
85−type Path f = [Segment f]
104+-- TODO: remove, unnecessary indirection
105+type Path ftype = [Segment ftype]
86106
107+-- | Type of a 'QueryArg'.
87108data ArgType
88109 = Normal
89110 | Flag
@@ -92,18 +113,41 @@ data ArgType
92113
93114makePrisms ''ArgType
94115
95−data QueryArg f = QueryArg
96− { _queryArgName :: Arg f
116+-- | Url Query argument.
117+--
118+-- Urls can contain query arguments, which is a list of key-value pairs.
119+-- In a typical url, query arguments look like this:
120+--
121+-- @?foo=bar&alist[]=el1&alist[]=el2&aflag@
122+--
123+-- Each pair can be
124+--
125+-- * @?foo=bar@: a plain key-val pair, either optional or required ('QueryParam')
126+-- * @?aflag@: a flag (no value, implicitly Bool with default `false` if it’s missing) ('QueryFlag')
127+-- * @?alist[]=el1&alist[]=el2@: list of values ('QueryParams')
128+--
129+-- @_queryArgType@ will be set accordingly.
130+--
131+-- For the plain key-val pairs ('QueryParam'), @_queryArgName@’s @ftype@ will be wrapped in a @Maybe@ if the argument is optional.
132+data QueryArg ftype = QueryArg
133+ { _queryArgName :: Arg ftype
134+ -- ^ Name and foreign type of the argument. Will be wrapped in `Maybe` if the query is optional and in a `[]` if the query is a list
97135 , _queryArgType :: ArgType
136+ -- ^ one of normal/plain, list or flag
98137 }
99138 deriving (Data, Eq, Show, Typeable)
100139
101140makeLenses ''QueryArg
102141
103−data HeaderArg f = HeaderArg
104− { _headerArg :: Arg f }
142+data HeaderArg ftype =
143+ -- | The name of the header and the foreign type of its value.
144+ HeaderArg
145+ { _headerArg :: Arg ftype }
146+ -- | Unused, will never be set.
147+ --
148+ -- TODO: remove
105149 | ReplaceHeaderArg
106− { _headerArg :: Arg f
150+ { _headerArg :: Arg ftype
107151 , _headerPattern :: Text
108152 }
109153 deriving (Data, Eq, Show, Typeable)
@@ -112,28 +156,71 @@ makeLenses ''HeaderArg
112156
113157makePrisms ''HeaderArg
114158
115−data Url f = Url
116− { _path :: Path f
117− , _queryStr :: [QueryArg f]
159+-- | Full endpoint url, with all captures and parameters
160+data Url ftype = Url
161+ { _path :: Path ftype
162+ -- ^ Url path, list of either static segments or captures
163+ --
164+ -- @"foo\/{id}\/bar"@
165+ , _queryStr :: [QueryArg ftype]
166+ -- ^ List of query args
167+ --
168+ -- @"?foo=bar&a=b"@
169+ , _frag :: Maybe ftype
170+ -- ^ Url fragment.
171+ --
172+ -- Not sent to the HTTP server, so only useful for frontend matters (e.g. inter-page linking).
173+ --
174+ -- @#fragmentText@
118175 }
119176 deriving (Data, Eq, Show, Typeable)
120177
121−defUrl :: Url f
122−defUrl = Url [] []
178+defUrl :: Url ftype
179+defUrl = Url [] [] Nothing
123180
124181makeLenses ''Url
125182
183+-- | See documentation of '_reqBodyContentType'
126184data ReqBodyContentType = ReqBodyJSON | ReqBodyMultipart
127185 deriving (Data, Eq, Show, Read)
128186
129−data Req f = Req
130− { _reqUrl :: Url f
187+-- | Full description of an endpoint in your API, generated by 'listFromAPI'. It should give you all the information needed to generate foreign language bindings.
188+--
189+-- Every field containing @ftype@ will use the foreign type mapping specified via 'HasForeignType' (see its docstring on how to set that up).
190+--
191+-- See https://docs.servant.dev/en/stable/tutorial/ApiType.html for accessible documentation of the possible content of an endpoint.
192+data Req ftype = Req
193+ { _reqUrl :: Url ftype
194+ -- ^ Full list of URL segments, including captures
131195 , _reqMethod :: HTTP.Method
132− , _reqHeaders :: [HeaderArg f]
133− , _reqBody :: Maybe f
134− , _reqReturnType :: Maybe f
196+ -- ^ @\"GET\"@\/@\"POST\"@\/@\"PUT\"@\/…
197+ , _reqHeaders :: [HeaderArg ftype]
198+ -- ^ Headers required by this endpoint, with their type
199+ , _reqBody :: Maybe ftype
200+ -- ^ Foreign type of the expected request body ('ReqBody'), if any
201+ , _reqReturnType :: Maybe ftype
202+ -- ^ The foreign type of the response, if any
135203 , _reqFuncName :: FunctionName
204+ -- ^ The URL segments rendered in a way that they can be easily concatenated into a canonical function name
136205 , _reqBodyContentType :: ReqBodyContentType
206+ -- ^ The content type the request body is transferred as.
207+ --
208+ -- This is a severe limitation of @servant-foreign@ currently,
209+ -- as we only allow the content type to be `JSON`
210+ -- no user-defined content types. ('ReqBodyMultipart' is not
211+ -- actually implemented.)
212+ --
213+ -- Thus, any routes looking like this will work:
214+ --
215+ -- @"foo" :> Get '[JSON] Foo@
216+ --
217+ -- while routes like
218+ --
219+ -- @"foo" :> Get '[MyFancyContentType] Foo@
220+ --
221+ -- will fail with an error like
222+ --
223+ -- @• JSON expected in list '[MyFancyContentType]@
137224 }
138225 deriving (Data, Eq, Show, Typeable)
139226
@@ -157,7 +244,7 @@ defReq = Req defUrl "GET" [] Nothing Nothing (FunctionName []) ReqBodyJSON
157244-- >
158245-- > -- Or for example in case of lists
159246-- > instance HasForeignType LangX Text a => HasForeignType LangX Text [a] where
160−-- > typeFor lang type _ = "listX of " <> typeFor lang ftype (Proxy :: Proxy a)
247+-- > typeFor lang ftype _ = "listX of " <> typeFor lang ftype (Proxy :: Proxy a)
161248--
162249-- Finally to generate list of information about all the endpoints for
163250-- an API you create a function of a form:
@@ -177,11 +264,16 @@ defReq = Req defUrl "GET" [] Nothing Nothing (FunctionName []) ReqBodyJSON
177264class HasForeignType lang ftype a where
178265 typeFor :: Proxy lang -> Proxy ftype -> Proxy a -> ftype
179266
267+-- | The language definition without any foreign types. It can be used for dynamic languages which do not /do/ type annotations.
180268data NoTypes
181269
182−instance HasForeignType NoTypes NoContent ftype where
270+-- | Use if the foreign language does not have any types.
271+instance HasForeignType NoTypes NoContent a where
183272 typeFor _ _ _ = NoContent
184273
274+-- | Implementation of the Servant framework types.
275+--
276+-- Relevant instances: Everything containing 'HasForeignType'.
185277class HasForeign lang ftype (api :: *) where
186278 type Foreign ftype api :: *
187279 foreignFor :: Proxy lang -> Proxy ftype -> Proxy api -> Req ftype -> Foreign ftype api
@@ -324,6 +416,16 @@ instance
324416 { _argName = PathSegment str
325417 , _argType = typeFor lang ftype (Proxy :: Proxy Bool) }
326418
419+instance
420+ (HasForeignType lang ftype (Maybe a), HasForeign lang ftype api)
421+ => HasForeign lang ftype (Fragment a :> api) where
422+ type Foreign ftype (Fragment a :> api) = Foreign ftype api
423+ foreignFor lang Proxy Proxy req =
424+ foreignFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy api) $
425+ req & reqUrl . frag .~ Just argT
426+ where
427+ argT = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy (Maybe a))
428+
327429instance HasForeign lang ftype Raw where
328430 type Foreign ftype Raw = HTTP.Method -> Req ftype
329431
@@ -385,6 +487,13 @@ instance HasForeign lang ftype api =>
385487
386488 foreignFor lang ftype Proxy = foreignFor lang ftype (Proxy :: Proxy api)
387489
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+
388497instance HasForeign lang ftype api
389498 => HasForeign lang ftype (HttpVersion :> api) where
390499 type Foreign ftype (HttpVersion :> api) = Foreign ftype api
servant-foreign/test/Servant/ForeignSpec.hs+7−4
@@ -11,11 +11,9 @@
1111
1212module Servant.ForeignSpec where
1313
14−import Data.Monoid
15− ((<>))
1614import Data.Proxy
17−import Servant.Test.ComprehensiveAPI
1815import Servant.Foreign
16+import Servant.Test.ComprehensiveAPI
1917import Servant.Types.SourceT
2018 (SourceT)
2119
@@ -91,6 +89,7 @@ listFromAPISpec = describe "listFromAPI" $ do
9189 { _reqUrl = Url
9290 [ Segment $ Static "test" ]
9391 [ QueryArg (Arg "flag" "boolX") Flag ]
92+ Nothing
9493 , _reqMethod = "GET"
9594 , _reqHeaders = [HeaderArg $ Arg "header" "maybe listX of stringX"]
9695 , _reqBody = Nothing
@@ -103,6 +102,7 @@ listFromAPISpec = describe "listFromAPI" $ do
103102 { _reqUrl = Url
104103 [ Segment $ Static "test" ]
105104 [ QueryArg (Arg "param" "maybe intX") Normal ]
105+ Nothing
106106 , _reqMethod = "POST"
107107 , _reqHeaders = []
108108 , _reqBody = Just "listX of stringX"
@@ -114,8 +114,9 @@ listFromAPISpec = describe "listFromAPI" $ do
114114 shouldBe putReq $ defReq
115115 { _reqUrl = Url
116116 [ Segment $ Static "test" ]
117− -- Shoud this be |intX| or |listX of intX| ?
117+ -- Should this be |intX| or |listX of intX| ?
118118 [ QueryArg (Arg "params" "listX of intX") List ]
119+ Nothing
119120 , _reqMethod = "PUT"
120121 , _reqHeaders = []
121122 , _reqBody = Just "stringX"
@@ -129,6 +130,7 @@ listFromAPISpec = describe "listFromAPI" $ do
129130 [ Segment $ Static "test"
130131 , Segment $ Cap (Arg "id" "intX") ]
131132 []
133+ Nothing
132134 , _reqMethod = "DELETE"
133135 , _reqHeaders = []
134136 , _reqBody = Nothing
@@ -142,6 +144,7 @@ listFromAPISpec = describe "listFromAPI" $ do
142144 [ Segment $ Static "test"
143145 , Segment $ Cap (Arg "ids" "listX of intX") ]
144146 []
147+ Nothing
145148 , _reqMethod = "GET"
146149 , _reqHeaders = []
147150 , _reqBody = Nothing
servant-http-streams/CHANGELOG.md+86
@@ -1,6 +1,92 @@
11 [The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-http-streams/CHANGELOG.md)
22[Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)
33
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+
14+0.18.3
15+------
16+
17+### Other changes
18+
19+- Support GHC-9.0.1.
20+- Fix test suite running in CI.
21+- Bump `bytestring` and `hspec` dependencies.
22+
23+0.18.2
24+------
25+
26+### Significant changes
27+
28+- Support `servant-client-core` 0.18.2.
29+
30+0.18.1
31+------
32+
33+### Significant changes
34+
35+- Union verbs
36+
37+### Other changes
38+
39+- Bump "tested-with" ghc versions
40+
41+0.18
42+----
43+
44+### Significant changes
45+
46+- Support for ghc8.8 (#1318, #1326, #1327)
47+
48+
49+0.17
50+----
51+
52+### Significant changes
53+
54+- Add NoContentVerb [#1028](https://github.com/haskell-servant/servant/issues/1028) [#1219](https://github.com/haskell-servant/servant/pull/1219) [#1228](https://github.com/haskell-servant/servant/pull/1228)
55+
56+ The `NoContent` API endpoints should now use `NoContentVerb` combinator.
57+ The API type changes are usually of the kind
58+
59+ ```diff
60+ - :<|> PostNoContent '[JSON] NoContent
61+ + :<|> PostNoContent
62+ ```
63+
64+ i.e. one doesn't need to specify the content-type anymore. There is no content.
65+
66+- `Capture` can be `Lenient` [#1155](https://github.com/haskell-servant/servant/issues/1155) [#1156](https://github.com/haskell-servant/servant/pull/1156)
67+
68+ You can specify a lenient capture as
69+
70+ ```haskell
71+ :<|> "capture-lenient" :> Capture' '[Lenient] "foo" Int :> GET
72+ ```
73+
74+ which will make the capture always succeed. Handlers will be of the
75+ type `Either String CapturedType`, where `Left err` represents
76+ the possible parse failure.
77+
78+### Other changes
79+
80+- *servant-client* *servant-client-core* *servant-http-streams* Fix Verb with headers checking content type differently [#1200](https://github.com/haskell-servant/servant/issues/1200) [#1204](https://github.com/haskell-servant/servant/pull/1204)
81+
82+ For `Verb`s with response `Headers`, the implementation didn't check
83+ for the content-type of the response. Now it does.
84+
85+- *servant-client* *servant-http-streams* `HasClient` instance for `Stream` with `Headers` [#1170](https://github.com/haskell-servant/servant/issues/1170) [#1197](https://github.com/haskell-servant/servant/pull/1197)
86+- *servant-client* Redact the authorization header in Show and exceptions [#1238](https://github.com/haskell-servant/servant/pull/1238)
87+
88+
89+
4900.16.0.1
591--------
692
servant-http-streams/servant-http-streams.cabal+20−25
@@ -1,6 +1,6 @@
1−cabal-version: >=1.10
1+cabal-version: 2.2
22name: servant-http-streams
3−version: 0.16
3+version: 0.18.4
44
55synopsis: Automatic derivation of querying functions for servant
66category: Servant, Web
@@ -14,18 +14,13 @@ description:
1414
1515homepage: http://docs.servant.dev/
1616bug-reports: http://github.com/haskell-servant/servant/issues
17−license: BSD3
17+license: BSD-3-Clause
1818license-file: LICENSE
1919author: Servant Contributors
2020maintainer: haskell-servant-maintainers@googlegroups.com
2121copyright: 2019 Servant Contributors
2222build-type: Simple
23−tested-with:
24− GHC ==8.0.2
25− || ==8.2.2
26− || ==8.4.4
27− || ==8.6.5
28− || ==8.8.1
23+tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1
2924
3025extra-source-files:
3126 CHANGELOG.md
@@ -43,14 +38,14 @@ library
4338 -- Bundled with GHC: Lower bound to not force re-installs
4439 -- text and mtl are bundled starting with GHC-8.4
4540 build-depends:
46− base >= 4.9 && < 4.14
47− , bytestring >= 0.10.8.1 && < 0.11
41+ base >= 4.9 && < 4.18
42+ , bytestring >= 0.10.8.1 && < 0.12
4843 , containers >= 0.5.7.1 && < 0.7
4944 , deepseq >= 1.4.2.0 && < 1.5
50− , mtl >= 2.2.2 && < 2.3
51− , text >= 1.2.3.0 && < 1.3
52− , time >= 1.6.0.1 && < 1.10
53− , transformers >= 0.5.2.0 && < 0.6
45+ , mtl ^>= 2.2.2 || ^>= 2.3.1
46+ , text >= 1.2.3.0 && < 2.1
47+ , time >= 1.6.0.1 && < 1.13
48+ , transformers >= 0.5.2.0 && < 0.7
5449
5550 if !impl(ghc >= 8.2)
5651 build-depends:
@@ -59,13 +54,13 @@ library
5954 -- Servant dependencies.
6055 -- Strict dependency on `servant-client-core` as we re-export things.
6156 build-depends:
62− servant == 0.16.*
63− , servant-client-core >= 0.16 && <0.16.1
57+ servant >= 0.18 && < 0.20
58+ , servant-client-core >= 0.18.3 && <0.20
6459
6560 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.
6661 -- Here can be exceptions if we really need features from the newer versions.
6762 build-depends:
68− base-compat >= 0.10.5 && < 0.12
63+ base-compat >= 0.10.5 && < 0.13
6964 , case-insensitive
7065 , http-streams >= 0.8.6.1 && < 0.9
7166 , http-media >= 0.7.1.3 && < 0.9
@@ -77,7 +72,7 @@ library
7772 , monad-control >= 1.0.2.3 && < 1.1
7873 , semigroupoids >= 5.3.1 && < 5.4
7974 , transformers-base >= 0.4.5.2 && < 0.5
80− , transformers-compat >= 0.6.2 && < 0.7
75+ , transformers-compat >= 0.6.2 && < 0.8
8176
8277 hs-source-dirs: src
8378 default-language: Haskell2010
@@ -114,19 +109,19 @@ test-suite spec
114109 , wai
115110 , warp
116111
117− -- Additonal dependencies
112+ -- Additional dependencies
118113 build-depends:
119114 entropy >= 0.4.1.3 && < 0.5
120− , hspec >= 2.6.0 && < 2.8
115+ , hspec >= 2.6.0 && < 2.10
121116 , HUnit >= 1.6.0.0 && < 1.7
122117 , network >= 2.8.0.0 && < 3.2
123− , QuickCheck >= 2.12.6.1 && < 2.14
124− , servant == 0.16.*
125− , servant-server == 0.16.*
118+ , QuickCheck >= 2.12.6.1 && < 2.15
119+ , servant == 0.19.*
120+ , servant-server == 0.19.*
126121 , tdigest >= 0.2 && < 0.3
127122
128123 build-tool-depends:
129− hspec-discover:hspec-discover >= 2.6.0 && < 2.8
124+ hspec-discover:hspec-discover >= 2.6.0 && < 2.10
130125
131126test-suite readme
132127 type: exitcode-stdio-1.0
servant-http-streams/src/Servant/HttpStreams/Internal.hs+11−10
@@ -49,8 +49,6 @@ import Data.Maybe
4949 (maybeToList)
5050import Data.Proxy
5151 (Proxy (..))
52−import Data.Semigroup
53− ((<>))
5452import Data.Sequence
5553 (fromList)
5654import Data.String
@@ -59,7 +57,7 @@ import GHC.Generics
5957import Network.HTTP.Media
6058 (renderHeader)
6159import Network.HTTP.Types
62− (Status (..), hContentType, http11, renderQuery)
60+ (Status (..), hContentType, http11, renderQuery, statusIsSuccessful)
6361import Servant.Client.Core
6462
6563import qualified Network.Http.Client as Client
@@ -141,7 +139,7 @@ instance Alt ClientM where
141139 a <!> b = a `catchError` \_ -> b
142140
143141instance RunClient ClientM where
144− runRequest = performRequest
142+ runRequestAcceptStatus = performRequest
145143 throwClientError = throwError
146144
147145instance RunStreamingClient ClientM where
@@ -155,17 +153,20 @@ withClientM cm env k =
155153 let Codensity f = runExceptT $ flip runReaderT env $ unClientM cm
156154 in f k
157155
158−performRequest :: Request -> ClientM Response
159−performRequest req = do
156+performRequest :: Maybe [Status] -> Request -> ClientM Response
157+performRequest acceptStatus req = do
160158 ClientEnv burl conn <- ask
161159 let (req', body) = requestToClientRequest burl req
162160 x <- ClientM $ lift $ lift $ Codensity $ \k -> do
163161 Client.sendRequest conn req' body
164162 Client.receiveResponse conn $ \res' body' -> do
165− let sc = Client.getStatusCode res'
163+ let status = toEnum $ Client.getStatusCode res'
166164 lbs <- BSL.fromChunks <$> Streams.toList body'
167165 let res'' = clientResponseToResponse res' lbs
168− if sc >= 200 && sc < 300
166+ goodStatus = case acceptStatus of
167+ Nothing -> statusIsSuccessful status
168+ Just good -> status `elem` good
169+ if goodStatus
169170 then k (Right res'')
170171 else k (Left (mkFailureResponse burl req res''))
171172
@@ -179,8 +180,8 @@ performWithStreamingRequest req k = do
179180 Client.sendRequest conn req' body
180181 Client.receiveResponseRaw conn $ \res' body' -> do
181182 -- check status code
182− let sc = Client.getStatusCode res'
183− unless (sc >= 200 && sc < 300) $ do
183+ let status = toEnum $ Client.getStatusCode res'
184+ unless (statusIsSuccessful status) $ do
184185 lbs <- BSL.fromChunks <$> Streams.toList body'
185186 throwIO $ mkFailureResponse burl req (clientResponseToResponse res' lbs)
186187
servant-http-streams/test/Servant/ClientSpec.hs+4−6
@@ -44,8 +44,6 @@ import Data.Maybe
4444 (isJust)
4545import Data.Monoid ()
4646import Data.Proxy
47−import Data.Semigroup
48− ((<>))
4947import GHC.Generics
5048 (Generic)
5149import qualified Network.HTTP.Types as HTTP
@@ -77,7 +75,7 @@ _ = client comprehensiveAPIWithoutStreaming
7775
7876spec :: Spec
7977spec = describe "Servant.HttpStreams" $ do
80− sucessSpec
78+ successSpec
8179 failSpec
8280 wrappedApiSpec
8381 basicAuthSpec
@@ -262,8 +260,8 @@ runClientUnsafe x burl = withClientEnvIO burl (runClientMUnsafe x)
262260 where
263261 runClientMUnsafe x env = withClientM x env return
264262
265−sucessSpec :: Spec
266−sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
263+successSpec :: Spec
264+successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
267265 it "Servant.API.Get root" $ \(_, baseUrl) -> do
268266 left show <$> runClient getRoot baseUrl `shouldReturn` Right carol
269267
@@ -482,7 +480,7 @@ startWaiApp app = do
482480 (port, socket) <- openTestSocket
483481 let settings = setPort port $ defaultSettings
484482 thread <- forkIO $ runSettingsSocket settings socket app
485− return (thread, BaseUrl Http "localhost" port "")
483+ return (thread, BaseUrl Http "127.0.0.1" port "")
486484
487485
488486endWaiApp :: (ThreadId, BaseUrl) -> IO ()
servant-jsaddle/CHANGELOG.mddeleted−4
@@ -1,4 +0,0 @@
1−X.Y
2−----
3−
4−Initial release
servant-jsaddle/README.mddeleted−15
@@ -1,15 +0,0 @@
1−# `servant-client-jsaddle`
2−
3−This is a an implementation of the `servant-client-core` API on top of `jsaddle`, a framework that lets you write Haskell programs that compile to javascript to run in a browser or compile to native code that connects to a browser.
4−
5−It is similar to `servant-client-ghcjs`, except it supports native compilation and native GHCi. It even reuses some of the logic from `servant-client-ghcjs`.
6−
7−# Build
8−
9−This package comes with a test suite that depends on `jsaddle-webkit2gtk`. You may want to skip that because of the heavy dependency footprint.
10−
11− cabal new-build --allow-newer=aeson,http-types --disable-tests
12−
13−# Usage
14−
15−TBD. Similar to `servant-client` and `servant-client-ghcjs`.
servant-jsaddle/Setup.hsdeleted−2
@@ -1,2 +0,0 @@
1−import Distribution.Simple
2−main = defaultMain
servant-jsaddle/servant-jsaddle.cabaldeleted−125
@@ -1,125 +0,0 @@
1−name: servant-jsaddle
2−version: 0.16
3−synopsis:
4− automatic derivation of querying functions for servant webservices for jsaddle
5−
6−description:
7− This library lets you automatically derive Haskell functions that
8− let you query each endpoint of a <http://hackage.haskell.org/package/servant servant> webservice.
9− .
10− See <http://haskell-servant.readthedocs.org/en/stable/tutorial/Client.html the client section of the tutorial>.
11− .
12− <https://github.com/haskell-servant/servant/blob/master/servant-client/CHANGELOG.md CHANGELOG>
13−
14−license: BSD3
15−license-file: LICENSE
16−author: Servant Contributors
17−maintainer: haskell-servant-maintainers@googlegroups.com
18−copyright:
19− 2014-2016 Zalora South East Asia Pte Ltd, 2016-2017 Servant Contributors
20−
21−category: Servant, Web
22−build-type: Simple
23−cabal-version: >=1.10
24−tested-with:
25− GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.1
26− , GHCJS ==8.4
27−
28−homepage: http://haskell-servant.readthedocs.org/
29−bug-reports: http://github.com/haskell-servant/servant/issues
30−extra-source-files:
31− CHANGELOG.md
32− README.md
33−
34−source-repository head
35− type: git
36− location: http://github.com/haskell-servant/servant.git
37−
38−library
39− default-language: Haskell2010
40− hs-source-dirs: src
41− ghc-options: -Wall
42− exposed-modules:
43− Servant.Client.Internal.JSaddleXhrClient
44− Servant.Client.JSaddle
45−
46− -- Bundled with GHC: Lower bound to not force re-installs
47− -- text and mtl are bundled starting with GHC-8.4
48− build-depends:
49− base >=4.9 && <4.14
50− , bytestring >=0.10.8.1 && <0.11
51− , containers >=0.5.7.1 && <0.7
52− , mtl >=2.2.2 && <2.3
53− , text >=1.2.3.0 && <1.3
54− , transformers >=0.5.2.0 && <0.6
55−
56− if impl(ghcjs -any)
57− build-depends: ghcjs-base
58−
59− -- Servant dependencies.
60− -- Strict dependency on `servant-client-core` as we re-export things.
61− build-depends: servant-client-core >=0.16 && <0.16.1
62− build-depends:
63− base-compat >=0.10.5 && <0.12
64− , case-insensitive >=1.2.0.0 && <1.3
65− , exceptions >=0.10.0 && <0.11
66− , ghcjs-dom >=0.9.4.0 && <0.10
67− , http-media >=0.7.1.3 && <0.9
68− , http-types >=0.12.2 && <0.13
69− , jsaddle >=0.9.6.0 && <0.10
70− , monad-control >=1.0.2.3 && <1.1
71− , semigroupoids >=5.3.1 && <5.4
72− , string-conversions >=0.3 && <0.5
73− , transformers-base >=0.4.4 && <0.5
74−
75− if impl(ghc >=8.0)
76− ghc-options: -Wno-redundant-constraints
77−
78−test-suite spec
79− type: exitcode-stdio-1.0
80− ghc-options: -Wall
81− default-language: Haskell2010
82− hs-source-dirs: test
83− main-is: Spec.hs
84−
85− if impl(ghcjs -any)
86− build-depends:
87− base
88− , servant-jsaddle
89−
90− else
91− other-modules: Servant.Client.JSaddleSpec
92−
93− -- Dependencies inherited from the library. No need to specify bounds.
94− build-depends:
95− base
96− , bytestring
97− , containers
98− , exceptions
99− , ghcjs-dom
100− , http-media
101− , http-types
102− , jsaddle
103− , mtl
104− , process
105− , semigroupoids
106− , servant
107− , servant-client-core
108− , servant-jsaddle
109− , servant-server
110− , string-conversions
111− , text
112− , wai
113− , wai-cors
114− , wai-extra
115− , warp
116− , websockets
117−
118− -- Additonal dependencies
119− build-depends:
120− aeson
121− , hspec
122− , jsaddle-warp
123− , QuickCheck
124−
125− build-tool-depends: hspec-discover:hspec-discover >=2.6.0 && <2.8
servant-jsaddle/src/Servant/Client/Internal/JSaddleXhrClient.hsdeleted−311
@@ -1,311 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE DeriveGeneric #-}
3−{-# LANGUAGE FlexibleContexts #-}
4−{-# LANGUAGE FlexibleInstances #-}
5−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6−{-# LANGUAGE MultiParamTypeClasses #-}
7−{-# LANGUAGE OverloadedStrings #-}
8−{-# LANGUAGE ScopedTypeVariables #-}
9−{-# LANGUAGE StandaloneDeriving #-}
10−{-# LANGUAGE TypeFamilies #-}
11−{-# LANGUAGE UndecidableInstances #-}
12−{-# LANGUAGE ViewPatterns #-}
13−{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
14−
15−module Servant.Client.Internal.JSaddleXhrClient where
16−
17−import Prelude ()
18−import Prelude.Compat
19−
20−import Control.Concurrent
21− (MVar, newEmptyMVar, takeMVar, tryPutMVar)
22−import Control.Exception
23− (Exception, toException)
24−import Control.Monad
25− (forM_, unless, void)
26−import Control.Monad.Catch
27− (MonadCatch, MonadThrow, catch)
28−import Control.Monad.Error.Class
29− (MonadError (..))
30−import Control.Monad.IO.Class
31− (MonadIO (..))
32−import Control.Monad.Reader
33− (MonadReader, ReaderT, asks, runReaderT)
34−import Control.Monad.Trans.Except
35− (ExceptT, runExceptT)
36−import Data.Bifunctor
37− (bimap, first, second)
38−import Data.ByteString.Builder
39− (toLazyByteString)
40−import qualified Data.ByteString.Char8 as BS
41−import qualified Data.ByteString.Lazy as BSL
42−import qualified Data.ByteString.Lazy as L
43−import Data.CaseInsensitive
44− (mk, original)
45−import Data.Char
46− (isSpace)
47−import Data.Foldable
48− (toList)
49−import Data.Functor.Alt
50− (Alt (..))
51−import Data.Proxy
52− (Proxy (..))
53−import qualified Data.Sequence as Seq
54−import Data.String.Conversions
55− (cs)
56−import qualified Data.Text.Encoding as T
57−import qualified Data.Text.Encoding.Error as T
58−import GHC.Generics
59−import qualified GHCJS.Buffer as Buffer
60−import qualified GHCJS.DOM
61−import qualified GHCJS.DOM.EventM as JSDOM
62−import qualified GHCJS.DOM.Location as Location
63−import GHCJS.DOM.Types
64− (DOM, DOMContext, askDOM, runDOM)
65−import qualified GHCJS.DOM.Types as JS
66−import qualified GHCJS.DOM.Window as Window
67−import qualified GHCJS.DOM.XMLHttpRequest as JS
68−import qualified JavaScript.TypedArray.ArrayBuffer as ArrayBuffer
69−import qualified Language.Javascript.JSaddle.Types as JSaddle
70−import Network.HTTP.Media
71− (renderHeader)
72−import Network.HTTP.Types
73− (ResponseHeaders, http11, mkStatus, renderQuery, statusCode)
74−import System.IO
75− (hPutStrLn, stderr)
76−
77−import Servant.Client.Core
78−
79−-- Note: assuming encoding UTF-8
80−
81−data ClientEnv
82− = ClientEnv
83− { baseUrl :: BaseUrl
84− -- | Modify the XMLHttpRequest at will, right before sending.
85− , fixUpXhr :: JS.XMLHttpRequest -> DOM ()
86− }
87−
88−data JSaddleConnectionError = JSaddleConnectionError
89− deriving (Eq, Show)
90−
91−instance Exception JSaddleConnectionError
92−
93−-- | Default 'ClientEnv'
94−mkClientEnv :: BaseUrl -> ClientEnv
95−mkClientEnv burl = ClientEnv burl (const (pure ()))
96−
97−instance Show ClientEnv where
98− showsPrec prec (ClientEnv burl _) =
99− showParen (prec >= 11)
100− ( showString "ClientEnv {"
101− . showString "baseUrl = "
102− . showsPrec 0 burl
103− . showString ", fixUpXhr = <function>"
104− . showString "}"
105− )
106−
107−client :: HasClient ClientM api => Proxy api -> Client ClientM api
108−client api = api `clientIn` (Proxy :: Proxy ClientM)
109−
110−newtype ClientM a = ClientM
111− { fromClientM :: ReaderT ClientEnv (ExceptT ClientError DOM) a }
112− deriving ( Functor, Applicative, Monad, MonadIO, Generic
113− , MonadReader ClientEnv, MonadError ClientError)
114−deriving instance MonadThrow DOM => MonadThrow ClientM
115−deriving instance MonadCatch DOM => MonadCatch ClientM
116−
117−-- | Try clients in order, last error is preserved.
118−instance Alt ClientM where
119− a <!> b = a `catchError` const b
120−
121−instance RunClient ClientM where
122− throwClientError = throwError
123− runRequest r = do
124− d <- ClientM askDOM
125− performRequest d r
126−
127−runClientM :: ClientM a -> ClientEnv -> DOM (Either ClientError a)
128−runClientM cm env = runExceptT $ flip runReaderT env $ fromClientM cm
129−
130−runClientM' :: ClientM a -> DOM (Either ClientError a)
131−runClientM' m = do
132− burl <- getDefaultBaseUrl
133− runClientM m (mkClientEnv burl)
134−
135−getDefaultBaseUrl :: DOM BaseUrl
136−getDefaultBaseUrl = do
137− win <- GHCJS.DOM.currentWindow >>= \mw -> case mw of
138− Just x -> pure x
139− Nothing -> fail "Can not determine default base url without window."
140− curLoc <- Window.getLocation win
141−
142− protocolStr <- Location.getProtocol curLoc
143− portStr <- Location.getPort curLoc
144− hostname <- Location.getHostname curLoc
145−
146− let protocol
147− | (protocolStr :: JS.JSString) == "https:"
148− = Https
149− | otherwise = Http
150−
151− port :: Int
152− port | null portStr = case protocol of
153− Http -> 80
154− Https -> 443
155− | otherwise = read portStr
156−
157− pure (BaseUrl protocol hostname port "")
158−
159−performRequest :: DOMContext -> Request -> ClientM Response
160−performRequest domc req = do
161− xhr <- JS.newXMLHttpRequest `runDOM` domc
162− burl <- asks baseUrl
163− fixUp <- asks fixUpXhr
164− performXhr xhr burl req fixUp `runDOM` domc
165− resp <- toResponse domc xhr
166−
167− let status = statusCode (responseStatusCode resp)
168− unless (status >= 200 && status < 300) $
169− throwError $ mkFailureResponse burl req resp
170−
171− pure resp
172−
173−
174−-- * performing requests
175−-- Performs the xhr and blocks until the response was received
176−performXhr :: JS.XMLHttpRequest -> BaseUrl -> Request -> (JS.XMLHttpRequest -> DOM ()) -> DOM ()
177−performXhr xhr burl request fixUp = do
178−
179− let username, password :: Maybe JS.JSString
180− username = Nothing; password = Nothing
181−
182− JS.open xhr (decodeUtf8Lenient $ requestMethod request) (toUrl burl request) True username password
183− setHeaders xhr request
184− fixUp xhr
185−
186− waiter <- liftIO $ newEmptyMVar
187−
188− cleanup <- JSDOM.on xhr JS.readyStateChange $ do
189− state <- JS.getReadyState xhr
190− case state of
191− -- onReadyStateChange's callback can fire state 4
192− -- (which means "request finished and response is ready")
193− -- multiple times. By using tryPutMVar, only the first time
194− -- state 4 is fired will cause an MVar to be put. Subsequent
195− -- fires are ignored.
196− 4 -> void $ liftIO $ tryPutMVar waiter ()
197− _ -> return ()
198−
199− sendXhr xhr (toBody request) `catch` handleXHRError waiter -- We handle any errors in `toResponse`.
200−
201− liftIO $ takeMVar waiter
202−
203− cleanup
204−
205− where
206−
207− handleXHRError :: MVar () -> JS.XHRError -> DOM ()
208− handleXHRError waiter e = do
209− liftIO $ hPutStrLn stderr $ "servant-client-jsaddle: exception in `sendXhr` (should get handled in response handling): " <> show e
210− void $ liftIO $ tryPutMVar waiter ()
211−
212−
213−toUrl :: BaseUrl -> Request -> JS.JSString
214−toUrl burl request =
215− let pathS = JS.toJSString $ decodeUtf8Lenient $ L.toStrict $ toLazyByteString $
216− requestPath request
217− queryS =
218− JS.toJSString $ decodeUtf8Lenient $
219− renderQuery True $
220− toList $
221− requestQueryString request
222− in JS.toJSString (showBaseUrl burl) <> pathS <> queryS :: JS.JSString
223−
224−setHeaders :: JS.XMLHttpRequest -> Request -> DOM ()
225−setHeaders xhr request = do
226− forM_ (toList $ requestAccept request) $ \mediaType -> -- FIXME review
227− JS.setRequestHeader
228− xhr
229− ("Accept" :: JS.JSString)
230− (decodeUtf8Lenient $ renderHeader mediaType)
231−
232− forM_ (requestBody request) $ \(_, mediaType) ->
233− JS.setRequestHeader
234− xhr
235− ("Content-Type" :: JS.JSString)
236− (decodeUtf8Lenient $ renderHeader mediaType)
237−
238− forM_ (toList $ requestHeaders request) $ \(key, value) ->
239− JS.setRequestHeader xhr (decodeUtf8Lenient $ original key) (decodeUtf8Lenient value)
240−
241−-- ArrayBufferView is a type that only exists in the spec and covers many concrete types.
242−castMutableArrayBufferToArrayBufferView :: ArrayBuffer.MutableArrayBuffer -> DOM JS.ArrayBufferView
243−castMutableArrayBufferToArrayBufferView x = JS.liftJSM $ do
244− JS.fromJSValUnchecked $ JS.pToJSVal x
245−
246−mkFailureResponse :: BaseUrl -> Request -> ResponseF BSL.ByteString -> ClientError
247−mkFailureResponse burl request =
248− FailureResponse (bimap (const ()) f request)
249− where
250− f b = (burl, BSL.toStrict $ toLazyByteString b)
251−
252−sendXhr :: JS.XMLHttpRequest -> Maybe L.ByteString -> DOM ()
253−sendXhr xhr Nothing = JS.send xhr
254−sendXhr xhr (Just body) = do
255− -- Reason for copy: hopefully offset will be 0 and length b == len
256− -- FIXME: use a typed array constructor that accepts offset and length and skip the copy
257− (b, _offset, _len) <- JSaddle.ghcjsPure $ Buffer.fromByteString $ BS.copy $ L.toStrict body
258− b' <- Buffer.thaw b
259− b'' <- JSaddle.ghcjsPure $ Buffer.getArrayBuffer b'
260− JS.sendArrayBuffer xhr =<< castMutableArrayBufferToArrayBufferView b''
261−
262−toBody :: Request -> Maybe L.ByteString
263−toBody request = case requestBody request of
264− Nothing -> Nothing
265− Just (RequestBodyLBS "", _) -> Nothing
266− Just (RequestBodyLBS x, _) -> Just x
267− Just (RequestBodyBS "", _) -> Nothing
268− Just (RequestBodyBS x, _) -> Just $ L.fromStrict x
269− Just (RequestBodySource _, _) -> error "RequestBodySource isn't supported"
270−
271−-- * inspecting the xhr response
272−
273−-- This function is only supposed to handle 'ConnectionError's. Other
274−-- 'ClientError's are created in Servant.Client.Req.
275−toResponse :: DOMContext -> JS.XMLHttpRequest -> ClientM Response
276−toResponse domc xhr = do
277− let inDom :: DOM a -> ClientM a
278− inDom = flip runDOM domc
279− status <- inDom $ JS.getStatus xhr
280− case status of
281− 0 -> throwError $ ConnectionError $ toException JSaddleConnectionError
282− _ -> inDom $ do
283− statusText <- BS.pack <$> JS.getStatusText xhr
284− headers <- parseHeaders <$> JS.getAllResponseHeaders xhr
285− responseText <- maybe "" (L.fromStrict . BS.pack) <$> JS.getResponseText xhr -- FIXME: Text/Binary? Performance? Test?
286− pure Response
287− { responseStatusCode = mkStatus (fromIntegral status) statusText
288− , responseBody = responseText
289− , responseHeaders = Seq.fromList headers
290− , responseHttpVersion = http11 -- this is made up
291− }
292−
293−parseHeaders :: String -> ResponseHeaders
294−parseHeaders s =
295− (first mk . first strip . second strip . parseHeader) <$>
296− splitOn "\r\n" (cs s)
297− where
298− parseHeader :: BS.ByteString -> (BS.ByteString, BS.ByteString)
299− parseHeader h = case BS.breakSubstring ":" (cs h) of
300− (key, BS.drop 1 -> value) -> (key, value)
301−
302− splitOn :: BS.ByteString -> BS.ByteString -> [BS.ByteString]
303− splitOn separator input = case BS.breakSubstring separator input of
304− (prefix, "") -> [prefix]
305− (prefix, rest) -> prefix : splitOn separator (BS.drop (BS.length separator) rest)
306−
307− strip :: BS.ByteString -> BS.ByteString
308− strip = BS.dropWhile isSpace . BS.reverse . BS.dropWhile isSpace . BS.reverse
309−
310−decodeUtf8Lenient :: BS.ByteString -> JS.JSString
311−decodeUtf8Lenient = JS.toJSString . T.decodeUtf8With T.lenientDecode
servant-jsaddle/src/Servant/Client/JSaddle.hsdeleted−20
@@ -1,20 +0,0 @@
1−-- | This module provides 'client' which can automatically generate
2−-- querying functions for each endpoint just from the type representing your
3−-- API.
4−module Servant.Client.JSaddle
5− (
6− client
7− , ClientM
8− , runClientM
9− , runClientM'
10−
11− -- * Configuration
12− , ClientEnv(..)
13− , mkClientEnv
14− , getDefaultBaseUrl
15−
16− , module Servant.Client.Core.Reexport
17− ) where
18−
19−import Servant.Client.Internal.JSaddleXhrClient
20−import Servant.Client.Core.Reexport
servant-jsaddle/test/Servant/Client/JSaddleSpec.hsdeleted−173
@@ -1,173 +0,0 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE DeriveAnyClass #-}
3−{-# LANGUAGE DeriveGeneric #-}
4−{-# LANGUAGE OverloadedStrings #-}
5−{-# LANGUAGE TypeApplications #-}
6−{-# LANGUAGE TypeOperators #-}
7−module Servant.Client.JSaddleSpec where
8−
9−import Control.Concurrent
10− (threadDelay)
11−import Control.Concurrent.MVar
12− (newEmptyMVar, putMVar, takeMVar)
13−import Control.Exception
14− (handle, throwIO)
15−import Control.Monad.Trans
16−import Data.Aeson
17−import Data.ByteString
18− (ByteString)
19−import qualified Data.ByteString as B
20−import Data.Proxy
21−import Data.String
22−import Data.Word
23−import GHC.Generics
24−import qualified GHCJS.DOM
25−import qualified GHCJS.DOM.Window as Window
26−import Language.Javascript.JSaddle.Monad
27− (JSM)
28−import qualified Language.Javascript.JSaddle.Monad as JSaddle
29−import qualified Language.Javascript.JSaddle.Run as Run
30−import qualified Language.Javascript.JSaddle.WebSockets as WS
31−import qualified Network.HTTP.Types as Http
32−import qualified Network.Wai as Wai
33−import Network.Wai.Handler.Warp as Warp
34−import Network.Wai.Middleware.AddHeaders
35−import Network.Wai.Middleware.Cors
36− (simpleCors)
37−import Network.WebSockets
38− (defaultConnectionOptions)
39−import qualified Network.WebSockets as WS
40−import Servant.API
41−import Servant.Client.JSaddle
42−import Servant.Server
43−import qualified System.Process as P
44−import Test.Hspec
45−
46−type TestApi = ReqBody '[OctetStream] ByteString :> Post '[JSON] TestResponse
47−testApi :: Proxy TestApi
48−testApi = Proxy
49−
50−data TestResponse = TestResponse { byteList :: [Word8] }
51− deriving (Generic, ToJSON, FromJSON, Show, Eq)
52−
53−testServer :: Server TestApi
54−testServer x = do
55− pure . TestResponse . B.unpack $ x
56−
57−testClient :: Client ClientM TestApi
58−testClient = client testApi
59−
60−-- WARNING: approximation!
61−jsaddleFinally :: JSM b -> JSM a -> JSM a
62−jsaddleFinally handler m = JSaddle.bracket (pure ()) (const handler) (const m)
63−-- jsaddleFinally handler m = JSaddle.catch (m <* handler) (\e -> handler >> throw (e :: SomeException))
64−
65−close :: JSM ()
66−close = do
67− mw <- GHCJS.DOM.currentWindow
68− case mw of
69− Just w -> do
70− liftIO $ putStrLn "Closing window..."
71− Window.close w
72− Nothing -> liftIO $ putStrLn "Can't close the window!"
73−
74−
75−
76−spec :: Spec
77−spec = do
78− describe "Servant.Client.JSaddle" $ do
79− it "Receive a properly encoded response" $ do
80− -- A mvar to tell promptly when we are done
81− done <- newEmptyMVar
82−
83− -- How this work:
84− --
85− -- 1. we start server warp, which serves simple API
86− -- 2. we start client warp, which serves jsaddle running the 'action'
87− -- 3. we run google-chrome-stable to open jsaddle page and to run the test
88−
89− let action :: Int -> JSM ()
90− action serverPort = do
91− liftIO $ threadDelay $ 500 * 1000
92− -- a mix of valid utf-8 and non-utf8 bytes
93− let bytes = [0x01, 0xff, 0x02, 0xfe, 0x03, 0xfd, 0x00, 0x64, 0xc3, 0xbb, 0x68, 0xc3]
94− response <- flip runClientM clientEnv $ testClient (B.pack bytes)
95− liftIO $ print response
96− liftIO $ response `shouldBe` Right (TestResponse bytes)
97−
98− -- we are done.
99− liftIO $ putMVar done ()
100− where
101− clientEnv = mkClientEnv BaseUrl
102− { baseUrlScheme = Http
103− , baseUrlHost = "localhost"
104− , baseUrlPort = fromIntegral serverPort
105− , baseUrlPath = "/"
106− }
107−
108− let serverApp :: IO Application
109− serverApp = pure $ logRequest $ addCors $ serve testApi testServer
110−
111− let handler :: WS.ConnectionException -> IO ()
112− handler WS.ConnectionClosed = return ()
113− handler e = throwIO e
114−
115− handle handler $ Warp.testWithApplication serverApp $ \serverPort -> do
116− threadDelay $ 500 * 1000
117−
118− let clientApp :: IO Application
119− clientApp = WS.jsaddleOr defaultConnectionOptions (action serverPort >> Run.syncPoint) WS.jsaddleApp
120−
121− Warp.testWithApplication (simpleCors <$> clientApp) $ \clientPort -> do
122− threadDelay $ 500 * 1000
123−
124− putStrLn $ "server http://localhost:" ++ show serverPort
125− putStrLn $ "client http://localhost:" ++ show clientPort
126− putStrLn $ "google-chrome-stable --headless --disable-gpu --screenshot http://localhost:" ++ show clientPort
127−
128−
129− -- Run headless chrome
130− -- https://docs.travis-ci.com/user/gui-and-headless-browsers/#using-the-chrome-addon-in-the-headless-mode
131− -- https://developers.google.com/web/updates/2017/04/headless-chrome
132− hdl <- P.spawnProcess "google-chrome-stable"
133− [ "--headless"
134− , "--disable-gpu"
135− , "--remote-debugging-port=9222" -- TODO: bind to random port
136− , "http://localhost:" ++ show clientPort
137− ]
138−
139− -- wait for test to run.
140− takeMVar done
141−
142− -- kill chrome
143− P.terminateProcess hdl
144−
145−-------------------------------------------------------------------------------
146−-- Logger middleware
147−-------------------------------------------------------------------------------
148−
149−logRequest :: Wai.Middleware
150−logRequest app request respond = do
151− putStrLn "Request"
152− print request
153− app request $ \response -> do
154− putStrLn "Response Headers"
155− mapM_ print (Wai.responseHeaders response)
156− respond response
157−
158−-------------------------------------------------------------------------------
159−-- OPTIONS
160−-------------------------------------------------------------------------------
161−
162−corsHeaders :: (IsString s1, IsString s2) => [(s1, s2)]
163−corsHeaders =
164− [ ("Access-Control-Allow-Origin", "*")
165− , ("Access-Control-Allow-Methods", "POST")
166− , ("Access-Control-Allow-Headers", "content-type")
167− ]
168−
169−addCors :: Wai.Middleware
170−addCors app request respond =
171− if Wai.requestMethod request == "OPTIONS"
172− then respond $ Wai.responseLBS Http.status200 corsHeaders ""
173− else addHeaders corsHeaders app request respond
servant-jsaddle/test/Spec.hsdeleted−8
@@ -1,8 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−#ifdef __GHCJS__
3−module Main (main) where
4−main :: IO ()
5−main = return ()
6−#else
7−{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
8−#endif
servant-machines/servant-machines.cabal+11−17
@@ -1,7 +1,6 @@
1−cabal-version: >=1.10
1+cabal-version: 2.2
22name: servant-machines
3−version: 0.15
4−x-revision: 1
3+version: 0.15.1
54
65synopsis: Servant Stream support for machines
76category: Servant, Web, Enumerator
@@ -11,34 +10,29 @@ description: Servant Stream support for machines.
1110
1211homepage: http://docs.servant.dev/
1312bug-reports: http://github.com/haskell-servant/servant/issues
14−license: BSD3
13+license: BSD-3-Clause
1514license-file: LICENSE
1615author: Servant Contributors
1716maintainer: haskell-servant-maintainers@googlegroups.com
1817copyright: 2018-2019 Servant Contributors
1918build-type: Simple
20−tested-with:
21− GHC ==8.0.2
22− || ==8.2.2
23− || ==8.4.4
24− || ==8.6.5
25− || ==8.8.1
19+tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2
2620
2721extra-source-files:
2822 CHANGELOG.md
2923
3024source-repository head
3125 type: git
32− location: http://github.com/haskell-servant/servant-machines.git
26+ location: http://github.com/haskell-servant/servant.git
3327
3428library
3529 exposed-modules: Servant.Machines
3630 build-depends:
3731 base >=4.9 && <5
38− , bytestring >=0.10.8.1 && <0.11
32+ , bytestring >=0.10.8.1 && <0.12
3933 , machines >=0.6.4 && <0.8
40− , mtl >=2.2.2 && <2.3
41− , servant >=0.15 && <0.17
34+ , mtl ^>=2.2.2 || ^>=2.3.1
35+ , servant >=0.15 && <0.20
4236 hs-source-dirs: src
4337 default-language: Haskell2010
4438 ghc-options: -Wall
@@ -57,9 +51,9 @@ test-suite example
5751 , servant
5852 , machines
5953 , servant-machines
60− , servant-server >=0.15 && <0.17
61− , servant-client >=0.15 && <0.17
54+ , servant-server >=0.15 && <0.20
55+ , servant-client >=0.15 && <0.20
6256 , wai >=3.2.1.2 && <3.3
63− , warp >=3.2.25 && <3.3
57+ , warp >=3.2.25 && <3.4
6458 , http-client
6559 default-language: Haskell2010
servant-pipes/CHANGELOG.md+11
@@ -1,3 +1,14 @@
1+0.15.3
2+------
3+
4+### Other changes
5+
6+- Support GHC-9.0.1.
7+- Bump `bytestring` dependency.
8+
9+0.15.2
10+------
11+
1120.15.1
213------
314
servant-pipes/example/Main.hs+1−1
@@ -64,7 +64,7 @@ server = fast :<|> slow :<|> readme :<|> proxy
6464
6565 readme = liftIO $ do
6666 putStrLn "/readme"
67− return $ P.withFile "README.md" ReadMode PBS.fromHandle
67+ return $ P.withFile "README.md" ReadMode $ \h -> PBS.fromHandle h
6868
6969 proxy c = liftIO $ do
7070 putStrLn "/proxy"
servant-pipes/servant-pipes.cabal+12−17
@@ -1,6 +1,6 @@
1−cabal-version: >=1.10
1+cabal-version: 2.2
22name: servant-pipes
3−version: 0.15.1
3+version: 0.15.3
44
55synopsis: Servant Stream support for pipes
66category: Servant, Web, Pipes
@@ -10,36 +10,31 @@ description: Servant Stream support for pipes.
1010
1111homepage: http://docs.servant.dev/
1212bug-reports: http://github.com/haskell-servant/servant/issues
13−license: BSD3
13+license: BSD-3-Clause
1414license-file: LICENSE
1515author: Servant Contributors
1616maintainer: haskell-servant-maintainers@googlegroups.com
1717copyright: 2018-2019 Servant Contributors
1818build-type: Simple
19−tested-with:
20− GHC ==8.0.2
21− || ==8.2.2
22− || ==8.4.4
23− || ==8.6.5
24− || ==8.8.1
19+tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2
2520
2621extra-source-files:
2722 CHANGELOG.md
2823
2924source-repository head
3025 type: git
31− location: http://github.com/haskell-servant/servant-pipes.git
26+ location: http://github.com/haskell-servant/servant.git
3227
3328library
3429 exposed-modules: Servant.Pipes
3530 build-depends:
3631 base >=4.9 && <5
37− , bytestring >=0.10.8.1 && <0.11
32+ , bytestring >=0.10.8.1 && <0.12
3833 , pipes >=4.3.9 && <4.4
3934 , pipes-safe >=2.3.1 && <2.4
40− , mtl >=2.2.2 && <2.3
35+ , mtl ^>=2.2.2 || ^>=2.3.1
4136 , monad-control >=1.0.2.3 && <1.1
42− , servant >=0.15 && <0.17
37+ , servant >=0.15 && <0.20
4338 hs-source-dirs: src
4439 default-language: Haskell2010
4540 ghc-options: -Wall
@@ -56,13 +51,13 @@ test-suite example
5651 , bytestring
5752 , http-media
5853 , servant
59− , pipes
54+ , pipes
6055 , pipes-safe
6156 , servant-pipes
6257 , pipes-bytestring >=2.1.6 && <2.2
63− , servant-server >=0.15 && <0.17
64− , servant-client >=0.15 && <0.17
58+ , servant-server >=0.15 && <0.20
59+ , servant-client >=0.15 && <0.20
6560 , wai >=3.2.1.2 && <3.3
66− , warp >=3.2.25 && <3.3
61+ , warp >=3.2.25 && <3.4
6762 , http-client
6863 default-language: Haskell2010
servant-server/CHANGELOG.md+117
@@ -1,6 +1,123 @@
11[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-server/CHANGELOG.md)
22[Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)
33
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+
34+0.18.3
35+------
36+
37+### Significant changes
38+
39+- Add response header support to UVerb (#1420)
40+
41+### Other changes
42+
43+- Support GHC-9.0.1.
44+- Bump `bytestring`, `hspec` and `base64-bytestring` dependencies.
45+
46+0.18.2
47+------
48+
49+### Significant changes
50+
51+- Support `Fragment` combinator.
52+
53+0.18.1
54+------
55+
56+### Significant changes
57+
58+- Union verbs
59+
60+### Other changes
61+
62+- Bump "tested-with" ghc versions
63+- Allow newer dependencies
64+
65+0.18
66+----
67+
68+### Significant changes
69+
70+- Support for ghc8.8 (#1318, #1326, #1327)
71+
72+- Configurable error messages for automatic errors thrown by servant,
73+ like "no route" or "could not parse json body" (#1312, #1326, #1327)
74+
75+
76+0.17
77+----
78+
79+### Significant changes
80+
81+- Add NoContentVerb [#1028](https://github.com/haskell-servant/servant/issues/1028) [#1219](https://github.com/haskell-servant/servant/pull/1219) [#1228](https://github.com/haskell-servant/servant/pull/1228)
82+
83+ The `NoContent` API endpoints should now use `NoContentVerb` combinator.
84+ The API type changes are usually of the kind
85+
86+ ```diff
87+ - :<|> PostNoContent '[JSON] NoContent
88+ + :<|> PostNoContent
89+ ```
90+
91+ i.e. one doesn't need to specify the content-type anymore. There is no content.
92+
93+- `Capture` can be `Lenient` [#1155](https://github.com/haskell-servant/servant/issues/1155) [#1156](https://github.com/haskell-servant/servant/pull/1156)
94+
95+ You can specify a lenient capture as
96+
97+ ```haskell
98+ :<|> "capture-lenient" :> Capture' '[Lenient] "foo" Int :> GET
99+ ```
100+
101+ which will make the capture always succeed. Handlers will be of the
102+ type `Either String CapturedType`, where `Left err` represents
103+ the possible parse failure.
104+
105+- *servant-server* use queryString to parse QueryParam, QueryParams and QueryFlag [#1249](https://github.com/haskell-servant/servant/pull/1249) [#1262](https://github.com/haskell-servant/servant/pull/1262)
106+
107+ Some APIs need query parameters rewriting, e.g. in order to support
108+ for multiple casing (camel, snake, etc) or something to that effect.
109+
110+ This could be easily achieved by using WAI Middleware and modifying
111+ request's `Query`. But QueryParam, QueryParams and QueryFlag use
112+ `rawQueryString`. By using `queryString` rather then `rawQueryString`
113+ we can enable such rewritings.
114+
115+- *servant* *servant-server* Make packages `build-type: Simple` [#1263](https://github.com/haskell-servant/servant/pull/1263)
116+
117+ We used `build-type: Custom`, but it's problematic e.g.
118+ for cross-compiling. The benefit is small, as the doctests
119+ can be run other ways too (though not so conveniently).
120+
41210.16.2
5122------
6123
servant-server/Setup.hs+1−32
@@ -1,33 +1,2 @@
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 ()
1+import Distribution.Simple
312main = defaultMain
32−
33−#endif
servant-server/example/README.md+1−1
@@ -1,2 +1,2 @@
11- `greet.hs` shows how to write a simple webservice, run it, query it with automatically-derived haskell functions and print the (generated) markdown documentation for the API.
2−- `greet.md` contains the aforementionned generated documentation.
2+- `greet.md` contains the aforementioned generated documentation.
servant-server/example/greet.hs+16−2
@@ -1,5 +1,6 @@
11{-# LANGUAGE DataKinds #-}
22{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE RecordWildCards #-}
34{-# LANGUAGE OverloadedStrings #-}
45{-# LANGUAGE PolyKinds #-}
56{-# LANGUAGE TypeFamilies #-}
@@ -16,6 +17,7 @@ import Network.Wai
1617import Network.Wai.Handler.Warp
1718
1819import Servant
20+import Servant.Server.Generic ()
1921
2022-- * Example
2123
@@ -38,6 +40,14 @@ type TestApi =
3840 -- DELETE /greet/:greetid
3941 :<|> "greet" :> Capture "greetid" Text :> Delete '[JSON] NoContent
4042
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+
4151testApi :: Proxy TestApi
4252testApi = Proxy
4353
@@ -48,9 +58,13 @@ testApi = Proxy
4858--
4959-- Each handler runs in the 'Handler' monad.
5060server :: 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
5266
53− where helloH name Nothing = helloH name (Just False)
67+ helloH name Nothing = helloH name (Just False)
5468 helloH name (Just False) = return . Greet $ "Hello, " <> name
5569 helloH name (Just True) = return . Greet . toUpper $ "Hello, " <> name
5670
servant-server/servant-server.cabal+32−50
@@ -1,6 +1,6 @@
1−cabal-version: >=1.10
1+cabal-version: 2.2
22name: servant-server
3−version: 0.16
3+version: 0.19.2
44
55synopsis: A family of combinators for defining webservices APIs and serving them
66category: Servant, Web
@@ -17,18 +17,13 @@ description:
1717
1818homepage: http://docs.servant.dev/
1919bug-reports: http://github.com/haskell-servant/servant/issues
20−license: BSD3
20+license: BSD-3-Clause
2121license-file: LICENSE
2222author: Servant Contributors
2323maintainer: haskell-servant-maintainers@googlegroups.com
2424copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors
25−build-type: Custom
26−tested-with:
27− GHC ==8.0.2
28− || ==8.2.2
29− || ==8.4.4
30− || ==8.6.5
31− || ==8.8.1
25+build-type: Simple
26+tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.4 || ==9.4.3
3227
3328extra-source-files:
3429 CHANGELOG.md
@@ -38,12 +33,6 @@ source-repository head
3833 type: git
3934 location: http://github.com/haskell-servant/servant.git
4035
41−custom-setup
42− setup-depends:
43− base >= 4 && <5,
44− Cabal,
45− cabal-doctest >= 1.0.6 && <1.1
46−
4736library
4837 exposed-modules:
4938 Servant
@@ -55,12 +44,14 @@ library
5544 Servant.Server.Internal.Context
5645 Servant.Server.Internal.Delayed
5746 Servant.Server.Internal.DelayedIO
47+ Servant.Server.Internal.ErrorFormatter
5848 Servant.Server.Internal.Handler
59− Servant.Server.Internal.Router
6049 Servant.Server.Internal.RouteResult
50+ Servant.Server.Internal.Router
6151 Servant.Server.Internal.RoutingApplication
6252 Servant.Server.Internal.ServerError
6353 Servant.Server.StaticFiles
54+ Servant.Server.UVerb
6455
6556 -- deprecated
6657 exposed-modules:
@@ -69,41 +60,44 @@ library
6960 -- Bundled with GHC: Lower bound to not force re-installs
7061 -- text and mtl are bundled starting with GHC-8.4
7162 build-depends:
72− base >= 4.9 && < 4.14
73− , bytestring >= 0.10.8.1 && < 0.11
63+ base >= 4.9 && < 4.18
64+ , bytestring >= 0.10.8.1 && < 0.12
65+ , constraints >= 0.2 && < 0.14
7466 , containers >= 0.5.7.1 && < 0.7
75− , mtl >= 2.2.2 && < 2.3
76− , text >= 1.2.3.0 && < 1.3
77− , transformers >= 0.5.2.0 && < 0.6
67+ , mtl ^>= 2.2.2 || ^>= 2.3.1
68+ , text >= 1.2.3.0 && < 2.1
69+ , transformers >= 0.5.2.0 && < 0.7
7870 , filepath >= 1.4.1.1 && < 1.5
7971
8072 -- Servant dependencies
8173 -- strict dependency as we re-export 'servant' things.
8274 build-depends:
83− servant >= 0.16 && < 0.17.1
84− , http-api-data >= 0.4.1 && < 0.4.2
75+ servant >= 0.19 && < 0.20
76+ , http-api-data >= 0.4.1 && < 0.5.1
8577
8678 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.
8779 -- Here can be exceptions if we really need features from the newer versions.
8880 build-depends:
89− base-compat >= 0.10.5 && < 0.12
90− , base64-bytestring >= 1.0.0.1 && < 1.1
81+ base-compat >= 0.10.5 && < 0.13
82+ , base64-bytestring >= 1.0.0.1 && < 1.3
9183 , exceptions >= 0.10.0 && < 0.11
9284 , http-media >= 0.7.1.3 && < 0.9
9385 , http-types >= 0.12.2 && < 0.13
9486 , network-uri >= 2.6.1.0 && < 2.8
9587 , monad-control >= 1.0.2.3 && < 1.1
9688 , network >= 2.8 && < 3.2
89+ , sop-core >= 0.4.0.0 && < 0.6
9790 , string-conversions >= 0.4.0.1 && < 0.5
98− , resourcet >= 1.2.2 && < 1.3
91+ , resourcet >= 1.2.2 && < 1.4
9992 , tagged >= 0.8.6 && < 0.9
10093 , transformers-base >= 0.4.5.2 && < 0.5
101− , wai >= 3.2.1.2 && < 3.3
94+ , wai >= 3.2.2.1 && < 3.3
10295 , wai-app-static >= 3.1.6.2 && < 3.2
10396 , word8 >= 0.1.3 && < 0.2
10497
10598 hs-source-dirs: src
10699 default-language: Haskell2010
100+
107101 ghc-options: -Wall -Wno-redundant-constraints
108102
109103executable greet
@@ -120,8 +114,8 @@ executable greet
120114 , text
121115
122116 build-depends:
123− aeson >= 1.4.1.0 && < 1.5
124− , warp >= 3.2.25 && < 3.3
117+ aeson >= 1.4.1.0 && < 3
118+ , warp >= 3.2.25 && < 3.4
125119
126120test-suite spec
127121 type: exitcode-stdio-1.0
@@ -154,35 +148,23 @@ test-suite spec
154148 , safe
155149 , servant
156150 , servant-server
151+ , sop-core
157152 , string-conversions
158153 , text
159154 , transformers
160155 , transformers-compat
161156 , wai
162157
163− -- Additonal dependencies
158+ -- Additional dependencies
164159 build-depends:
165− aeson >= 1.4.1.0 && < 1.5
160+ aeson >= 1.4.1.0 && < 3
166161 , directory >= 1.3.0.0 && < 1.4
167− , hspec >= 2.6.0 && < 2.8
168− , hspec-wai >= 0.9.0 && < 0.10
169− , QuickCheck >= 2.12.6.1 && < 2.14
162+ , hspec >= 2.6.0 && < 2.10
163+ , hspec-wai >= 0.10.1 && < 0.12
164+ , QuickCheck >= 2.12.6.1 && < 2.15
170165 , should-not-typecheck >= 2.1.0 && < 2.2
171166 , temporary >= 1.3 && < 1.4
172− , wai-extra >= 3.0.24.3 && < 3.1
167+ , wai-extra >= 3.0.24.3 && < 3.2
173168
174169 build-tool-depends:
175− hspec-discover:hspec-discover >= 2.6.0 && <2.8
176−
177−test-suite doctests
178− build-depends:
179− base
180− , servant-server
181− , doctest >= 0.16.0 && <0.17
182− type: exitcode-stdio-1.0
183− main-is: test/doctests.hs
184− buildable: True
185− default-language: Haskell2010
186− ghc-options: -Wall -threaded
187− if impl(ghc >= 8.2)
188− x-doctest-options: -fdiagnostics-color=never
170+ hspec-discover:hspec-discover >= 2.6.0 && <2.10
servant-server/src/Servant/Server.hs+63−10
@@ -1,8 +1,10 @@
1−{-# LANGUAGE ConstraintKinds #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE FlexibleContexts #-}
4−{-# LANGUAGE RankNTypes #-}
5−{-# LANGUAGE TypeFamilies #-}
1+{-# LANGUAGE ConstraintKinds #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE RankNTypes #-}
5+{-# LANGUAGE ScopedTypeVariables #-}
6+{-# LANGUAGE TypeFamilies #-}
7+{-# LANGUAGE TypeOperators #-}
68
79-- | This module lets you implement 'Server's for defined APIs. You'll
810-- most likely just need 'serve'.
@@ -10,6 +12,8 @@ module Servant.Server
1012 ( -- * Run a wai application from an API
1113 serve
1214 , serveWithContext
15+ , serveWithContextT
16+ , ServerContext
1317
1418 , -- * Construct a wai Application from an API
1519 toApplication
@@ -35,6 +39,8 @@ module Servant.Server
3539 -- * Context
3640 , Context(..)
3741 , HasContextEntry(getContextEntry)
42+ , type (.++)
43+ , (.++)
3844 -- ** NamedContext
3945 , NamedContext(..)
4046 , descendIntoNamedContext
@@ -86,9 +92,28 @@ module Servant.Server
8692 , err504
8793 , err505
8894
95+ -- * Formatting of errors from combinators
96+ --
97+ -- | You can configure how Servant will render errors that occur while parsing the request.
98+
99+ , ErrorFormatter
100+ , NotFoundErrorFormatter
101+ , ErrorFormatters
102+
103+ , bodyParserErrorFormatter
104+ , urlParseErrorFormatter
105+ , headerParseErrorFormatter
106+ , notFoundErrorFormatter
107+
108+ , DefaultErrorFormatters
109+ , defaultErrorFormatters
110+
111+ , getAcceptHeader
112+
89113 -- * Re-exports
90114 , Application
91115 , Tagged (..)
116+ , module Servant.Server.UVerb
92117
93118 ) where
94119
@@ -101,10 +126,20 @@ import Data.Text
101126import Network.Wai
102127 (Application)
103128import Servant.Server.Internal
129+import Servant.Server.UVerb
104130
105131
106132-- * Implementing Servers
107133
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+
108143-- | 'serve' allows you to implement an API and produce a wai 'Application'.
109144--
110145-- Example:
@@ -129,10 +164,27 @@ import Servant.Server.Internal
129164serve :: (HasServer api '[]) => Proxy api -> Server api -> Application
130165serve p = serveWithContext p EmptyContext
131166
132−serveWithContext :: (HasServer api context)
167+-- | Like 'serve', but allows you to pass custom context.
168+--
169+-- 'defaultErrorFormatters' will always be appended to the end of the passed context,
170+-- but if you pass your own formatter, it will override the default one.
171+serveWithContext :: ( HasServer api context
172+ , ServerContext context
173+ )
133174 => Proxy api -> Context context -> Server api -> Application
134−serveWithContext p context server =
135− toApplication (runRouter (route p context (emptyDelayed (Route 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 =
184+ toApplication (runRouter format404 (route p context (emptyDelayed router)))
185+ where
186+ router = Route $ hoistServerWithContext p (Proxy :: Proxy context) toHandler server
187+ format404 = notFoundErrorFormatter . getContextEntry . mkContextWithErrorFormatter $ context
136188
137189-- | Hoist server implementation.
138190--
@@ -183,7 +235,7 @@ hoistServer p = hoistServerWithContext p (Proxy :: Proxy '[])
183235-- > │ └─ e/
184236-- > │ └─•
185237-- > ├─ b/
186−-- > │ └─ <capture>/
238+-- > │ └─ <x::Int>/
187239-- > │ ├─•
188240-- > │ ┆
189241-- > │ └─•
@@ -200,7 +252,8 @@ hoistServer p = hoistServerWithContext p (Proxy :: Proxy '[])
200252--
201253-- [@─•@] Leaves reflect endpoints.
202254--
203−-- [@\<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@.
204257--
205258-- [@\<raw\>@] This is a part of the API we do not know anything about.
206259--
servant-server/src/Servant/Server/Experimental/Auth.hs+2−1
@@ -1,5 +1,6 @@
11{-# OPTIONS_GHC -fno-warn-orphans #-}
22{-# LANGUAGE DeriveDataTypeable #-}
3+{-# LANGUAGE DeriveFunctor #-}
34{-# LANGUAGE DeriveGeneric #-}
45{-# LANGUAGE FlexibleContexts #-}
56{-# LANGUAGE FlexibleInstances #-}
@@ -44,7 +45,7 @@ type family AuthServerData a :: *
4445-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE
4546newtype AuthHandler r usr = AuthHandler
4647 { unAuthHandler :: r -> Handler usr }
47− deriving (Generic, Typeable)
48+ deriving (Functor, Generic, Typeable)
4849
4950-- | NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE
5051mkAuthHandler :: (r -> Handler usr) -> AuthHandler r usr
servant-server/src/Servant/Server/Generic.hs+18−20
@@ -1,12 +1,10 @@
1−{-# LANGUAGE ConstraintKinds #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE FlexibleContexts #-}
4−{-# LANGUAGE KindSignatures #-}
5−{-# LANGUAGE RankNTypes #-}
6−{-# LANGUAGE ScopedTypeVariables #-}
7−{-# LANGUAGE TypeFamilies #-}
8−{-# LANGUAGE TypeOperators #-}
9−{-# LANGUAGE UndecidableInstances #-}
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE RankNTypes #-}
4+{-# LANGUAGE ScopedTypeVariables #-}
5+{-# LANGUAGE TypeFamilies #-}
6+{-# LANGUAGE TypeOperators #-}
7+
108-- | @since 0.14.1
119module Servant.Server.Generic (
1210 AsServerT,
@@ -15,23 +13,17 @@ module Servant.Server.Generic (
1513 genericServeT,
1614 genericServeTWithContext,
1715 genericServer,
18− genericServerT,
16+ genericServerT
1917 ) where
2018
2119import Data.Proxy
2220 (Proxy (..))
2321
24−import Servant.API.Generic
2522import Servant.Server
23+import Servant.API.Generic
24+import Servant.Server.Internal
2625
27−-- | A type that specifies that an API record contains a server implementation.
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−
34−-- | Transform record of routes into a WAI 'Application'.
26+-- | Transform a record of routes into a WAI 'Application'.
3527genericServe
3628 :: forall routes.
3729 ( HasServer (ToServantApi routes) '[]
@@ -67,6 +59,7 @@ genericServeTWithContext
6759 ( GenericServant routes (AsServerT m)
6860 , GenericServant routes AsApi
6961 , HasServer (ToServantApi routes) ctx
62+ , HasContextEntry (ctx .++ DefaultErrorFormatters) ErrorFormatters
7063 , ServerT (ToServantApi routes) m ~ ToServant routes (AsServerT m)
7164 )
7265 => (forall a. m a -> Handler a) -- ^ 'hoistServer' argument to come back to 'Handler'
@@ -80,15 +73,20 @@ genericServeTWithContext f server ctx =
8073 p = genericApi (Proxy :: Proxy routes)
8174 pctx = Proxy :: Proxy ctx
8275
83−-- | Transform record of endpoints into a 'Server'.
76+-- | Transform a record of endpoints into a 'Server'.
8477genericServer
8578 :: GenericServant routes AsServer
8679 => routes AsServer
8780 -> ToServant routes AsServer
8881genericServer = toServant
8982
83+-- | Transform a record of endpoints into a @'ServerT' m@.
84+--
85+-- You can see an example usage of this function
86+-- <https://docs.servant.dev/en/stable/cookbook/generic/Generic.html#using-generics-together-with-a-custom-monad in the Servant Cookbook>.
9087genericServerT
9188 :: GenericServant routes (AsServerT m)
9289 => routes (AsServerT m)
9390 -> ToServant routes (AsServerT m)
9491genericServerT = toServant
92+
servant-server/src/Servant/Server/Internal.hs+297−110
@@ -1,29 +1,31 @@
1−{-# LANGUAGE CPP #-}
1+{-# LANGUAGE AllowAmbiguousTypes #-}
22{-# LANGUAGE ConstraintKinds #-}
3+{-# LANGUAGE CPP #-}
34{-# LANGUAGE DataKinds #-}
45{-# LANGUAGE DeriveDataTypeable #-}
56{-# LANGUAGE FlexibleContexts #-}
67{-# LANGUAGE FlexibleInstances #-}
8+{-# LANGUAGE InstanceSigs #-}
9+{-# LANGUAGE LambdaCase #-}
710{-# LANGUAGE MultiParamTypeClasses #-}
811{-# LANGUAGE OverloadedStrings #-}
912{-# LANGUAGE PolyKinds #-}
13+{-# LANGUAGE QuantifiedConstraints #-}
1014{-# LANGUAGE RankNTypes #-}
1115{-# LANGUAGE ScopedTypeVariables #-}
1216{-# LANGUAGE TupleSections #-}
17+{-# LANGUAGE TypeApplications #-}
1318{-# LANGUAGE TypeFamilies #-}
1419{-# LANGUAGE TypeOperators #-}
1520{-# LANGUAGE UndecidableInstances #-}
1621
17−#if MIN_VERSION_base(4,9,0) && __GLASGOW_HASKELL__ >= 802
18−#define HAS_TYPE_ERROR
19−#endif
20−
2122module Servant.Server.Internal
2223 ( module Servant.Server.Internal
2324 , module Servant.Server.Internal.BasicAuth
2425 , module Servant.Server.Internal.Context
2526 , module Servant.Server.Internal.Delayed
2627 , module Servant.Server.Internal.DelayedIO
28+ , module Servant.Server.Internal.ErrorFormatter
2729 , module Servant.Server.Internal.Handler
2830 , module Servant.Server.Internal.Router
2931 , module Servant.Server.Internal.RouteResult
@@ -34,19 +36,19 @@ module Servant.Server.Internal
3436import Control.Monad
3537 (join, when)
3638import Control.Monad.Trans
37− (liftIO)
39+ (liftIO, lift)
3840import Control.Monad.Trans.Resource
39− (runResourceT)
41+ (runResourceT, ReleaseKey)
42+import Data.Acquire
4043import qualified Data.ByteString as B
4144import qualified Data.ByteString.Builder as BB
4245import qualified Data.ByteString.Char8 as BC8
4346import qualified Data.ByteString.Lazy as BL
47+import Data.Constraint (Constraint, Dict(..))
4448import Data.Either
4549 (partitionEithers)
4650import Data.Maybe
4751 (fromMaybe, isNothing, mapMaybe, maybeToList)
48−import Data.Semigroup
49− ((<>))
5052import Data.String
5153 (IsString (..))
5254import Data.String.Conversions
@@ -55,58 +57,70 @@ import Data.Tagged
5557 (Tagged (..), retag, untag)
5658import qualified Data.Text as T
5759import Data.Typeable
60+import GHC.Generics
5861import GHC.TypeLits
59− (KnownNat, KnownSymbol, natVal, symbolVal)
62+ (KnownNat, KnownSymbol, TypeError, symbolVal)
6063import qualified Network.HTTP.Media as NHM
6164import Network.HTTP.Types hiding
6265 (Header, ResponseHeaders)
6366import Network.Socket
6467 (SockAddr)
6568import Network.Wai
66− (Application, Request, httpVersion, isSecure, lazyRequestBody,
67− rawQueryString, remoteHost, requestBody, requestHeaders,
69+ (Application, Request, Response, ResponseReceived, httpVersion, isSecure, lazyRequestBody,
70+ queryString, remoteHost, getRequestBodyChunk, requestHeaders,
6871 requestMethod, responseLBS, responseStream, vault)
6972import Prelude ()
7073import Prelude.Compat
7174import Servant.API
7275 ((:<|>) (..), (:>), Accept (..), BasicAuth, Capture',
73− CaptureAll, Description, EmptyAPI, FramingRender (..),
74− FramingUnrender (..), FromSourceIO (..), Header', If,
75− IsSecure (..), QueryFlag, QueryParam', QueryParams, Raw,
76− ReflectMethod (reflectMethod), RemoteHost, ReqBody',
77− SBool (..), SBoolI (..), SourceIO, Stream, StreamBody',
78− Summary, ToSourceIO (..), Vault, Verb, NoContentVerb,
79− WithNamedContext)
76+ CaptureAll, Description, EmptyAPI, Fragment,
77+ FramingRender (..), FramingUnrender (..), FromSourceIO (..),
78+ Header', If, IsSecure (..), NoContentVerb, QueryFlag,
79+ QueryParam', QueryParams, Raw, RawM, ReflectMethod (reflectMethod),
80+ RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO,
81+ Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb,
82+ WithNamedContext, WithResource, NamedRoutes)
83+import Servant.API.Generic (GenericMode(..), ToServant, ToServantApi, GServantProduct, toServant, fromServant)
8084import Servant.API.ContentTypes
8185 (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),
82− AllMime, MimeRender (..), MimeUnrender (..), canHandleAcceptH,
83− NoContent (NoContent))
86+ AllMime, MimeRender (..), MimeUnrender (..), NoContent,
87+ canHandleAcceptH)
8488import Servant.API.Modifiers
8589 (FoldLenient, FoldRequired, RequestArgument,
8690 unfoldRequestArgument)
8791import Servant.API.ResponseHeaders
8892 (GetHeaders, Headers, getHeaders, getResponse)
93+import Servant.API.Status
94+ (statusFromNat)
8995import qualified Servant.Types.SourceT as S
96+import Servant.API.TypeErrors
9097import Web.HttpApiData
91− (FromHttpApiData, parseHeader, parseQueryParam,
92− parseUrlPieceMaybe, parseUrlPieces, parseUrlPiece)
98+ (FromHttpApiData, parseHeader, parseQueryParam, parseUrlPiece,
99+ parseUrlPieces)
100+import Data.Kind
101+ (Type)
93102
94103import Servant.Server.Internal.BasicAuth
95104import Servant.Server.Internal.Context
96105import Servant.Server.Internal.Delayed
97106import Servant.Server.Internal.DelayedIO
107+import Servant.Server.Internal.ErrorFormatter
98108import Servant.Server.Internal.Handler
99109import Servant.Server.Internal.Router
100110import Servant.Server.Internal.RouteResult
101111import Servant.Server.Internal.RoutingApplication
102112import Servant.Server.Internal.ServerError
103113
104−#ifdef HAS_TYPE_ERROR
105114import GHC.TypeLits
106115 (ErrorMessage (..), TypeError)
107−#endif
116+import Servant.API.TypeLevel
117+ (AtLeastOneFragment, FragmentUnique)
108118
109119class 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.
110124 type ServerT api (m :: * -> *) :: *
111125
112126 route ::
@@ -168,7 +182,10 @@ instance (HasServer a context, HasServer b context) => HasServer (a :<|> b) cont
168182-- > server = getBook
169183-- > where getBook :: Text -> Handler Book
170184-- > getBook isbn = ...
171−instance (KnownSymbol capture, FromHttpApiData a, HasServer api context, SBoolI (FoldLenient mods))
185+instance (KnownSymbol capture, FromHttpApiData a, Typeable a
186+ , HasServer api context, SBoolI (FoldLenient mods)
187+ , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
188+ )
172189 => HasServer (Capture' mods capture a :> api) context where
173190
174191 type ServerT (Capture' mods capture a :> api) m =
@@ -177,15 +194,19 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer api context, SBoolI
177194 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
178195
179196 route Proxy context d =
180− CaptureRouter $
197+ CaptureRouter [hint] $
181198 route (Proxy :: Proxy api)
182199 context
183− (addCapture d $ \ txt -> case ( sbool :: SBool (FoldLenient mods)
184− , parseUrlPiece txt :: Either T.Text a) of
185− (SFalse, Left e) -> delayedFail err400 { errBody = cs e }
186− (SFalse, Right v) -> return v
187− (STrue, piece) -> return $ (either (Left . cs) Right) piece
188− )
200+ (addCapture d $ \ txt -> withRequest $ \ request ->
201+ case ( sbool :: SBool (FoldLenient mods)
202+ , parseUrlPiece txt :: Either T.Text a) of
203+ (SFalse, Left e) -> delayedFail $ formatError rep request $ cs e
204+ (SFalse, Right v) -> return v
205+ (STrue, piece) -> return $ (either (Left . cs) Right) piece)
206+ where
207+ rep = typeRep (Proxy :: Proxy Capture')
208+ formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
209+ hint = CaptureHint (T.pack $ symbolVal $ Proxy @capture) (typeRep (Proxy :: Proxy a))
189210
190211-- | If you use 'CaptureAll' in one of the endpoints for your API,
191212-- this automatically requires your server-side handler to be a
@@ -204,7 +225,10 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer api context, SBoolI
204225-- > server = getSourceFile
205226-- > where getSourceFile :: [Text] -> Handler Book
206227-- > getSourceFile pathSegments = ...
207−instance (KnownSymbol capture, FromHttpApiData a, HasServer api context)
228+instance (KnownSymbol capture, FromHttpApiData a, Typeable a
229+ , HasServer api context
230+ , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
231+ )
208232 => HasServer (CaptureAll capture a :> api) context where
209233
210234 type ServerT (CaptureAll capture a :> api) m =
@@ -213,13 +237,53 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer api context)
213237 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
214238
215239 route Proxy context d =
216− CaptureAllRouter $
240+ CaptureAllRouter [hint] $
217241 route (Proxy :: Proxy api)
218242 context
219− (addCapture d $ \ txts -> case parseUrlPieces txts of
220− Left _ -> delayedFail err400
221− Right v -> return v
243+ (addCapture d $ \ txts -> withRequest $ \ request ->
244+ case parseUrlPieces txts of
245+ Left e -> delayedFail $ formatError rep request $ cs e
246+ Right v -> return v
222247 )
248+ where
249+ rep = typeRep (Proxy :: Proxy CaptureAll)
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+
223287
224288
225289allowedMethodHead :: Method -> Request -> Bool
@@ -240,10 +304,10 @@ methodCheck method request
240304-- body check is no longer an option. However, we now run the accept
241305-- check before the body check and can therefore afford to make it
242306-- recoverable.
243−acceptCheck :: (AllMime list) => Proxy list -> B.ByteString -> DelayedIO ()
307+acceptCheck :: (AllMime list) => Proxy list -> AcceptHeader -> DelayedIO ()
244308acceptCheck proxy accH
245− | canHandleAcceptH proxy (AcceptHeader accH) = return ()
246− | otherwise = delayedFail err406
309+ | canHandleAcceptH proxy accH = return ()
310+ | otherwise = delayedFail err406
247311
248312methodRouter :: (AllCTRender ctypes a)
249313 => (b -> ([(HeaderName, B.ByteString)], a))
@@ -253,12 +317,12 @@ methodRouter :: (AllCTRender ctypes a)
253317methodRouter splitHeaders method proxy status action = leafRouter route'
254318 where
255319 route' env request respond =
256− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
320+ let accH = getAcceptHeader request
257321 in runAction (action `addMethodCheck` methodCheck method request
258322 `addAcceptCheck` acceptCheck proxy accH
259323 ) env request respond $ \ output -> do
260324 let (headers, b) = splitHeaders output
261− case handleAcceptH proxy (AcceptHeader accH) b of
325+ case handleAcceptH proxy accH b of
262326 Nothing -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does
263327 Just (contentT, body) ->
264328 let bdy = if allowedMethodHead method request then "" else body
@@ -272,7 +336,7 @@ noContentRouter method status action = leafRouter route'
272336 where
273337 route' env request respond =
274338 runAction (action `addMethodCheck` methodCheck method request)
275− env request respond $ \ output ->
339+ env request respond $ \ _output ->
276340 Route $ responseLBS status [] ""
277341
278342instance {-# OVERLAPPABLE #-}
@@ -284,7 +348,7 @@ instance {-# OVERLAPPABLE #-}
284348
285349 route Proxy _ = methodRouter ([],) method (Proxy :: Proxy ctypes) status
286350 where method = reflectMethod (Proxy :: Proxy method)
287− status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
351+ status = statusFromNat (Proxy :: Proxy status)
288352
289353instance {-# OVERLAPPING #-}
290354 ( AllCTRender ctypes a, ReflectMethod method, KnownNat status
@@ -296,7 +360,7 @@ instance {-# OVERLAPPING #-}
296360
297361 route Proxy _ = methodRouter (\x -> (getHeaders x, getResponse x)) method (Proxy :: Proxy ctypes) status
298362 where method = reflectMethod (Proxy :: Proxy method)
299− status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
363+ status = statusFromNat (Proxy :: Proxy status)
300364
301365instance (ReflectMethod method) =>
302366 HasServer (NoContentVerb method) context where
@@ -317,7 +381,7 @@ instance {-# OVERLAPPABLE #-}
317381
318382 route Proxy _ = streamRouter ([],) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)
319383 where method = reflectMethod (Proxy :: Proxy method)
320− status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
384+ status = statusFromNat (Proxy :: Proxy status)
321385
322386
323387instance {-# OVERLAPPING #-}
@@ -331,7 +395,7 @@ instance {-# OVERLAPPING #-}
331395
332396 route Proxy _ = streamRouter (\x -> (getHeaders x, getResponse x)) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)
333397 where method = reflectMethod (Proxy :: Proxy method)
334− status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
398+ status = statusFromNat (Proxy :: Proxy status)
335399
336400
337401streamRouter :: forall ctype a c chunk env framing. (MimeRender ctype chunk, FramingRender framing, ToSourceIO chunk a) =>
@@ -343,7 +407,7 @@ streamRouter :: forall ctype a c chunk env framing. (MimeRender ctype chunk, Fra
343407 -> Delayed env (Handler c)
344408 -> Router env
345409streamRouter splitHeaders method status framingproxy ctypeproxy action = leafRouter $ \env request respond ->
346− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
410+ let AcceptHeader accH = getAcceptHeader request
347411 cmediatype = NHM.matchAccept [contentType ctypeproxy] accH
348412 accCheck = when (isNothing cmediatype) $ delayedFail err406
349413 contentHeader = (hContentType, NHM.renderHeader . maybeToList $ cmediatype)
@@ -388,6 +452,7 @@ streamRouter splitHeaders method status framingproxy ctypeproxy action = leafRou
388452instance
389453 (KnownSymbol sym, FromHttpApiData a, HasServer api context
390454 , SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)
455+ , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
391456 )
392457 => HasServer (Header' mods sym a :> api) context where
393458------
@@ -399,6 +464,9 @@ instance
399464 route Proxy context subserver = route (Proxy :: Proxy api) context $
400465 subserver `addHeaderCheck` withRequest headerCheck
401466 where
467+ rep = typeRep (Proxy :: Proxy Header')
468+ formatError = headerParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
469+
402470 headerName :: IsString n => n
403471 headerName = fromString $ symbolVal (Proxy :: Proxy sym)
404472
@@ -409,15 +477,13 @@ instance
409477 mev :: Maybe (Either T.Text a)
410478 mev = fmap parseHeader $ lookup headerName (requestHeaders req)
411479
412− errReq = delayedFailFatal err400
413− { errBody = "Header " <> headerName <> " is required"
414− }
480+ errReq = delayedFailFatal $ formatError rep req
481+ $ "Header " <> headerName <> " is required"
415482
416− errSt e = delayedFailFatal err400
417− { errBody = cs $ "Error parsing header "
418− <> headerName
419− <> " failed: " <> e
420− }
483+ errSt e = delayedFailFatal $ formatError rep req
484+ $ cs $ "Error parsing header "
485+ <> headerName
486+ <> " failed: " <> e
421487
422488-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,
423489-- this automatically requires your server-side handler to be a function
@@ -443,6 +509,7 @@ instance
443509instance
444510 ( KnownSymbol sym, FromHttpApiData a, HasServer api context
445511 , SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)
512+ , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
446513 )
447514 => HasServer (QueryParam' mods sym a :> api) context where
448515------
@@ -452,9 +519,12 @@ instance
452519 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
453520
454521 route Proxy context subserver =
455− let querytext req = parseQueryText $ rawQueryString req
522+ let querytext = queryToQueryText . queryString
456523 paramname = cs $ symbolVal (Proxy :: Proxy sym)
457524
525+ rep = typeRep (Proxy :: Proxy QueryParam')
526+ formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
527+
458528 parseParam :: Request -> DelayedIO (RequestArgument mods a)
459529 parseParam req =
460530 unfoldRequestArgument (Proxy :: Proxy mods) errReq errSt mev
@@ -462,14 +532,12 @@ instance
462532 mev :: Maybe (Either T.Text a)
463533 mev = fmap parseQueryParam $ join $ lookup paramname $ querytext req
464534
465− errReq = delayedFailFatal err400
466− { errBody = cs $ "Query parameter " <> paramname <> " is required"
467− }
535+ errReq = delayedFailFatal $ formatError rep req
536+ $ cs $ "Query parameter " <> paramname <> " is required"
468537
469− errSt e = delayedFailFatal err400
470− { errBody = cs $ "Error parsing query parameter "
471− <> paramname <> " failed: " <> e
472− }
538+ errSt e = delayedFailFatal $ formatError rep req
539+ $ cs $ "Error parsing query parameter "
540+ <> paramname <> " failed: " <> e
473541
474542 delayed = addParameterCheck subserver . withRequest $ \req ->
475543 parseParam req
@@ -495,7 +563,8 @@ instance
495563-- > server = getBooksBy
496564-- > where getBooksBy :: [Text] -> Handler [Book]
497565-- > getBooksBy authors = ...return all books by these authors...
498−instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)
566+instance (KnownSymbol sym, FromHttpApiData a, HasServer api context
567+ , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters)
499568 => HasServer (QueryParams sym a :> api) context where
500569
501570 type ServerT (QueryParams sym a :> api) m =
@@ -506,21 +575,23 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)
506575 route Proxy context subserver = route (Proxy :: Proxy api) context $
507576 subserver `addParameterCheck` withRequest paramsCheck
508577 where
578+ rep = typeRep (Proxy :: Proxy QueryParams)
579+ formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
580+
509581 paramname = cs $ symbolVal (Proxy :: Proxy sym)
510582 paramsCheck req =
511583 case partitionEithers $ fmap parseQueryParam params of
512584 ([], parsed) -> return parsed
513− (errs, _) -> delayedFailFatal err400
514− { errBody = cs $ "Error parsing query parameter(s) "
515− <> paramname <> " failed: "
516− <> T.intercalate ", " errs
517− }
585+ (errs, _) -> delayedFailFatal $ formatError rep req
586+ $ cs $ "Error parsing query parameter(s) "
587+ <> paramname <> " failed: "
588+ <> T.intercalate ", " errs
518589 where
519590 params :: [T.Text]
520591 params = mapMaybe snd
521592 . filter (looksLikeParam . fst)
522− . parseQueryText
523− . rawQueryString
593+ . queryToQueryText
594+ . queryString
524595 $ req
525596
526597 looksLikeParam name = name == paramname || name == (paramname <> "[]")
@@ -546,7 +617,7 @@ instance (KnownSymbol sym, HasServer api context)
546617 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
547618
548619 route Proxy context subserver =
549− let querytext r = parseQueryText $ rawQueryString r
620+ let querytext = queryToQueryText . queryString
550621 param r = case lookup paramname (querytext r) of
551622 Just Nothing -> True -- param is there, with no value
552623 Just (Just v) -> examine v -- param with a value
@@ -582,13 +653,42 @@ instance HasServer Raw context where
582653 Fail a -> respond $ Fail a
583654 FailFatal e -> respond $ FailFatal e
584655
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+
585685-- | If you use 'ReqBody' in one of the endpoints for your API,
586686-- this automatically requires your server-side handler to be a function
587687-- that takes an argument of the type specified by 'ReqBody'.
588688-- The @Content-Type@ header is inspected, and the list provided is used to
589689-- attempt deserialization. If the request does not have a @Content-Type@
590690-- header, it is treated as @application/octet-stream@ (as specified in
591−-- <http://tools.ietf.org/html/rfc7231#section-3.1.1.5 RFC7231>.
691+-- [RFC 7231 section 3.1.1.5](http://tools.ietf.org/html/rfc7231#section-3.1.1.5)).
592692-- This lets servant worry about extracting it from the request and turning
593693-- it into a value of the type you specify.
594694--
@@ -604,6 +704,7 @@ instance HasServer Raw context where
604704-- > where postBook :: Book -> Handler Book
605705-- > postBook book = ...insert into your db...
606706instance ( AllCTUnrender list a, HasServer api context, SBoolI (FoldLenient mods)
707+ , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
607708 ) => HasServer (ReqBody' mods list a :> api) context where
608709
609710 type ServerT (ReqBody' mods list a :> api) m =
@@ -615,6 +716,9 @@ instance ( AllCTUnrender list a, HasServer api context, SBoolI (FoldLenient mods
615716 = route (Proxy :: Proxy api) context $
616717 addBodyCheck subserver ctCheck bodyCheck
617718 where
719+ rep = typeRep (Proxy :: Proxy ReqBody')
720+ formatError = bodyParserErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
721+
618722 -- Content-Type check, we only lookup we can try to parse the request body
619723 ctCheck = withRequest $ \ request -> do
620724 -- See HTTP RFC 2616, section 7.2.1
@@ -633,7 +737,7 @@ instance ( AllCTUnrender list a, HasServer api context, SBoolI (FoldLenient mods
633737 case sbool :: SBool (FoldLenient mods) of
634738 STrue -> return mrqbody
635739 SFalse -> case mrqbody of
636− Left e -> delayedFailFatal err400 { errBody = cs e }
740+ Left e -> delayedFailFatal $ formatError rep request e
637741 Right v -> return v
638742
639743instance
@@ -656,7 +760,7 @@ instance
656760 bodyCheck fromRS = withRequest $ \req -> do
657761 let mimeUnrender' = mimeUnrender (Proxy :: Proxy ctype) :: BL.ByteString -> Either String chunk
658762 let framingUnrender' = framingUnrender (Proxy :: Proxy framing) mimeUnrender' :: SourceIO B.ByteString -> SourceIO chunk
659− let body = requestBody req
763+ let body = getRequestBodyChunk req
660764 let rs = S.fromAction B.null body
661765 let rs' = fromRS $ framingUnrender' rs
662766 return rs'
@@ -725,12 +829,12 @@ data EmptyServer = EmptyServer deriving (Typeable, Eq, Show, Bounded, Enum)
725829emptyServer :: ServerT EmptyAPI m
726830emptyServer = Tagged EmptyServer
727831
728−-- | The server for an `EmptyAPI` is `emptyAPIServer`.
832+-- | The server for an `EmptyAPI` is `emptyServer`.
729833--
730834-- > type MyApi = "nothing" :> EmptyApi
731835-- >
732836-- > server :: Server MyApi
733−-- > server = emptyAPIServer
837+-- > server = emptyServer
734838instance HasServer EmptyAPI context where
735839 type ServerT EmptyAPI m = Tagged m EmptyServer
736840
@@ -759,7 +863,10 @@ instance ( KnownSymbol realm
759863-- * helpers
760864
761865ct_wildcard :: B.ByteString
762−ct_wildcard = "*" <> "/" <> "*" -- Because CPP
866+ct_wildcard = "*" <> "/" <> "*"
867+
868+getAcceptHeader :: Request -> AcceptHeader
869+getAcceptHeader = AcceptHeader . fromMaybe ct_wildcard . lookup hAccept . requestHeaders
763870
764871-- * General Authentication
765872
@@ -784,39 +891,19 @@ instance (HasContextEntry context (NamedContext name subContext), HasServer subA
784891 hoistServerWithContext _ _ nt s = hoistServerWithContext (Proxy :: Proxy subApi) (Proxy :: Proxy subContext) nt s
785892
786893-------------------------------------------------------------------------------
787−-- TypeError helpers
894+-- Custom type errors
788895-------------------------------------------------------------------------------
789896
790−#ifdef HAS_TYPE_ERROR
791−-- | This instance catches mistakes when there are non-saturated
792−-- type applications on LHS of ':>'.
793−--
794−-- >>> serve (Proxy :: Proxy (Capture "foo" :> Get '[JSON] Int)) (error "...")
795−-- ...
796−-- ...Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'.
797−-- ...Maybe you haven't applied enough arguments to
798−-- ...Capture' '[] "foo"
799−-- ...
800−--
801−-- >>> undefined :: Server (Capture "foo" :> Get '[JSON] Int)
802−-- ...
803−-- ...Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'.
804−-- ...Maybe you haven't applied enough arguments to
805−-- ...Capture' '[] "foo"
806−-- ...
807−--
808−instance TypeError (HasServerArrowKindError arr) => HasServer ((arr :: k -> l) :> api) context
897+-- Erroring instance for 'HasServer' when a combinator is not fully applied
898+instance TypeError (PartialApplication
899+#if __GLASGOW_HASKELL__ >= 904
900+ @(Type -> [Type] -> Constraint)
901+#endif
902+ HasServer arr) => HasServer ((arr :: a -> b) :> sub) context
809903 where
810− type ServerT (arr :> api) m = TypeError (HasServerArrowKindError arr)
811− -- it doens't really matter what sub route we peak
812− route _ _ _ = error "servant-server panic: impossible happened in HasServer (arr :> api)"
813− hoistServerWithContext _ _ _ = id
814−
815−-- Cannot have TypeError here, otherwise use of this symbol will error :)
816−type HasServerArrowKindError arr =
817− 'Text "Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'."
818− ':$$: 'Text "Maybe you haven't applied enough arguments to"
819− ':$$: 'ShowType arr
904+ type ServerT (arr :> sub) _ = TypeError (PartialApplication (HasServer :: * -> [*] -> Constraint) arr)
905+ route = error "unreachable"
906+ hoistServerWithContext _ _ _ _ = error "unreachable"
820907
821908-- | This instance prevents from accidentally using '->' instead of ':>'
822909--
@@ -850,7 +937,107 @@ type HasServerArrowTypeError a b =
850937 ':$$: 'ShowType a
851938 ':$$: 'Text "and"
852939 ':$$: '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)
853949#endif
950+ HasServer ty) => HasServer (ty :> sub) context
951+
952+instance {-# OVERLAPPABLE #-} TypeError (NoInstanceFor (HasServer api context)) => HasServer api context
953+
954+-- | Ignore @'Fragment'@ in server handlers.
955+-- See <https://ietf.org/rfc/rfc2616.html#section-15.1.3> for more details.
956+--
957+-- Example:
958+--
959+-- > type MyApi = "books" :> Fragment Text :> Get '[JSON] [Book]
960+-- >
961+-- > server :: Server MyApi
962+-- > server = getBooks
963+-- > where getBooks :: Handler [Book]
964+-- > getBooks = ...return all books...
965+instance (AtLeastOneFragment api, FragmentUnique (Fragment a1 :> api), HasServer api context)
966+ => HasServer (Fragment a1 :> api) context where
967+ type ServerT (Fragment a1 :> api) m = ServerT api m
968+
969+ route _ = route (Proxy :: Proxy api)
970+
971+ hoistServerWithContext _ = hoistServerWithContext (Proxy :: Proxy api)
854972
855973-- $setup
856974-- >>> 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+1−3
@@ -12,8 +12,6 @@ import Control.Monad.Trans
1212import qualified Data.ByteString as BS
1313import Data.ByteString.Base64
1414 (decodeLenient)
15−import Data.Monoid
16− ((<>))
1715import Data.Typeable
1816 (Typeable)
1917import Data.Word8
@@ -32,7 +30,7 @@ import Servant.Server.Internal.ServerError
3230-- * Basic Auth
3331
3432-- | servant-server's current implementation of basic authentication is not
35−-- immune to certian kinds of timing attacks. Decoding payloads does not take
33+-- immune to certain kinds of timing attacks. Decoding payloads does not take
3634-- a fixed amount of time.
3735
3836-- | The result of authentication/authorization
servant-server/src/Servant/Server/Internal/Context.hs+24−9
@@ -1,11 +1,12 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE FlexibleContexts #-}
3−{-# LANGUAGE FlexibleInstances #-}
4−{-# LANGUAGE GADTs #-}
5−{-# LANGUAGE KindSignatures #-}
6−{-# LANGUAGE MultiParamTypeClasses #-}
7−{-# LANGUAGE ScopedTypeVariables #-}
8−{-# LANGUAGE TypeOperators #-}
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE GADTs #-}
5+{-# LANGUAGE KindSignatures #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE ScopedTypeVariables #-}
8+{-# LANGUAGE TypeFamilies #-}
9+{-# LANGUAGE TypeOperators #-}
910
1011module Servant.Server.Internal.Context where
1112
@@ -20,7 +21,7 @@ import GHC.TypeLits
2021--
2122-- If you are using combinators that require a non-empty 'Context' you have to
2223-- use 'Servant.Server.serveWithContext' and pass it a 'Context' that contains all
23−-- the values your combinators need. A 'Context' is essentially a heterogenous
24+-- the values your combinators need. A 'Context' is essentially a heterogeneous
2425-- list and accessing the elements is being done by type (see 'getContextEntry').
2526-- The parameter of the type 'Context' is a type-level list reflecting the types
2627-- of the contained context entries. To create a 'Context' with entries, use the
@@ -45,6 +46,20 @@ instance Eq (Context '[]) where
4546instance (Eq a, Eq (Context as)) => Eq (Context (a ': as)) where
4647 x1 :. y1 == x2 :. y2 = x1 == x2 && y1 == y2
4748
49+-- | Append two type-level lists.
50+--
51+-- Hint: import it as
52+--
53+-- > import Servant.Server (type (.++))
54+type family (.++) (l1 :: [*]) (l2 :: [*]) where
55+ '[] .++ a = a
56+ (a ': as) .++ b = a ': (as .++ b)
57+
58+-- | Append two contexts.
59+(.++) :: Context l1 -> Context l2 -> Context (l1 .++ l2)
60+EmptyContext .++ a = a
61+(a :. as) .++ b = a :. (as .++ b)
62+
4863-- | This class is used to access context entries in 'Context's. 'getContextEntry'
4964-- returns the first value where the type matches:
5065--
servant-server/src/Servant/Server/Internal/Delayed.hs+1−1
@@ -268,5 +268,5 @@ runAction action env req respond k = runResourceT $
268268~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
269269
270270Due to GHC issue <https://ghc.haskell.org/trac/ghc/ticket/2595 2595>, we cannot
271−do the more succint thing - just update the records we actually change.
271+do the more succinct thing - just update the records we actually change.
272272-}
servant-server/src/Servant/Server/Internal/DelayedIO.hs+4−5
@@ -12,20 +12,19 @@ import Control.Monad.Reader
1212import Control.Monad.Trans
1313 (MonadIO (..), MonadTrans (..))
1414import Control.Monad.Trans.Control
15− (ComposeSt, MonadBaseControl (..), MonadTransControl (..),
16− defaultLiftBaseWith, defaultRestoreM)
15+ (MonadBaseControl (..))
1716import Control.Monad.Trans.Resource
1817 (MonadResource (..), ResourceT, runInternalState,
19− runResourceT, transResourceT, withInternalState)
18+ transResourceT, withInternalState)
2019import Network.Wai
21− (Application, Request, Response, ResponseReceived)
20+ (Request)
2221
2322import Servant.Server.Internal.RouteResult
2423import Servant.Server.Internal.ServerError
2524
2625-- | Computations used in a 'Delayed' can depend on the
2726-- incoming 'Request', may perform 'IO', and result in a
28−-- 'RouteResult', meaning they can either suceed, fail
27+-- 'RouteResult', meaning they can either succeed, fail
2928-- (with the possibility to recover), or fail fatally.
3029--
3130newtype DelayedIO a = DelayedIO { runDelayedIO' :: ReaderT Request (ResourceT (RouteResultT IO)) a }
servant-server/src/Servant/Server/Internal/ErrorFormatter.hsnew file+87
@@ -0,0 +1,87 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE PolyKinds #-}
3+{-# LANGUAGE RankNTypes #-}
4+{-# LANGUAGE TypeOperators #-}
5+
6+module Servant.Server.Internal.ErrorFormatter
7+ ( ErrorFormatters(..)
8+ , ErrorFormatter
9+ , NotFoundErrorFormatter
10+
11+ , DefaultErrorFormatters
12+ , defaultErrorFormatters
13+
14+ , MkContextWithErrorFormatter
15+ , mkContextWithErrorFormatter
16+ ) where
17+
18+import Data.String.Conversions
19+ (cs)
20+import Data.Typeable
21+import Network.Wai.Internal
22+ (Request)
23+
24+import Servant.API
25+ (Capture, ReqBody)
26+import Servant.Server.Internal.Context
27+import Servant.Server.Internal.ServerError
28+
29+-- | 'Context' that contains default error formatters.
30+type DefaultErrorFormatters = '[ErrorFormatters]
31+
32+-- | A collection of error formatters for different situations.
33+--
34+-- If you need to override one of them, use 'defaultErrorFormatters' with record update syntax.
35+data ErrorFormatters = ErrorFormatters
36+ { -- | Format error from parsing the request body.
37+ bodyParserErrorFormatter :: ErrorFormatter
38+ -- | Format error from parsing url parts or query parameters.
39+ , urlParseErrorFormatter :: ErrorFormatter
40+ -- | Format error from parsing request headers.
41+ , headerParseErrorFormatter :: ErrorFormatter
42+ -- | Format error for not found URLs.
43+ , notFoundErrorFormatter :: NotFoundErrorFormatter
44+ }
45+
46+-- | Default formatters will just return HTTP 400 status code with error
47+-- message as response body.
48+defaultErrorFormatters :: ErrorFormatters
49+defaultErrorFormatters = ErrorFormatters
50+ { bodyParserErrorFormatter = err400Formatter
51+ , urlParseErrorFormatter = err400Formatter
52+ , headerParseErrorFormatter = err400Formatter
53+ , notFoundErrorFormatter = const err404
54+ }
55+
56+-- | A custom formatter for errors produced by parsing combinators like
57+-- 'ReqBody' or 'Capture'.
58+--
59+-- A 'TypeRep' argument described the concrete combinator that raised
60+-- the error, allowing formatter to customize the message for different
61+-- combinators.
62+--
63+-- A full 'Request' is also passed so that the formatter can react to @Accept@ header,
64+-- for example.
65+type ErrorFormatter = TypeRep -> Request -> String -> ServerError
66+
67+-- | This formatter does not get neither 'TypeRep' nor error message.
68+type NotFoundErrorFormatter = Request -> ServerError
69+
70+type MkContextWithErrorFormatter (ctx :: [*]) = ctx .++ DefaultErrorFormatters
71+
72+mkContextWithErrorFormatter :: forall (ctx :: [*]). Context ctx -> Context (MkContextWithErrorFormatter ctx)
73+mkContextWithErrorFormatter ctx = ctx .++ (defaultErrorFormatters :. EmptyContext)
74+
75+-- Internal
76+
77+err400Formatter :: ErrorFormatter
78+err400Formatter _ _ e = err400 { errBody = cs e }
79+
80+-- These definitions suppress "unused import" warning.
81+-- The imorts are needed for Haddock to correctly link to them.
82+_RB :: Proxy ReqBody
83+_RB = Proxy
84+_C :: Proxy Capture
85+_C = Proxy
86+_CT :: Proxy Context
87+_CT = Proxy
servant-server/src/Servant/Server/Internal/Handler.hs+7−2
@@ -13,17 +13,19 @@ import Control.Monad.Base
1313import Control.Monad.Catch
1414 (MonadCatch, MonadMask, MonadThrow)
1515import Control.Monad.Error.Class
16− (MonadError)
16+ (MonadError, throwError)
1717import Control.Monad.IO.Class
1818 (MonadIO)
1919import Control.Monad.Trans.Control
2020 (MonadBaseControl (..))
2121import Control.Monad.Trans.Except
2222 (ExceptT, runExceptT)
23+import Data.String
24+ (fromString)
2325import GHC.Generics
2426 (Generic)
2527import Servant.Server.Internal.ServerError
26− (ServerError)
28+ (ServerError, errBody, err500)
2729
2830newtype Handler a = Handler { runHandler' :: ExceptT ServerError IO a }
2931 deriving
@@ -32,6 +34,9 @@ newtype Handler a = Handler { runHandler' :: ExceptT ServerError IO a }
3234 , MonadThrow, MonadCatch, MonadMask
3335 )
3436
37+instance MonadFail Handler where
38+ fail str = throwError err500 { errBody = fromString str }
39+
3540instance MonadBase IO Handler where
3641 liftBase = Handler . liftBase
3742
servant-server/src/Servant/Server/Internal/Router.hs+69−33
@@ -9,20 +9,40 @@ import Prelude.Compat
99
1010import Data.Function
1111 (on)
12+import Data.List
13+ (nub)
1214import Data.Map
1315 (Map)
1416import qualified Data.Map as M
1517import Data.Text
1618 (Text)
1719import qualified Data.Text as T
20+import Data.Typeable
21+ (TypeRep)
1822import Network.Wai
1923 (Response, pathInfo)
20−import Servant.Server.Internal.RoutingApplication
24+import Servant.Server.Internal.ErrorFormatter
2125import Servant.Server.Internal.RouteResult
26+import Servant.Server.Internal.RoutingApplication
2227import Servant.Server.Internal.ServerError
2328
2429type Router env = Router' env RoutingApplication
2530
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+
2646-- | Internal representation of a router.
2747--
2848-- The first argument describes an environment type that is
@@ -35,12 +55,23 @@ data Router' env a =
3555 -- ^ the map contains routers for subpaths (first path component used
3656 -- for lookup and removed afterwards), the list contains handlers
3757 -- for the empty path, to be tried in order
38− | CaptureRouter (Router' (Text, env) a)
58+ | CaptureRouter [CaptureHint] (Router' (Text, env) a)
3959 -- ^ first path component is passed to the child router in its
40− -- environment and removed afterwards
41− | CaptureAllRouter (Router' ([Text], env) a)
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.
69+ | CaptureAllRouter [CaptureHint] (Router' ([Text], env) a)
4270 -- ^ all path components are passed to the child router in its
4371 -- 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'.
4475 | RawRouter (env -> a)
4576 -- ^ to be used for routes we do not know anything about
4677 | Choice (Router' env a) (Router' env a)
@@ -68,8 +99,8 @@ leafRouter l = StaticRouter M.empty [l]
6899choice :: Router' env a -> Router' env a -> Router' env a
69100choice (StaticRouter table1 ls1) (StaticRouter table2 ls2) =
70101 StaticRouter (M.unionWith choice table1 table2) (ls1 ++ ls2)
71−choice (CaptureRouter router1) (CaptureRouter router2) =
72− CaptureRouter (choice router1 router2)
102+choice (CaptureRouter hints1 router1) (CaptureRouter hints2 router2) =
103+ CaptureRouter (nub $ hints1 ++ hints2) (choice router1 router2)
73104choice router1 (Choice router2 router3) = Choice (choice router1 router2) router3
74105choice router1 router2 = Choice router1 router2
75106
@@ -83,7 +114,11 @@ choice router1 router2 = Choice router1 router2
83114--
84115data RouterStructure =
85116 StaticRouterStructure (Map Text RouterStructure) Int
86− | 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.
87122 | RawRouterStructure
88123 | ChoiceStructure RouterStructure RouterStructure
89124 deriving (Eq, Show)
@@ -97,11 +132,11 @@ data RouterStructure =
97132routerStructure :: Router' env a -> RouterStructure
98133routerStructure (StaticRouter m ls) =
99134 StaticRouterStructure (fmap routerStructure m) (length ls)
100−routerStructure (CaptureRouter router) =
101− CaptureRouterStructure $
135+routerStructure (CaptureRouter hints router) =
136+ CaptureRouterStructure hints $
102137 routerStructure router
103−routerStructure (CaptureAllRouter router) =
104− CaptureRouterStructure $
138+routerStructure (CaptureAllRouter hints router) =
139+ CaptureRouterStructure hints $
105140 routerStructure router
106141routerStructure (RawRouter _) =
107142 RawRouterStructure
@@ -113,8 +148,8 @@ routerStructure (Choice r1 r2) =
113148-- | Compare the structure of two routers.
114149--
115150sameStructure :: Router' env a -> Router' env b -> Bool
116−sameStructure r1 r2 =
117− routerStructure r1 == routerStructure r2
151+sameStructure router1 router2 =
152+ routerStructure router1 == routerStructure router2
118153
119154-- | Provide a textual representation of the
120155-- structure of a router.
@@ -125,7 +160,8 @@ routerLayout router =
125160 where
126161 mkRouterLayout :: Bool -> RouterStructure -> [Text]
127162 mkRouterLayout c (StaticRouterStructure m n) = mkSubTrees c (M.toList m) n
128− mkRouterLayout c (CaptureRouterStructure r) = mkSubTree c "<capture>" (mkRouterLayout False r)
163+ mkRouterLayout c (CaptureRouterStructure hints r) =
164+ mkSubTree c (toCaptureTags hints) (mkRouterLayout False r)
129165 mkRouterLayout c RawRouterStructure =
130166 if c then ["├─ <raw>"] else ["└─ <raw>"]
131167 mkRouterLayout c (ChoiceStructure r1 r2) =
@@ -153,52 +189,52 @@ tweakResponse :: (RouteResult Response -> RouteResult Response) -> Router env ->
153189tweakResponse f = fmap (\a -> \req cont -> a req (cont . f))
154190
155191-- | Interpret a router as an application.
156−runRouter :: Router () -> RoutingApplication
157−runRouter r = runRouterEnv r ()
192+runRouter :: NotFoundErrorFormatter -> Router () -> RoutingApplication
193+runRouter fmt r = runRouterEnv fmt r ()
158194
159−runRouterEnv :: Router env -> env -> RoutingApplication
160−runRouterEnv router env request respond =
195+runRouterEnv :: NotFoundErrorFormatter -> Router env -> env -> RoutingApplication
196+runRouterEnv fmt router env request respond =
161197 case router of
162198 StaticRouter table ls ->
163199 case pathInfo request of
164− [] -> runChoice ls env request respond
200+ [] -> runChoice fmt ls env request respond
165201 -- This case is to handle trailing slashes.
166− [""] -> runChoice ls env request respond
202+ [""] -> runChoice fmt ls env request respond
167203 first : rest | Just router' <- M.lookup first table
168204 -> let request' = request { pathInfo = rest }
169− in runRouterEnv router' env request' respond
170− _ -> respond $ Fail err404
171− CaptureRouter router' ->
205+ in runRouterEnv fmt router' env request' respond
206+ _ -> respond $ Fail $ fmt request
207+ CaptureRouter _ router' ->
172208 case pathInfo request of
173− [] -> respond $ Fail err404
209+ [] -> respond $ Fail $ fmt request
174210 -- This case is to handle trailing slashes.
175− [""] -> respond $ Fail err404
211+ [""] -> respond $ Fail $ fmt request
176212 first : rest
177213 -> let request' = request { pathInfo = rest }
178− in runRouterEnv router' (first, env) request' respond
179− CaptureAllRouter router' ->
214+ in runRouterEnv fmt router' (first, env) request' respond
215+ CaptureAllRouter _ router' ->
180216 let segments = pathInfo request
181217 request' = request { pathInfo = [] }
182− in runRouterEnv router' (segments, env) request' respond
218+ in runRouterEnv fmt router' (segments, env) request' respond
183219 RawRouter app ->
184220 app env request respond
185221 Choice r1 r2 ->
186− runChoice [runRouterEnv r1, runRouterEnv r2] env request respond
222+ runChoice fmt [runRouterEnv fmt r1, runRouterEnv fmt r2] env request respond
187223
188224-- | Try a list of routing applications in order.
189225-- We stop as soon as one fails fatally or succeeds.
190226-- If all fail normally, we pick the "best" error.
191227--
192−runChoice :: [env -> RoutingApplication] -> env -> RoutingApplication
193−runChoice ls =
228+runChoice :: NotFoundErrorFormatter -> [env -> RoutingApplication] -> env -> RoutingApplication
229+runChoice fmt ls =
194230 case ls of
195− [] -> \ _ _ respond -> respond (Fail err404)
231+ [] -> \ _ request respond -> respond (Fail $ fmt request)
196232 [r] -> r
197233 (r : rs) ->
198234 \ env request respond ->
199235 r env request $ \ response1 ->
200236 case response1 of
201− Fail _ -> runChoice rs env request $ \ response2 ->
237+ Fail _ -> runChoice fmt rs env request $ \ response2 ->
202238 respond $ highestPri response1 response2
203239 _ -> respond response1
204240 where
servant-server/src/Servant/Server/Internal/ServerError.hs+1−1
@@ -187,7 +187,7 @@ err403 = ServerError { errHTTPCode = 403
187187-- Example:
188188--
189189-- > failingHandler :: Handler ()
190−-- > failingHandler = throwError $ err404 { errBody = "(╯°□°）╯︵ ┻━┻)." }
190+-- > failingHandler = throwError $ err404 { errBody = "Are you lost?" }
191191--
192192err404 :: ServerError
193193err404 = ServerError { errHTTPCode = 404
servant-server/src/Servant/Server/UVerb.hsnew file+116
@@ -0,0 +1,116 @@
1+{-# LANGUAGE ConstraintKinds #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE InstanceSigs #-}
6+{-# LANGUAGE KindSignatures #-}
7+{-# LANGUAGE MultiParamTypeClasses #-}
8+{-# LANGUAGE OverloadedStrings #-}
9+{-# LANGUAGE RankNTypes #-}
10+{-# LANGUAGE ScopedTypeVariables #-}
11+{-# LANGUAGE TypeApplications #-}
12+{-# LANGUAGE TypeFamilies #-}
13+{-# LANGUAGE TypeOperators #-}
14+{-# LANGUAGE UndecidableInstances #-}
15+
16+{-# OPTIONS_GHC -Wno-orphans #-}
17+{-# OPTIONS_GHC -Wno-redundant-constraints #-}
18+
19+module Servant.Server.UVerb
20+ ( respond,
21+ IsServerResource,
22+ )
23+where
24+
25+import qualified Data.ByteString as B
26+import Data.Proxy (Proxy (Proxy))
27+import Data.SOP (I (I))
28+import Data.SOP.Constraint (All, And)
29+import Data.String.Conversions (LBS, cs)
30+import Network.HTTP.Types (Status, HeaderName, hContentType)
31+import Network.Wai (responseLBS, Request)
32+import Servant.API (ReflectMethod, reflectMethod)
33+import Servant.API.ContentTypes (AllCTRender (handleAcceptH), AllMime)
34+import Servant.API.ResponseHeaders (GetHeaders (..), Headers (..))
35+import Servant.API.UVerb (HasStatus, IsMember, Statuses, UVerb, Union, Unique, WithStatus (..), foldMapUnion, inject, statusOf)
36+import Servant.Server.Internal (Context, Delayed, Handler, HasServer (..), RouteResult (FailFatal, Route), Router, Server, ServerT, acceptCheck, addAcceptCheck, addMethodCheck, allowedMethodHead, err406, getAcceptHeader, leafRouter, methodCheck, runAction)
37+
38+
39+-- | 'return' for 'UVerb' handlers. Takes a value of any of the members of the open union,
40+-- and will construct a union value in an 'Applicative' (eg. 'Server').
41+respond ::
42+ forall (x :: *) (xs :: [*]) (f :: * -> *).
43+ (Applicative f, HasStatus x, IsMember x xs) =>
44+ x ->
45+ f (Union xs)
46+respond = pure . inject . I
47+
48+class IsServerResource (cts :: [*]) a where
49+ resourceResponse :: Request -> Proxy cts -> a -> Maybe (LBS, LBS)
50+ resourceHeaders :: Proxy cts -> a -> [(HeaderName, B.ByteString)]
51+
52+instance {-# OVERLAPPABLE #-} AllCTRender cts a
53+ => IsServerResource cts a where
54+ resourceResponse request p res = handleAcceptH p (getAcceptHeader request) res
55+ resourceHeaders _ _ = []
56+
57+instance {-# OVERLAPPING #-} (IsServerResource cts a, GetHeaders (Headers h a))
58+ => IsServerResource cts (Headers h a) where
59+ resourceResponse request p res = resourceResponse request p (getResponse res)
60+ resourceHeaders cts res = getHeaders res ++ resourceHeaders cts (getResponse res)
61+
62+instance {-# OVERLAPPING #-} IsServerResource cts a
63+ => IsServerResource cts (WithStatus n a) where
64+ resourceResponse request p (WithStatus x) = resourceResponse request p x
65+ resourceHeaders cts (WithStatus x) = resourceHeaders cts x
66+
67+encodeResource :: forall a cts . (IsServerResource cts a, HasStatus a)
68+ => Request -> Proxy cts -> a
69+ -> (Status, Maybe (LBS, LBS), [(HeaderName, B.ByteString)])
70+encodeResource request cts res = (statusOf (Proxy @a),
71+ resourceResponse request cts res,
72+ resourceHeaders cts res)
73+
74+type IsServerResourceWithStatus cts = IsServerResource cts `And` HasStatus
75+
76+instance
77+ ( ReflectMethod method,
78+ AllMime contentTypes,
79+ All (IsServerResourceWithStatus contentTypes) as,
80+ Unique (Statuses as) -- for consistency with servant-swagger (server would work fine
81+ -- without; client is a bit of a corner case, because it dispatches
82+ -- the parser based on the status code. with this uniqueness
83+ -- constraint it won't have to run more than one parser in weird
84+ -- corner cases.
85+ ) =>
86+ HasServer (UVerb method contentTypes as) context
87+ where
88+ type ServerT (UVerb method contentTypes as) m = m (Union as)
89+
90+ hoistServerWithContext _ _ nt s = nt s
91+
92+ route ::
93+ forall env.
94+ Proxy (UVerb method contentTypes as) ->
95+ Context context ->
96+ Delayed env (Server (UVerb method contentTypes as)) ->
97+ Router env
98+ route _proxy _ctx action = leafRouter route'
99+ where
100+ method = reflectMethod (Proxy @method)
101+ route' env request cont = do
102+ let action' :: Delayed env (Handler (Union as))
103+ action' =
104+ action
105+ `addMethodCheck` methodCheck method request
106+ `addAcceptCheck` acceptCheck (Proxy @contentTypes) (getAcceptHeader request)
107+
108+ runAction action' env request cont $ \(output :: Union as) -> do
109+ let cts = Proxy @contentTypes
110+ pickResource :: Union as -> (Status, Maybe (LBS, LBS), [(HeaderName, B.ByteString)])
111+ pickResource = foldMapUnion (Proxy @(IsServerResourceWithStatus contentTypes)) (encodeResource request cts)
112+ case pickResource output of
113+ (_, Nothing, _) -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does
114+ (status, Just (contentT, body), headers) ->
115+ let bdy = if allowedMethodHead method request then "" else body
116+ in Route $ responseLBS status ((hContentType, cs contentT) : headers) bdy
servant-server/test/Servant/Server/ErrorSpec.hs+58−2
@@ -12,9 +12,9 @@ import Data.Aeson
1212 (encode)
1313import qualified Data.ByteString.Char8 as BC
1414import qualified Data.ByteString.Lazy.Char8 as BCL
15−import Data.Monoid
16− ((<>))
1715import Data.Proxy
16+import Data.String.Conversions
17+ (cs)
1818import Network.HTTP.Types
1919 (hAccept, hAuthorization, hContentType, methodGet, methodPost,
2020 methodPut)
@@ -31,6 +31,7 @@ spec = describe "HTTP Errors" $ do
3131 prioErrorsSpec
3232 errorRetrySpec
3333 errorChoiceSpec
34+ customFormattersSpec
3435
3536-- * Auth machinery (reused throughout)
3637
@@ -293,6 +294,61 @@ errorChoiceSpec = describe "Multiple handlers return errors"
293294 `shouldRespondWith` 415
294295
295296
297+-- }}}
298+------------------------------------------------------------------------------
299+-- * Custom errors {{{
300+
301+customFormatter :: ErrorFormatter
302+customFormatter _ _ err = err400 { errBody = "CUSTOM! " <> cs err }
303+
304+customFormatters :: ErrorFormatters
305+customFormatters = defaultErrorFormatters
306+ { bodyParserErrorFormatter = customFormatter
307+ , urlParseErrorFormatter = customFormatter
308+ , notFoundErrorFormatter = const $ err404 { errBody = "CUSTOM! Not Found" }
309+ }
310+
311+type CustomFormatterAPI
312+ = "query" :> QueryParam' '[Required, Strict] "param" Int :> Get '[PlainText] String
313+ :<|> "capture" :> Capture "cap" Bool :> Get '[PlainText] String
314+ :<|> "body" :> ReqBody '[JSON] Int :> Post '[PlainText] String
315+
316+customFormatterAPI :: Proxy CustomFormatterAPI
317+customFormatterAPI = Proxy
318+
319+customFormatterServer :: Server CustomFormatterAPI
320+customFormatterServer = (\_ -> return "query")
321+ :<|> (\_ -> return "capture")
322+ :<|> (\_ -> return "body")
323+
324+customFormattersSpec :: Spec
325+customFormattersSpec = describe "Custom errors from combinators"
326+ $ with (return $ serveWithContext customFormatterAPI (customFormatters :. EmptyContext) customFormatterServer) $ do
327+
328+ let startsWithCustom = ResponseMatcher
329+ { matchStatus = 400
330+ , matchHeaders = []
331+ , matchBody = MatchBody $ \_ body -> if "CUSTOM!" `BCL.isPrefixOf` body
332+ then Nothing
333+ else Just $ show body <> " does not start with \"CUSTOM!\""
334+ }
335+
336+ it "formats query parse error" $ do
337+ request methodGet "query?param=false" [] ""
338+ `shouldRespondWith` startsWithCustom
339+
340+ it "formats query parse error with missing param" $ do
341+ request methodGet "query" [] ""
342+ `shouldRespondWith` startsWithCustom
343+
344+ it "formats capture parse error" $ do
345+ request methodGet "capture/42" [] ""
346+ `shouldRespondWith` startsWithCustom
347+
348+ it "formats body parse error" $ do
349+ request methodPost "body" [(hContentType, "application/json")] "foo"
350+ `shouldRespondWith` startsWithCustom
351+
296352-- }}}
297353------------------------------------------------------------------------------
298354-- * Instances {{{
servant-server/test/Servant/Server/Internal/ContextSpec.hs+1−1
@@ -1,5 +1,5 @@
11{-# LANGUAGE DataKinds #-}
2−{-# OPTIONS_GHC -fdefer-type-errors -Wwarn #-}
2+{-# OPTIONS_GHC -fdefer-type-errors -Wwarn -Wno-deferred-type-errors #-}
33module Servant.Server.Internal.ContextSpec (spec) where
44
55import Data.Proxy
servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs+2−2
@@ -11,7 +11,7 @@ module Servant.Server.Internal.RoutingApplicationSpec (spec) where
1111import Prelude ()
1212import Prelude.Compat
1313
14−import Control.Exception hiding
14+import Control.Exception hiding
1515 (Handler)
1616import Control.Monad.IO.Class
1717import Control.Monad.Trans.Resource
@@ -28,7 +28,7 @@ import Test.Hspec
2828import Test.Hspec.Wai
2929 (request, shouldRespondWith, with)
3030
31−import qualified Data.Text as T
31+import qualified Data.Text as T
3232
3333import System.IO.Unsafe
3434 (unsafePerformIO)
servant-server/test/Servant/Server/RouterSpec.hs+129−8
@@ -9,7 +9,9 @@ import Control.Monad
99import Data.Proxy
1010 (Proxy (..))
1111import Data.Text
12− (unpack)
12+ (Text, unpack)
13+import Data.Typeable
14+ (typeRep)
1315import Network.HTTP.Types
1416 (Status (..))
1517import Network.Wai
@@ -27,12 +29,13 @@ spec :: Spec
2729spec = describe "Servant.Server.Internal.Router" $ do
2830 routerSpec
2931 distributivitySpec
32+ serverLayoutSpec
3033
3134routerSpec :: Spec
3235routerSpec = do
3336 describe "tweakResponse" $ do
3437 let app' :: Application
35− app' = toApplication $ runRouter router'
38+ app' = toApplication $ runRouter (const err404) router'
3639
3740 router', router :: Router ()
3841 router' = tweakResponse (fmap twk) router
@@ -48,10 +51,10 @@ routerSpec = do
4851
4952 describe "runRouter" $ do
5053 let toApp :: Router () -> Application
51− toApp = toApplication . runRouter
54+ toApp = toApplication . runRouter (const err404)
5255
5356 cap :: Router ()
54− cap = CaptureRouter $
57+ cap = CaptureRouter [hint] $
5558 let delayed = addCapture (emptyDelayed $ Route pure) (const $ delayedFail err400)
5659 in leafRouter
5760 $ \env req res ->
@@ -59,6 +62,9 @@ routerSpec = do
5962 . const
6063 $ Route success
6164
65+ hint :: CaptureHint
66+ hint = CaptureHint "anything" $ typeRep (Proxy :: Proxy ())
67+
6268 router :: Router ()
6369 router = leafRouter (\_ _ res -> res $ Route success)
6470 `Choice` cap
@@ -98,12 +104,30 @@ distributivitySpec =
98104 it "properly handles mixing static paths at different levels" $ do
99105 level `shouldHaveSameStructureAs` levelRef
100106
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+
101119shouldHaveSameStructureAs ::
102120 (HasServer api1 '[], HasServer api2 '[]) => Proxy api1 -> Proxy api2 -> Expectation
103121shouldHaveSameStructureAs p1 p2 =
104122 unless (sameStructure (makeTrivialRouter p1) (makeTrivialRouter p2)) $
105123 expectationFailure ("expected:\n" ++ unpack (layout p2) ++ "\nbut got:\n" ++ unpack (layout p1))
106124
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+
107131makeTrivialRouter :: (HasServer layout '[]) => Proxy layout -> Router ()
108132makeTrivialRouter p =
109133 route p EmptyContext (emptyDelayed (FailFatal err501))
@@ -144,12 +168,12 @@ staticRef = Proxy
144168-- structure:
145169
146170type Dynamic =
147− "a" :> Capture "foo" Int :> "b" :> End
148− :<|> "a" :> Capture "bar" Bool :> "c" :> End
149− :<|> "a" :> Capture "baz" Char :> "d" :> End
171+ "a" :> Capture "foo" Int :> "b" :> End
172+ :<|> "a" :> Capture "foo" Int :> "c" :> End
173+ :<|> "a" :> Capture "foo" Int :> "d" :> End
150174
151175type DynamicRef =
152− "a" :> Capture "anything" () :>
176+ "a" :> Capture "foo" Int :>
153177 ("b" :> End :<|> "c" :> End :<|> "d" :> End)
154178
155179dynamic :: Proxy Dynamic
@@ -339,3 +363,100 @@ level = Proxy
339363
340364levelRef :: Proxy LevelRef
341365levelRef = 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+310−126
@@ -1,13 +1,13 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE DeriveGeneric #-}
3−{-# LANGUAGE FlexibleContexts #-}
4−{-# LANGUAGE FlexibleInstances #-}
5−{-# LANGUAGE OverloadedStrings #-}
6−{-# LANGUAGE PolyKinds #-}
7−{-# LANGUAGE ScopedTypeVariables #-}
8−{-# LANGUAGE TypeFamilies #-}
9−{-# LANGUAGE TypeOperators #-}
10−{-# LANGUAGE TypeSynonymInstances #-}
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE OverloadedStrings #-}
6+{-# LANGUAGE PolyKinds #-}
7+{-# LANGUAGE ScopedTypeVariables #-}
8+{-# LANGUAGE TypeFamilies #-}
9+{-# LANGUAGE TypeOperators #-}
10+{-# LANGUAGE TypeApplications #-}
1111{-# OPTIONS_GHC -freduction-depth=100 #-}
1212
1313module Servant.ServerSpec where
@@ -17,14 +17,20 @@ import Prelude.Compat
1717
1818import Control.Monad
1919 (forM_, unless, when)
20+import Control.Monad.Reader (runReaderT, ask)
2021import Control.Monad.Error.Class
2122 (MonadError (..))
23+import Control.Monad.IO.Class (MonadIO(..))
2224import Data.Aeson
2325 (FromJSON, ToJSON, decode', encode)
26+import Data.Acquire
27+ (Acquire, mkAcquire)
2428import qualified Data.ByteString as BS
2529import qualified Data.ByteString.Base64 as Base64
2630import Data.Char
2731 (toUpper)
32+import Data.Maybe
33+ (fromMaybe)
2834import Data.Proxy
2935 (Proxy (Proxy))
3036import Data.String
@@ -35,32 +41,34 @@ import qualified Data.Text as T
3541import GHC.Generics
3642 (Generic)
3743import Network.HTTP.Types
38− (Status (..), hAccept, hContentType, imATeapot418,
44+ (QueryItem, Status (..), hAccept, hContentType, imATeapot418,
3945 methodDelete, methodGet, methodHead, methodPatch, methodPost,
4046 methodPut, ok200, parseQuery)
4147import Network.Wai
42− (Application, Request, pathInfo, queryString, rawQueryString,
43− requestHeaders, responseLBS)
48+ (Application, Middleware, Request, pathInfo, queryString,
49+ rawQueryString, requestHeaders, responseLBS)
4450import Network.Wai.Test
4551 (defaultRequest, request, runSession, simpleBody,
4652 simpleHeaders, simpleStatus)
4753import Servant.API
4854 ((:<|>) (..), (:>), AuthProtect, BasicAuth,
49− BasicAuthData (BasicAuthData), Capture, Capture', CaptureAll, Lenient, Strict, Delete,
50− EmptyAPI, Get, Header, Headers, HttpVersion, IsSecure (..),
51− JSON, NoContent (..), NoFraming, OctetStream, Patch,
52− PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw,
53− RemoteHost, ReqBody, SourceIO, StdMethod (..), Stream, Verb,
54− NoContentVerb, addHeader)
55+ BasicAuthData (BasicAuthData), Capture, Capture', CaptureAll,
56+ Delete, EmptyAPI, Fragment, Get, HasStatus (StatusOf), Header,
57+ Headers, HttpVersion, IsSecure (..), JSON, Lenient,
58+ NoContent (..), NoContentVerb, NoFraming, OctetStream, Patch,
59+ PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw, RawM,
60+ RemoteHost, ReqBody, SourceIO, StdMethod (..), Stream, Strict,
61+ UVerb, Union, Verb, WithStatus (..), addHeader)
5562import Servant.Server
56− (Context ((:.), EmptyContext), Handler, Server, Tagged (..),
57− emptyServer, err400, err401, err403, err404, serve, serveWithContext)
63+ (Context ((:.), EmptyContext), Handler, Server, ServerT, Tagged (..),
64+ emptyServer, err401, err403, err404, hoistServer, respond, serve,
65+ serveWithContext)
5866import Servant.Test.ComprehensiveAPI
5967import qualified Servant.Types.SourceT as S
6068import Test.Hspec
6169 (Spec, context, describe, it, shouldBe, shouldContain)
6270import Test.Hspec.Wai
63− (get, liftIO, matchHeaders, matchStatus, shouldRespondWith,
71+ (get, matchHeaders, matchStatus, shouldRespondWith,
6472 with, (<:>))
6573import qualified Test.Hspec.Wai as THW
6674
@@ -77,22 +85,29 @@ import Servant.Server.Internal.Context
7785-- This declaration simply checks that all instances are in place.
7886_ = serveWithContext comprehensiveAPI comprehensiveApiContext
7987
80−comprehensiveApiContext :: Context '[NamedContext "foo" '[]]
81−comprehensiveApiContext = NamedContext EmptyContext :. EmptyContext
88+comprehensiveApiContext :: Context '[NamedContext "foo" '[], Acquire Int]
89+comprehensiveApiContext =
90+ NamedContext EmptyContext :.
91+ mkAcquire (pure 10) (\_ -> pure ()) :.
92+ EmptyContext
8293
8394-- * Specs
8495
8596spec :: Spec
8697spec = do
8798 verbSpec
99+ uverbSpec
88100 captureSpec
89101 captureAllSpec
90102 queryParamSpec
103+ fragmentSpec
91104 reqBodySpec
92105 headerSpec
93106 rawSpec
107+ rawMSpec
94108 alternativeSpec
95109 responseHeadersSpec
110+ uverbResponseHeadersSpec
96111 miscCombinatorSpec
97112 basicAuthSpec
98113 genAuthSpec
@@ -218,7 +233,7 @@ captureServer = getLegs :<|> getEars :<|> getEyes
218233 _ -> throwError err404
219234
220235 getEars :: Either String Integer -> Handler Animal
221− getEars (Left e) = return chimera -- ignore integer parse error, return weird animal
236+ getEars (Left _) = return chimera -- ignore integer parse error, return weird animal
222237 getEars (Right 2) = return jerry
223238 getEars (Right _) = throwError err404
224239
@@ -251,8 +266,8 @@ captureSpec = do
251266
252267 with (return (serve
253268 (Proxy :: Proxy (Capture "captured" String :> Raw))
254− (\ "captured" -> Tagged $ \request_ respond ->
255− respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do
269+ (\ "captured" -> Tagged $ \request_ sendResponse ->
270+ sendResponse $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do
256271 it "strips the captured path snippet from pathInfo" $ do
257272 get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String]))
258273
@@ -303,8 +318,8 @@ captureAllSpec = do
303318
304319 with (return (serve
305320 (Proxy :: Proxy (CaptureAll "segments" String :> Raw))
306− (\ _captured -> Tagged $ \request_ respond ->
307− respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do
321+ (\ _captured -> Tagged $ \request_ sendResponse ->
322+ sendResponse $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do
308323 it "consumes everything from pathInfo" $ do
309324 get "/captured/foo/bar/baz" `shouldRespondWith` (fromString (show ([] :: [Int])))
310325
@@ -339,117 +354,154 @@ qpServer = queryParamServer :<|> qpNames :<|> qpCapitalize :<|> qpAge :<|> qpAge
339354 queryParamServer (Just name_) = return alice{name = name_}
340355 queryParamServer Nothing = return alice
341356
357+
358+
342359queryParamSpec :: Spec
343360queryParamSpec = do
361+ let mkRequest params pinfo = Network.Wai.Test.request defaultRequest
362+ { rawQueryString = params
363+ , queryString = parseQuery params
364+ , pathInfo = pinfo
365+ }
366+
344367 describe "Servant.API.QueryParam" $ do
345368 it "allows retrieving simple GET parameters" $
346− (flip runSession) (serve queryParamApi qpServer) $ do
347− let params1 = "?name=bob"
348− response1 <- Network.Wai.Test.request defaultRequest{
349− rawQueryString = params1,
350− queryString = parseQuery params1
351− }
352− liftIO $ do
353− decode' (simpleBody response1) `shouldBe` Just alice{
354− name = "bob"
355− }
369+ flip runSession (serve queryParamApi qpServer) $ do
370+ response1 <- mkRequest "?name=bob" []
371+ liftIO $ decode' (simpleBody response1) `shouldBe` Just alice
372+ { name = "bob"
373+ }
356374
357375 it "allows retrieving lists in GET parameters" $
358− (flip runSession) (serve queryParamApi qpServer) $ do
359− let params2 = "?names[]=bob&names[]=john"
360− response2 <- Network.Wai.Test.request defaultRequest{
361− rawQueryString = params2,
362− queryString = parseQuery params2,
363− pathInfo = ["a"]
364− }
365− liftIO $
366− decode' (simpleBody response2) `shouldBe` Just alice{
367− name = "john"
368− }
376+ flip runSession (serve queryParamApi qpServer) $ do
377+ response2 <- mkRequest "?names[]=bob&names[]=john" ["a"]
378+ liftIO $ decode' (simpleBody response2) `shouldBe` Just alice
379+ { name = "john"
380+ }
369381
370382 it "parses a query parameter" $
371− (flip runSession) (serve queryParamApi qpServer) $ do
372− let params = "?age=55"
373− response <- Network.Wai.Test.request defaultRequest{
374− rawQueryString = params,
375− queryString = parseQuery params,
376− pathInfo = ["param"]
377− }
378− liftIO $
379− decode' (simpleBody response) `shouldBe` Just alice{
380− age = 55
381− }
383+ flip runSession (serve queryParamApi qpServer) $ do
384+ response <- mkRequest "?age=55" ["param"]
385+ liftIO $ decode' (simpleBody response) `shouldBe` Just alice
386+ { age = 55
387+ }
382388
383389 it "generates an error on query parameter parse failure" $
384− (flip runSession) (serve queryParamApi qpServer) $ do
385− let params = "?age=foo"
386− response <- Network.Wai.Test.request defaultRequest{
387− rawQueryString = params,
388− queryString = parseQuery params,
389− pathInfo = ["param"]
390− }
390+ flip runSession (serve queryParamApi qpServer) $ do
391+ response <- mkRequest "?age=foo" ["param"]
391392 liftIO $ statusCode (simpleStatus response) `shouldBe` 400
392393 return ()
393394
394395 it "parses multiple query parameters" $
395− (flip runSession) (serve queryParamApi qpServer) $ do
396− let params = "?ages=10&ages=22"
397− response <- Network.Wai.Test.request defaultRequest{
398− rawQueryString = params,
399− queryString = parseQuery params,
400− pathInfo = ["multiparam"]
401− }
402− liftIO $
403− decode' (simpleBody response) `shouldBe` Just alice{
404− age = 32
405− }
396+ flip runSession (serve queryParamApi qpServer) $ do
397+ response <- mkRequest "?ages=10&ages=22" ["multiparam"]
398+ liftIO $ decode' (simpleBody response) `shouldBe` Just alice
399+ { age = 32
400+ }
406401
407402 it "generates an error on parse failures of multiple parameters" $
408− (flip runSession) (serve queryParamApi qpServer) $ do
409− let params = "?ages=2&ages=foo"
410− response <- Network.Wai.Test.request defaultRequest{
411− rawQueryString = params,
412− queryString = parseQuery params,
413− pathInfo = ["multiparam"]
414− }
403+ flip runSession (serve queryParamApi qpServer) $ do
404+ response <- mkRequest "?ages=2&ages=foo" ["multiparam"]
415405 liftIO $ statusCode (simpleStatus response) `shouldBe` 400
416406 return ()
417407
418−
419408 it "allows retrieving value-less GET parameters" $
420− (flip runSession) (serve queryParamApi qpServer) $ do
421− let params3 = "?capitalize"
422− response3 <- Network.Wai.Test.request defaultRequest{
423− rawQueryString = params3,
424− queryString = parseQuery params3,
425− pathInfo = ["b"]
426− }
427− liftIO $
428− decode' (simpleBody response3) `shouldBe` Just alice{
429− name = "ALICE"
430− }
431−
432− let params3' = "?capitalize="
433− response3' <- Network.Wai.Test.request defaultRequest{
434− rawQueryString = params3',
435− queryString = parseQuery params3',
436− pathInfo = ["b"]
437− }
438− liftIO $
439− decode' (simpleBody response3') `shouldBe` Just alice{
440− name = "ALICE"
441− }
442−
443− let params3'' = "?unknown="
444− response3'' <- Network.Wai.Test.request defaultRequest{
445− rawQueryString = params3'',
446− queryString = parseQuery params3'',
447− pathInfo = ["b"]
448− }
449− liftIO $
450− decode' (simpleBody response3'') `shouldBe` Just alice{
451− name = "Alice"
452− }
409+ flip runSession (serve queryParamApi qpServer) $ do
410+ response3 <- mkRequest "?capitalize" ["b"]
411+ liftIO $ decode' (simpleBody response3) `shouldBe` Just alice
412+ { name = "ALICE"
413+ }
414+
415+ response3' <- mkRequest "?capitalize=" ["b"]
416+ liftIO $ decode' (simpleBody response3') `shouldBe` Just alice
417+ { name = "ALICE"
418+ }
419+
420+ response3'' <- mkRequest "?unknown=" ["b"]
421+ liftIO $ decode' (simpleBody response3'') `shouldBe` Just alice
422+ { name = "Alice"
423+ }
424+
425+ describe "Uses queryString instead of rawQueryString" $ do
426+ -- test query parameters rewriter
427+ let queryRewriter :: Middleware
428+ queryRewriter app req = app req
429+ { queryString = fmap rewrite $ queryString req
430+ }
431+ where
432+ rewrite :: QueryItem -> QueryItem
433+ rewrite (k, v) = (fromMaybe k (BS.stripPrefix "person_" k), v)
434+
435+ let app = queryRewriter $ serve queryParamApi qpServer
436+
437+ it "allows rewriting for simple GET/query parameters" $
438+ flip runSession app $ do
439+ response1 <- mkRequest "?person_name=bob" []
440+ liftIO $ decode' (simpleBody response1) `shouldBe` Just alice
441+ { name = "bob"
442+ }
443+
444+ it "allows rewriting for lists in GET parameters" $
445+ flip runSession app $ do
446+ response2 <- mkRequest "?person_names[]=bob&person_names[]=john" ["a"]
447+ liftIO $ decode' (simpleBody response2) `shouldBe` Just alice
448+ { name = "john"
449+ }
450+
451+ it "allows rewriting when parsing multiple query parameters" $
452+ flip runSession app $ do
453+ response <- mkRequest "?person_ages=10&person_ages=22" ["multiparam"]
454+ liftIO $ decode' (simpleBody response) `shouldBe` Just alice
455+ { age = 32
456+ }
457+
458+ it "allows retrieving value-less GET parameters" $
459+ flip runSession app $ do
460+ response3 <- mkRequest "?person_capitalize" ["b"]
461+ liftIO $ decode' (simpleBody response3) `shouldBe` Just alice
462+ { name = "ALICE"
463+ }
464+
465+ response3' <- mkRequest "?person_capitalize=" ["b"]
466+ liftIO $ decode' (simpleBody response3') `shouldBe` Just alice
467+ { name = "ALICE"
468+ }
469+
470+ response3'' <- mkRequest "?person_unknown=" ["b"]
471+ liftIO $ decode' (simpleBody response3'') `shouldBe` Just alice
472+ { name = "Alice"
473+ }
474+
475+-- }}}
476+------------------------------------------------------------------------------
477+-- * fragmentSpec {{{
478+------------------------------------------------------------------------------
479+
480+type FragmentApi = "name" :> Fragment String :> Get '[JSON] Person
481+ :<|> "age" :> Fragment Integer :> Get '[JSON] Person
482+
483+fragmentApi :: Proxy FragmentApi
484+fragmentApi = Proxy
485+
486+fragServer :: Server FragmentApi
487+fragServer = fragmentServer :<|> fragAge
488+ where
489+ fragmentServer = return alice
490+ fragAge = return alice
491+
492+fragmentSpec :: Spec
493+fragmentSpec = do
494+ let mkRequest params pinfo = Network.Wai.Test.request defaultRequest
495+ { rawQueryString = params
496+ , queryString = parseQuery params
497+ , pathInfo = pinfo
498+ }
499+
500+ describe "Servant.API.Fragment" $ do
501+ it "ignores fragment even if it is present in query" $ do
502+ flip runSession (serve fragmentApi fragServer) $ do
503+ response1 <- mkRequest "#Alice" ["name"]
504+ liftIO $ decode' (simpleBody response1) `shouldBe` Just alice
453505
454506-- }}}
455507------------------------------------------------------------------------------
@@ -536,15 +588,15 @@ rawApi :: Proxy RawApi
536588rawApi = Proxy
537589
538590rawApplication :: Show a => (Request -> a) -> Tagged m Application
539−rawApplication f = Tagged $ \request_ respond ->
540− respond $ responseLBS ok200 []
591+rawApplication f = Tagged $ \request_ sendResponse ->
592+ sendResponse $ responseLBS ok200 []
541593 (cs $ show $ f request_)
542594
543595rawSpec :: Spec
544596rawSpec = do
545597 describe "Servant.API.Raw" $ do
546598 it "runs applications" $ do
547− (flip runSession) (serve rawApi (rawApplication (const (42 :: Integer)))) $ do
599+ flip runSession (serve rawApi (rawApplication (const (42 :: Integer)))) $ do
548600 response <- Network.Wai.Test.request defaultRequest{
549601 pathInfo = ["foo"]
550602 }
@@ -552,7 +604,7 @@ rawSpec = do
552604 simpleBody response `shouldBe` "42"
553605
554606 it "gets the pathInfo modified" $ do
555− (flip runSession) (serve rawApi (rawApplication pathInfo)) $ do
607+ flip runSession (serve rawApi (rawApplication pathInfo)) $ do
556608 response <- Network.Wai.Test.request defaultRequest{
557609 pathInfo = ["foo", "bar"]
558610 }
@@ -561,6 +613,46 @@ rawSpec = do
561613
562614-- }}}
563615------------------------------------------------------------------------------
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+------------------------------------------------------------------------------
564656-- * alternativeSpec {{{
565657------------------------------------------------------------------------------
566658type AlternativeApi =
@@ -642,6 +734,31 @@ responseHeadersSpec = describe "ResponseHeaders" $ do
642734 THW.request method "" [(hAccept, "crazy/mime")] ""
643735 `shouldRespondWith` 406
644736
737+-- }}}
738+------------------------------------------------------------------------------
739+-- * uverbResponseHeaderSpec {{{
740+------------------------------------------------------------------------------
741+type UVerbHeaderResponse = '[
742+ WithStatus 200 (Headers '[Header "H1" Int] String),
743+ WithStatus 404 String ]
744+
745+type UVerbResponseHeadersApi =
746+ Capture "ok" Bool :> UVerb 'GET '[JSON] UVerbHeaderResponse
747+
748+uverbResponseHeadersServer :: Server UVerbResponseHeadersApi
749+uverbResponseHeadersServer True = respond . WithStatus @200 . addHeader @"H1" (5 :: Int) $ ("foo" :: String)
750+uverbResponseHeadersServer False = respond . WithStatus @404 $ ("bar" :: String)
751+
752+uverbResponseHeadersSpec :: Spec
753+uverbResponseHeadersSpec = describe "UVerbResponseHeaders" $ do
754+ with (return $ serve (Proxy :: Proxy UVerbResponseHeadersApi) uverbResponseHeadersServer) $ do
755+
756+ it "includes the headers in the response" $
757+ THW.request methodGet "/true" [] ""
758+ `shouldRespondWith` "\"foo\"" { matchHeaders = ["H1" <:> "5"]
759+ , matchStatus = 200
760+ }
761+
645762-- }}}
646763------------------------------------------------------------------------------
647764-- * miscCombinatorSpec {{{
@@ -698,7 +815,7 @@ basicAuthApi = Proxy
698815basicAuthServer :: Server BasicAuthAPI
699816basicAuthServer =
700817 const (return jerry) :<|>
701− (Tagged $ \ _ respond -> respond $ responseLBS imATeapot418 [] "")
818+ (Tagged $ \ _ sendResponse -> sendResponse $ responseLBS imATeapot418 [] "")
702819
703820basicAuthContext :: Context '[ BasicAuthCheck () ]
704821basicAuthContext =
@@ -743,7 +860,7 @@ genAuthApi = Proxy
743860
744861genAuthServer :: Server GenAuthAPI
745862genAuthServer = const (return tweety)
746− :<|> (Tagged $ \ _ respond -> respond $ responseLBS imATeapot418 [] "")
863+ :<|> (Tagged $ \ _ sendResponse -> sendResponse $ responseLBS imATeapot418 [] "")
747864
748865type instance AuthServerData (AuthProtect "auth") = ()
749866
@@ -773,6 +890,73 @@ genAuthSpec = do
773890 it "plays nice with subsequent Raw endpoints" $ do
774891 get "/foo" `shouldRespondWith` 418
775892
893+-- }}}
894+------------------------------------------------------------------------------
895+-- * UVerb {{{
896+------------------------------------------------------------------------------
897+
898+newtype PersonResponse = PersonResponse Person
899+ deriving Generic
900+instance ToJSON PersonResponse
901+instance HasStatus PersonResponse where
902+ type StatusOf PersonResponse = 200
903+
904+newtype RedirectResponse = RedirectResponse String
905+ deriving Generic
906+instance ToJSON RedirectResponse
907+instance HasStatus RedirectResponse where
908+ type StatusOf RedirectResponse = 301
909+
910+newtype AnimalResponse = AnimalResponse Animal
911+ deriving Generic
912+instance ToJSON AnimalResponse
913+instance HasStatus AnimalResponse where
914+ type StatusOf AnimalResponse = 203
915+
916+
917+type UVerbApi
918+ = "person" :> Capture "shouldRedirect" Bool :> UVerb 'GET '[JSON] '[PersonResponse, RedirectResponse]
919+ :<|> "animal" :> UVerb 'GET '[JSON] '[AnimalResponse]
920+
921+uverbSpec :: Spec
922+uverbSpec = describe "Servant.API.UVerb " $ do
923+ let
924+ joe = Person "joe" 42
925+ mouse = Animal "Mouse" 7
926+
927+ personHandler
928+ :: Bool
929+ -> Handler (Union '[PersonResponse
930+ ,RedirectResponse])
931+ personHandler True = respond $ RedirectResponse "over there!"
932+ personHandler False = respond $ PersonResponse joe
933+
934+ animalHandler = respond $ AnimalResponse mouse
935+
936+ server :: Server UVerbApi
937+ server = personHandler :<|> animalHandler
938+
939+ with (pure $ serve (Proxy :: Proxy UVerbApi) server) $ do
940+ context "A route returning either 301/String or 200/Person" $ do
941+ context "when requesting the person" $ do
942+ let theRequest = THW.get "/person/false"
943+ it "returns status 200" $
944+ theRequest `shouldRespondWith` 200
945+ it "returns a person" $ do
946+ response <- theRequest
947+ liftIO $ decode' (simpleBody response) `shouldBe` Just joe
948+ context "requesting the redirect" $
949+ it "returns a message and status 301" $
950+ THW.get "/person/true"
951+ `shouldRespondWith` "\"over there!\"" {matchStatus = 301}
952+ context "a route with a single response type" $ do
953+ let theRequest = THW.get "/animal"
954+ it "should return the defined status code" $
955+ theRequest `shouldRespondWith` 203
956+ it "should return the expected response" $ do
957+ response <- theRequest
958+ liftIO $ decode' (simpleBody response) `shouldBe` Just mouse
959+
776960-- }}}
777961------------------------------------------------------------------------------
778962-- * Test data types {{{
servant-server/test/doctests.hsdeleted−27
@@ -1,27 +0,0 @@
1−-----------------------------------------------------------------------------
2−-- |
3−-- Module : Main (doctests)
4−-- Copyright : (C) 2012-14 Edward Kmett
5−-- License : BSD-style (see the file LICENSE)
6−-- Maintainer : Edward Kmett <ekmett@gmail.com>
7−-- Stability : provisional
8−-- Portability : portable
9−--
10−-- This module provides doctests for a project based on the actual versions
11−-- of the packages it was built with. It requires a corresponding Setup.lhs
12−-- to be added to the project
13−-----------------------------------------------------------------------------
14−module Main where
15−
16−import Build_doctests
17− (flags, module_sources, pkgs)
18−import Data.Foldable
19− (traverse_)
20−import Test.DocTest
21−
22−main :: IO ()
23−main = do
24− traverse_ putStrLn args
25− doctest args
26− where
27− args = flags ++ pkgs ++ module_sources
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+278−2
@@ -1,5 +1,281 @@
11[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)
22
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+
124+0.18.3
125+------
126+
127+### Significant changes
128+
129+- Add response header support to UVerb (#1420).
130+- Use Capture Description if available (#1423).
131+
132+### Other changes
133+
134+- Support GHC-9.0.1.
135+- Bump `bytestring`, `attoparsec`, `hspec` and `singleton-bool` dependencies.
136+
137+0.18.2
138+------
139+
140+### Significant changes
141+
142+- Introduce `Fragment` combinator.
143+- Fix `MimeRender` and `MimeUnrender` instances for `WithStatus`.
144+
145+0.18.1
146+------
147+
148+### Significant changes
149+
150+- Union verbs
151+
152+### Other changes
153+
154+- Bump "tested-with" ghc versions
155+- Allow newer dependencies
156+
157+0.18
158+----
159+
160+### Significant changes
161+
162+- Support for ghc8.8 (#1318, #1326, #1327)
163+
164+- Configurable error messages for automatic errors thrown by servant,
165+ like "no route" or "could not parse json body" (#1312, #1326, #1327)
166+
167+### Other changes
168+
169+- Witness that a type-level natural number corresponds to a HTTP
170+ status code (#1310)
171+
172+- Improve haddocs (#1279)
173+
174+- Dependency management (#1269, #1293, #1286, #1287)
175+
176+
177+0.17
178+----
179+
180+### Significant changes
181+
182+- Add NoContentVerb [#1028](https://github.com/haskell-servant/servant/issues/1028) [#1219](https://github.com/haskell-servant/servant/pull/1219) [#1228](https://github.com/haskell-servant/servant/pull/1228)
183+
184+ The `NoContent` API endpoints should now use `NoContentVerb` combinator.
185+ The API type changes are usually of the kind
186+
187+ ```diff
188+ - :<|> PostNoContent '[JSON] NoContent
189+ + :<|> PostNoContent
190+ ```
191+
192+ i.e. one doesn't need to specify the content-type anymore. There is no content.
193+
194+- `Capture` can be `Lenient` [#1155](https://github.com/haskell-servant/servant/issues/1155) [#1156](https://github.com/haskell-servant/servant/pull/1156)
195+
196+ You can specify a lenient capture as
197+
198+ ```haskell
199+ :<|> "capture-lenient" :> Capture' '[Lenient] "foo" Int :> GET
200+ ```
201+
202+ which will make the capture always succeed. Handlers will be of the
203+ type `Either String CapturedType`, where `Left err` represents
204+ the possible parse failure.
205+
206+- *servant-client* Added a function to create Client.Request in ClientEnv [#1213](https://github.com/haskell-servant/servant/pull/1213) [#1255](https://github.com/haskell-servant/servant/pull/1255)
207+
208+ The new member `makeClientRequest` of `ClientEnv` is used to create
209+ `http-client` `Request` from `servant-client-core` `Request`.
210+ This functionality can be used for example to set
211+ dynamic timeouts for each request.
212+
213+- *servant-server* use queryString to parse QueryParam, QueryParams and QueryFlag [#1249](https://github.com/haskell-servant/servant/pull/1249) [#1262](https://github.com/haskell-servant/servant/pull/1262)
214+
215+ Some APIs need query parameters rewriting, e.g. in order to support
216+ for multiple casing (camel, snake, etc) or something to that effect.
217+
218+ This could be easily achieved by using WAI Middleware and modifying
219+ request's `Query`. But QueryParam, QueryParams and QueryFlag use
220+ `rawQueryString`. By using `queryString` rather then `rawQueryString`
221+ we can enable such rewritings.
222+
223+- *servant* *servant-server* Make packages `build-type: Simple` [#1263](https://github.com/haskell-servant/servant/pull/1263)
224+
225+ We used `build-type: Custom`, but it's problematic e.g.
226+ for cross-compiling. The benefit is small, as the doctests
227+ can be run other ways too (though not so conveniently).
228+
229+- *servant* Remove deprecated modules [1268#](https://github.com/haskell-servant/servant/pull/1268)
230+
231+ - `Servant.Utils.Links` is `Servant.Links`
232+ - `Servant.API.Internal.Test.ComprehensiveAPI` is `Servant.Test.ComprehensiveAPI`
233+
234+### Other changes
235+
236+- *servant-client* *servant-client-core* *servant-http-streams* Fix Verb with headers checking content type differently [#1200](https://github.com/haskell-servant/servant/issues/1200) [#1204](https://github.com/haskell-servant/servant/pull/1204)
237+
238+ For `Verb`s with response `Headers`, the implementation didn't check
239+ for the content-type of the response. Now it does.
240+
241+- *servant-docs* Merge documentation from duplicate routes [#1240](https://github.com/haskell-servant/servant/issues/1240) [#1241](https://github.com/haskell-servant/servant/pull/1241)
242+
243+ Servant supports defining the same route multiple times with different
244+ content-types and result-types, but servant-docs was only documenting
245+ the first of copy of such duplicated routes. It now combines the
246+ documentation from all the copies.
247+
248+ Unfortunately, it is not yet possible for the documentation to specify
249+ multiple status codes.
250+
251+- Add sponsorship button [#1190](https://github.com/haskell-servant/servant/pull/1190)
252+
253+ [Well-Typed](https://www.well-typed.com/) is a consultancy which could help you with `servant` issues
254+ (See consultancies section on https://www.servant.dev/).
255+
256+- Try changelog-d for changelog management [#1230](https://github.com/haskell-servant/servant/pull/1230)
257+
258+ Check the [CONTRIBUTING.md](https://github.com/haskell-servant/servant/blob/master/CONTRIBUTING.md) for details
259+
260+- CI and testing tweaks. [#1154](https://github.com/haskell-servant/servant/pull/1154) [#1157](https://github.com/haskell-servant/servant/pull/1157) [#1182](https://github.com/haskell-servant/servant/pull/1182) [#1214](https://github.com/haskell-servant/servant/pull/1214) [#1229](https://github.com/haskell-servant/servant/pull/1229) [#1233](https://github.com/haskell-servant/servant/pull/1233) [#1242](https://github.com/haskell-servant/servant/pull/1242) [#1247](https://github.com/haskell-servant/servant/pull/1247) [#1250](https://github.com/haskell-servant/servant/pull/1250) [#1258](https://github.com/haskell-servant/servant/pull/1258)
261+
262+ We are experiencing some bitrotting of cookbook recipe dependencies,
263+ therefore some of them aren't build as part of our CI anymore.
264+
265+- New cookbook recipes [#1088](https://github.com/haskell-servant/servant/pull/1088) [#1171](https://github.com/haskell-servant/servant/pull/1171) [#1198](https://github.com/haskell-servant/servant/pull/1198)
266+
267+ - [OIDC Recipe](#TODO)
268+ - [MySQL Recipe](#TODO)
269+
270+- *servant-jsaddle* Progress on servant-jsaddle [#1216](https://github.com/haskell-servant/servant/pull/1216)
271+- *servant-docs* Prevent race-conditions in testing [#1194](https://github.com/haskell-servant/servant/pull/1194)
272+- *servant-client* *servant-http-streams* `HasClient` instance for `Stream` with `Headers` [#1170](https://github.com/haskell-servant/servant/issues/1170) [#1197](https://github.com/haskell-servant/servant/pull/1197)
273+- *servant* Remove unused extensions from cabal file [#1201](https://github.com/haskell-servant/servant/pull/1201)
274+- *servant-client* Redact the authorization header in Show and exceptions [#1238](https://github.com/haskell-servant/servant/pull/1238)
275+- Dependency upgrades [#1173](https://github.com/haskell-servant/servant/pull/1173) [#1181](https://github.com/haskell-servant/servant/pull/1181) [#1183](https://github.com/haskell-servant/servant/pull/1183) [#1188](https://github.com/haskell-servant/servant/pull/1188) [#1224](https://github.com/haskell-servant/servant/pull/1224) [#1245](https://github.com/haskell-servant/servant/pull/1245) [#1257](https://github.com/haskell-servant/servant/pull/1257)
276+- Documentation updates [#1162](https://github.com/haskell-servant/servant/pull/1162) [#1174](https://github.com/haskell-servant/servant/pull/1174) [#1175](https://github.com/haskell-servant/servant/pull/1175) [#1234](https://github.com/haskell-servant/servant/pull/1234) [#1244](https://github.com/haskell-servant/servant/pull/1244) [#1247](https://github.com/haskell-servant/servant/pull/1247)
277+
278+
32790.16.2
4280------
5281
@@ -303,7 +579,7 @@
303579
304580- *servant-client-core* Add `hoistClient` to `HasClient`.
305581 Just like `hoistServer` allows us to change the monad in which request handlers
306− of a web application live in, we also have `hoistClient` for changing the monad
582+ of a web application live, we also have `hoistClient` for changing the monad
307583 in which *client functions* live.
308584 Read [tutorial section for more information](https://docs.servant.dev/en/release-0.14/tutorial/Client.html#changing-the-monad-the-client-functions-live-in).
309585 ([#936](https://github.com/haskell-servant/servant/pull/936))
@@ -510,7 +786,7 @@
510786
511787 `enter` isn't exported from `Servant` module anymore. You can change
512788 `enter` to `hoistServer` in a straight forward way.
513− Unwrap natural transformation and add a api type `Proxy`:
789+ Unwrap natural transformation and add an api type `Proxy`:
514790
515791 ```diff
516792 -server = enter (NT nt) impl
servant/Setup.hs+1−32
@@ -1,33 +1,2 @@
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 ()
1+import Distribution.Simple
312main = defaultMain
32−
33−#endif
servant/servant.cabal+36−62
@@ -1,6 +1,6 @@
1−cabal-version: >=1.10
1+cabal-version: 2.2
22name: servant
3−version: 0.16
3+version: 0.19.1
44
55synopsis: A family of combinators for defining webservices APIs
66category: Servant, Web
@@ -13,20 +13,15 @@ description:
1313
1414homepage: http://docs.servant.dev/
1515bug-reports: http://github.com/haskell-servant/servant/issues
16−license: BSD3
16+license: BSD-3-Clause
1717license-file: LICENSE
1818author: Servant Contributors
1919maintainer: haskell-servant-maintainers@googlegroups.com
2020copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors
21−build-type: Custom
21+build-type: Simple
2222
23−tested-with:
24− GHC ==8.0.2
25− || ==8.2.2
26− || ==8.4.4
27− || ==8.6.5
28− || ==8.8.1
29− , GHCJS == 8.4
23+tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1
24+ , GHCJS ==8.6.0.1
3025
3126extra-source-files:
3227 CHANGELOG.md
@@ -35,12 +30,6 @@ source-repository head
3530 type: git
3631 location: http://github.com/haskell-servant/servant.git
3732
38−custom-setup
39− setup-depends:
40− base >= 4 && <5,
41− Cabal,
42− cabal-doctest >= 1.0.6 && <1.1
43−
4433library
4534 exposed-modules:
4635 Servant.API
@@ -51,22 +40,29 @@ library
5140 Servant.API.Description
5241 Servant.API.Empty
5342 Servant.API.Experimental.Auth
43+ Servant.API.Fragment
5444 Servant.API.Generic
5545 Servant.API.Header
5646 Servant.API.HttpVersion
5747 Servant.API.IsSecure
5848 Servant.API.Modifiers
49+ Servant.API.NamedRoutes
5950 Servant.API.QueryParam
6051 Servant.API.Raw
6152 Servant.API.RemoteHost
6253 Servant.API.ReqBody
6354 Servant.API.ResponseHeaders
55+ Servant.API.Status
6456 Servant.API.Stream
6557 Servant.API.Sub
58+ Servant.API.TypeErrors
6659 Servant.API.TypeLevel
60+ Servant.API.UVerb
61+ Servant.API.UVerb.Union
6762 Servant.API.Vault
6863 Servant.API.Verbs
6964 Servant.API.WithNamedContext
65+ Servant.API.WithResource
7066
7167 -- Types
7268 exposed-modules:
@@ -80,54 +76,53 @@ library
8076 exposed-modules:
8177 Servant.Links
8278
83− -- Deprecated modules, to be removed in late 2019
84− exposed-modules:
85− Servant.Utils.Links
86− Servant.API.Internal.Test.ComprehensiveAPI
87−
8879 -- Bundled with GHC: Lower bound to not force re-installs
8980 -- text and mtl are bundled starting with GHC-8.4
9081 --
9182 -- note: mtl lower bound is so low because of GHC-7.8
9283 build-depends:
93− base >= 4.9 && < 4.14
94− , bytestring >= 0.10.8.1 && < 0.11
95− , mtl >= 2.2.2 && < 2.3
96− , transformers >= 0.5.2.0 && < 0.6
97− , text >= 1.2.3.0 && < 1.3
84+ base >= 4.9 && < 4.18
85+ , bytestring >= 0.10.8.1 && < 0.12
86+ , constraints >= 0.2
87+ , mtl ^>= 2.2.2 || ^>= 2.3.1
88+ , sop-core >= 0.4.0.0 && < 0.6
89+ , transformers >= 0.5.2.0 && < 0.7
90+ , text >= 1.2.3.0 && < 2.1
9891
9992
10093 -- We depend (heavily) on the API of these packages:
10194 -- i.e. re-export, or allow using without direct dependency
10295 build-depends:
103− http-api-data >= 0.4.1 && < 0.4.2
104− , singleton-bool >= 0.1.4 && < 0.1.6
96+ http-api-data >= 0.4.1 && < 0.5.1
97+ , singleton-bool >= 0.1.4 && < 0.1.7
10598
10699 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.
107100 -- Here can be exceptions if we really need features from the newer versions.
108101 build-depends:
109− base-compat >= 0.10.5 && < 0.12
110− , aeson >= 1.4.1.0 && < 1.5
111− , attoparsec >= 0.13.2.2 && < 0.14
102+ base-compat >= 0.10.5 && < 0.13
103+ , aeson >= 1.4.1.0 && < 3
104+ , attoparsec >= 0.13.2.2 && < 0.15
112105 , bifunctors >= 5.5.3 && < 5.6
113106 , case-insensitive >= 1.2.0.11 && < 1.3
114107 , deepseq >= 1.4.2.0 && < 1.5
115108 , http-media >= 0.7.1.3 && < 0.9
116109 , http-types >= 0.12.2 && < 0.13
117− , mmorph >= 1.1.2 && < 1.2
110+ , mmorph >= 1.1.2 && < 1.3
118111 , network-uri >= 2.6.1.0 && < 2.7
119− , QuickCheck >= 2.12.6.1 && < 2.14
112+ , QuickCheck >= 2.12.6.1 && < 2.15
120113 , string-conversions >= 0.4.0.1 && < 0.5
121114 , tagged >= 0.8.6 && < 0.9
122115 , vault >= 0.3.1.2 && < 0.4
123116
124117 hs-source-dirs: src
125118 default-language: Haskell2010
126− other-extensions: CPP
119+ other-extensions: AllowAmbiguousTypes
120+ , CPP
127121 , ConstraintKinds
128122 , DataKinds
129123 , DeriveDataTypeable
130124 , DeriveGeneric
125+ , ExplicitNamespaces
131126 , FlexibleContexts
132127 , FlexibleInstances
133128 , FunctionalDependencies
@@ -136,11 +131,13 @@ library
136131 , MultiParamTypeClasses
137132 , OverloadedStrings
138133 , PolyKinds
134+ , RankNTypes
139135 , ScopedTypeVariables
140136 , TupleSections
141137 , TypeFamilies
142138 , TypeOperators
143139 , UndecidableInstances
140+
144141 ghc-options: -Wall -Wno-redundant-constraints
145142
146143test-suite spec
@@ -168,34 +165,11 @@ test-suite spec
168165 , text
169166 , transformers
170167
171− -- Additonal dependencies
168+ -- Additional dependencies
172169 build-depends:
173− hspec >= 2.6.0 && < 2.8
174− , QuickCheck >= 2.12.6.1 && < 2.14
170+ hspec >= 2.6.0 && < 2.10
171+ , QuickCheck >= 2.12.6.1 && < 2.15
175172 , quickcheck-instances >= 0.3.19 && < 0.4
176173
177174 build-tool-depends:
178− hspec-discover:hspec-discover >= 2.6.0 && < 2.8
179−
180−test-suite doctests
181− if impl(ghcjs)
182− buildable: False
183−
184− build-depends:
185− base
186− , servant
187− , doctest >= 0.16.0 && <0.17
188−
189− -- We test Links failure with doctest, so we need extra dependencies
190− build-depends:
191− hspec >= 2.6.0 && < 2.8
192−
193− type: exitcode-stdio-1.0
194− main-is: test/doctests.hs
195− buildable: True
196− default-language: Haskell2010
197− ghc-options: -Wall -threaded
198− if impl(ghc >= 8.2)
199− x-doctest-options: -fdiagnostics-color=never
200− x-doctest-source-dirs: test
201− x-doctest-modules: Servant.LinksSpec
175+ hspec-discover:hspec-discover >= 2.6.0 && < 2.10
servant/src/Servant/API.hs+27−7
@@ -19,6 +19,8 @@ module Servant.API (
1919 -- | Retrieving the HTTP version of the request
2020 module Servant.API.QueryParam,
2121 -- | Retrieving parameters from the query string of the 'URI': @'QueryParam'@
22+ module Servant.API.Fragment,
23+ -- | Documenting the fragment of the 'URI': @'Fragment'@
2224 module Servant.API.ReqBody,
2325 -- | Accessing the request body as a JSON-encoded type: @'ReqBody'@
2426 module Servant.API.RemoteHost,
@@ -29,9 +31,16 @@ module Servant.API (
2931 -- | Access the location for arbitrary data to be shared by applications and middleware
3032 module Servant.API.WithNamedContext,
3133 -- | Access context entries in combinators in servant-server
34+ module Servant.API.WithResource,
35+ -- | Access a managed resource scoped to a single request
3236
3337 -- * Actual endpoints, distinguished by HTTP method
3438 module Servant.API.Verbs,
39+ module Servant.API.UVerb,
40+
41+ -- * Sub-APIs defined as records of routes
42+ module Servant.API.NamedRoutes,
43+ module Servant.API.Generic,
3544
3645 -- * Streaming endpoints, distinguished by HTTP method
3746 module Servant.API.Stream,
@@ -92,6 +101,11 @@ import Servant.API.Empty
92101 (EmptyAPI (..))
93102import Servant.API.Experimental.Auth
94103 (AuthProtect)
104+import Servant.API.Fragment
105+ (Fragment)
106+import Servant.API.Generic
107+ (AsApi, GServantProduct, GenericMode ((:-)), GenericServant,
108+ ToServant, ToServantApi, fromServant, genericApi, toServant)
95109import Servant.API.Header
96110 (Header, Header')
97111import Servant.API.HttpVersion
@@ -100,10 +114,12 @@ import Servant.API.IsSecure
100114 (IsSecure (..))
101115import Servant.API.Modifiers
102116 (Lenient, Optional, Required, Strict)
117+import Servant.API.NamedRoutes
118+ (NamedRoutes)
103119import Servant.API.QueryParam
104120 (QueryFlag, QueryParam, QueryParam', QueryParams)
105121import Servant.API.Raw
106− (Raw)
122+ (Raw, RawM)
107123import Servant.API.RemoteHost
108124 (RemoteHost)
109125import Servant.API.ReqBody
@@ -120,20 +136,24 @@ import Servant.API.Stream
120136 ToSourceIO (..))
121137import Servant.API.Sub
122138 ((:>))
139+import Servant.API.UVerb
140+ (HasStatus, IsMember, StatusOf, Statuses, UVerb, Union,
141+ Unique, WithStatus (..), inject, statusOf)
123142import Servant.API.Vault
124143 (Vault)
125144import Servant.API.Verbs
126145 (Delete, DeleteAccepted, DeleteNoContent,
127146 DeleteNonAuthoritative, Get, GetAccepted, GetNoContent,
128147 GetNonAuthoritative, GetPartialContent, GetResetContent,
129− Patch, PatchAccepted, PatchNoContent, PatchNonAuthoritative,
130− Post, PostAccepted, PostCreated, PostNoContent,
131− PostNonAuthoritative, PostResetContent, Put, PutAccepted,
132− PutCreated, PutNoContent, PutNonAuthoritative,
133− ReflectMethod (reflectMethod), StdMethod (..),
134− Verb, NoContentVerb)
148+ NoContentVerb, Patch, PatchAccepted, PatchNoContent,
149+ PatchNonAuthoritative, Post, PostAccepted, PostCreated,
150+ PostNoContent, PostNonAuthoritative, PostResetContent, Put,
151+ PutAccepted, PutCreated, PutNoContent, PutNonAuthoritative,
152+ ReflectMethod (reflectMethod), StdMethod (..), Verb)
135153import Servant.API.WithNamedContext
136154 (WithNamedContext)
155+import Servant.API.WithResource
156+ (WithResource)
137157import Servant.Links
138158 (HasLink (..), IsElem, IsElem', Link, URI (..), safeLink)
139159import Web.HttpApiData
servant/src/Servant/API/Alternative.hs−2
@@ -16,8 +16,6 @@ import Data.Bifunctor
1616 (Bifunctor (..))
1717import Data.Bitraversable
1818 (Bitraversable (..))
19−import Data.Semigroup
20− (Semigroup (..))
2119import Data.Typeable
2220 (Typeable)
2321import Prelude ()
servant/src/Servant/API/ContentTypes.hs+3−3
@@ -2,6 +2,7 @@
22{-# LANGUAGE DataKinds #-}
33{-# LANGUAGE DeriveDataTypeable #-}
44{-# LANGUAGE DeriveGeneric #-}
5+{-# LANGUAGE FlexibleContexts #-}
56{-# LANGUAGE FlexibleInstances #-}
67{-# LANGUAGE MultiParamTypeClasses #-}
78{-# LANGUAGE OverloadedStrings #-}
@@ -20,7 +21,7 @@
2021--
2122-- Content-Types are used in `ReqBody` and the method combinators:
2223--
23−-- >>> type MyEndpoint = ReqBody '[JSON, PlainText] Book :> Get '[JSON, PlainText] Book
24+-- >>> type MyEndpoint = ReqBody '[JSON, PlainText] Book :> Put '[JSON, PlainText] Book
2425--
2526-- Meaning the endpoint accepts requests of Content-Type @application/json@
2627-- or @text/plain;charset-utf8@, and returns data in either one of those
@@ -294,7 +295,7 @@ instance {-# OVERLAPPABLE #-}
294295-- then this would be taken care of. However there is no more specific instance
295296-- between that and 'MimeRender JSON a', so we do this instead
296297instance {-# OVERLAPPING #-} ( Accept ctyp ) => AllMimeRender '[ctyp] NoContent where
297− allMimeRender _ _ = map (, "") $ NE.toList $ contentTypes pctyp
298+ allMimeRender _ NoContent = map (, "") $ NE.toList $ contentTypes pctyp
298299 where
299300 pctyp = Proxy :: Proxy ctyp
300301
@@ -419,7 +420,6 @@ instance MimeUnrender OctetStream BS.ByteString where
419420 mimeUnrender _ = Right . toStrict
420421
421422
422−
423423-- $setup
424424-- >>> :set -XFlexibleInstances
425425-- >>> :set -XMultiParamTypeClasses
servant/src/Servant/API/Fragment.hsnew file+25
@@ -0,0 +1,25 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE DeriveDataTypeable #-}
3+{-# LANGUAGE PolyKinds #-}
4+{-# LANGUAGE TypeOperators #-}
5+{-# OPTIONS_HADDOCK not-home #-}
6+module Servant.API.Fragment (Fragment) where
7+
8+import Data.Typeable
9+ (Typeable)
10+
11+-- | Document the URI fragment in API. Useful in combination with 'Link'.
12+--
13+-- Example:
14+--
15+-- >>> -- /post#TRACKING
16+-- >>> type MyApi = "post" :> Fragment Text :> Get '[JSON] Tracking
17+data Fragment (a :: *)
18+ deriving Typeable
19+
20+-- $setup
21+-- >>> import Servant.API
22+-- >>> import Data.Aeson
23+-- >>> import Data.Text
24+-- >>> data Tracking
25+-- >>> instance ToJSON Tracking where { toJSON = undefined }
servant/src/Servant/API/Header.hs+1−1
@@ -23,7 +23,7 @@ import Servant.API.Modifiers
2323-- >>> type MyApi = "view-my-referer" :> Header "from" Referer :> Get '[JSON] Referer
2424type Header = Header' '[Optional, Strict]
2525
26−data Header' (mods :: [*]) (sym :: Symbol) a
26+data Header' (mods :: [*]) (sym :: Symbol) (a :: *)
2727 deriving Typeable
2828
2929-- $setup
servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hsdeleted−6
@@ -1,6 +0,0 @@
1−module Servant.API.Internal.Test.ComprehensiveAPI
2− {-# DEPRECATED "Use Servant.TestComprehensiveAPI" #-}
3− ( module Servant.Test.ComprehensiveAPI )
4− where
5−
6−import Servant.Test.ComprehensiveAPI
servant/src/Servant/API/Modifiers.hs−2
@@ -131,8 +131,6 @@ type RequestArgument mods a =
131131 (If (FoldLenient mods) (Either Text a) a)
132132 (Maybe (If (FoldLenient mods) (Either Text a) a))
133133
134−
135−
136134-- | Unfold a value into a 'RequestArgument'.
137135unfoldRequestArgument
138136 :: forall mods m a. (Monad m, SBoolI (FoldRequired mods), SBoolI (FoldLenient mods))
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
1515-- <https://hackage.haskell.org/package/servant-server/docs/Servant-Server-StaticFiles.html Servant.Server.StaticFiles>
1616-- to serve static files stored in a particular directory on your filesystem
1717data 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+30−9
@@ -3,13 +3,12 @@
33{-# LANGUAGE DeriveFunctor #-}
44{-# LANGUAGE FlexibleContexts #-}
55{-# LANGUAGE FlexibleInstances #-}
6−{-# LANGUAGE FunctionalDependencies #-}
76{-# LANGUAGE GADTs #-}
8−{-# LANGUAGE KindSignatures #-}
9−{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE FunctionalDependencies #-}
108{-# LANGUAGE PolyKinds #-}
119{-# LANGUAGE ScopedTypeVariables #-}
1210{-# LANGUAGE TypeFamilies #-}
11+{-# LANGUAGE TypeFamilyDependencies #-}
1312{-# LANGUAGE TypeOperators #-}
1413{-# LANGUAGE UndecidableInstances #-}
1514{-# OPTIONS_HADDOCK not-home #-}
@@ -53,6 +52,9 @@ import Prelude ()
5352import Prelude.Compat
5453import Servant.API.Header
5554 (Header)
55+import Servant.API.UVerb.Union
56+import qualified Data.SOP.BasicFunctors as SOP
57+import qualified Data.SOP.NS as SOP
5658
5759-- | Response Header objects. You should never need to construct one directly.
5860-- Instead, use 'addOptionalHeader'.
@@ -95,7 +97,7 @@ type family HeaderValMap (f :: * -> *) (xs :: [*]) where
9597
9698class BuildHeadersTo hs where
9799 buildHeadersTo :: [HTTP.Header] -> HList hs
98− -- ^ Note: if there are multiple occurences of a header in the argument,
100+ -- ^ Note: if there are multiple occurrences of a header in the argument,
99101 -- the values are interspersed with commas before deserialization (see
100102 -- <http://www.w3.org/Protocols/rfc2616/rfc2616-sec4.html#sec4.2 RFC2616 Sec 4.2>)
101103
@@ -114,7 +116,7 @@ instance {-# OVERLAPPABLE #-} ( FromHttpApiData v, BuildHeadersTo xs, KnownSymbo
114116 `HCons` buildHeadersTo headers
115117 Right h -> Header h `HCons` buildHeadersTo headers
116118
117−-- * Getting
119+-- * Getting headers
118120
119121class GetHeaders ls where
120122 getHeaders :: ls -> [HTTP.Header]
@@ -155,23 +157,42 @@ instance (KnownSymbol h, GetHeadersFromHList rest, ToHttpApiData v)
155157 where
156158 getHeaders' hs = getHeadersFromHList $ getHeadersHList hs
157159
158−-- * Adding
160+-- * Adding headers
159161
160162-- We need all these fundeps to save type inference
161163class AddHeader h v orig new
162164 | h v orig -> new, new -> h, new -> v, new -> orig where
163165 addOptionalHeader :: ResponseHeader h v -> orig -> new -- ^ N.B.: The same header can't be added multiple times
164166
165−
167+-- In this instance, we add a Header on top of something that is already decorated with some headers
166168instance {-# OVERLAPPING #-} ( KnownSymbol h, ToHttpApiData v )
167169 => AddHeader h v (Headers (fst ': rest) a) (Headers (Header h v ': fst ': rest) a) where
168170 addOptionalHeader hdr (Headers resp heads) = Headers resp (HCons hdr heads)
169171
170−instance {-# OVERLAPPABLE #-} ( KnownSymbol h, ToHttpApiData v
171− , new ~ (Headers '[Header h v] a) )
172+-- In this instance, 'a' parameter is decorated with a Header.
173+instance {-# OVERLAPPABLE #-} ( KnownSymbol h, ToHttpApiData v , new ~ Headers '[Header h v] a)
172174 => AddHeader h v a new where
173175 addOptionalHeader hdr resp = Headers resp (HCons hdr HNil)
174176
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+
175196-- | @addHeader@ adds a header to a response. Note that it changes the type of
176197-- the value in the following ways:
177198--
servant/src/Servant/API/Status.hsnew file+160
@@ -0,0 +1,160 @@
1+{-# LANGUAGE DataKinds #-}
2+-- Flexible instances is necessary on GHC 8.4 and earlier
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE ScopedTypeVariables #-}
5+module Servant.API.Status where
6+
7+import GHC.TypeLits (KnownNat, natVal)
8+import Network.HTTP.Types.Status
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
13+
14+-- | Witness that a type-level natural number corresponds to a HTTP status code
15+class KnownNat n => KnownStatus n where
16+ statusVal :: proxy n -> Status
17+
18+instance KnownStatus 100 where
19+ statusVal _ = status100
20+
21+instance KnownStatus 101 where
22+ statusVal _ = status101
23+
24+instance KnownStatus 200 where
25+ statusVal _ = status200
26+
27+instance KnownStatus 201 where
28+ statusVal _ = status201
29+
30+instance KnownStatus 202 where
31+ statusVal _ = status202
32+
33+instance KnownStatus 203 where
34+ statusVal _ = status203
35+
36+instance KnownStatus 204 where
37+ statusVal _ = status204
38+
39+instance KnownStatus 205 where
40+ statusVal _ = status205
41+
42+instance KnownStatus 206 where
43+ statusVal _ = status206
44+
45+instance KnownStatus 300 where
46+ statusVal _ = status300
47+
48+instance KnownStatus 301 where
49+ statusVal _ = status301
50+
51+instance KnownStatus 302 where
52+ statusVal _ = status302
53+
54+instance KnownStatus 303 where
55+ statusVal _ = status303
56+
57+instance KnownStatus 304 where
58+ statusVal _ = status304
59+
60+instance KnownStatus 305 where
61+ statusVal _ = status305
62+
63+instance KnownStatus 307 where
64+ statusVal _ = status307
65+
66+instance KnownStatus 308 where
67+ statusVal _ = status308
68+
69+instance KnownStatus 400 where
70+ statusVal _ = status400
71+
72+instance KnownStatus 401 where
73+ statusVal _ = status401
74+
75+instance KnownStatus 402 where
76+ statusVal _ = status402
77+
78+instance KnownStatus 403 where
79+ statusVal _ = status403
80+
81+instance KnownStatus 404 where
82+ statusVal _ = status404
83+
84+instance KnownStatus 405 where
85+ statusVal _ = status405
86+
87+instance KnownStatus 406 where
88+ statusVal _ = status406
89+
90+instance KnownStatus 407 where
91+ statusVal _ = status407
92+
93+instance KnownStatus 408 where
94+ statusVal _ = status408
95+
96+instance KnownStatus 409 where
97+ statusVal _ = status409
98+
99+instance KnownStatus 410 where
100+ statusVal _ = status410
101+
102+instance KnownStatus 411 where
103+ statusVal _ = status411
104+
105+instance KnownStatus 412 where
106+ statusVal _ = status412
107+
108+instance KnownStatus 413 where
109+ statusVal _ = status413
110+
111+instance KnownStatus 414 where
112+ statusVal _ = status414
113+
114+instance KnownStatus 415 where
115+ statusVal _ = status415
116+
117+instance KnownStatus 416 where
118+ statusVal _ = status416
119+
120+instance KnownStatus 417 where
121+ statusVal _ = status417
122+
123+instance KnownStatus 418 where
124+ statusVal _ = status418
125+
126+instance KnownStatus 422 where
127+ statusVal _ = status422
128+
129+instance KnownStatus 426 where
130+ statusVal _ = status426
131+
132+instance KnownStatus 428 where
133+ statusVal _ = status428
134+
135+instance KnownStatus 429 where
136+ statusVal _ = status429
137+
138+instance KnownStatus 431 where
139+ statusVal _ = status431
140+
141+instance KnownStatus 500 where
142+ statusVal _ = status500
143+
144+instance KnownStatus 501 where
145+ statusVal _ = status501
146+
147+instance KnownStatus 502 where
148+ statusVal _ = status502
149+
150+instance KnownStatus 503 where
151+ statusVal _ = status503
152+
153+instance KnownStatus 504 where
154+ statusVal _ = status504
155+
156+instance KnownStatus 505 where
157+ statusVal _ = status505
158+
159+instance KnownStatus 511 where
160+ statusVal _ = status511
servant/src/Servant/API/Stream.hs−2
@@ -47,8 +47,6 @@ import qualified Data.ByteString.Lazy as LBS
4747import qualified Data.ByteString.Lazy.Char8 as LBS8
4848import Data.List.NonEmpty
4949 (NonEmpty (..))
50−import Data.Monoid
51− ((<>))
5250import Data.Proxy
5351 (Proxy)
5452import 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+62−12
@@ -1,12 +1,16 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE ConstraintKinds #-}
3−{-# LANGUAGE DataKinds #-}
4−{-# LANGUAGE KindSignatures #-}
5−{-# LANGUAGE MultiParamTypeClasses #-}
6−{-# LANGUAGE PolyKinds #-}
7−{-# LANGUAGE TypeFamilies #-}
8−{-# LANGUAGE TypeOperators #-}
9−{-# LANGUAGE UndecidableInstances #-}
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE ConstraintKinds #-}
3+{-# LANGUAGE DataKinds #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE KindSignatures #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE PolyKinds #-}
8+{-# LANGUAGE ScopedTypeVariables #-}
9+{-# LANGUAGE TypeFamilies #-}
10+{-# LANGUAGE TypeOperators #-}
11+{-# LANGUAGE RankNTypes #-}
12+{-# LANGUAGE UndecidableInstances #-}
13+{-# LANGUAGE UndecidableSuperClasses #-}
1014
1115{-|
1216This module collects utilities for manipulating @servant@ API types. The
@@ -41,6 +45,9 @@ module Servant.API.TypeLevel (
4145 -- ** Logic
4246 Or,
4347 And,
48+ -- ** Fragment
49+ FragmentUnique,
50+ AtLeastOneFragment
4451 ) where
4552
4653
@@ -50,6 +57,7 @@ import Servant.API.Alternative
5057 (type (:<|>))
5158import Servant.API.Capture
5259 (Capture, CaptureAll)
60+import Servant.API.Fragment
5361import Servant.API.Header
5462 (Header)
5563import Servant.API.QueryParam
@@ -60,6 +68,8 @@ import Servant.API.Sub
6068 (type (:>))
6169import Servant.API.Verbs
6270 (Verb)
71+import Servant.API.UVerb
72+ (UVerb)
6373import GHC.TypeLits
6474 (ErrorMessage (..), TypeError)
6575
@@ -100,7 +110,7 @@ type family IsElem' a s :: Constraint
100110--
101111-- >>> ok (Proxy :: Proxy (IsElem ("bye" :> Get '[JSON] Int) SampleAPI))
102112-- ...
103−-- ... Could not deduce...
113+-- ... Could not ...
104114-- ...
105115--
106116-- An endpoint is considered within an api even if it is missing combinators
@@ -128,6 +138,7 @@ type family IsElem endpoint api :: Constraint where
128138 IsElem sa (QueryParam x y :> sb) = IsElem sa sb
129139 IsElem sa (QueryParams x y :> sb) = IsElem sa sb
130140 IsElem sa (QueryFlag x :> sb) = IsElem sa sb
141+ IsElem sa (Fragment x :> sb) = IsElem sa sb
131142 IsElem (Verb m s ct typ) (Verb m s ct' typ)
132143 = IsSubList ct ct'
133144 IsElem e e = ()
@@ -140,7 +151,7 @@ type family IsElem endpoint api :: Constraint where
140151--
141152-- >>> ok (Proxy :: Proxy (IsSubAPI (SampleAPI :<|> Get '[JSON] Int) SampleAPI))
142153-- ...
143−-- ... Could not deduce...
154+-- ... Could not ...
144155-- ...
145156--
146157-- This uses @IsElem@ for checking; thus the note there applies here.
@@ -163,7 +174,7 @@ type family AllIsElem xs api :: Constraint where
163174--
164175-- >>> ok (Proxy :: Proxy (IsIn (Get '[JSON] Int) (Header "h" Bool :> Get '[JSON] Int)))
165176-- ...
166−-- ... Could not deduce...
177+-- ... Could not ...
167178-- ...
168179type family IsIn (endpoint :: *) (api :: *) :: Constraint where
169180 IsIn e (sa :<|> sb) = Or (IsIn e sa) (IsIn e sb)
@@ -241,6 +252,43 @@ We might try to factor these our more cleanly, but the type synonyms and type
241252families are not evaluated (see https://ghc.haskell.org/trac/ghc/ticket/12048).
242253-}
243254
255+-- ** Fragment
256+
257+class FragmentUnique api => AtLeastOneFragment api
258+
259+-- | If fragment appeared in API endpoint twice, compile-time error would be raised.
260+--
261+-- >>> -- type FailAPI = Fragment Bool :> Fragment Int :> Get '[JSON] NoContent
262+-- >>> instance AtLeastOneFragment FailAPI
263+-- ...
264+-- ...Only one Fragment allowed per endpoint in api...
265+-- ...
266+-- ...In the instance declaration for...
267+instance AtLeastOneFragment (Verb m s ct typ)
268+
269+instance AtLeastOneFragment (UVerb m cts as)
270+
271+instance AtLeastOneFragment (Fragment a)
272+
273+type family FragmentUnique api :: Constraint where
274+ FragmentUnique (sa :<|> sb) = And (FragmentUnique sa) (FragmentUnique sb)
275+ FragmentUnique (Fragment a :> sa) = FragmentNotIn sa (Fragment a :> sa)
276+ FragmentUnique (x :> sa) = FragmentUnique sa
277+ FragmentUnique (Fragment a) = ()
278+ FragmentUnique x = ()
279+
280+type family FragmentNotIn api orig :: Constraint where
281+ FragmentNotIn (sa :<|> sb) orig =
282+ And (FragmentNotIn sa orig) (FragmentNotIn sb orig)
283+ FragmentNotIn (Fragment c :> sa) orig = TypeError (NotUniqueFragmentInApi orig)
284+ FragmentNotIn (x :> sa) orig = FragmentNotIn sa orig
285+ FragmentNotIn (Fragment c) orig = TypeError (NotUniqueFragmentInApi orig)
286+ FragmentNotIn x orig = ()
287+
288+type NotUniqueFragmentInApi api =
289+ 'Text "Only one Fragment allowed per endpoint in api ‘"
290+ ':<>: 'ShowType api
291+ ':<>: 'Text "’."
244292
245293-- $setup
246294--
@@ -248,6 +296,7 @@ families are not evaluated (see https://ghc.haskell.org/trac/ghc/ticket/12048).
248296--
249297-- >>> :set -XPolyKinds
250298-- >>> :set -XGADTs
299+-- >>> :set -XTypeSynonymInstances -XFlexibleInstances
251300-- >>> import Data.Proxy
252301-- >>> import Data.Type.Equality
253302-- >>> import Servant.API
@@ -255,4 +304,5 @@ families are not evaluated (see https://ghc.haskell.org/trac/ghc/ticket/12048).
255304-- >>> instance Show (OK ctx) where show _ = "OK"
256305-- >>> let ok :: ctx => Proxy ctx -> OK ctx; ok _ = OK
257306-- >>> type SampleAPI = "hello" :> Get '[JSON] Int :<|> "bye" :> Capture "name" String :> Post '[JSON, PlainText] Bool
307+-- >>> type FailAPI = Fragment Bool :> Fragment Int :> Get '[JSON] NoContent
258308-- >>> let sampleAPI = Proxy :: Proxy SampleAPI
servant/src/Servant/API/UVerb.hsnew file+127
@@ -0,0 +1,127 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE ConstraintKinds #-}
3+{-# LANGUAGE DataKinds #-}
4+{-# LANGUAGE DeriveGeneric #-}
5+{-# LANGUAGE FlexibleContexts #-}
6+{-# LANGUAGE FlexibleInstances #-}
7+{-# LANGUAGE MultiParamTypeClasses #-}
8+{-# LANGUAGE RankNTypes #-}
9+{-# LANGUAGE ScopedTypeVariables #-}
10+{-# LANGUAGE TypeFamilies #-}
11+{-# LANGUAGE TypeOperators #-}
12+{-# LANGUAGE UndecidableInstances #-}
13+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
14+
15+-- | An alternative to 'Verb' for end-points that respond with a resource value of any of an
16+-- open union of types, and specific status codes for each type in this union. (`UVerb` is
17+-- short for `UnionVerb`)
18+--
19+-- This can be used for returning (rather than throwing) exceptions in a server as in, say
20+-- @'[Report, WaiError]@; or responding with either a 303 forward with a location header, or
21+-- 201 created with a different body type, depending on the circumstances. (All of this can
22+-- be done with vanilla servant-server by throwing exceptions, but it can't be represented in
23+-- the API types without something like `UVerb`.)
24+--
25+-- See <https://docs.servant.dev/en/stable/cookbook/uverb/UVerb.html> for a working example.
26+module Servant.API.UVerb
27+ ( UVerb,
28+ HasStatus (StatusOf),
29+ statusOf,
30+ HasStatuses (Statuses, statuses),
31+ WithStatus (..),
32+ module Servant.API.UVerb.Union,
33+ )
34+where
35+
36+import Data.Proxy (Proxy (Proxy))
37+import GHC.TypeLits (Nat)
38+import Network.HTTP.Types (Status, StdMethod)
39+import Servant.API.ContentTypes (JSON, PlainText, FormUrlEncoded, OctetStream, NoContent, MimeRender(mimeRender), MimeUnrender(mimeUnrender))
40+import Servant.API.Status (KnownStatus, statusVal)
41+import Servant.API.ResponseHeaders (Headers)
42+import Servant.API.UVerb.Union
43+
44+class KnownStatus (StatusOf a) => HasStatus (a :: *) where
45+ type StatusOf (a :: *) :: Nat
46+
47+statusOf :: forall a proxy. HasStatus a => proxy a -> Status
48+statusOf = const (statusVal (Proxy :: Proxy (StatusOf a)))
49+
50+-- | If an API can respond with 'NoContent' we assume that this will happen
51+-- with the status code 204 No Content. If this needs to be overridden,
52+-- 'WithStatus' can be used.
53+instance HasStatus NoContent where
54+ type StatusOf NoContent = 204
55+
56+class HasStatuses (as :: [*]) where
57+ type Statuses (as :: [*]) :: [Nat]
58+ statuses :: Proxy as -> [Status]
59+
60+instance HasStatuses '[] where
61+ type Statuses '[] = '[]
62+ statuses _ = []
63+
64+instance (HasStatus a, HasStatuses as) => HasStatuses (a ': as) where
65+ type Statuses (a ': as) = StatusOf a ': Statuses as
66+ statuses _ = statusOf (Proxy :: Proxy a) : statuses (Proxy :: Proxy as)
67+
68+-- | A simple newtype wrapper that pairs a type with its status code. It
69+-- implements all the content types that Servant ships with by default.
70+newtype WithStatus (k :: Nat) a = WithStatus a
71+ deriving (Eq, Show)
72+
73+-- | an instance of this typeclass assigns a HTTP status code to a return type
74+--
75+-- Example:
76+--
77+-- @
78+-- data NotFoundError = NotFoundError String
79+--
80+-- instance HasStatus NotFoundError where
81+-- type StatusOf NotFoundError = 404
82+-- @
83+--
84+-- You can also use the convience newtype wrapper 'WithStatus' if you want to
85+-- avoid writing a 'HasStatus' instance manually. It also has the benefit of
86+-- showing the status code in the type; which might aid in readability.
87+instance KnownStatus n => HasStatus (WithStatus n a) where
88+ type StatusOf (WithStatus n a) = n
89+
90+instance HasStatus a => HasStatus (Headers ls a) where
91+ type StatusOf (Headers ls a) = StatusOf a
92+
93+-- | A variant of 'Verb' that can have any of a number of response values and status codes.
94+--
95+-- FUTUREWORK: it would be nice to make 'Verb' a special case of 'UVerb', and only write
96+-- instances for 'HasServer' etc. for the latter, getting them for the former for free.
97+-- Something like:
98+--
99+-- @type Verb method statusCode contentTypes a = UVerb method contentTypes [WithStatus statusCode a]@
100+--
101+-- Backwards compatibility is tricky, though: this type alias would mean people would have to
102+-- use 'respond' instead of 'pure' or 'return', so all old handlers would have to be rewritten.
103+data UVerb (method :: StdMethod) (contentTypes :: [*]) (as :: [*])
104+
105+instance {-# OVERLAPPING #-} MimeRender JSON a => MimeRender JSON (WithStatus _status a) where
106+ mimeRender contentTypeProxy (WithStatus a) = mimeRender contentTypeProxy a
107+
108+instance {-# OVERLAPPING #-} MimeRender PlainText a => MimeRender PlainText (WithStatus _status a) where
109+ mimeRender contentTypeProxy (WithStatus a) = mimeRender contentTypeProxy a
110+
111+instance {-# OVERLAPPING #-} MimeRender FormUrlEncoded a => MimeRender FormUrlEncoded (WithStatus _status a) where
112+ mimeRender contentTypeProxy (WithStatus a) = mimeRender contentTypeProxy a
113+
114+instance {-# OVERLAPPING #-} MimeRender OctetStream a => MimeRender OctetStream (WithStatus _status a) where
115+ mimeRender contentTypeProxy (WithStatus a) = mimeRender contentTypeProxy a
116+
117+instance {-# OVERLAPPING #-} MimeUnrender JSON a => MimeUnrender JSON (WithStatus _status a) where
118+ mimeUnrender contentTypeProxy input = WithStatus <$> mimeUnrender contentTypeProxy input
119+
120+instance {-# OVERLAPPING #-} MimeUnrender PlainText a => MimeUnrender PlainText (WithStatus _status a) where
121+ mimeUnrender contentTypeProxy input = WithStatus <$> mimeUnrender contentTypeProxy input
122+
123+instance {-# OVERLAPPING #-} MimeUnrender FormUrlEncoded a => MimeUnrender FormUrlEncoded (WithStatus _status a) where
124+ mimeUnrender contentTypeProxy input = WithStatus <$> mimeUnrender contentTypeProxy input
125+
126+instance {-# OVERLAPPING #-} MimeUnrender OctetStream a => MimeUnrender OctetStream (WithStatus _status a) where
127+ mimeUnrender contentTypeProxy input = WithStatus <$> mimeUnrender contentTypeProxy input
servant/src/Servant/API/UVerb/Union.hsnew file+147
@@ -0,0 +1,147 @@
1+{-# LANGUAGE ConstraintKinds #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE ExplicitNamespaces #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE KindSignatures #-}
7+{-# LANGUAGE MultiParamTypeClasses #-}
8+{-# LANGUAGE PolyKinds #-}
9+{-# LANGUAGE RankNTypes #-}
10+{-# LANGUAGE TypeFamilies #-}
11+{-# LANGUAGE TypeOperators #-}
12+{-# LANGUAGE UndecidableInstances #-}
13+
14+{-
15+
16+Copyright Dennis Gosnell (c) 2017-2018
17+
18+All rights reserved.
19+
20+Redistribution and use in source and binary forms, with or without
21+modification, are permitted provided that the following conditions are met:
22+
23+ * Redistributions of source code must retain the above copyright
24+ notice, this list of conditions and the following disclaimer.
25+
26+ * Redistributions in binary form must reproduce the above
27+ copyright notice, this list of conditions and the following
28+ disclaimer in the documentation and/or other materials provided
29+ with the distribution.
30+
31+ * Neither the name of Author name here nor the names of other
32+ contributors may be used to endorse or promote products derived
33+ from this software without specific prior written permission.
34+
35+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
36+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
37+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
38+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
39+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
40+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
41+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
42+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
43+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
44+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
45+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
46+
47+-}
48+
49+-- | Type-level code for implementing and using 'UVerb'. Heavily inspired by
50+-- [world-peace](https://github.com/cdepillabout/world-peace).
51+module Servant.API.UVerb.Union
52+( IsMember
53+, Unique
54+, Union
55+, inject
56+, eject
57+, foldMapUnion
58+, matchUnion
59+)
60+where
61+
62+import Data.Proxy (Proxy)
63+import Data.SOP.BasicFunctors (I, unI)
64+import Data.SOP.Constraint
65+import Data.SOP.NS
66+import Data.Type.Bool (If)
67+import Data.Type.Equality (type (==))
68+import GHC.TypeLits
69+
70+type Union = NS I
71+
72+-- | Convenience function to apply a function to an unknown union element using a type class.
73+-- All elements of the union must have instances in the type class, and the function is
74+-- applied unconditionally.
75+--
76+-- See also: 'matchUnion'.
77+foldMapUnion ::
78+ forall (c :: * -> Constraint) (a :: *) (as :: [*]).
79+ All c as =>
80+ Proxy c ->
81+ (forall x. c x => x -> a) ->
82+ Union as ->
83+ a
84+foldMapUnion proxy go = cfoldMap_NS proxy (go . unI)
85+
86+-- | Convenience function to extract a union element using 'cast', ie. return the value if the
87+-- selected type happens to be the actual type of the union in this value, or 'Nothing'
88+-- otherwise.
89+--
90+-- See also: 'foldMapUnion'.
91+matchUnion :: forall (a :: *) (as :: [*]). (IsMember a as) => Union as -> Maybe a
92+matchUnion = fmap unI . eject
93+
94+-- * Stuff stolen from 'Data.WorldPeace" but for generics-sop
95+
96+-- (this could to go sop-core, except it's probably too specialized to the servant use-case.)
97+
98+type IsMember (a :: u) (as :: [u]) = (Unique as, CheckElemIsMember a as, UElem a as)
99+
100+class UElem x xs where
101+ inject :: f x -> NS f xs
102+ eject :: NS f xs -> Maybe (f x)
103+
104+instance {-# OVERLAPPING #-} UElem x (x ': xs) where
105+ inject = Z
106+ eject (Z x) = Just x
107+ eject _ = Nothing
108+
109+instance {-# OVERLAPPING #-} UElem x xs => UElem x (x' ': xs) where
110+ inject = S . inject
111+ eject (Z _) = Nothing
112+ eject (S ns) = eject ns
113+
114+-- | Check whether @a@ is in list. This will throw nice errors if the element is not in the
115+-- list, or if there is a duplicate in the list.
116+type family CheckElemIsMember (a :: k) (as :: [k]) :: Constraint where
117+ CheckElemIsMember a as =
118+ If (Elem a as) (() :: Constraint) (TypeError (NoElementError a as))
119+
120+type NoElementError (r :: k) (rs :: [k]) =
121+ 'Text "Expected one of:"
122+ ':$$: 'Text " " ':<>: 'ShowType rs
123+ ':$$: 'Text "But got:"
124+ ':$$: 'Text " " ':<>: 'ShowType r
125+
126+type DuplicateElementError (rs :: [k]) =
127+ 'Text "Duplicate element in list:"
128+ ':$$: 'Text " " ':<>: 'ShowType rs
129+
130+type family Elem (x :: k) (xs :: [k]) :: Bool where
131+ Elem x (x ': _) = 'True
132+ Elem x (_ ': xs) = Elem x xs
133+ Elem _ '[] = 'False
134+
135+type family Unique xs :: Constraint where
136+ Unique xs = If (Nubbed xs == 'True) (() :: Constraint) (TypeError (DuplicateElementError xs))
137+
138+type family Nubbed xs :: Bool where
139+ Nubbed '[] = 'True
140+ Nubbed (x ': xs) = If (Elem x xs) 'False (Nubbed xs)
141+
142+_testNubbed :: ( ( Nubbed '[Bool, Int, Int] ~ 'False
143+ , Nubbed '[Int, Int, Bool] ~ 'False
144+ , Nubbed '[Int, Bool] ~ 'True
145+ )
146+ => a) -> a
147+_testNubbed a = a
servant/src/Servant/API/Verbs.hs+2−1
@@ -128,7 +128,8 @@ type DeleteNoContent = NoContentVerb 'DELETE
128128type PatchNoContent = NoContentVerb 'PATCH
129129-- | 'PUT' with 204 status code.
130130type PutNoContent = NoContentVerb 'PUT
131−
131+-- | 'HEAD' with 204 status code.
132+type HeadNoContent = NoContentVerb 'HEAD
132133
133134-- ** 205 Reset Content
134135--
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+112−14
@@ -1,13 +1,19 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
12{-# LANGUAGE ConstraintKinds #-}
3+{-# LANGUAGE CPP #-}
24{-# LANGUAGE DataKinds #-}
35{-# LANGUAGE FlexibleContexts #-}
46{-# LANGUAGE FlexibleInstances #-}
57{-# LANGUAGE FunctionalDependencies #-}
8+{-# LANGUAGE InstanceSigs #-}
69{-# LANGUAGE PolyKinds #-}
10+{-# LANGUAGE QuantifiedConstraints #-}
711{-# LANGUAGE ScopedTypeVariables #-}
12+{-# LANGUAGE TypeApplications #-}
813{-# LANGUAGE TypeFamilies #-}
914{-# LANGUAGE TypeOperators #-}
1015{-# LANGUAGE UndecidableInstances #-}
16+
1117{-# OPTIONS_HADDOCK not-home #-}
1218
1319-- | Type safe generation of internal links.
@@ -17,6 +23,7 @@
1723-- >>> :set -XDataKinds -XTypeFamilies -XTypeOperators
1824-- >>> import Servant.API
1925-- >>> import Servant.Links
26+-- >>> import Web.HttpApiData (toUrlPiece)
2027-- >>> import Data.Proxy
2128-- >>>
2229-- >>> type Hello = "hello" :> Get '[JSON] Int
@@ -54,7 +61,7 @@
5461-- >>> toUrlPiece $ safeLink api without
5562-- "bye"
5663--
57−-- If you would like create a helper for generating links only within that API,
64+-- If you would like to create a helper for generating links only within that API,
5865-- you can partially apply safeLink if you specify a correct type signature
5966-- like so:
6067--
@@ -65,7 +72,7 @@
6572-- >>> apiLink = safeLink api
6673-- >>> :}
6774--
68−-- `safeLink'` allows to make specialise the output:
75+-- `safeLink'` allows you to specialise the output:
6976--
7077-- >>> safeLink' toUrlPiece api without
7178-- "bye"
@@ -85,7 +92,7 @@
8592-- >>> let bad_link = Proxy :: Proxy ("hello" :> Delete '[JSON] NoContent)
8693-- >>> safeLink api bad_link
8794-- ...
88−-- ...Could not deduce...
95+-- ...Could not ...
8996-- ...
9097--
9198-- This error is essentially saying that the type family couldn't find
@@ -120,13 +127,13 @@ module Servant.Links (
120127 , Param (..)
121128 , linkSegments
122129 , linkQueryParams
130+ , linkFragment
123131) where
124132
125133import Data.List
134+import Data.Constraint
126135import Data.Proxy
127136 (Proxy (..))
128−import Data.Semigroup
129− ((<>))
130137import Data.Singletons.Bool
131138 (SBool (..), SBoolI (..))
132139import qualified Data.Text as Text
@@ -134,7 +141,7 @@ import qualified Data.Text.Encoding as TE
134141import Data.Type.Bool
135142 (If)
136143import GHC.TypeLits
137− (KnownSymbol, symbolVal)
144+ (KnownSymbol, TypeError, symbolVal)
138145import Network.URI
139146 (URI (..), escapeURIString, isUnreserved)
140147import Prelude ()
@@ -152,6 +159,8 @@ import Servant.API.Empty
152159 (EmptyAPI (..))
153160import Servant.API.Experimental.Auth
154161 (AuthProtect)
162+import Servant.API.Fragment
163+ (Fragment)
155164import Servant.API.Generic
156165import Servant.API.Header
157166 (Header')
@@ -161,10 +170,12 @@ import Servant.API.IsSecure
161170 (IsSecure)
162171import Servant.API.Modifiers
163172 (FoldRequired)
173+import Servant.API.NamedRoutes
174+ (NamedRoutes)
164175import Servant.API.QueryParam
165176 (QueryFlag, QueryParam', QueryParams)
166177import Servant.API.Raw
167− (Raw)
178+ (Raw, RawM)
168179import Servant.API.RemoteHost
169180 (RemoteHost)
170181import Servant.API.ReqBody
@@ -173,14 +184,20 @@ import Servant.API.Stream
173184 (Stream, StreamBody')
174185import Servant.API.Sub
175186 (type (:>))
187+import Servant.API.TypeErrors
176188import Servant.API.TypeLevel
189+import Servant.API.UVerb
177190import Servant.API.Vault
178191 (Vault)
179192import Servant.API.Verbs
180193 (Verb, NoContentVerb)
181194import Servant.API.WithNamedContext
182195 (WithNamedContext)
196+import Servant.API.WithResource
197+ (WithResource)
183198import Web.HttpApiData
199+import Data.Kind
200+ (Type)
184201
185202-- | A safe link datatype.
186203-- The only way of constructing a 'Link' is using 'safeLink', which means any
@@ -188,10 +205,13 @@ import Web.HttpApiData
188205data Link = Link
189206 { _segments :: [Escaped]
190207 , _queryParams :: [Param]
208+ , _fragment :: Fragment'
191209 } deriving Show
192210
193211newtype Escaped = Escaped String
194212
213+type Fragment' = Maybe String
214+
195215escaped :: String -> Escaped
196216escaped = Escaped . escapeURIString isUnreserved
197217
@@ -208,11 +228,14 @@ linkSegments = map getEscaped . _segments
208228linkQueryParams :: Link -> [Param]
209229linkQueryParams = _queryParams
210230
231+linkFragment :: Link -> Fragment'
232+linkFragment = _fragment
233+
211234instance ToHttpApiData Link where
212235 toHeader = TE.encodeUtf8 . toUrlPiece
213236 toUrlPiece l =
214237 let uri = linkURI l
215− in Text.pack $ uriPath uri ++ uriQuery uri
238+ in Text.pack $ uriPath uri ++ uriQuery uri ++ uriFragment uri
216239
217240-- | Query parameter.
218241data Param
@@ -228,6 +251,9 @@ addQueryParam :: Param -> Link -> Link
228251addQueryParam qp l =
229252 l { _queryParams = _queryParams l <> [qp] }
230253
254+addFragment :: Fragment' -> Link -> Link
255+addFragment fr l = l { _fragment = fr }
256+
231257-- | Transform 'Link' into 'URI'.
232258--
233259-- >>> type API = "something" :> Get '[JSON] Int
@@ -245,7 +271,7 @@ addQueryParam qp l =
245271-- >>> type SomeRoute = "abc" :> Capture "email" String :> Put '[JSON] ()
246272-- >>> let someRoute = Proxy :: Proxy SomeRoute
247273-- >>> safeLink someRoute someRoute "test@example.com"
248−-- Link {_segments = ["abc","test%40example.com"], _queryParams = []}
274+-- Link {_segments = ["abc","test%40example.com"], _queryParams = [], _fragment = Nothing}
249275--
250276-- >>> linkURI $ safeLink someRoute someRoute "test@example.com"
251277-- abc/test%40example.com
@@ -269,11 +295,12 @@ data LinkArrayElementStyle
269295-- sum?x=1&x=2&x=3
270296--
271297linkURI' :: LinkArrayElementStyle -> Link -> URI
272−linkURI' addBrackets (Link segments q_params) =
298+linkURI' addBrackets (Link segments q_params mfragment) =
273299 URI mempty -- No scheme (relative)
274300 Nothing -- Or authority (relative)
275301 (intercalate "/" $ map getEscaped segments)
276− (makeQueries q_params) mempty
302+ (makeQueries q_params)
303+ (makeFragment mfragment)
277304 where
278305 makeQueries :: [Param] -> String
279306 makeQueries [] = ""
@@ -285,6 +312,10 @@ linkURI' addBrackets (Link segments q_params) =
285312 makeQuery (SingleParam k v) = escape k <> "=" <> escape (Text.unpack v)
286313 makeQuery (FlagParam k) = escape k
287314
315+ makeFragment :: Fragment' -> String
316+ makeFragment Nothing = ""
317+ makeFragment (Just fr) = "#" <> escape fr
318+
288319 style = case addBrackets of
289320 LinkArrayElementBracket -> "[]="
290321 LinkArrayElementPlain -> "="
@@ -310,7 +341,7 @@ safeLink'
310341 -> Proxy api -- ^ The whole API that this endpoint is a part of
311342 -> Proxy endpoint -- ^ The API endpoint you would like to point to
312343 -> MkLink endpoint a
313−safeLink' toA _ endpoint = toLink toA endpoint (Link mempty mempty)
344+safeLink' toA _ endpoint = toLink toA endpoint (Link mempty mempty mempty)
314345
315346-- | Create all links in an API.
316347--
@@ -341,7 +372,7 @@ allLinks'
341372 => (Link -> a)
342373 -> Proxy api
343374 -> MkLink api a
344−allLinks' toA api = toLink toA api (Link mempty mempty)
375+allLinks' toA api = toLink toA api (Link mempty mempty mempty)
345376
346377-------------------------------------------------------------------------------
347378-- Generics
@@ -529,6 +560,10 @@ instance HasLink sub => HasLink (WithNamedContext name context sub) where
529560 type MkLink (WithNamedContext name context sub) a = MkLink sub a
530561 toLink toA _ = toLink toA (Proxy :: Proxy sub)
531562
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+
532567instance HasLink sub => HasLink (RemoteHost :> sub) where
533568 type MkLink (RemoteHost :> sub) a = MkLink sub a
534569 toLink = simpleToLink (Proxy :: Proxy sub)
@@ -554,16 +589,60 @@ instance HasLink Raw where
554589 type MkLink Raw a = a
555590 toLink toA _ = toA
556591
592+instance HasLink RawM where
593+ type MkLink RawM a = a
594+ toLink toA _ = toA
595+
557596instance HasLink (Stream m status fr ct a) where
558597 type MkLink (Stream m status fr ct a) r = r
559598 toLink toA _ = toA
560599
600+-- UVerb instances
601+instance HasLink (UVerb m ct a) where
602+ type MkLink (UVerb m ct a) r = r
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
632+
561633-- AuthProtext instances
562634instance HasLink sub => HasLink (AuthProtect tag :> sub) where
563635 type MkLink (AuthProtect tag :> sub) a = MkLink sub a
564636 toLink = simpleToLink (Proxy :: Proxy sub)
565637
566−-- | Helper for implemneting 'toLink' for combinators not affecting link
638+instance (HasLink sub, ToHttpApiData v)
639+ => HasLink (Fragment v :> sub) where
640+ type MkLink (Fragment v :> sub) a = v -> MkLink sub a
641+ toLink toA _ l mv =
642+ toLink toA (Proxy :: Proxy sub) $
643+ addFragment ((Just . Text.unpack . toQueryParam) mv) l
644+
645+-- | Helper for implementing 'toLink' for combinators not affecting link
567646-- structure.
568647simpleToLink
569648 :: forall sub a combinator.
@@ -579,3 +658,22 @@ simpleToLink _ toA _ = toLink toA (Proxy :: Proxy sub)
579658-- $setup
580659-- >>> import Servant.API
581660-- >>> 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+3−1
@@ -48,7 +48,7 @@ comprehensiveAPIWithoutStreaming = Proxy
4848type ComprehensiveAPIWithoutStreamingOrRaw' endpoint =
4949 GET
5050 :<|> "get-int" :> Get '[JSON] Int
51− :<|> "capture" :> Capture' '[Description "example description"] "foo" Int :> GET
51+ :<|> "capture" :> Capture' '[Description "example description"] "bar" Int :> GET
5252 :<|> "capture-lenient" :> Capture' '[Lenient] "foo" Int :> GET
5353 :<|> "header" :> Header "foo" Int :> GET
5454 :<|> "header-lenient" :> Header' '[Required, Lenient] "bar" Int :> GET
@@ -71,6 +71,8 @@ type ComprehensiveAPIWithoutStreamingOrRaw' endpoint =
7171 :<|> "summary" :> Summary "foo" :> GET
7272 :<|> "description" :> Description "foo" :> GET
7373 :<|> "alternative" :> ("left" :> GET :<|> "right" :> GET)
74+ :<|> "fragment" :> Fragment Int :> GET
75+ :<|> "resource" :> WithResource Int :> GET
7476 :<|> endpoint
7577
7678type ComprehensiveAPIWithoutStreamingOrRaw = ComprehensiveAPIWithoutStreamingOrRaw' EmptyEndpoint
servant/src/Servant/Types/SourceT.hs+4−1
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
12{-# LANGUAGE DeriveFunctor #-}
23{-# LANGUAGE GADTs #-}
34{-# LANGUAGE RankNTypes #-}
@@ -154,8 +155,10 @@ instance (Applicative m, Show1 m, Show a) => Show (StepT m a) where
154155-- | >>> lift [1,2,3] :: StepT [] Int
155156-- Effect [Yield 1 Stop,Yield 2 Stop,Yield 3 Stop]
156157--
158+#if !MIN_VERSION_transformers(0,6,0)
157159instance MonadTrans StepT where
158160 lift = Effect . fmap (`Yield` Stop)
161+#endif
159162
160163instance MFunctor StepT where
161164 hoist f = go where
@@ -319,7 +322,7 @@ fromActionStep stop action = loop where
319322-- | Read file.
320323--
321324-- >>> foreach fail BS.putStr (readFile "servant.cabal")
322−-- cabal-version: >=1.10
325+-- cabal-version: 2.2
323326-- name: servant
324327-- ...
325328--
servant/src/Servant/Utils/Links.hsdeleted−6
@@ -1,6 +0,0 @@
1−module Servant.Utils.Links
2− {-# DEPRECATED "Use Servant.Links." #-}
3− ( module Servant.Links )
4− where
5−
6−import Servant.Links
servant/test/Servant/API/ContentTypesSpec.hs+11
@@ -33,6 +33,8 @@ import Data.String.Conversions
3333import qualified Data.Text as TextS
3434import qualified Data.Text.Encoding as TextSE
3535import qualified Data.Text.Lazy as TextL
36+import Control.Exception
37+ (evaluate)
3638import GHC.Generics
3739import Test.Hspec
3840import Test.QuickCheck
@@ -78,6 +80,15 @@ spec = describe "Servant.API.ContentTypes" $ do
7880 it "has mimeUnrender reverse mimeRender for valid top-level json " $ do
7981 property $ \x -> mimeUnrender p (mimeRender p x) == Right (x::SomeData)
8082
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+
8192 describe "The PlainText Content-Type type" $ do
8293 let p = Proxy :: Proxy PlainText
8394
servant/test/Servant/API/ResponseHeadersSpec.hs+11
@@ -2,10 +2,14 @@
22{-# LANGUAGE OverloadedStrings #-}
33module Servant.API.ResponseHeadersSpec where
44
5+import Data.Proxy
6+import GHC.TypeLits
57import Test.Hspec
68
9+import Servant.API.ContentTypes
710import Servant.API.Header
811import Servant.API.ResponseHeaders
12+import Servant.API.UVerb
913
1014spec :: Spec
1115spec = describe "Servant.API.ResponseHeaders" $ do
@@ -28,3 +32,10 @@ spec = describe "Servant.API.ResponseHeaders" $ do
2832 it "does not add a header" $ do
2933 let val = noHeader 5 :: Headers '[Header "test" Int] Int
3034 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+
servant/test/Servant/API/StreamSpec.hs+1−1
@@ -90,7 +90,7 @@ runRenderFrames :: (SourceT Identity a -> SourceT Identity LBS.ByteString) -> [a
9090runRenderFrames f = fmap mconcat . runExcept . runSourceT . f . source
9191
9292runUnrenderFrames :: (SourceT Identity b -> SourceT Identity a) -> [b] -> [Either String a]
93−runUnrenderFrames f = go . Effect . flip unSourceT return . f . source where
93+runUnrenderFrames f = go . Effect . (\x -> unSourceT x return) . f . source where
9494 go :: StepT Identity a -> [Either String a]
9595 go Stop = []
9696 go (Error err) = [Left err]
servant/test/Servant/LinksSpec.hs+18−1
@@ -13,9 +13,9 @@ import Test.Hspec
1313 (Expectation, Spec, describe, it, shouldBe)
1414
1515import Servant.API
16+import Servant.Links
1617import Servant.Test.ComprehensiveAPI
1718 (comprehensiveAPIWithoutRaw)
18−import Servant.Links
1919
2020type TestApi =
2121 -- Capture and query params
@@ -26,6 +26,12 @@ type TestApi =
2626 -- Flags
2727 :<|> "balls" :> QueryFlag "bouncy" :> QueryFlag "fast" :> Delete '[JSON] NoContent
2828
29+ -- Fragment
30+ :<|> "say" :> Fragment String :> Get '[JSON] NoContent
31+
32+ -- UVerb
33+ :<|> "uverb-example" :> UVerb 'GET '[JSON] '[WithStatus 200 NoContent]
34+
2935 -- All of the verbs
3036 :<|> "get" :> Get '[JSON] NoContent
3137 :<|> "put" :> Put '[JSON] NoContent
@@ -70,12 +76,20 @@ spec = describe "Servant.Links" $ do
7076 ["roads", "lead", "to", "rome"]
7177 `shouldBeLink` "all/roads/lead/to/rome"
7278
79+ it "generated correct links for UVerbs" $ do
80+ apiLink (Proxy :: Proxy ("uverb-example" :> UVerb 'GET '[JSON] '[WithStatus 200 NoContent]))
81+ `shouldBeLink` "uverb-example"
82+
7383 it "generates correct links for query flags" $ do
7484 let l1 = Proxy :: Proxy ("balls" :> QueryFlag "bouncy"
7585 :> QueryFlag "fast" :> Delete '[JSON] NoContent)
7686 apiLink l1 True True `shouldBeLink` "balls?bouncy&fast"
7787 apiLink l1 False True `shouldBeLink` "balls?fast"
7888
89+ it "generates correct link for fragment" $ do
90+ let l1 = Proxy :: Proxy ("say" :> Fragment String :> Get '[JSON] NoContent)
91+ apiLink l1 "something" `shouldBeLink` "say#something"
92+
7993 it "generates correct links for all of the verbs" $ do
8094 apiLink (Proxy :: Proxy ("get" :> Get '[JSON] NoContent)) `shouldBeLink` "get"
8195 apiLink (Proxy :: Proxy ("put" :> Put '[JSON] NoContent)) `shouldBeLink` "put"
@@ -92,6 +106,9 @@ spec = describe "Servant.Links" $ do
92106 let firstLink :<|> _ = allLinks comprehensiveAPIWithoutRaw
93107 firstLink `shouldBeLink` ""
94108
109+-- The doctests below aren't run on CI, setting that up is tricky.
110+-- They are run by makefile rule, however.
111+
95112-- |
96113-- Before https://github.com/CRogers/should-not-typecheck/issues/5 is fixed,
97114-- we'll just use doctest
servant/test/doctests.hsdeleted−27
@@ -1,27 +0,0 @@
1−-----------------------------------------------------------------------------
2−-- |
3−-- Module : Main (doctests)
4−-- Copyright : (C) 2012-14 Edward Kmett
5−-- License : BSD-style (see the file LICENSE)
6−-- Maintainer : Edward Kmett <ekmett@gmail.com>
7−-- Stability : provisional
8−-- Portability : portable
9−--
10−-- This module provides doctests for a project based on the actual versions
11−-- of the packages it was built with. It requires a corresponding Setup.lhs
12−-- to be added to the project
13−-----------------------------------------------------------------------------
14−module Main where
15−
16−import Build_doctests
17− (flags, module_sources, pkgs)
18−import Data.Foldable
19− (traverse_)
20−import Test.DocTest
21−
22−main :: IO ()
23−main = do
24− traverse_ putStrLn args
25− doctest args
26− where
27− args = flags ++ pkgs ++ module_sources
stack.yaml+5−17
@@ -1,32 +1,20 @@
1−# Let's try to keep resolver at the first day of the month
2−resolver: nightly-2018-09-28 # Last nightly with GHC-8.4.3
1+resolver: lts-18.5
32packages:
4−- servant-client/
53- servant-client-core/
4+- servant-client/
65- servant-docs/
76- servant-foreign/
7+- servant-http-streams/
88- servant-server/
99- servant/
1010
1111- servant-conduit
1212- servant-machines/
1313- servant-pipes/
14+- servant-swagger/
1415
1516# allow-newer: true # ignores all bounds, that's a sledgehammer
1617# - doc/tutorial/
1718
1819extra-deps:
19−- base-compat-0.10.5
20−- conduit-1.3.1
21−- hspec-2.6.0
22−- hspec-core-2.6.0
23−- hspec-discover-2.6.0
24−- http-api-data-0.4
25−- http-media-0.7.1.3
26−- network-2.8.0.0
27−- pipes-safe-2.3.1
28−- QuickCheck-2.12.6.1
29−- resourcet-1.2.2
30−- sop-core-0.4.0.0
31−- wai-extra-3.0.24.3
32−- tasty-1.1.0.4
20+- hspec-wai-0.10.1
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