git.iko.soy/typeable/servant
on master help sign in
swap
b3279d9250 ahead, 0 behind
218 files changed+8654−1304
since splitsnapshots
unifiedsplit
.github/run-ghcjs-tests.sh+14 .github/workflows/master.yml+147 .gitignore+2 .travis.yml−423 CONTRIBUTING.md+4−2 Makefile−32 README.md+7−21 cabal.ghcjs.project+5−1 cabal.haskell-ci−25 cabal.project+13−32 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/1580+12 changelog.d/1589+2 changelog.d/1595+2 changelog.d/servant-docs-curl+16 doc/Makefile+1−1 doc/conf.py+1−2 doc/cookbook/basic-auth/basic-auth.cabal+3−3 doc/cookbook/basic-streaming/basic-streaming.cabal+3−3 doc/cookbook/curl-mock/CurlMock.lhs−1 doc/cookbook/curl-mock/curl-mock.cabal+6−3 doc/cookbook/custom-errors/custom-errors.cabal+3−3 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/file-upload.cabal+3−3 doc/cookbook/generic/generic.cabal+3−3 doc/cookbook/hoist-server-with-context/hoist-server-with-context.cabal+4−4 doc/cookbook/https/https.cabal+4−4 doc/cookbook/index.rst+3−2 doc/cookbook/jwt-and-basic-auth/jwt-and-basic-auth.cabal+4−4 doc/cookbook/open-id-connect/OpenIdConnect.cabal+3−3 doc/cookbook/pagination/pagination.cabal+3−3 doc/cookbook/sentry/sentry.cabal+3−3 doc/cookbook/structuring-apis/structuring-apis.cabal+3−3 doc/cookbook/testing/testing.cabal+3−3 doc/cookbook/using-custom-monad/using-custom-monad.cabal+3−3 doc/cookbook/using-free-client/UsingFreeClient.lhs+1−1 doc/cookbook/using-free-client/using-free-client.cabal+3−3 doc/cookbook/uverb/UVerb.lhs+9−3 doc/cookbook/uverb/uverb.cabal+6−4 doc/links.rst+1−1 doc/tutorial/ApiType.lhs+27 doc/tutorial/Authentication.lhs+1−2 doc/tutorial/index.rst+1−37 doc/tutorial/install.rst+68 doc/tutorial/tutorial.cabal+6−9 ghcjs.nix+22 nix/README.md+18 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-auth/servant-auth-client/LICENSE+31 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+134 servant-auth/servant-auth-server/src/Servant/Auth/Server.hs+180 servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal.hs+70 servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/AddSetCookie.hs+106 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+182 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+72 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+112 servant-auth/servant-auth-server/src/Servant/Auth/Server/SetCookieOrphan.hs+3 servant-auth/servant-auth-server/test/Servant/Auth/ServerSpec.hs+607 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+50 servant-client-core/servant-client-core.cabal+17−16 servant-client-core/src/Servant/Client/Core.hs+1 servant-client-core/src/Servant/Client/Core/BasicAuth.hs−2 servant-client-core/src/Servant/Client/Core/HasClient.hs+226−32 servant-client-core/src/Servant/Client/Core/Reexport.hs+4 servant-client-core/src/Servant/Client/Core/Request.hs+26−11 servant-client-core/src/Servant/Client/Generic.hs+8−11 servant-client-core/test/Servant/Client/Core/RequestSpec.hs+12 servant-client-ghcjs/servant-client-ghcjs.cabal+6−6 servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs+8−5 servant-client/CHANGELOG.md+50 servant-client/servant-client.cabal+25−18 servant-client/src/Servant/Client/Internal/HttpClient.hs+19−14 servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs+5−7 servant-client/test/Servant/BrokenSpec.hs+71 servant-client/test/Servant/ClientTestUtils.hs+115−33 servant-client/test/Servant/FailSpec.hs+3−5 servant-client/test/Servant/GenericSpec.hs+37 servant-client/test/Servant/SuccessSpec.hs+59−27 servant-conduit/servant-conduit.cabal+8−8 servant-docs/CHANGELOG.md+28 servant-docs/example/greet.hs+4−4 servant-docs/example/greet.md+32−1 servant-docs/golden/comprehensive.md+24−2 servant-docs/servant-docs.cabal+13−13 servant-docs/src/Servant/Docs/Internal.hs+133−25 servant-docs/test/Servant/DocsSpec.hs+6−2 servant-foreign/CHANGELOG.md+24 servant-foreign/servant-foreign.cabal+11−12 servant-foreign/src/Servant/Foreign.hs+22−19 servant-foreign/src/Servant/Foreign/Inflections.hs+18−13 servant-foreign/src/Servant/Foreign/Internal.hs+134−32 servant-foreign/test/Servant/ForeignSpec.hs+6−3 servant-http-streams/CHANGELOG.md+26 servant-http-streams/servant-http-streams.cabal+17−17 servant-http-streams/src/Servant/HttpStreams/Internal.hs+6−8 servant-http-streams/test/Servant/ClientSpec.hs+1−3 servant-machines/servant-machines.cabal+8−8 servant-pipes/CHANGELOG.md+11 servant-pipes/example/Main.hs+1−1 servant-pipes/servant-pipes.cabal+10−10 servant-server/CHANGELOG.md+43 servant-server/example/greet.hs+16−2 servant-server/servant-server.cabal+18−16 servant-server/src/Servant/Server.hs+34−11 servant-server/src/Servant/Server/Generic.hs+11−18 servant-server/src/Servant/Server/Internal.hs+138−61 servant-server/src/Servant/Server/Internal/BasicAuth.hs−2 servant-server/src/Servant/Server/Internal/Handler.hs+7−2 servant-server/src/Servant/Server/Internal/Router.hs+31−14 servant-server/src/Servant/Server/Internal/ServerError.hs+1−1 servant-server/src/Servant/Server/UVerb.hs+40−20 servant-server/test/Servant/Server/ErrorSpec.hs−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+127−6 servant-server/test/Servant/ServerSpec.hs+74−15 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+488 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+137 servant/servant.cabal+20−16 servant/src/Servant/API.hs+21−9 servant/src/Servant/API/Alternative.hs−2 servant/src/Servant/API/ContentTypes.hs+3−2 servant/src/Servant/API/Fragment.hs+25 servant/src/Servant/API/Modifiers.hs−2 servant/src/Servant/API/NamedRoutes.hs+10 servant/src/Servant/API/ResponseHeaders.hs+6−8 servant/src/Servant/API/Status.hs+6−1 servant/src/Servant/API/Stream.hs−2 servant/src/Servant/API/TypeErrors.hs+40 servant/src/Servant/API/TypeLevel.hs+59−9 servant/src/Servant/API/UVerb.hs+45−18 servant/src/Servant/API/UVerb/Union.hs+2−2 servant/src/Servant/API/Verbs.hs+2−1 servant/src/Servant/Links.hs+86−9 servant/src/Servant/Test/ComprehensiveAPI.hs+2−1 servant/src/Servant/Types/SourceT.hs+1−1 servant/test/Servant/API/ContentTypesSpec.hs+11 servant/test/Servant/API/StreamSpec.hs+1−1 servant/test/Servant/LinksSpec.hs+15−1 stack.yaml+2−1 stack.yaml.lock+19
.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+147
@@ -0,0 +1,147 @@
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+
24+ steps:
25+ - uses: actions/checkout@v2
26+
27+ - uses: haskell/actions/setup@v1
28+ id: setup-haskell-cabal
29+ name: Setup Haskell
30+ with:
31+ ghc-version: ${{ matrix.ghc }}
32+ cabal-version: ${{ matrix.cabal }}
33+
34+ - name: Freeze
35+ run: |
36+ cabal configure --enable-tests --enable-benchmarks --test-show-details=direct
37+ cabal freeze
38+
39+ - uses: actions/cache@v2.1.3
40+ name: Cache ~/.cabal/store and dist-newstyle
41+ with:
42+ path: |
43+ ${{ steps.setup-haskell-cabal.outputs.cabal-store }}
44+ dist-newstyle
45+ key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }}
46+ restore-keys: |
47+ ${{ runner.os }}-${{ matrix.ghc }}-
48+
49+ - name: Configure
50+ run: |
51+ cabal install --ignore-project -j2 doctest --constraint='doctest ^>=0.20'
52+
53+ - name: Build
54+ run: |
55+ cabal build all
56+
57+ - name: Test
58+ run: |
59+ cabal test all
60+
61+ - name: Run doctests
62+ run: |
63+ # Necessary for doctest to be found in $PATH
64+ export PATH="$HOME/.cabal/bin:$PATH"
65+
66+ DOCTEST="cabal repl --with-ghc=doctest --ghc-options=-w"
67+ (cd servant && eval $DOCTEST)
68+ (cd servant-client && eval $DOCTEST)
69+ (cd servant-client-core && eval $DOCTEST)
70+ (cd servant-http-streams && eval $DOCTEST)
71+ (cd servant-docs && eval $DOCTEST)
72+ (cd servant-foreign && eval $DOCTEST)
73+ (cd servant-server && eval $DOCTEST)
74+ (cd servant-machines && eval $DOCTEST)
75+ (cd servant-conduit && eval $DOCTEST)
76+ (cd servant-pipes && eval $DOCTEST)
77+
78+ stack:
79+ name: stack / ghc ${{ matrix.ghc }}
80+ runs-on: ubuntu-latest
81+ strategy:
82+ matrix:
83+ stack: ["2.7.5"]
84+ ghc: ["8.10.7"]
85+
86+ steps:
87+ - uses: actions/checkout@v2
88+
89+ - uses: haskell/actions/setup@v1
90+ name: Setup Haskell Stack
91+ with:
92+ ghc-version: ${{ matrix.ghc }}
93+ stack-version: ${{ matrix.stack }}
94+
95+ - uses: actions/cache@v2.1.3
96+ name: Cache ~/.stack
97+ with:
98+ path: ~/.stack
99+ key: ${{ runner.os }}-${{ matrix.ghc }}-stack
100+
101+ - name: Install dependencies
102+ run: |
103+ stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks --only-dependencies
104+
105+ - name: Build
106+ run: |
107+ stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks
108+
109+ - name: Test
110+ run: |
111+ stack test --system-ghc
112+
113+ ghcjs:
114+ name: ubuntu-latest / ghcjs 8.6
115+ runs-on: "ubuntu-latest"
116+
117+ steps:
118+ - uses: actions/checkout@v2
119+ - uses: cachix/install-nix-action@v13
120+ with:
121+ extra_nix_config: |
122+ trusted-public-keys = ryantrinkle.com-1:JJiAKaRv9mWgpVAz8dwewnZe0AzzEAzPkagE9SP5NWI=1aba6f367982bd6dd78ec2fda75ab246a62d32c5 cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY=
123+ substituters = https://nixcache.reflex-frp.org https://cache.nixos.org/
124+ - name: Setup
125+ run: |
126+ # Override cabal.project with the lightweight GHCJS one
127+ cp cabal.ghcjs.project cabal.project
128+ cat cabal.project
129+ nix-shell ghcjs.nix --run "cabal v2-update && cabal v2-freeze"
130+
131+ - uses: actions/cache@v2.1.3
132+ name: Cache ~/.cabal/store and dist-newstyle
133+ with:
134+ path: |
135+ ~/.cabal/store
136+ dist-newstyle
137+ key: ${{ runner.os }}-ghcjs8.6-${{ hashFiles('cabal.project.freeze') }}
138+ restore-keys: |
139+ ${{ runner.os }}-ghcjs8.6-
140+
141+ - name: Build
142+ run: |
143+ nix-shell ghcjs.nix --run "cabal v2-build --ghcjs --enable-tests --enable-benchmarks all"
144+
145+ - name: Tests
146+ run: |
147+ nix-shell ghcjs.nix --run ".github/run-ghcjs-tests.sh"
.gitignore+2
@@ -30,6 +30,8 @@ doc/_build
3030doc/venv
3131doc/tutorial/static/api.js
3232doc/tutorial/static/jq.js
33+shell.nix
34+.hspec-failures
3335
3436# nix
3537result*
.travis.ymldeleted−423
@@ -1,423 +0,0 @@
1−# This Travis job script has been generated by a script via
2−#
3−# haskell-ci '--branches' 'master' '--output' '.travis.yml' '--config=cabal.haskell-ci' 'cabal.project'
4−#
5−# To regenerate the script (for example after adjusting tested-with) run
6−#
7−# haskell-ci regenerate
8−#
9−# For more information, see https://github.com/haskell-CI/haskell-ci
10−#
11−# version: 0.10.3
12−#
13−version: ~> 1.0
14−language: c
15−os: linux
16−dist: bionic
17−git:
18− # whether to recursively clone submodules
19− submodules: false
20−branches:
21− only:
22− - master
23− - master
24−addons:
25− google: stable
26−cache:
27− directories:
28− - $HOME/.cabal/packages
29− - $HOME/.cabal/store
30− - $HOME/.hlint
31−before_cache:
32− - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log
33− # remove files that are regenerated by 'cabal update'
34− - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.*
35− - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json
36− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache
37− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar
38− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx
39− - rm -rfv $CABALHOME/packages/head.hackage
40−jobs:
41− include:
42− - compiler: ghcjs-8.4
43− 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"]}}
44− os: linux
45− - compiler: ghc-8.10.2
46− 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.10.2","cabal-install-3.2"]}}
47− os: linux
48− - compiler: ghc-8.10.1
49− 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.10.1","cabal-install-3.2"]}}
50− os: linux
51− - compiler: ghc-8.8.4
52− 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.4","cabal-install-3.2"]}}
53− os: linux
54− - compiler: ghc-8.8.3
55− 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.3","cabal-install-3.2"]}}
56− os: linux
57− - compiler: ghc-8.6.5
58− 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.2"]}}
59− os: linux
60− - compiler: ghc-8.4.4
61− 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.2"]}}
62− os: linux
63− - compiler: ghc-8.2.2
64− 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.2"]}}
65− os: linux
66− - compiler: ghc-8.0.2
67− 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.2"]}}
68− os: linux
69−before_install:
70− - |
71− if echo $CC | grep -q ghcjs; then
72− GHCJS=true;
73− else
74− GHCJS=false;
75− fi
76− - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//')
77− - WITHCOMPILER="-w $HC"
78− - if $GHCJS ; then HC=${HC}js ; fi
79− - if $GHCJS ; then WITHCOMPILER="--ghcjs ${WITHCOMPILER}js" ; fi
80− - HADDOCK=$(echo "/opt/$CC/bin/haddock" | sed 's/-/\//')
81− - if $GHCJS ; then PATH="/opt/ghc/8.4.4/bin:$PATH" ; fi
82− - HCPKG="$HC-pkg"
83− - unset CC
84− - CABAL=/opt/ghc/bin/cabal
85− - CABALHOME=$HOME/.cabal
86− - export PATH="$CABALHOME/bin:$PATH"
87− - TOP=$(pwd)
88− - "HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\\d+)\\.(\\d+)\\.(\\d+)(\\.(\\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')"
89− - echo $HCNUMVER
90− - CABAL="$CABAL -vnormal+nowrap"
91− - set -o pipefail
92− - TEST=--enable-tests
93− - BENCH=--enable-benchmarks
94− - HEADHACKAGE=false
95− - rm -f $CABALHOME/config
96− - |
97− echo "verbose: normal +nowrap +markoutput" >> $CABALHOME/config
98− echo "remote-build-reporting: anonymous" >> $CABALHOME/config
99− echo "write-ghc-environment-files: always" >> $CABALHOME/config
100− echo "remote-repo-cache: $CABALHOME/packages" >> $CABALHOME/config
101− echo "logs-dir: $CABALHOME/logs" >> $CABALHOME/config
102− echo "world-file: $CABALHOME/world" >> $CABALHOME/config
103− echo "extra-prog-path: $CABALHOME/bin" >> $CABALHOME/config
104− echo "symlink-bindir: $CABALHOME/bin" >> $CABALHOME/config
105− echo "installdir: $CABALHOME/bin" >> $CABALHOME/config
106− echo "build-summary: $CABALHOME/logs/build.log" >> $CABALHOME/config
107− echo "store-dir: $CABALHOME/store" >> $CABALHOME/config
108− echo "install-dirs user" >> $CABALHOME/config
109− echo " prefix: $CABALHOME" >> $CABALHOME/config
110− echo "repository hackage.haskell.org" >> $CABALHOME/config
111− echo " url: http://hackage.haskell.org/" >> $CABALHOME/config
112−install:
113− - ${CABAL} --version
114− - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"
115− - node --version
116− - echo $GHCJS
117− - GHCJOBS=-j2
118− - |
119− echo "program-default-options" >> $CABALHOME/config
120− echo " ghc-options: $GHCJOBS +RTS -M6G -RTS" >> $CABALHOME/config
121− - cat $CABALHOME/config
122− - rm -fv cabal.project cabal.project.local cabal.project.freeze
123− - travis_retry ${CABAL} v2-update -v
124− - if ! $GHCJS ; then ${CABAL} v2-install $WITHCOMPILER --ignore-project -j2 doctest --constraint='doctest ^>=0.17' ; fi
125− - if $GHCJS ; then ${CABAL} v2-install -w ghc-8.4.4 --ignore-project cabal-plan --constraint='cabal-plan ^>=0.6.0.0' --constraint='cabal-plan +exe' ; fi
126− - if $GHCJS ; then ${CABAL} v2-install -w ghc-8.4.4 --ignore-project hspec-discover ; fi
127− # Generate cabal.project
128− - rm -rf cabal.project cabal.project.local cabal.project.freeze
129− - touch cabal.project
130− - |
131− if $GHCJS || ! $GHCJS && { [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then echo "packages: servant" >> cabal.project ; fi
132− if ! $GHCJS && { [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then echo "packages: servant-client" >> cabal.project ; fi
133− if $GHCJS || ! $GHCJS && { [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then echo "packages: servant-client-core" >> cabal.project ; fi
134− if ! $GHCJS && { [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then echo "packages: servant-http-streams" >> cabal.project ; fi
135− if ! $GHCJS && { [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then echo "packages: servant-docs" >> cabal.project ; fi
136− if ! $GHCJS && { [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then echo "packages: servant-foreign" >> cabal.project ; fi
137− if ! $GHCJS && { [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then echo "packages: servant-server" >> cabal.project ; fi
138− if ! $GHCJS && { [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo "packages: doc/tutorial" >> cabal.project ; fi
139− if ! $GHCJS && { [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then echo "packages: servant-machines" >> cabal.project ; fi
140− if ! $GHCJS && { [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then echo "packages: servant-conduit" >> cabal.project ; fi
141− if ! $GHCJS && { [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then echo "packages: servant-pipes" >> cabal.project ; fi
142− if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo "packages: doc/cookbook/basic-auth" >> cabal.project ; fi
143− if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo "packages: doc/cookbook/curl-mock" >> cabal.project ; fi
144− if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo "packages: doc/cookbook/custom-errors" >> cabal.project ; fi
145− if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo "packages: doc/cookbook/basic-streaming" >> cabal.project ; fi
146− if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo "packages: doc/cookbook/db-postgres-pool" >> cabal.project ; fi
147− if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo "packages: doc/cookbook/file-upload" >> cabal.project ; fi
148− if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo "packages: doc/cookbook/generic" >> cabal.project ; fi
149− if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo "packages: doc/cookbook/pagination" >> cabal.project ; fi
150− if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo "packages: doc/cookbook/testing" >> cabal.project ; fi
151− if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo "packages: doc/cookbook/structuring-apis" >> cabal.project ; fi
152− if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo "packages: doc/cookbook/using-custom-monad" >> cabal.project ; fi
153− if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo "packages: doc/cookbook/using-free-client" >> cabal.project ; fi
154− - if $GHCJS || ! $GHCJS && { [ $HCNUMVER -ge 80200 ] && [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then echo 'package servant' >> cabal.project ; fi
155− - "if $GHCJS || ! $GHCJS && { [ $HCNUMVER -ge 80200 ] && [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
156− - if ! $GHCJS && { [ $HCNUMVER -ge 80200 ] && [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then echo 'package servant-client' >> cabal.project ; fi
157− - "if ! $GHCJS && { [ $HCNUMVER -ge 80200 ] && [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
158− - if $GHCJS || ! $GHCJS && { [ $HCNUMVER -ge 80200 ] && [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then echo 'package servant-client-core' >> cabal.project ; fi
159− - "if $GHCJS || ! $GHCJS && { [ $HCNUMVER -ge 80200 ] && [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
160− - if ! $GHCJS && { [ $HCNUMVER -ge 80200 ] && [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then echo 'package servant-http-streams' >> cabal.project ; fi
161− - "if ! $GHCJS && { [ $HCNUMVER -ge 80200 ] && [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
162− - if ! $GHCJS && { [ $HCNUMVER -ge 80200 ] && [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then echo 'package servant-docs' >> cabal.project ; fi
163− - "if ! $GHCJS && { [ $HCNUMVER -ge 80200 ] && [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
164− - if ! $GHCJS && { [ $HCNUMVER -ge 80200 ] && [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then echo 'package servant-foreign' >> cabal.project ; fi
165− - "if ! $GHCJS && { [ $HCNUMVER -ge 80200 ] && [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
166− - if ! $GHCJS && { [ $HCNUMVER -ge 80200 ] && [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then echo 'package servant-server' >> cabal.project ; fi
167− - "if ! $GHCJS && { [ $HCNUMVER -ge 80200 ] && [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
168− - if ! $GHCJS && { [ $HCNUMVER -ge 80200 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo 'package tutorial' >> cabal.project ; fi
169− - "if ! $GHCJS && { [ $HCNUMVER -ge 80200 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
170− - if ! $GHCJS && { [ $HCNUMVER -ge 80200 ] && [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then echo 'package servant-machines' >> cabal.project ; fi
171− - "if ! $GHCJS && { [ $HCNUMVER -ge 80200 ] && [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
172− - if ! $GHCJS && { [ $HCNUMVER -ge 80200 ] && [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then echo 'package servant-conduit' >> cabal.project ; fi
173− - "if ! $GHCJS && { [ $HCNUMVER -ge 80200 ] && [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
174− - if ! $GHCJS && { [ $HCNUMVER -ge 80200 ] && [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then echo 'package servant-pipes' >> cabal.project ; fi
175− - "if ! $GHCJS && { [ $HCNUMVER -ge 80200 ] && [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
176− - if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo 'package cookbook-basic-auth' >> cabal.project ; fi
177− - "if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
178− - if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo 'package cookbook-curl-mock' >> cabal.project ; fi
179− - "if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
180− - if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo 'package cookbook-custom-errors' >> cabal.project ; fi
181− - "if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
182− - if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo 'package cookbook-basic-streaming' >> cabal.project ; fi
183− - "if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
184− - if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo 'package cookbook-db-postgres-pool' >> cabal.project ; fi
185− - "if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
186− - if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo 'package cookbook-file-upload' >> cabal.project ; fi
187− - "if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
188− - if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo 'package cookbook-generic' >> cabal.project ; fi
189− - "if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
190− - if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo 'package cookbook-pagination' >> cabal.project ; fi
191− - "if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
192− - if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo 'package cookbook-testing' >> cabal.project ; fi
193− - "if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
194− - if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo 'package cookbook-structuring-apis' >> cabal.project ; fi
195− - "if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
196− - if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo 'package cookbook-using-custom-monad' >> cabal.project ; fi
197− - "if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
198− - if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo 'package cookbook-using-free-client' >> cabal.project ; fi
199− - "if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
200− - |
201− echo "constraints: foundation >=0.0.14" >> cabal.project
202− echo "constraints: memory <0.14.12 || >0.14.12" >> cabal.project
203− echo "constraints: base-compat ^>=0.11" >> cabal.project
204− echo "constraints: semigroups ^>=0.19" >> cabal.project
205− echo "constraints: sqlite-simple < 0" >> cabal.project
206− echo "allow-newer: servant-pagination-2.2.2:servant" >> cabal.project
207− echo "allow-newer: servant-pagination-2.2.2:servant-server" >> cabal.project
208− echo "allow-newer: servant-multipart:servant" >> cabal.project
209− echo "allow-newer: servant-multipart:servant-server" >> cabal.project
210− echo "allow-newer: servant-multipart:servant-client-core" >> cabal.project
211− echo "allow-newer: servant-js:servant" >> cabal.project
212− echo "optimization: False" >> cabal.project
213− - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(cookbook-basic-auth|cookbook-basic-streaming|cookbook-curl-mock|cookbook-custom-errors|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"
214− - cat cabal.project || true
215− - cat cabal.project.local || true
216− - if [ -f "servant/configure.ac" ]; then (cd "servant" && autoreconf -i); fi
217− - if [ -f "servant-client/configure.ac" ]; then (cd "servant-client" && autoreconf -i); fi
218− - if [ -f "servant-client-core/configure.ac" ]; then (cd "servant-client-core" && autoreconf -i); fi
219− - if [ -f "servant-http-streams/configure.ac" ]; then (cd "servant-http-streams" && autoreconf -i); fi
220− - if [ -f "servant-docs/configure.ac" ]; then (cd "servant-docs" && autoreconf -i); fi
221− - if [ -f "servant-foreign/configure.ac" ]; then (cd "servant-foreign" && autoreconf -i); fi
222− - if [ -f "servant-server/configure.ac" ]; then (cd "servant-server" && autoreconf -i); fi
223− - if [ -f "doc/tutorial/configure.ac" ]; then (cd "doc/tutorial" && autoreconf -i); fi
224− - if [ -f "servant-machines/configure.ac" ]; then (cd "servant-machines" && autoreconf -i); fi
225− - if [ -f "servant-conduit/configure.ac" ]; then (cd "servant-conduit" && autoreconf -i); fi
226− - if [ -f "servant-pipes/configure.ac" ]; then (cd "servant-pipes" && autoreconf -i); fi
227− - if [ -f "doc/cookbook/basic-auth/configure.ac" ]; then (cd "doc/cookbook/basic-auth" && autoreconf -i); fi
228− - if [ -f "doc/cookbook/curl-mock/configure.ac" ]; then (cd "doc/cookbook/curl-mock" && autoreconf -i); fi
229− - if [ -f "doc/cookbook/custom-errors/configure.ac" ]; then (cd "doc/cookbook/custom-errors" && autoreconf -i); fi
230− - if [ -f "doc/cookbook/basic-streaming/configure.ac" ]; then (cd "doc/cookbook/basic-streaming" && autoreconf -i); fi
231− - if [ -f "doc/cookbook/db-postgres-pool/configure.ac" ]; then (cd "doc/cookbook/db-postgres-pool" && autoreconf -i); fi
232− - if [ -f "doc/cookbook/file-upload/configure.ac" ]; then (cd "doc/cookbook/file-upload" && autoreconf -i); fi
233− - if [ -f "doc/cookbook/generic/configure.ac" ]; then (cd "doc/cookbook/generic" && autoreconf -i); fi
234− - if [ -f "doc/cookbook/pagination/configure.ac" ]; then (cd "doc/cookbook/pagination" && autoreconf -i); fi
235− - if [ -f "doc/cookbook/testing/configure.ac" ]; then (cd "doc/cookbook/testing" && autoreconf -i); fi
236− - if [ -f "doc/cookbook/structuring-apis/configure.ac" ]; then (cd "doc/cookbook/structuring-apis" && autoreconf -i); fi
237− - if [ -f "doc/cookbook/using-custom-monad/configure.ac" ]; then (cd "doc/cookbook/using-custom-monad" && autoreconf -i); fi
238− - if [ -f "doc/cookbook/using-free-client/configure.ac" ]; then (cd "doc/cookbook/using-free-client" && autoreconf -i); fi
239− - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH}
240− - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'"
241− - rm cabal.project.freeze
242−script:
243− - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
244− # Packaging...
245− - echo 'Packaging...' && echo -en 'travis_fold:start:sdist\\r'
246− - ${CABAL} v2-sdist all
247− - echo -en 'travis_fold:end:sdist\\r'
248− # Unpacking...
249− - echo 'Unpacking...' && echo -en 'travis_fold:start:unpack\\r'
250− - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/
251− - cd ${DISTDIR} || false
252− - find . -maxdepth 1 -type f -name '*.tar.gz' -exec tar -xvf '{}' \;
253− - find . -maxdepth 1 -type f -name '*.tar.gz' -exec rm '{}' \;
254− - PKGDIR_servant="$(find . -maxdepth 1 -type d -regex '.*/servant-[0-9.]*')"
255− - PKGDIR_servant_client="$(find . -maxdepth 1 -type d -regex '.*/servant-client-[0-9.]*')"
256− - PKGDIR_servant_client_core="$(find . -maxdepth 1 -type d -regex '.*/servant-client-core-[0-9.]*')"
257− - PKGDIR_servant_http_streams="$(find . -maxdepth 1 -type d -regex '.*/servant-http-streams-[0-9.]*')"
258− - PKGDIR_servant_docs="$(find . -maxdepth 1 -type d -regex '.*/servant-docs-[0-9.]*')"
259− - PKGDIR_servant_foreign="$(find . -maxdepth 1 -type d -regex '.*/servant-foreign-[0-9.]*')"
260− - PKGDIR_servant_server="$(find . -maxdepth 1 -type d -regex '.*/servant-server-[0-9.]*')"
261− - PKGDIR_tutorial="$(find . -maxdepth 1 -type d -regex '.*/tutorial-[0-9.]*')"
262− - PKGDIR_servant_machines="$(find . -maxdepth 1 -type d -regex '.*/servant-machines-[0-9.]*')"
263− - PKGDIR_servant_conduit="$(find . -maxdepth 1 -type d -regex '.*/servant-conduit-[0-9.]*')"
264− - PKGDIR_servant_pipes="$(find . -maxdepth 1 -type d -regex '.*/servant-pipes-[0-9.]*')"
265− - PKGDIR_cookbook_basic_auth="$(find . -maxdepth 1 -type d -regex '.*/cookbook-basic-auth-[0-9.]*')"
266− - PKGDIR_cookbook_curl_mock="$(find . -maxdepth 1 -type d -regex '.*/cookbook-curl-mock-[0-9.]*')"
267− - PKGDIR_cookbook_custom_errors="$(find . -maxdepth 1 -type d -regex '.*/cookbook-custom-errors-[0-9.]*')"
268− - PKGDIR_cookbook_basic_streaming="$(find . -maxdepth 1 -type d -regex '.*/cookbook-basic-streaming-[0-9.]*')"
269− - PKGDIR_cookbook_db_postgres_pool="$(find . -maxdepth 1 -type d -regex '.*/cookbook-db-postgres-pool-[0-9.]*')"
270− - PKGDIR_cookbook_file_upload="$(find . -maxdepth 1 -type d -regex '.*/cookbook-file-upload-[0-9.]*')"
271− - PKGDIR_cookbook_generic="$(find . -maxdepth 1 -type d -regex '.*/cookbook-generic-[0-9.]*')"
272− - PKGDIR_cookbook_pagination="$(find . -maxdepth 1 -type d -regex '.*/cookbook-pagination-[0-9.]*')"
273− - PKGDIR_cookbook_testing="$(find . -maxdepth 1 -type d -regex '.*/cookbook-testing-[0-9.]*')"
274− - PKGDIR_cookbook_structuring_apis="$(find . -maxdepth 1 -type d -regex '.*/cookbook-structuring-apis-[0-9.]*')"
275− - PKGDIR_cookbook_using_custom_monad="$(find . -maxdepth 1 -type d -regex '.*/cookbook-using-custom-monad-[0-9.]*')"
276− - PKGDIR_cookbook_using_free_client="$(find . -maxdepth 1 -type d -regex '.*/cookbook-using-free-client-[0-9.]*')"
277− # Generate cabal.project
278− - rm -rf cabal.project cabal.project.local cabal.project.freeze
279− - touch cabal.project
280− - |
281− if $GHCJS || ! $GHCJS && { [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then echo "packages: ${PKGDIR_servant}" >> cabal.project ; fi
282− if ! $GHCJS && { [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then echo "packages: ${PKGDIR_servant_client}" >> cabal.project ; fi
283− if $GHCJS || ! $GHCJS && { [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then echo "packages: ${PKGDIR_servant_client_core}" >> cabal.project ; fi
284− if ! $GHCJS && { [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then echo "packages: ${PKGDIR_servant_http_streams}" >> cabal.project ; fi
285− if ! $GHCJS && { [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then echo "packages: ${PKGDIR_servant_docs}" >> cabal.project ; fi
286− if ! $GHCJS && { [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then echo "packages: ${PKGDIR_servant_foreign}" >> cabal.project ; fi
287− if ! $GHCJS && { [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then echo "packages: ${PKGDIR_servant_server}" >> cabal.project ; fi
288− if ! $GHCJS && { [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo "packages: ${PKGDIR_tutorial}" >> cabal.project ; fi
289− if ! $GHCJS && { [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then echo "packages: ${PKGDIR_servant_machines}" >> cabal.project ; fi
290− if ! $GHCJS && { [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then echo "packages: ${PKGDIR_servant_conduit}" >> cabal.project ; fi
291− if ! $GHCJS && { [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then echo "packages: ${PKGDIR_servant_pipes}" >> cabal.project ; fi
292− if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo "packages: ${PKGDIR_cookbook_basic_auth}" >> cabal.project ; fi
293− if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo "packages: ${PKGDIR_cookbook_curl_mock}" >> cabal.project ; fi
294− if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo "packages: ${PKGDIR_cookbook_custom_errors}" >> cabal.project ; fi
295− if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo "packages: ${PKGDIR_cookbook_basic_streaming}" >> cabal.project ; fi
296− if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo "packages: ${PKGDIR_cookbook_db_postgres_pool}" >> cabal.project ; fi
297− if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo "packages: ${PKGDIR_cookbook_file_upload}" >> cabal.project ; fi
298− if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo "packages: ${PKGDIR_cookbook_generic}" >> cabal.project ; fi
299− if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo "packages: ${PKGDIR_cookbook_pagination}" >> cabal.project ; fi
300− if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo "packages: ${PKGDIR_cookbook_testing}" >> cabal.project ; fi
301− if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo "packages: ${PKGDIR_cookbook_structuring_apis}" >> cabal.project ; fi
302− if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo "packages: ${PKGDIR_cookbook_using_custom_monad}" >> cabal.project ; fi
303− if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo "packages: ${PKGDIR_cookbook_using_free_client}" >> cabal.project ; fi
304− - if $GHCJS || ! $GHCJS && { [ $HCNUMVER -ge 80200 ] && [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then echo 'package servant' >> cabal.project ; fi
305− - "if $GHCJS || ! $GHCJS && { [ $HCNUMVER -ge 80200 ] && [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
306− - if ! $GHCJS && { [ $HCNUMVER -ge 80200 ] && [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then echo 'package servant-client' >> cabal.project ; fi
307− - "if ! $GHCJS && { [ $HCNUMVER -ge 80200 ] && [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
308− - if $GHCJS || ! $GHCJS && { [ $HCNUMVER -ge 80200 ] && [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then echo 'package servant-client-core' >> cabal.project ; fi
309− - "if $GHCJS || ! $GHCJS && { [ $HCNUMVER -ge 80200 ] && [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
310− - if ! $GHCJS && { [ $HCNUMVER -ge 80200 ] && [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then echo 'package servant-http-streams' >> cabal.project ; fi
311− - "if ! $GHCJS && { [ $HCNUMVER -ge 80200 ] && [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
312− - if ! $GHCJS && { [ $HCNUMVER -ge 80200 ] && [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then echo 'package servant-docs' >> cabal.project ; fi
313− - "if ! $GHCJS && { [ $HCNUMVER -ge 80200 ] && [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
314− - if ! $GHCJS && { [ $HCNUMVER -ge 80200 ] && [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then echo 'package servant-foreign' >> cabal.project ; fi
315− - "if ! $GHCJS && { [ $HCNUMVER -ge 80200 ] && [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
316− - if ! $GHCJS && { [ $HCNUMVER -ge 80200 ] && [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then echo 'package servant-server' >> cabal.project ; fi
317− - "if ! $GHCJS && { [ $HCNUMVER -ge 80200 ] && [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
318− - if ! $GHCJS && { [ $HCNUMVER -ge 80200 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo 'package tutorial' >> cabal.project ; fi
319− - "if ! $GHCJS && { [ $HCNUMVER -ge 80200 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
320− - if ! $GHCJS && { [ $HCNUMVER -ge 80200 ] && [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then echo 'package servant-machines' >> cabal.project ; fi
321− - "if ! $GHCJS && { [ $HCNUMVER -ge 80200 ] && [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
322− - if ! $GHCJS && { [ $HCNUMVER -ge 80200 ] && [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then echo 'package servant-conduit' >> cabal.project ; fi
323− - "if ! $GHCJS && { [ $HCNUMVER -ge 80200 ] && [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
324− - if ! $GHCJS && { [ $HCNUMVER -ge 80200 ] && [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then echo 'package servant-pipes' >> cabal.project ; fi
325− - "if ! $GHCJS && { [ $HCNUMVER -ge 80200 ] && [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
326− - if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo 'package cookbook-basic-auth' >> cabal.project ; fi
327− - "if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
328− - if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo 'package cookbook-curl-mock' >> cabal.project ; fi
329− - "if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
330− - if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo 'package cookbook-custom-errors' >> cabal.project ; fi
331− - "if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
332− - if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo 'package cookbook-basic-streaming' >> cabal.project ; fi
333− - "if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
334− - if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo 'package cookbook-db-postgres-pool' >> cabal.project ; fi
335− - "if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
336− - if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo 'package cookbook-file-upload' >> cabal.project ; fi
337− - "if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
338− - if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo 'package cookbook-generic' >> cabal.project ; fi
339− - "if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
340− - if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo 'package cookbook-pagination' >> cabal.project ; fi
341− - "if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
342− - if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo 'package cookbook-testing' >> cabal.project ; fi
343− - "if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
344− - if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo 'package cookbook-structuring-apis' >> cabal.project ; fi
345− - "if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
346− - if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo 'package cookbook-using-custom-monad' >> cabal.project ; fi
347− - "if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
348− - if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo 'package cookbook-using-free-client' >> cabal.project ; fi
349− - "if ! $GHCJS && { [ $HCNUMVER -ge 80400 ] && [ $HCNUMVER -lt 80804 ] || [ $HCNUMVER -ge 81000 ] && [ $HCNUMVER -lt 81002 ]; } ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
350− - |
351− echo "constraints: foundation >=0.0.14" >> cabal.project
352− echo "constraints: memory <0.14.12 || >0.14.12" >> cabal.project
353− echo "constraints: base-compat ^>=0.11" >> cabal.project
354− echo "constraints: semigroups ^>=0.19" >> cabal.project
355− echo "constraints: sqlite-simple < 0" >> cabal.project
356− echo "allow-newer: servant-pagination-2.2.2:servant" >> cabal.project
357− echo "allow-newer: servant-pagination-2.2.2:servant-server" >> cabal.project
358− echo "allow-newer: servant-multipart:servant" >> cabal.project
359− echo "allow-newer: servant-multipart:servant-server" >> cabal.project
360− echo "allow-newer: servant-multipart:servant-client-core" >> cabal.project
361− echo "allow-newer: servant-js:servant" >> cabal.project
362− echo "optimization: False" >> cabal.project
363− - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(cookbook-basic-auth|cookbook-basic-streaming|cookbook-curl-mock|cookbook-custom-errors|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"
364− - cat cabal.project || true
365− - cat cabal.project.local || true
366− - |
367− pkgdir() {
368− case $1 in
369− servant) echo ${PKGDIR_servant} ;;
370− servant-client) echo ${PKGDIR_servant_client} ;;
371− servant-client-core) echo ${PKGDIR_servant_client_core} ;;
372− servant-http-streams) echo ${PKGDIR_servant_http_streams} ;;
373− servant-docs) echo ${PKGDIR_servant_docs} ;;
374− servant-foreign) echo ${PKGDIR_servant_foreign} ;;
375− servant-server) echo ${PKGDIR_servant_server} ;;
376− tutorial) echo ${PKGDIR_tutorial} ;;
377− servant-machines) echo ${PKGDIR_servant_machines} ;;
378− servant-conduit) echo ${PKGDIR_servant_conduit} ;;
379− servant-pipes) echo ${PKGDIR_servant_pipes} ;;
380− cookbook-basic-auth) echo ${PKGDIR_cookbook_basic_auth} ;;
381− cookbook-curl-mock) echo ${PKGDIR_cookbook_curl_mock} ;;
382− cookbook-custom-errors) echo ${PKGDIR_cookbook_custom_errors} ;;
383− cookbook-basic-streaming) echo ${PKGDIR_cookbook_basic_streaming} ;;
384− cookbook-db-postgres-pool) echo ${PKGDIR_cookbook_db_postgres_pool} ;;
385− cookbook-file-upload) echo ${PKGDIR_cookbook_file_upload} ;;
386− cookbook-generic) echo ${PKGDIR_cookbook_generic} ;;
387− cookbook-pagination) echo ${PKGDIR_cookbook_pagination} ;;
388− cookbook-testing) echo ${PKGDIR_cookbook_testing} ;;
389− cookbook-structuring-apis) echo ${PKGDIR_cookbook_structuring_apis} ;;
390− cookbook-using-custom-monad) echo ${PKGDIR_cookbook_using_custom_monad} ;;
391− cookbook-using-free-client) echo ${PKGDIR_cookbook_using_free_client} ;;
392− esac
393− }
394− - echo -en 'travis_fold:end:unpack\\r'
395− # Building with tests and benchmarks...
396− - echo 'Building with tests and benchmarks...' && echo -en 'travis_fold:start:build-everything\\r'
397− # build & run tests, build benchmarks
398− - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all
399− - echo -en 'travis_fold:end:build-everything\\r'
400− # Testing...
401− - if ! $GHCJS ; then ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all ; fi
402− - 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
403− # Doctest...
404− - echo 'Doctest...' && echo -en 'travis_fold:start:doctest\\r'
405− - perl -i -e 'while (<ARGV>) { print unless /package-id\s+(base-compat-batteries)-\d+(\.\d+)*/; }' .ghc.environment.*
406− - if ! $GHCJS && { [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then (cd ${PKGDIR_servant} && doctest src) ; fi
407− - if ! $GHCJS && { [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then (cd ${PKGDIR_servant_client} && doctest src) ; fi
408− - if ! $GHCJS && { [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then (cd ${PKGDIR_servant_client_core} && doctest src) ; fi
409− - if ! $GHCJS && { [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then (cd ${PKGDIR_servant_http_streams} && doctest src) ; fi
410− - if ! $GHCJS && { [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then (cd ${PKGDIR_servant_docs} && doctest src) ; fi
411− - if ! $GHCJS && { [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then (cd ${PKGDIR_servant_foreign} && doctest src) ; fi
412− - if ! $GHCJS && { [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then (cd ${PKGDIR_servant_server} && doctest src) ; fi
413− - if ! $GHCJS && { [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then (cd ${PKGDIR_servant_machines} && doctest src) ; fi
414− - if ! $GHCJS && { [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then (cd ${PKGDIR_servant_conduit} && doctest src) ; fi
415− - if ! $GHCJS && { [ $HCNUMVER -lt 80800 ] || [ $HCNUMVER -ge 80804 ] && [ $HCNUMVER -lt 81000 ] || [ $HCNUMVER -ge 81002 ]; } ; then (cd ${PKGDIR_servant_pipes} && doctest src) ; fi
416− - echo -en 'travis_fold:end:doctest\\r'
417− # haddock...
418− - echo 'haddock...' && echo -en 'travis_fold:start:haddock\\r'
419− - if ! $GHCJS ; then ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all ; fi
420− - echo -en 'travis_fold:end:haddock\\r'
421−
422−# REGENDATA ("0.10.3",["--branches","master","--output",".travis.yml","--config=cabal.haskell-ci","cabal.project"])
423−# EOF
CONTRIBUTING.md+4−2
@@ -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
Makefiledeleted−32
@@ -1,32 +0,0 @@
1−# With common maintenance tasks
2−
3−HC ?= ghc-8.4.4
4−
5−all :
6− @echo "Don't try to make all at once!"
7−
8−really-all :
9− $(MAKE) build-ghc
10− $(MAKE) build-ghc HC=ghc-8.0.2
11− $(MAKE) build-ghc HC=ghc-8.2.2
12− $(MAKE) build-ghc HC=ghc-8.6.5
13− $(MAKE) build-ghcjs
14−
15−build-ghc :
16− cabal v2-build -w $(HC) all
17−
18−build-ghcjs :
19− cabal v2-build --builddir=dist-newstyle-ghcjs --project-file=cabal.ghcjs.project all
20−
21−packdeps :
22− packdeps */*.cabal
23−
24−doctest : doctest-servant doctest-servant-server
25− perl -i -e 'while (<ARGV>) { print unless /package-id\s+base-compat-\d+(\.\d+)*/; }' .ghc.environment.*
26−
27−doctest-servant :
28− (cd servant && doctest src)
29− (cd servant && doctest test/Servant/LinksSpec.hs)
30−
31−doctest-servant-server :
32− (cd servant-server && doctest src)
README.md+7−21
@@ -13,7 +13,7 @@ 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
@@ -40,26 +40,6 @@ See `CONTRIBUTING.md`
4040 - `git push --tags`
4141 - `cabal sdist` and `cabal upload`
4242
43−## travis
44−
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 to a dependency failing to build, you can temporarily
55−add `constraints` to the `cabal.project` file, and regenerate the `.travis.yml`.
56−For example, the following will disallow a single `troublemaker-13.37` package version:
57−
58−```
59−constraints:
60− troublemaker <13.37 && > 13.37
61−```
62−
6343## TechEmpower framework benchmarks
6444
6545We develop and maintain the servant TFB entry in https://github.com/haskell-servant/FrameworkBenchmarks/
@@ -83,3 +63,9 @@ To compare with `reitit` (Clojure framework)
8363```
8464
8565You 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−25
@@ -1,25 +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−doctest: True
8−doctest-filter-packages: base-compat-batteries
9−doctest-skip: tutorial
10−
11−-- https://github.com/haskell/cabal/issues/6176
12−ghcjs-tools: hspec-discover
13−
14−-- We have inplace packages (servant-js) so we skip installing dependencies in a separate step
15−install-dependencies: False
16−
17−-- this speed-ups the build a little, but we have to check these for release
18−no-tests-no-benchmarks: False
19−unconstrained: False
20−
21−-- Don't run cabal check, as cookbook examples won't pass it
22−cabal-check: False
23−
24−-- ghc-options: -j2
25−jobs: :2
cabal.project+13−32
@@ -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
@@ -25,15 +32,16 @@ packages:
2532 doc/cookbook/custom-errors
2633 doc/cookbook/basic-streaming
2734 doc/cookbook/db-postgres-pool
28− -- doc/cookbook/db-sqlite-simple
35+ doc/cookbook/db-sqlite-simple
2936 doc/cookbook/file-upload
3037 doc/cookbook/generic
31− -- doc/cookbook/hoist-server-with-context
32− -- doc/cookbook/https
33− -- doc/cookbook/jwt-and-basic-auth/
38+ doc/cookbook/hoist-server-with-context
39+ doc/cookbook/https
40+ doc/cookbook/jwt-and-basic-auth
3441 doc/cookbook/pagination
3542 -- doc/cookbook/sentry
36− doc/cookbook/testing
43+ -- Commented out because servant-quickcheck currently doesn't build.
44+ -- doc/cookbook/testing
3745 doc/cookbook/uverb
3846 doc/cookbook/structuring-apis
3947 doc/cookbook/using-custom-monad
@@ -43,30 +51,3 @@ packages:
4351tests: True
4452optimization: False
4553-- reorder-goals: True
46−
47−constraints:
48− -- see https://github.com/haskell-infra/hackage-trustees/issues/119
49− foundation >=0.0.14,
50− memory <0.14.12 || >0.14.12
51−
52−constraints: base-compat ^>=0.11
53−constraints: semigroups ^>=0.19
54−
55−-- MonadFail
56−-- https://github.com/nurpax/sqlite-simple/issues/74
57−constraints: sqlite-simple < 0
58−-- allow-newer: sqlite-simple-0.4.16.0:semigroups
59−-- allow-newer: direct-sqlite-2.3.24:semigroups
60−
61−-- needed for doctests
62−write-ghc-environment-files: always
63−
64−-- https://github.com/chordify/haskell-servant-pagination/pull/12
65−allow-newer: servant-pagination-2.2.2:servant
66−allow-newer: servant-pagination-2.2.2:servant-server
67−
68−-- https://github.com/haskell-servant/servant-multipart/pull/41
69−allow-newer: servant-multipart:servant
70−allow-newer: servant-multipart:servant-server
71−allow-newer: servant-multipart:servant-client-core
72−allow-newer: servant-js:servant
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/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/servant-docs-curlnew file+16
@@ -0,0 +1,16 @@
1+synopsis: Add sample cURL requests to generated documentation
2+prs: #1401
3+
4+description: {
5+
6+Add sample cURL requests to generated documentation.
7+
8+Those supplying changes to the Request `header` field manually using
9+lenses will need to add a sample bytestring value.
10+
11+`headers <>~ ["unicorn"]`
12+
13+becomes
14+
15+`headers <>~ [("unicorn", "sample value")]`
16+}
doc/Makefile+1−1
@@ -10,7 +10,7 @@ BUILDDIR = _build
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.3, GHC ==8.10.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/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.3, GHC ==8.10.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−1
@@ -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)
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.3, GHC ==8.10.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/custom-errors.cabal+3−3
@@ -1,14 +1,14 @@
1+cabal-version: 2.2
12name: cookbook-custom-errors
23version: 0.1
34synopsis: Return custom error messages from combinators
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.3, GHC ==8.10.1
11+tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
1212
1313executable cookbook-custom-errors
1414 main-is: CustomErrors.lhs
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.3, GHC ==8.10.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.3, GHC ==8.10.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/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.3, GHC ==8.10.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.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.3, GHC ==8.10.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/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.3, GHC ==8.10.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.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.3, GHC ==8.10.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+3−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,
@@ -26,6 +26,7 @@ you name it!
2626 using-custom-monad/UsingCustomMonad.lhs
2727 using-free-client/UsingFreeClient.lhs
2828 custom-errors/CustomErrors.lhs
29+ uverb/UVerb.lhs
2930 basic-auth/BasicAuth.lhs
3031 basic-streaming/Streaming.lhs
3132 jwt-and-basic-auth/JWTAndBasicAuth.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.3, GHC ==8.10.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/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/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.3, GHC ==8.10.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.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.3, GHC ==8.10.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/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.3, GHC ==8.10.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+3−3
@@ -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.3, GHC ==8.10.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
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.3, GHC ==8.10.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+1−1
@@ -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.defaultMakeClientRequest burl req
122+ req' <- I.defaultMakeClientRequest burl req
123123 putStrLn $ "Making request: " ++ show req'
124124```
125125
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.3, GHC ==8.10.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.lhs+9−3
@@ -4,14 +4,18 @@ Servant allows you to talk about the exceptions you throw in your API
44types. This is not limited to actual exceptions, you can write
55handlers that respond with arbitrary open unions of types.
66
7+## Compatibility
8+
9+:warning: This cookbook is compatible with GHC 8.6.1 or higher :warning:
10+
711## Preliminaries
812
913```haskell
1014{-# LANGUAGE ConstraintKinds #-}
1115{-# LANGUAGE DataKinds #-}
12−{-# LANGUAGE DeriveAnyClass #-}
1316{-# LANGUAGE DeriveGeneric #-}
1417{-# LANGUAGE DerivingStrategies #-}
18+{-# LANGUAGE DeriveAnyClass #-}
1519{-# LANGUAGE DerivingVia #-}
1620{-# LANGUAGE FlexibleContexts #-}
1721{-# LANGUAGE FlexibleInstances #-}
@@ -134,7 +138,7 @@ Since `UVerb` (probably) will mostly be used for error-like responses, it may be
134138
135139```haskell
136140newtype UVerbT xs m a = UVerbT { unUVerbT :: ExceptT (Union xs) m a }
137− deriving newtype (Functor, Applicative, Monad, MonadTrans)
141+ deriving (Functor, Applicative, Monad, MonadTrans)
138142
139143-- | Deliberately hide 'ExceptT's 'MonadError' instance to be able to use
140144-- underlying monad's instance.
@@ -161,7 +165,9 @@ data Foo = Foo Int Int Int
161165 deriving HasStatus via WithStatus 200 Foo
162166
163167data Bar = Bar
164− deriving (Show, Eq, GHC.Generic, ToJSON)
168+ deriving (Show, Eq, GHC.Generic)
169+
170+instance ToJSON Bar
165171
166172h :: Handler (Union '[Foo, WithStatus 400 Bar])
167173h = runUVerbT $ do
doc/cookbook/uverb/uverb.cabal+6−4
@@ -1,16 +1,16 @@
1+cabal-version: 2.2
12name: cookbook-uverb
23version: 0.0.1
34synopsis: How to use the 'UVerb' type.
45description: Listing alternative responses and exceptions in your API types.
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.2
13+tested-with: GHC==8.6.5, GHC==8.8.4, GHC==8.10.7
1414
1515executable cookbook-uverb
1616 main-is: UVerb.lhs
@@ -28,6 +28,8 @@ executable cookbook-uverb
2828 , swagger2
2929 , wai
3030 , warp
31− default-language: Haskell2010
31+ if impl(ghc >= 9)
32+ buildable: False
33+ default-language: Haskell2010
3234 ghc-options: -Wall -pgmL markdown-unlit
3335 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/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+1−2
@@ -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)
@@ -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
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/tutorial.cabal+6−9
@@ -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.3, GHC ==8.10.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
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.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-auth/servant-auth-client/LICENSEnew file+31
@@ -0,0 +1,31 @@
1+Copyright Julian K. Arni (c) 2015
2+
3+All rights reserved.
4+
5+Redistribution and use in source and binary forms, with or without
6+modification, are permitted provided that the following conditions are met:
7+
8+ * Redistributions of source code must retain the above copyright
9+ notice, this list of conditions and the following disclaimer.
10+
11+ * Redistributions in binary form must reproduce the above
12+ copyright notice, this list of conditions and the following
13+ disclaimer in the documentation and/or other materials provided
14+ with the distribution.
15+
16+ * Neither the name of Julian K. Arni nor the names of other
17+ contributors may be used to endorse or promote products derived
18+ from this software without specific prior written permission.
19+
20+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31+
servant-auth/servant-auth-client/Setup.hsnew file+2
@@ -0,0 +1,2 @@
1+import Distribution.Simple
2+main = defaultMain
servant-auth/servant-auth-client/servant-auth-client.cabalnew file+80
@@ -0,0 +1,80 @@
1+cabal-version: 2.2
2+name: servant-auth-client
3+version: 0.4.1.0
4+synopsis: servant-client/servant-auth compatibility
5+description: This package provides instances that allow generating clients from
6+ <https://hackage.haskell.org/package/servant servant>
7+ APIs that use
8+ <https://hackage.haskell.org/package/servant-auth servant-auth's> @Auth@ combinator.
9+ .
10+ For a quick overview of the usage, see the <https://github.com/haskell-servant/servant/tree/master/servant-auth#readme README>.
11+category: Web, Servant, Authentication
12+homepage: https://github.com/haskell-servant/servant/tree/master/servant-auth#readme
13+bug-reports: https://github.com/haskell-servant/servant/issues
14+author: Julian K. Arni
15+maintainer: jkarni@gmail.com
16+copyright: (c) Julian K. Arni
17+license: BSD-3-Clause
18+license-file: LICENSE
19+tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1
20+build-type: Simple
21+extra-source-files:
22+ CHANGELOG.md
23+
24+source-repository head
25+ type: git
26+ location: https://github.com/haskell-servant/servant
27+
28+library
29+ hs-source-dirs:
30+ src
31+ default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
32+ ghc-options: -Wall
33+ build-depends:
34+ base >= 4.10 && < 4.17
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.7.0.0 && < 0.10
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.17
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.2
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.19,
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+134
@@ -0,0 +1,134 @@
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.17
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.7.0.0 && < 0.10
45+ , lens >= 4.16.1 && < 5.2
46+ , memory >= 0.14.16 && < 0.18
47+ , monad-time >= 0.3.1.0 && < 0.4
48+ , mtl >= 2.2.2 && < 2.3
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.12
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+ other-modules:
133+ Servant.Auth.ServerSpec
134+ 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+70
@@ -0,0 +1,70 @@
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+ xsrf <- makeXsrfCookie cookieSettings
58+ fmap (Just xsrf `SetCookieCons`) $
59+ case authResult of
60+ (Authenticated v) -> do
61+ ejwt <- makeSessionCookie cookieSettings jwtSettings v
62+ case ejwt of
63+ Nothing -> return $ Nothing `SetCookieCons` SetCookieNil
64+ Just jwt -> return $ Just jwt `SetCookieCons` SetCookieNil
65+ _ -> return $ Nothing `SetCookieCons` SetCookieNil
66+
67+ go :: (AuthResult v -> ServerT api Handler)
68+ -> (AuthResult v, SetCookieList n)
69+ -> ServerT (AddSetCookiesApi n api) Handler
70+ go fn (authResult, cookies) = addSetCookies cookies $ fn authResult
servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/AddSetCookie.hsnew file+106
@@ -0,0 +1,106 @@
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.Generic
15+import Servant.Server.Generic
16+import Web.Cookie
17+
18+-- What are we doing here? Well, the idea is to add headers to the response,
19+-- but the headers come from the authentication check. In order to do that, we
20+-- tweak a little the general theme of recursing down the API tree; this time,
21+-- we recurse down a variation of it that adds headers to all the endpoints.
22+-- This involves the usual type-level checks.
23+--
24+-- TODO: If the endpoints already have headers, this will not work as is.
25+
26+data Nat = Z | S Nat
27+
28+type family AddSetCookiesApi (n :: Nat) a where
29+ AddSetCookiesApi ('S 'Z) a = AddSetCookieApi a
30+ AddSetCookiesApi ('S n) a = AddSetCookiesApi n (AddSetCookieApi a)
31+
32+type family AddSetCookieApiVerb a where
33+ AddSetCookieApiVerb (Headers ls a) = Headers (Header "Set-Cookie" SetCookie ': ls) a
34+ AddSetCookieApiVerb a = Headers '[Header "Set-Cookie" SetCookie] a
35+
36+type family AddSetCookieApi a :: *
37+type instance AddSetCookieApi (a :> b) = a :> AddSetCookieApi b
38+type instance AddSetCookieApi (a :<|> b) = AddSetCookieApi a :<|> AddSetCookieApi b
39+type instance AddSetCookieApi (NamedRoutes api) = AddSetCookieApi (ToServantApi api)
40+type instance AddSetCookieApi (Verb method stat ctyps a)
41+ = Verb method stat ctyps (AddSetCookieApiVerb a)
42+type instance AddSetCookieApi Raw = Raw
43+#if MIN_VERSION_servant_server(0,15,0)
44+type instance AddSetCookieApi (Stream method stat framing ctyps a)
45+ = Stream method stat framing ctyps (AddSetCookieApiVerb a)
46+#endif
47+type instance AddSetCookieApi (Headers hs a) = AddSetCookieApiVerb (Headers hs a)
48+
49+data SetCookieList (n :: Nat) :: * where
50+ SetCookieNil :: SetCookieList 'Z
51+ SetCookieCons :: Maybe SetCookie -> SetCookieList n -> SetCookieList ('S n)
52+
53+class AddSetCookies (n :: Nat) orig new where
54+ addSetCookies :: SetCookieList n -> orig -> new
55+
56+instance {-# OVERLAPS #-} AddSetCookies ('S n) oldb newb
57+ => AddSetCookies ('S n) (a -> oldb) (a -> newb) where
58+ addSetCookies cookies oldfn = addSetCookies cookies . oldfn
59+
60+instance AddSetCookies 'Z orig orig where
61+ addSetCookies _ = id
62+
63+instance {-# OVERLAPPABLE #-}
64+ ( Functor m
65+ , AddSetCookies n (m old) (m cookied)
66+ , AddHeader "Set-Cookie" SetCookie cookied new
67+ ) => AddSetCookies ('S n) (m old) (m new) where
68+ addSetCookies (mCookie `SetCookieCons` rest) oldVal =
69+ case mCookie of
70+ Nothing -> noHeader <$> addSetCookies rest oldVal
71+ Just cookie -> addHeader cookie <$> addSetCookies rest oldVal
72+
73+instance {-# OVERLAPS #-}
74+ (AddSetCookies ('S n) a a', AddSetCookies ('S n) b b')
75+ => AddSetCookies ('S n) (a :<|> b) (a' :<|> b') where
76+ addSetCookies cookies (a :<|> b) = addSetCookies cookies a :<|> addSetCookies cookies b
77+
78+instance {-# OVERLAPS #-}
79+ ( AddSetCookies ('S n) (ServerT (ToServantApi api) m) cookiedApi
80+ , Generic (api (AsServerT m))
81+ , GServantProduct (Rep (api (AsServerT m)))
82+ , ToServant api (AsServerT m) ~ ServerT (ToServantApi api) m
83+ )
84+ => AddSetCookies ('S n) (api (AsServerT m)) cookiedApi where
85+ addSetCookies cookies = addSetCookies cookies . toServant
86+
87+-- | for @servant <0.11@
88+instance
89+ AddSetCookies ('S n) Application Application where
90+ addSetCookies cookies r request respond
91+ = r request $ respond . mapResponseHeaders (++ mkHeaders cookies)
92+
93+-- | for @servant >=0.11@
94+instance
95+ AddSetCookies ('S n) (Tagged m Application) (Tagged m Application) where
96+ addSetCookies cookies r = Tagged $ \request respond ->
97+ unTagged r request $ respond . mapResponseHeaders (++ mkHeaders cookies)
98+
99+mkHeaders :: SetCookieList x -> [HTTP.Header]
100+mkHeaders x = ("Set-Cookie",) <$> mkCookies x
101+ where
102+ mkCookies :: forall y. SetCookieList y -> [BS.ByteString]
103+ mkCookies SetCookieNil = []
104+ mkCookies (SetCookieCons Nothing rest) = mkCookies rest
105+ mkCookies (SetCookieCons (Just y) rest)
106+ = 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+182
@@ -0,0 +1,182 @@
1+{-# LANGUAGE CPP #-}
2+module Servant.Auth.Server.Internal.Cookie where
3+
4+import Blaze.ByteString.Builder (toByteString)
5+import Control.Monad.Except
6+import Control.Monad.Reader
7+import qualified Crypto.JOSE as Jose
8+import qualified Crypto.JWT as Jose
9+import Data.ByteArray (constEq)
10+import qualified Data.ByteString as BS
11+import qualified Data.ByteString.Base64 as BS64
12+import qualified Data.ByteString.Lazy as BSL
13+import Data.CaseInsensitive (mk)
14+import Data.Maybe (fromMaybe)
15+import Data.Time.Calendar (Day(..))
16+import Data.Time.Clock (UTCTime(..), secondsToDiffTime)
17+import Network.HTTP.Types (methodGet)
18+import Network.HTTP.Types.Header(hCookie)
19+import Network.Wai (Request, requestHeaders, requestMethod)
20+import Servant (AddHeader, addHeader)
21+import System.Entropy (getEntropy)
22+import Web.Cookie
23+
24+import Servant.Auth.JWT (FromJWT (decodeJWT), ToJWT)
25+import Servant.Auth.Server.Internal.ConfigTypes
26+import Servant.Auth.Server.Internal.JWT (makeJWT, verifyJWT)
27+import Servant.Auth.Server.Internal.Types
28+
29+
30+cookieAuthCheck :: FromJWT usr => CookieSettings -> JWTSettings -> AuthCheck usr
31+cookieAuthCheck ccfg jwtSettings = do
32+ req <- ask
33+ jwtCookie <- maybe mempty return $ do
34+ cookies' <- lookup hCookie $ requestHeaders req
35+ let cookies = parseCookies cookies'
36+ -- Apply the XSRF check if enabled.
37+ guard $ fromMaybe True $ do
38+ xsrfCookieCfg <- xsrfCheckRequired ccfg req
39+ return $ xsrfCookieAuthCheck xsrfCookieCfg req cookies
40+ -- session cookie *must* be HttpOnly and Secure
41+ lookup (sessionCookieName ccfg) cookies
42+ verifiedJWT <- liftIO $ verifyJWT jwtSettings jwtCookie
43+ case verifiedJWT of
44+ Nothing -> mzero
45+ Just v -> return v
46+
47+xsrfCheckRequired :: CookieSettings -> Request -> Maybe XsrfCookieSettings
48+xsrfCheckRequired cookieSettings req = do
49+ xsrfCookieCfg <- cookieXsrfSetting cookieSettings
50+ let disableForGetReq = xsrfExcludeGet xsrfCookieCfg && requestMethod req == methodGet
51+ guard $ not disableForGetReq
52+ return xsrfCookieCfg
53+
54+xsrfCookieAuthCheck :: XsrfCookieSettings -> Request -> [(BS.ByteString, BS.ByteString)] -> Bool
55+xsrfCookieAuthCheck xsrfCookieCfg req cookies = fromMaybe False $ do
56+ xsrfCookie <- lookup (xsrfCookieName xsrfCookieCfg) cookies
57+ xsrfHeader <- lookup (mk $ xsrfHeaderName xsrfCookieCfg) $ requestHeaders req
58+ return $ xsrfCookie `constEq` xsrfHeader
59+
60+-- | Makes a cookie to be used for XSRF.
61+makeXsrfCookie :: CookieSettings -> IO SetCookie
62+makeXsrfCookie cookieSettings = case cookieXsrfSetting cookieSettings of
63+ Just xsrfCookieSettings -> makeRealCookie xsrfCookieSettings
64+ Nothing -> return $ noXsrfTokenCookie cookieSettings
65+ where
66+ makeRealCookie xsrfCookieSettings = do
67+ xsrfValue <- BS64.encode <$> getEntropy 32
68+ return
69+ $ applyXsrfCookieSettings xsrfCookieSettings
70+ $ applyCookieSettings cookieSettings
71+ $ def{ setCookieValue = xsrfValue }
72+
73+
74+-- | Alias for 'makeXsrfCookie'.
75+makeCsrfCookie :: CookieSettings -> IO SetCookie
76+makeCsrfCookie = makeXsrfCookie
77+{-# DEPRECATED makeCsrfCookie "Use makeXsrfCookie instead" #-}
78+
79+
80+-- | Makes a cookie with session information.
81+makeSessionCookie :: ToJWT v => CookieSettings -> JWTSettings -> v -> IO (Maybe SetCookie)
82+makeSessionCookie cookieSettings jwtSettings v = do
83+ ejwt <- makeJWT v jwtSettings (cookieExpires cookieSettings)
84+ case ejwt of
85+ Left _ -> return Nothing
86+ Right jwt -> return
87+ $ Just
88+ $ applySessionCookieSettings cookieSettings
89+ $ applyCookieSettings cookieSettings
90+ $ def{ setCookieValue = BSL.toStrict jwt }
91+
92+noXsrfTokenCookie :: CookieSettings -> SetCookie
93+noXsrfTokenCookie cookieSettings =
94+ applyCookieSettings cookieSettings $ def{ setCookieName = "NO-XSRF-TOKEN", setCookieValue = "" }
95+
96+applyCookieSettings :: CookieSettings -> SetCookie -> SetCookie
97+applyCookieSettings cookieSettings setCookie = setCookie
98+ { setCookieMaxAge = cookieMaxAge cookieSettings
99+ , setCookieExpires = cookieExpires cookieSettings
100+ , setCookiePath = cookiePath cookieSettings
101+ , setCookieDomain = cookieDomain cookieSettings
102+ , setCookieSecure = case cookieIsSecure cookieSettings of
103+ Secure -> True
104+ NotSecure -> False
105+ }
106+
107+applyXsrfCookieSettings :: XsrfCookieSettings -> SetCookie -> SetCookie
108+applyXsrfCookieSettings xsrfCookieSettings setCookie = setCookie
109+ { setCookieName = xsrfCookieName xsrfCookieSettings
110+ , setCookiePath = xsrfCookiePath xsrfCookieSettings
111+ , setCookieHttpOnly = False
112+ }
113+
114+applySessionCookieSettings :: CookieSettings -> SetCookie -> SetCookie
115+applySessionCookieSettings cookieSettings setCookie = setCookie
116+ { setCookieName = sessionCookieName cookieSettings
117+ , setCookieSameSite = case cookieSameSite cookieSettings of
118+ AnySite -> anySite
119+ SameSiteStrict -> Just sameSiteStrict
120+ SameSiteLax -> Just sameSiteLax
121+ , setCookieHttpOnly = True
122+ }
123+ where
124+#if MIN_VERSION_cookie(0,4,5)
125+ anySite = Just sameSiteNone
126+#else
127+ anySite = Nothing
128+#endif
129+
130+-- | For a JWT-serializable session, returns a function that decorates a
131+-- provided response object with XSRF and session cookies. This should be used
132+-- when a user successfully authenticates with credentials.
133+acceptLogin :: ( ToJWT session
134+ , AddHeader "Set-Cookie" SetCookie response withOneCookie
135+ , AddHeader "Set-Cookie" SetCookie withOneCookie withTwoCookies )
136+ => CookieSettings
137+ -> JWTSettings
138+ -> session
139+ -> IO (Maybe (response -> withTwoCookies))
140+acceptLogin cookieSettings jwtSettings session = do
141+ mSessionCookie <- makeSessionCookie cookieSettings jwtSettings session
142+ case mSessionCookie of
143+ Nothing -> pure Nothing
144+ Just sessionCookie -> do
145+ xsrfCookie <- makeXsrfCookie cookieSettings
146+ return $ Just $ addHeader sessionCookie . addHeader xsrfCookie
147+
148+-- | Arbitrary cookie expiry time set back in history after unix time 0
149+expireTime :: UTCTime
150+expireTime = UTCTime (ModifiedJulianDay 50000) 0
151+
152+-- | Adds headers to a response that clears all session cookies
153+-- | using max-age and expires cookie attributes.
154+clearSession :: ( AddHeader "Set-Cookie" SetCookie response withOneCookie
155+ , AddHeader "Set-Cookie" SetCookie withOneCookie withTwoCookies )
156+ => CookieSettings
157+ -> response
158+ -> withTwoCookies
159+clearSession cookieSettings = addHeader clearedSessionCookie . addHeader clearedXsrfCookie
160+ where
161+ -- According to RFC6265 max-age takes precedence, but IE/Edge ignore it completely so we set both
162+ cookieSettingsExpires = cookieSettings
163+ { cookieExpires = Just expireTime
164+ , cookieMaxAge = Just (secondsToDiffTime 0)
165+ }
166+ clearedSessionCookie = applySessionCookieSettings cookieSettingsExpires $ applyCookieSettings cookieSettingsExpires def
167+ clearedXsrfCookie = case cookieXsrfSetting cookieSettings of
168+ Just xsrfCookieSettings -> applyXsrfCookieSettings xsrfCookieSettings $ applyCookieSettings cookieSettingsExpires def
169+ Nothing -> noXsrfTokenCookie cookieSettingsExpires
170+
171+makeSessionCookieBS :: ToJWT v => CookieSettings -> JWTSettings -> v -> IO (Maybe BS.ByteString)
172+makeSessionCookieBS a b c = fmap (toByteString . renderSetCookie) <$> makeSessionCookie a b c
173+
174+-- | Alias for 'makeSessionCookie'.
175+makeCookie :: ToJWT v => CookieSettings -> JWTSettings -> v -> IO (Maybe SetCookie)
176+makeCookie = makeSessionCookie
177+{-# DEPRECATED makeCookie "Use makeSessionCookie instead" #-}
178+
179+-- | Alias for 'makeSessionCookieBS'.
180+makeCookieBS :: ToJWT v => CookieSettings -> JWTSettings -> v -> IO (Maybe BS.ByteString)
181+makeCookieBS = makeSessionCookieBS
182+{-# 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+72
@@ -0,0 +1,72 @@
1+module Servant.Auth.Server.Internal.JWT where
2+
3+import Control.Lens
4+import Control.Monad.Except
5+import Control.Monad.Reader
6+import qualified Crypto.JOSE as Jose
7+import qualified Crypto.JWT as Jose
8+import Data.Aeson (FromJSON, Result (..), ToJSON, fromJSON,
9+ toJSON)
10+import Data.ByteArray (constEq)
11+import qualified Data.ByteString as BS
12+import qualified Data.ByteString.Lazy as BSL
13+import qualified Data.HashMap.Strict as HM
14+import Data.Maybe (fromMaybe)
15+import qualified Data.Text as T
16+import Data.Time (UTCTime)
17+import Network.Wai (requestHeaders)
18+
19+import Servant.Auth.JWT (FromJWT(..), ToJWT(..))
20+import Servant.Auth.Server.Internal.ConfigTypes
21+import Servant.Auth.Server.Internal.Types
22+
23+
24+-- | A JWT @AuthCheck@. You likely won't need to use this directly unless you
25+-- are protecting a @Raw@ endpoint.
26+jwtAuthCheck :: FromJWT usr => JWTSettings -> AuthCheck usr
27+jwtAuthCheck jwtSettings = do
28+ req <- ask
29+ token <- maybe mempty return $ do
30+ authHdr <- lookup "Authorization" $ requestHeaders req
31+ let bearer = "Bearer "
32+ (mbearer, rest) = BS.splitAt (BS.length bearer) authHdr
33+ guard (mbearer `constEq` bearer)
34+ return rest
35+ verifiedJWT <- liftIO $ verifyJWT jwtSettings token
36+ case verifiedJWT of
37+ Nothing -> mzero
38+ Just v -> return v
39+
40+-- | Creates a JWT containing the specified data. The data is stored in the
41+-- @dat@ claim. The 'Maybe UTCTime' argument indicates the time at which the
42+-- token expires.
43+makeJWT :: ToJWT a
44+ => a -> JWTSettings -> Maybe UTCTime -> IO (Either Jose.Error BSL.ByteString)
45+makeJWT v cfg expiry = runExceptT $ do
46+ bestAlg <- Jose.bestJWSAlg $ signingKey cfg
47+ let alg = fromMaybe bestAlg $ jwtAlg cfg
48+ ejwt <- Jose.signClaims (signingKey cfg)
49+ (Jose.newJWSHeader ((), alg))
50+ (addExp $ encodeJWT v)
51+
52+ return $ Jose.encodeCompact ejwt
53+ where
54+ addExp claims = case expiry of
55+ Nothing -> claims
56+ Just e -> claims & Jose.claimExp ?~ Jose.NumericDate e
57+
58+
59+verifyJWT :: FromJWT a => JWTSettings -> BS.ByteString -> IO (Maybe a)
60+verifyJWT jwtCfg input = do
61+ keys <- validationKeys jwtCfg
62+ verifiedJWT <- runExceptT $ do
63+ unverifiedJWT <- Jose.decodeCompact (BSL.fromStrict input)
64+ Jose.verifyClaims
65+ (jwtSettingsToJwtValidationSettings jwtCfg)
66+ keys
67+ unverifiedJWT
68+ return $ case verifiedJWT of
69+ Left (_ :: Jose.JWTError) -> Nothing
70+ Right v -> case decodeJWT v of
71+ Left _ -> Nothing
72+ 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+112
@@ -0,0 +1,112 @@
1+{-# LANGUAGE CPP #-}
2+module Servant.Auth.Server.Internal.Types where
3+
4+import Control.Applicative
5+import Control.Monad.Reader
6+import Control.Monad.Time
7+import Data.Monoid (Monoid (..))
8+import Data.Semigroup (Semigroup (..))
9+import Data.Time (getCurrentTime)
10+import GHC.Generics (Generic)
11+import Network.Wai (Request)
12+
13+import qualified Control.Monad.Fail as Fail
14+
15+-- | The result of an authentication attempt.
16+data AuthResult val
17+ = BadPassword
18+ | NoSuchUser
19+ -- | Authentication succeeded.
20+ | Authenticated val
21+ -- | If an authentication procedure cannot be carried out - if for example it
22+ -- expects a password and username in a header that is not present -
23+ -- @Indefinite@ is returned. This indicates that other authentication
24+ -- methods should be tried.
25+ | Indefinite
26+ deriving (Eq, Show, Read, Generic, Ord, Functor, Traversable, Foldable)
27+
28+instance Semigroup (AuthResult val) where
29+ Indefinite <> y = y
30+ x <> _ = x
31+
32+instance Monoid (AuthResult val) where
33+ mempty = Indefinite
34+ mappend = (<>)
35+
36+instance Applicative AuthResult where
37+ pure = return
38+ (<*>) = ap
39+
40+instance Monad AuthResult where
41+ return = Authenticated
42+ Authenticated v >>= f = f v
43+ BadPassword >>= _ = BadPassword
44+ NoSuchUser >>= _ = NoSuchUser
45+ Indefinite >>= _ = Indefinite
46+
47+instance Alternative AuthResult where
48+ empty = mzero
49+ (<|>) = mplus
50+
51+instance MonadPlus AuthResult where
52+ mzero = mempty
53+ mplus = (<>)
54+
55+
56+-- | An @AuthCheck@ is the function used to decide the authentication status
57+-- (the 'AuthResult') of a request. Different @AuthCheck@s may be combined as a
58+-- Monoid or Alternative; the semantics of this is that the *first*
59+-- non-'Indefinite' result from left to right is used and the rest are ignored.
60+newtype AuthCheck val = AuthCheck
61+ { runAuthCheck :: Request -> IO (AuthResult val) }
62+ deriving (Generic, Functor)
63+
64+instance Semigroup (AuthCheck val) where
65+ AuthCheck f <> AuthCheck g = AuthCheck $ \x -> do
66+ fx <- f x
67+ case fx of
68+ Indefinite -> g x
69+ r -> pure r
70+
71+instance Monoid (AuthCheck val) where
72+ mempty = AuthCheck $ const $ return mempty
73+ mappend = (<>)
74+
75+instance Applicative AuthCheck where
76+ pure = return
77+ (<*>) = ap
78+
79+instance Monad AuthCheck where
80+ return = AuthCheck . return . return . return
81+ AuthCheck ac >>= f = AuthCheck $ \req -> do
82+ aresult <- ac req
83+ case aresult of
84+ Authenticated usr -> runAuthCheck (f usr) req
85+ BadPassword -> return BadPassword
86+ NoSuchUser -> return NoSuchUser
87+ Indefinite -> return Indefinite
88+
89+#if !MIN_VERSION_base(4,13,0)
90+ fail = Fail.fail
91+#endif
92+
93+instance Fail.MonadFail AuthCheck where
94+ fail _ = AuthCheck . const $ return Indefinite
95+
96+instance MonadReader Request AuthCheck where
97+ ask = AuthCheck $ \x -> return (Authenticated x)
98+ local f (AuthCheck check) = AuthCheck $ \req -> check (f req)
99+
100+instance MonadIO AuthCheck where
101+ liftIO action = AuthCheck $ const $ Authenticated <$> action
102+
103+instance MonadTime AuthCheck where
104+ currentTime = liftIO getCurrentTime
105+
106+instance Alternative AuthCheck where
107+ empty = mzero
108+ (<|>) = mplus
109+
110+instance MonadPlus AuthCheck where
111+ mzero = mempty
112+ 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+607
@@ -0,0 +1,607 @@
1+{-# LANGUAGE CPP #-}
2+module Servant.Auth.ServerSpec (spec) where
3+
4+#if !MIN_VERSION_servant_server(0,16,0)
5+#define ServerError ServantErr
6+#endif
7+
8+import Control.Lens
9+import Control.Monad.Except (runExceptT)
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)
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.CaseInsensitive (mk)
29+import Data.Foldable (find)
30+import Data.Monoid
31+import Data.Time
32+import Data.Time.Clock (getCurrentTime)
33+import GHC.Generics (Generic)
34+import Network.HTTP.Client (cookie_http_only,
35+ cookie_name, cookie_value,
36+ cookie_expiry_time,
37+ destroyCookieJar)
38+import Network.HTTP.Types (Status, status200,
39+ status401)
40+import Network.Wai (responseLBS)
41+import Network.Wai.Handler.Warp (testWithApplication)
42+import Network.Wreq (Options, auth, basicAuth,
43+ cookieExpiryTime, cookies,
44+ defaults, get, getWith, postWith,
45+ header, oauth2Bearer,
46+ responseBody,
47+ responseCookieJar,
48+ responseHeader,
49+ responseStatus)
50+import Network.Wreq.Types (Postable(..))
51+import Servant hiding (BasicAuth,
52+ IsSecure (..), header)
53+import Servant.API.Generic ((:-))
54+import Servant.Auth.Server
55+import Servant.Auth.Server.Internal.Cookie (expireTime)
56+import Servant.Auth.Server.SetCookieOrphan ()
57+#if MIN_VERSION_servant_server(0,15,0)
58+import qualified Servant.Types.SourceT as S
59+#endif
60+import System.IO.Unsafe (unsafePerformIO)
61+import Test.Hspec
62+import Test.QuickCheck
63+import qualified Network.HTTP.Client as HCli
64+
65+
66+
67+spec :: Spec
68+spec = do
69+ authSpec
70+ cookieAuthSpec
71+ jwtAuthSpec
72+ throwAllSpec
73+ basicAuthSpec
74+
75+------------------------------------------------------------------------------
76+-- * Auth {{{
77+
78+authSpec :: Spec
79+authSpec
80+ = describe "The Auth combinator"
81+ $ around (testWithApplication . return $ app jwtAndCookieApi) $ do
82+
83+ it "returns a 401 if all authentications are Indefinite" $ \port -> do
84+ get (url port) `shouldHTTPErrorWith` status401
85+
86+ it "succeeds if one authentication suceeds" $ \port -> property $
87+ \(user :: User) -> do
88+ jwt <- makeJWT user jwtCfg Nothing
89+ opts <- addJwtToHeader jwt
90+ resp <- getWith opts (url port)
91+ resp ^? responseBody . _JSON `shouldBe` Just (length $ name user)
92+
93+ it "fails (403) if one authentication fails" $ const $
94+ pendingWith "Authentications don't yet fail, only are Indefinite"
95+
96+ it "doesn't clobber pre-existing response headers" $ \port -> property $
97+ \(user :: User) -> do
98+ jwt <- makeJWT user jwtCfg Nothing
99+ opts <- addJwtToHeader jwt
100+ resp <- getWith opts (url port ++ "/header")
101+ resp ^. responseHeader "Blah" `shouldBe` "1797"
102+ resp ^. responseHeader "Set-Cookie" `shouldSatisfy` (/= "")
103+
104+ context "Raw" $ do
105+
106+ it "gets the response body" $ \port -> property $ \(user :: User) -> do
107+ jwt <- makeJWT user jwtCfg Nothing
108+ opts <- addJwtToHeader jwt
109+ resp <- getWith opts (url port ++ "/raw")
110+ resp ^. responseBody `shouldBe` "how are you?"
111+
112+ it "doesn't clobber pre-existing reponse headers" $ \port -> property $
113+ \(user :: User) -> do
114+ jwt <- makeJWT user jwtCfg Nothing
115+ opts <- addJwtToHeader jwt
116+ resp <- getWith opts (url port ++ "/raw")
117+ resp ^. responseHeader "hi" `shouldBe` "there"
118+ resp ^. responseHeader "Set-Cookie" `shouldSatisfy` (/= "")
119+
120+
121+ context "Setting cookies" $ do
122+
123+ it "sets cookies that it itself accepts" $ \port -> property $ \user -> do
124+ jwt <- createJWT theKey (newJWSHeader ((), HS256))
125+ (claims $ toJSON user)
126+ opts' <- addJwtToCookie cookieCfg jwt
127+ let opts = addCookie (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"])
128+ (xsrfField xsrfCookieName cookieCfg <> "=blah")
129+ resp <- getWith opts (url port)
130+ let (cookieJar:_) = resp ^.. responseCookieJar
131+ Just xxsrf = find (\x -> cookie_name x == xsrfField xsrfCookieName cookieCfg)
132+ $ destroyCookieJar cookieJar
133+ opts2 = defaults
134+ & cookies .~ Just cookieJar
135+ & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ [cookie_value xxsrf]
136+ resp2 <- getWith opts2 (url port)
137+ resp2 ^? responseBody . _JSON `shouldBe` Just (length $ name user)
138+
139+ it "uses the Expiry from the configuration" $ \port -> property $ \(user :: User) -> do
140+ jwt <- createJWT theKey (newJWSHeader ((), HS256))
141+ (claims $ toJSON user)
142+ opts' <- addJwtToCookie cookieCfg jwt
143+ let opts = addCookie (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"])
144+ (xsrfField xsrfCookieName cookieCfg <> "=blah")
145+ resp <- getWith opts (url port)
146+ let (cookieJar:_) = resp ^.. responseCookieJar
147+ Just xxsrf = find (\x -> cookie_name x == xsrfField xsrfCookieName cookieCfg)
148+ $ destroyCookieJar cookieJar
149+ xxsrf ^. cookieExpiryTime `shouldBe` future
150+
151+ it "sets the token cookie as HttpOnly" $ \port -> property $ \(user :: User) -> do
152+ jwt <- createJWT theKey (newJWSHeader ((), HS256))
153+ (claims $ toJSON user)
154+ opts' <- addJwtToCookie cookieCfg jwt
155+ let opts = addCookie (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"])
156+ (xsrfField xsrfCookieName cookieCfg <> "=blah")
157+ resp <- getWith opts (url port)
158+ let (cookieJar:_) = resp ^.. responseCookieJar
159+ Just token = find (\x -> cookie_name x == sessionCookieName cookieCfg)
160+ $ destroyCookieJar cookieJar
161+ cookie_http_only token `shouldBe` True
162+
163+
164+
165+-- }}}
166+------------------------------------------------------------------------------
167+-- * Cookie Auth {{{
168+
169+cookieAuthSpec :: Spec
170+cookieAuthSpec
171+ = describe "The Auth combinator" $ do
172+ describe "With XSRF check" $
173+ around (testWithApplication . return $ app cookieOnlyApi) $ do
174+
175+ it "fails if XSRF header and cookie don't match" $ \port -> property
176+ $ \(user :: User) -> do
177+ jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)
178+ opts' <- addJwtToCookie cookieCfg jwt
179+ let opts = addCookie (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"])
180+ (xsrfField xsrfCookieName cookieCfg <> "=blerg")
181+ getWith opts (url port) `shouldHTTPErrorWith` status401
182+
183+ it "fails with no XSRF header or cookie" $ \port -> property
184+ $ \(user :: User) -> do
185+ jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)
186+ opts <- addJwtToCookie cookieCfg jwt
187+ getWith opts (url port) `shouldHTTPErrorWith` status401
188+
189+ it "succeeds if XSRF header and cookie match, and JWT is valid" $ \port -> property
190+ $ \(user :: User) -> do
191+ jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)
192+ opts' <- addJwtToCookie cookieCfg jwt
193+ let opts = addCookie (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"])
194+ (xsrfField xsrfCookieName cookieCfg <> "=blah")
195+ resp <- getWith opts (url port)
196+ resp ^? responseBody . _JSON `shouldBe` Just (length $ name user)
197+
198+ it "sets and clears the right cookies" $ \port -> property
199+ $ \(user :: User) -> do
200+ let optsFromResp resp =
201+ let jar = resp ^. responseCookieJar
202+ Just xsrfCookieValue = cookie_value <$> find (\c -> cookie_name c == xsrfField xsrfCookieName cookieCfg) (destroyCookieJar jar)
203+ in defaults
204+ & cookies .~ Just jar -- real cookie jars aren't updated by being replaced
205+ & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ [xsrfCookieValue]
206+
207+ resp <- postWith defaults (url port ++ "/login") user
208+ (resp ^. responseCookieJar) `shouldMatchCookieNames`
209+ [ sessionCookieName cookieCfg
210+ , xsrfField xsrfCookieName cookieCfg
211+ ]
212+ let loggedInOpts = optsFromResp resp
213+
214+ resp <- getWith loggedInOpts (url port)
215+ resp ^? responseBody . _JSON `shouldBe` Just (length $ name user)
216+
217+ -- logout
218+ resp <- getWith loggedInOpts (url port ++ "/logout")
219+
220+ -- assert cookies were expired
221+ now <- getCurrentTime
222+ let assertCookie c = now >= cookie_expiry_time c
223+ all assertCookie (destroyCookieJar (resp ^. responseCookieJar)) `shouldBe` True
224+
225+ let loggedOutOpts = optsFromResp resp
226+ getWith loggedOutOpts (url port) `shouldHTTPErrorWith` status401
227+
228+ describe "With no XSRF check for GET requests" $ let
229+ noXsrfGet xsrfCfg = xsrfCfg { xsrfExcludeGet = True }
230+ cookieCfgNoXsrfGet = cookieCfg { cookieXsrfSetting = fmap noXsrfGet $ cookieXsrfSetting cookieCfg }
231+ in around (testWithApplication . return $ appWithCookie cookieOnlyApi cookieCfgNoXsrfGet) $ do
232+
233+ it "succeeds with no XSRF header or cookie for GET" $ \port -> property
234+ $ \(user :: User) -> do
235+ jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)
236+ opts <- addJwtToCookie cookieCfgNoXsrfGet jwt
237+ resp <- getWith opts (url port)
238+ resp ^? responseBody . _JSON `shouldBe` Just (length $ name user)
239+
240+ it "fails with no XSRF header or cookie for POST" $ \port -> property
241+ $ \(user :: User) number -> do
242+ jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)
243+ opts <- addJwtToCookie cookieCfgNoXsrfGet jwt
244+ postWith opts (url port) (toJSON (number :: Int)) `shouldHTTPErrorWith` status401
245+
246+ describe "With no XSRF check at all" $ let
247+ cookieCfgNoXsrf = cookieCfg { cookieXsrfSetting = Nothing }
248+ in around (testWithApplication . return $ appWithCookie cookieOnlyApi cookieCfgNoXsrf) $ do
249+
250+ it "succeeds with no XSRF header or cookie for GET" $ \port -> property
251+ $ \(user :: User) -> do
252+ jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)
253+ opts <- addJwtToCookie cookieCfgNoXsrf jwt
254+ resp <- getWith opts (url port)
255+ resp ^? responseBody . _JSON `shouldBe` Just (length $ name user)
256+
257+ it "succeeds with no XSRF header or cookie for POST" $ \port -> property
258+ $ \(user :: User) number -> do
259+ jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)
260+ opts <- addJwtToCookie cookieCfgNoXsrf jwt
261+ resp <- postWith opts (url port) $ toJSON (number :: Int)
262+ resp ^? responseBody . _JSON `shouldBe` Just number
263+
264+ it "sets and clears the right cookies" $ \port -> property
265+ $ \(user :: User) -> do
266+ let optsFromResp resp = defaults
267+ & cookies .~ Just (resp ^. responseCookieJar) -- real cookie jars aren't updated by being replaced
268+
269+ resp <- postWith defaults (url port ++ "/login") user
270+ (resp ^. responseCookieJar) `shouldMatchCookieNames`
271+ [ sessionCookieName cookieCfg
272+ , "NO-XSRF-TOKEN"
273+ ]
274+ let loggedInOpts = optsFromResp resp
275+
276+ resp <- getWith (loggedInOpts) (url port)
277+ resp ^? responseBody . _JSON `shouldBe` Just (length $ name user)
278+
279+ resp <- getWith loggedInOpts (url port ++ "/logout")
280+ (resp ^. responseCookieJar) `shouldMatchCookieNameValues`
281+ [ (sessionCookieName cookieCfg, "value")
282+ , ("NO-XSRF-TOKEN", "")
283+ ]
284+
285+ -- assert cookies were expired
286+ now <- getCurrentTime
287+ let assertCookie c = now >= cookie_expiry_time c
288+ all assertCookie (destroyCookieJar (resp ^. responseCookieJar)) `shouldBe` True
289+
290+ let loggedOutOpts = optsFromResp resp
291+
292+ getWith loggedOutOpts (url port) `shouldHTTPErrorWith` status401
293+
294+-- }}}
295+------------------------------------------------------------------------------
296+-- * JWT Auth {{{
297+
298+jwtAuthSpec :: Spec
299+jwtAuthSpec
300+ = describe "The JWT combinator"
301+ $ around (testWithApplication . return $ app jwtOnlyApi) $ do
302+
303+ it "fails if 'aud' does not match predicate" $ \port -> property $
304+ \(user :: User) -> do
305+ jwt <- createJWT theKey (newJWSHeader ((), HS256))
306+ (claims (toJSON user) & claimAud .~ Just (Audience ["boo"]))
307+ opts <- addJwtToHeader (jwt >>= (return . encodeCompact))
308+ getWith opts (url port) `shouldHTTPErrorWith` status401
309+
310+ it "succeeds if 'aud' does match predicate" $ \port -> property $
311+ \(user :: User) -> do
312+ jwt <- createJWT theKey (newJWSHeader ((), HS256))
313+ (claims (toJSON user) & claimAud .~ Just (Audience ["anythingElse"]))
314+ opts <- addJwtToHeader (jwt >>= (return . encodeCompact))
315+ resp <- getWith opts (url port)
316+ resp ^. responseStatus `shouldBe` status200
317+
318+ it "fails if 'nbf' is set to a future date" $ \port -> property $
319+ \(user :: User) -> do
320+ jwt <- createJWT theKey (newJWSHeader ((), HS256))
321+ (claims (toJSON user) & claimNbf .~ Just (NumericDate future))
322+ opts <- addJwtToHeader (jwt >>= (return . encodeCompact))
323+ getWith opts (url port) `shouldHTTPErrorWith` status401
324+
325+ it "fails if 'exp' is set to a past date" $ \port -> property $
326+ \(user :: User) -> do
327+ jwt <- makeJWT user jwtCfg (Just past)
328+ opts <- addJwtToHeader jwt
329+ getWith opts (url port) `shouldHTTPErrorWith` status401
330+
331+ it "succeeds if 'exp' is set to a future date" $ \port -> property $
332+ \(user :: User) -> do
333+ jwt <- makeJWT user jwtCfg (Just future)
334+ opts <- addJwtToHeader jwt
335+ resp <- getWith opts (url port)
336+ resp ^. responseStatus `shouldBe` status200
337+
338+ it "fails if JWT is not signed" $ \port -> property $ \(user :: User) -> do
339+ jwt <- createJWT theKey (newJWSHeader ((), None))
340+ (claims $ toJSON user)
341+ opts <- addJwtToHeader (jwt >>= (return . encodeCompact))
342+ getWith opts (url port) `shouldHTTPErrorWith` status401
343+
344+ it "fails if JWT does not use expected algorithm" $ const $
345+ pendingWith "Need https://github.com/frasertweedale/hs-jose/issues/19"
346+
347+ it "fails if data is not valid JSON" $ \port -> do
348+ jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims "{{")
349+ opts <- addJwtToHeader (jwt >>= (return .encodeCompact))
350+ getWith opts (url port) `shouldHTTPErrorWith` status401
351+
352+ it "suceeds as wreq's oauth2Bearer" $ \port -> property $ \(user :: User) -> do
353+ jwt <- createJWT theKey (newJWSHeader ((), HS256))
354+ (claims $ toJSON user)
355+ resp <- case jwt >>= (return . encodeCompact) of
356+ Left (e :: Error) -> fail $ show e
357+ Right v -> getWith (defaults & auth ?~ oauth2Bearer (BSL.toStrict v)) (url port)
358+ resp ^. responseStatus `shouldBe` status200
359+
360+-- }}}
361+------------------------------------------------------------------------------
362+-- * Basic Auth {{{
363+
364+basicAuthSpec :: Spec
365+basicAuthSpec = describe "The BasicAuth combinator"
366+ $ around (testWithApplication . return $ app basicAuthApi) $ do
367+
368+ it "succeeds with the correct password and username" $ \port -> do
369+ resp <- getWith (defaults & auth ?~ basicAuth "ali" "Open sesame") (url port)
370+ resp ^. responseStatus `shouldBe` status200
371+
372+ it "fails with non-existent user" $ \port -> do
373+ getWith (defaults & auth ?~ basicAuth "thief" "Open sesame") (url port)
374+ `shouldHTTPErrorWith` status401
375+
376+ it "fails with incorrect password" $ \port -> do
377+ getWith (defaults & auth ?~ basicAuth "ali" "phatic") (url port)
378+ `shouldHTTPErrorWith` status401
379+
380+ it "fails with no auth header" $ \port -> do
381+ get (url port) `shouldHTTPErrorWith` status401
382+
383+-- }}}
384+------------------------------------------------------------------------------
385+-- * ThrowAll {{{
386+
387+throwAllSpec :: Spec
388+throwAllSpec = describe "throwAll" $ do
389+
390+ it "works for plain values" $ do
391+ let t :: Either ServerError Int :<|> Either ServerError Bool :<|> Either ServerError String
392+ t = throwAll err401
393+ t `shouldBe` throwError err401 :<|> throwError err401 :<|> throwError err401
394+
395+ it "works for function types" $ property $ \i -> do
396+ let t :: Int -> (Either ServerError Bool :<|> Either ServerError String)
397+ t = throwAll err401
398+ expected _ = throwError err401 :<|> throwError err401
399+ t i `shouldBe` expected i
400+
401+-- }}}
402+------------------------------------------------------------------------------
403+-- * API and Server {{{
404+
405+type API auths
406+ = Auth auths User :>
407+ ( Get '[JSON] Int
408+ :<|> ReqBody '[JSON] Int :> Post '[JSON] Int
409+ :<|> NamedRoutes DummyRoutes
410+ :<|> "header" :> Get '[JSON] (Headers '[Header "Blah" Int] Int)
411+#if MIN_VERSION_servant_server(0,15,0)
412+ :<|> "stream" :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString)
413+#endif
414+ :<|> "raw" :> Raw
415+ )
416+ :<|> "login" :> ReqBody '[JSON] User :> Post '[JSON] (Headers '[ Header "Set-Cookie" SetCookie
417+ , Header "Set-Cookie" SetCookie ] NoContent)
418+ :<|> "logout" :> Get '[JSON] (Headers '[ Header "Set-Cookie" SetCookie
419+ , Header "Set-Cookie" SetCookie ] NoContent)
420+
421+data DummyRoutes mode = DummyRoutes
422+ { dummyInt :: mode :- "dummy" :> Get '[JSON] Int
423+ } deriving Generic
424+
425+jwtOnlyApi :: Proxy (API '[Servant.Auth.Server.JWT])
426+jwtOnlyApi = Proxy
427+
428+cookieOnlyApi :: Proxy (API '[Cookie])
429+cookieOnlyApi = Proxy
430+
431+basicAuthApi :: Proxy (API '[BasicAuth])
432+basicAuthApi = Proxy
433+
434+jwtAndCookieApi :: Proxy (API '[Servant.Auth.Server.JWT, Cookie])
435+jwtAndCookieApi = Proxy
436+
437+theKey :: JWK
438+theKey = unsafePerformIO . genJWK $ OctGenParam 256
439+{-# NOINLINE theKey #-}
440+
441+
442+cookieCfg :: CookieSettings
443+cookieCfg = def
444+ { cookieExpires = Just future
445+ , cookieIsSecure = NotSecure
446+ , sessionCookieName = "RuncibleSpoon"
447+ , cookieXsrfSetting = pure $ def
448+ { xsrfCookieName = "TheyDinedOnMince"
449+ , xsrfHeaderName = "AndSlicesOfQuince"
450+ }
451+ }
452+xsrfField :: (XsrfCookieSettings -> a) -> CookieSettings -> a
453+xsrfField f = maybe (error "expected XsrfCookieSettings for test") f . cookieXsrfSetting
454+
455+jwtCfg :: JWTSettings
456+jwtCfg = (defaultJWTSettings theKey) { audienceMatches = \x ->
457+ if x == "boo" then DoesNotMatch else Matches }
458+
459+instance FromBasicAuthData User where
460+ fromBasicAuthData (BasicAuthData usr pwd) _
461+ = return $ if usr == "ali" && pwd == "Open sesame"
462+ then Authenticated $ User "ali" "ali@the-thieves-den.com"
463+ else Indefinite
464+
465+-- Could be anything, really, but since this is already in the cfg we don't
466+-- have to add it
467+type instance BasicAuthCfg = JWK
468+
469+appWithCookie :: AreAuths auths '[CookieSettings, JWTSettings, JWK] User
470+ => Proxy (API auths) -> CookieSettings -> Application
471+appWithCookie api ccfg = serveWithContext api ctx $ server ccfg
472+ where
473+ ctx = ccfg :. jwtCfg :. theKey :. EmptyContext
474+
475+-- | Takes a proxy parameter indicating which authentication systems to enable.
476+app :: AreAuths auths '[CookieSettings, JWTSettings, JWK] User
477+ => Proxy (API auths) -> Application
478+app api = appWithCookie api cookieCfg
479+
480+server :: CookieSettings -> Server (API auths)
481+server ccfg =
482+ (\authResult -> case authResult of
483+ Authenticated usr -> getInt usr
484+ :<|> postInt usr
485+ :<|> DummyRoutes { dummyInt = getInt usr }
486+ :<|> getHeaderInt
487+#if MIN_VERSION_servant_server(0,15,0)
488+ :<|> return (S.source ["bytestring"])
489+#endif
490+ :<|> raw
491+ Indefinite -> throwAll err401
492+ _ -> throwAll err403
493+ )
494+ :<|> getLogin
495+ :<|> getLogout
496+ where
497+ getInt :: User -> Handler Int
498+ getInt usr = return . length $ name usr
499+
500+ postInt :: User -> Int -> Handler Int
501+ postInt _ = return
502+
503+ getHeaderInt :: Handler (Headers '[Header "Blah" Int] Int)
504+ getHeaderInt = return $ addHeader 1797 17
505+
506+ getLogin :: User -> Handler (Headers '[ Header "Set-Cookie" SetCookie
507+ , Header "Set-Cookie" SetCookie ] NoContent)
508+ getLogin user = do
509+ maybeApplyCookies <- liftIO $ acceptLogin ccfg jwtCfg user
510+ case maybeApplyCookies of
511+ Just applyCookies -> return $ applyCookies NoContent
512+ Nothing -> error "cookies failed to apply"
513+
514+ getLogout :: Handler (Headers '[ Header "Set-Cookie" SetCookie
515+ , Header "Set-Cookie" SetCookie ] NoContent)
516+ getLogout = return $ clearSession ccfg NoContent
517+
518+ raw :: Server Raw
519+ raw =
520+#if MIN_VERSION_servant_server(0,11,0)
521+ Tagged $
522+#endif
523+ \_req respond ->
524+ respond $ responseLBS status200 [("hi", "there")] "how are you?"
525+
526+-- }}}
527+------------------------------------------------------------------------------
528+-- * Utils {{{
529+
530+past :: UTCTime
531+past = parseTimeOrError True defaultTimeLocale "%Y-%m-%d" "1970-01-01"
532+
533+future :: UTCTime
534+future = parseTimeOrError True defaultTimeLocale "%Y-%m-%d" "2070-01-01"
535+
536+addJwtToHeader :: Either Error BSL.ByteString -> IO Options
537+addJwtToHeader jwt = case jwt of
538+ Left e -> fail $ show e
539+ Right v -> return
540+ $ defaults & header "Authorization" .~ ["Bearer " <> BSL.toStrict v]
541+
542+createJWT :: JWK -> JWSHeader () -> ClaimsSet -> IO (Either Error Crypto.JWT.SignedJWT)
543+createJWT k a b = runExceptT $ signClaims k a b
544+
545+addJwtToCookie :: ToCompact a => CookieSettings -> Either Error a -> IO Options
546+addJwtToCookie ccfg jwt = case jwt >>= (return . encodeCompact) of
547+ Left e -> fail $ show e
548+ Right v -> return
549+ $ defaults & header "Cookie" .~ [sessionCookieName ccfg <> "=" <> BSL.toStrict v]
550+
551+addCookie :: Options -> BS.ByteString -> Options
552+addCookie opts cookie' = opts & header "Cookie" %~ \c -> case c of
553+ [h] -> [cookie' <> "; " <> h]
554+ [] -> [cookie']
555+ _ -> error "expecting single cookie header"
556+
557+
558+shouldHTTPErrorWith :: IO a -> Status -> Expectation
559+shouldHTTPErrorWith act stat = act `shouldThrow` \e -> case e of
560+#if MIN_VERSION_http_client(0,5,0)
561+ HCli.HttpExceptionRequest _ (HCli.StatusCodeException resp _)
562+ -> HCli.responseStatus resp == stat
563+#else
564+ HCli.StatusCodeException x _ _ -> x == stat
565+#endif
566+ _ -> False
567+
568+shouldMatchCookieNames :: HCli.CookieJar -> [BS.ByteString] -> Expectation
569+shouldMatchCookieNames cj patterns
570+ = fmap cookie_name (destroyCookieJar cj)
571+ `shouldMatchList` patterns
572+
573+shouldMatchCookieNameValues :: HCli.CookieJar -> [(BS.ByteString, BS.ByteString)] -> Expectation
574+shouldMatchCookieNameValues cj patterns
575+ = fmap ((,) <$> cookie_name <*> cookie_value) (destroyCookieJar cj)
576+ `shouldMatchList` patterns
577+
578+url :: Int -> String
579+url port = "http://localhost:" <> show port
580+
581+claims :: Value -> ClaimsSet
582+claims val = emptyClaimsSet & unregisteredClaims . at "dat" .~ Just val
583+-- }}}
584+------------------------------------------------------------------------------
585+-- * Types {{{
586+
587+data User = User
588+ { name :: String
589+ , _id :: String
590+ } deriving (Eq, Show, Read, Generic)
591+
592+instance FromJWT User
593+instance ToJWT User
594+instance FromJSON User
595+instance ToJSON User
596+
597+instance Arbitrary User where
598+ arbitrary = User <$> arbitrary <*> arbitrary
599+
600+instance Postable User where
601+ postPayload user request = return $ request
602+ { HCli.requestBody = HCli.RequestBodyLBS $ encode user
603+ , HCli.requestHeaders = (mk "Content-Type", "application/json") : HCli.requestHeaders request
604+ }
605+
606+
607+-- }}}
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.17
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.2
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.17
37+ , containers >= 0.6 && < 0.7
38+ , aeson >= 1.3.1.1 && < 3
39+ , jose >= 0.7.0.0 && < 0.10
40+ , lens >= 4.16.1 && < 5.2
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 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+50
@@ -1,6 +1,56 @@
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+
4540.18.1
555------
656
servant-client-core/servant-client-core.cabal+17−16
@@ -1,6 +1,6 @@
1−cabal-version: >=1.10
1+cabal-version: 2.2
22name: servant-client-core
3−version: 0.18.1
3+version: 0.19
44
55synopsis: Core functionality and class for client function generation for servant APIs
66category: Servant, Web
@@ -10,14 +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: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.2
20− , 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
2121
2222extra-source-files:
2323 CHANGELOG.md
@@ -50,13 +50,14 @@ library
5050 --
5151 -- note: mtl lower bound is so low because of GHC-7.8
5252 build-depends:
53− base >= 4.9 && < 4.15
54− , bytestring >= 0.10.8.1 && < 0.11
53+ base >= 4.9 && < 4.17
54+ , bytestring >= 0.10.8.1 && < 0.12
55+ , constraints >= 0.2 && < 0.14
5556 , containers >= 0.5.7.1 && < 0.7
5657 , deepseq >= 1.4.2.0 && < 1.5
57− , text >= 1.2.3.0 && < 1.3
58+ , text >= 1.2.3.0 && < 2.1
5859 , transformers >= 0.5.2.0 && < 0.6
59− , template-haskell >= 2.11.1.0 && < 2.17
60+ , template-haskell >= 2.11.1.0 && < 2.19
6061
6162 if !impl(ghc >= 8.2)
6263 build-depends:
@@ -64,14 +65,14 @@ library
6465
6566 -- Servant dependencies
6667 build-depends:
67− servant >= 0.18.1 && <0.19
68+ servant >= 0.19
6869
6970 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.
7071 -- Here can be exceptions if we really need features from the newer versions.
7172 build-depends:
72− aeson >= 1.4.1.0 && < 1.6
73− , base-compat >= 0.10.5 && < 0.12
74− , base64-bytestring >= 1.0.0.1 && < 1.2
73+ aeson >= 1.4.1.0 && < 3
74+ , base-compat >= 0.10.5 && < 0.13
75+ , base64-bytestring >= 1.0.0.1 && < 1.3
7576 , exceptions >= 0.10.0 && < 0.11
7677 , free >= 5.1 && < 5.2
7778 , http-media >= 0.7.1.3 && < 0.9
@@ -103,8 +104,8 @@ test-suite spec
103104 -- Additional dependencies
104105 build-depends:
105106 deepseq >= 1.4.2.0 && < 1.5
106− , hspec >= 2.6.0 && < 2.8
107− , QuickCheck >= 2.12.6.1 && < 2.14
107+ , hspec >= 2.6.0 && < 2.10
108+ , QuickCheck >= 2.12.6.1 && < 2.15
108109
109110 build-tool-depends:
110− 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+1
@@ -59,6 +59,7 @@ module Servant.Client.Core
5959 , appendToPath
6060 , setRequestBodyLBS
6161 , setRequestBody
62+ , encodeQueryParamValue
6263 ) where
6364import Servant.Client.Core.Auth
6465import 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+226−32
@@ -6,6 +6,7 @@
66{-# LANGUAGE MultiParamTypeClasses #-}
77{-# LANGUAGE OverloadedStrings #-}
88{-# LANGUAGE PolyKinds #-}
9+{-# LANGUAGE QuantifiedConstraints #-}
910{-# LANGUAGE RankNTypes #-}
1011{-# LANGUAGE ScopedTypeVariables #-}
1112{-# LANGUAGE TypeApplications #-}
@@ -17,6 +18,9 @@ module Servant.Client.Core.HasClient (
1718 clientIn,
1819 HasClient (..),
1920 EmptyClient (..),
21+ AsClientT,
22+ (//),
23+ (/:),
2024 foldMapUnion,
2125 matchUnion,
2226 ) where
@@ -28,9 +32,11 @@ import Control.Arrow
2832 (left, (+++))
2933import Control.Monad
3034 (unless)
31−import qualified Data.ByteString.Lazy as BL
35+import qualified Data.ByteString as BS
36+import qualified Data.ByteString.Lazy as BL
3237import Data.Either
3338 (partitionEithers)
39+import Data.Constraint (Dict(..))
3440import Data.Foldable
3541 (toList)
3642import Data.List
@@ -39,7 +45,8 @@ import Data.Sequence
3945 (fromList)
4046import qualified Data.Text as T
4147import Network.HTTP.Media
42− (MediaType, matches, parseAccept, (//))
48+ (MediaType, matches, parseAccept)
49+import qualified Network.HTTP.Media as Media
4350import qualified Data.Sequence as Seq
4451import Data.SOP.BasicFunctors
4552 (I (I), (:.:) (Comp))
@@ -56,26 +63,33 @@ import Data.Text
5663import Data.Proxy
5764 (Proxy (Proxy))
5865import GHC.TypeLits
59− (KnownSymbol, symbolVal)
66+ (KnownNat, KnownSymbol, TypeError, symbolVal)
6067import Network.HTTP.Types
6168 (Status)
6269import qualified Network.HTTP.Types as H
6370import Servant.API
6471 ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, BasicAuthData,
6572 BuildHeadersTo (..), Capture', CaptureAll, Description,
66− EmptyAPI, FramingRender (..), FramingUnrender (..),
73+ EmptyAPI, Fragment, FramingRender (..), FramingUnrender (..),
6774 FromSourceIO (..), Header', Headers (..), HttpVersion,
6875 IsSecure, MimeRender (mimeRender),
69− MimeUnrender (mimeUnrender), NoContent (NoContent), QueryFlag,
70− QueryParam', QueryParams, Raw, ReflectMethod (..), RemoteHost,
71− ReqBody', SBoolI, Stream, StreamBody', Summary, ToHttpApiData,
72− ToSourceIO (..), Vault, Verb, NoContentVerb, WithNamedContext,
73− contentType, getHeadersHList, getResponse, toQueryParam,
74− toUrlPiece)
76+ MimeUnrender (mimeUnrender), NoContent (NoContent),
77+ NoContentVerb, QueryFlag, QueryParam', QueryParams, Raw,
78+ ReflectMethod (..), RemoteHost, ReqBody', SBoolI, Stream,
79+ StreamBody', Summary, ToHttpApiData, ToSourceIO (..), Vault,
80+ Verb, WithNamedContext, WithStatus (..), contentType, getHeadersHList,
81+ getResponse, toEncodedUrlPiece, toUrlPiece, NamedRoutes)
82+import Servant.API.Generic
83+ (GenericMode(..), ToServant, ToServantApi
84+ , GenericServant, toServant, fromServant)
7585import Servant.API.ContentTypes
7686 (contentTypes, AllMime (allMime), AllMimeUnrender (allMimeUnrender))
87+import Servant.API.Status
88+ (statusFromNat)
89+import Servant.API.TypeLevel (FragmentUnique, AtLeastOneFragment)
7790import Servant.API.Modifiers
7891 (FoldRequired, RequiredArgument, foldRequiredArgument)
92+import Servant.API.TypeErrors
7993import Servant.API.UVerb
8094 (HasStatus, HasStatuses (Statuses, statuses), UVerb, Union, Unique, inject, statusOf, foldMapUnion, matchUnion)
8195
@@ -194,7 +208,7 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m api)
194208 clientWithRoute pm (Proxy :: Proxy api)
195209 (appendToPath p req)
196210
197− where p = (toUrlPiece val)
211+ where p = toEncodedUrlPiece val
198212
199213 hoistClientMonad pm _ f cl = \a ->
200214 hoistClientMonad pm (Proxy :: Proxy api) f (cl a)
@@ -229,7 +243,7 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m sublayout)
229243 clientWithRoute pm (Proxy :: Proxy sublayout)
230244 (foldl' (flip appendToPath) req ps)
231245
232− where ps = map (toUrlPiece) vals
246+ where ps = map toEncodedUrlPiece vals
233247
234248 hoistClientMonad pm _ f cl = \as ->
235249 hoistClientMonad pm (Proxy :: Proxy sublayout) f (cl as)
@@ -237,10 +251,11 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m sublayout)
237251instance {-# OVERLAPPABLE #-}
238252 -- Note [Non-Empty Content Types]
239253 ( RunClient m, MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)
254+ , KnownNat status
240255 ) => HasClient m (Verb method status cts' a) where
241256 type Client m (Verb method status cts' a) = m a
242257 clientWithRoute _pm Proxy req = do
243− response <- runRequest req
258+ response <- runRequestAcceptStatus (Just [status]) req
244259 { requestAccept = fromList $ toList accept
245260 , requestMethod = method
246261 }
@@ -248,18 +263,20 @@ instance {-# OVERLAPPABLE #-}
248263 where
249264 accept = contentTypes (Proxy :: Proxy ct)
250265 method = reflectMethod (Proxy :: Proxy method)
266+ status = statusFromNat (Proxy :: Proxy status)
251267
252268 hoistClientMonad _ _ f ma = f ma
253269
254270instance {-# OVERLAPPING #-}
255− ( RunClient m, ReflectMethod method
271+ ( RunClient m, ReflectMethod method, KnownNat status
256272 ) => HasClient m (Verb method status cts NoContent) where
257273 type Client m (Verb method status cts NoContent)
258274 = m NoContent
259275 clientWithRoute _pm Proxy req = do
260− _response <- runRequest req { requestMethod = method }
276+ _response <- runRequestAcceptStatus (Just [status]) req { requestMethod = method }
261277 return NoContent
262278 where method = reflectMethod (Proxy :: Proxy method)
279+ status = statusFromNat (Proxy :: Proxy status)
263280
264281 hoistClientMonad _ _ f ma = f ma
265282
@@ -276,13 +293,13 @@ instance (RunClient m, ReflectMethod method) =>
276293
277294instance {-# OVERLAPPING #-}
278295 -- Note [Non-Empty Content Types]
279− ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls
296+ ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls, KnownNat status
280297 , ReflectMethod method, cts' ~ (ct ': cts)
281298 ) => HasClient m (Verb method status cts' (Headers ls a)) where
282299 type Client m (Verb method status cts' (Headers ls a))
283300 = m (Headers ls a)
284301 clientWithRoute _pm Proxy req = do
285− response <- runRequest req
302+ response <- runRequestAcceptStatus (Just [status]) req
286303 { requestMethod = method
287304 , requestAccept = fromList $ toList accept
288305 }
@@ -290,28 +307,51 @@ instance {-# OVERLAPPING #-}
290307 return $ Headers { getResponse = val
291308 , getHeadersHList = buildHeadersTo . toList $ responseHeaders response
292309 }
293− where method = reflectMethod (Proxy :: Proxy method)
294− 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)
295314
296315 hoistClientMonad _ _ f ma = f ma
297316
298317instance {-# OVERLAPPING #-}
299− ( RunClient m, BuildHeadersTo ls, ReflectMethod method
318+ ( RunClient m, BuildHeadersTo ls, ReflectMethod method, KnownNat status
300319 ) => HasClient m (Verb method status cts (Headers ls NoContent)) where
301320 type Client m (Verb method status cts (Headers ls NoContent))
302321 = m (Headers ls NoContent)
303322 clientWithRoute _pm Proxy req = do
304− let method = reflectMethod (Proxy :: Proxy method)
305− response <- runRequest req { requestMethod = method }
323+ response <- runRequestAcceptStatus (Just [status]) req { requestMethod = method }
306324 return $ Headers { getResponse = NoContent
307325 , getHeadersHList = buildHeadersTo . toList $ responseHeaders response
308326 }
327+ where
328+ method = reflectMethod (Proxy :: Proxy method)
329+ status = statusFromNat (Proxy :: Proxy status)
309330
310331 hoistClientMonad _ _ f ma = f ma
311332
312333data ClientParseError = ClientParseError MediaType String | ClientStatusMismatch | ClientNoMatchingStatus
313334 deriving (Eq, Show)
314335
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+
315355instance {-# OVERLAPPING #-}
316356 ( RunClient m,
317357 contentTypes ~ (contentType ': otherContentTypes),
@@ -320,7 +360,7 @@ instance {-# OVERLAPPING #-}
320360 as ~ (a ': as'),
321361 AllMime contentTypes,
322362 ReflectMethod method,
323− All (AllMimeUnrender contentTypes) as,
363+ All (UnrenderResponse contentTypes) as,
324364 All HasStatus as, HasStatuses as',
325365 Unique (Statuses as)
326366 ) =>
@@ -343,7 +383,8 @@ instance {-# OVERLAPPING #-}
343383
344384 let status = responseStatusCode response
345385 body = responseBody response
346− res = tryParsers status $ mimeUnrenders (Proxy @contentTypes) body
386+ headers = responseHeaders response
387+ res = tryParsers status $ mimeUnrenders (Proxy @contentTypes) headers body
347388 case res of
348389 Left errors -> throwClientError $ DecodeFailure (T.pack (show errors)) response
349390 Right x -> return x
@@ -364,13 +405,14 @@ instance {-# OVERLAPPING #-}
364405 -- | Given a list of types, parses the given response body as each type
365406 mimeUnrenders ::
366407 forall cts xs.
367− All (AllMimeUnrender cts) xs =>
408+ All (UnrenderResponse cts) xs =>
368409 Proxy cts ->
410+ Seq.Seq H.Header ->
369411 BL.ByteString ->
370412 NP ([] :.: Either (MediaType, String)) xs
371− mimeUnrenders ctp body = cpure_NP
372− (Proxy @(AllMimeUnrender cts))
373− (Comp . map (\(mediaType, parser) -> left ((,) mediaType) (parser body)) . allMimeUnrender $ ctp)
413+ mimeUnrenders ctp headers body = cpure_NP
414+ (Proxy @(UnrenderResponse cts))
415+ (Comp . unrenderResponse headers body $ ctp)
374416
375417 hoistClientMonad _ _ nt s = nt s
376418
@@ -527,7 +569,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequire
527569 (Proxy :: Proxy mods) add (maybe req add) mparam
528570 where
529571 add :: a -> Request
530− add param = appendToQueryString pname (Just $ toQueryParam param) req
572+ add param = appendToQueryString pname (Just $ encodeQueryParamValue param) req
531573
532574 pname :: Text
533575 pname = pack $ symbolVal (Proxy :: Proxy sym)
@@ -576,7 +618,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api)
576618 )
577619
578620 where pname = pack $ symbolVal (Proxy :: Proxy sym)
579− paramlist' = map (Just . toQueryParam) paramlist
621+ paramlist' = map (Just . encodeQueryParamValue) paramlist
580622
581623 hoistClientMonad pm _ f cl = \as ->
582624 hoistClientMonad pm (Proxy :: Proxy api) f (cl as)
@@ -698,7 +740,7 @@ instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where
698740 clientWithRoute pm (Proxy :: Proxy api)
699741 (appendToPath p req)
700742
701− where p = pack $ symbolVal (Proxy :: Proxy path)
743+ where p = toEncodedUrlPiece $ pack $ symbolVal (Proxy :: Proxy path)
702744
703745 hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
704746
@@ -745,6 +787,29 @@ instance ( HasClient m api
745787 hoistClientMonad pm _ f cl = \authreq ->
746788 hoistClientMonad pm (Proxy :: Proxy api) f (cl authreq)
747789
790+-- | Ignore @'Fragment'@ in client functions.
791+-- See <https://ietf.org/rfc/rfc2616.html#section-15.1.3> for more details.
792+--
793+-- Example:
794+--
795+-- > type MyApi = "books" :> Fragment Text :> Get '[JSON] [Book]
796+-- >
797+-- > myApi :: Proxy MyApi
798+-- > myApi = Proxy
799+-- >
800+-- > getBooks :: ClientM [Book]
801+-- > getBooks = client myApi
802+-- > -- then you can just use "getBooksBy" to query that endpoint.
803+-- > -- 'getBooks' for all books.
804+instance (AtLeastOneFragment api, FragmentUnique (Fragment a :> api), HasClient m api
805+ ) => HasClient m (Fragment a :> api) where
806+
807+ type Client m (Fragment a :> api) = Client m api
808+
809+ clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api)
810+
811+ hoistClientMonad pm _ = hoistClientMonad pm (Proxy :: Proxy api)
812+
748813-- * Basic Authentication
749814
750815instance HasClient m api => HasClient m (BasicAuth realm usr :> api) where
@@ -756,6 +821,119 @@ instance HasClient m api => HasClient m (BasicAuth realm usr :> api) where
756821 hoistClientMonad pm _ f cl = \bauth ->
757822 hoistClientMonad pm (Proxy :: Proxy api) f (cl bauth)
758823
824+-- | A type that specifies that an API record contains a client implementation.
825+data AsClientT (m :: * -> *)
826+instance GenericMode (AsClientT m) where
827+ type AsClientT m :- api = Client m api
828+
829+
830+type GClientConstraints api m =
831+ ( GenericServant api (AsClientT m)
832+ , Client m (ToServantApi api) ~ ToServant api (AsClientT m)
833+ )
834+
835+class GClient (api :: * -> *) m where
836+ gClientProof :: Dict (GClientConstraints api m)
837+
838+instance GClientConstraints api m => GClient api m where
839+ gClientProof = Dict
840+
841+instance
842+ ( forall n. GClient api n
843+ , HasClient m (ToServantApi api)
844+ , RunClient m
845+ )
846+ => HasClient m (NamedRoutes api) where
847+ type Client m (NamedRoutes api) = api (AsClientT m)
848+
849+ clientWithRoute :: Proxy m -> Proxy (NamedRoutes api) -> Request -> Client m (NamedRoutes api)
850+ clientWithRoute pm _ request =
851+ case gClientProof @api @m of
852+ Dict -> fromServant $ clientWithRoute pm (Proxy @(ToServantApi api)) request
853+
854+ hoistClientMonad
855+ :: forall ma mb.
856+ Proxy m
857+ -> Proxy (NamedRoutes api)
858+ -> (forall x. ma x -> mb x)
859+ -> Client ma (NamedRoutes api)
860+ -> Client mb (NamedRoutes api)
861+ hoistClientMonad _ _ nat clientA =
862+ case (gClientProof @api @ma, gClientProof @api @mb) of
863+ (Dict, Dict) ->
864+ fromServant @api @(AsClientT mb) $
865+ hoistClientMonad @m @(ToServantApi api) @ma @mb Proxy Proxy nat $
866+ toServant @api @(AsClientT ma) clientA
867+
868+infixl 1 //
869+infixl 2 /:
870+
871+-- | Helper to make code using records of clients more readable.
872+--
873+-- Can be mixed with (/:) for supplying arguments.
874+--
875+-- Example:
876+--
877+-- @
878+-- type Api = NamedRoutes RootApi
879+--
880+-- data RootApi mode = RootApi
881+-- { subApi :: mode :- NamedRoutes SubApi
882+-- , …
883+-- } deriving Generic
884+--
885+-- data SubApi mode = SubApi
886+-- { endpoint :: mode :- Get '[JSON] Person
887+-- , …
888+-- } deriving Generic
889+--
890+-- api :: Proxy API
891+-- api = Proxy
892+--
893+-- rootClient :: RootApi (AsClientT ClientM)
894+-- rootClient = client api
895+--
896+-- endpointClient :: ClientM Person
897+-- endpointClient = client // subApi // endpoint
898+-- @
899+(//) :: a -> (a -> b) -> b
900+x // f = f x
901+
902+-- | Convenience function for supplying arguments to client functions when
903+-- working with records of clients.
904+--
905+-- Intended to be used in conjunction with '(//)'.
906+--
907+-- Example:
908+--
909+-- @
910+-- type Api = NamedRoutes RootApi
911+--
912+-- data RootApi mode = RootApi
913+-- { subApi :: mode :- Capture "token" String :> NamedRoutes SubApi
914+-- , hello :: mode :- Capture "name" String :> Get '[JSON] String
915+-- , …
916+-- } deriving Generic
917+--
918+-- data SubApi mode = SubApi
919+-- { endpoint :: mode :- Get '[JSON] Person
920+-- , …
921+-- } deriving Generic
922+--
923+-- api :: Proxy API
924+-- api = Proxy
925+--
926+-- rootClient :: RootApi (AsClientT ClientM)
927+-- rootClient = client api
928+--
929+-- hello :: String -> ClientM String
930+-- hello name = rootClient // hello /: name
931+--
932+-- endpointClient :: ClientM Person
933+-- endpointClient = client // subApi /: "foobar123" // endpoint
934+-- @
935+(/:) :: (a -> b -> c) -> b -> a -> c
936+(/:) = flip
759937
760938
761939{- Note [Non-Empty Content Types]
@@ -781,7 +959,7 @@ for empty and one for non-empty lists).
781959checkContentTypeHeader :: RunClient m => Response -> m MediaType
782960checkContentTypeHeader response =
783961 case lookup "Content-Type" $ toList $ responseHeaders response of
784− Nothing -> return $ "application"//"octet-stream"
962+ Nothing -> return $ "application" Media.// "octet-stream"
785963 Just t -> case parseAccept t of
786964 Nothing -> throwClientError $ InvalidContentTypeHeader response
787965 Just t' -> return t'
@@ -797,3 +975,19 @@ decodedAs response ct = do
797975 Right val -> return val
798976 where
799977 accept = toList $ contentTypes ct
978+
979+-------------------------------------------------------------------------------
980+-- Custom type errors
981+-------------------------------------------------------------------------------
982+
983+-- Erroring instance for HasClient' when a combinator is not fully applied
984+instance (RunClient m, TypeError (PartialApplication HasClient arr)) => HasClient m ((arr :: a -> b) :> sub)
985+ where
986+ type Client m (arr :> sub) = TypeError (PartialApplication HasClient arr)
987+ clientWithRoute _ _ _ = error "unreachable"
988+ hoistClientMonad _ _ _ _ = error "unreachable"
989+
990+-- Erroring instances for 'HasClient' for unknown API combinators
991+instance {-# OVERLAPPABLE #-} (RunClient m, TypeError (NoInstanceForSub (HasClient m) ty)) => HasClient m (ty :> sub)
992+
993+instance {-# OVERLAPPABLE #-} (RunClient m, TypeError (NoInstanceFor (HasClient m api))) => HasClient m api
servant-client-core/src/Servant/Client/Core/Reexport.hs+4
@@ -7,6 +7,9 @@ module Servant.Client.Core.Reexport
77 HasClient(..)
88 , foldMapUnion
99 , matchUnion
10+ , AsClientT
11+ , (//)
12+ , (/:)
1013
1114 -- * Response (for @Raw@)
1215 , Response
@@ -23,6 +26,7 @@ module Servant.Client.Core.Reexport
2326 , showBaseUrl
2427 , parseBaseUrl
2528 , InvalidBaseUrlException
29+
2630 ) where
2731
2832
servant-client-core/src/Servant/Client/Core/Request.hs+26−11
@@ -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)
@@ -50,9 +51,9 @@ import Network.HTTP.Media
5051 (MediaType)
5152import Network.HTTP.Types
5253 (Header, HeaderName, HttpVersion (..), Method, QueryItem,
53− http11, methodGet)
54+ http11, methodGet, urlEncodeBuilder)
5455import Servant.API
55− (ToHttpApiData, toEncodedUrlPiece, toHeader, SourceIO)
56+ (ToHttpApiData, toEncodedUrlPiece, toQueryParam, toHeader, SourceIO)
5657
5758import Servant.Client.Core.Internal (mediaTypeRnf)
5859
@@ -80,12 +81,13 @@ instance (Show a, Show b) =>
8081 . showString ", requestAccept = "
8182 . showsPrec 0 (requestAccept req)
8283 . showString ", requestHeaders = "
83− . showsPrec 0 (redactSensitiveHeader <$> requestHeaders req))
84+ . showsPrec 0 (redactSensitiveHeader <$> requestHeaders req)
8485 . showString ", requestHttpVersion = "
8586 . showsPrec 0 (requestHttpVersion req)
8687 . showString ", requestMethod = "
8788 . showsPrec 0 (requestMethod req)
8889 . showString "}"
90+ )
8991 where
9092 redactSensitiveHeader :: Header -> Header
9193 redactSensitiveHeader ("Authorization", _) = ("Authorization", "<REDACTED>")
@@ -112,7 +114,7 @@ instance (NFData path, NFData body) => NFData (RequestF body path) where
112114 rnfB Nothing = ()
113115 rnfB (Just (b, mt)) = rnf b `seq` mediaTypeRnf mt
114116
115−type Request = RequestF RequestBody Builder.Builder
117+type Request = RequestF RequestBody Builder
116118
117119-- | The request body. R replica of the @http-client@ @RequestBody@.
118120data RequestBody
@@ -143,18 +145,31 @@ defaultRequest = Request
143145 , requestMethod = methodGet
144146 }
145147
146−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
147152appendToPath p req
148− = req { requestPath = requestPath req <> "/" <> toEncodedUrlPiece p }
153+ = req { requestPath = requestPath req <> "/" <> p }
149154
150−appendToQueryString :: Text -- ^ param name
151− -> 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
152159 -> Request
153160 -> Request
154161appendToQueryString pname pvalue req
155162 = req { requestQueryString = requestQueryString req
156− Seq.|> (encodeUtf8 pname, encodeUtf8 <$> pvalue)}
163+ Seq.|> (encodeUtf8 pname, pvalue)}
157164
165+-- | Encode a query parameter value.
166+--
167+encodeQueryParamValue :: ToHttpApiData a => a -> BS.ByteString
168+encodeQueryParamValue = LBS.toStrict . Builder.toLazyByteString
169+ . urlEncodeBuilder True . encodeUtf8 . toQueryParam
170+
171+-- | Add header to the request being constructed.
172+--
158173addHeader :: ToHttpApiData a => HeaderName -> a -> Request -> Request
159174addHeader name val req
160175 = req { requestHeaders = requestHeaders req Seq.|> (name, toHeader val)}
servant-client-core/src/Servant/Client/Generic.hs+8−11
@@ -1,9 +1,10 @@
1−{-# LANGUAGE ConstraintKinds #-}
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.hs+12
@@ -10,10 +10,22 @@ import Data.List (isInfixOf)
1010import Servant.Client.Core.Request
1111import Test.Hspec
1212
13+newtype DataWithRequest = DataWithRequest (RequestF RequestBody ())
14+ deriving Show
15+
1316spec :: Spec
1417spec = do
1518 describe "Request" $ do
1619 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\"})"
1729 it "redacts the authorization header" $ do
1830 let request = void $ defaultRequest { requestHeaders = pure ("authorization", "secret") }
1931 isInfixOf "secret" (show request) `shouldBe` False
servant-client-ghcjs/servant-client-ghcjs.cabal+6−6
@@ -1,4 +1,4 @@
1−cabal-version: >=1.10
1+cabal-version: 2.2
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
@@ -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+50
@@ -1,6 +1,56 @@
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+
4540.18.1
555------
656
servant-client/servant-client.cabal+25−18
@@ -1,6 +1,6 @@
1−cabal-version: >=1.10
1+cabal-version: 2.2
22name: servant-client
3−version: 0.18.1
3+version: 0.19
44
55synopsis: Automatic derivation of querying functions for servant
66category: Servant, Web
@@ -14,13 +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: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.2
23+tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1
24+ , GHCJS ==8.6.0.1
2425
2526extra-source-files:
2627 CHANGELOG.md
@@ -40,14 +41,14 @@ library
4041 -- Bundled with GHC: Lower bound to not force re-installs
4142 -- text and mtl are bundled starting with GHC-8.4
4243 build-depends:
43− base >= 4.9 && < 4.15
44− , bytestring >= 0.10.8.1 && < 0.11
44+ base >= 4.9 && < 4.17
45+ , bytestring >= 0.10.8.1 && < 0.12
4546 , containers >= 0.5.7.1 && < 0.7
4647 , deepseq >= 1.4.2.0 && < 1.5
4748 , mtl >= 2.2.2 && < 2.3
4849 , stm >= 2.4.5.1 && < 2.6
49− , text >= 1.2.3.0 && < 1.3
50− , time >= 1.6.0.1 && < 1.10
50+ , text >= 1.2.3.0 && < 2.1
51+ , time >= 1.6.0.1 && < 1.12
5152 , transformers >= 0.5.2.0 && < 0.6
5253
5354 if !impl(ghc >= 8.2)
@@ -57,14 +58,14 @@ library
5758 -- Servant dependencies.
5859 -- Strict dependency on `servant-client-core` as we re-export things.
5960 build-depends:
60− servant == 0.18.*
61− , servant-client-core >= 0.18.1 && <0.18.2
61+ servant >= 0.18 && < 0.20
62+ , servant-client-core >= 0.19 && < 0.19.1
6263
6364 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.
6465 -- Here can be exceptions if we really need features from the newer versions.
6566 build-depends:
66− base-compat >= 0.10.5 && < 0.12
67− , 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
6869 , http-media >= 0.7.1.3 && < 0.9
6970 , http-types >= 0.12.2 && < 0.13
7071 , exceptions >= 0.10.0 && < 0.11
@@ -72,7 +73,7 @@ library
7273 , monad-control >= 1.0.2.3 && < 1.1
7374 , semigroupoids >= 5.3.1 && < 5.4
7475 , transformers-base >= 0.4.5.2 && < 0.5
75− , transformers-compat >= 0.6.2 && < 0.7
76+ , transformers-compat >= 0.6.2 && < 0.8
7677
7778 hs-source-dirs: src
7879 default-language: Haskell2010
@@ -82,14 +83,18 @@ test-suite spec
8283 type: exitcode-stdio-1.0
8384 ghc-options: -Wall -rtsopts -threaded "-with-rtsopts=-T -N2"
8485 default-language: Haskell2010
86+ if impl(ghcjs)
87+ buildable: False
8588 hs-source-dirs: test
8689 main-is: Spec.hs
8790 other-modules:
8891 Servant.BasicAuthSpec
92+ Servant.BrokenSpec
8993 Servant.ClientTestUtils
9094 Servant.ConnectionErrorSpec
9195 Servant.FailSpec
9296 Servant.GenAuthSpec
97+ Servant.GenericSpec
9398 Servant.HoistClientSpec
9499 Servant.StreamSpec
95100 Servant.SuccessSpec
@@ -119,16 +124,16 @@ test-suite spec
119124 -- Additional dependencies
120125 build-depends:
121126 entropy >= 0.4.1.3 && < 0.5
122− , hspec >= 2.6.0 && < 2.8
127+ , hspec >= 2.6.0 && < 2.10
123128 , HUnit >= 1.6.0.0 && < 1.7
124129 , network >= 2.8.0.0 && < 3.2
125− , QuickCheck >= 2.12.6.1 && < 2.14
126− , servant == 0.18.*
127− , servant-server == 0.18.*
130+ , QuickCheck >= 2.12.6.1 && < 2.15
131+ , servant == 0.19.*
132+ , servant-server == 0.19.*
128133 , tdigest >= 0.2 && < 0.3
129134
130135 build-tool-depends:
131− hspec-discover:hspec-discover >= 2.6.0 && < 2.8
136+ hspec-discover:hspec-discover >= 2.6.0 && < 2.10
132137
133138test-suite readme
134139 type: exitcode-stdio-1.0
@@ -137,3 +142,5 @@ test-suite readme
137142 build-tool-depends: markdown-unlit:markdown-unlit
138143 ghc-options: -pgmL markdown-unlit
139144 default-language: Haskell2010
145+ if impl(ghcjs)
146+ buildable: False
servant-client/src/Servant/Client/Internal/HttpClient.hs+19−14
@@ -24,7 +24,7 @@ import Control.Monad
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,7 +63,7 @@ import GHC.Generics
6563import Network.HTTP.Media
6664 (renderHeader)
6765import Network.HTTP.Types
68− (hContentType, renderQuery, statusCode, Status)
66+ (hContentType, renderQuery, statusIsSuccessful, urlEncode, Status)
6967import Servant.Client.Core
7068
7169import qualified Network.HTTP.Client as Client
@@ -82,7 +80,7 @@ data ClientEnv
8280 { manager :: Client.Manager
8381 , baseUrl :: BaseUrl
8482 , cookieJar :: Maybe (TVar Client.CookieJar)
85− , makeClientRequest :: BaseUrl -> Request -> Client.Request
83+ , makeClientRequest :: BaseUrl -> Request -> IO Client.Request
8684 -- ^ this function can be used to customize the creation of @http-client@ requests from @servant@ requests. Default value: 'defaultMakeClientRequest'
8785 -- Note that:
8886 -- 1. 'makeClientRequest' exists to allow overriding operational semantics e.g. 'responseTimeout' per request,
@@ -138,7 +136,7 @@ newtype ClientM a = ClientM
138136 { unClientM :: ReaderT ClientEnv (ExceptT ClientError IO) a }
139137 deriving ( Functor, Applicative, Monad, MonadIO, Generic
140138 , MonadReader ClientEnv, MonadError ClientError, MonadThrow
141− , MonadCatch)
139+ , MonadCatch, MonadMask)
142140
143141instance MonadBase IO ClientM where
144142 liftBase = ClientM . liftBase
@@ -164,7 +162,7 @@ runClientM cm env = runExceptT $ flip runReaderT env $ unClientM cm
164162performRequest :: Maybe [Status] -> Request -> ClientM Response
165163performRequest acceptStatus req = do
166164 ClientEnv m burl cookieJar' createClientRequest <- ask
167− let clientRequest = createClientRequest burl req
165+ clientRequest <- liftIO $ createClientRequest burl req
168166 request <- case cookieJar' of
169167 Nothing -> pure clientRequest
170168 Just cj -> liftIO $ do
@@ -181,10 +179,9 @@ performRequest acceptStatus req = do
181179
182180 response <- maybe (requestWithoutCookieJar m request) (requestWithCookieJar m request) cookieJar'
183181 let status = Client.responseStatus response
184− status_code = statusCode status
185182 ourResponse = clientResponseToResponse id response
186183 goodStatus = case acceptStatus of
187− Nothing -> status_code >= 200 && status_code < 300
184+ Nothing -> statusIsSuccessful status
188185 Just good -> status `elem` good
189186 unless goodStatus $ do
190187 throwError $ mkFailureResponse burl req ourResponse
@@ -232,15 +229,15 @@ clientResponseToResponse f r = Response
232229-- | Create a @http-client@ 'Client.Request' from a @servant@ 'Request'
233230-- The 'Client.host', 'Client.path' and 'Client.port' fields are extracted from the 'BaseUrl'
234231-- otherwise the body, headers and query string are derived from the @servant@ 'Request'
235−defaultMakeClientRequest :: BaseUrl -> Request -> Client.Request
236−defaultMakeClientRequest burl r = Client.defaultRequest
232+defaultMakeClientRequest :: BaseUrl -> Request -> IO Client.Request
233+defaultMakeClientRequest burl r = return Client.defaultRequest
237234 { Client.method = requestMethod r
238235 , Client.host = fromString $ baseUrlHost burl
239236 , Client.port = baseUrlPort burl
240237 , Client.path = BSL.toStrict
241238 $ fromString (baseUrlPath burl)
242239 <> toLazyByteString (requestPath r)
243− , Client.queryString = renderQuery True . toList $ requestQueryString r
240+ , Client.queryString = buildQueryString . toList $ requestQueryString r
244241 , Client.requestHeaders =
245242 maybeToList acceptHdr ++ maybeToList contentTypeHdr ++ headers
246243 , Client.requestBody = body
@@ -249,7 +246,7 @@ defaultMakeClientRequest burl r = Client.defaultRequest
249246 where
250247 -- Content-Type and Accept are specified by requestBody and requestAccept
251248 headers = filter (\(h, _) -> h /= "Accept" && h /= "Content-Type") $
252− toList $requestHeaders r
249+ toList $ requestHeaders r
253250
254251 acceptHdr
255252 | null hs = Nothing
@@ -291,6 +288,14 @@ defaultMakeClientRequest burl r = Client.defaultRequest
291288 Http -> False
292289 Https -> True
293290
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+
294299catchConnectionError :: IO a -> IO (Either ClientError a)
295300catchConnectionError action =
296301 catch (Right <$> action) $ \e ->
servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs+5−7
@@ -47,7 +47,7 @@ import Data.Time.Clock
4747 (getCurrentTime)
4848import GHC.Generics
4949import Network.HTTP.Types
50− (Status, statusCode)
50+ (Status, statusIsSuccessful)
5151
5252import qualified Network.HTTP.Client as Client
5353
@@ -140,7 +140,7 @@ performRequest :: Maybe [Status] -> Request -> ClientM Response
140140performRequest acceptStatus req = do
141141 -- TODO: should use Client.withResponse here too
142142 ClientEnv m burl cookieJar' createClientRequest <- ask
143− let clientRequest = createClientRequest burl req
143+ clientRequest <- liftIO $ createClientRequest burl req
144144 request <- case cookieJar' of
145145 Nothing -> pure clientRequest
146146 Just cj -> liftIO $ do
@@ -163,10 +163,9 @@ performRequest acceptStatus req = do
163163 now' <- getCurrentTime
164164 atomically $ modifyTVar' cj (fst . Client.updateCookieJar response request now')
165165 let status = Client.responseStatus response
166− status_code = statusCode status
167166 ourResponse = clientResponseToResponse id response
168167 goodStatus = case acceptStatus of
169− Nothing -> status_code >= 200 && status_code < 300
168+ Nothing -> statusIsSuccessful status
170169 Just good -> status `elem` good
171170 unless goodStatus $ do
172171 throwError $ mkFailureResponse burl req ourResponse
@@ -178,14 +177,13 @@ performWithStreamingRequest req k = do
178177 m <- asks manager
179178 burl <- asks baseUrl
180179 createClientRequest <- asks makeClientRequest
181− let request = createClientRequest burl req
180+ request <- liftIO $ createClientRequest burl req
182181 ClientM $ lift $ lift $ Codensity $ \k1 ->
183182 Client.withResponse request m $ \res -> do
184183 let status = Client.responseStatus res
185− status_code = statusCode status
186184
187185 -- we throw FailureResponse in IO :(
188− unless (status_code >= 200 && status_code < 300) $ do
186+ unless (statusIsSuccessful status) $ do
189187 b <- BSL.fromChunks <$> Client.brConsume (Client.responseBody res)
190188 throwIO $ mkFailureResponse burl req (clientResponseToResponse (const b) res)
191189
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+115−33
@@ -1,18 +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 TypeApplications #-}
13−{-# LANGUAGE TypeFamilies #-}
14−{-# LANGUAGE TypeOperators #-}
15−{-# 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 #-}
1616{-# OPTIONS_GHC -freduction-depth=100 #-}
1717{-# OPTIONS_GHC -fno-warn-orphans #-}
1818{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
@@ -24,23 +24,32 @@ import Prelude.Compat
2424
2525import Control.Concurrent
2626 (ThreadId, forkIO, killThread)
27+import Control.Monad
28+ (join)
2729import Control.Monad.Error.Class
2830 (throwError)
2931import Data.Aeson
30−import qualified Data.ByteString.Lazy as LazyByteString
32+import Data.ByteString
33+ (ByteString)
34+import Data.ByteString.Builder
35+ (byteString)
36+import qualified Data.ByteString.Lazy as LazyByteString
3137import Data.Char
3238 (chr, isPrint)
3339import Data.Monoid ()
3440import Data.Proxy
35−import Data.Text (Text)
36−import qualified Data.Text as Text
37−import Data.Text.Encoding (encodeUtf8, decodeUtf8)
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)
3847import GHC.Generics
3948 (Generic)
40−import qualified Network.HTTP.Client as C
41−import qualified Network.HTTP.Types as HTTP
49+import qualified Network.HTTP.Client as C
50+import qualified Network.HTTP.Types as HTTP
4251import Network.Socket
43−import qualified Network.Wai as Wai
52+import qualified Network.Wai as Wai
4453import Network.Wai.Handler.Warp
4554import System.IO.Unsafe
4655 (unsafePerformIO)
@@ -50,15 +59,15 @@ import Web.FormUrlEncoded
5059
5160import Servant.API
5261 ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth,
53− BasicAuthData (..), Capture, CaptureAll,
54− DeleteNoContent, EmptyAPI, FormUrlEncoded, Get, Header,
55− Headers, JSON, MimeRender(mimeRender),
56− MimeUnrender(mimeUnrender), NoContent (NoContent), PlainText,
57− Post, QueryFlag, QueryParam, QueryParams, Raw, ReqBody,
58− StdMethod(GET), Union, UVerb, WithStatus(WithStatus),
59− 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 ((:-))
6069import Servant.Client
61−import qualified Servant.Client.Core.Auth as Auth
70+import qualified Servant.Client.Core.Auth as Auth
6271import Servant.Server
6372import Servant.Server.Experimental.Auth
6473import Servant.Test.ComprehensiveAPI
@@ -99,16 +108,38 @@ carol = Person "Carol" 17
99108
100109type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]
101110
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+
102124type Api =
103125 Get '[JSON] Person
104126 :<|> "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
105131 :<|> "deleteEmpty" :> DeleteNoContent
106132 :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person
107133 :<|> "captureAll" :> CaptureAll "names" String :> Get '[JSON] [Person]
108134 :<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person
109135 :<|> "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
110140 :<|> "params" :> QueryParams "names" String :> Get '[JSON] [Person]
111141 :<|> "flag" :> QueryFlag "flag" :> Get '[JSON] Bool
142+ :<|> "fragment" :> Fragment String :> Get '[JSON] Person
112143 :<|> "rawSuccess" :> Raw
113144 :<|> "rawSuccessPassHeaders" :> Raw
114145 :<|> "rawFailure" :> Raw
@@ -119,6 +150,7 @@ type Api =
119150 ReqBody '[JSON] [(String, [Rational])] :>
120151 Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])])
121152 :<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool)
153+ :<|> "uverb-headers" :> UVerb 'GET '[JSON] '[ WithStatus 200 (Headers TestHeaders Bool), WithStatus 204 String ]
122154 :<|> "deleteContentType" :> DeleteNoContent
123155 :<|> "redirectWithCookie" :> Raw
124156 :<|> "empty" :> EmptyAPI
@@ -127,57 +159,70 @@ type Api =
127159 UVerb 'GET '[PlainText] '[WithStatus 200 Person,
128160 WithStatus 301 Text]
129161 :<|> "uverb-get-created" :> UVerb 'GET '[PlainText] '[WithStatus 201 Person]
130−
162+ :<|> NamedRoutes RecordRoutes
163+ :<|> "captureVerbatim" :> Capture "someString" Verbatim :> Get '[PlainText] Text
131164
132165api :: Proxy Api
133166api = Proxy
134167
135168getRoot :: ClientM Person
136169getGet :: ClientM Person
170+getGet307 :: ClientM Text
137171getDeleteEmpty :: ClientM NoContent
138172getCapture :: String -> ClientM Person
139173getCaptureAll :: [String] -> ClientM [Person]
140174getBody :: Person -> ClientM Person
141175getQueryParam :: Maybe String -> ClientM Person
176+getQueryParamBinary :: Maybe UrlEncodedByteString -> HTTP.Method -> ClientM Response
142177getQueryParams :: [String] -> ClientM [Person]
143178getQueryFlag :: Bool -> ClientM Bool
179+getFragment :: ClientM Person
144180getRawSuccess :: HTTP.Method -> ClientM Response
145181getRawSuccessPassHeaders :: HTTP.Method -> ClientM Response
146182getRawFailure :: HTTP.Method -> ClientM Response
147183getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]
148184 -> ClientM (String, Maybe Int, Bool, [(String, [Rational])])
149185getRespHeaders :: ClientM (Headers TestHeaders Bool)
186+getUVerbRespHeaders :: ClientM (Union '[ WithStatus 200 (Headers TestHeaders Bool), WithStatus 204 String ])
150187getDeleteContentType :: ClientM NoContent
151188getRedirectWithCookie :: HTTP.Method -> ClientM Response
152189uverbGetSuccessOrRedirect :: Bool
153190 -> ClientM (Union '[WithStatus 200 Person,
154191 WithStatus 301 Text])
155192uverbGetCreated :: ClientM (Union '[WithStatus 201 Person])
193+recordRoutes :: RecordRoutes (AsClientT ClientM)
156194
157195getRoot
158196 :<|> getGet
197+ :<|> getGet307
159198 :<|> getDeleteEmpty
160199 :<|> getCapture
161200 :<|> getCaptureAll
162201 :<|> getBody
163202 :<|> getQueryParam
203+ :<|> getQueryParamBinary
164204 :<|> getQueryParams
165205 :<|> getQueryFlag
206+ :<|> getFragment
166207 :<|> getRawSuccess
167208 :<|> getRawSuccessPassHeaders
168209 :<|> getRawFailure
169210 :<|> getMultiple
170211 :<|> getRespHeaders
212+ :<|> getUVerbRespHeaders
171213 :<|> getDeleteContentType
172214 :<|> getRedirectWithCookie
173215 :<|> EmptyClient
174216 :<|> uverbGetSuccessOrRedirect
175− :<|> uverbGetCreated = client api
217+ :<|> uverbGetCreated
218+ :<|> recordRoutes
219+ :<|> captureVerbatim = client api
176220
177221server :: Application
178222server = serve api (
179223 return carol
180224 :<|> return alice
225+ :<|> return "redirecting"
181226 :<|> return NoContent
182227 :<|> (\ name -> return $ Person name 0)
183228 :<|> (\ names -> return (zipWith Person names [0..]))
@@ -186,13 +231,22 @@ server = serve api (
186231 Just "alice" -> return alice
187232 Just n -> throwError $ ServerError 400 (n ++ " not found") "" []
188233 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+ )
189241 :<|> (\ names -> return (zipWith Person names [0..]))
190242 :<|> return
243+ :<|> return alice
191244 :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "rawSuccess")
192245 :<|> (Tagged $ \ request respond -> (respond $ Wai.responseLBS HTTP.ok200 (Wai.requestHeaders $ request) "rawSuccess"))
193246 :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.badRequest400 [] "rawFailure")
194247 :<|> (\ a b c d -> return (a, b, c, d))
195248 :<|> (return $ addHeader 1729 $ addHeader "eg2" True)
249+ :<|> (pure . Z . I . WithStatus $ addHeader 1729 $ addHeader "eg2" True)
196250 :<|> return NoContent
197251 :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.found302 [("Location", "testlocation"), ("Set-Cookie", "testcookie=test")] "")
198252 :<|> emptyServer
@@ -200,8 +254,18 @@ server = serve api (
200254 then respond (WithStatus @301 ("redirecting" :: Text))
201255 else respond (WithStatus @200 alice ))
202256 :<|> 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
203265 )
204266
267+-- * api for testing failures
268+
205269type FailApi =
206270 "get" :> Raw
207271 :<|> "capture" :> Capture "name" String :> Raw
@@ -216,7 +280,7 @@ failServer = serve failApi (
216280 :<|> (\ _capture -> Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "application/json")] "")
217281 :<|> (Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "fooooo")] "")
218282 :<|> (Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "application/x-www-form-urlencoded"), ("X-Example1", "1"), ("X-Example2", "foo")] "")
219− )
283+ )
220284
221285-- * basic auth stuff
222286
@@ -300,3 +364,21 @@ pathGen = fmap NonEmpty path
300364 filter (not . (`elem` ("?%[]/#;" :: String))) $
301365 filter isPrint $
302366 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+59−27
@@ -1,17 +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 TypeApplications #-}
12−{-# LANGUAGE TypeFamilies #-}
13−{-# LANGUAGE TypeOperators #-}
14−{-# 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 #-}
1515{-# OPTIONS_GHC -freduction-depth=100 #-}
1616{-# OPTIONS_GHC -fno-warn-orphans #-}
1717{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
@@ -22,11 +22,13 @@ import Prelude ()
2222import Prelude.Compat
2323
2424import Control.Arrow
25− (left)
25+ ((+++), left)
2626import Control.Concurrent.STM
2727 (atomically)
2828import Control.Concurrent.STM.TVar
2929 (newTVar, readTVar)
30+import qualified Data.ByteString as BS
31+import qualified Data.ByteString.Lazy as BL
3032import Data.Foldable
3133 (forM_, toList)
3234import Data.Maybe
@@ -34,20 +36,21 @@ import Data.Maybe
3436import Data.Monoid ()
3537import Data.Text
3638 (Text)
37−import qualified Network.HTTP.Client as C
38−import qualified Network.HTTP.Types as HTTP
39+import Data.Text.Encoding
40+ (encodeUtf8)
41+import qualified Network.HTTP.Client as C
42+import qualified Network.HTTP.Types as HTTP
3943import Test.Hspec
4044import Test.Hspec.QuickCheck
4145import Test.HUnit
4246import Test.QuickCheck
4347
4448import Servant.API
45− (NoContent (NoContent), WithStatus(WithStatus), getHeaders)
49+ (NoContent (NoContent), WithStatus (WithStatus), getHeaders, Headers(..))
4650import Servant.Client
47−import qualified Servant.Client.Core.Request as Req
48−import Servant.Client.Internal.HttpClient (defaultMakeClientRequest)
49−import Servant.Test.ComprehensiveAPI
51+import qualified Servant.Client.Core.Request as Req
5052import Servant.ClientTestUtils
53+import Servant.Test.ComprehensiveAPI
5154
5255-- This declaration simply checks that all instances are in place.
5356_ = client comprehensiveAPIWithoutStreaming
@@ -58,11 +61,15 @@ spec = describe "Servant.SuccessSpec" $ do
5861
5962successSpec :: Spec
6063successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
61− it "Servant.API.Get root" $ \(_, baseUrl) -> do
62− 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
6370
64− it "Servant.API.Get" $ \(_, baseUrl) -> do
65− left show <$> runClient getGet baseUrl `shouldReturn` Right alice
71+ it "get redirection endpoint" $ \(_, baseUrl) -> do
72+ left show <$> runClient getGet307 baseUrl `shouldReturn` Right "redirecting"
6673
6774 describe "Servant.API.Delete" $ do
6875 it "allows empty content type" $ \(_, baseUrl) -> do
@@ -94,6 +101,11 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
94101 Left (FailureResponse _ r) <- runClient (getQueryParam (Just "bob")) baseUrl
95102 responseStatusCode r `shouldBe` HTTP.Status 400 "bob not found"
96103
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+
97109 it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do
98110 left show <$> runClient (getQueryParams []) baseUrl `shouldReturn` Right []
99111 left show <$> runClient (getQueryParams ["alice", "bob"]) baseUrl
@@ -103,6 +115,9 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
103115 forM_ [False, True] $ \ flag -> it (show flag) $ \(_, baseUrl) -> do
104116 left show <$> runClient (getQueryFlag flag) baseUrl `shouldReturn` Right flag
105117
118+ it "Servant.API.Fragment" $ \(_, baseUrl) -> do
119+ left id <$> runClient getFragment baseUrl `shouldReturn` Right alice
120+
106121 it "Servant.API.Raw on success" $ \(_, baseUrl) -> do
107122 res <- runClient (getRawSuccess HTTP.methodGet) baseUrl
108123 case res of
@@ -126,6 +141,15 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
126141 Left e -> assertFailure $ show e
127142 Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]
128143
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+
129153 it "Stores Cookie in CookieJar after a redirect" $ \(_, baseUrl) -> do
130154 mgr <- C.newManager C.defaultManagerSettings
131155 cj <- atomically . newTVar $ C.createCookieJar []
@@ -138,8 +162,9 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
138162 mgr <- C.newManager C.defaultManagerSettings
139163 -- In proper situation, extra headers should probably be visible in API type.
140164 -- However, testing for response timeout is difficult, so we test with something which is easy to observe
141− let createClientRequest url r = (defaultMakeClientRequest url r) { C.requestHeaders = [("X-Added-Header", "XXX")] }
142− let clientEnv = (mkClientEnv mgr baseUrl) { makeClientRequest = createClientRequest }
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 }
143168 res <- runClientM (getRawSuccessPassHeaders HTTP.methodGet) clientEnv
144169 case res of
145170 Left e ->
@@ -174,3 +199,10 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
174199 case eitherResponse of
175200 Left clientError -> fail $ show clientError
176201 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+8−8
@@ -1,4 +1,4 @@
1−cabal-version: >=1.10
1+cabal-version: 2.2
22name: servant-conduit
33version: 0.15.1
44
@@ -10,30 +10,30 @@ description: Servant Stream support for conduit.
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: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.2
19+tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2
2020
2121extra-source-files:
2222 CHANGELOG.md
2323
2424source-repository head
2525 type: git
26− location: http://github.com/haskell-servant/servant-conduit.git
26+ location: http://github.com/haskell-servant/servant.git
2727
2828library
2929 exposed-modules: Servant.Conduit
3030 build-depends:
3131 base >=4.9 && <5
32− , bytestring >=0.10.8.1 && <0.11
32+ , bytestring >=0.10.8.1 && <0.12
3333 , conduit >=1.3.1 && <1.4
3434 , mtl >=2.2.2 && <2.3
3535 , resourcet >=1.2.2 && <1.3
36− , servant >=0.15 && <0.19
36+ , servant >=0.15 && <0.20
3737 , unliftio-core >=0.1.2.0 && <0.3
3838 hs-source-dirs: src
3939 default-language: Haskell2010
@@ -54,8 +54,8 @@ test-suite example
5454 , resourcet
5555 , servant
5656 , servant-conduit
57− , servant-server >=0.15 && <0.19
58− , servant-client >=0.15 && <0.19
57+ , servant-server >=0.15 && <0.20
58+ , servant-client >=0.15 && <0.20
5959 , wai >=3.2.1.2 && <3.3
6060 , warp >=3.2.25 && <3.4
6161 , http-client
servant-docs/CHANGELOG.md+28
@@ -1,6 +1,34 @@
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+
4320.11.7
533------
634
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+32−1
@@ -51,6 +51,15 @@ 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
@@ -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+24−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:
servant-docs/servant-docs.cabal+13−13
@@ -1,6 +1,6 @@
1−cabal-version: >=1.10
1+cabal-version: 2.2
22name: servant-docs
3−version: 0.11.7
3+version: 0.12
44
55synopsis: generate API docs for your servant webservice
66category: Servant, Web
@@ -13,13 +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: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.2
22+tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1
2323
2424extra-source-files:
2525 CHANGELOG.md
@@ -41,25 +41,25 @@ library
4141 --
4242 -- note: mtl lower bound is so low because of GHC-7.8
4343 build-depends:
44− base >= 4.9 && < 4.15
45− , bytestring >= 0.10.8.1 && < 0.11
46− , text >= 1.2.3.0 && < 1.3
44+ base >= 4.9 && < 4.17
45+ , bytestring >= 0.10.8.1 && < 0.12
46+ , text >= 1.2.3.0 && < 2.1
4747
4848 -- Servant dependencies
4949 build-depends:
50− servant >= 0.18 && <0.19
50+ servant >= 0.18 && <0.20
5151
5252 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.
5353 -- Here can be exceptions if we really need features from the newer versions.
5454 build-depends:
55− aeson >= 1.4.1.0 && < 1.6
55+ aeson >= 1.4.1.0 && < 3
5656 , aeson-pretty >= 0.8.5 && < 0.9
57− , base-compat >= 0.10.5 && < 0.12
57+ , base-compat >= 0.10.5 && < 0.13
5858 , case-insensitive >= 1.2.0.11 && < 1.3
59− , hashable >= 1.2.7.0 && < 1.4
59+ , hashable >= 1.2.7.0 && < 1.5
6060 , http-media >= 0.7.1.3 && < 0.9
6161 , http-types >= 0.12.2 && < 0.13
62− , lens >= 4.17 && < 4.20
62+ , lens >= 4.17 && < 5.2
6363 , string-conversions >= 0.4.0.1 && < 0.5
6464 , universe-base >= 1.1.1 && < 1.2
6565 , unordered-containers >= 0.2.9.0 && < 0.3
@@ -102,7 +102,7 @@ test-suite spec
102102
103103 -- Additional dependencies
104104 build-depends:
105− tasty >= 1.1.0.4 && < 1.3,
105+ tasty >= 1.1.0.4 && < 1.5,
106106 tasty-golden >= 2.3.2 && < 2.4,
107107 tasty-hunit >= 0.10.0.1 && < 0.11,
108108 transformers >= 0.5.2.0 && < 0.6
servant-docs/src/Servant/Docs/Internal.hs+133−25
@@ -25,8 +25,8 @@ 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)
@@ -50,19 +50,21 @@ import Data.Ord
5050 (comparing)
5151import Data.Proxy
5252 (Proxy (Proxy))
53−import Data.Semigroup
54− (Semigroup (..))
5553import Data.String.Conversions
5654 (cs)
5755import Data.Text
5856 (Text, unpack)
5957import GHC.Generics
58+ (Generic, Rep, K1(K1), M1(M1), U1(U1), V1,
59+ (:*:)((:*:)), (:+:)(L1, R1))
60+import qualified GHC.Generics as G
6061import GHC.TypeLits
6162import Servant.API
6263import Servant.API.ContentTypes
6364import Servant.API.TypeLevel
65+import Servant.API.Generic
6466
65−import qualified Data.Universe.Helpers as U
67+import qualified Data.Universe.Helpers as U
6668
6769import qualified Data.HashMap.Strict as HM
6870import qualified Data.Text as T
@@ -159,6 +161,20 @@ data DocQueryParam = DocQueryParam
159161 , _paramKind :: ParamKind
160162 } deriving (Eq, Ord, Show)
161163
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+
162178-- | An introductory paragraph for your documentation. You can pass these to
163179-- 'docsWithIntros'.
164180data DocIntro = DocIntro
@@ -279,8 +295,9 @@ defResponse = Response
279295data Action = Action
280296 { _authInfo :: [DocAuthentication] -- user supplied info
281297 , _captures :: [DocCapture] -- type collected + user supplied info
282− , _headers :: [Text] -- type collected
298+ , _headers :: [HTTP.Header] -- type collected
283299 , _params :: [DocQueryParam] -- type collected + user supplied info
300+ , _fragment :: Maybe DocFragment -- type collected + user supplied info
284301 , _notes :: [DocNote] -- user supplied
285302 , _mxParams :: [(String, [DocQueryParam])] -- type collected + user supplied info
286303 , _rqtypes :: [M.MediaType] -- type collected
@@ -294,8 +311,9 @@ data Action = Action
294311-- As such, we invent a non-commutative, left associative operation
295312-- 'combineAction' to mush two together taking the response from the very left.
296313combineAction :: Action -> Action -> Action
297−Action a c h p n m ts body resp `combineAction` Action a' c' h' p' n' m' ts' body' resp' =
298− Action (a <> a') (c <> c') (h <> h') (p <> p') (n <> n') (m <> m') (ts <> ts') (body <> body') (resp `combineResponse` 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')
299317
300318-- | Default 'Action'. Has no 'captures', no query 'params', expects
301319-- no request body ('rqbody') and the typical response is 'defResponse'.
@@ -303,10 +321,10 @@ Action a c h p n m ts body resp `combineAction` Action a' c' h' p' n' m' ts' bod
303321-- Tweakable with lenses.
304322--
305323-- >>> defAction
306−-- 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 = []}}
307325--
308326-- >>> defAction & response.respStatus .~ 201
309−-- 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 = []}}
310328--
311329defAction :: Action
312330defAction =
@@ -314,6 +332,7 @@ defAction =
314332 []
315333 []
316334 []
335+ Nothing
317336 []
318337 []
319338 []
@@ -337,12 +356,14 @@ data ShowContentTypes = AllContentTypes -- ^ For each example, show each conten
337356--
338357-- @since 0.11.1
339358data RenderingOptions = RenderingOptions
340− { _requestExamples :: !ShowContentTypes
359+ { _requestExamples :: !ShowContentTypes
341360 -- ^ How many content types to display for request body examples?
342− , _responseExamples :: !ShowContentTypes
361+ , _responseExamples :: !ShowContentTypes
343362 -- ^ How many content types to display for response body examples?
344− , _notesHeading :: !(Maybe String)
363+ , _notesHeading :: !(Maybe String)
345364 -- ^ 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`).
346367 } deriving (Show)
347368
348369-- | Default API generation options.
@@ -354,9 +375,10 @@ data RenderingOptions = RenderingOptions
354375-- @since 0.11.1
355376defRenderingOptions :: RenderingOptions
356377defRenderingOptions = RenderingOptions
357− { _requestExamples = AllContentTypes
358− , _responseExamples = AllContentTypes
359− , _notesHeading = Nothing
378+ { _requestExamples = AllContentTypes
379+ , _responseExamples = AllContentTypes
380+ , _notesHeading = Nothing
381+ , _renderCurlBasePath = Nothing
360382 }
361383
362384-- gimme some lenses
@@ -366,6 +388,7 @@ makeLenses ''API
366388makeLenses ''Endpoint
367389makeLenses ''DocCapture
368390makeLenses ''DocQueryParam
391+makeLenses ''DocFragment
369392makeLenses ''DocIntro
370393makeLenses ''DocNote
371394makeLenses ''Response
@@ -392,7 +415,7 @@ docsWithOptions p = docsFor p (defEndpoint, defAction)
392415-- > extra :: ExtraInfo TestApi
393416-- > extra =
394417-- > extraInfo (Proxy :: Proxy ("greet" :> Capture "greetid" Text :> Delete)) $
395−-- > defAction & headers <>~ ["unicorns"]
418+-- > defAction & headers <>~ [("X-Num-Unicorns", 1)]
396419-- > & notes <>~ [ DocNote "Title" ["This is some text"]
397420-- > , DocNote "Second section" ["And some more"]
398421-- > ]
@@ -487,7 +510,7 @@ samples = map ("",)
487510
488511-- | Default sample Generic-based inputs/outputs.
489512defaultSamples :: forall a. (Generic a, GToSample (Rep a)) => Proxy a -> [(Text, a)]
490−defaultSamples _ = second to <$> gtoSamples (Proxy :: Proxy (Rep a))
513+defaultSamples _ = second G.to <$> gtoSamples (Proxy :: Proxy (Rep a))
491514
492515-- | @'ToSample'@ for Generics.
493516--
@@ -585,6 +608,15 @@ class ToCapture c where
585608class ToAuthInfo a where
586609 toAuthInfo :: Proxy a -> DocAuthentication
587610
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+
588620-- | Generate documentation in Markdown format for
589621-- the given 'API'.
590622--
@@ -614,7 +646,7 @@ markdown = markdownWith defRenderingOptions
614646--
615647-- @since 0.11.1
616648markdownWith :: RenderingOptions -> API -> String
617−markdownWith RenderingOptions{..} api = unlines $
649+markdownWith RenderingOptions{..} api = unlines $
618650 introsStr (api ^. apiIntros)
619651 ++ (concatMap (uncurry printEndpoint) . sort . HM.toList $ api ^. apiEndpoints)
620652
@@ -625,10 +657,12 @@ markdownWith RenderingOptions{..} api = unlines $
625657 notesStr (action ^. notes) ++
626658 authStr (action ^. authInfo) ++
627659 capturesStr (action ^. captures) ++
628− headersStr (action ^. headers) ++
660+ headersStr (toListOf (headers . each . _1 . to (T.pack . BSC.unpack . CI.original)) action) ++
629661 paramsStr meth (action ^. params) ++
662+ fragmentStr (action ^. fragment) ++
630663 rqbodyStr (action ^. rqtypes) (action ^. rqbody) ++
631664 responseStr (action ^. response) ++
665+ maybe [] (curlStr endpoint (action ^. headers) (action ^. rqbody)) _renderCurlBasePath ++
632666 []
633667
634668 where str = "## " ++ BSC.unpack meth
@@ -728,6 +762,14 @@ markdownWith RenderingOptions{..} api = unlines $
728762
729763 where values = param ^. paramValues
730764
765+ fragmentStr :: Maybe DocFragment -> [String]
766+ fragmentStr Nothing = []
767+ fragmentStr (Just frag) =
768+ [ "### Fragment:", ""
769+ , "- *" ++ (frag ^. fragSymbol) ++ "*: " ++ (frag ^. fragDesc)
770+ , ""
771+ ]
772+
731773 rqbodyStr :: [M.MediaType] -> [(Text, M.MediaType, ByteString)]-> [String]
732774 rqbodyStr [] [] = []
733775 rqbodyStr types s =
@@ -776,7 +818,6 @@ markdownWith RenderingOptions{..} api = unlines $
776818 ("text", "css") -> "css"
777819 (_, _) -> ""
778820
779−
780821 contentStr mime_type body =
781822 "" :
782823 "```" <> markdownForType mime_type :
@@ -801,6 +842,36 @@ markdownWith RenderingOptions{..} api = unlines $
801842 xs ->
802843 formatBodies _responseExamples xs
803844
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+
804875-- * Instances
805876
806877-- | The generated docs for @a ':<|>' b@ just appends the docs
@@ -824,7 +895,7 @@ instance HasDocs EmptyAPI where
824895-- | @"books" :> 'Capture' "isbn" Text@ will appear as
825896-- @/books/:isbn@ in the docs.
826897instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs api)
827− => HasDocs (Capture' mods sym a :> api) where
898+ => HasDocs (Capture' '[] sym a :> api) where
828899
829900 docsFor Proxy (endpoint, action) =
830901 docsFor subApiP (endpoint', action')
@@ -836,6 +907,28 @@ instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs api)
836907 endpoint' = over path (\p -> p ++ [":" ++ symbolVal symP]) endpoint
837908 symP = Proxy :: Proxy sym
838909
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+
839932
840933-- | @"books" :> 'CaptureAll' "isbn" Text@ will appear as
841934-- @/books/:isbn@ in the docs.
@@ -917,14 +1010,17 @@ instance {-# OVERLAPPING #-}
9171010 status = fromInteger $ natVal (Proxy :: Proxy status)
9181011 p = Proxy :: Proxy a
9191012
920−instance (KnownSymbol sym, HasDocs api)
1013+instance (ToHttpApiData a, ToSample a, KnownSymbol sym, HasDocs api)
9211014 => HasDocs (Header' mods sym a :> api) where
9221015 docsFor Proxy (endpoint, action) =
9231016 docsFor subApiP (endpoint, action')
9241017
9251018 where subApiP = Proxy :: Proxy api
926− action' = over headers (|> headername) action
927− 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>"
9281024
9291025instance (KnownSymbol sym, ToParam (QueryParam' mods sym a), HasDocs api)
9301026 => HasDocs (QueryParam' mods sym a :> api) where
@@ -957,6 +1053,15 @@ instance (KnownSymbol sym, ToParam (QueryFlag sym), HasDocs api)
9571053 paramP = Proxy :: Proxy (QueryFlag sym)
9581054 action' = over params (|> toParam paramP) action
9591055
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
9601065
9611066instance HasDocs Raw where
9621067 docsFor _proxy (endpoint, action) _ =
@@ -1046,6 +1151,9 @@ instance (ToAuthInfo (BasicAuth realm usr), HasDocs api) => HasDocs (BasicAuth r
10461151 authProxy = Proxy :: Proxy (BasicAuth realm usr)
10471152 action' = over authInfo (|> toAuthInfo authProxy) action
10481153
1154+instance HasDocs (ToServantApi api) => HasDocs (NamedRoutes api) where
1155+ docsFor Proxy = docsFor (Proxy :: Proxy (ToServantApi api))
1156+
10491157-- ToSample instances for simple types
10501158instance ToSample NoContent
10511159instance ToSample Bool
servant-docs/test/Servant/DocsSpec.hs+6−2
@@ -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
@@ -124,8 +126,10 @@ spec = describe "Servant.Docs" $ do
124126 it "mentions headers" $ do
125127 md `shouldContain` "- This endpoint is sensitive to the value of the **X-Test** HTTP header."
126128
127− it "contains response samples" $
128− 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"
129133 it "contains request body samples" $
130134 md `shouldContain` "17"
131135
servant-foreign/CHANGELOG.md+24
@@ -1,6 +1,30 @@
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+
4280.15.1
529------
630
servant-foreign/servant-foreign.cabal+11−12
@@ -1,6 +1,6 @@
1−cabal-version: >=1.10
1+cabal-version: 2.2
22name: servant-foreign
3−version: 0.15.2
3+version: 0.15.4
44
55synopsis: Helpers for generating clients for servant APIs in any programming language
66category: Servant, Web
@@ -15,13 +15,13 @@ 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
2222copyright: 2015-2019 Servant Contributors
2323build-type: Simple
24−tested-with: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.2
24+tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1
2525
2626extra-source-files:
2727 CHANGELOG.md
@@ -41,18 +41,18 @@ library
4141 --
4242 -- note: mtl lower bound is so low because of GHC-7.8
4343 build-depends:
44− base >= 4.9 && < 4.15
45− , text >= 1.2.3.0 && < 1.3
44+ base >= 4.9 && < 4.17
45+ , text >= 1.2.3.0 && < 2.1
4646
4747 -- Servant dependencies
4848 build-depends:
49− servant >=0.18 && <0.19
49+ servant >=0.18 && <0.20
5050
5151 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.
5252 -- Here can be exceptions if we really need features from the newer versions.
5353 build-depends:
54− base-compat >= 0.10.5 && < 0.12
55− , lens >= 4.17 && < 4.20
54+ base-compat >= 0.10.5 && < 0.13
55+ , lens >= 4.17 && < 5.2
5656 , http-types >= 0.12.2 && < 0.13
5757
5858 hs-source-dirs: src
@@ -74,8 +74,7 @@ test-suite spec
7474
7575 -- Additional dependencies
7676 build-depends:
77− hspec >= 2.6.0 && <2.8
78−
77+ hspec >= 2.6.0 && <2.10
7978 build-tool-depends:
80− hspec-discover:hspec-discover >=2.6.0 && <2.8
79+ hspec-discover:hspec-discover >=2.6.0 && <2.10
8180 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+134−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
servant-foreign/test/Servant/ForeignSpec.hs+6−3
@@ -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"
@@ -116,6 +116,7 @@ listFromAPISpec = describe "listFromAPI" $ do
116116 [ Segment $ Static "test" ]
117117 -- 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+26
@@ -1,6 +1,32 @@
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+
4300.18.1
531------
632
servant-http-streams/servant-http-streams.cabal+17−17
@@ -1,6 +1,6 @@
1−cabal-version: >=1.10
1+cabal-version: 2.2
22name: servant-http-streams
3−version: 0.18.1
3+version: 0.18.4
44
55synopsis: Automatic derivation of querying functions for servant
66category: Servant, Web
@@ -14,13 +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: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.2
23+tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1
2424
2525extra-source-files:
2626 CHANGELOG.md
@@ -38,13 +38,13 @@ library
3838 -- Bundled with GHC: Lower bound to not force re-installs
3939 -- text and mtl are bundled starting with GHC-8.4
4040 build-depends:
41− base >= 4.9 && < 4.15
42− , bytestring >= 0.10.8.1 && < 0.11
41+ base >= 4.9 && < 4.17
42+ , bytestring >= 0.10.8.1 && < 0.12
4343 , containers >= 0.5.7.1 && < 0.7
4444 , deepseq >= 1.4.2.0 && < 1.5
4545 , mtl >= 2.2.2 && < 2.3
46− , text >= 1.2.3.0 && < 1.3
47− , time >= 1.6.0.1 && < 1.10
46+ , text >= 1.2.3.0 && < 2.1
47+ , time >= 1.6.0.1 && < 1.12
4848 , transformers >= 0.5.2.0 && < 0.6
4949
5050 if !impl(ghc >= 8.2)
@@ -54,13 +54,13 @@ library
5454 -- Servant dependencies.
5555 -- Strict dependency on `servant-client-core` as we re-export things.
5656 build-depends:
57− servant == 0.18.*
58− , servant-client-core >= 0.18.1 && <0.18.2
57+ servant >= 0.18 && < 0.20
58+ , servant-client-core >= 0.18.3 && <0.20
5959
6060 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.
6161 -- Here can be exceptions if we really need features from the newer versions.
6262 build-depends:
63− base-compat >= 0.10.5 && < 0.12
63+ base-compat >= 0.10.5 && < 0.13
6464 , case-insensitive
6565 , http-streams >= 0.8.6.1 && < 0.9
6666 , http-media >= 0.7.1.3 && < 0.9
@@ -72,7 +72,7 @@ library
7272 , monad-control >= 1.0.2.3 && < 1.1
7373 , semigroupoids >= 5.3.1 && < 5.4
7474 , transformers-base >= 0.4.5.2 && < 0.5
75− , transformers-compat >= 0.6.2 && < 0.7
75+ , transformers-compat >= 0.6.2 && < 0.8
7676
7777 hs-source-dirs: src
7878 default-language: Haskell2010
@@ -112,16 +112,16 @@ test-suite spec
112112 -- Additional dependencies
113113 build-depends:
114114 entropy >= 0.4.1.3 && < 0.5
115− , hspec >= 2.6.0 && < 2.8
115+ , hspec >= 2.6.0 && < 2.10
116116 , HUnit >= 1.6.0.0 && < 1.7
117117 , network >= 2.8.0.0 && < 3.2
118− , QuickCheck >= 2.12.6.1 && < 2.14
119− , servant == 0.18.*
120− , servant-server == 0.18.*
118+ , QuickCheck >= 2.12.6.1 && < 2.15
119+ , servant == 0.19.*
120+ , servant-server == 0.19.*
121121 , tdigest >= 0.2 && < 0.3
122122
123123 build-tool-depends:
124− hspec-discover:hspec-discover >= 2.6.0 && < 2.8
124+ hspec-discover:hspec-discover >= 2.6.0 && < 2.10
125125
126126test-suite readme
127127 type: exitcode-stdio-1.0
servant-http-streams/src/Servant/HttpStreams/Internal.hs+6−8
@@ -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
@@ -162,12 +160,12 @@ performRequest acceptStatus req = do
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
168166 goodStatus = case acceptStatus of
169− Nothing -> sc >= 200 && sc < 300
170− Just good -> sc `elem` (statusCode <$> good)
167+ Nothing -> statusIsSuccessful status
168+ Just good -> status `elem` good
171169 if goodStatus
172170 then k (Right res'')
173171 else k (Left (mkFailureResponse burl req res''))
@@ -182,8 +180,8 @@ performWithStreamingRequest req k = do
182180 Client.sendRequest conn req' body
183181 Client.receiveResponseRaw conn $ \res' body' -> do
184182 -- check status code
185− let sc = Client.getStatusCode res'
186− unless (sc >= 200 && sc < 300) $ do
183+ let status = toEnum $ Client.getStatusCode res'
184+ unless (statusIsSuccessful status) $ do
187185 lbs <- BSL.fromChunks <$> Streams.toList body'
188186 throwIO $ mkFailureResponse burl req (clientResponseToResponse res' lbs)
189187
servant-http-streams/test/Servant/ClientSpec.hs+1−3
@@ -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
@@ -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-machines/servant-machines.cabal+8−8
@@ -1,4 +1,4 @@
1−cabal-version: >=1.10
1+cabal-version: 2.2
22name: servant-machines
33version: 0.15.1
44
@@ -10,29 +10,29 @@ description: Servant Stream support for machines.
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: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.2
19+tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2
2020
2121extra-source-files:
2222 CHANGELOG.md
2323
2424source-repository head
2525 type: git
26− location: http://github.com/haskell-servant/servant-machines.git
26+ location: http://github.com/haskell-servant/servant.git
2727
2828library
2929 exposed-modules: Servant.Machines
3030 build-depends:
3131 base >=4.9 && <5
32− , bytestring >=0.10.8.1 && <0.11
32+ , bytestring >=0.10.8.1 && <0.12
3333 , machines >=0.6.4 && <0.8
3434 , mtl >=2.2.2 && <2.3
35− , servant >=0.15 && <0.19
35+ , servant >=0.15 && <0.20
3636 hs-source-dirs: src
3737 default-language: Haskell2010
3838 ghc-options: -Wall
@@ -51,8 +51,8 @@ test-suite example
5151 , servant
5252 , machines
5353 , servant-machines
54− , servant-server >=0.15 && <0.19
55− , servant-client >=0.15 && <0.19
54+ , servant-server >=0.15 && <0.20
55+ , servant-client >=0.15 && <0.20
5656 , wai >=3.2.1.2 && <3.3
5757 , warp >=3.2.25 && <3.4
5858 , http-client
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+10−10
@@ -1,6 +1,6 @@
1−cabal-version: >=1.10
1+cabal-version: 2.2
22name: servant-pipes
3−version: 0.15.2
3+version: 0.15.3
44
55synopsis: Servant Stream support for pipes
66category: Servant, Web, Pipes
@@ -10,31 +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: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.2
19+tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2
2020
2121extra-source-files:
2222 CHANGELOG.md
2323
2424source-repository head
2525 type: git
26− location: http://github.com/haskell-servant/servant-pipes.git
26+ location: http://github.com/haskell-servant/servant.git
2727
2828library
2929 exposed-modules: Servant.Pipes
3030 build-depends:
3131 base >=4.9 && <5
32− , bytestring >=0.10.8.1 && <0.11
32+ , bytestring >=0.10.8.1 && <0.12
3333 , pipes >=4.3.9 && <4.4
3434 , pipes-safe >=2.3.1 && <2.4
3535 , mtl >=2.2.2 && <2.3
3636 , monad-control >=1.0.2.3 && <1.1
37− , servant >=0.15 && <0.19
37+ , servant >=0.15 && <0.20
3838 hs-source-dirs: src
3939 default-language: Haskell2010
4040 ghc-options: -Wall
@@ -51,12 +51,12 @@ test-suite example
5151 , bytestring
5252 , http-media
5353 , servant
54− , pipes
54+ , pipes
5555 , pipes-safe
5656 , servant-pipes
5757 , pipes-bytestring >=2.1.6 && <2.2
58− , servant-server >=0.15 && <0.19
59− , servant-client >=0.15 && <0.19
58+ , servant-server >=0.15 && <0.20
59+ , servant-client >=0.15 && <0.20
6060 , wai >=3.2.1.2 && <3.3
6161 , warp >=3.2.25 && <3.4
6262 , http-client
servant-server/CHANGELOG.md+43
@@ -1,6 +1,49 @@
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.1
7+------
8+
9+- Add `MonadFail` instance for `Handler` wrt [#1545](https://github.com/haskell-servant/servant/issues/1545)
10+- Support GHC 9.2 [#1525](https://github.com/haskell-servant/servant/issues/1525)
11+
12+0.19
13+----
14+
15+### Significant changes
16+
17+- Drop support for GHC < 8.6.
18+- Support GHC 9.0 (GHC 9.2 should work as well, but isn't fully tested yet).
19+- Support Aeson 2 ([#1475](https://github.com/haskell-servant/servant/pull/1475)),
20+ which fixes a [DOS vulnerability](https://github.com/haskell/aeson/issues/864)
21+ related to hash collisions.
22+- Add `NamedRoutes` combinator, making support for records first-class in Servant
23+ ([#1388](https://github.com/haskell-servant/servant/pull/1388)).
24+- Add custom type errors for partially applied combinators
25+ ([#1289](https://github.com/haskell-servant/servant/pull/1289),
26+ [#1486](https://github.com/haskell-servant/servant/pull/1486)).
27+
28+0.18.3
29+------
30+
31+### Significant changes
32+
33+- Add response header support to UVerb (#1420)
34+
35+### Other changes
36+
37+- Support GHC-9.0.1.
38+- Bump `bytestring`, `hspec` and `base64-bytestring` dependencies.
39+
40+0.18.2
41+------
42+
43+### Significant changes
44+
45+- Support `Fragment` combinator.
46+
4470.18.1
548------
649
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+18−16
@@ -1,6 +1,6 @@
1−cabal-version: >=1.10
1+cabal-version: 2.2
22name: servant-server
3−version: 0.18.1
3+version: 0.19.1
44
55synopsis: A family of combinators for defining webservices APIs and serving them
66category: Servant, Web
@@ -17,13 +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
2525build-type: Simple
26−tested-with: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.2
26+tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1
2727
2828extra-source-files:
2929 CHANGELOG.md
@@ -60,25 +60,26 @@ library
6060 -- Bundled with GHC: Lower bound to not force re-installs
6161 -- text and mtl are bundled starting with GHC-8.4
6262 build-depends:
63− base >= 4.9 && < 4.15
64− , bytestring >= 0.10.8.1 && < 0.11
63+ base >= 4.9 && < 4.17
64+ , bytestring >= 0.10.8.1 && < 0.12
65+ , constraints >= 0.2 && < 0.14
6566 , containers >= 0.5.7.1 && < 0.7
6667 , mtl >= 2.2.2 && < 2.3
67− , text >= 1.2.3.0 && < 1.3
68+ , text >= 1.2.3.0 && < 2.1
6869 , transformers >= 0.5.2.0 && < 0.6
6970 , filepath >= 1.4.1.1 && < 1.5
7071
7172 -- Servant dependencies
7273 -- strict dependency as we re-export 'servant' things.
7374 build-depends:
74− servant >= 0.18.1 && < 0.18.2
75− , http-api-data >= 0.4.1 && < 0.4.3
75+ servant >= 0.19 && < 0.20
76+ , http-api-data >= 0.4.1 && < 0.4.4
7677
7778 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.
7879 -- Here can be exceptions if we really need features from the newer versions.
7980 build-depends:
80− base-compat >= 0.10.5 && < 0.12
81− , base64-bytestring >= 1.0.0.1 && < 1.2
81+ base-compat >= 0.10.5 && < 0.13
82+ , base64-bytestring >= 1.0.0.1 && < 1.3
8283 , exceptions >= 0.10.0 && < 0.11
8384 , http-media >= 0.7.1.3 && < 0.9
8485 , http-types >= 0.12.2 && < 0.13
@@ -113,7 +114,7 @@ executable greet
113114 , text
114115
115116 build-depends:
116− aeson >= 1.4.1.0 && < 1.6
117+ aeson >= 1.4.1.0 && < 3
117118 , warp >= 3.2.25 && < 3.4
118119
119120test-suite spec
@@ -147,6 +148,7 @@ test-suite spec
147148 , safe
148149 , servant
149150 , servant-server
151+ , sop-core
150152 , string-conversions
151153 , text
152154 , transformers
@@ -155,14 +157,14 @@ test-suite spec
155157
156158 -- Additional dependencies
157159 build-depends:
158− aeson >= 1.4.1.0 && < 1.6
160+ aeson >= 1.4.1.0 && < 3
159161 , directory >= 1.3.0.0 && < 1.4
160− , hspec >= 2.6.0 && < 2.8
162+ , hspec >= 2.6.0 && < 2.10
161163 , hspec-wai >= 0.10.1 && < 0.12
162− , QuickCheck >= 2.12.6.1 && < 2.14
164+ , QuickCheck >= 2.12.6.1 && < 2.15
163165 , should-not-typecheck >= 2.1.0 && < 2.2
164166 , temporary >= 1.3 && < 1.4
165167 , wai-extra >= 3.0.24.3 && < 3.2
166168
167169 build-tool-depends:
168− hspec-discover:hspec-discover >= 2.6.0 && <2.8
170+ hspec-discover:hspec-discover >= 2.6.0 && <2.10
servant-server/src/Servant/Server.hs+34−11
@@ -1,9 +1,10 @@
1−{-# LANGUAGE ConstraintKinds #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE FlexibleContexts #-}
4−{-# LANGUAGE RankNTypes #-}
5−{-# LANGUAGE TypeFamilies #-}
6−{-# LANGUAGE TypeOperators #-}
1+{-# LANGUAGE ConstraintKinds #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE RankNTypes #-}
5+{-# LANGUAGE ScopedTypeVariables #-}
6+{-# LANGUAGE TypeFamilies #-}
7+{-# LANGUAGE TypeOperators #-}
78
89-- | This module lets you implement 'Server's for defined APIs. You'll
910-- most likely just need 'serve'.
@@ -11,6 +12,8 @@ module Servant.Server
1112 ( -- * Run a wai application from an API
1213 serve
1314 , serveWithContext
15+ , serveWithContextT
16+ , ServerContext
1417
1518 , -- * Construct a wai Application from an API
1619 toApplication
@@ -128,6 +131,15 @@ import Servant.Server.UVerb
128131
129132-- * Implementing Servers
130133
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+
131143-- | 'serve' allows you to implement an API and produce a wai 'Application'.
132144--
133145-- Example:
@@ -157,11 +169,21 @@ serve p = serveWithContext p EmptyContext
157169-- 'defaultErrorFormatters' will always be appended to the end of the passed context,
158170-- but if you pass your own formatter, it will override the default one.
159171serveWithContext :: ( HasServer api context
160− , HasContextEntry (context .++ DefaultErrorFormatters) ErrorFormatters )
172+ , ServerContext context
173+ )
161174 => Proxy api -> Context context -> Server api -> Application
162−serveWithContext p context server =
163− toApplication (runRouter format404 (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)))
164185 where
186+ router = Route $ hoistServerWithContext p (Proxy :: Proxy context) toHandler server
165187 format404 = notFoundErrorFormatter . getContextEntry . mkContextWithErrorFormatter $ context
166188
167189-- | Hoist server implementation.
@@ -213,7 +235,7 @@ hoistServer p = hoistServerWithContext p (Proxy :: Proxy '[])
213235-- > │ └─ e/
214236-- > │ └─•
215237-- > ├─ b/
216−-- > │ └─ <capture>/
238+-- > │ └─ <x::Int>/
217239-- > │ ├─•
218240-- > │ ┆
219241-- > │ └─•
@@ -230,7 +252,8 @@ hoistServer p = hoistServerWithContext p (Proxy :: Proxy '[])
230252--
231253-- [@─•@] Leaves reflect endpoints.
232254--
233−-- [@\<capture\>/@] This is a delayed capture of a path component.
255+-- [@\<x::Int\>/@] This is a delayed capture of a single
256+-- path component named @x@, of expected type @Int@.
234257--
235258-- [@\<raw\>@] This is a part of the API we do not know anything about.
236259--
servant-server/src/Servant/Server/Generic.hs+11−18
@@ -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,21 +13,15 @@ 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
26−
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
23+import Servant.API.Generic
24+import Servant.Server.Internal
3325
3426-- | Transform a record of routes into a WAI 'Application'.
3527genericServe
@@ -97,3 +89,4 @@ genericServerT
9789 => routes (AsServerT m)
9890 -> ToServant routes (AsServerT m)
9991genericServerT = toServant
92+
servant-server/src/Servant/Server/Internal.hs+138−61
@@ -1,23 +1,22 @@
1−{-# LANGUAGE CPP #-}
1+{-# LANGUAGE AllowAmbiguousTypes #-}
22{-# LANGUAGE ConstraintKinds #-}
33{-# LANGUAGE DataKinds #-}
44{-# LANGUAGE DeriveDataTypeable #-}
55{-# LANGUAGE FlexibleContexts #-}
66{-# LANGUAGE FlexibleInstances #-}
7+{-# LANGUAGE InstanceSigs #-}
78{-# LANGUAGE MultiParamTypeClasses #-}
89{-# LANGUAGE OverloadedStrings #-}
910{-# LANGUAGE PolyKinds #-}
11+{-# LANGUAGE QuantifiedConstraints #-}
1012{-# LANGUAGE RankNTypes #-}
1113{-# LANGUAGE ScopedTypeVariables #-}
1214{-# LANGUAGE TupleSections #-}
15+{-# LANGUAGE TypeApplications #-}
1316{-# LANGUAGE TypeFamilies #-}
1417{-# LANGUAGE TypeOperators #-}
1518{-# LANGUAGE UndecidableInstances #-}
1619
17−#if MIN_VERSION_base(4,9,0) && __GLASGOW_HASKELL__ >= 802
18−#define HAS_TYPE_ERROR
19−#endif
20−
2120module Servant.Server.Internal
2221 ( module Servant.Server.Internal
2322 , module Servant.Server.Internal.BasicAuth
@@ -42,12 +41,11 @@ import qualified Data.ByteString as B
4241import qualified Data.ByteString.Builder as BB
4342import qualified Data.ByteString.Char8 as BC8
4443import qualified Data.ByteString.Lazy as BL
44+import Data.Constraint (Constraint, Dict(..))
4545import Data.Either
4646 (partitionEithers)
4747import Data.Maybe
4848 (fromMaybe, isNothing, mapMaybe, maybeToList)
49−import Data.Semigroup
50− ((<>))
5149import Data.String
5250 (IsString (..))
5351import Data.String.Conversions
@@ -56,8 +54,9 @@ import Data.Tagged
5654 (Tagged (..), retag, untag)
5755import qualified Data.Text as T
5856import Data.Typeable
57+import GHC.Generics
5958import GHC.TypeLits
60− (KnownNat, KnownSymbol, natVal, symbolVal)
59+ (KnownNat, KnownSymbol, TypeError, symbolVal)
6160import qualified Network.HTTP.Media as NHM
6261import Network.HTTP.Types hiding
6362 (Header, ResponseHeaders)
@@ -71,26 +70,30 @@ import Prelude ()
7170import Prelude.Compat
7271import Servant.API
7372 ((:<|>) (..), (:>), Accept (..), BasicAuth, Capture',
74− CaptureAll, Description, EmptyAPI, FramingRender (..),
75− FramingUnrender (..), FromSourceIO (..), Header', If,
76− IsSecure (..), QueryFlag, QueryParam', QueryParams, Raw,
77− ReflectMethod (reflectMethod), RemoteHost, ReqBody',
78− SBool (..), SBoolI (..), SourceIO, Stream, StreamBody',
79− Summary, ToSourceIO (..), Vault, Verb, NoContentVerb,
80− WithNamedContext)
73+ CaptureAll, Description, EmptyAPI, Fragment,
74+ FramingRender (..), FramingUnrender (..), FromSourceIO (..),
75+ Header', If, IsSecure (..), NoContentVerb, QueryFlag,
76+ QueryParam', QueryParams, Raw, ReflectMethod (reflectMethod),
77+ RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO,
78+ Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb,
79+ WithNamedContext, NamedRoutes)
80+import Servant.API.Generic (GenericMode(..), ToServant, ToServantApi, GServantProduct, toServant, fromServant)
8181import Servant.API.ContentTypes
8282 (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),
83− AllMime, MimeRender (..), MimeUnrender (..), canHandleAcceptH,
84− NoContent)
83+ AllMime, MimeRender (..), MimeUnrender (..), NoContent,
84+ canHandleAcceptH)
8585import Servant.API.Modifiers
8686 (FoldLenient, FoldRequired, RequestArgument,
8787 unfoldRequestArgument)
8888import Servant.API.ResponseHeaders
8989 (GetHeaders, Headers, getHeaders, getResponse)
90+import Servant.API.Status
91+ (statusFromNat)
9092import qualified Servant.Types.SourceT as S
93+import Servant.API.TypeErrors
9194import Web.HttpApiData
92− (FromHttpApiData, parseHeader, parseQueryParam,
93− parseUrlPieces, parseUrlPiece)
95+ (FromHttpApiData, parseHeader, parseQueryParam, parseUrlPiece,
96+ parseUrlPieces)
9497
9598import Servant.Server.Internal.BasicAuth
9699import Servant.Server.Internal.Context
@@ -103,10 +106,10 @@ import Servant.Server.Internal.RouteResult
103106import Servant.Server.Internal.RoutingApplication
104107import Servant.Server.Internal.ServerError
105108
106−#ifdef HAS_TYPE_ERROR
107109import GHC.TypeLits
108110 (ErrorMessage (..), TypeError)
109−#endif
111+import Servant.API.TypeLevel
112+ (AtLeastOneFragment, FragmentUnique)
110113
111114class HasServer api context where
112115 type ServerT api (m :: * -> *) :: *
@@ -170,7 +173,7 @@ instance (HasServer a context, HasServer b context) => HasServer (a :<|> b) cont
170173-- > server = getBook
171174-- > where getBook :: Text -> Handler Book
172175-- > getBook isbn = ...
173−instance (KnownSymbol capture, FromHttpApiData a
176+instance (KnownSymbol capture, FromHttpApiData a, Typeable a
174177 , HasServer api context, SBoolI (FoldLenient mods)
175178 , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
176179 )
@@ -182,7 +185,7 @@ instance (KnownSymbol capture, FromHttpApiData a
182185 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
183186
184187 route Proxy context d =
185− CaptureRouter $
188+ CaptureRouter [hint] $
186189 route (Proxy :: Proxy api)
187190 context
188191 (addCapture d $ \ txt -> withRequest $ \ request ->
@@ -194,6 +197,7 @@ instance (KnownSymbol capture, FromHttpApiData a
194197 where
195198 rep = typeRep (Proxy :: Proxy Capture')
196199 formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
200+ hint = CaptureHint (T.pack $ symbolVal $ Proxy @capture) (typeRep (Proxy :: Proxy a))
197201
198202-- | If you use 'CaptureAll' in one of the endpoints for your API,
199203-- this automatically requires your server-side handler to be a
@@ -212,7 +216,7 @@ instance (KnownSymbol capture, FromHttpApiData a
212216-- > server = getSourceFile
213217-- > where getSourceFile :: [Text] -> Handler Book
214218-- > getSourceFile pathSegments = ...
215−instance (KnownSymbol capture, FromHttpApiData a
219+instance (KnownSymbol capture, FromHttpApiData a, Typeable a
216220 , HasServer api context
217221 , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
218222 )
@@ -224,7 +228,7 @@ instance (KnownSymbol capture, FromHttpApiData a
224228 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
225229
226230 route Proxy context d =
227− CaptureAllRouter $
231+ CaptureAllRouter [hint] $
228232 route (Proxy :: Proxy api)
229233 context
230234 (addCapture d $ \ txts -> withRequest $ \ request ->
@@ -235,6 +239,7 @@ instance (KnownSymbol capture, FromHttpApiData a
235239 where
236240 rep = typeRep (Proxy :: Proxy CaptureAll)
237241 formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
242+ hint = CaptureHint (T.pack $ symbolVal $ Proxy @capture) (typeRep (Proxy :: Proxy [a]))
238243
239244allowedMethodHead :: Method -> Request -> Bool
240245allowedMethodHead method request = method == methodGet && requestMethod request == methodHead
@@ -298,7 +303,7 @@ instance {-# OVERLAPPABLE #-}
298303
299304 route Proxy _ = methodRouter ([],) method (Proxy :: Proxy ctypes) status
300305 where method = reflectMethod (Proxy :: Proxy method)
301− status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
306+ status = statusFromNat (Proxy :: Proxy status)
302307
303308instance {-# OVERLAPPING #-}
304309 ( AllCTRender ctypes a, ReflectMethod method, KnownNat status
@@ -310,7 +315,7 @@ instance {-# OVERLAPPING #-}
310315
311316 route Proxy _ = methodRouter (\x -> (getHeaders x, getResponse x)) method (Proxy :: Proxy ctypes) status
312317 where method = reflectMethod (Proxy :: Proxy method)
313− status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
318+ status = statusFromNat (Proxy :: Proxy status)
314319
315320instance (ReflectMethod method) =>
316321 HasServer (NoContentVerb method) context where
@@ -331,7 +336,7 @@ instance {-# OVERLAPPABLE #-}
331336
332337 route Proxy _ = streamRouter ([],) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)
333338 where method = reflectMethod (Proxy :: Proxy method)
334− status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
339+ status = statusFromNat (Proxy :: Proxy status)
335340
336341
337342instance {-# OVERLAPPING #-}
@@ -345,7 +350,7 @@ instance {-# OVERLAPPING #-}
345350
346351 route Proxy _ = streamRouter (\x -> (getHeaders x, getResponse x)) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)
347352 where method = reflectMethod (Proxy :: Proxy method)
348− status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
353+ status = statusFromNat (Proxy :: Proxy status)
349354
350355
351356streamRouter :: forall ctype a c chunk env framing. (MimeRender ctype chunk, FramingRender framing, ToSourceIO chunk a) =>
@@ -784,7 +789,7 @@ instance ( KnownSymbol realm
784789-- * helpers
785790
786791ct_wildcard :: B.ByteString
787−ct_wildcard = "*" <> "/" <> "*" -- Because CPP
792+ct_wildcard = "*" <> "/" <> "*"
788793
789794getAcceptHeader :: Request -> AcceptHeader
790795getAcceptHeader = AcceptHeader . fromMaybe ct_wildcard . lookup hAccept . requestHeaders
@@ -812,39 +817,15 @@ instance (HasContextEntry context (NamedContext name subContext), HasServer subA
812817 hoistServerWithContext _ _ nt s = hoistServerWithContext (Proxy :: Proxy subApi) (Proxy :: Proxy subContext) nt s
813818
814819-------------------------------------------------------------------------------
815−-- TypeError helpers
820+-- Custom type errors
816821-------------------------------------------------------------------------------
817822
818−#ifdef HAS_TYPE_ERROR
819−-- | This instance catches mistakes when there are non-saturated
820−-- type applications on LHS of ':>'.
821−--
822−-- >>> serve (Proxy :: Proxy (Capture "foo" :> Get '[JSON] Int)) (error "...")
823−-- ...
824−-- ...Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'.
825−-- ...Maybe you haven't applied enough arguments to
826−-- ...Capture' '[] "foo"
827−-- ...
828−--
829−-- >>> undefined :: Server (Capture "foo" :> Get '[JSON] Int)
830−-- ...
831−-- ...Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'.
832−-- ...Maybe you haven't applied enough arguments to
833−-- ...Capture' '[] "foo"
834−-- ...
835−--
836−instance TypeError (HasServerArrowKindError arr) => HasServer ((arr :: k -> l) :> api) context
823+-- Erroring instance for 'HasServer' when a combinator is not fully applied
824+instance TypeError (PartialApplication HasServer arr) => HasServer ((arr :: a -> b) :> sub) context
837825 where
838− type ServerT (arr :> api) m = TypeError (HasServerArrowKindError arr)
839− -- it doesn't really matter what sub route we peak
840− route _ _ _ = error "servant-server panic: impossible happened in HasServer (arr :> api)"
841− hoistServerWithContext _ _ _ = id
842−
843−-- Cannot have TypeError here, otherwise use of this symbol will error :)
844−type HasServerArrowKindError arr =
845− 'Text "Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'."
846− ':$$: 'Text "Maybe you haven't applied enough arguments to"
847− ':$$: 'ShowType arr
826+ type ServerT (arr :> sub) _ = TypeError (PartialApplication (HasServer :: * -> [*] -> Constraint) arr)
827+ route = error "unreachable"
828+ hoistServerWithContext _ _ _ _ = error "unreachable"
848829
849830-- | This instance prevents from accidentally using '->' instead of ':>'
850831--
@@ -878,7 +859,103 @@ type HasServerArrowTypeError a b =
878859 ':$$: 'ShowType a
879860 ':$$: 'Text "and"
880861 ':$$: 'ShowType b
881−#endif
862+
863+-- Erroring instances for 'HasServer' for unknown API combinators
864+
865+-- XXX: This omits the @context@ parameter, e.g.:
866+--
867+-- "There is no instance for HasServer (Bool :> …)". Do we care ?
868+instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub HasServer ty) => HasServer (ty :> sub) context
869+
870+instance {-# OVERLAPPABLE #-} TypeError (NoInstanceFor (HasServer api context)) => HasServer api context
871+
872+-- | Ignore @'Fragment'@ in server handlers.
873+-- See <https://ietf.org/rfc/rfc2616.html#section-15.1.3> for more details.
874+--
875+-- Example:
876+--
877+-- > type MyApi = "books" :> Fragment Text :> Get '[JSON] [Book]
878+-- >
879+-- > server :: Server MyApi
880+-- > server = getBooks
881+-- > where getBooks :: Handler [Book]
882+-- > getBooks = ...return all books...
883+instance (AtLeastOneFragment api, FragmentUnique (Fragment a1 :> api), HasServer api context)
884+ => HasServer (Fragment a1 :> api) context where
885+ type ServerT (Fragment a1 :> api) m = ServerT api m
886+
887+ route _ = route (Proxy :: Proxy api)
888+
889+ hoistServerWithContext _ = hoistServerWithContext (Proxy :: Proxy api)
882890
883891-- $setup
884892-- >>> import Servant
893+
894+-- | A type that specifies that an API record contains a server implementation.
895+data AsServerT (m :: * -> *)
896+instance GenericMode (AsServerT m) where
897+ type AsServerT m :- api = ServerT api m
898+
899+type AsServer = AsServerT Handler
900+
901+
902+-- | Set of constraints required to convert to / from vanilla server types.
903+type GServerConstraints api m =
904+ ( ToServant api (AsServerT m) ~ ServerT (ToServantApi api) m
905+ , GServantProduct (Rep (api (AsServerT m)))
906+ )
907+
908+-- | This class is a necessary evil: in the implementation of 'HasServer' for
909+-- @'NamedRoutes' api@, we essentially need the quantified constraint @forall
910+-- m. 'GServerConstraints' m@ to hold.
911+--
912+-- We cannot require do that directly as the definition of 'GServerConstraints'
913+-- contains type family applications ('Rep' and 'ServerT'). The trick is to hide
914+-- those type family applications behind a typeclass providing evidence for
915+-- @'GServerConstraints' api m@ in the form of a dictionary, and require that
916+-- @forall m. 'GServer' api m@ instead.
917+--
918+-- Users shouldn't have to worry about this class, as the only possible instance
919+-- is provided in this module for all record APIs.
920+
921+class GServer (api :: * -> *) (m :: * -> *) where
922+ gServerProof :: Dict (GServerConstraints api m)
923+
924+instance
925+ ( ToServant api (AsServerT m) ~ ServerT (ToServantApi api) m
926+ , GServantProduct (Rep (api (AsServerT m)))
927+ ) => GServer api m where
928+ gServerProof = Dict
929+
930+instance
931+ ( HasServer (ToServantApi api) context
932+ , forall m. Generic (api (AsServerT m))
933+ , forall m. GServer api m
934+ ) => HasServer (NamedRoutes api) context where
935+
936+ type ServerT (NamedRoutes api) m = api (AsServerT m)
937+
938+ route
939+ :: Proxy (NamedRoutes api)
940+ -> Context context
941+ -> Delayed env (api (AsServerT Handler))
942+ -> Router env
943+ route _ ctx delayed =
944+ case gServerProof @api @Handler of
945+ Dict -> route (Proxy @(ToServantApi api)) ctx (toServant <$> delayed)
946+
947+ hoistServerWithContext
948+ :: forall m n. Proxy (NamedRoutes api)
949+ -> Proxy context
950+ -> (forall x. m x -> n x)
951+ -> api (AsServerT m)
952+ -> api (AsServerT n)
953+ hoistServerWithContext _ pctx nat server =
954+ case (gServerProof @api @m, gServerProof @api @n) of
955+ (Dict, Dict) ->
956+ fromServant servantSrvN
957+ where
958+ servantSrvM :: ServerT (ToServantApi api) m =
959+ toServant server
960+ servantSrvN :: ServerT (ToServantApi api) n =
961+ hoistServerWithContext (Proxy @(ToServantApi api)) pctx nat servantSrvM
servant-server/src/Servant/Server/Internal/BasicAuth.hs−2
@@ -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
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+31−14
@@ -9,12 +9,16 @@ 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)
2024import Servant.Server.Internal.ErrorFormatter
@@ -24,6 +28,18 @@ import Servant.Server.Internal.ServerError
2428
2529type Router env = Router' env RoutingApplication
2630
31+data CaptureHint = CaptureHint
32+ { captureName :: Text
33+ , captureType :: TypeRep
34+ }
35+ deriving (Show, Eq)
36+
37+toCaptureTag :: CaptureHint -> Text
38+toCaptureTag hint = captureName hint <> "::" <> (T.pack . show) (captureType hint)
39+
40+toCaptureTags :: [CaptureHint] -> Text
41+toCaptureTags hints = "<" <> T.intercalate "|" (map toCaptureTag hints) <> ">"
42+
2743-- | Internal representation of a router.
2844--
2945-- The first argument describes an environment type that is
@@ -36,10 +52,10 @@ data Router' env a =
3652 -- ^ the map contains routers for subpaths (first path component used
3753 -- for lookup and removed afterwards), the list contains handlers
3854 -- for the empty path, to be tried in order
39− | CaptureRouter (Router' (Text, env) a)
55+ | CaptureRouter [CaptureHint] (Router' (Text, env) a)
4056 -- ^ first path component is passed to the child router in its
4157 -- environment and removed afterwards
42− | CaptureAllRouter (Router' ([Text], env) a)
58+ | CaptureAllRouter [CaptureHint] (Router' ([Text], env) a)
4359 -- ^ all path components are passed to the child router in its
4460 -- environment and are removed afterwards
4561 | RawRouter (env -> a)
@@ -69,8 +85,8 @@ leafRouter l = StaticRouter M.empty [l]
6985choice :: Router' env a -> Router' env a -> Router' env a
7086choice (StaticRouter table1 ls1) (StaticRouter table2 ls2) =
7187 StaticRouter (M.unionWith choice table1 table2) (ls1 ++ ls2)
72−choice (CaptureRouter router1) (CaptureRouter router2) =
73− CaptureRouter (choice router1 router2)
88+choice (CaptureRouter hints1 router1) (CaptureRouter hints2 router2) =
89+ CaptureRouter (nub $ hints1 ++ hints2) (choice router1 router2)
7490choice router1 (Choice router2 router3) = Choice (choice router1 router2) router3
7591choice router1 router2 = Choice router1 router2
7692
@@ -84,7 +100,7 @@ choice router1 router2 = Choice router1 router2
84100--
85101data RouterStructure =
86102 StaticRouterStructure (Map Text RouterStructure) Int
87− | CaptureRouterStructure RouterStructure
103+ | CaptureRouterStructure [CaptureHint] RouterStructure
88104 | RawRouterStructure
89105 | ChoiceStructure RouterStructure RouterStructure
90106 deriving (Eq, Show)
@@ -98,11 +114,11 @@ data RouterStructure =
98114routerStructure :: Router' env a -> RouterStructure
99115routerStructure (StaticRouter m ls) =
100116 StaticRouterStructure (fmap routerStructure m) (length ls)
101−routerStructure (CaptureRouter router) =
102− CaptureRouterStructure $
117+routerStructure (CaptureRouter hints router) =
118+ CaptureRouterStructure hints $
103119 routerStructure router
104−routerStructure (CaptureAllRouter router) =
105− CaptureRouterStructure $
120+routerStructure (CaptureAllRouter hints router) =
121+ CaptureRouterStructure hints $
106122 routerStructure router
107123routerStructure (RawRouter _) =
108124 RawRouterStructure
@@ -114,8 +130,8 @@ routerStructure (Choice r1 r2) =
114130-- | Compare the structure of two routers.
115131--
116132sameStructure :: Router' env a -> Router' env b -> Bool
117−sameStructure r1 r2 =
118− routerStructure r1 == routerStructure r2
133+sameStructure router1 router2 =
134+ routerStructure router1 == routerStructure router2
119135
120136-- | Provide a textual representation of the
121137-- structure of a router.
@@ -126,7 +142,8 @@ routerLayout router =
126142 where
127143 mkRouterLayout :: Bool -> RouterStructure -> [Text]
128144 mkRouterLayout c (StaticRouterStructure m n) = mkSubTrees c (M.toList m) n
129− mkRouterLayout c (CaptureRouterStructure r) = mkSubTree c "<capture>" (mkRouterLayout False r)
145+ mkRouterLayout c (CaptureRouterStructure hints r) =
146+ mkSubTree c (toCaptureTags hints) (mkRouterLayout False r)
130147 mkRouterLayout c RawRouterStructure =
131148 if c then ["├─ <raw>"] else ["└─ <raw>"]
132149 mkRouterLayout c (ChoiceStructure r1 r2) =
@@ -169,7 +186,7 @@ runRouterEnv fmt router env request respond =
169186 -> let request' = request { pathInfo = rest }
170187 in runRouterEnv fmt router' env request' respond
171188 _ -> respond $ Fail $ fmt request
172− CaptureRouter router' ->
189+ CaptureRouter _ router' ->
173190 case pathInfo request of
174191 [] -> respond $ Fail $ fmt request
175192 -- This case is to handle trailing slashes.
@@ -177,7 +194,7 @@ runRouterEnv fmt router env request respond =
177194 first : rest
178195 -> let request' = request { pathInfo = rest }
179196 in runRouterEnv fmt router' (first, env) request' respond
180− CaptureAllRouter router' ->
197+ CaptureAllRouter _ router' ->
181198 let segments = pathInfo request
182199 request' = request { pathInfo = [] }
183200 in runRouterEnv fmt router' (segments, env) request' respond
servant-server/src/Servant/Server/Internal/ServerError.hs+1−1
@@ -187,7 +187,7 @@ err403 = ServerError { errHTTPCode = 403
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.hs+40−20
@@ -22,15 +22,17 @@ module Servant.Server.UVerb
2222 )
2323where
2424
25+import qualified Data.ByteString as B
2526import Data.Proxy (Proxy (Proxy))
2627import Data.SOP (I (I))
2728import Data.SOP.Constraint (All, And)
2829import Data.String.Conversions (LBS, cs)
29−import Network.HTTP.Types (Status, hContentType)
30−import Network.Wai (responseLBS)
30+import Network.HTTP.Types (Status, HeaderName, hContentType)
31+import Network.Wai (responseLBS, Request)
3132import Servant.API (ReflectMethod, reflectMethod)
3233import Servant.API.ContentTypes (AllCTRender (handleAcceptH), AllMime)
33−import Servant.API.UVerb (HasStatus, IsMember, Statuses, UVerb, Union, Unique, foldMapUnion, inject, statusOf)
34+import Servant.API.ResponseHeaders (GetHeaders (..), Headers (..))
35+import Servant.API.UVerb (HasStatus, IsMember, Statuses, UVerb, Union, Unique, WithStatus (..), foldMapUnion, inject, statusOf)
3436import Servant.Server.Internal (Context, Delayed, Handler, HasServer (..), RouteResult (FailFatal, Route), Router, Server, ServerT, acceptCheck, addAcceptCheck, addMethodCheck, allowedMethodHead, err406, getAcceptHeader, leafRouter, methodCheck, runAction)
3537
3638
@@ -43,15 +45,40 @@ respond ::
4345 f (Union xs)
4446respond = pure . inject . I
4547
46−-- | Helper constraint used in @instance 'HasServer' 'UVerb'@.
47−type IsServerResource contentTypes = AllCTRender contentTypes `And` HasStatus
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
4875
4976instance
5077 ( ReflectMethod method,
5178 AllMime contentTypes,
52− All (IsServerResource contentTypes) as,
79+ All (IsServerResourceWithStatus contentTypes) as,
5380 Unique (Statuses as) -- for consistency with servant-swagger (server would work fine
54− -- wihtout; client is a bit of a corner case, because it dispatches
81+ -- without; client is a bit of a corner case, because it dispatches
5582 -- the parser based on the status code. with this uniqueness
5683 -- constraint it won't have to run more than one parser in weird
5784 -- corner cases.
@@ -77,20 +104,13 @@ instance
77104 action
78105 `addMethodCheck` methodCheck method request
79106 `addAcceptCheck` acceptCheck (Proxy @contentTypes) (getAcceptHeader request)
80− mkProxy :: a -> Proxy a
81− mkProxy _ = Proxy
82107
83108 runAction action' env request cont $ \(output :: Union as) -> do
84− let encodeResource :: (AllCTRender contentTypes a, HasStatus a) => a -> (Status, Maybe (LBS, LBS))
85− encodeResource res =
86− ( statusOf $ mkProxy res,
87− handleAcceptH (Proxy @contentTypes) (getAcceptHeader request) res
88− )
89− pickResource :: Union as -> (Status, Maybe (LBS, LBS))
90− pickResource = foldMapUnion (Proxy @(IsServerResource contentTypes)) encodeResource
91−
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)
92112 case pickResource output of
93− (_, Nothing) -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does
94− (status, Just (contentT, body)) ->
113+ (_, Nothing, _) -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does
114+ (status, Just (contentT, body), headers) ->
95115 let bdy = if allowedMethodHead method request then "" else body
96− in Route $ responseLBS status ((hContentType, cs contentT) : []) bdy
116+ in Route $ responseLBS status ((hContentType, cs contentT) : headers) bdy
servant-server/test/Servant/Server/ErrorSpec.hs−2
@@ -12,8 +12,6 @@ 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
1816import Data.String.Conversions
1917 (cs)
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+127−6
@@ -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,6 +29,7 @@ spec :: Spec
2729spec = describe "Servant.Server.Internal.Router" $ do
2830 routerSpec
2931 distributivitySpec
32+ serverLayoutSpec
3033
3134routerSpec :: Spec
3235routerSpec = do
@@ -51,7 +54,7 @@ routerSpec = do
5154 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+74−15
@@ -1,12 +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 #-}
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 #-}
1011{-# OPTIONS_GHC -freduction-depth=100 #-}
1112
1213module Servant.ServerSpec where
@@ -48,12 +49,12 @@ import Network.Wai.Test
4849import Servant.API
4950 ((:<|>) (..), (:>), AuthProtect, BasicAuth,
5051 BasicAuthData (BasicAuthData), Capture, Capture', CaptureAll,
51− Delete, EmptyAPI, Get, HasStatus(StatusOf), Header, Headers,
52− HttpVersion, IsSecure (..), JSON, Lenient, NoContent (..),
53− NoContentVerb, NoFraming, OctetStream, Patch, PlainText, Post,
54− Put, QueryFlag, QueryParam, QueryParams, Raw, RemoteHost,
55− ReqBody, SourceIO, StdMethod (..), Stream, Strict, Union,
56− UVerb, Verb, addHeader)
52+ Delete, EmptyAPI, Fragment, Get, HasStatus (StatusOf), Header,
53+ Headers, HttpVersion, IsSecure (..), JSON, Lenient,
54+ NoContent (..), NoContentVerb, NoFraming, OctetStream, Patch,
55+ PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw,
56+ RemoteHost, ReqBody, SourceIO, StdMethod (..), Stream, Strict,
57+ UVerb, Union, Verb, WithStatus (..), addHeader)
5758import Servant.Server
5859 (Context ((:.), EmptyContext), Handler, Server, Tagged (..),
5960 emptyServer, err401, err403, err404, respond, serve,
@@ -92,11 +93,13 @@ spec = do
9293 captureSpec
9394 captureAllSpec
9495 queryParamSpec
96+ fragmentSpec
9597 reqBodySpec
9698 headerSpec
9799 rawSpec
98100 alternativeSpec
99101 responseHeadersSpec
102+ uverbResponseHeadersSpec
100103 miscCombinatorSpec
101104 basicAuthSpec
102105 genAuthSpec
@@ -461,6 +464,37 @@ queryParamSpec = do
461464 { name = "Alice"
462465 }
463466
467+-- }}}
468+------------------------------------------------------------------------------
469+-- * fragmentSpec {{{
470+------------------------------------------------------------------------------
471+
472+type FragmentApi = "name" :> Fragment String :> Get '[JSON] Person
473+ :<|> "age" :> Fragment Integer :> Get '[JSON] Person
474+
475+fragmentApi :: Proxy FragmentApi
476+fragmentApi = Proxy
477+
478+fragServer :: Server FragmentApi
479+fragServer = fragmentServer :<|> fragAge
480+ where
481+ fragmentServer = return alice
482+ fragAge = return alice
483+
484+fragmentSpec :: Spec
485+fragmentSpec = do
486+ let mkRequest params pinfo = Network.Wai.Test.request defaultRequest
487+ { rawQueryString = params
488+ , queryString = parseQuery params
489+ , pathInfo = pinfo
490+ }
491+
492+ describe "Servant.API.Fragment" $ do
493+ it "ignores fragment even if it is present in query" $ do
494+ flip runSession (serve fragmentApi fragServer) $ do
495+ response1 <- mkRequest "#Alice" ["name"]
496+ liftIO $ decode' (simpleBody response1) `shouldBe` Just alice
497+
464498-- }}}
465499------------------------------------------------------------------------------
466500-- * reqBodySpec {{{
@@ -652,6 +686,31 @@ responseHeadersSpec = describe "ResponseHeaders" $ do
652686 THW.request method "" [(hAccept, "crazy/mime")] ""
653687 `shouldRespondWith` 406
654688
689+-- }}}
690+------------------------------------------------------------------------------
691+-- * uverbResponseHeaderSpec {{{
692+------------------------------------------------------------------------------
693+type UVerbHeaderResponse = '[
694+ WithStatus 200 (Headers '[Header "H1" Int] String),
695+ WithStatus 404 String ]
696+
697+type UVerbResponseHeadersApi =
698+ Capture "ok" Bool :> UVerb 'GET '[JSON] UVerbHeaderResponse
699+
700+uverbResponseHeadersServer :: Server UVerbResponseHeadersApi
701+uverbResponseHeadersServer True = respond . WithStatus @200 . addHeader @"H1" (5 :: Int) $ ("foo" :: String)
702+uverbResponseHeadersServer False = respond . WithStatus @404 $ ("bar" :: String)
703+
704+uverbResponseHeadersSpec :: Spec
705+uverbResponseHeadersSpec = describe "UVerbResponseHeaders" $ do
706+ with (return $ serve (Proxy :: Proxy UVerbResponseHeadersApi) uverbResponseHeadersServer) $ do
707+
708+ it "includes the headers in the response" $
709+ THW.request methodGet "/true" [] ""
710+ `shouldRespondWith` "\"foo\"" { matchHeaders = ["H1" <:> "5"]
711+ , matchStatus = 200
712+ }
713+
655714-- }}}
656715------------------------------------------------------------------------------
657716-- * miscCombinatorSpec {{{
servant-swagger/CHANGELOG.mdnew file+143
@@ -0,0 +1,143 @@
1+1.1.9
2+-------
3+
4+* Support `servant-0.18`
5+
6+1.1.8
7+-------
8+
9+* Support `servant-0.17`
10+
11+1.1.7.1
12+-------
13+
14+* Support `swagger2-2.4`
15+
16+1.1.7
17+-----
18+
19+* Support servant-0.15
20+ - support for 'Stream' and 'StreamBody' combinators
21+ - orphan 'ToSchema (SourceT m a)' instance
22+* Fix BodyTypes to work with generalized ReqBody'
23+ [#88](https://github.com/haskell-servant/servant-swagger/pull/88)
24+
25+1.1.6
26+-----
27+
28+* Fixes:
29+ * `validateEveryToJSON` now prints validation errors
30+
31+* Notes:
32+ * GHC-8.6 compatible release
33+
34+1.1.5
35+-----
36+
37+* Notes:
38+ * `servant-0.13` compatible release
39+ * Drops compatibility with previous `servant` versions.
40+
41+1.1.4
42+-----
43+
44+* Notes:
45+ * `servant-0.12` compatible release
46+
47+1.1.3.1
48+---
49+
50+* Notes:
51+ * GHC-8.2 compatible release
52+
53+1.1.3
54+---
55+
56+* Notes:
57+ * `servant-0.11` compatible release
58+
59+1.1.2.1
60+---
61+
62+* Notes:
63+ * `servant-0.10` compatible release
64+
65+1.1.2
66+---
67+
68+* Minor fixes:
69+ * Support for aeson-1, insert-ordered-containers-0.2
70+ * CaptureAll instance
71+
72+1.1.1
73+---
74+
75+* Minor fixes:
76+ * Fix `unused-imports` and `unused-foralls` warnings;
77+ * Fix tests to match `swagger2-2.1.1` (add `example` property for `UTCTime` schema).
78+
79+1.1
80+---
81+
82+* Breaking changes:
83+ * Requires `swagger2 >= 2.1`
84+ * Requires `servant >= 0.5`
85+
86+* Notes:
87+ * GHC-8.0 compatible release
88+
89+1.0.3
90+---
91+
92+* Fixes:
93+ * Improve compile-time performance of `BodyTypes` even further (see [18e0d95](https://github.com/haskell-servant/servant-swagger/commit/18e0d95ef6fe9076dd9621cb515d8d1a189f71d3))!
94+
95+1.0.2
96+---
97+
98+* Minor changes:
99+ * Add GHC 7.8 support (see [#26](https://github.com/haskell-servant/servant-swagger/pull/26)).
100+
101+* Fixes:
102+ * Improve compile-time performance of `BodyTypes` (see [#25](https://github.com/haskell-servant/servant-swagger/issues/25)).
103+
104+1.0.1
105+---
106+
107+* Fixes:
108+ * Stop using `Data.Swagger.Internal`;
109+ * Documentation fixes (links to examples).
110+
111+1.0
112+---
113+
114+* Major changes (see [#24](https://github.com/haskell-servant/servant-swagger/pull/24)):
115+ * Switch to `swagger2-2.*`;
116+ * Add automatic `ToJSON`/`ToSchema` validation tests;
117+ * Add great documentation;
118+ * Export some type-level functions for servant API.
119+
120+* Minor changes:
121+ * Rework Todo API example;
122+ * Stop exporting `ToResponseHeader`, `AllAccept` and `AllToResponseHeader` (see [bd50db4](https://github.com/haskell-servant/servant-swagger/commit/bd50db48ca6a106e4366560ded70932d409de1e2));
123+ * Change maintainer, update authors/copyrights (see [1a62681](https://github.com/haskell-servant/servant-swagger/commit/1a6268101dc826a92c42e832e402e251c0d32147));
124+ * Include changelog and example files into `extra-source-files`.
125+
126+0.1.2
127+---
128+
129+* Fixes:
130+ * Fix default spec for `ReqBody` param to be required (see [#22](https://github.com/haskell-servant/servant-swagger/issues/22));
131+ * Set version bounds for `swagger2`.
132+
133+0.1.1
134+---
135+
136+* Fixes:
137+ * Fix `subOperations` to filter endpoints also by method (see [#18](https://github.com/haskell-servant/servant-swagger/issues/18));
138+ * Fix response schema in `ToSwagger` instance for `Header` (see [b59e557](https://github.com/haskell-servant/servant-swagger/commit/b59e557a05bc2669332c52b397879e7598747b82)).
139+
140+0.1
141+---
142+* Major changes
143+ * Use `swagger2` for data model (see [#9](https://github.com/dmjio/servant-swagger/pull/9)); this changes almost everything.
servant-swagger/LICENSEnew file+28
@@ -0,0 +1,28 @@
1+Copyright (c) 2015-2016, Servant contributors
2+All rights reserved.
3+
4+Redistribution and use in source and binary forms, with or without
5+modification, are permitted provided that the following conditions are met:
6+
7+* Redistributions of source code must retain the above copyright notice, this
8+ list of conditions and the following disclaimer.
9+
10+* Redistributions in binary form must reproduce the above copyright notice,
11+ this list of conditions and the following disclaimer in the documentation
12+ and/or other materials provided with the distribution.
13+
14+* Neither the name of servant-swagger nor the names of its
15+ contributors may be used to endorse or promote products derived from
16+ this software without specific prior written permission.
17+
18+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
19+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
20+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
21+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
22+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
23+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
24+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
25+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
26+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
27+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
28+
servant-swagger/README.mdnew file+46
@@ -0,0 +1,46 @@
1+# servant-swagger
2+
3+[![Hackage](https://img.shields.io/hackage/v/servant-swagger.svg)](http://hackage.haskell.org/package/servant-swagger)
4+[![Stackage LTS](http://stackage.org/package/servant-swagger/badge/lts)](http://stackage.org/lts/package/servant-swagger)
5+[![Stackage Nightly](http://stackage.org/package/servant-swagger/badge/nightly)](http://stackage.org/nightly/package/servant-swagger)
6+
7+Swagger 2.0 conforming json for [servant](https://github.com/haskell-servant/servant) APIs.
8+
9+![servant-swagger robot](http://s16.postimg.org/rndz1wbyt/servant.png)
10+
11+### Motivation
12+
13+Swagger is a project used to describe and document RESTful APIs.
14+Unlike Servant it is language-agnostic and thus is quite popular among developers
15+in different languages. It also exists for a longer time and has more tools to work with.
16+
17+This package provides means to generate Swagger specification for a Servant API
18+and also to partially test whether API conforms with its specification.
19+
20+Generated Swagger specification then can be used for many things such as
21+- displaying interactive documentation using [Swagger UI](http://swagger.io/swagger-ui/);
22+- generating clients and servers in many languages using [Swagger Codegen](http://swagger.io/swagger-codegen/);
23+- and [many others](http://swagger.io/open-source-integrations/).
24+
25+### Usage
26+
27+Please refer to [haddock documentation](http://hackage.haskell.org/package/servant/servant-swagger).
28+
29+Some examples can be found in [`example/` directory](/example).
30+
31+### Try it out
32+
33+All generated swagger specifications can be interactively viewed on [Swagger Editor](http://editor.swagger.io/).
34+
35+Ready-to-use specification can be served as JSON and interactive API documentation
36+can be displayed using [Swagger UI](https://github.com/swagger-api/swagger-ui).
37+
38+Many Swagger tools, including server and client code generation for many languages, can be found on
39+[Swagger's Tools and Integrations page](http://swagger.io/open-source-integrations/).
40+
41+### Contributing
42+
43+We are happy to receive bug reports, fixes, documentation enhancements, and other improvements.
44+
45+Please report bugs via the [github issue tracker](https://github.com/haskell-servant/servant/issues).
46+
servant-swagger/Setup.hsnew file+33
@@ -0,0 +1,33 @@
1+{-# LANGUAGE CPP #-}
2+{-# OPTIONS_GHC -Wall #-}
3+module Main (main) where
4+
5+#ifndef MIN_VERSION_cabal_doctest
6+#define MIN_VERSION_cabal_doctest(x,y,z) 0
7+#endif
8+
9+#if MIN_VERSION_cabal_doctest(1,0,0)
10+
11+import Distribution.Extra.Doctest ( defaultMainWithDoctests )
12+main :: IO ()
13+main = defaultMainWithDoctests "doctests"
14+
15+#else
16+
17+#ifdef MIN_VERSION_Cabal
18+-- If the macro is defined, we have new cabal-install,
19+-- but for some reason we don't have cabal-doctest in package-db
20+--
21+-- Probably we are running cabal sdist, when otherwise using new-build
22+-- workflow
23+#warning You are configuring this package without cabal-doctest installed. \
24+ The doctests test-suite will not work as a result. \
25+ To fix this, install cabal-doctest before configuring.
26+#endif
27+
28+import Distribution.Simple
29+
30+main :: IO ()
31+main = defaultMain
32+
33+#endif
servant-swagger/example/LICENSEnew file+28
@@ -0,0 +1,28 @@
1+Copyright (c) 2015-2016, Servant contributors
2+All rights reserved.
3+
4+Redistribution and use in source and binary forms, with or without
5+modification, are permitted provided that the following conditions are met:
6+
7+* Redistributions of source code must retain the above copyright notice, this
8+ list of conditions and the following disclaimer.
9+
10+* Redistributions in binary form must reproduce the above copyright notice,
11+ this list of conditions and the following disclaimer in the documentation
12+ and/or other materials provided with the distribution.
13+
14+* Neither the name of servant-swagger nor the names of its
15+ contributors may be used to endorse or promote products derived from
16+ this software without specific prior written permission.
17+
18+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
19+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
20+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
21+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
22+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
23+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
24+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
25+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
26+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
27+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
28+
servant-swagger/example/example.cabalnew file+62
@@ -0,0 +1,62 @@
1+cabal-version: 2.2
2+name: example
3+version: 1.0
4+synopsis: servant-swagger demonstration
5+description: servant-swagger demonstration
6+license: BSD-3-Clause
7+license-file: LICENSE
8+author: David Johnson, Nickolay Kudasov
9+maintainer: nickolay.kudasov@gmail.com
10+copyright: (c) 2015-2016, Servant contributors
11+category: Web
12+build-type: Simple
13+data-files:
14+ swagger.json
15+
16+library
17+ ghc-options: -Wall
18+ hs-source-dirs: src/
19+ exposed-modules:
20+ Todo
21+ build-depends: base
22+ , aeson
23+ , aeson-pretty
24+ , bytestring
25+ , lens
26+ , servant
27+ , servant-server
28+ , servant-swagger
29+ , swagger2
30+ , text
31+ , time
32+ default-language: Haskell2010
33+
34+executable swagger-server
35+ ghc-options: -Wall
36+ hs-source-dirs: server/
37+ main-is: Main.hs
38+ build-depends: base
39+ , example
40+ , servant-server
41+ , warp
42+ default-language: Haskell2010
43+
44+test-suite swagger-server-spec
45+ ghc-options: -Wall
46+ type: exitcode-stdio-1.0
47+ hs-source-dirs: test
48+ main-is: Spec.hs
49+ other-modules:
50+ TodoSpec
51+ Paths_example
52+ build-depends: base == 4.*
53+ , base-compat >= 0.6.0
54+ , aeson >=0.11.2.0
55+ , bytestring
56+ , example
57+ , hspec
58+ , servant-swagger
59+ , QuickCheck
60+ , quickcheck-instances
61+ default-language: Haskell2010
62+
servant-swagger/example/server/Main.hsnew file+11
@@ -0,0 +1,11 @@
1+module Main where
2+
3+import Network.Wai.Handler.Warp
4+import Servant
5+import Todo
6+
7+main :: IO ()
8+main = do
9+ putStrLn "Running on port 8000"
10+ run 8000 $ serve (Proxy :: Proxy API) server
11+
servant-swagger/example/src/Todo.hsnew file+73
@@ -0,0 +1,73 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE DeriveDataTypeable #-}
3+{-# LANGUAGE DeriveGeneric #-}
4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5+{-# LANGUAGE OverloadedStrings #-}
6+{-# LANGUAGE TypeOperators #-}
7+module Todo where
8+
9+import Control.Lens
10+import Data.Aeson
11+import Data.Aeson.Encode.Pretty (encodePretty)
12+import qualified Data.ByteString.Lazy.Char8 as BL8
13+import Data.Proxy
14+import Data.Swagger
15+import Data.Text (Text)
16+import Data.Time (UTCTime (..), fromGregorian)
17+import Data.Typeable (Typeable)
18+import GHC.Generics
19+import Servant
20+import Servant.Swagger
21+
22+todoAPI :: Proxy TodoAPI
23+todoAPI = Proxy
24+
25+-- | The API of a Todo service.
26+type TodoAPI
27+ = "todo" :> Get '[JSON] [Todo]
28+ :<|> "todo" :> ReqBody '[JSON] Todo :> Post '[JSON] TodoId
29+ :<|> "todo" :> Capture "id" TodoId :> Get '[JSON] Todo
30+ :<|> "todo" :> Capture "id" TodoId :> ReqBody '[JSON] Todo :> Put '[JSON] TodoId
31+
32+-- | API for serving @swagger.json@.
33+type SwaggerAPI = "swagger.json" :> Get '[JSON] Swagger
34+
35+-- | Combined API of a Todo service with Swagger documentation.
36+type API = SwaggerAPI :<|> TodoAPI
37+
38+-- | A single Todo entry.
39+data Todo = Todo
40+ { created :: UTCTime -- ^ Creation datetime.
41+ , summary :: Text -- ^ Task summary.
42+ } deriving (Show, Generic, Typeable)
43+
44+-- | A unique Todo entry ID.
45+newtype TodoId = TodoId Int
46+ deriving (Show, Generic, Typeable, ToJSON, FromHttpApiData)
47+
48+instance ToJSON Todo
49+instance FromJSON Todo
50+
51+instance ToSchema Todo where
52+ declareNamedSchema proxy = genericDeclareNamedSchema defaultSchemaOptions proxy
53+ & mapped.schema.description ?~ "This is some real Todo right here"
54+ & mapped.schema.example ?~ toJSON (Todo (UTCTime (fromGregorian 2015 12 31) 0) "get milk")
55+
56+instance ToParamSchema TodoId
57+instance ToSchema TodoId
58+
59+-- | Swagger spec for Todo API.
60+todoSwagger :: Swagger
61+todoSwagger = toSwagger todoAPI
62+ & info.title .~ "Todo API"
63+ & info.version .~ "1.0"
64+ & info.description ?~ "This is an API that tests swagger integration"
65+ & info.license ?~ ("MIT" & url ?~ URL "http://mit.com")
66+
67+-- | Combined server of a Todo service with Swagger documentation.
68+server :: Server API
69+server = return todoSwagger :<|> error "not implemented"
70+
71+-- | Output generated @swagger.json@ file for the @'TodoAPI'@.
72+writeSwaggerJSON :: IO ()
73+writeSwaggerJSON = BL8.writeFile "example/swagger.json" (encodePretty todoSwagger)
servant-swagger/example/swagger.jsonnew file+158
@@ -0,0 +1,158 @@
1+{
2+ "swagger": "2.0",
3+ "info": {
4+ "version": "1.0",
5+ "title": "Todo API",
6+ "license": {
7+ "url": "http://mit.com",
8+ "name": "MIT"
9+ },
10+ "description": "This is an API that tests swagger integration"
11+ },
12+ "definitions": {
13+ "Todo": {
14+ "example": {
15+ "summary": "get milk",
16+ "created": "2015-12-31T00:00:00Z"
17+ },
18+ "required": [
19+ "created",
20+ "summary"
21+ ],
22+ "type": "object",
23+ "description": "This is some real Todo right here",
24+ "properties": {
25+ "summary": {
26+ "type": "string"
27+ },
28+ "created": {
29+ "$ref": "#/definitions/UTCTime"
30+ }
31+ }
32+ },
33+ "UTCTime": {
34+ "example": "2016-07-22T00:00:00Z",
35+ "format": "yyyy-mm-ddThh:MM:ssZ",
36+ "type": "string"
37+ },
38+ "TodoId": {
39+ "maximum": 9223372036854775807,
40+ "minimum": -9223372036854775808,
41+ "type": "integer"
42+ }
43+ },
44+ "paths": {
45+ "/todo/{id}": {
46+ "get": {
47+ "responses": {
48+ "400": {
49+ "description": "Invalid `id`"
50+ },
51+ "200": {
52+ "schema": {
53+ "$ref": "#/definitions/Todo"
54+ },
55+ "description": ""
56+ }
57+ },
58+ "produces": [
59+ "application/json;charset=utf-8"
60+ ],
61+ "parameters": [
62+ {
63+ "maximum": 9223372036854775807,
64+ "minimum": -9223372036854775808,
65+ "required": true,
66+ "in": "path",
67+ "name": "id",
68+ "type": "integer"
69+ }
70+ ]
71+ },
72+ "put": {
73+ "consumes": [
74+ "application/json;charset=utf-8"
75+ ],
76+ "responses": {
77+ "400": {
78+ "description": "Invalid `body` or `id`"
79+ },
80+ "200": {
81+ "schema": {
82+ "$ref": "#/definitions/TodoId"
83+ },
84+ "description": ""
85+ }
86+ },
87+ "produces": [
88+ "application/json;charset=utf-8"
89+ ],
90+ "parameters": [
91+ {
92+ "maximum": 9223372036854775807,
93+ "minimum": -9223372036854775808,
94+ "required": true,
95+ "in": "path",
96+ "name": "id",
97+ "type": "integer"
98+ },
99+ {
100+ "required": true,
101+ "schema": {
102+ "$ref": "#/definitions/Todo"
103+ },
104+ "in": "body",
105+ "name": "body"
106+ }
107+ ]
108+ }
109+ },
110+ "/todo": {
111+ "post": {
112+ "consumes": [
113+ "application/json;charset=utf-8"
114+ ],
115+ "responses": {
116+ "400": {
117+ "description": "Invalid `body`"
118+ },
119+ "200": {
120+ "schema": {
121+ "$ref": "#/definitions/TodoId"
122+ },
123+ "description": ""
124+ }
125+ },
126+ "produces": [
127+ "application/json;charset=utf-8"
128+ ],
129+ "parameters": [
130+ {
131+ "required": true,
132+ "schema": {
133+ "$ref": "#/definitions/Todo"
134+ },
135+ "in": "body",
136+ "name": "body"
137+ }
138+ ]
139+ },
140+ "get": {
141+ "responses": {
142+ "200": {
143+ "schema": {
144+ "items": {
145+ "$ref": "#/definitions/Todo"
146+ },
147+ "type": "array"
148+ },
149+ "description": ""
150+ }
151+ },
152+ "produces": [
153+ "application/json;charset=utf-8"
154+ ]
155+ }
156+ }
157+ }
158+}
servant-swagger/example/test/Spec.hsnew file+1
@@ -0,0 +1 @@
1+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
servant-swagger/example/test/TodoSpec.hsnew file+28
@@ -0,0 +1,28 @@
1+{-# OPTIONS_GHC -fno-warn-orphans #-}
2+module TodoSpec where
3+
4+import Prelude ()
5+import Prelude.Compat
6+
7+import Data.Aeson
8+import qualified Data.ByteString.Lazy.Char8 as BL8
9+import Paths_example
10+import Servant.Swagger.Test
11+import Test.Hspec
12+import Test.QuickCheck
13+import Test.QuickCheck.Instances ()
14+import Todo
15+
16+spec :: Spec
17+spec = describe "Swagger" $ do
18+ context "ToJSON matches ToSchema" $ validateEveryToJSON todoAPI
19+ it "swagger.json is up-to-date" $ do
20+ path <- getDataFileName "swagger.json"
21+ swag <- eitherDecode <$> BL8.readFile path
22+ swag `shouldBe` Right todoSwagger
23+
24+instance Arbitrary Todo where
25+ arbitrary = Todo <$> arbitrary <*> arbitrary
26+
27+instance Arbitrary TodoId where
28+ arbitrary = TodoId <$> arbitrary
servant-swagger/servant-swagger.cabalnew file+127
@@ -0,0 +1,127 @@
1+cabal-version: 2.2
2+name: servant-swagger
3+version: 1.1.11
4+synopsis: Generate a Swagger/OpenAPI/OAS 2.0 specification for your servant API.
5+description:
6+ Swagger is a project used to describe and document RESTful APIs. The core of the
7+ project is the [OpenAPI Specification (OAS)](https://swagger.io/docs/specification/about/).
8+ This library implements v2.0 of the spec. Unlike Servant it is language-agnostic and thus is
9+ quite popular among developers in different languages. It has also existed for a longer time
10+ and has more helpful tooling.
11+ .
12+ This package provides means to generate a Swagger/OAS specification for a Servant API
13+ and also to partially test whether an API conforms with its specification.
14+ .
15+ Generated Swagger specification then can be used for many things such as
16+ .
17+ * displaying interactive documentation using [Swagger UI](http://swagger.io/swagger-ui/);
18+ .
19+ * generating clients and servers in many languages using [Swagger Codegen](http://swagger.io/swagger-codegen/);
20+ .
21+ * and [many others](http://swagger.io/open-source-integrations/).
22+homepage: https://github.com/haskell-servant/servant/tree/master/servant-swagger#readme
23+bug-reports: https://github.com/haskell-servant/servant/issues
24+license: BSD-3-Clause
25+license-file: LICENSE
26+author: Servant Contributors
27+maintainer: haskell-servant-maintainers@googlegroups.com
28+copyright: (c) 2015-2018, Servant contributors
29+category: Web, Servant, Swagger
30+build-type: Custom
31+tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2
32+
33+extra-source-files:
34+ README.md
35+ , CHANGELOG.md
36+ , example/server/*.hs
37+ , example/src/*.hs
38+ , example/test/*.hs
39+ , example/*.cabal
40+ , example/swagger.json
41+ , example/LICENSE
42+extra-doc-files:
43+ example/src/*.hs
44+ , example/test/*.hs
45+
46+source-repository head
47+ type: git
48+ location: https://github.com/haskell-servant/servant.git
49+
50+custom-setup
51+ setup-depends:
52+ base >=4.9 && <5,
53+ Cabal >= 1.24,
54+ cabal-doctest >=1.0.6 && <1.1
55+
56+library
57+ ghc-options: -Wall
58+ exposed-modules:
59+ Servant.Swagger
60+ Servant.Swagger.Test
61+ Servant.Swagger.TypeLevel
62+
63+ -- Internal modules
64+ Servant.Swagger.Internal
65+ Servant.Swagger.Internal.Orphans
66+ Servant.Swagger.Internal.Test
67+ Servant.Swagger.Internal.TypeLevel
68+ Servant.Swagger.Internal.TypeLevel.API
69+ Servant.Swagger.Internal.TypeLevel.Every
70+ Servant.Swagger.Internal.TypeLevel.TMap
71+ hs-source-dirs: src
72+ build-depends: aeson >=1.4.2.0 && <3
73+ , aeson-pretty >=0.8.7 && <0.9
74+ , base >=4.9.1.0 && <5
75+ , base-compat >=0.10.5 && <0.13
76+ , bytestring >=0.10.8.1 && <0.12
77+ , http-media >=0.7.1.3 && <0.9
78+ , insert-ordered-containers >=0.2.1.0 && <0.3
79+ , lens >=4.17 && <6
80+ , servant >=0.18.2 && <0.20
81+ , singleton-bool >=0.1.4 && <0.2
82+ , swagger2 >=2.3.0.1 && <3
83+ , text >=1.2.3.0 && <2.1
84+ , unordered-containers >=0.2.9.0 && <0.3
85+
86+ , hspec
87+ , QuickCheck
88+ default-language: Haskell2010
89+
90+test-suite doctests
91+ ghc-options: -Wall
92+ build-depends:
93+ base,
94+ directory >= 1.0,
95+ doctest >= 0.17 && <0.21,
96+ servant,
97+ QuickCheck,
98+ filepath
99+ default-language: Haskell2010
100+ hs-source-dirs: test
101+ main-is: doctests.hs
102+ type: exitcode-stdio-1.0
103+
104+test-suite spec
105+ ghc-options: -Wall
106+ type: exitcode-stdio-1.0
107+ hs-source-dirs: test
108+ main-is: Spec.hs
109+ build-tool-depends: hspec-discover:hspec-discover >=2.6.0 && <2.10
110+ build-depends: base
111+ , base-compat
112+ , aeson >=1.4.2.0 && <3
113+ , hspec >=2.6.0 && <2.10
114+ , QuickCheck
115+ , lens
116+ , lens-aeson >=1.0.2 && <1.3
117+ , servant
118+ , servant-swagger
119+ , swagger2
120+ , text
121+ , template-haskell
122+ , utf8-string >=1.0.1.1 && <1.1
123+ , time
124+ , vector
125+ other-modules:
126+ Servant.SwaggerSpec
127+ default-language: Haskell2010
servant-swagger/src/Servant/Swagger.hsnew file+188
@@ -0,0 +1,188 @@
1+-- |
2+-- Module: Servant.Swagger
3+-- License: BSD3
4+-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
5+-- Stability: experimental
6+--
7+-- This module provides means to generate and manipulate
8+-- Swagger specification for servant APIs.
9+--
10+-- Swagger is a project used to describe and document RESTful APIs.
11+--
12+-- The Swagger specification defines a set of files required to describe such an API.
13+-- These files can then be used by the Swagger-UI project to display the API
14+-- and Swagger-Codegen to generate clients in various languages.
15+-- Additional utilities can also take advantage of the resulting files, such as testing tools.
16+--
17+-- For more information see <http://swagger.io/ Swagger documentation>.
18+module Servant.Swagger (
19+ -- * How to use this library
20+ -- $howto
21+
22+ -- ** Generate @'Swagger'@
23+ -- $generate
24+
25+ -- ** Annotate
26+ -- $annotate
27+
28+ -- ** Test
29+ -- $test
30+
31+ -- ** Serve
32+ -- $serve
33+
34+ -- * @'HasSwagger'@ class
35+ HasSwagger(..),
36+
37+ -- * Manipulation
38+ subOperations,
39+
40+ -- * Testing
41+ validateEveryToJSON,
42+ validateEveryToJSONWithPatternChecker,
43+) where
44+
45+import Servant.Swagger.Internal
46+import Servant.Swagger.Test
47+import Servant.Swagger.Internal.Orphans ()
48+
49+-- $setup
50+-- >>> import Control.Applicative
51+-- >>> import Control.Lens
52+-- >>> import Data.Aeson
53+-- >>> import Data.Aeson.Encode.Pretty
54+-- >>> import Data.Swagger
55+-- >>> import Data.Typeable
56+-- >>> import GHC.Generics
57+-- >>> import Servant.API
58+-- >>> import System.Environment
59+-- >>> import Test.Hspec
60+-- >>> import Test.QuickCheck
61+-- >>> import qualified Data.ByteString.Lazy.Char8 as BSL8
62+-- >>> :set -XDataKinds
63+-- >>> :set -XDeriveDataTypeable
64+-- >>> :set -XDeriveGeneric
65+-- >>> :set -XGeneralizedNewtypeDeriving
66+-- >>> :set -XOverloadedStrings
67+-- >>> :set -XTypeOperators
68+-- >>> setEnv "HSPEC_COLOR" "no"
69+-- >>> data User = User { name :: String, age :: Int } deriving (Show, Generic, Typeable)
70+-- >>> newtype UserId = UserId Integer deriving (Show, Generic, Typeable, ToJSON)
71+-- >>> instance ToJSON User
72+-- >>> instance ToSchema User
73+-- >>> instance ToSchema UserId
74+-- >>> instance ToParamSchema UserId
75+-- >>> type GetUsers = Get '[JSON] [User]
76+-- >>> type GetUser = Capture "user_id" UserId :> Get '[JSON] User
77+-- >>> type PostUser = ReqBody '[JSON] User :> Post '[JSON] UserId
78+-- >>> type UserAPI = GetUsers :<|> GetUser :<|> PostUser
79+-- >>> orderedKeys = encodePretty' (defConfig { confCompare = compare, confIndent = Spaces 0 })
80+
81+-- $howto
82+--
83+-- This section explains how to use this library to generate Swagger specification,
84+-- modify it and run automatic tests for a servant API.
85+--
86+-- For the purposes of this section we will use this servant API:
87+--
88+-- >>> data User = User { name :: String, age :: Int } deriving (Show, Generic, Typeable)
89+-- >>> newtype UserId = UserId Integer deriving (Show, Generic, Typeable, ToJSON)
90+-- >>> instance ToJSON User
91+-- >>> instance ToSchema User
92+-- >>> instance ToSchema UserId
93+-- >>> instance ToParamSchema UserId
94+-- >>> type GetUsers = Get '[JSON] [User]
95+-- >>> type GetUser = Capture "user_id" UserId :> Get '[JSON] User
96+-- >>> type PostUser = ReqBody '[JSON] User :> Post '[JSON] UserId
97+-- >>> type UserAPI = GetUsers :<|> GetUser :<|> PostUser
98+--
99+-- Here we define a user API with three endpoints. @GetUsers@ endpoint returns a list of all users.
100+-- @GetUser@ returns a user given his\/her ID. @PostUser@ creates a new user and returns his\/her ID.
101+
102+-- $generate
103+-- In order to generate @'Swagger'@ specification for a servant API, just use @'toSwagger'@:
104+--
105+-- >>> BSL8.putStrLn . orderedKeys $ toSwagger (Proxy :: Proxy UserAPI)
106+-- {"definitions":{"User":{"properties":{"age":{"maximum":9223372036854775807,"minimum":-9223372036854775808,"type":"integer"},"name":{"type":"string"}},"required":["name","age"],"type":"object"},"UserId":{"type":"integer"}},"info":{"title":"","version":""},"paths":{"/":{"get":{"produces":["application/json;charset=utf-8"],"responses":{"200":{"description":"","schema":{"items":{"$ref":"#/definitions/User"},"type":"array"}}}},"post":{"consumes":["application/json;charset=utf-8"],"parameters":[{"in":"body","name":"body","required":true,"schema":{"$ref":"#/definitions/User"}}],"produces":["application/json;charset=utf-8"],"responses":{"200":{"description":"","schema":{"$ref":"#/definitions/UserId"}},"400":{"description":"Invalid `body`"}}}},"/{user_id}":{"get":{"parameters":[{"in":"path","name":"user_id","required":true,"type":"integer"}],"produces":["application/json;charset=utf-8"],"responses":{"200":{"description":"","schema":{"$ref":"#/definitions/User"}},"400":{"description":"Invalid `user_id`"}}}}},"swagger":"2.0"}
107+--
108+-- By default @'toSwagger'@ will generate specification for all API routes, parameters, headers, responses and data schemas.
109+--
110+-- For some parameters it will also add 400 responses with a description mentioning parameter name.
111+--
112+-- Data schemas come from @'ToParamSchema'@ and @'ToSchema'@ classes.
113+
114+-- $annotate
115+-- While initially generated @'Swagger'@ looks good, it lacks some information it can't get from a servant API.
116+--
117+-- We can add this information using field lenses from @"Data.Swagger"@:
118+--
119+-- >>> :{
120+-- BSL8.putStrLn $ orderedKeys $ toSwagger (Proxy :: Proxy UserAPI)
121+-- & info.title .~ "User API"
122+-- & info.version .~ "1.0"
123+-- & info.description ?~ "This is an API for the Users service"
124+-- & info.license ?~ "MIT"
125+-- & host ?~ "example.com"
126+-- :}
127+-- {"definitions":{"User":{"properties":{"age":{"maximum":9223372036854775807,"minimum":-9223372036854775808,"type":"integer"},"name":{"type":"string"}},"required":["name","age"],"type":"object"},"UserId":{"type":"integer"}},"host":"example.com","info":{"description":"This is an API for the Users service","license":{"name":"MIT"},"title":"User API","version":"1.0"},"paths":{"/":{"get":{"produces":["application/json;charset=utf-8"],"responses":{"200":{"description":"","schema":{"items":{"$ref":"#/definitions/User"},"type":"array"}}}},"post":{"consumes":["application/json;charset=utf-8"],"parameters":[{"in":"body","name":"body","required":true,"schema":{"$ref":"#/definitions/User"}}],"produces":["application/json;charset=utf-8"],"responses":{"200":{"description":"","schema":{"$ref":"#/definitions/UserId"}},"400":{"description":"Invalid `body`"}}}},"/{user_id}":{"get":{"parameters":[{"in":"path","name":"user_id","required":true,"type":"integer"}],"produces":["application/json;charset=utf-8"],"responses":{"200":{"description":"","schema":{"$ref":"#/definitions/User"}},"400":{"description":"Invalid `user_id`"}}}}},"swagger":"2.0"}
128+--
129+-- It is also useful to annotate or modify certain endpoints.
130+-- @'subOperations'@ provides a convenient way to zoom into a part of an API.
131+--
132+-- @'subOperations' sub api@ traverses all operations of the @api@ which are also present in @sub@.
133+-- Furthermore, @sub@ is required to be an exact sub API of @api. Otherwise it will not typecheck.
134+--
135+-- @"Data.Swagger.Operation"@ provides some useful helpers that can be used with @'subOperations'@.
136+-- One example is applying tags to certain endpoints:
137+--
138+-- >>> let getOps = subOperations (Proxy :: Proxy (GetUsers :<|> GetUser)) (Proxy :: Proxy UserAPI)
139+-- >>> let postOps = subOperations (Proxy :: Proxy PostUser) (Proxy :: Proxy UserAPI)
140+-- >>> :{
141+-- BSL8.putStrLn $ orderedKeys $ toSwagger (Proxy :: Proxy UserAPI)
142+-- & applyTagsFor getOps ["get" & description ?~ "GET operations"]
143+-- & applyTagsFor postOps ["post" & description ?~ "POST operations"]
144+-- :}
145+-- {"definitions":{"User":{"properties":{"age":{"maximum":9223372036854775807,"minimum":-9223372036854775808,"type":"integer"},"name":{"type":"string"}},"required":["name","age"],"type":"object"},"UserId":{"type":"integer"}},"info":{"title":"","version":""},"paths":{"/":{"get":{"produces":["application/json;charset=utf-8"],"responses":{"200":{"description":"","schema":{"items":{"$ref":"#/definitions/User"},"type":"array"}}},"tags":["get"]},"post":{"consumes":["application/json;charset=utf-8"],"parameters":[{"in":"body","name":"body","required":true,"schema":{"$ref":"#/definitions/User"}}],"produces":["application/json;charset=utf-8"],"responses":{"200":{"description":"","schema":{"$ref":"#/definitions/UserId"}},"400":{"description":"Invalid `body`"}},"tags":["post"]}},"/{user_id}":{"get":{"parameters":[{"in":"path","name":"user_id","required":true,"type":"integer"}],"produces":["application/json;charset=utf-8"],"responses":{"200":{"description":"","schema":{"$ref":"#/definitions/User"}},"400":{"description":"Invalid `user_id`"}},"tags":["get"]}}},"swagger":"2.0","tags":[{"description":"GET operations","name":"get"},{"description":"POST operations","name":"post"}]}
146+--
147+-- This applies @\"get\"@ tag to the @GET@ endpoints and @\"post\"@ tag to the @POST@ endpoint of the User API.
148+
149+-- $test
150+-- Automatic generation of data schemas uses @'ToSchema'@ instances for the types
151+-- used in a servant API. But to encode/decode actual data servant uses different classes.
152+-- For instance in @UserAPI@ @User@ is always encoded/decoded using @'ToJSON'@ and @'FromJSON'@ instances.
153+--
154+-- To be sure your Haskell server/client handles data properly you need to check
155+-- that @'ToJSON'@ instance always generates values that satisfy schema produced
156+-- by @'ToSchema'@ instance.
157+--
158+-- With @'validateEveryToJSON'@ it is possible to test all those instances automatically,
159+-- without having to write down every type:
160+--
161+-- >>> instance Arbitrary User where arbitrary = User <$> arbitrary <*> arbitrary
162+-- >>> instance Arbitrary UserId where arbitrary = UserId <$> arbitrary
163+-- >>> hspec $ validateEveryToJSON (Proxy :: Proxy UserAPI)
164+-- <BLANKLINE>
165+-- [User]...
166+-- ...
167+-- User...
168+-- ...
169+-- UserId...
170+-- ...
171+-- Finished in ... seconds
172+-- 3 examples, 0 failures
173+--
174+-- Although servant is great, chances are that your API clients don't use Haskell.
175+-- In many cases @swagger.json@ serves as a specification, not a Haskell type.
176+--
177+-- In this cases it is a good idea to store generated and annotated @'Swagger'@ in a @swagger.json@ file
178+-- under a version control system (such as Git, Subversion, Mercurial, etc.).
179+--
180+-- It is also recommended to version API based on changes to the @swagger.json@ rather than changes
181+-- to the Haskell API.
182+--
183+-- See <example/test/TodoSpec.hs TodoSpec.hs> for an example of a complete test suite for a swagger specification.
184+
185+-- $serve
186+-- If you're implementing a server for an API, you might also want to serve its @'Swagger'@ specification.
187+--
188+-- See <example/src/Todo.hs Todo.hs> for an example of a server.
servant-swagger/src/Servant/Swagger/Internal.hsnew file+488
@@ -0,0 +1,488 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE ConstraintKinds #-}
3+{-# LANGUAGE DataKinds #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE OverloadedLists #-}
7+{-# LANGUAGE OverloadedStrings #-}
8+{-# LANGUAGE PolyKinds #-}
9+{-# LANGUAGE RankNTypes #-}
10+{-# LANGUAGE ScopedTypeVariables #-}
11+{-# LANGUAGE TypeOperators #-}
12+{-# LANGUAGE TypeFamilies #-}
13+#if __GLASGOW_HASKELL__ >= 806
14+{-# LANGUAGE UndecidableInstances #-}
15+#endif
16+module Servant.Swagger.Internal where
17+
18+import Prelude ()
19+import Prelude.Compat
20+
21+import Control.Applicative ((<|>))
22+import Control.Lens
23+import Data.Aeson
24+import Data.HashMap.Strict.InsOrd (InsOrdHashMap)
25+import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
26+import Data.Foldable (toList)
27+import Data.Proxy
28+import Data.Typeable
29+import Data.Singletons.Bool
30+import Data.Swagger hiding (Header)
31+import qualified Data.Swagger as Swagger
32+import Data.Swagger.Declare
33+import Data.Text (Text)
34+import qualified Data.Text as Text
35+import GHC.Generics (D1, Meta(..), Rep)
36+import GHC.TypeLits
37+import Network.HTTP.Media (MediaType)
38+import Servant.API
39+import Servant.API.Description (FoldDescription,
40+ reflectDescription)
41+import Servant.API.Generic (ToServantApi, AsApi)
42+import Servant.API.Modifiers (FoldRequired)
43+
44+import Servant.Swagger.Internal.TypeLevel.API
45+
46+-- | Generate a Swagger specification for a servant API.
47+--
48+-- To generate Swagger specification, your data types need
49+-- @'ToParamSchema'@ and/or @'ToSchema'@ instances.
50+--
51+-- @'ToParamSchema'@ is used for @'Capture'@, @'QueryParam'@ and @'Header'@.
52+-- @'ToSchema'@ is used for @'ReqBody'@ and response data types.
53+--
54+-- You can easily derive those instances via @Generic@.
55+-- For more information, refer to <http://hackage.haskell.org/package/swagger2/docs/Data-Swagger.html swagger2 documentation>.
56+--
57+-- Example:
58+--
59+-- @
60+-- newtype Username = Username String deriving (Generic, ToText)
61+--
62+-- instance ToParamSchema Username
63+--
64+-- data User = User
65+-- { username :: Username
66+-- , fullname :: String
67+-- } deriving (Generic)
68+--
69+-- instance ToJSON User
70+-- instance ToSchema User
71+--
72+-- type MyAPI = QueryParam "username" Username :> Get '[JSON] User
73+--
74+-- mySwagger :: Swagger
75+-- mySwagger = toSwagger (Proxy :: Proxy MyAPI)
76+-- @
77+class HasSwagger api where
78+ -- | Generate a Swagger specification for a servant API.
79+ toSwagger :: Proxy api -> Swagger
80+
81+instance HasSwagger Raw where
82+ toSwagger _ = mempty & paths . at "/" ?~ mempty
83+
84+instance HasSwagger EmptyAPI where
85+ toSwagger _ = mempty
86+
87+-- | All operations of sub API.
88+-- This is similar to @'operationsOf'@ but ensures that operations
89+-- indeed belong to the API at compile time.
90+subOperations :: (IsSubAPI sub api, HasSwagger sub) =>
91+ Proxy sub -- ^ Part of a servant API.
92+ -> Proxy api -- ^ The whole servant API.
93+ -> Traversal' Swagger Operation
94+subOperations sub _ = operationsOf (toSwagger sub)
95+
96+-- | Make a singleton Swagger spec (with only one endpoint).
97+-- For endpoints with no content see 'mkEndpointNoContent'.
98+mkEndpoint :: forall a cs hs proxy method status.
99+ (ToSchema a, AllAccept cs, AllToResponseHeader hs, SwaggerMethod method, KnownNat status)
100+ => FilePath -- ^ Endpoint path.
101+ -> proxy (Verb method status cs (Headers hs a)) -- ^ Method, content-types, headers and response.
102+ -> Swagger
103+mkEndpoint path proxy
104+ = mkEndpointWithSchemaRef (Just ref) path proxy
105+ & definitions .~ defs
106+ where
107+ (defs, ref) = runDeclare (declareSchemaRef (Proxy :: Proxy a)) mempty
108+
109+-- | Make a singletone 'Swagger' spec (with only one endpoint) and with no content schema.
110+mkEndpointNoContent :: forall nocontent cs hs proxy method status.
111+ (AllAccept cs, AllToResponseHeader hs, SwaggerMethod method, KnownNat status)
112+ => FilePath -- ^ Endpoint path.
113+ -> proxy (Verb method status cs (Headers hs nocontent)) -- ^ Method, content-types, headers and response.
114+ -> Swagger
115+mkEndpointNoContent path proxy
116+ = mkEndpointWithSchemaRef Nothing path proxy
117+
118+-- | Like @'mkEndpoint'@ but with explicit schema reference.
119+-- Unlike @'mkEndpoint'@ this function does not update @'definitions'@.
120+mkEndpointWithSchemaRef :: forall cs hs proxy method status a.
121+ (AllAccept cs, AllToResponseHeader hs, SwaggerMethod method, KnownNat status)
122+ => Maybe (Referenced Schema)
123+ -> FilePath
124+ -> proxy (Verb method status cs (Headers hs a))
125+ -> Swagger
126+mkEndpointWithSchemaRef mref path _ = mempty
127+ & paths.at path ?~
128+ (mempty & method ?~ (mempty
129+ & produces ?~ MimeList responseContentTypes
130+ & at code ?~ Inline (mempty
131+ & schema .~ mref
132+ & headers .~ responseHeaders)))
133+ where
134+ method = swaggerMethod (Proxy :: Proxy method)
135+ code = fromIntegral (natVal (Proxy :: Proxy status))
136+ responseContentTypes = allContentType (Proxy :: Proxy cs)
137+ responseHeaders = toAllResponseHeaders (Proxy :: Proxy hs)
138+
139+mkEndpointNoContentVerb :: forall proxy method.
140+ (SwaggerMethod method)
141+ => FilePath -- ^ Endpoint path.
142+ -> proxy (NoContentVerb method) -- ^ Method
143+ -> Swagger
144+mkEndpointNoContentVerb path _ = mempty
145+ & paths.at path ?~
146+ (mempty & method ?~ (mempty
147+ & at code ?~ Inline mempty))
148+ where
149+ method = swaggerMethod (Proxy :: Proxy method)
150+ code = 204 -- hardcoded in servant-server
151+
152+-- | Add parameter to every operation in the spec.
153+addParam :: Param -> Swagger -> Swagger
154+addParam param = allOperations.parameters %~ (Inline param :)
155+
156+-- | Add a tag to every operation in the spec.
157+addTag :: Text -> Swagger -> Swagger
158+addTag tag = allOperations.tags %~ ([tag] <>)
159+
160+-- | Add accepted content types to every operation in the spec.
161+addConsumes :: [MediaType] -> Swagger -> Swagger
162+addConsumes cs = allOperations.consumes %~ (<> Just (MimeList cs))
163+
164+-- | Format given text as inline code in Markdown.
165+markdownCode :: Text -> Text
166+markdownCode s = "`" <> s <> "`"
167+
168+addDefaultResponse400 :: ParamName -> Swagger -> Swagger
169+addDefaultResponse400 pname = setResponseWith (\old _new -> alter400 old) 400 (return response400)
170+ where
171+ sname = markdownCode pname
172+ description400 = "Invalid " <> sname
173+ alter400 = description %~ (<> (" or " <> sname))
174+ response400 = mempty & description .~ description400
175+
176+-- | Methods, available for Swagger.
177+class SwaggerMethod method where
178+ swaggerMethod :: proxy method -> Lens' PathItem (Maybe Operation)
179+
180+instance SwaggerMethod 'GET where swaggerMethod _ = get
181+instance SwaggerMethod 'PUT where swaggerMethod _ = put
182+instance SwaggerMethod 'POST where swaggerMethod _ = post
183+instance SwaggerMethod 'DELETE where swaggerMethod _ = delete
184+instance SwaggerMethod 'OPTIONS where swaggerMethod _ = options
185+instance SwaggerMethod 'HEAD where swaggerMethod _ = head_
186+instance SwaggerMethod 'PATCH where swaggerMethod _ = patch
187+
188+instance HasSwagger (UVerb method cs '[]) where
189+ toSwagger _ = mempty
190+
191+-- | @since <TODO>
192+instance
193+ {-# OVERLAPPABLE #-}
194+ ( ToSchema a,
195+ HasStatus a,
196+ AllAccept cs,
197+ SwaggerMethod method,
198+ HasSwagger (UVerb method cs as)
199+ ) =>
200+ HasSwagger (UVerb method cs (a ': as))
201+ where
202+ toSwagger _ =
203+ toSwagger (Proxy :: Proxy (Verb method (StatusOf a) cs a))
204+ `combineSwagger` toSwagger (Proxy :: Proxy (UVerb method cs as))
205+
206+-- ATTENTION: do not remove this instance!
207+-- A similar instance above will always use the more general
208+-- polymorphic -- HasSwagger instance and will result in a type error
209+-- since 'NoContent' does not have a 'ToSchema' instance.
210+instance
211+ ( KnownNat status,
212+ AllAccept cs,
213+ SwaggerMethod method,
214+ HasSwagger (UVerb method cs as)
215+ ) =>
216+ HasSwagger (UVerb method cs (WithStatus status NoContent ': as))
217+ where
218+ toSwagger _ =
219+ toSwagger (Proxy :: Proxy (Verb method status cs NoContent))
220+ `combineSwagger` toSwagger (Proxy :: Proxy (UVerb method cs as))
221+
222+
223+-- workaround for https://github.com/GetShopTV/swagger2/issues/218
224+-- We'd like to juse use (<>) but the instances are wrong
225+combinePathItem :: PathItem -> PathItem -> PathItem
226+combinePathItem s t = PathItem
227+ { _pathItemGet = _pathItemGet s <> _pathItemGet t
228+ , _pathItemPut = _pathItemPut s <> _pathItemPut t
229+ , _pathItemPost = _pathItemPost s <> _pathItemPost t
230+ , _pathItemDelete = _pathItemDelete s <> _pathItemDelete t
231+ , _pathItemOptions = _pathItemOptions s <> _pathItemOptions t
232+ , _pathItemHead = _pathItemHead s <> _pathItemHead t
233+ , _pathItemPatch = _pathItemPatch s <> _pathItemPatch t
234+ , _pathItemParameters = _pathItemParameters s <> _pathItemParameters t
235+ }
236+
237+combineSwagger :: Swagger -> Swagger -> Swagger
238+combineSwagger s t = Swagger
239+ { _swaggerInfo = _swaggerInfo s <> _swaggerInfo t
240+ , _swaggerHost = _swaggerHost s <|> _swaggerHost t
241+ , _swaggerBasePath = _swaggerBasePath s <|> _swaggerBasePath t
242+ , _swaggerSchemes = _swaggerSchemes s <> _swaggerSchemes t
243+ , _swaggerConsumes = _swaggerConsumes s <> _swaggerConsumes t
244+ , _swaggerProduces = _swaggerProduces s <> _swaggerProduces t
245+ , _swaggerPaths = InsOrdHashMap.unionWith combinePathItem (_swaggerPaths s) (_swaggerPaths t)
246+ , _swaggerDefinitions = _swaggerDefinitions s <> _swaggerDefinitions t
247+ , _swaggerParameters = _swaggerParameters s <> _swaggerParameters t
248+ , _swaggerResponses = _swaggerResponses s <> _swaggerResponses t
249+ , _swaggerSecurityDefinitions = _swaggerSecurityDefinitions s <> _swaggerSecurityDefinitions t
250+ , _swaggerSecurity = _swaggerSecurity s <> _swaggerSecurity t
251+ , _swaggerTags = _swaggerTags s <> _swaggerTags t
252+ , _swaggerExternalDocs = _swaggerExternalDocs s <|> _swaggerExternalDocs t
253+ }
254+
255+instance {-# OVERLAPPABLE #-} (ToSchema a, AllAccept cs, KnownNat status, SwaggerMethod method) => HasSwagger (Verb method status cs a) where
256+ toSwagger _ = toSwagger (Proxy :: Proxy (Verb method status cs (Headers '[] a)))
257+
258+-- | @since 1.1.7
259+instance (ToSchema a, Accept ct, KnownNat status, SwaggerMethod method) => HasSwagger (Stream method status fr ct a) where
260+ toSwagger _ = toSwagger (Proxy :: Proxy (Verb method status '[ct] (Headers '[] a)))
261+
262+instance {-# OVERLAPPABLE #-} (ToSchema a, AllAccept cs, AllToResponseHeader hs, KnownNat status, SwaggerMethod method)
263+ => HasSwagger (Verb method status cs (Headers hs a)) where
264+ toSwagger = mkEndpoint "/"
265+
266+-- ATTENTION: do not remove this instance!
267+-- A similar instance above will always use the more general
268+-- polymorphic -- HasSwagger instance and will result in a type error
269+-- since 'NoContent' does not have a 'ToSchema' instance.
270+instance (AllAccept cs, KnownNat status, SwaggerMethod method) => HasSwagger (Verb method status cs NoContent) where
271+ toSwagger _ = toSwagger (Proxy :: Proxy (Verb method status cs (Headers '[] NoContent)))
272+
273+instance (AllAccept cs, AllToResponseHeader hs, KnownNat status, SwaggerMethod method)
274+ => HasSwagger (Verb method status cs (Headers hs NoContent)) where
275+ toSwagger = mkEndpointNoContent "/"
276+
277+instance (SwaggerMethod method) => HasSwagger (NoContentVerb method) where
278+ toSwagger = mkEndpointNoContentVerb "/"
279+
280+instance (HasSwagger a, HasSwagger b) => HasSwagger (a :<|> b) where
281+ toSwagger _ = toSwagger (Proxy :: Proxy a) <> toSwagger (Proxy :: Proxy b)
282+
283+-- | @'Vault'@ combinator does not change our specification at all.
284+instance (HasSwagger sub) => HasSwagger (Vault :> sub) where
285+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
286+
287+-- | @'IsSecure'@ combinator does not change our specification at all.
288+instance (HasSwagger sub) => HasSwagger (IsSecure :> sub) where
289+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
290+
291+-- | @'RemoteHost'@ combinator does not change our specification at all.
292+instance (HasSwagger sub) => HasSwagger (RemoteHost :> sub) where
293+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
294+
295+-- | @'Fragment'@ combinator does not change our specification at all.
296+instance HasSwagger sub => HasSwagger (Fragment a :> sub) where
297+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
298+
299+-- | @'HttpVersion'@ combinator does not change our specification at all.
300+instance (HasSwagger sub) => HasSwagger (HttpVersion :> sub) where
301+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
302+
303+-- | @'WithNamedContext'@ combinator does not change our specification at all.
304+instance (HasSwagger sub) => HasSwagger (WithNamedContext x c sub) where
305+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
306+
307+instance (KnownSymbol sym, HasSwagger sub) => HasSwagger (sym :> sub) where
308+ toSwagger _ = prependPath piece (toSwagger (Proxy :: Proxy sub))
309+ where
310+ piece = symbolVal (Proxy :: Proxy sym)
311+
312+instance (KnownSymbol sym, Typeable a, ToParamSchema a, HasSwagger sub, KnownSymbol (FoldDescription mods)) => HasSwagger (Capture' mods sym a :> sub) where
313+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
314+ & addParam param
315+ & prependPath capture
316+ & addDefaultResponse400 tname
317+ where
318+ symbol = symbolVal (Proxy :: Proxy sym)
319+ pname = if symbol == ""
320+ then camelTo2 '-' . tyConName . typeRepTyCon $ typeRep (Proxy :: Proxy a)
321+ else symbol
322+ tname = Text.pack pname
323+ transDesc "" = Nothing
324+ transDesc desc = Just (Text.pack desc)
325+ capture = "{" <> pname <> "}"
326+ param = mempty
327+ & name .~ tname
328+ & description .~ transDesc (reflectDescription (Proxy :: Proxy mods))
329+ & required ?~ True
330+ & schema .~ ParamOther (mempty
331+ & in_ .~ ParamPath
332+ & paramSchema .~ toParamSchema (Proxy :: Proxy a))
333+
334+-- | Swagger Spec doesn't have a notion of CaptureAll, this instance is the best effort.
335+instance (KnownSymbol sym, Typeable a, ToParamSchema a, HasSwagger sub) => HasSwagger (CaptureAll sym a :> sub) where
336+ toSwagger _ = toSwagger (Proxy :: Proxy (Capture sym a :> sub))
337+
338+instance (KnownSymbol desc, HasSwagger api) => HasSwagger (Description desc :> api) where
339+ toSwagger _ = toSwagger (Proxy :: Proxy api)
340+ & allOperations.description %~ (Just (Text.pack (symbolVal (Proxy :: Proxy desc))) <>)
341+
342+instance (KnownSymbol desc, HasSwagger api) => HasSwagger (Summary desc :> api) where
343+ toSwagger _ = toSwagger (Proxy :: Proxy api)
344+ & allOperations.summary %~ (Just (Text.pack (symbolVal (Proxy :: Proxy desc))) <>)
345+
346+instance (KnownSymbol sym, ToParamSchema a, HasSwagger sub, SBoolI (FoldRequired mods), KnownSymbol (FoldDescription mods)) => HasSwagger (QueryParam' mods sym a :> sub) where
347+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
348+ & addParam param
349+ & addDefaultResponse400 tname
350+ where
351+ tname = Text.pack (symbolVal (Proxy :: Proxy sym))
352+ transDesc "" = Nothing
353+ transDesc desc = Just (Text.pack desc)
354+ param = mempty
355+ & name .~ tname
356+ & description .~ transDesc (reflectDescription (Proxy :: Proxy mods))
357+ & required ?~ reflectBool (Proxy :: Proxy (FoldRequired mods))
358+ & schema .~ ParamOther sch
359+ sch = mempty
360+ & in_ .~ ParamQuery
361+ & paramSchema .~ toParamSchema (Proxy :: Proxy a)
362+
363+instance (KnownSymbol sym, ToParamSchema a, HasSwagger sub) => HasSwagger (QueryParams sym a :> sub) where
364+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
365+ & addParam param
366+ & addDefaultResponse400 tname
367+ where
368+ tname = Text.pack (symbolVal (Proxy :: Proxy sym))
369+ param = mempty
370+ & name .~ tname
371+ & schema .~ ParamOther sch
372+ sch = mempty
373+ & in_ .~ ParamQuery
374+ & paramSchema .~ pschema
375+ pschema = mempty
376+#if MIN_VERSION_swagger2(2,4,0)
377+ & type_ ?~ SwaggerArray
378+#else
379+ & type_ .~ SwaggerArray
380+#endif
381+ & items ?~ SwaggerItemsPrimitive (Just CollectionMulti) (toParamSchema (Proxy :: Proxy a))
382+
383+instance (KnownSymbol sym, HasSwagger sub) => HasSwagger (QueryFlag sym :> sub) where
384+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
385+ & addParam param
386+ & addDefaultResponse400 tname
387+ where
388+ tname = Text.pack (symbolVal (Proxy :: Proxy sym))
389+ param = mempty
390+ & name .~ tname
391+ & schema .~ ParamOther (mempty
392+ & in_ .~ ParamQuery
393+ & allowEmptyValue ?~ True
394+ & paramSchema .~ (toParamSchema (Proxy :: Proxy Bool)
395+ & default_ ?~ toJSON False))
396+
397+instance (KnownSymbol sym, ToParamSchema a, HasSwagger sub, SBoolI (FoldRequired mods), KnownSymbol (FoldDescription mods)) => HasSwagger (Header' mods sym a :> sub) where
398+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
399+ & addParam param
400+ & addDefaultResponse400 tname
401+ where
402+ tname = Text.pack (symbolVal (Proxy :: Proxy sym))
403+ transDesc "" = Nothing
404+ transDesc desc = Just (Text.pack desc)
405+ param = mempty
406+ & name .~ tname
407+ & description .~ transDesc (reflectDescription (Proxy :: Proxy mods))
408+ & required ?~ reflectBool (Proxy :: Proxy (FoldRequired mods))
409+ & schema .~ ParamOther (mempty
410+ & in_ .~ ParamHeader
411+ & paramSchema .~ toParamSchema (Proxy :: Proxy a))
412+
413+instance (ToSchema a, AllAccept cs, HasSwagger sub, KnownSymbol (FoldDescription mods)) => HasSwagger (ReqBody' mods cs a :> sub) where
414+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
415+ & addParam param
416+ & addConsumes (allContentType (Proxy :: Proxy cs))
417+ & addDefaultResponse400 tname
418+ & definitions %~ (<> defs)
419+ where
420+ tname = "body"
421+ transDesc "" = Nothing
422+ transDesc desc = Just (Text.pack desc)
423+ (defs, ref) = runDeclare (declareSchemaRef (Proxy :: Proxy a)) mempty
424+ param = mempty
425+ & name .~ tname
426+ & description .~ transDesc (reflectDescription (Proxy :: Proxy mods))
427+ & required ?~ True
428+ & schema .~ ParamBody ref
429+
430+-- | This instance is an approximation.
431+--
432+-- @since 1.1.7
433+instance (ToSchema a, Accept ct, HasSwagger sub, KnownSymbol (FoldDescription mods)) => HasSwagger (StreamBody' mods fr ct a :> sub) where
434+ toSwagger _ = toSwagger (Proxy :: Proxy sub)
435+ & addParam param
436+ & addConsumes (toList (contentTypes (Proxy :: Proxy ct)))
437+ & addDefaultResponse400 tname
438+ & definitions %~ (<> defs)
439+ where
440+ tname = "body"
441+ transDesc "" = Nothing
442+ transDesc desc = Just (Text.pack desc)
443+ (defs, ref) = runDeclare (declareSchemaRef (Proxy :: Proxy a)) mempty
444+ param = mempty
445+ & name .~ tname
446+ & description .~ transDesc (reflectDescription (Proxy :: Proxy mods))
447+ & required ?~ True
448+ & schema .~ ParamBody ref
449+
450+instance (HasSwagger (ToServantApi routes), KnownSymbol datatypeName, Rep (routes AsApi) ~ D1 ('MetaData datatypeName moduleName packageName isNewtype) f) => HasSwagger (NamedRoutes routes) where
451+ toSwagger _ = addTag (Text.pack $ symbolVal (Proxy :: Proxy datatypeName)) (toSwagger (Proxy :: Proxy (ToServantApi routes)))
452+
453+-- =======================================================================
454+-- Below are the definitions that should be in Servant.API.ContentTypes
455+-- =======================================================================
456+
457+class AllAccept cs where
458+ allContentType :: Proxy cs -> [MediaType]
459+
460+instance AllAccept '[] where
461+ allContentType _ = []
462+
463+instance (Accept c, AllAccept cs) => AllAccept (c ': cs) where
464+ allContentType _ = contentType (Proxy :: Proxy c) : allContentType (Proxy :: Proxy cs)
465+
466+class ToResponseHeader h where
467+ toResponseHeader :: Proxy h -> (HeaderName, Swagger.Header)
468+
469+instance (KnownSymbol sym, ToParamSchema a) => ToResponseHeader (Header sym a) where
470+ toResponseHeader _ = (hname, Swagger.Header Nothing hschema)
471+ where
472+ hname = Text.pack (symbolVal (Proxy :: Proxy sym))
473+ hschema = toParamSchema (Proxy :: Proxy a)
474+
475+class AllToResponseHeader hs where
476+ toAllResponseHeaders :: Proxy hs -> InsOrdHashMap HeaderName Swagger.Header
477+
478+instance AllToResponseHeader '[] where
479+ toAllResponseHeaders _ = mempty
480+
481+instance (ToResponseHeader h, AllToResponseHeader hs) => AllToResponseHeader (h ': hs) where
482+ toAllResponseHeaders _ = InsOrdHashMap.insert headerName headerBS hdrs
483+ where
484+ (headerName, headerBS) = toResponseHeader (Proxy :: Proxy h)
485+ hdrs = toAllResponseHeaders (Proxy :: Proxy hs)
486+
487+instance AllToResponseHeader hs => AllToResponseHeader (HList hs) where
488+ toAllResponseHeaders _ = toAllResponseHeaders (Proxy :: Proxy hs)
servant-swagger/src/Servant/Swagger/Internal/Orphans.hsnew file+27
@@ -0,0 +1,27 @@
1+{-# OPTIONS_GHC -fno-warn-orphans #-}
2+{-# LANGUAGE CPP #-}
3+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4+{-# LANGUAGE ScopedTypeVariables #-}
5+{-# LANGUAGE StandaloneDeriving #-}
6+module Servant.Swagger.Internal.Orphans where
7+
8+import Data.Proxy
9+ (Proxy (..))
10+import Data.Swagger
11+import Servant.Types.SourceT
12+ (SourceT)
13+#if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)
14+import Servant.API (WithStatus(..))
15+#endif
16+
17+-- | Pretend that 'SourceT m a' is '[a]'.
18+--
19+-- @since 1.1.7
20+--
21+instance ToSchema a => ToSchema (SourceT m a) where
22+ declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
23+
24+#if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)
25+-- @since 1.1.11
26+deriving instance ToSchema a => ToSchema (WithStatus s a)
27+#endif
servant-swagger/src/Servant/Swagger/Internal/Test.hsnew file+207
@@ -0,0 +1,207 @@
1+{-# LANGUAGE ConstraintKinds #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE RankNTypes #-}
5+{-# LANGUAGE ScopedTypeVariables #-}
6+{-# LANGUAGE TypeOperators #-}
7+{-# LANGUAGE OverloadedStrings #-}
8+module Servant.Swagger.Internal.Test where
9+
10+import Data.Aeson (ToJSON (..))
11+import Data.Aeson.Encode.Pretty (encodePretty', defConfig,
12+ confCompare)
13+import Data.Swagger (Pattern, ToSchema,
14+ toSchema)
15+import Data.Swagger.Schema.Validation
16+import Data.Text (Text)
17+import qualified Data.Text.Lazy as TL
18+import qualified Data.Text.Lazy.Encoding as TL
19+import Data.Typeable
20+import Test.Hspec
21+import Test.Hspec.QuickCheck
22+import Test.QuickCheck (Arbitrary, Property,
23+ counterexample, property)
24+
25+import Servant.API
26+import Servant.Swagger.Internal.TypeLevel
27+
28+-- $setup
29+-- >>> import Control.Applicative
30+-- >>> import GHC.Generics
31+-- >>> import Test.QuickCheck
32+-- >>> import System.Environment (setEnv)
33+-- >>> :set -XDeriveGeneric
34+-- >>> :set -XGeneralizedNewtypeDeriving
35+-- >>> :set -XDataKinds
36+-- >>> :set -XTypeOperators
37+-- >>> setEnv "HSPEC_COLOR" "no"
38+
39+-- | Verify that every type used with @'JSON'@ content type in a servant API
40+-- has compatible @'ToJSON'@ and @'ToSchema'@ instances using @'validateToJSON'@.
41+--
42+-- /NOTE:/ @'validateEveryToJSON'@ does not perform string pattern validation.
43+-- See @'validateEveryToJSONWithPatternChecker'@.
44+--
45+-- @'validateEveryToJSON'@ will produce one @'prop'@ specification for every type in the API.
46+-- Each type only gets one test, even if it occurs multiple times in the API.
47+--
48+-- >>> data User = User { name :: String, age :: Maybe Int } deriving (Show, Generic, Typeable)
49+-- >>> newtype UserId = UserId String deriving (Show, Generic, Typeable, ToJSON, Arbitrary)
50+-- >>> instance ToJSON User
51+-- >>> instance ToSchema User
52+-- >>> instance ToSchema UserId
53+-- >>> instance Arbitrary User where arbitrary = User <$> arbitrary <*> arbitrary
54+-- >>> type UserAPI = (Capture "user_id" UserId :> Get '[JSON] User) :<|> (ReqBody '[JSON] User :> Post '[JSON] UserId)
55+--
56+-- >>> hspec $ context "ToJSON matches ToSchema" $ validateEveryToJSON (Proxy :: Proxy UserAPI)
57+-- <BLANKLINE>
58+-- ToJSON matches ToSchema...
59+-- User...
60+-- ...
61+-- UserId...
62+-- ...
63+-- Finished in ... seconds
64+-- 2 examples, 0 failures
65+--
66+-- For the test to compile all body types should have the following instances:
67+--
68+-- * @'ToJSON'@ and @'ToSchema'@ are used to perform the validation;
69+-- * @'Typeable'@ is used to name the test for each type;
70+-- * @'Show'@ is used to display value for which @'ToJSON'@ does not satisfy @'ToSchema'@.
71+-- * @'Arbitrary'@ is used to arbitrarily generate values.
72+--
73+-- If any of the instances is missing, you'll get a descriptive type error:
74+--
75+-- >>> data Contact = Contact { fullname :: String, phone :: Integer } deriving (Show, Generic)
76+-- >>> instance ToJSON Contact
77+-- >>> instance ToSchema Contact
78+-- >>> type ContactAPI = Get '[JSON] Contact
79+-- >>> hspec $ validateEveryToJSON (Proxy :: Proxy ContactAPI)
80+-- ...
81+-- ...No instance for (Arbitrary Contact)
82+-- ... arising from a use of ‘validateEveryToJSON’
83+-- ...
84+validateEveryToJSON
85+ :: forall proxy api .
86+ TMap (Every [Typeable, Show, Arbitrary, ToJSON, ToSchema])
87+ (BodyTypes JSON api)
88+ => proxy api -- ^ Servant API.
89+ -> Spec
90+validateEveryToJSON _ = props
91+ (Proxy :: Proxy [ToJSON, ToSchema])
92+ (maybeCounterExample . prettyValidateWith validateToJSON)
93+ (Proxy :: Proxy (BodyTypes JSON api))
94+
95+-- | Verify that every type used with @'JSON'@ content type in a servant API
96+-- has compatible @'ToJSON'@ and @'ToSchema'@ instances using @'validateToJSONWithPatternChecker'@.
97+--
98+-- For validation without patterns see @'validateEveryToJSON'@.
99+validateEveryToJSONWithPatternChecker :: forall proxy api. TMap (Every [Typeable, Show, Arbitrary, ToJSON, ToSchema]) (BodyTypes JSON api) =>
100+ (Pattern -> Text -> Bool) -- ^ @'Pattern'@ checker.
101+ -> proxy api -- ^ Servant API.
102+ -> Spec
103+validateEveryToJSONWithPatternChecker checker _ = props
104+ (Proxy :: Proxy [ToJSON, ToSchema])
105+ (maybeCounterExample . prettyValidateWith (validateToJSONWithPatternChecker checker))
106+ (Proxy :: Proxy (BodyTypes JSON api))
107+
108+-- * QuickCheck-related stuff
109+
110+-- | Construct property tests for each type in a list.
111+-- The name for each property is the name of the corresponding type.
112+--
113+-- >>> :{
114+-- hspec $
115+-- context "read . show == id" $
116+-- props
117+-- (Proxy :: Proxy [Eq, Show, Read])
118+-- (\x -> read (show x) === x)
119+-- (Proxy :: Proxy [Bool, Int, String])
120+-- :}
121+-- <BLANKLINE>
122+-- read . show == id
123+-- Bool...
124+-- ...
125+-- Int...
126+-- ...
127+-- [Char]...
128+-- ...
129+-- Finished in ... seconds
130+-- 3 examples, 0 failures
131+props :: forall p p'' cs xs. TMap (Every (Typeable ': Show ': Arbitrary ': cs)) xs =>
132+ p cs -- ^ A list of constraints.
133+ -> (forall x. EveryTF cs x => x -> Property) -- ^ Property predicate.
134+ -> p'' xs -- ^ A list of types.
135+ -> Spec
136+props _ f px = sequence_ specs
137+ where
138+ specs :: [Spec]
139+ specs = tmapEvery (Proxy :: Proxy (Typeable ': Show ': Arbitrary ': cs)) aprop px
140+
141+ aprop :: forall p' a. (EveryTF cs a, Typeable a, Show a, Arbitrary a) => p' a -> Spec
142+ aprop _ = prop (show (typeOf (undefined :: a))) (f :: a -> Property)
143+
144+-- | Pretty print validation errors
145+-- together with actual JSON and Swagger Schema
146+-- (using 'encodePretty').
147+--
148+-- >>> import Data.Aeson
149+-- >>> import Data.Foldable (traverse_)
150+-- >>> data Person = Person { name :: String, phone :: Integer } deriving (Generic)
151+-- >>> instance ToJSON Person where toJSON p = object [ "name" .= name p ]
152+-- >>> instance ToSchema Person
153+-- >>> let person = Person { name = "John", phone = 123456 }
154+-- >>> traverse_ putStrLn $ prettyValidateWith validateToJSON person
155+-- Validation against the schema fails:
156+-- * property "phone" is required, but not found in "{\"name\":\"John\"}"
157+-- <BLANKLINE>
158+-- JSON value:
159+-- {
160+-- "name": "John"
161+-- }
162+-- <BLANKLINE>
163+-- Swagger Schema:
164+-- {
165+-- "properties": {
166+-- "name": {
167+-- "type": "string"
168+-- },
169+-- "phone": {
170+-- "type": "integer"
171+-- }
172+-- },
173+-- "required": [
174+-- "name",
175+-- "phone"
176+-- ],
177+-- "type": "object"
178+-- }
179+-- <BLANKLINE>
180+--
181+-- FIXME: this belongs in "Data.Swagger.Schema.Validation" (in @swagger2@).
182+prettyValidateWith
183+ :: forall a. (ToJSON a, ToSchema a)
184+ => (a -> [ValidationError]) -> a -> Maybe String
185+prettyValidateWith f x =
186+ case f x of
187+ [] -> Nothing
188+ errors -> Just $ unlines
189+ [ "Validation against the schema fails:"
190+ , unlines (map (" * " ++) errors)
191+ , "JSON value:"
192+ , ppJSONString json
193+ , ""
194+ , "Swagger Schema:"
195+ , ppJSONString (toJSON schema)
196+ ]
197+ where
198+ ppJSONString = TL.unpack . TL.decodeUtf8 . encodePretty' ppCfg
199+ ppCfg = defConfig { confCompare = compare }
200+
201+ json = toJSON x
202+ schema = toSchema (Proxy :: Proxy a)
203+
204+-- | Provide a counterexample if there is any.
205+maybeCounterExample :: Maybe String -> Property
206+maybeCounterExample Nothing = property True
207+maybeCounterExample (Just s) = counterexample s (property False)
servant-swagger/src/Servant/Swagger/Internal/TypeLevel.hsnew file+9
@@ -0,0 +1,9 @@
1+module Servant.Swagger.Internal.TypeLevel (
2+ module Servant.Swagger.Internal.TypeLevel.API,
3+ module Servant.Swagger.Internal.TypeLevel.Every,
4+ module Servant.Swagger.Internal.TypeLevel.TMap,
5+) where
6+
7+import Servant.Swagger.Internal.TypeLevel.API
8+import Servant.Swagger.Internal.TypeLevel.Every
9+import Servant.Swagger.Internal.TypeLevel.TMap
servant-swagger/src/Servant/Swagger/Internal/TypeLevel/API.hsnew file+86
@@ -0,0 +1,86 @@
1+{-# LANGUAGE ConstraintKinds #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE KindSignatures #-}
4+{-# LANGUAGE PolyKinds #-}
5+{-# LANGUAGE TypeFamilies #-}
6+{-# LANGUAGE TypeOperators #-}
7+{-# LANGUAGE UndecidableInstances #-}
8+module Servant.Swagger.Internal.TypeLevel.API where
9+
10+import GHC.Exts (Constraint)
11+import Servant.API
12+
13+-- | Build a list of endpoints from an API.
14+type family EndpointsList api where
15+ EndpointsList (a :<|> b) = AppendList (EndpointsList a) (EndpointsList b)
16+ EndpointsList (e :> a) = MapSub e (EndpointsList a)
17+ EndpointsList a = '[a]
18+
19+-- | Check whether @sub@ is a sub API of @api@.
20+type family IsSubAPI sub api :: Constraint where
21+ IsSubAPI sub api = AllIsElem (EndpointsList sub) api
22+
23+-- | Check that every element of @xs@ is an endpoint of @api@.
24+type family AllIsElem xs api :: Constraint where
25+ AllIsElem '[] api = ()
26+ AllIsElem (x ': xs) api = (IsIn x api, AllIsElem xs api)
27+
28+-- | Apply @(e :>)@ to every API in @xs@.
29+type family MapSub e xs where
30+ MapSub e '[] = '[]
31+ MapSub e (x ': xs) = (e :> x) ': MapSub e xs
32+
33+-- | Append two type-level lists.
34+type family AppendList xs ys where
35+ AppendList '[] ys = ys
36+ AppendList (x ': xs) ys = x ': AppendList xs ys
37+
38+type family Or (a :: Constraint) (b :: Constraint) :: Constraint where
39+ Or () b = ()
40+ Or a () = ()
41+
42+type family IsIn sub api :: Constraint where
43+ IsIn e (a :<|> b) = Or (IsIn e a) (IsIn e b)
44+ IsIn (e :> a) (e :> b) = IsIn a b
45+ IsIn e e = ()
46+
47+-- | Check whether a type is a member of a list of types.
48+-- This is a type-level analogue of @'elem'@.
49+type family Elem x xs where
50+ Elem x '[] = 'False
51+ Elem x (x ': xs) = 'True
52+ Elem x (y ': xs) = Elem x xs
53+
54+-- | Remove duplicates from a type-level list.
55+type family Nub xs where
56+ Nub '[] = '[]
57+ Nub (x ': xs) = x ': Nub (Remove x xs)
58+
59+-- | Remove element from a type-level list.
60+type family Remove x xs where
61+ Remove x '[] = '[]
62+ Remove x (x ': ys) = Remove x ys
63+ Remove x (y ': ys) = y ': Remove x ys
64+
65+-- | Extract a list of unique "body" types for a specific content-type from a servant API.
66+type BodyTypes c api = Nub (BodyTypes' c api)
67+
68+-- | @'AddBodyType' c cs a as@ adds type @a@ to the list @as@
69+-- only if @c@ is in @cs@.
70+type AddBodyType c cs a as = If (Elem c cs) (a ': as) as
71+
72+-- | Extract a list of "body" types for a specific content-type from a servant API.
73+-- To extract unique types see @'BodyTypes'@.
74+--
75+-- @'NoContent'@ is removed from the list and not tested. (This allows for leaving the body
76+-- completely empty on responses to requests that only accept 'application/json', while
77+-- setting the content-type in the response accordingly.)
78+type family BodyTypes' c api :: [*] where
79+ BodyTypes' c (Verb verb b cs (Headers hdrs a)) = AddBodyType c cs a '[]
80+ BodyTypes' c (Verb verb b cs NoContent) = '[]
81+ BodyTypes' c (Verb verb b cs a) = AddBodyType c cs a '[]
82+ BodyTypes' c (ReqBody' mods cs a :> api) = AddBodyType c cs a (BodyTypes' c api)
83+ BodyTypes' c (e :> api) = BodyTypes' c api
84+ BodyTypes' c (a :<|> b) = AppendList (BodyTypes' c a) (BodyTypes' c b)
85+ BodyTypes' c api = '[]
86+
servant-swagger/src/Servant/Swagger/Internal/TypeLevel/Every.hsnew file+63
@@ -0,0 +1,63 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE ConstraintKinds #-}
3+{-# LANGUAGE DataKinds #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE GADTs #-}
7+{-# LANGUAGE InstanceSigs #-}
8+{-# LANGUAGE KindSignatures #-}
9+{-# LANGUAGE MultiParamTypeClasses #-}
10+{-# LANGUAGE PolyKinds #-}
11+{-# LANGUAGE RankNTypes #-}
12+{-# LANGUAGE ScopedTypeVariables #-}
13+{-# LANGUAGE TypeFamilies #-}
14+{-# LANGUAGE TypeOperators #-}
15+{-# LANGUAGE UndecidableInstances #-}
16+#if __GLASGOW_HASKELL__ >= 800
17+{-# LANGUAGE UndecidableSuperClasses #-}
18+#endif
19+module Servant.Swagger.Internal.TypeLevel.Every where
20+
21+import Data.Proxy
22+import GHC.Exts (Constraint)
23+
24+import Servant.Swagger.Internal.TypeLevel.TMap
25+
26+-- $setup
27+-- >>> :set -XDataKinds
28+-- >>> :set -XFlexibleContexts
29+-- >>> :set -XGADTs
30+-- >>> :set -XRankNTypes
31+-- >>> :set -XScopedTypeVariables
32+-- >>> import GHC.TypeLits
33+-- >>> import Data.List
34+
35+-- | Apply multiple constraint constructors to a type.
36+--
37+-- @
38+-- EveryTF '[Show, Read] a ~ (Show a, Read a)
39+-- @
40+--
41+-- Note that since this is a type family, you have to alway fully apply @'EveryTF'@.
42+--
43+-- For partial application of multiple constraint constructors see @'Every'@.
44+type family EveryTF cs x :: Constraint where
45+ EveryTF '[] x = ()
46+ EveryTF (c ': cs) x = (c x, EveryTF cs x)
47+
48+-- | Apply multiple constraint constructors to a type as a class.
49+--
50+-- This is different from @'EveryTF'@ in that it allows partial application.
51+class EveryTF cs x => Every (cs :: [* -> Constraint]) (x :: *) where
52+
53+instance Every '[] x where
54+instance (c x, Every cs x) => Every (c ': cs) x where
55+
56+-- | Like @'tmap'@, but uses @'Every'@ for multiple constraints.
57+--
58+-- >>> let zero :: forall p a. (Show a, Num a) => p a -> String; zero _ = show (0 :: a)
59+-- >>> tmapEvery (Proxy :: Proxy [Show, Num]) zero (Proxy :: Proxy [Int, Float]) :: [String]
60+-- ["0","0.0"]
61+tmapEvery :: forall a cs p p'' xs. (TMap (Every cs) xs) =>
62+ p cs -> (forall x p'. Every cs x => p' x -> a) -> p'' xs -> [a]
63+tmapEvery _ = tmap (Proxy :: Proxy (Every cs))
servant-swagger/src/Servant/Swagger/Internal/TypeLevel/TMap.hsnew file+37
@@ -0,0 +1,37 @@
1+{-# LANGUAGE ConstraintKinds #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE KindSignatures #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE PolyKinds #-}
7+{-# LANGUAGE RankNTypes #-}
8+{-# LANGUAGE ScopedTypeVariables #-}
9+{-# LANGUAGE TypeOperators #-}
10+{-# LANGUAGE UndecidableInstances #-}
11+module Servant.Swagger.Internal.TypeLevel.TMap where
12+
13+import Data.Proxy
14+import GHC.Exts (Constraint)
15+
16+-- $setup
17+-- >>> :set -XDataKinds
18+-- >>> :set -XFlexibleContexts
19+-- >>> :set -XGADTs
20+-- >>> :set -XRankNTypes
21+-- >>> :set -XScopedTypeVariables
22+-- >>> import GHC.TypeLits
23+-- >>> import Data.List
24+
25+-- | Map a list of constrained types to a list of values.
26+--
27+-- >>> tmap (Proxy :: Proxy KnownSymbol) symbolVal (Proxy :: Proxy ["hello", "world"])
28+-- ["hello","world"]
29+class TMap (q :: k -> Constraint) (xs :: [k]) where
30+ tmap :: p q -> (forall x p'. q x => p' x -> a) -> p'' xs -> [a]
31+
32+instance TMap q '[] where
33+ tmap _ _ _ = []
34+
35+instance (q x, TMap q xs) => TMap q (x ': xs) where
36+ tmap q f _ = f (Proxy :: Proxy x) : tmap q f (Proxy :: Proxy xs)
37+
servant-swagger/src/Servant/Swagger/Test.hsnew file+13
@@ -0,0 +1,13 @@
1+-- |
2+-- Module: Servant.Swagger.Test
3+-- License: BSD3
4+-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
5+-- Stability: experimental
6+--
7+-- Automatic tests for servant API against Swagger spec.
8+module Servant.Swagger.Test (
9+ validateEveryToJSON,
10+ validateEveryToJSONWithPatternChecker,
11+) where
12+
13+import Servant.Swagger.Internal.Test
servant-swagger/src/Servant/Swagger/TypeLevel.hsnew file+15
@@ -0,0 +1,15 @@
1+-- |
2+-- Module: Servant.Swagger.TypeLevel
3+-- License: BSD3
4+-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
5+-- Stability: experimental
6+--
7+-- Useful type families for servant APIs.
8+module Servant.Swagger.TypeLevel (
9+ IsSubAPI,
10+ EndpointsList,
11+ BodyTypes,
12+) where
13+
14+import Servant.Swagger.Internal.TypeLevel
15+
servant-swagger/test/Servant/SwaggerSpec.hsnew file+489
@@ -0,0 +1,489 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE DeriveDataTypeable #-}
4+{-# LANGUAGE DeriveGeneric #-}
5+{-# LANGUAGE OverloadedStrings #-}
6+{-# LANGUAGE QuasiQuotes #-}
7+{-# LANGUAGE TypeFamilies #-}
8+{-# LANGUAGE TypeOperators #-}
9+{-# LANGUAGE PackageImports #-}
10+module Servant.SwaggerSpec where
11+
12+import Control.Lens
13+import Data.Aeson (ToJSON(toJSON), Value, genericToJSON)
14+import Data.Aeson.QQ.Simple
15+import qualified Data.Aeson.Types as JSON
16+import Data.Char (toLower)
17+import Data.Int (Int64)
18+import Data.Proxy
19+import Data.Swagger
20+import Data.Text (Text)
21+import Data.Time
22+import GHC.Generics
23+import Servant.API
24+import Servant.Swagger
25+import Servant.Test.ComprehensiveAPI (comprehensiveAPI)
26+import Test.Hspec hiding (example)
27+
28+#if !MIN_VERSION_swagger2(2,4,0)
29+import Data.Aeson.Lens (key, _Array)
30+import qualified Data.Vector as V
31+#endif
32+
33+checkAPI :: HasSwagger api => Proxy api -> Value -> IO ()
34+checkAPI proxy = checkSwagger (toSwagger proxy)
35+
36+checkSwagger :: Swagger -> Value -> IO ()
37+checkSwagger swag js = toJSON swag `shouldBe` js
38+
39+spec :: Spec
40+spec = describe "HasSwagger" $ do
41+ it "Todo API" $ checkAPI (Proxy :: Proxy TodoAPI) todoAPI
42+ it "Hackage API (with tags)" $ checkSwagger hackageSwaggerWithTags hackageAPI
43+ it "GetPost API (test subOperations)" $ checkSwagger getPostSwagger getPostAPI
44+ it "UVerb API" $ checkSwagger uverbSwagger uverbAPI
45+ it "Comprehensive API" $ do
46+ let _x = toSwagger comprehensiveAPI
47+ True `shouldBe` True -- type-level test
48+
49+main :: IO ()
50+main = hspec spec
51+
52+-- =======================================================================
53+-- Todo API
54+-- =======================================================================
55+
56+data Todo = Todo
57+ { created :: UTCTime
58+ , title :: String
59+ , summary :: Maybe String
60+ } deriving (Generic)
61+
62+instance ToJSON Todo
63+instance ToSchema Todo
64+
65+newtype TodoId = TodoId String deriving (Generic)
66+instance ToParamSchema TodoId
67+
68+type TodoAPI = "todo" :> Capture "id" TodoId :> Get '[JSON] Todo
69+
70+todoAPI :: Value
71+todoAPI = [aesonQQ|
72+{
73+ "swagger":"2.0",
74+ "info":
75+ {
76+ "title": "",
77+ "version": ""
78+ },
79+ "definitions":
80+ {
81+ "Todo":
82+ {
83+ "type": "object",
84+ "required": [ "created", "title" ],
85+ "properties":
86+ {
87+ "created": { "$ref": "#/definitions/UTCTime" },
88+ "title": { "type": "string" },
89+ "summary": { "type": "string" }
90+ }
91+ },
92+ "UTCTime":
93+ {
94+ "type": "string",
95+ "format": "yyyy-mm-ddThh:MM:ssZ",
96+ "example": "2016-07-22T00:00:00Z"
97+ }
98+ },
99+ "paths":
100+ {
101+ "/todo/{id}":
102+ {
103+ "get":
104+ {
105+ "responses":
106+ {
107+ "200":
108+ {
109+ "schema": { "$ref":"#/definitions/Todo" },
110+ "description": ""
111+ },
112+ "400": { "description": "Invalid `id`" }
113+ },
114+ "produces": [ "application/json;charset=utf-8" ],
115+ "parameters":
116+ [
117+ {
118+ "required": true,
119+ "in": "path",
120+ "name": "id",
121+ "type": "string"
122+ }
123+ ]
124+ }
125+ }
126+ }
127+}
128+|]
129+
130+-- =======================================================================
131+-- Hackage API
132+-- =======================================================================
133+
134+type HackageAPI
135+ = HackageUserAPI
136+ :<|> HackagePackagesAPI
137+
138+type HackageUserAPI =
139+ "users" :> Get '[JSON] [UserSummary]
140+ :<|> "user" :> Capture "username" Username :> Get '[JSON] UserDetailed
141+
142+type HackagePackagesAPI
143+ = "packages" :> Get '[JSON] [Package]
144+
145+type Username = Text
146+
147+data UserSummary = UserSummary
148+ { summaryUsername :: Username
149+ , summaryUserid :: Int64 -- Word64 would make sense too
150+ } deriving (Eq, Show, Generic)
151+
152+lowerCutPrefix :: String -> String -> String
153+lowerCutPrefix s = map toLower . drop (length s)
154+
155+instance ToJSON UserSummary where
156+ toJSON = genericToJSON JSON.defaultOptions { JSON.fieldLabelModifier = lowerCutPrefix "summary" }
157+
158+instance ToSchema UserSummary where
159+ declareNamedSchema proxy = genericDeclareNamedSchema defaultSchemaOptions { fieldLabelModifier = lowerCutPrefix "summary" } proxy
160+ & mapped.schema.example ?~ toJSON UserSummary
161+ { summaryUsername = "JohnDoe"
162+ , summaryUserid = 123 }
163+
164+type Group = Text
165+
166+data UserDetailed = UserDetailed
167+ { username :: Username
168+ , userid :: Int64
169+ , groups :: [Group]
170+ } deriving (Eq, Show, Generic)
171+instance ToSchema UserDetailed
172+
173+newtype Package = Package { packageName :: Text }
174+ deriving (Eq, Show, Generic)
175+instance ToSchema Package
176+
177+hackageSwaggerWithTags :: Swagger
178+hackageSwaggerWithTags = toSwagger (Proxy :: Proxy HackageAPI)
179+ & host ?~ Host "hackage.haskell.org" Nothing
180+ & applyTagsFor usersOps ["users" & description ?~ "Operations about user"]
181+ & applyTagsFor packagesOps ["packages" & description ?~ "Query packages"]
182+ where
183+ usersOps, packagesOps :: Traversal' Swagger Operation
184+ usersOps = subOperations (Proxy :: Proxy HackageUserAPI) (Proxy :: Proxy HackageAPI)
185+ packagesOps = subOperations (Proxy :: Proxy HackagePackagesAPI) (Proxy :: Proxy HackageAPI)
186+
187+hackageAPI :: Value
188+hackageAPI = modifyValue [aesonQQ|
189+{
190+ "swagger":"2.0",
191+ "host":"hackage.haskell.org",
192+ "info":{
193+ "version":"",
194+ "title":""
195+ },
196+ "definitions":{
197+ "UserDetailed":{
198+ "required":[
199+ "username",
200+ "userid",
201+ "groups"
202+ ],
203+ "type":"object",
204+ "properties":{
205+ "groups":{
206+ "items":{
207+ "type":"string"
208+ },
209+ "type":"array"
210+ },
211+ "username":{
212+ "type":"string"
213+ },
214+ "userid":{
215+ "maximum":9223372036854775807,
216+ "minimum":-9223372036854775808,
217+ "type":"integer",
218+ "format":"int64"
219+ }
220+ }
221+ },
222+ "Package":{
223+ "required":[
224+ "packageName"
225+ ],
226+ "type":"object",
227+ "properties":{
228+ "packageName":{
229+ "type":"string"
230+ }
231+ }
232+ },
233+ "UserSummary":{
234+ "required":[
235+ "username",
236+ "userid"
237+ ],
238+ "type":"object",
239+ "properties":{
240+ "username":{
241+ "type":"string"
242+ },
243+ "userid":{
244+ "maximum":9223372036854775807,
245+ "minimum":-9223372036854775808,
246+ "type":"integer",
247+ "format":"int64"
248+ }
249+ },
250+ "example":{
251+ "username": "JohnDoe",
252+ "userid": 123
253+ }
254+ }
255+ },
256+ "paths":{
257+ "/users":{
258+ "get":{
259+ "responses":{
260+ "200":{
261+ "schema":{
262+ "items":{
263+ "$ref":"#/definitions/UserSummary"
264+ },
265+ "type":"array"
266+ },
267+ "description":""
268+ }
269+ },
270+ "produces":[
271+ "application/json;charset=utf-8"
272+ ],
273+ "tags":[
274+ "users"
275+ ]
276+ }
277+ },
278+ "/packages":{
279+ "get":{
280+ "responses":{
281+ "200":{
282+ "schema":{
283+ "items":{
284+ "$ref":"#/definitions/Package"
285+ },
286+ "type":"array"
287+ },
288+ "description":""
289+ }
290+ },
291+ "produces":[
292+ "application/json;charset=utf-8"
293+ ],
294+ "tags":[
295+ "packages"
296+ ]
297+ }
298+ },
299+ "/user/{username}":{
300+ "get":{
301+ "responses":{
302+ "400":{
303+ "description":"Invalid `username`"
304+ },
305+ "200":{
306+ "schema":{
307+ "$ref":"#/definitions/UserDetailed"
308+ },
309+ "description":""
310+ }
311+ },
312+ "produces":[
313+ "application/json;charset=utf-8"
314+ ],
315+ "parameters":[
316+ {
317+ "required":true,
318+ "in":"path",
319+ "name":"username",
320+ "type":"string"
321+ }
322+ ],
323+ "tags":[
324+ "users"
325+ ]
326+ }
327+ }
328+ },
329+ "tags":[
330+ {
331+ "name":"users",
332+ "description":"Operations about user"
333+ },
334+ {
335+ "name":"packages",
336+ "description":"Query packages"
337+ }
338+ ]
339+}
340+|]
341+ where
342+ modifyValue :: Value -> Value
343+#if MIN_VERSION_swagger2(2,4,0)
344+ modifyValue = id
345+#else
346+ -- swagger2-2.4 preserves order of tags
347+ -- swagger2-2.3 used Set, so they are ordered
348+ -- packages comes before users.
349+ -- We simply reverse, not properly sort here for simplicity: 2 elements.
350+ modifyValue = over (key "tags" . _Array) V.reverse
351+#endif
352+
353+
354+-- =======================================================================
355+-- Get/Post API (test for subOperations)
356+-- =======================================================================
357+
358+type GetPostAPI = Get '[JSON] String :<|> Post '[JSON] String
359+
360+getPostSwagger :: Swagger
361+getPostSwagger = toSwagger (Proxy :: Proxy GetPostAPI)
362+ & applyTagsFor getOps ["get" & description ?~ "GET operations"]
363+ where
364+ getOps :: Traversal' Swagger Operation
365+ getOps = subOperations (Proxy :: Proxy (Get '[JSON] String)) (Proxy :: Proxy GetPostAPI)
366+
367+getPostAPI :: Value
368+getPostAPI = [aesonQQ|
369+{
370+ "swagger":"2.0",
371+ "info":{
372+ "version":"",
373+ "title":""
374+ },
375+ "paths":{
376+ "/":{
377+ "post":{
378+ "responses":{
379+ "200":{
380+ "schema":{
381+ "type":"string"
382+ },
383+ "description":""
384+ }
385+ },
386+ "produces":[ "application/json;charset=utf-8" ]
387+ },
388+ "get":{
389+ "responses":{
390+ "200":{
391+ "schema":{
392+ "type":"string"
393+ },
394+ "description":""
395+ }
396+ },
397+ "produces":[ "application/json;charset=utf-8" ],
398+ "tags":[ "get" ]
399+ }
400+ }
401+ },
402+ "tags":[
403+ {
404+ "name":"get",
405+ "description":"GET operations"
406+ }
407+ ]
408+}
409+|]
410+
411+-- =======================================================================
412+-- UVerb API
413+-- =======================================================================
414+
415+data Lunch = Lunch {name :: String}
416+ deriving (Eq, Show, Generic)
417+
418+instance ToSchema Lunch
419+
420+instance HasStatus Lunch where
421+ type StatusOf Lunch = 200
422+
423+data NoLunch = NoLunch
424+ deriving (Eq, Show, Generic)
425+
426+instance ToSchema NoLunch
427+
428+instance HasStatus NoLunch where
429+ type StatusOf NoLunch = 404
430+
431+type UVerbAPI2 =
432+ "lunch" :> UVerb 'GET '[JSON] '[Lunch, NoLunch]
433+
434+uverbSwagger :: Swagger
435+uverbSwagger = toSwagger (Proxy :: Proxy UVerbAPI2)
436+
437+uverbAPI :: Value
438+uverbAPI =
439+ [aesonQQ|
440+ {
441+ "swagger": "2.0",
442+ "info": {
443+ "version": "",
444+ "title": ""
445+ },
446+ "definitions": {
447+ "Lunch": {
448+ "required": [
449+ "name"
450+ ],
451+ "type": "object",
452+ "properties": {
453+ "name": {
454+ "type": "string"
455+ }
456+ }
457+ },
458+ "NoLunch": {
459+ "type": "string",
460+ "enum": [
461+ "NoLunch"
462+ ]
463+ }
464+ },
465+ "paths": {
466+ "/lunch": {
467+ "get": {
468+ "responses": {
469+ "404": {
470+ "schema": {
471+ "$ref": "#/definitions/NoLunch"
472+ },
473+ "description": ""
474+ },
475+ "200": {
476+ "schema": {
477+ "$ref": "#/definitions/Lunch"
478+ },
479+ "description": ""
480+ }
481+ },
482+ "produces": [
483+ "application/json;charset=utf-8"
484+ ]
485+ }
486+ }
487+ }
488+}
489+|]
servant-swagger/test/Spec.hsnew file+1
@@ -0,0 +1 @@
1+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
servant-swagger/test/doctests.hsnew file+12
@@ -0,0 +1,12 @@
1+module Main where
2+
3+import Build_doctests (flags, pkgs, module_sources)
4+import Data.Foldable (traverse_)
5+import Test.DocTest
6+
7+main :: IO ()
8+main = do
9+ traverse_ putStrLn args
10+ doctest args
11+ where
12+ args = flags ++ pkgs ++ module_sources
servant/CHANGELOG.md+137
@@ -1,5 +1,142 @@
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
6+----
7+
8+### Significant changes
9+
10+- Drop support for GHC < 8.6.
11+- Support GHC 9.0 (GHC 9.2 should work as well, but isn't fully tested yet).
12+- Support Aeson 2 ([#1475](https://github.com/haskell-servant/servant/pull/1475)),
13+ which fixes a [DOS vulnerability](https://github.com/haskell/aeson/issues/864)
14+ related to hash collisions.
15+- Add `NamedRoutes` combinator, making support for records first-class in Servant
16+ ([#1388](https://github.com/haskell-servant/servant/pull/1388)).
17+
18+ Users can now directly mark part as an API as defined by a record, instead of
19+ using `(:<|>)` to combine routes. Concretely, the anonymous:
20+
21+ ```haskell
22+ type API =
23+ "version" :> Get '[JSON] String :<|>
24+ "products" :> Get '[JSON] [Product]
25+ ```
26+
27+ can be replaced with the explicitly-named:
28+
29+ ```haskell
30+ type API = NamedRoutes NamedAPI
31+ data NamedAPI mode = NamedAPI
32+ { version :: mode :- "version" :> Get '[JSON] String
33+ , products :: mode :- "products" :> Get '[JSON] [Product]
34+ }
35+ ```
36+
37+ `NamedRoutes` builds upon `servant-generic`, but improves usability by freeing
38+ users from the need to perform `toServant` / `fromServant` conversions
39+ manually. Serving `NamedRoutes NamedAPI` is now done directly by providing a
40+ record of handlers, and servant generates clients directly as records as well.
41+ In particular, it makes it much more practical to work with nested hierarchies
42+ of named routes.
43+
44+ Two convenience functions, `(//)` and `(/:)`, have been added to make the
45+ usage of named route hierarchies more pleasant:
46+
47+ ```haskell
48+ rootClient :: RootApi (AsClientT ClientM)
49+ rootClient = client (Proxy @API)
50+
51+ helloClient :: String -> ClientM String
52+ helloClient name = rootClient // hello /: name
53+
54+ endpointClient :: ClientM Person
55+ endpointClient = rootClient // subApi /: "foobar123" // endpoint
56+
57+ type Api = NamedRoutes RootApi
58+
59+ data RootApi mode = RootApi
60+ { subApi :: mode :- Capture "token" String :> NamedRoutes SubApi
61+ , hello :: mode :- Capture "name" String :> Get '[JSON] String
62+ , …
63+ } deriving Generic
64+
65+ data SubApi mode = SubApi
66+ { endpoint :: mode :- Get '[JSON] Person
67+ , …
68+ } deriving Generic
69+ ```
70+
71+- Add custom type errors for partially applied combinators
72+ ([#1289](https://github.com/haskell-servant/servant/pull/1289),
73+ [#1486](https://github.com/haskell-servant/servant/pull/1486)).
74+
75+ For example, forgetting to document the expected type for a query parameter,
76+ as in:
77+
78+ ``` haskell
79+ type API = QueryParam "param" :> Get '[JSON] NoContent
80+ ```
81+
82+ will raise to the following error when trying to serve the API:
83+
84+ ```
85+ • There is no instance for HasServer (QueryParam'
86+ '[Optional, Strict] "param" :> ...)
87+ QueryParam' '[Optional, Strict] "1" expects 1 more arguments
88+ ```
89+
90+ As a consequence of this change, unsaturated types are now forbidden before `(:>)`.
91+
92+- Add a `HeadNoContent` verb ([#1502](https://github.com/haskell-servant/servant/pull/1502)).
93+
94+- *servant-client* / *servant-client-core* / *servant-http-streams*:
95+ Fix erroneous behavior, where only 2XX status codes would be considered
96+ successful, irrelevant of the status parameter specified by the verb
97+ combinator. ([#1469](https://github.com/haskell-servant/servant/pull/1469))
98+
99+- *servant-client* / *servant-client-core*: Fix `Show` instance for
100+ `Servant.Client.Core.Request`.
101+
102+
103+- *servant-client* / *servant-client-core*: Allow passing arbitrary binary data
104+ in Query parameters.
105+ ([#1432](https://github.com/haskell-servant/servant/pull/1432)).
106+
107+- *servant-docs*: Generate sample cURL requests
108+ ([#1401](https://github.com/haskell-servant/servant/pull/1401/files)).
109+
110+ Breaking change: requires sample header values to be supplied with `headers`.
111+
112+### Other changes
113+
114+- Various bit rotten cookbooks have been updated and re-introduced on
115+ [docs.servant.dev](https://docs.servant.dev).
116+
117+- Various version bumps.
118+
119+0.18.3
120+------
121+
122+### Significant changes
123+
124+- Add response header support to UVerb (#1420).
125+- Use Capture Description if available (#1423).
126+
127+### Other changes
128+
129+- Support GHC-9.0.1.
130+- Bump `bytestring`, `attoparsec`, `hspec` and `singleton-bool` dependencies.
131+
132+0.18.2
133+------
134+
135+### Significant changes
136+
137+- Introduce `Fragment` combinator.
138+- Fix `MimeRender` and `MimeUnrender` instances for `WithStatus`.
139+
31400.18.1
4141------
5142
servant/servant.cabal+20−16
@@ -1,6 +1,6 @@
1−cabal-version: >=1.10
1+cabal-version: 2.2
22name: servant
3−version: 0.18.1
3+version: 0.19
44
55synopsis: A family of combinators for defining webservices APIs
66category: Servant, Web
@@ -13,15 +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
2121build-type: Simple
2222
23−tested-with: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.2
24− , 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
2525
2626extra-source-files:
2727 CHANGELOG.md
@@ -40,11 +40,13 @@ library
4040 Servant.API.Description
4141 Servant.API.Empty
4242 Servant.API.Experimental.Auth
43+ Servant.API.Fragment
4344 Servant.API.Generic
4445 Servant.API.Header
4546 Servant.API.HttpVersion
4647 Servant.API.IsSecure
4748 Servant.API.Modifiers
49+ Servant.API.NamedRoutes
4850 Servant.API.QueryParam
4951 Servant.API.Raw
5052 Servant.API.RemoteHost
@@ -53,6 +55,7 @@ library
5355 Servant.API.Status
5456 Servant.API.Stream
5557 Servant.API.Sub
58+ Servant.API.TypeErrors
5659 Servant.API.TypeLevel
5760 Servant.API.UVerb
5861 Servant.API.UVerb.Union
@@ -77,32 +80,33 @@ library
7780 --
7881 -- note: mtl lower bound is so low because of GHC-7.8
7982 build-depends:
80− base >= 4.9 && < 4.15
81− , bytestring >= 0.10.8.1 && < 0.11
83+ base >= 4.9 && < 4.17
84+ , bytestring >= 0.10.8.1 && < 0.12
85+ , constraints >= 0.2
8286 , mtl >= 2.2.2 && < 2.3
8387 , sop-core >= 0.4.0.0 && < 0.6
8488 , transformers >= 0.5.2.0 && < 0.6
85− , text >= 1.2.3.0 && < 1.3
89+ , text >= 1.2.3.0 && < 2.1
8690
8791
8892 -- We depend (heavily) on the API of these packages:
8993 -- i.e. re-export, or allow using without direct dependency
9094 build-depends:
91− http-api-data >= 0.4.1 && < 0.4.3
92− , singleton-bool >= 0.1.4 && < 0.1.6
95+ http-api-data >= 0.4.1 && < 0.4.4
96+ , singleton-bool >= 0.1.4 && < 0.1.7
9397
9498 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.
9599 -- Here can be exceptions if we really need features from the newer versions.
96100 build-depends:
97− base-compat >= 0.10.5 && < 0.12
98− , aeson >= 1.4.1.0 && < 1.6
99− , attoparsec >= 0.13.2.2 && < 0.14
101+ base-compat >= 0.10.5 && < 0.13
102+ , aeson >= 1.4.1.0 && < 3
103+ , attoparsec >= 0.13.2.2 && < 0.15
100104 , bifunctors >= 5.5.3 && < 5.6
101105 , case-insensitive >= 1.2.0.11 && < 1.3
102106 , deepseq >= 1.4.2.0 && < 1.5
103107 , http-media >= 0.7.1.3 && < 0.9
104108 , http-types >= 0.12.2 && < 0.13
105− , mmorph >= 1.1.2 && < 1.2
109+ , mmorph >= 1.1.2 && < 1.3
106110 , network-uri >= 2.6.1.0 && < 2.7
107111 , QuickCheck >= 2.12.6.1 && < 2.15
108112 , string-conversions >= 0.4.0.1 && < 0.5
@@ -162,9 +166,9 @@ test-suite spec
162166
163167 -- Additional dependencies
164168 build-depends:
165− hspec >= 2.6.0 && < 2.8
169+ hspec >= 2.6.0 && < 2.10
166170 , QuickCheck >= 2.12.6.1 && < 2.15
167171 , quickcheck-instances >= 0.3.19 && < 0.4
168172
169173 build-tool-depends:
170− hspec-discover:hspec-discover >= 2.6.0 && < 2.8
174+ hspec-discover:hspec-discover >= 2.6.0 && < 2.10
servant/src/Servant/API.hs+21−9
@@ -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,
@@ -34,6 +36,10 @@ module Servant.API (
3436 module Servant.API.Verbs,
3537 module Servant.API.UVerb,
3638
39+ -- * Sub-APIs defined as records of routes
40+ module Servant.API.NamedRoutes,
41+ module Servant.API.Generic,
42+
3743 -- * Streaming endpoints, distinguished by HTTP method
3844 module Servant.API.Stream,
3945
@@ -93,8 +99,13 @@ import Servant.API.Empty
9399 (EmptyAPI (..))
94100import Servant.API.Experimental.Auth
95101 (AuthProtect)
102+import Servant.API.Fragment
103+ (Fragment)
96104import Servant.API.Header
97105 (Header, Header')
106+import Servant.API.Generic
107+ (GenericMode ((:-)), AsApi, ToServant, ToServantApi, GServantProduct,
108+ GenericServant, fromServant, toServant, genericApi)
98109import Servant.API.HttpVersion
99110 (HttpVersion (..))
100111import Servant.API.IsSecure
@@ -121,21 +132,22 @@ import Servant.API.Stream
121132 ToSourceIO (..))
122133import Servant.API.Sub
123134 ((:>))
135+import Servant.API.UVerb
136+ (HasStatus, IsMember, StatusOf, Statuses, UVerb, Union,
137+ Unique, WithStatus (..), inject, statusOf)
124138import Servant.API.Vault
125139 (Vault)
140+import Servant.API.NamedRoutes
141+ (NamedRoutes)
126142import Servant.API.Verbs
127143 (Delete, DeleteAccepted, DeleteNoContent,
128144 DeleteNonAuthoritative, Get, GetAccepted, GetNoContent,
129145 GetNonAuthoritative, GetPartialContent, GetResetContent,
130− Patch, PatchAccepted, PatchNoContent, PatchNonAuthoritative,
131− Post, PostAccepted, PostCreated, PostNoContent,
132− PostNonAuthoritative, PostResetContent, Put, PutAccepted,
133− PutCreated, PutNoContent, PutNonAuthoritative,
134− ReflectMethod (reflectMethod), StdMethod (..),
135− Verb, NoContentVerb)
136−import Servant.API.UVerb
137− (UVerb, Union, HasStatus, StatusOf, statusOf, Statuses,
138− WithStatus (..), IsMember, Unique, inject)
146+ NoContentVerb, Patch, PatchAccepted, PatchNoContent,
147+ PatchNonAuthoritative, Post, PostAccepted, PostCreated,
148+ PostNoContent, PostNonAuthoritative, PostResetContent, Put,
149+ PutAccepted, PutCreated, PutNoContent, PutNonAuthoritative,
150+ ReflectMethod (reflectMethod), StdMethod (..), Verb)
139151import Servant.API.WithNamedContext
140152 (WithNamedContext)
141153import Servant.Links
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−2
@@ -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
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/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/ResponseHeaders.hs+6−8
@@ -3,10 +3,8 @@
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 #-}
@@ -114,7 +112,7 @@ instance {-# OVERLAPPABLE #-} ( FromHttpApiData v, BuildHeadersTo xs, KnownSymbo
114112 `HCons` buildHeadersTo headers
115113 Right h -> Header h `HCons` buildHeadersTo headers
116114
117−-- * Getting
115+-- * Getting headers
118116
119117class GetHeaders ls where
120118 getHeaders :: ls -> [HTTP.Header]
@@ -155,20 +153,20 @@ instance (KnownSymbol h, GetHeadersFromHList rest, ToHttpApiData v)
155153 where
156154 getHeaders' hs = getHeadersFromHList $ getHeadersHList hs
157155
158−-- * Adding
156+-- * Adding headers
159157
160158-- We need all these fundeps to save type inference
161159class AddHeader h v orig new
162160 | h v orig -> new, new -> h, new -> v, new -> orig where
163161 addOptionalHeader :: ResponseHeader h v -> orig -> new -- ^ N.B.: The same header can't be added multiple times
164162
165−
163+-- In this instance, we add a Header on top of something that is already decorated with some headers
166164instance {-# OVERLAPPING #-} ( KnownSymbol h, ToHttpApiData v )
167165 => AddHeader h v (Headers (fst ': rest) a) (Headers (Header h v ': fst ': rest) a) where
168166 addOptionalHeader hdr (Headers resp heads) = Headers resp (HCons hdr heads)
169167
170−instance {-# OVERLAPPABLE #-} ( KnownSymbol h, ToHttpApiData v
171− , new ~ (Headers '[Header h v] a) )
168+-- In this instance, 'a' parameter is decorated with a Header.
169+instance {-# OVERLAPPABLE #-} ( KnownSymbol h, ToHttpApiData v , new ~ Headers '[Header h v] a)
172170 => AddHeader h v a new where
173171 addOptionalHeader hdr resp = Headers resp (HCons hdr HNil)
174172
servant/src/Servant/API/Status.hs+6−1
@@ -1,10 +1,15 @@
11{-# LANGUAGE DataKinds #-}
22-- Flexible instances is necessary on GHC 8.4 and earlier
33{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE ScopedTypeVariables #-}
45module Servant.API.Status where
56
7+import GHC.TypeLits (KnownNat, natVal)
68import Network.HTTP.Types.Status
7−import GHC.TypeLits
9+
10+-- | Retrieve a known or unknown Status from a KnownNat
11+statusFromNat :: forall a proxy. KnownNat a => proxy a -> Status
12+statusFromNat = toEnum . fromInteger . natVal
813
914-- | Witness that a type-level natural number corresponds to a HTTP status code
1015class KnownNat n => KnownStatus n where
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+59−9
@@ -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
@@ -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 = ()
@@ -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.hs+45−18
@@ -4,14 +4,13 @@
44{-# LANGUAGE DeriveGeneric #-}
55{-# LANGUAGE FlexibleContexts #-}
66{-# LANGUAGE FlexibleInstances #-}
7−{-# LANGUAGE KindSignatures #-}
87{-# LANGUAGE MultiParamTypeClasses #-}
98{-# LANGUAGE RankNTypes #-}
109{-# LANGUAGE ScopedTypeVariables #-}
11−{-# LANGUAGE TypeApplications #-}
1210{-# LANGUAGE TypeFamilies #-}
1311{-# LANGUAGE TypeOperators #-}
1412{-# LANGUAGE UndecidableInstances #-}
13+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
1514
1615-- | An alternative to 'Verb' for end-points that respond with a resource value of any of an
1716-- open union of types, and specific status codes for each type in this union. (`UVerb` is
@@ -34,12 +33,10 @@ module Servant.API.UVerb
3433 )
3534where
3635
37−import Data.Aeson (FromJSON, ToJSON)
3836import Data.Proxy (Proxy (Proxy))
39−import qualified GHC.Generics as GHC
4037import GHC.TypeLits (Nat)
4138import Network.HTTP.Types (Status, StdMethod)
42−import Servant.API.ContentTypes (MimeRender (mimeRender), MimeUnrender (mimeUnrender), NoContent)
39+import Servant.API.ContentTypes (JSON, PlainText, FormUrlEncoded, OctetStream, NoContent, MimeRender(mimeRender), MimeUnrender(mimeUnrender))
4340import Servant.API.Status (KnownStatus, statusVal)
4441import Servant.API.UVerb.Union
4542
@@ -49,9 +46,6 @@ class KnownStatus (StatusOf a) => HasStatus (a :: *) where
4946statusOf :: forall a proxy. HasStatus a => proxy a -> Status
5047statusOf = const (statusVal (Proxy :: Proxy (StatusOf a)))
5148
52−instance KnownStatus n => HasStatus (WithStatus n a) where
53− type StatusOf (WithStatus n a) = n
54−
5549-- | If an API can respond with 'NoContent' we assume that this will happen
5650-- with the status code 204 No Content. If this needs to be overridden,
5751-- 'WithStatus' can be used.
@@ -70,19 +64,28 @@ instance (HasStatus a, HasStatuses as) => HasStatuses (a ': as) where
7064 type Statuses (a ': as) = StatusOf a ': Statuses as
7165 statuses _ = statusOf (Proxy :: Proxy a) : statuses (Proxy :: Proxy as)
7266
67+-- | A simple newtype wrapper that pairs a type with its status code. It
68+-- implements all the content types that Servant ships with by default.
7369newtype WithStatus (k :: Nat) a = WithStatus a
74− deriving (Eq, Show, GHC.Generic)
70+ deriving (Eq, Show)
7571
76−instance (GHC.Generic (WithStatus n a), ToJSON a) => ToJSON (WithStatus n a)
77−
78−instance (GHC.Generic (WithStatus n a), FromJSON a) => FromJSON (WithStatus n a)
79−
80−instance MimeRender ctype a => MimeRender ctype (WithStatus _status a) where
81− mimeRender contentTypeProxy (WithStatus a) = mimeRender contentTypeProxy a
72+-- | an instance of this typeclass assigns a HTTP status code to a return type
73+--
74+-- Example:
75+--
76+-- @
77+-- data NotFoundError = NotFoundError String
78+--
79+-- instance HasStatus NotFoundError where
80+-- type StatusOf NotFoundError = 404
81+-- @
82+--
83+-- You can also use the convience newtype wrapper 'WithStatus' if you want to
84+-- avoid writing a 'HasStatus' instance manually. It also has the benefit of
85+-- showing the status code in the type; which might aid in readability.
86+instance KnownStatus n => HasStatus (WithStatus n a) where
87+ type StatusOf (WithStatus n a) = n
8288
83−instance MimeUnrender ctype a => MimeUnrender ctype (WithStatus _status a) where
84− mimeUnrender contentTypeProxy input =
85− WithStatus <$> mimeUnrender contentTypeProxy input
8689
8790-- | A variant of 'Verb' that can have any of a number of response values and status codes.
8891--
@@ -95,3 +98,27 @@ instance MimeUnrender ctype a => MimeUnrender ctype (WithStatus _status a) where
9598-- Backwards compatibility is tricky, though: this type alias would mean people would have to
9699-- use 'respond' instead of 'pure' or 'return', so all old handlers would have to be rewritten.
97100data UVerb (method :: StdMethod) (contentTypes :: [*]) (as :: [*])
101+
102+instance {-# OVERLAPPING #-} MimeRender JSON a => MimeRender JSON (WithStatus _status a) where
103+ mimeRender contentTypeProxy (WithStatus a) = mimeRender contentTypeProxy a
104+
105+instance {-# OVERLAPPING #-} MimeRender PlainText a => MimeRender PlainText (WithStatus _status a) where
106+ mimeRender contentTypeProxy (WithStatus a) = mimeRender contentTypeProxy a
107+
108+instance {-# OVERLAPPING #-} MimeRender FormUrlEncoded a => MimeRender FormUrlEncoded (WithStatus _status a) where
109+ mimeRender contentTypeProxy (WithStatus a) = mimeRender contentTypeProxy a
110+
111+instance {-# OVERLAPPING #-} MimeRender OctetStream a => MimeRender OctetStream (WithStatus _status a) where
112+ mimeRender contentTypeProxy (WithStatus a) = mimeRender contentTypeProxy a
113+
114+instance {-# OVERLAPPING #-} MimeUnrender JSON a => MimeUnrender JSON (WithStatus _status a) where
115+ mimeUnrender contentTypeProxy input = WithStatus <$> mimeUnrender contentTypeProxy input
116+
117+instance {-# OVERLAPPING #-} MimeUnrender PlainText a => MimeUnrender PlainText (WithStatus _status a) where
118+ mimeUnrender contentTypeProxy input = WithStatus <$> mimeUnrender contentTypeProxy input
119+
120+instance {-# OVERLAPPING #-} MimeUnrender FormUrlEncoded a => MimeUnrender FormUrlEncoded (WithStatus _status a) where
121+ mimeUnrender contentTypeProxy input = WithStatus <$> mimeUnrender contentTypeProxy input
122+
123+instance {-# OVERLAPPING #-} MimeUnrender OctetStream a => MimeUnrender OctetStream (WithStatus _status a) where
124+ mimeUnrender contentTypeProxy input = WithStatus <$> mimeUnrender contentTypeProxy input
servant/src/Servant/API/UVerb/Union.hs+2−2
@@ -47,7 +47,7 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
4747-}
4848
4949-- | Type-level code for implementing and using 'UVerb'. Heavily inspired by
50−-- [world-piece](https://github.com/cdepillabout/world-peace).
50+-- [world-peace](https://github.com/cdepillabout/world-peace).
5151module Servant.API.UVerb.Union
5252( IsMember
5353, Unique
@@ -144,4 +144,4 @@ _testNubbed :: ( ( Nubbed '[Bool, Int, Int] ~ 'False
144144 , Nubbed '[Int, Bool] ~ 'True
145145 )
146146 => a) -> a
147−_testNubbed = id
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/Links.hs+86−9
@@ -1,13 +1,18 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
12{-# LANGUAGE ConstraintKinds #-}
23{-# LANGUAGE DataKinds #-}
34{-# LANGUAGE FlexibleContexts #-}
45{-# LANGUAGE FlexibleInstances #-}
56{-# LANGUAGE FunctionalDependencies #-}
7+{-# LANGUAGE InstanceSigs #-}
68{-# LANGUAGE PolyKinds #-}
9+{-# LANGUAGE QuantifiedConstraints #-}
710{-# LANGUAGE ScopedTypeVariables #-}
11+{-# LANGUAGE TypeApplications #-}
812{-# LANGUAGE TypeFamilies #-}
913{-# LANGUAGE TypeOperators #-}
1014{-# LANGUAGE UndecidableInstances #-}
15+
1116{-# OPTIONS_HADDOCK not-home #-}
1217
1318-- | Type safe generation of internal links.
@@ -17,6 +22,7 @@
1722-- >>> :set -XDataKinds -XTypeFamilies -XTypeOperators
1823-- >>> import Servant.API
1924-- >>> import Servant.Links
25+-- >>> import Web.HttpApiData (toUrlPiece)
2026-- >>> import Data.Proxy
2127-- >>>
2228-- >>> type Hello = "hello" :> Get '[JSON] Int
@@ -120,13 +126,13 @@ module Servant.Links (
120126 , Param (..)
121127 , linkSegments
122128 , linkQueryParams
129+ , linkFragment
123130) where
124131
125132import Data.List
133+import Data.Constraint
126134import Data.Proxy
127135 (Proxy (..))
128−import Data.Semigroup
129− ((<>))
130136import Data.Singletons.Bool
131137 (SBool (..), SBoolI (..))
132138import qualified Data.Text as Text
@@ -134,7 +140,7 @@ import qualified Data.Text.Encoding as TE
134140import Data.Type.Bool
135141 (If)
136142import GHC.TypeLits
137− (KnownSymbol, symbolVal)
143+ (KnownSymbol, TypeError, symbolVal)
138144import Network.URI
139145 (URI (..), escapeURIString, isUnreserved)
140146import Prelude ()
@@ -152,6 +158,8 @@ import Servant.API.Empty
152158 (EmptyAPI (..))
153159import Servant.API.Experimental.Auth
154160 (AuthProtect)
161+import Servant.API.Fragment
162+ (Fragment)
155163import Servant.API.Generic
156164import Servant.API.Header
157165 (Header')
@@ -161,6 +169,8 @@ import Servant.API.IsSecure
161169 (IsSecure)
162170import Servant.API.Modifiers
163171 (FoldRequired)
172+import Servant.API.NamedRoutes
173+ (NamedRoutes)
164174import Servant.API.QueryParam
165175 (QueryFlag, QueryParam', QueryParams)
166176import Servant.API.Raw
@@ -173,7 +183,9 @@ import Servant.API.Stream
173183 (Stream, StreamBody')
174184import Servant.API.Sub
175185 (type (:>))
186+import Servant.API.TypeErrors
176187import Servant.API.TypeLevel
188+import Servant.API.UVerb
177189import Servant.API.Vault
178190 (Vault)
179191import Servant.API.Verbs
@@ -188,10 +200,13 @@ import Web.HttpApiData
188200data Link = Link
189201 { _segments :: [Escaped]
190202 , _queryParams :: [Param]
203+ , _fragment :: Fragment'
191204 } deriving Show
192205
193206newtype Escaped = Escaped String
194207
208+type Fragment' = Maybe String
209+
195210escaped :: String -> Escaped
196211escaped = Escaped . escapeURIString isUnreserved
197212
@@ -208,11 +223,14 @@ linkSegments = map getEscaped . _segments
208223linkQueryParams :: Link -> [Param]
209224linkQueryParams = _queryParams
210225
226+linkFragment :: Link -> Fragment'
227+linkFragment = _fragment
228+
211229instance ToHttpApiData Link where
212230 toHeader = TE.encodeUtf8 . toUrlPiece
213231 toUrlPiece l =
214232 let uri = linkURI l
215− in Text.pack $ uriPath uri ++ uriQuery uri
233+ in Text.pack $ uriPath uri ++ uriQuery uri ++ uriFragment uri
216234
217235-- | Query parameter.
218236data Param
@@ -228,6 +246,9 @@ addQueryParam :: Param -> Link -> Link
228246addQueryParam qp l =
229247 l { _queryParams = _queryParams l <> [qp] }
230248
249+addFragment :: Fragment' -> Link -> Link
250+addFragment fr l = l { _fragment = fr }
251+
231252-- | Transform 'Link' into 'URI'.
232253--
233254-- >>> type API = "something" :> Get '[JSON] Int
@@ -245,7 +266,7 @@ addQueryParam qp l =
245266-- >>> type SomeRoute = "abc" :> Capture "email" String :> Put '[JSON] ()
246267-- >>> let someRoute = Proxy :: Proxy SomeRoute
247268-- >>> safeLink someRoute someRoute "test@example.com"
248−-- Link {_segments = ["abc","test%40example.com"], _queryParams = []}
269+-- Link {_segments = ["abc","test%40example.com"], _queryParams = [], _fragment = Nothing}
249270--
250271-- >>> linkURI $ safeLink someRoute someRoute "test@example.com"
251272-- abc/test%40example.com
@@ -269,11 +290,12 @@ data LinkArrayElementStyle
269290-- sum?x=1&x=2&x=3
270291--
271292linkURI' :: LinkArrayElementStyle -> Link -> URI
272−linkURI' addBrackets (Link segments q_params) =
293+linkURI' addBrackets (Link segments q_params mfragment) =
273294 URI mempty -- No scheme (relative)
274295 Nothing -- Or authority (relative)
275296 (intercalate "/" $ map getEscaped segments)
276− (makeQueries q_params) mempty
297+ (makeQueries q_params)
298+ (makeFragment mfragment)
277299 where
278300 makeQueries :: [Param] -> String
279301 makeQueries [] = ""
@@ -285,6 +307,10 @@ linkURI' addBrackets (Link segments q_params) =
285307 makeQuery (SingleParam k v) = escape k <> "=" <> escape (Text.unpack v)
286308 makeQuery (FlagParam k) = escape k
287309
310+ makeFragment :: Fragment' -> String
311+ makeFragment Nothing = ""
312+ makeFragment (Just fr) = "#" <> escape fr
313+
288314 style = case addBrackets of
289315 LinkArrayElementBracket -> "[]="
290316 LinkArrayElementPlain -> "="
@@ -310,7 +336,7 @@ safeLink'
310336 -> Proxy api -- ^ The whole API that this endpoint is a part of
311337 -> Proxy endpoint -- ^ The API endpoint you would like to point to
312338 -> MkLink endpoint a
313−safeLink' toA _ endpoint = toLink toA endpoint (Link mempty mempty)
339+safeLink' toA _ endpoint = toLink toA endpoint (Link mempty mempty mempty)
314340
315341-- | Create all links in an API.
316342--
@@ -341,7 +367,7 @@ allLinks'
341367 => (Link -> a)
342368 -> Proxy api
343369 -> MkLink api a
344−allLinks' toA api = toLink toA api (Link mempty mempty)
370+allLinks' toA api = toLink toA api (Link mempty mempty mempty)
345371
346372-------------------------------------------------------------------------------
347373-- Generics
@@ -558,11 +584,51 @@ instance HasLink (Stream m status fr ct a) where
558584 type MkLink (Stream m status fr ct a) r = r
559585 toLink toA _ = toA
560586
587+-- UVerb instances
588+instance HasLink (UVerb m ct a) where
589+ type MkLink (UVerb m ct a) r = r
590+ toLink toA _ = toA
591+-- Instance for NamedRoutes combinator
592+
593+type GLinkConstraints routes a =
594+ ( MkLink (ToServant routes AsApi) a ~ ToServant routes (AsLink a)
595+ , GenericServant routes (AsLink a)
596+ )
597+
598+class GLink (routes :: * -> *) (a :: *) where
599+ gLinkProof :: Dict (GLinkConstraints routes a)
600+
601+instance GLinkConstraints routes a => GLink routes a where
602+ gLinkProof = Dict
603+
604+instance
605+ ( HasLink (ToServantApi routes)
606+ , forall a. GLink routes a
607+ ) => HasLink (NamedRoutes routes) where
608+
609+ type MkLink (NamedRoutes routes) a = routes (AsLink a)
610+
611+ toLink
612+ :: forall a. (Link -> a)
613+ -> Proxy (NamedRoutes routes)
614+ -> Link
615+ -> routes (AsLink a)
616+
617+ toLink toA _ l = case gLinkProof @routes @a of
618+ Dict -> fromServant $ toLink toA (Proxy @(ToServantApi routes)) l
619+
561620-- AuthProtext instances
562621instance HasLink sub => HasLink (AuthProtect tag :> sub) where
563622 type MkLink (AuthProtect tag :> sub) a = MkLink sub a
564623 toLink = simpleToLink (Proxy :: Proxy sub)
565624
625+instance (HasLink sub, ToHttpApiData v)
626+ => HasLink (Fragment v :> sub) where
627+ type MkLink (Fragment v :> sub) a = v -> MkLink sub a
628+ toLink toA _ l mv =
629+ toLink toA (Proxy :: Proxy sub) $
630+ addFragment ((Just . Text.unpack . toQueryParam) mv) l
631+
566632-- | Helper for implementing 'toLink' for combinators not affecting link
567633-- structure.
568634simpleToLink
@@ -579,3 +645,14 @@ simpleToLink _ toA _ = toLink toA (Proxy :: Proxy sub)
579645-- $setup
580646-- >>> import Servant.API
581647-- >>> import Data.Text (Text)
648+
649+-- Erroring instance for 'HasLink' when a combinator is not fully applied
650+instance TypeError (PartialApplication HasLink arr) => HasLink ((arr :: a -> b) :> sub)
651+ where
652+ type MkLink (arr :> sub) _ = TypeError (PartialApplication (HasLink :: * -> Constraint) arr)
653+ toLink = error "unreachable"
654+
655+-- Erroring instances for 'HasLink' for unknown API combinators
656+instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub HasLink ty) => HasLink (ty :> sub)
657+
658+instance {-# OVERLAPPABLE #-} TypeError (NoInstanceFor (HasLink api)) => HasLink api
servant/src/Servant/Test/ComprehensiveAPI.hs+2−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,7 @@ type ComprehensiveAPIWithoutStreamingOrRaw' endpoint =
7171 :<|> "summary" :> Summary "foo" :> GET
7272 :<|> "description" :> Description "foo" :> GET
7373 :<|> "alternative" :> ("left" :> GET :<|> "right" :> GET)
74+ :<|> "fragment" :> Fragment Int :> GET
7475 :<|> endpoint
7576
7677type ComprehensiveAPIWithoutStreamingOrRaw = ComprehensiveAPIWithoutStreamingOrRaw' EmptyEndpoint
servant/src/Servant/Types/SourceT.hs+1−1
@@ -319,7 +319,7 @@ fromActionStep stop action = loop where
319319-- | Read file.
320320--
321321-- >>> foreach fail BS.putStr (readFile "servant.cabal")
322−-- cabal-version: >=1.10
322+-- cabal-version: 2.2
323323-- name: servant
324324-- ...
325325--
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/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+15−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"
stack.yaml+2−1
@@ -1,4 +1,4 @@
1−resolver: lts-14.17
1+resolver: lts-18.5
22packages:
33- servant-client-core/
44- servant-client/
@@ -11,6 +11,7 @@ packages:
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/
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