git.iko.soy/servant
on b440691 help sign in
aaeee88
swap
0 ahead, 587 behind
333 files changed+3254−19391
since splitsnapshots
unifiedsplit
.github/FUNDING.yml−12 .github/run-ghcjs-tests.sh−14 .github/workflows/master.yml−148 .gitignore+1−10 .travis.yml+172 CONTRIBUTING.md+4−34 README.md+17−27 cabal.ghcjs.project+15−5 cabal.make-travis-yml+15 cabal.project+20−35 changelog.d/1432−9 changelog.d/1469−11 changelog.d/1477−9 changelog.d/1529−10 changelog.d/1556−81 changelog.d/1569−13 changelog.d/1571−10 changelog.d/1573−2 changelog.d/1580−12 changelog.d/1589−2 changelog.d/1595−2 changelog.d/1606−10 changelog.d/1638−2 changelog.d/1649−8 changelog.d/config−2 changelog.d/servant-docs-curl−16 default.nix−38 doc/Makefile+1−3 doc/README.md−8 doc/building-the-docs+8 doc/conf.py+3−1 doc/cookbook/basic-auth/basic-auth.cabal+4−4 doc/cookbook/basic-streaming/Streaming.lhs−129 doc/cookbook/basic-streaming/basic-streaming.cabal−28 doc/cookbook/cabal.project−2 doc/cookbook/cabal.project.local doc/cookbook/curl-mock/CurlMock.lhs+23−10 doc/cookbook/curl-mock/curl-mock.cabal+5−7 doc/cookbook/custom-errors/CustomErrors.lhs−189 doc/cookbook/custom-errors/custom-errors.cabal−25 doc/cookbook/db-mysql-basics/MysqlBasics.lhs−236 doc/cookbook/db-mysql-basics/mysql-basics.cabal−40 doc/cookbook/db-postgres-pool/db-postgres-pool.cabal+4−4 doc/cookbook/db-sqlite-simple/db-sqlite-simple.cabal+5−5 doc/cookbook/file-upload/FileUpload.lhs+4−4 doc/cookbook/file-upload/file-upload.cabal+4−4 doc/cookbook/generic/Generic.lhs+7−42 doc/cookbook/generic/generic.cabal+4−4 doc/cookbook/hoist-server-with-context/HoistServerWithContext.lhs+4−11 doc/cookbook/hoist-server-with-context/hoist-server-with-context.cabal+5−6 doc/cookbook/https/Https.lhs+5−5 doc/cookbook/https/https.cabal+5−5 doc/cookbook/index.rst+2−8 doc/cookbook/jwt-and-basic-auth/jwt-and-basic-auth.cabal+5−5 doc/cookbook/managed-resource/ManagedResource.lhs−114 doc/cookbook/managed-resource/managed-resource.cabal−30 doc/cookbook/open-id-connect/OpenIdConnect.cabal−45 doc/cookbook/open-id-connect/OpenIdConnect.lhs−472 doc/cookbook/pagination/Pagination.lhs+8−8 doc/cookbook/pagination/pagination.cabal+5−5 doc/cookbook/sentry/Sentry.lhs+2−2 doc/cookbook/sentry/sentry.cabal+4−4 doc/cookbook/structuring-apis/StructuringApis.lhs+1−1 doc/cookbook/structuring-apis/structuring-apis.cabal+4−4 doc/cookbook/testing/Testing.lhs+15−13 doc/cookbook/testing/testing.cabal+5−5 doc/cookbook/using-custom-monad/UsingCustomMonad.lhs+1−4 doc/cookbook/using-custom-monad/using-custom-monad.cabal+4−4 doc/cookbook/using-free-client/UsingFreeClient.lhs+9−7 doc/cookbook/using-free-client/using-free-client.cabal+4−4 doc/cookbook/uverb/UVerb.lhs−223 doc/cookbook/uverb/uverb.cabal−35 doc/examples.md+1−1 doc/links.rst+3−3 doc/requirements.txt+3−4 doc/tutorial/ApiType.lhs+9−42 doc/tutorial/Authentication.lhs+11−10 doc/tutorial/Client.lhs+26−26 doc/tutorial/Docs.lhs+2−2 doc/tutorial/Javascript.lhs+2−2 doc/tutorial/Server.lhs+41−55 doc/tutorial/index.rst+20−1 doc/tutorial/install.rst−68 doc/tutorial/test/Spec.hs+1−11 doc/tutorial/tinc.yaml+13 doc/tutorial/tutorial.cabal+17−11 ghcjs.nix−22 nix/README.md−18 nix/nixpkgs.json−4 nix/nixpkgs.nix−4 nix/shell.nix+18−17 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−135 servant-auth/servant-auth-server/src/Servant/Auth/Server.hs−180 servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal.hs−67 servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/AddSetCookie.hs−119 servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/BasicAuth.hs−59 servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/Class.hs−72 servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/ConfigTypes.hs−127 servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/Cookie.hs−183 servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/FormLogin.hs−3 servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/JWT.hs−68 servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/ThrowAll.hs−58 servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/Types.hs−113 servant-auth/servant-auth-server/src/Servant/Auth/Server/SetCookieOrphan.hs−3 servant-auth/servant-auth-server/test/Servant/Auth/ServerSpec.hs−634 servant-auth/servant-auth-server/test/Spec.hs−1 servant-auth/servant-auth-swagger/.ghci−1 servant-auth/servant-auth-swagger/CHANGELOG.md−24 servant-auth/servant-auth-swagger/LICENSE−31 servant-auth/servant-auth-swagger/Setup.hs−2 servant-auth/servant-auth-swagger/servant-auth-swagger.cabal−70 servant-auth/servant-auth-swagger/src/Servant/Auth/Swagger.hs−87 servant-auth/servant-auth-swagger/test/Servant/Auth/SwaggerSpec.hs−38 servant-auth/servant-auth-swagger/test/Spec.hs−1 servant-auth/servant-auth/.ghci−1 servant-auth/servant-auth/CHANGELOG.md−20 servant-auth/servant-auth/LICENSE−31 servant-auth/servant-auth/Setup.hs−2 servant-auth/servant-auth/servant-auth.cabal−47 servant-auth/servant-auth/src/Servant/Auth.hs−54 servant-auth/servant-auth/src/Servant/Auth/JWT.hs−40 servant-auth/servant-auth/test/Spec.hs−1 servant-client-core/CHANGELOG.md+2−234 servant-client-core/LICENSE+1−1 servant-client-core/servant-client-core.cabal+39−48 servant-client-core/src/Servant/Client/Core.hs+16−24 servant-client-core/src/Servant/Client/Core/ClientError.hs−86 servant-client-core/src/Servant/Client/Core/Internal.hs−12 servant-client-core/src/Servant/Client/Core/Auth.hs → servant-client-core/src/Servant/Client/Core/Internal/Auth.hs+2−6 servant-client-core/src/Servant/Client/Core/BaseUrl.hs → servant-client-core/src/Servant/Client/Core/Internal/BaseUrl.hs+1−12 servant-client-core/src/Servant/Client/Core/BasicAuth.hs → servant-client-core/src/Servant/Client/Core/Internal/BasicAuth.hs+5−4 servant-client-core/src/Servant/Client/Core/Internal/ClientF.hs+10 servant-client-core/src/Servant/Client/Core/Internal/Generic.hs+155 servant-client-core/src/Servant/Client/Core/HasClient.hs → servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs+89−443 servant-client-core/src/Servant/Client/Core/Internal/Request.hs+138 servant-client-core/src/Servant/Client/Core/Internal/RunClient.hs+60 servant-client-core/src/Servant/Client/Core/Reexport.hs+10−13 servant-client-core/src/Servant/Client/Core/Request.hs−192 servant-client-core/src/Servant/Client/Core/Response.hs−53 servant-client-core/src/Servant/Client/Core/RunClient.hs−55 servant-client-core/src/Servant/Client/Free.hs+1−1 servant-client-core/src/Servant/Client/Generic.hs+11−8 servant-client-core/test/Servant/Client/Core/Internal/BaseUrlSpec.hs+1−1 servant-client-core/test/Servant/Client/Core/RequestSpec.hs−31 servant-client-ghcjs/LICENSE+1−1 servant-client-ghcjs/README.md+2−2 servant-client-ghcjs/servant-client-ghcjs.cabal+36−46 servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs+48−52 servant-client-ghcjs/tinc.yaml+5 servant-client/CHANGELOG.md+2−238 servant-client/LICENSE+1−1 servant-client/servant-client.cabal+43−69 servant-client/src/Servant/Client.hs−1 servant-client/src/Servant/Client/Internal/HttpClient.hs+90−148 servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs−203 servant-client/src/Servant/Client/Streaming.hs−19 servant-client/test/Servant/BasicAuthSpec.hs−53 servant-client/test/Servant/BrokenSpec.hs−71 servant-http-streams/test/Servant/ClientSpec.hs → servant-client/test/Servant/ClientSpec.hs+105−71 servant-client/test/Servant/ClientTestUtils.hs−384 servant-client/test/Servant/ConnectionErrorSpec.hs−55 servant-client/test/Servant/FailSpec.hs−79 servant-client/test/Servant/GenAuthSpec.hs−54 servant-client/test/Servant/GenericSpec.hs−37 servant-client/test/Servant/HoistClientSpec.hs−58 servant-client/test/Servant/StreamSpec.hs+73−109 servant-client/test/Servant/SuccessSpec.hs−208 servant-client/test/Servant/WrappedApiSpec.hs−63 servant-client/tinc.yaml+5 servant-conduit/CHANGELOG.md−4 servant-conduit/LICENSE−30 servant-conduit/README.md−3 servant-conduit/Setup.hs−2 servant-conduit/example/Main.hs−103 servant-conduit/servant-conduit.cabal−62 servant-conduit/src/Servant/Conduit.hs−72 servant-docs/CHANGELOG.md−91 servant-docs/LICENSE+1−1 servant-docs/README.md+11−44 servant-docs/example/greet.hs+4−4 servant-docs/example/greet.md+27−55 servant-docs/golden/comprehensive.md−610 servant-docs/servant-docs.cabal+31−32 servant-docs/src/Servant/Docs/Internal.hs+72−229 servant-docs/src/Servant/Docs/Internal/Pretty.hs−19 servant-docs/test/Servant/DocsSpec.hs+25−97 servant-docs/test/Spec.hs+1−8 servant-docs/tinc.yaml+3 servant-foreign/CHANGELOG.md−99 servant-foreign/LICENSE+1−1 servant-foreign/servant-foreign.cabal+22−20 servant-foreign/src/Servant/Foreign.hs+18−23 servant-foreign/src/Servant/Foreign/Inflections.hs+13−18 servant-foreign/src/Servant/Foreign/Internal.hs+35−169 servant-foreign/test/Servant/ForeignSpec.hs+4−12 servant-foreign/tinc.yaml+3 servant-http-streams/CHANGELOG.md−98 servant-http-streams/LICENSE−30 servant-http-streams/README.lhs−1 servant-http-streams/README.md−44 servant-http-streams/Setup.hs−2 servant-http-streams/servant-http-streams.cabal−132 servant-http-streams/src/Servant/HttpStreams.hs−19 servant-http-streams/src/Servant/HttpStreams/Internal.hs−258 servant-http-streams/test/Servant/StreamSpec.hs−110 servant-http-streams/test/Spec.hs−1 servant-machines/CHANGELOG.md−4 servant-machines/LICENSE−30 servant-machines/README.md−3 servant-machines/Setup.hs−2 servant-machines/example/Main.hs−98 servant-machines/servant-machines.cabal−59 servant-machines/src/Servant/Machines.hs−46 servant-pipes/CHANGELOG.md−22 servant-pipes/LICENSE−30 servant-pipes/README.md−3 servant-pipes/Setup.hs−2 servant-pipes/example/Main.hs−107 servant-pipes/servant-pipes.cabal−63 servant-pipes/src/Servant/Pipes.hs−75 servant-server/CHANGELOG.md−193 servant-server/LICENSE+1−1 servant-server/README.md+1−1 servant-server/Setup.hs+32−1 servant-server/example/README.md+1−1 servant-server/example/greet.hs+3−19 servant-server/servant-server.cabal+71−55 servant-server/src/Servant/Server.hs+12−65 servant-server/src/Servant/Server/Experimental/Auth.hs+6−5 servant-server/src/Servant/Server/Generic.hs+19−59 servant-server/src/Servant/Server/Internal.hs+143−376 servant-server/src/Servant/Server/Internal/BasicAuth.hs+6−4 servant-server/src/Servant/Server/Internal/Context.hs+9−24 servant-server/src/Servant/Server/Internal/Delayed.hs−272 servant-server/src/Servant/Server/Internal/DelayedIO.hs−71 servant-server/src/Servant/Server/Internal/ErrorFormatter.hs−87 servant-server/src/Servant/Server/Internal/Handler.hs+9−14 servant-server/src/Servant/Server/Internal/RouteResult.hs−76 servant-server/src/Servant/Server/Internal/Router.hs+37−85 servant-server/src/Servant/Server/Internal/RoutingApplication.hs+383−4 servant-server/src/Servant/Server/Internal/ServerError.hs → servant-server/src/Servant/Server/Internal/ServantErr.hs+74−76 servant-server/src/Servant/Server/UVerb.hs−116 servant-server/test/Servant/Server/ErrorSpec.hs+2−58 servant-server/test/Servant/Server/Internal/ContextSpec.hs+1−1 servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs+3−3 servant-server/test/Servant/Server/RouterSpec.hs+16−162 servant-server/test/Servant/ServerSpec.hs+140−356 servant-server/test/doctests.hs+27 servant-server/tinc.yaml+3 servant-swagger/CHANGELOG.md−143 servant-swagger/LICENSE−28 servant-swagger/README.md−46 servant-swagger/Setup.hs−33 servant-swagger/example/LICENSE−28 servant-swagger/example/example.cabal−62 servant-swagger/example/server/Main.hs−11 servant-swagger/example/src/Todo.hs−73 servant-swagger/example/swagger.json−158 servant-swagger/example/test/Spec.hs−1 servant-swagger/example/test/TodoSpec.hs−28 servant-swagger/servant-swagger.cabal−127 servant-swagger/src/Servant/Swagger.hs−188 servant-swagger/src/Servant/Swagger/Internal.hs−492 servant-swagger/src/Servant/Swagger/Internal/Orphans.hs−27 servant-swagger/src/Servant/Swagger/Internal/Test.hs−207 servant-swagger/src/Servant/Swagger/Internal/TypeLevel.hs−9 servant-swagger/src/Servant/Swagger/Internal/TypeLevel/API.hs−86 servant-swagger/src/Servant/Swagger/Internal/TypeLevel/Every.hs−63 servant-swagger/src/Servant/Swagger/Internal/TypeLevel/TMap.hs−37 servant-swagger/src/Servant/Swagger/Test.hs−13 servant-swagger/src/Servant/Swagger/TypeLevel.hs−15 servant-swagger/test/Servant/SwaggerSpec.hs−489 servant-swagger/test/Spec.hs−1 servant-swagger/test/doctests.hs−12 servant/CHANGELOG.md+11−541 servant/LICENSE+1−1 servant/Setup.hs+32−1 servant/servant.cabal+73−73 servant/src/Servant/API.hs+13−33 servant/src/Servant/API/Alternative.hs+2 servant/src/Servant/API/ContentTypes.hs+3−7 servant/src/Servant/API/Description.hs+2−2 servant/src/Servant/API/Fragment.hs−25 servant/src/Servant/API/Header.hs+1−1 servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs+50 servant/src/Servant/API/Modifiers.hs+2 servant/src/Servant/API/NamedRoutes.hs−10 servant/src/Servant/API/Raw.hs+2−6 servant/src/Servant/API/ResponseHeaders.hs+9−86 servant/src/Servant/API/Status.hs−160 servant/src/Servant/API/Stream.hs+173−195 servant/src/Servant/API/TypeErrors.hs−40 servant/src/Servant/API/TypeLevel.hs+13−63 servant/src/Servant/API/UVerb.hs−127 servant/src/Servant/API/UVerb/Union.hs−147 servant/src/Servant/API/Verbs.hs+6−13 servant/src/Servant/API/WithResource.hs−3 servant/src/Servant/Links.hs+16−122 servant/src/Servant/Test/ComprehensiveAPI.hs−81 servant/src/Servant/Types/SourceT.hs−384 servant/src/Servant/Utils/Links.hs+6 servant/test/Servant/API/ContentTypesSpec.hs+6−31 servant/test/Servant/API/ResponseHeadersSpec.hs−11 servant/test/Servant/API/StreamSpec.hs−99 servant/test/Servant/LinksSpec.hs+3−20 servant/test/doctests.hs+27 stack.yaml+10−9 stack.yaml.lock−19 streaming-benchmark.sh−268
.github/FUNDING.ymldeleted−12
@@ -1,12 +0,0 @@
1−# These are supported funding model platforms
2−
3−github: [arianvp]
4−patreon: # Replace with a single Patreon username
5−open_collective: # Replace with a single Open Collective username
6−ko_fi: # Replace with a single Ko-fi username
7−tidelift: # Replace with a single Tidelift platform-name/package-name e.g., npm/babel
8−community_bridge: # Replace with a single Community Bridge project-name e.g., cloud-foundry
9−liberapay: # Replace with a single Liberapay username
10−issuehunt: # Replace with a single IssueHunt username
11−otechie: # Replace with a single Otechie username
12−custom: https://github.com/haskell-servant/haskell-servant.github.io/blob/hakyll/consultancies.md
.github/run-ghcjs-tests.shdeleted−14
@@ -1,14 +0,0 @@
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.ymldeleted−148
@@ -1,148 +0,0 @@
1−name: CI
2−
3−# Trigger the workflow on push or pull request, but only for the master branch
4−on:
5− pull_request:
6− push:
7− branches: [master]
8−
9−jobs:
10− cabal:
11− name: ${{ matrix.os }} / ghc ${{ matrix.ghc }}
12− runs-on: ${{ matrix.os }}
13− strategy:
14− matrix:
15− os: [ubuntu-latest]
16− cabal: ["3.6"]
17− ghc:
18− - "8.6.5"
19− - "8.8.4"
20− - "8.10.7"
21− - "9.0.2"
22− - "9.2.2"
23− - "9.4.2"
24−
25− steps:
26− - uses: actions/checkout@v2
27−
28− - uses: haskell/actions/setup@v1
29− id: setup-haskell-cabal
30− name: Setup Haskell
31− with:
32− ghc-version: ${{ matrix.ghc }}
33− cabal-version: ${{ matrix.cabal }}
34−
35− - name: Freeze
36− run: |
37− cabal configure --enable-tests --enable-benchmarks --test-show-details=direct
38− cabal freeze
39−
40− - uses: actions/cache@v2.1.3
41− name: Cache ~/.cabal/store and dist-newstyle
42− with:
43− path: |
44− ${{ steps.setup-haskell-cabal.outputs.cabal-store }}
45− dist-newstyle
46− key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }}
47− restore-keys: |
48− ${{ runner.os }}-${{ matrix.ghc }}-
49−
50− - name: Configure
51− run: |
52− cabal install --ignore-project -j2 doctest --constraint='doctest ^>=0.20'
53−
54− - name: Build
55− run: |
56− cabal build all
57−
58− - name: Test
59− run: |
60− cabal test all
61−
62− - name: Run doctests
63− run: |
64− # Necessary for doctest to be found in $PATH
65− export PATH="$HOME/.cabal/bin:$PATH"
66−
67− DOCTEST="cabal repl --with-ghc=doctest --ghc-options=-w"
68− (cd servant && eval $DOCTEST)
69− (cd servant-client && eval $DOCTEST)
70− (cd servant-client-core && eval $DOCTEST)
71− (cd servant-http-streams && eval $DOCTEST)
72− (cd servant-docs && eval $DOCTEST)
73− (cd servant-foreign && eval $DOCTEST)
74− (cd servant-server && eval $DOCTEST)
75− (cd servant-machines && eval $DOCTEST)
76− (cd servant-conduit && eval $DOCTEST)
77− (cd servant-pipes && eval $DOCTEST)
78−
79− # stack:
80− # name: stack / ghc ${{ matrix.ghc }}
81− # runs-on: ubuntu-latest
82− # strategy:
83− # matrix:
84− # stack: ["2.7.5"]
85− # ghc: ["8.10.7"]
86−
87− # steps:
88− # - uses: actions/checkout@v2
89−
90− # - uses: haskell/actions/setup@v1
91− # name: Setup Haskell Stack
92− # with:
93− # ghc-version: ${{ matrix.ghc }}
94− # stack-version: ${{ matrix.stack }}
95−
96− # - uses: actions/cache@v2.1.3
97− # name: Cache ~/.stack
98− # with:
99− # path: ~/.stack
100− # key: ${{ runner.os }}-${{ matrix.ghc }}-stack
101−
102− # - name: Install dependencies
103− # run: |
104− # stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks --only-dependencies
105−
106− # - name: Build
107− # run: |
108− # stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks
109−
110− # - name: Test
111− # run: |
112− # stack test --system-ghc
113−
114− ghcjs:
115− name: ubuntu-latest / ghcjs 8.6
116− runs-on: "ubuntu-latest"
117−
118− steps:
119− - uses: actions/checkout@v2
120− - uses: cachix/install-nix-action@v13
121− with:
122− extra_nix_config: |
123− trusted-public-keys = ryantrinkle.com-1:JJiAKaRv9mWgpVAz8dwewnZe0AzzEAzPkagE9SP5NWI=1aba6f367982bd6dd78ec2fda75ab246a62d32c5 cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY=
124− substituters = https://nixcache.reflex-frp.org https://cache.nixos.org/
125− - name: Setup
126− run: |
127− # Override cabal.project with the lightweight GHCJS one
128− cp cabal.ghcjs.project cabal.project
129− cat cabal.project
130− nix-shell ghcjs.nix --run "cabal v2-update && cabal v2-freeze"
131−
132− - uses: actions/cache@v2.1.3
133− name: Cache ~/.cabal/store and dist-newstyle
134− with:
135− path: |
136− ~/.cabal/store
137− dist-newstyle
138− key: ${{ runner.os }}-ghcjs8.6-${{ hashFiles('cabal.project.freeze') }}
139− restore-keys: |
140− ${{ runner.os }}-ghcjs8.6-
141−
142− - name: Build
143− run: |
144− nix-shell ghcjs.nix --run "cabal v2-build --ghcjs --enable-tests --enable-benchmarks all"
145−
146− - name: Tests
147− run: |
148− nix-shell ghcjs.nix --run ".github/run-ghcjs-tests.sh"
.gitignore+1−10
@@ -1,6 +1,5 @@
11**/*/dist
2−*~
3−dist-*
2+dist-newstyle
43.ghc.environment.*
54/bin
65/lib
@@ -30,11 +29,3 @@ doc/_build
3029doc/venv
3130doc/tutorial/static/api.js
3231doc/tutorial/static/jq.js
33−shell.nix
34−.hspec-failures
35−
36−# nix
37−result*
38−
39−# local versions of things
40−servant-multipart
.travis.ymlnew file+172
@@ -0,0 +1,172 @@
1+# This Travis job script has been generated by a script via
2+#
3+# runghc make_travis_yml_2.hs '--config=cabal.make-travis-yml' '--output=.travis.yml' 'cabal.project'
4+#
5+# For more information, see https://github.com/haskell-CI/haskell-ci
6+#
7+language: c
8+sudo: false
9+
10+git:
11+ submodules: false # whether to recursively clone submodules
12+
13+branches:
14+ only:
15+ - master
16+
17+cache:
18+ directories:
19+ - $HOME/.cabal/packages
20+ - $HOME/.cabal/store
21+
22+before_cache:
23+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log
24+ # remove files that are regenerated by 'cabal update'
25+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.*
26+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json
27+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache
28+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar
29+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx
30+
31+ - rm -rfv $HOME/.cabal/packages/head.hackage
32+
33+matrix:
34+ include:
35+ - compiler: "ghc-8.6.1"
36+ # env: TEST=--disable-tests BENCH=--disable-benchmarks
37+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.6.1], sources: [hvr-ghc]}}
38+ - compiler: "ghc-8.4.4"
39+ # env: TEST=--disable-tests BENCH=--disable-benchmarks
40+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.4.4], sources: [hvr-ghc]}}
41+ - compiler: "ghc-8.2.2"
42+ # env: TEST=--disable-tests BENCH=--disable-benchmarks
43+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.2.2], sources: [hvr-ghc]}}
44+ - compiler: "ghc-8.0.2"
45+ # env: TEST=--disable-tests BENCH=--disable-benchmarks
46+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.0.2], sources: [hvr-ghc]}}
47+
48+before_install:
49+ - HC=${CC}
50+ - HCPKG=${HC/ghc/ghc-pkg}
51+ - unset CC
52+ - ROOTDIR=$(pwd)
53+ - mkdir -p $HOME/.local/bin
54+ - "PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$HOME/local/bin:$PATH"
55+ - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') ))
56+ - echo $HCNUMVER
57+
58+install:
59+ - cabal --version
60+ - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"
61+ - BENCH=${BENCH---enable-benchmarks}
62+ - TEST=${TEST---enable-tests}
63+ - HADDOCK=${HADDOCK-true}
64+ - UNCONSTRAINED=${UNCONSTRAINED-true}
65+ - NOINSTALLEDCONSTRAINTS=${NOINSTALLEDCONSTRAINTS-false}
66+ - GHCHEAD=${GHCHEAD-false}
67+ - travis_retry cabal update -v
68+ - "sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config"
69+ - rm -fv cabal.project cabal.project.local
70+ - "if [ $HCNUMVER -ge 70800 ]; then sed -i.bak 's/-- ghc-options:.*/ghc-options: -j2/' ${HOME}/.cabal/config; fi"
71+ - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$'
72+ - "printf 'packages: \"servant\" \"servant-client\" \"servant-client-core\" \"servant-docs\" \"servant-foreign\" \"servant-server\" \"doc/tutorial\" \"doc/cookbook/basic-auth\" \"doc/cookbook/curl-mock\" \"doc/cookbook/db-postgres-pool\" \"doc/cookbook/db-sqlite-simple\" \"doc/cookbook/file-upload\" \"doc/cookbook/generic\" \"doc/cookbook/https\" \"doc/cookbook/sentry\" \"doc/cookbook/testing\" \"doc/cookbook/structuring-apis\" \"doc/cookbook/using-custom-monad\" \"doc/cookbook/using-free-client\"\\n' > cabal.project"
73+ - "echo 'constraints: foundation >=0.0.14,memory <0.14.12 || >0.14.12' >> cabal.project"
74+ - "echo 'allow-newer: servant-auth-server:http-types,servant-auth-server:servant-server,servant-js:base, servant-pagination:servant,servant-pagination:servant-server' >> cabal.project"
75+ - touch cabal.project.local
76+ - "if ! $NOINSTALLEDCONSTRAINTS; then for pkg in $($HCPKG list --simple-output); do echo $pkg | grep -vw -- servant | grep -vw -- servant-client | grep -vw -- servant-client-core | grep -vw -- servant-docs | grep -vw -- servant-foreign | grep -vw -- servant-server | grep -vw -- tutorial | grep -vw -- cookbook-basic-auth | grep -vw -- cookbook-curl-mock | grep -vw -- cookbook-db-postgres-pool | grep -vw -- cookbook-db-sqlite-simple | grep -vw -- cookbook-file-upload | grep -vw -- cookbook-generic | grep -vw -- cookbook-https | grep -vw -- cookbook-sentry | grep -vw -- cookbook-testing | grep -vw -- cookbook-structuring-apis | grep -vw -- cookbook-using-custom-monad | grep -vw -- cookbook-using-free-client | sed 's/^/constraints: /' | sed 's/-[^-]*$/ installed/' >> cabal.project.local; done; fi"
77+ - cat cabal.project || true
78+ - cat cabal.project.local || true
79+ - if [ -f "servant/configure.ac" ]; then
80+ (cd "servant" && autoreconf -i);
81+ fi
82+ - if [ -f "servant-client/configure.ac" ]; then
83+ (cd "servant-client" && autoreconf -i);
84+ fi
85+ - if [ -f "servant-client-core/configure.ac" ]; then
86+ (cd "servant-client-core" && autoreconf -i);
87+ fi
88+ - if [ -f "servant-docs/configure.ac" ]; then
89+ (cd "servant-docs" && autoreconf -i);
90+ fi
91+ - if [ -f "servant-foreign/configure.ac" ]; then
92+ (cd "servant-foreign" && autoreconf -i);
93+ fi
94+ - if [ -f "servant-server/configure.ac" ]; then
95+ (cd "servant-server" && autoreconf -i);
96+ fi
97+ - if [ -f "doc/tutorial/configure.ac" ]; then
98+ (cd "doc/tutorial" && autoreconf -i);
99+ fi
100+ - if [ -f "doc/cookbook/basic-auth/configure.ac" ]; then
101+ (cd "doc/cookbook/basic-auth" && autoreconf -i);
102+ fi
103+ - if [ -f "doc/cookbook/curl-mock/configure.ac" ]; then
104+ (cd "doc/cookbook/curl-mock" && autoreconf -i);
105+ fi
106+ - if [ -f "doc/cookbook/db-postgres-pool/configure.ac" ]; then
107+ (cd "doc/cookbook/db-postgres-pool" && autoreconf -i);
108+ fi
109+ - if [ -f "doc/cookbook/db-sqlite-simple/configure.ac" ]; then
110+ (cd "doc/cookbook/db-sqlite-simple" && autoreconf -i);
111+ fi
112+ - if [ -f "doc/cookbook/file-upload/configure.ac" ]; then
113+ (cd "doc/cookbook/file-upload" && autoreconf -i);
114+ fi
115+ - if [ -f "doc/cookbook/generic/configure.ac" ]; then
116+ (cd "doc/cookbook/generic" && autoreconf -i);
117+ fi
118+ - if [ -f "doc/cookbook/https/configure.ac" ]; then
119+ (cd "doc/cookbook/https" && autoreconf -i);
120+ fi
121+ - if [ -f "doc/cookbook/sentry/configure.ac" ]; then
122+ (cd "doc/cookbook/sentry" && autoreconf -i);
123+ fi
124+ - if [ -f "doc/cookbook/testing/configure.ac" ]; then
125+ (cd "doc/cookbook/testing" && autoreconf -i);
126+ fi
127+ - if [ -f "doc/cookbook/structuring-apis/configure.ac" ]; then
128+ (cd "doc/cookbook/structuring-apis" && autoreconf -i);
129+ fi
130+ - if [ -f "doc/cookbook/using-custom-monad/configure.ac" ]; then
131+ (cd "doc/cookbook/using-custom-monad" && autoreconf -i);
132+ fi
133+ - if [ -f "doc/cookbook/using-free-client/configure.ac" ]; then
134+ (cd "doc/cookbook/using-free-client" && autoreconf -i);
135+ fi
136+ - rm -f cabal.project.freeze
137+ - rm -rf .ghc.environment.* "servant"/dist "servant-client"/dist "servant-client-core"/dist "servant-docs"/dist "servant-foreign"/dist "servant-server"/dist "doc/tutorial"/dist "doc/cookbook/basic-auth"/dist "doc/cookbook/curl-mock"/dist "doc/cookbook/db-postgres-pool"/dist "doc/cookbook/db-sqlite-simple"/dist "doc/cookbook/file-upload"/dist "doc/cookbook/generic"/dist "doc/cookbook/https"/dist "doc/cookbook/sentry"/dist "doc/cookbook/testing"/dist "doc/cookbook/structuring-apis"/dist "doc/cookbook/using-custom-monad"/dist "doc/cookbook/using-free-client"/dist
138+ - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
139+
140+# Here starts the actual work to be performed for the package under test;
141+# any command which exits with a non-zero exit code causes the build to fail.
142+script:
143+ # test that source-distributions can be generated
144+ - echo Packaging... && echo -en 'travis_fold:start:sdist\\r'
145+ - cabal new-sdist all
146+ - echo -en 'travis_fold:end:sdist\\r'
147+ - echo Unpacking... && echo -en 'travis_fold:start:unpack\\r'
148+ - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/
149+ - cd ${DISTDIR} || false
150+ - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \;
151+ - "printf 'packages: servant-*/*.cabal servant-client-*/*.cabal servant-client-core-*/*.cabal servant-docs-*/*.cabal servant-foreign-*/*.cabal servant-server-*/*.cabal tutorial-*/*.cabal cookbook-basic-auth-*/*.cabal cookbook-curl-mock-*/*.cabal cookbook-db-postgres-pool-*/*.cabal cookbook-db-sqlite-simple-*/*.cabal cookbook-file-upload-*/*.cabal cookbook-generic-*/*.cabal cookbook-https-*/*.cabal cookbook-sentry-*/*.cabal cookbook-testing-*/*.cabal cookbook-structuring-apis-*/*.cabal cookbook-using-custom-monad-*/*.cabal cookbook-using-free-client-*/*.cabal\\n' > cabal.project"
152+ - "echo 'constraints: foundation >=0.0.14,memory <0.14.12 || >0.14.12' >> cabal.project"
153+ - "echo 'allow-newer: servant-auth-server:http-types,servant-auth-server:servant-server,servant-js:base, servant-pagination:servant,servant-pagination:servant-server' >> cabal.project"
154+ - touch cabal.project.local
155+ - "if ! $NOINSTALLEDCONSTRAINTS; then for pkg in $($HCPKG list --simple-output); do echo $pkg | grep -vw -- servant | grep -vw -- servant-client | grep -vw -- servant-client-core | grep -vw -- servant-docs | grep -vw -- servant-foreign | grep -vw -- servant-server | grep -vw -- tutorial | grep -vw -- cookbook-basic-auth | grep -vw -- cookbook-curl-mock | grep -vw -- cookbook-db-postgres-pool | grep -vw -- cookbook-db-sqlite-simple | grep -vw -- cookbook-file-upload | grep -vw -- cookbook-generic | grep -vw -- cookbook-https | grep -vw -- cookbook-sentry | grep -vw -- cookbook-testing | grep -vw -- cookbook-structuring-apis | grep -vw -- cookbook-using-custom-monad | grep -vw -- cookbook-using-free-client | sed 's/^/constraints: /' | sed 's/-[^-]*$/ installed/' >> cabal.project.local; done; fi"
156+ - cat cabal.project || true
157+ - cat cabal.project.local || true
158+ - echo -en 'travis_fold:end:unpack\\r'
159+
160+ - echo Building with tests and benchmarks... && echo -en 'travis_fold:start:build-everything\\r'
161+ # build & run tests, build benchmarks
162+ - cabal new-build -w ${HC} ${TEST} ${BENCH} all
163+ - echo -en 'travis_fold:end:build-everything\\r'
164+ - if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} ${BENCH} all; fi
165+
166+ - echo Haddock... && echo -en 'travis_fold:start:haddock\\r'
167+ # haddock
168+ - if $HADDOCK; then cabal new-haddock -w ${HC} ${TEST} ${BENCH} all; else echo "Skipping haddock generation";fi
169+
170+ - echo -en 'travis_fold:end:haddock\\r'
171+# REGENDATA ["--config=cabal.make-travis-yml","--output=.travis.yml","cabal.project"]
172+# EOF
CONTRIBUTING.md+4−34
@@ -21,7 +21,6 @@ Or `nix`:
2121./scripts/generate-nix-files.sh # Get up-to-date shell.nix files
2222```
2323
24−To build the docs, see `doc/README.md`.
2524
2625## General
2726
@@ -35,34 +34,7 @@ Some things we like:
3534Though we aren't sticklers for style, the `.stylish-haskell.yaml` and `HLint.hs`
3635files in the repository provide a good baseline for consistency.
3736
38−**Important**: please do not modify the versions of the servant packages you are sending patches for.
39−
40−## Changelog entries
41−
42−We experiment with using [changelog-d tool](https://github.com/phadej/changelog-d) to assemble changelogs.
43−You are not required to install it.
44−
45−In each PR please add a file to `changelog.d` directory named after issue you are solving or the pull request itself (in a separate commit after you know the pull request number). For example
46−
47−```cabal
48−synopsis: One sentence summary of the change.
49−prs: #1219
50−issues: #1028
51−
52−description: {
53−
54−A longer description. Small changes don't need this.
55−Bigger ones definitely do, for example we try to include migration hints
56−for breaking changes.
57−
58−However if you don't know what to write, that's ok too.
59−
60−By the way, the braces around are omitted when the file is parsed.
61−They can be used so the field doesn't need to be indented, which is handy
62−for prose.
63−
64−}
65−```
37+**Important**: please do not modify the changelog files nor the versions of the servant packages you are sending patches for. We take care of this before every release and do it uniformly for all the servant packages, so there's no need to worry about this for your pull requests.
6638
6739## PR process
6840
@@ -79,10 +51,8 @@ not been a timely response to a PR, you can ping the Maintainers group (with
7951We encourage people to experiment with new combinators and instances - it is
8052one of the most powerful ways of using `servant`, and a wonderful way of
8153getting to know it better. If you do write a new combinator, we would love to
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).
54+know about it! Either hop on #servant on freenode and let us know, or open an
55+issue with the `news` tag (which we will close when we read it).
8656
8757As for adding them to the main repo: maintaining combinators can be expensive,
8858since official combinators must have instances for all classes (and new classes
@@ -105,7 +75,7 @@ the `news` label if you make a new package so we can know about it!
10575
10676## Release policy
10777
108−We are currently moving to a more aggressive release policy, so that you can get
78+We are currently moving to a more aggresive release policy, so that you can get
10979what you contribute from Hackage fairly soon. However, note that prior to major
11080releases it may take some time in between releases.
11181
README.md+17−27
@@ -4,16 +4,16 @@
44
55## Getting Started
66
7−We have a [tutorial](http://docs.servant.dev/en/stable/tutorial/index.html) that
7+We have a [tutorial](http://haskell-servant.readthedocs.org/en/stable/tutorial/index.html) that
88introduces the core features of servant. After this article, you should be able
99to write your first servant webservices, learning the rest from the haddocks'
1010examples.
1111
12−The core documentation can be found [here](http://docs.servant.dev/).
12+The central documentation can be found [here](http://haskell-servant.readthedocs.org/).
1313Other blog posts, videos and slides can be found on the
14−[website](http://www.servant.dev/).
14+[website](http://haskell-servant.github.io/).
1515
16−If you need help, drop by the IRC channel (#haskell-servant on libera.chat) or [mailing
16+If you need help, drop by the IRC channel (#servant on freenode) or [mailing
1717list](https://groups.google.com/forum/#!forum/haskell-servant).
1818
1919## Contributing
@@ -24,7 +24,7 @@ See `CONTRIBUTING.md`
2424
2525- Update changelog and bump versions in `master`
2626 - `git log --oneline v0.12.. | grep 'Merge pull request'` is a good starting point (use correct previous release tag)
27−- Create a release branch, e.g. `release-0.13`
27+- Create a release branch, e.g. `release-0.13`, and *protect it* from accidental force pushes.
2828 - Release branch is useful for backporting fixes from `master`
2929- Smoke test in [`servant-universe`](https://github.com/phadej/servant-universe)
3030 - `git submodule foreach git checkout master` and `git submodule foreach git pull` to get newest of everything.
@@ -32,7 +32,7 @@ See `CONTRIBUTING.md`
3232 - It's a good idea to separate these steps, as tests often pass, if they compile :)
3333 - See `cabal.project` to selectively `allow-newer`
3434 - If some packages are broken, on your discretisation there are two options:
35− - Fix them and make PRs: it's a good idea to test against older `servant` version too.
35+ - Fix them and make PRs: it's good idea to test against older `servant` version too.
3636 - Temporarily comment out broken package
3737 - If you make a commit for `servant-universe`, you can use it as submodule in private projects to test even more
3838- When ripples are cleared out:
@@ -40,32 +40,22 @@ See `CONTRIBUTING.md`
4040 - `git push --tags`
4141 - `cabal sdist` and `cabal upload`
4242
43−## TechEmpower framework benchmarks
43+## travis
4444
45−We develop and maintain the servant TFB entry in https://github.com/haskell-servant/FrameworkBenchmarks/
45+`.travis.yml` is generated using `make-travis-yml` tool, in
46+[multi-ghc-travis](https://github.com/haskell-hvr/multi-ghc-travis) repository.
4647
47−To verify (i.e. compile and test that it works)
48+To regenerate the script use (*note:* atm you need to comment `doc/cookbook/` packages).
4849
49−```sh
50−./tfb --mode verify --test servant servant-beam servant-psql-simple --type json plaintext db fortune
5150```
52−
53−To compare with `warp`
54−
55−```sh
56−./tfb --mode benchmark --test warp servant servant-beam servant-psql-simple --type json plaintext db fortune
51+runghc ~/Documents/other-haskell/multi-ghc-travis/make_travis_yml_2.hs regenerate
5752```
5853
59−To compare with `reitit` (Clojure framework)
54+In case Travis jobs fail due failing build of dependency, you can temporarily
55+add `constraints` to the `cabal.project`, and regenerate the `.travis.yml`.
56+For example, the following will disallow single `troublemaker-13.37` package version:
6057
61−```sh
62−./tfb --mode benchmark --test reitit reitit-async reitit-jdbc servant servant-beam servant-psql-simple --type json plaintext db fortune
6358```
64−
65−You can see the visualised results at https://www.techempower.com/benchmarks/#section=test
66−
67−## Nix
68−
69−A developer shell.nix file is provided in the `nix` directory
70−
71−See [nix/README.md](nix/README.md)
59+constraints:
60+ troublemaker <13.37 && > 13.37
61+```
cabal.ghcjs.project+15−5
@@ -1,14 +1,24 @@
11-- Using https://launchpad.net/~hvr/+archive/ubuntu/ghcjs
2+--
3+-- $ cabal new-build --project-file cabal.ghcjs.project all -w /opt/ghcjs/8.4/bin/ghcjs
24
35packages:
46 servant/
5− servant-client/
67 servant-client-core/
8+ servant-client-ghcjs/
79
810-- we need to tell cabal we are using GHCJS
911compiler: ghcjs
10−tests: True
1112
12−-- Constraints so that reflex-platform provided packages are selected.
13−constraints: attoparsec == 0.13.2.2
14−constraints: hashable == 1.3.0.0
13+-- https://github.com/ghcjs/ghcjs/issues/665
14+constraints: primitive <0.6.4
15+
16+-- ghcjs-base wants old aeson
17+allow-newer: ghcjs-base:aeson
18+
19+-- https://github.com/nomeata/hackage-ghcjs-overlay
20+repository ghcjs-overlay
21+ url: http://hackage-ghcjs-overlay.nomeata.de/
22+ secure: True
23+ root-keys:
24+ key-threshold: 0
cabal.make-travis-ymlnew file+15
@@ -0,0 +1,15 @@
1+folds: all-but-test
2+branches: master
3+
4+-- We have inplace packages (servant-js) so we skip installing dependencies in a separate step
5+install-dependencies-step: False
6+
7+-- this speed-ups the build a little, but we have to check these for release
8+no-tests-no-benchmarks: False
9+unconstrained-step: False
10+
11+-- Don't run cabal check, as cookbook examples won't pass it
12+cabal-check: False
13+
14+-- ghc-options: -j2
15+jobs: :2
cabal.project+20−35
@@ -1,54 +1,39 @@
1−packages:
2− servant/
3− servant-auth/servant-auth
4− servant-auth/servant-auth-client
5− servant-auth/servant-auth-docs
6− servant-auth/servant-auth-server
7− servant-auth/servant-auth-swagger
8−
1+packages: servant/
92 servant-client/
103 servant-client-core/
11− servant-http-streams/
124 servant-docs/
135 servant-foreign/
146 servant-server/
15− servant-swagger/
167 doc/tutorial/
178
18−-- servant streaming
19−packages:
20− servant-machines/
21− servant-conduit/
22− servant-pipes/
23−
24−-- servant GHCJS
25−-- packages:
26−-- servant-jsaddle/
9+ -- doc/cookbook/*/*.cabal
2710
28−-- Cookbooks
29−packages:
3011 doc/cookbook/basic-auth
3112 doc/cookbook/curl-mock
32− doc/cookbook/custom-errors
33− doc/cookbook/basic-streaming
3413 doc/cookbook/db-postgres-pool
3514 doc/cookbook/db-sqlite-simple
3615 doc/cookbook/file-upload
3716 doc/cookbook/generic
38− doc/cookbook/hoist-server-with-context
17+ -- doc/cookbook/hoist-server-with-context
3918 doc/cookbook/https
40− doc/cookbook/jwt-and-basic-auth
41− doc/cookbook/pagination
42− -- doc/cookbook/sentry
43− -- Commented out because servant-quickcheck currently doesn't build.
44− -- doc/cookbook/testing
45− doc/cookbook/uverb
19+ -- doc/cookbook/jwt-and-basic-auth/
20+ -- doc/cookbook/pagination
21+ doc/cookbook/sentry
22+ doc/cookbook/testing
4623 doc/cookbook/structuring-apis
4724 doc/cookbook/using-custom-monad
4825 doc/cookbook/using-free-client
49− -- doc/cookbook/open-id-connect
50− doc/cookbook/managed-resource
5126
52−tests: True
53−optimization: False
54−-- reorder-goals: True
27+allow-newer:
28+ servant-auth-server:http-types,
29+ servant-auth-server:servant-server,
30+ servant-js:base
31+
32+constraints:
33+ -- see https://github.com/haskell-infra/hackage-trustees/issues/119
34+ foundation >=0.0.14,
35+ memory <0.14.12 || >0.14.12
36+
37+allow-newer:
38+ servant-pagination:servant,
39+ servant-pagination:servant-server
changelog.d/1432deleted−9
@@ -1,9 +0,0 @@
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/1469deleted−11
@@ -1,11 +0,0 @@
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/1477deleted−9
@@ -1,9 +0,0 @@
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/1529deleted−10
@@ -1,10 +0,0 @@
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/1556deleted−81
@@ -1,81 +0,0 @@
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/1569deleted−13
@@ -1,13 +0,0 @@
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/1571deleted−10
@@ -1,10 +0,0 @@
1−synopsis: Support UVerb in servant-auth-server
2−prs: #1571
3−issues: #1570
4−description: {
5−UVerb endpoints are now supported by servant-auth-server and can be used under the
6−Auth combinator when writing servers. It is still unsupported by
7−servant-auth-client.
8−
9−This PR also brings Headers support in UVerb responses
10−}
changelog.d/1573deleted−2
@@ -1,2 +0,0 @@
1−synopsis: Add API docs for ServerT
2−prs: #1573
changelog.d/1580deleted−12
@@ -1,12 +0,0 @@
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/1589deleted−2
@@ -1,2 +0,0 @@
1−synopsis: Only include question mark for nonempty query strings
2−prs: 1589
changelog.d/1595deleted−2
@@ -1,2 +0,0 @@
1−synopsis: Run ClientEnv's makeClientRequest in IO.
2−prs: #1595
changelog.d/1606deleted−10
@@ -1,10 +0,0 @@
1−synopsis: Handle Cookies correctly for RunStreamingClient
2−prs: #1606
3−issues: #1605
4−
5−description: {
6−
7−Makes performWithStreamingRequest take into consideration the
8−CookieJar, which it previously didn't.
9−
10−}
changelog.d/1638deleted−2
@@ -1,2 +0,0 @@
1−synopsis: Add Functor instance to AuthHandler.
2−prs: #1638
changelog.d/1649deleted−8
@@ -1,8 +0,0 @@
1−synopsis: Add HasStatus instance for Headers (that defers StatusOf to underlying value)
2−prs: #1649
3−
4−description: {
5−
6−Adds a new HasStatus (Headers hs a) instance (StatusOf (Headers hs a) = StatusOf a)
7−
8−}
changelog.d/configdeleted−2
@@ -1,2 +0,0 @@
1−organization: haskell-servant
2−repository: servant
changelog.d/servant-docs-curldeleted−16
@@ -1,16 +0,0 @@
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−}
default.nixdeleted−38
@@ -1,38 +0,0 @@
1−with (builtins.fromJSON (builtins.readFile ./nix/nixpkgs.json));
2−{
3− pkgs ? import (builtins.fetchTarball {
4− url = "https://github.com/NixOS/nixpkgs/archive/${rev}.tar.gz";
5− inherit sha256;
6− }) {}
7−, compiler ? "ghc883"
8−}:
9−let
10− overrides = self: super: {
11− servant = self.callCabal2nix "servant" ./servant {};
12− servant-docs = self.callCabal2nix "servant-docs" ./servant-docs {};
13− servant-pipes = self.callCabal2nix "servant-pipes" ./servant-pipes {};
14− servant-server = self.callCabal2nix "servant-server" ./servant-server {};
15− servant-client = self.callCabal2nix "servant-client" ./servant-client {};
16− servant-foreign = self.callCabal2nix "servant-foreign" ./servant-foreign {};
17− servant-conduit = self.callCabal2nix "servant-conduit" ./servant-conduit {};
18− servant-machines = self.callCabal2nix "servant-machines" ./servant-machines {};
19− servant-client-core = self.callCabal2nix "servant-client-core" ./servant-client-core {};
20− servant-http-streams = self.callCabal2nix "servant-http-streams" ./servant-http-streams {};
21− };
22− hPkgs = pkgs.haskell.packages.${compiler}.override { inherit overrides; };
23−in
24− with hPkgs;
25− {
26− inherit
27− servant
28− servant-client
29− servant-client-core
30− servant-conduit
31− servant-docs
32− servant-foreign
33− servant-http-streams
34− servant-machines
35− servant-pipes
36− servant-server;
37− }
38−
doc/Makefile+1−3
@@ -10,8 +10,6 @@ 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 README.md."; fi
14− @if [ ! "z$$(which $(SPHINXBUILD))" = "z$$(pwd)/venv/bin/sphinx-build" ]; then echo "WARNING: Did you forgot to 'source venv/bin/activate'"; fi
1513 @$(SPHINXBUILD) -M help "$(SOURCEDIR)" "$(BUILDDIR)" $(SPHINXOPTS) $(O)
1614
1715.PHONY: help Makefile
@@ -19,4 +17,4 @@ help:
1917# Catch-all target: route all unknown targets to Sphinx using the new
2018# "make mode" option. $(O) is meant as a shortcut for $(SPHINXOPTS).
2119%: Makefile
22− @$(SPHINXBUILD) -M $@ "$(SOURCEDIR)" "$(BUILDDIR)" $(SPHINXOPTS) $(O)
20+ @$(SPHINXBUILD) -M $@ "$(SOURCEDIR)" "$(BUILDDIR)" $(SPHINXOPTS) $(O)
doc/README.mddeleted−8
@@ -1,8 +0,0 @@
1−To build the docs locally:
2−
3− $ virtualenv venv
4− $ . ./venv/bin/activate
5− $ pip install -r requirements.txt
6− $ make html
7−
8−Docs will be built in _build/html/index.html .
doc/building-the-docsnew file+8
@@ -0,0 +1,8 @@
1+To build the docs locally:
2+
3+$ virtualenv venv
4+$ . ./venv/bin/activate
5+$ pip install -r requirements.txt
6+$ make html
7+
8+Docs will be built in _build/html/index.html .
doc/conf.py+3−1
@@ -46,7 +46,7 @@ master_doc = 'index'
4646
4747# General information about the project.
4848project = u'Servant'
49−copyright = u'2022, Servant Contributors'
49+copyright = u'2018, Servant Contributors'
5050author = u'Servant Contributors'
5151
5252# The version info for the project you're documenting, acts as replacement for
@@ -167,5 +167,7 @@ texinfo_documents = [
167167# -- Markdown -------------------------------------------------------------
168168
169169source_parsers = {
170+ '.md': CommonMarkParser,
170171 '.lhs': CommonMarkParser,
171172}
173+
doc/cookbook/basic-auth/basic-auth.cabal+4−4
@@ -1,14 +1,14 @@
1−cabal-version: 2.2
21name: cookbook-basic-auth
32version: 0.1
43synopsis: Basic Authentication cookbook example
5−homepage: http://docs.servant.dev/
6−license: BSD-3-Clause
4+homepage: http://haskell-servant.readthedocs.org/
5+license: BSD3
76license-file: ../../../servant/LICENSE
87author: Servant Contributors
98maintainer: haskell-servant-maintainers@googlegroups.com
109build-type: Simple
11−tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
10+cabal-version: >=1.10
11+tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.1
1212
1313executable cookbook-basic-auth
1414 main-is: BasicAuth.lhs
doc/cookbook/basic-streaming/Streaming.lhsdeleted−129
@@ -1,129 +0,0 @@
1−# Streaming out-of-the-box
2−
3−In other words, without streaming libraries.
4−
5−## Introduction
6−
7−- Servant supports streaming
8−- Some basic usage doesn't require usage of streaming libraries,
9− like `conduit`, `pipes`, `machines` or `streaming`.
10− We have bindings for them though.
11−- Similar example is bundled with each of our streaming library interop packages (see
12−[servant-pipes](https://github.com/haskell-servant/servant/blob/master/servant-pipes/example/Main.hs),
13−[servant-conduit](https://github.com/haskell-servant/servant/blob/master/servant-conduit/example/Main.hs) and
14−[servant-machines](https://github.com/haskell-servant/servant/blob/master/servant-machines/example/Main.hs))
15−- `SourceT` doesn't have *Prelude* with handy combinators, so we have to write
16− things ourselves. (Note to self: `mapM` and `foldM` would be handy to have).
17−
18−## Code
19−
20−```haskell
21−{-# LANGUAGE BangPatterns #-}
22−{-# LANGUAGE DataKinds #-}
23−{-# LANGUAGE DeriveGeneric #-}
24−{-# LANGUAGE TypeOperators #-}
25−module Main (main) where
26−
27−import Control.Concurrent
28− (threadDelay)
29−import Control.Monad.IO.Class
30− (MonadIO (..))
31−import qualified Data.ByteString as BS
32−import Data.Maybe
33− (fromMaybe)
34−import Network.HTTP.Client
35− (defaultManagerSettings, newManager)
36−import Network.Wai
37− (Application)
38−import System.Environment
39− (getArgs, lookupEnv)
40−import Text.Read
41− (readMaybe)
42−
43−import Servant
44−import Servant.Client.Streaming
45−import qualified Servant.Types.SourceT as S
46−
47−import qualified Network.Wai.Handler.Warp as Warp
48−
49−type FastAPI = "get" :> Capture "num" Int :> StreamGet NewlineFraming JSON (SourceIO Int)
50−
51−type API = FastAPI
52− :<|> "slow" :> Capture "num" Int :> StreamGet NewlineFraming JSON (SourceIO Int)
53− -- monad can be ResourceT IO too.
54− :<|> "readme" :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString)
55− -- we can have streaming request body
56− :<|> "proxy"
57− :> StreamBody NoFraming OctetStream (SourceIO BS.ByteString)
58− :> StreamPost NoFraming OctetStream (SourceIO BS.ByteString)
59−
60−api :: Proxy API
61−api = Proxy
62−
63−server :: Server API
64−server = fast :<|> slow :<|> readme :<|> proxy where
65− fast n = liftIO $ do
66− putStrLn $ "/get/" ++ show n
67− return $ fastSource n
68−
69− slow n = liftIO $ do
70− putStrLn $ "/slow/" ++ show n
71− return $ slowSource n
72−
73− readme = liftIO $ do
74− putStrLn "/proxy"
75− return (S.readFile "README.md")
76−
77− proxy c = liftIO $ do
78− putStrLn "/proxy"
79− return c
80−
81− -- for some reason unfold leaks?
82− fastSource = S.fromStepT . mk where
83− mk m
84− | m < 0 = S.Stop
85− | otherwise = S.Yield m (mk (m - 1))
86−
87− slowSource m = S.mapStepT delay (fastSource m) where
88− delay S.Stop = S.Stop
89− delay (S.Error err) = S.Error err
90− delay (S.Skip s) = S.Skip (delay s)
91− delay (S.Effect ms) = S.Effect (fmap delay ms)
92− delay (S.Yield x s) = S.Effect $
93− S.Yield x (delay s) <$ threadDelay 1000000
94−
95−app :: Application
96−app = serve api server
97−
98−cli :: Client ClientM FastAPI
99−cli :<|> _ :<|> _ :<|> _ = client api
100−
101−main :: IO ()
102−main = do
103− args <- getArgs
104− case args of
105− ("server":_) -> do
106− putStrLn "Starting cookbook-basic-streaming at http://localhost:8000"
107− port <- fromMaybe 8000 . (>>= readMaybe) <$> lookupEnv "PORT"
108− Warp.run port app
109− ("client":ns:_) -> do
110− n <- maybe (fail $ "not a number: " ++ ns) pure $ readMaybe ns
111− mgr <- newManager defaultManagerSettings
112− burl <- parseBaseUrl "http://localhost:8000/"
113− withClientM (cli n) (mkClientEnv mgr burl) $ \me -> case me of
114− Left err -> print err
115− Right src -> do
116− x <- S.unSourceT src (go (0 :: Int))
117− print x
118− where
119− go !acc S.Stop = return acc
120− go !acc (S.Error err) = print err >> return acc
121− go !acc (S.Skip s) = go acc s
122− go !acc (S.Effect ms) = ms >>= go acc
123− go !acc (S.Yield _ s) = go (acc + 1) s
124− _ -> do
125− putStrLn "Try:"
126− putStrLn "cabal new-run cookbook-basic-streaming server"
127− putStrLn "cabal new-run cookbook-basic-streaming client 10"
128− putStrLn "time curl -H 'Accept: application/json' localhost:8000/slow/5"
129−```
doc/cookbook/basic-streaming/basic-streaming.cabaldeleted−28
@@ -1,28 +0,0 @@
1−cabal-version: 2.2
2−name: cookbook-basic-streaming
3−version: 2.1
4−synopsis: Streaming in servant without streaming libs
5−homepage: http://docs.servant.dev/
6−license: BSD-3-Clause
7−license-file: ../../../servant/LICENSE
8−author: Servant Contributors
9−maintainer: haskell-servant-maintainers@googlegroups.com
10−build-type: Simple
11−tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
12−
13−executable cookbook-basic-streaming
14− main-is: Streaming.lhs
15− build-tool-depends: markdown-unlit:markdown-unlit
16− default-language: Haskell2010
17− ghc-options: -Wall -pgmL markdown-unlit -threaded -rtsopts
18−
19− hs-source-dirs: .
20− build-depends: base >= 4.8 && <5
21− , aeson
22− , bytestring
23− , servant
24− , servant-server
25− , servant-client
26− , http-client
27− , wai
28− , warp
doc/cookbook/cabal.project−2
@@ -1,7 +1,6 @@
11packages:
22 basic-auth/
33 curl-mock/
4− db-mysql-basics/
54 db-sqlite-simple/
65 db-postgres-pool/
76 using-custom-monad/
@@ -13,7 +12,6 @@ packages:
1312 pagination/
1413 sentry/
1514 testing/
16− open-id-connect/
1715 ../../servant
1816 ../../servant-server
1917 ../../servant-client-core
doc/cookbook/cabal.project.localdeleted

No changes to the content.

doc/cookbook/curl-mock/CurlMock.lhs+23−10
@@ -1,7 +1,7 @@
11# Generating mock curl calls
22
33In this example we will generate curl requests with mock post data from a servant API.
4−This may be useful for testing and development purposes.
4+This may be usefull for testing and development purposes.
55Especially post requests with a request body are tedious to send manually.
66
77Also, we will learn how to use the servant-foreign library to generate stuff from servant APIs.
@@ -22,8 +22,9 @@ Language extensions and imports:
2222{-# LANGUAGE TypeOperators #-}
2323
2424import Control.Lens ((^.))
25−import Data.Aeson
25+import Data.Aeson.Compat
2626import Data.Aeson.Text
27+import Data.Monoid ((<>))
2728import Data.Proxy (Proxy (Proxy))
2829import Data.Text (Text)
2930import Data.Text.Encoding (decodeUtf8)
@@ -75,7 +76,7 @@ api = Proxy
7576```
7677
7778
78−## servant-foreign and the HasForeignType Class
79+## servant-forgein and the HasForeignType Class
7980
8081Servant-foreign allows us to look into the API we designed.
8182The entry point is `listFromAPI` which takes three types and returns a list of endpoints:
@@ -85,7 +86,7 @@ listFromAPI :: (HasForeign lang ftype api, GenerateList ftype (Foreign ftype api
8586```
8687
8788This looks a bit confusing...
88−[Here](https://hackage.haskell.org/package/servant-foreign/docs/Servant-Foreign.html#t:HasForeign) is the documentation for the `HasForeign` typeclass.
89+[Here](https://hackage.haskell.org/package/servant-foreign-0.11.1/docs/Servant-Foreign.html#t:HasForeignType) is the documentation for the `HasForeign` typeclass.
8990We will not go into details here, but this allows us to create a value of type `ftype` for any type `a` in our API.
9091
9192In our case we want to create a mock of every type `a`.
@@ -129,12 +130,24 @@ generateCurl :: (GenerateList Mocked (Foreign Mocked api), HasForeign NoLang Moc
129130generateCurl p host =
130131 fmap T.unlines body
131132 where
132− body = mapM (generateEndpoint host)
133+ body = foldr (\endp curlCalls -> mCons (generateEndpoint host endp) curlCalls) (return [])
133134 $ listFromAPI (Proxy :: Proxy NoLang) (Proxy :: Proxy Mocked) p
134135```
135136
136−First, `listFromAPI` gives us a list of `Req Mocked`. Each `Req` describes one endpoint from the API type.
137−We generate a curl call for each of them using the following helper.
137+To understand this function, better start at the end:
138+
139+`listFromAPI` gives us a list of endpoints. We iterate over them (`foldr`) and call `generateEndpoint` for every endpoint.
140+
141+As generate endpoint will not return `Text` but `IO Text` (remember we need some random bits to mock), we cannot just use the cons operator but need to build `IO [Text]` from `IO Text`s.
142+
143+``` haskell
144+mCons :: IO a -> IO [a] -> IO [a]
145+mCons ele list =
146+ ele >>= \e -> list >>= \l -> return ( e : l )
147+```
148+
149+
150+Now comes the juicy part; accessing the endpoints data:
138151
139152``` haskell
140153generateEndpoint :: Text -> Req Mocked -> IO Text
@@ -156,7 +169,7 @@ generateEndpoint host req =
156169`servant-foreign` offers a multitude of lenses to be used with `Req`-values.
157170
158171`reqMethod` gives us a straigthforward `Network.HTTP.Types.Method`, `reqUrl` the url part and so on.
159−Just take a look at [the docs](https://hackage.haskell.org/package/servant-foreign/docs/Servant-Foreign.html).
172+Just take a look at [the docs](https://hackage.haskell.org/package/servant-foreign-0.11.1/docs/Servant-Foreign.html).
160173
161174But how do we get our mocked json string? This seems to be a bit to short to be true:
162175
@@ -188,7 +201,7 @@ And now, lets hook it all up in our main function:
188201``` haskell
189202main :: IO ()
190203main =
191− generateCurl api "localhost:8081" >>= T.IO.putStrLn
204+ generateCurl api "localhost:8081" >>= (\v -> T.IO.putStrLn v)
192205```
193206
194207Done:
@@ -200,6 +213,6 @@ curl -X POST -d '{"email":"wV򝣀_b򆎘:z񁊞򲙲!(3DM V","age":10,"name":"=|W"}
200213```
201214
202215This is of course no complete curl call mock generator, many things including path arguments are missing.
203−But it correctly generates mock calls for simple POST requests.
216+But it correctly generate mock calls for simple POST requests.
204217
205218Also, we now know how to use `HasForeignType` and `listFromAPI` to generate anything we want.
doc/cookbook/curl-mock/curl-mock.cabal+5−7
@@ -1,22 +1,20 @@
1−cabal-version: 2.2
21name: cookbook-curl-mock
32version: 0.1
43synopsis: Generate curl mock requests cookbook example
5−homepage: http://docs.servant.dev
6−license: BSD-3-Clause
4+homepage: http://haskell-servant.readthedocs.org
5+license: BSD3
76license-file: ../../../servant/LICENSE
87author: Servant Contributors
98maintainer: haskell-servant-maintainers@googlegroups.com
109build-type: Simple
11−tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
10+cabal-version: >=1.10
11+tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.1
1212
1313executable cookbock-curl-mock
14− if impl(ghc >= 9.2)
15− -- generic-arbitrary is incompatible
16− buildable: False
1714 main-is: CurlMock.lhs
1815 build-depends: base == 4.*
1916 , aeson
17+ , aeson-compat
2018 , lens
2119 , text
2220 , servant
doc/cookbook/custom-errors/CustomErrors.lhsdeleted−189
@@ -1,189 +0,0 @@
1−# Customizing errors from Servant
2−
3−Servant handles a lot of parsing and validation of the input request. When it can't parse something: query
4−parameters, URL parts or request body, it will return appropriate HTTP codes like 400 Bad Request.
5−
6−These responses will contain the error message in their body without any formatting. However, it is often
7−desirable to be able to provide custom formatting for these error messages, for example, to wrap them in JSON.
8−
9−Recently Servant got a way to add such formatting. This Cookbook chapter demonstrates how to use it.
10−
11−Extensions and imports:
12−```haskell
13−{-# LANGUAGE DataKinds #-}
14−{-# LANGUAGE DeriveGeneric #-}
15−{-# LANGUAGE OverloadedStrings #-}
16−{-# LANGUAGE PolyKinds #-}
17−{-# LANGUAGE TypeFamilies #-}
18−{-# LANGUAGE TypeOperators #-}
19−
20−import Data.Aeson
21−import Data.Proxy
22−import Data.Text
23−import GHC.Generics
24−import Network.Wai
25−import Network.Wai.Handler.Warp
26−
27−import Servant
28−
29−import Data.String.Conversions
30− (cs)
31−import Servant.API.ContentTypes
32−```
33−
34−The API (from `greet.hs` example in Servant sources):
35−
36−```haskell
37−-- | A greet message data type
38−newtype Greet = Greet { _msg :: Text }
39− deriving (Generic, Show)
40−
41−instance FromJSON Greet
42−instance ToJSON Greet
43−
44−-- API specification
45−type TestApi =
46− -- GET /hello/:name?capital={true, false} returns a Greet as JSON
47− "hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get '[JSON] Greet
48−
49− -- POST /greet with a Greet as JSON in the request body,
50− -- returns a Greet as JSON
51− :<|> "greet" :> ReqBody '[JSON] Greet :> Post '[JSON] Greet
52−
53− -- DELETE /greet/:greetid
54− :<|> "greet" :> Capture "greetid" Text :> Delete '[JSON] NoContent
55−
56−testApi :: Proxy TestApi
57−testApi = Proxy
58−
59−-- Server-side handlers.
60−--
61−-- There's one handler per endpoint, which, just like in the type
62−-- that represents the API, are glued together using :<|>.
63−--
64−-- Each handler runs in the 'Handler' monad.
65−server :: Server TestApi
66−server = helloH :<|> postGreetH :<|> deleteGreetH
67−
68− where helloH name Nothing = helloH name (Just False)
69− helloH name (Just False) = return . Greet $ "Hello, " <> name
70− helloH name (Just True) = return . Greet . toUpper $ "Hello, " <> name
71−
72− postGreetH greet = return greet
73−
74− deleteGreetH _ = return NoContent
75−```
76−
77−## Error formatters
78−
79−`servant-server` provides an `ErrorFormatter` type to specify how the error message will be
80−formatted. A formatter is just a function accepting three parameters:
81−
82−- `TypeRep` from `Data.Typeable`: this is a runtime representation of the type of the combinator
83− (like `Capture` or `ReqBody`) that generated the error. It can be used to display its name (with
84− `show`) or even dynamically dispatch on the combinator type. See the docs for `Data.Typeable` and
85− `Type.Reflection` modules.
86−- `Request`: full information for the request that led to the error.
87−- `String`: specific error message from the combinator.
88−
89−The formatter is expected to produce a `ServerError` which will be returned from the handler.
90−
91−Additionally, there is `NotFoundErrorFormatter`, which accepts only `Request` and can customize the
92−error in case when no route can be matched (HTTP 404).
93−
94−Let's make two formatters. First one will wrap our error in a JSON:
95−
96−```json
97−{
98− "error": "ERROR MESSAGE",
99− "combinator": "NAME OF THE COMBINATOR"
100−}
101−```
102−
103−Additionally, this formatter will examine the `Accept` header of the request and generate JSON
104−message only if client can accept it.
105−
106−```haskell
107−customFormatter :: ErrorFormatter
108−customFormatter tr req err =
109− let
110− -- aeson Value which will be sent to the client
111− value = object ["combinator" .= show tr, "error" .= err]
112− -- Accept header of the request
113− accH = getAcceptHeader req
114− in
115− -- handleAcceptH is Servant's function that checks whether the client can accept a
116− -- certain message type.
117− -- In this case we call it with "Proxy '[JSON]" argument, meaning that we want to return a JSON.
118− case handleAcceptH (Proxy :: Proxy '[JSON]) accH value of
119− -- If client can't handle JSON, we just return the body the old way
120− Nothing -> err400 { errBody = cs err }
121− -- Otherwise, we return the JSON formatted body and set the "Content-Type" header.
122− Just (ctypeH, body) -> err400
123− { errBody = body
124− , errHeaders = [("Content-Type", cs ctypeH)]
125− }
126−
127−notFoundFormatter :: NotFoundErrorFormatter
128−notFoundFormatter req =
129− err404 { errBody = cs $ "Not found path: " <> rawPathInfo req }
130−```
131−
132−If you don't need to react to the `Accept` header, you can just unconditionally return the JSON like
133−this (with `encode` from `Data.Aeson`):
134−
135−```
136−err400
137− { errBody = encode body
138− , errHeaders = [("Content-Type", "application/json")]
139− }
140−```
141−
142−## Passing formatters to Servant
143−
144−Servant uses the Context to configure formatters. You only need to add a value of type
145−`ErrorFormatters` to your context. This is a record with the following fields:
146−
147−- `bodyParserErrorFormatter :: ErrorFormatter`
148−- `urlParseErrorFormatter :: ErrorFormatter`
149−- `headerParseErrorFormatter :: ErrorFormatter`
150−- `notFoundErrorFormatter :: NotFoundErrorFormatter`
151−
152−Default formatters are exported as `defaultErrorFormatters`, so you can use record update syntax to
153−set the only ones you need:
154−
155−```haskell
156−customFormatters :: ErrorFormatters
157−customFormatters = defaultErrorFormatters
158− { bodyParserErrorFormatter = customFormatter
159− , notFoundErrorFormatter = notFoundFormatter
160− }
161−```
162−
163−And at last, use `serveWithContext` to run your server as usual:
164−
165−```haskell
166−app :: Application
167−app = serveWithContext testApi (customFormatters :. EmptyContext) server
168−
169−main :: IO ()
170−main = run 8000 app
171−```
172−
173−Now if we try to request something with a wrong body, we will get a nice error:
174−
175−```
176−$ http -j POST localhost:8000/greet 'foo=bar'
177−HTTP/1.1 400 Bad Request
178−Content-Type: application/json;charset=utf-8
179−Date: Fri, 17 Jul 2020 13:34:18 GMT
180−Server: Warp/3.3.12
181−Transfer-Encoding: chunked
182−
183−{
184− "combinator": "ReqBody'",
185− "error": "Error in $: parsing Main.Greet(Greet) failed, key \"_msg\" not found"
186−}
187−```
188−
189−Notice the `Content-Type` header set by our combinator.
doc/cookbook/custom-errors/custom-errors.cabaldeleted−25
@@ -1,25 +0,0 @@
1−cabal-version: 2.2
2−name: cookbook-custom-errors
3−version: 0.1
4−synopsis: Return custom error messages from combinators
5−homepage: http://docs.servant.dev
6−license: BSD-3-Clause
7−license-file: ../../../servant/LICENSE
8−author: Servant Contributors
9−maintainer: haskell-servant-maintainers@googlegroups.com
10−build-type: Simple
11−tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
12−
13−executable cookbook-custom-errors
14− main-is: CustomErrors.lhs
15− build-depends: base == 4.*
16− , aeson
17− , servant
18− , servant-server
19− , string-conversions
20− , text
21− , wai
22− , warp
23− default-language: Haskell2010
24− ghc-options: -Wall -pgmL markdown-unlit
25− build-tool-depends: markdown-unlit:markdown-unlit
doc/cookbook/db-mysql-basics/MysqlBasics.lhsdeleted−236
@@ -1,236 +0,0 @@
1−# Overview
2−
3−This doc will walk through a single-module implementation of a servant API connecting to a MySQL database. It will also include some basic CRUD operations.
4−
5−Once you can wrap your head around this implementation, understanding more complex features like resource pools would be beneficial next steps.
6−
7−The only *prerequisite* is that you have a MySQL database open on port 3306 of your machine. Docker is an easy way to manage this.
8−
9−## Setup
10−
11−- The mysql database should be up and running on 127.0.0.1:3306
12−
13−- Our API will be exposed on localhost:8080
14−
15−## REST actions available
16−
17−*Get all people*
18−
19−```
20−/people GET
21−```
22−
23−*Get person by ID*
24−
25−```
26−/people/:id GET
27−```
28−
29−*Insert a new person*
30−
31−```
32−/people POST
33−
34−{
35− "name": "NewName",
36− "age": 24
37−}
38−```
39−
40−*Delete a person*
41−
42−```
43−/people/:id DELETE
44−```
45−
46−## Other notes
47−
48−At the time of writing this issue may occur when building your project:
49−
50−```
51−setup: Missing dependencies on foreign libraries:
52−* Missing (or bad) C libraries: ssl, crypto
53−```
54−
55−If using stack, this can be fixed by adding the following lines to your `stack.yaml`:
56−
57−```
58−extra-include-dirs:
59−- /usr/local/opt/openssl/include
60−extra-lib-dirs:
61−- /usr/local/opt/openssl/lib
62−```
63−
64−Or for cabal, running your builds with these configurations passed as options.
65−
66−## Implementation: Main.hs
67−
68−Let's jump in:
69−
70−```haskell
71−{-# LANGUAGE DataKinds #-}
72−{-# LANGUAGE DeriveGeneric #-}
73−{-# LANGUAGE FlexibleInstances #-}
74−{-# LANGUAGE GADTs #-}
75−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
76−{-# LANGUAGE MultiParamTypeClasses #-}
77−{-# LANGUAGE QuasiQuotes #-}
78−{-# LANGUAGE TemplateHaskell #-}
79−{-# LANGUAGE TypeFamilies #-}
80−{-# LANGUAGE TypeOperators #-}
81−module Lib where
82−
83−import Control.Monad.IO.Class (liftIO)
84−import Control.Monad.Logger (NoLoggingT (..))
85−import Control.Monad.Trans.Reader (runReaderT)
86−import Control.Monad.Trans.Resource (ResourceT, runResourceT)
87−import Data.Aeson as JSON
88−import Data.Int (Int64 (..))
89−import Data.Text (Text)
90−import qualified Data.Text as T
91−import qualified Data.Text.IO as T
92−import Database.Persist
93−import Database.Persist.MySQL (ConnectInfo (..),
94− SqlBackend (..),
95− defaultConnectInfo, fromSqlKey, runMigration,
96− runSqlPool, toSqlKey, withMySQLConn)
97−import Database.Persist.Sql (SqlPersistT, runSqlConn)
98−import Database.Persist.TH (mkMigrate, mkPersist,
99− persistLowerCase, share,
100− sqlSettings)
101−import Database.Persist.Types (PersistValue(PersistInt64))
102−import Servant (Handler, throwError)
103−
104−import GHC.Generics
105−import Network.Wai
106−import Network.Wai.Handler.Warp
107−import Servant
108−import Servant.API
109−import System.Environment (getArgs)
110−
111−share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
112−Person json
113− Id Int Primary Unique
114− name Text
115− age Text
116− deriving Eq Show Generic
117−|]
118−
119−type Api =
120− "person" :> Get '[JSON] [Person]
121− :<|> "person" :> Capture "id" Int :> Get '[JSON] Person
122− :<|> "person" :> Capture "id" Int :> Delete '[JSON] ()
123− :<|> "person" :> ReqBody '[JSON] Person :> Post '[JSON] Person
124−
125−apiProxy :: Proxy Api
126−apiProxy = Proxy
127−
128−app :: Application
129−app = serve apiProxy server
130−
131−-- Run a database operation, and lift the result into a Handler.
132−-- This minimises usage of IO operations in other functions
133−runDB :: SqlPersistT (ResourceT (NoLoggingT IO)) a -> Handler a
134−runDB a = liftIO $ runNoLoggingT $ runResourceT $ withMySQLConn connInfo $ runSqlConn a
135−
136−-- Change these out to suit your local setup
137−connInfo :: ConnectInfo
138−connInfo = defaultConnectInfo { connectHost = "127.0.0.1", connectUser = "root", connectPassword = "abcd", connectDatabase = "test-database" }
139−
140−doMigration :: IO ()
141−doMigration = runNoLoggingT $ runResourceT $ withMySQLConn connInfo $ runReaderT $ runMigration migrateAll
142−
143−server :: Server Api
144−server =
145− personGET :<|>
146− personGETById :<|>
147− personDELETE :<|>
148− personPOST
149− where
150− personGET = selectPersons
151− personGETById id = selectPersonById id
152− personDELETE id = deletePerson id
153− personPOST personJson = createPerson personJson
154−
155−selectPersons :: Handler [Person]
156−selectPersons = do
157− personList <- runDB $ selectList [] []
158− return $ map (\(Entity _ u) -> u) personList
159−
160−selectPersonById :: Int -> Handler Person
161−selectPersonById id = do
162− sqlResult <- runDB $ get $ PersonKey id
163− case sqlResult of
164− Just person -> return person
165− Nothing -> throwError err404 { errBody = JSON.encode "Person with ID not found." }
166−
167−createPerson :: Person -> Handler Person
168−createPerson person = do
169− attemptCreate <- runDB $ insert person
170− case attemptCreate of
171− PersonKey k -> return person
172− _ -> throwError err503 { errBody = JSON.encode "Could not create Person." }
173−
174−deletePerson :: Int -> Handler ()
175−deletePerson id = do runDB $ delete $ PersonKey id
176−
177−startApp :: IO ()
178−startApp = do
179− args <- getArgs
180− let arg1 = if not (null args) then Just (head args) else Nothing
181− case arg1 of
182− Just "migrate" -> doMigration
183− _ -> run 8080 app
184−```
185−
186−## Sample requests
187−
188−Assuming that you have the db running and have first run `stack exec run migrate`, the following sample requests will test your API:
189−
190−*Create a person*
191−
192−```bash
193−curl -X POST \
194− http://localhost:8080/person \
195− -H 'Accept: */*' \
196− -H 'Accept-Encoding: gzip, deflate' \
197− -H 'Cache-Control: no-cache' \
198− -H 'Connection: keep-alive' \
199− -H 'Content-Length: 62' \
200− -H 'Content-Type: application/json' \
201− -H 'Host: localhost:8080' \
202− -H 'cache-control: no-cache' \
203− -d '{
204− "name": "Jake",
205− "age": "25"
206−}'
207−```
208−
209−*Get all persons*
210−
211−```bash
212−curl -X GET \
213− http://localhost:8080/person \
214− -H 'Accept: */*' \
215− -H 'Accept-Encoding: gzip, deflate' \
216− -H 'Cache-Control: no-cache' \
217− -H 'Connection: keep-alive' \
218− -H 'Content-Length: 33' \
219− -H 'Content-Type: application/json' \
220− -H 'Host: localhost:8080' \
221− -H 'cache-control: no-cache'
222−```
223−
224−*Get person by ID*
225−
226−```bash
227−curl -X GET \
228− http://localhost:8080/person/1 \
229− -H 'Accept: */*' \
230− -H 'Accept-Encoding: gzip, deflate' \
231− -H 'Cache-Control: no-cache' \
232− -H 'Connection: keep-alive' \
233− -H 'Content-Type: application/json' \
234− -H 'Host: localhost:8080' \
235− -H 'cache-control: no-cache'
236−```
doc/cookbook/db-mysql-basics/mysql-basics.cabaldeleted−40
@@ -1,40 +0,0 @@
1−cabal-version: 2.2
2−name: mysql-basics
3−version: 0.1.0.0
4−synopsis: Simple MySQL API cookbook example
5−homepage: http://docs.servant.dev/
6−license: BSD-3-Clause
7−license-file: ../../../servant/LICENSE
8−author: Servant Contributors
9−maintainer: haskell-servant-maintainers@googlegroups.com
10−build-type: Simple
11−
12−executable run
13− hs-source-dirs: .
14− main-is: MysqlBasics.hs
15− ghc-options: -threaded -rtsopts -with-rtsopts=-N
16− build-depends: aeson
17− , base
18− , bytestring
19− , http-client
20− , monad-logger
21− , mysql-simple
22− , persistent
23− , persistent-mysql
24− , persistent-template
25− , resource-pool
26− , resourcet
27− , servant
28− , servant-client
29− , servant-server
30− , text
31− , transformers
32− , wai
33− , warp
34− default-language: Haskell2010
35− ghc-options: -Wall -pgmL markdown-unlit
36− build-tool-depends: markdown-unlit:markdown-unlit
37−
38−source-repository head
39− type: git
40− location: https://github.com/githubuser/mysql-basics
doc/cookbook/db-postgres-pool/db-postgres-pool.cabal+4−4
@@ -1,14 +1,14 @@
1−cabal-version: 2.2
21name: cookbook-db-postgres-pool
32version: 0.1
43synopsis: Simple PostgreSQL connection pool cookbook example
5−homepage: http://docs.servant.dev/
6−license: BSD-3-Clause
4+homepage: http://haskell-servant.readthedocs.org/
5+license: BSD3
76license-file: ../../../servant/LICENSE
87author: Servant Contributors
98maintainer: haskell-servant-maintainers@googlegroups.com
109build-type: Simple
11−tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
10+cabal-version: >=1.10
11+tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.1
1212
1313executable cookbook-db-postgres-pool
1414 main-is: PostgresPool.lhs
doc/cookbook/db-sqlite-simple/db-sqlite-simple.cabal+5−5
@@ -1,14 +1,14 @@
1−cabal-version: 2.2
21name: cookbook-db-sqlite-simple
32version: 0.1
43synopsis: Simple SQLite DB cookbook example
5−homepage: http://docs.servant.dev/
6−license: BSD-3-Clause
4+homepage: http://haskell-servant.readthedocs.org/
5+license: BSD3
76license-file: ../../../servant/LICENSE
87author: Servant Contributors
98maintainer: haskell-servant-maintainers@googlegroups.com
109build-type: Simple
11−tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
10+cabal-version: >=1.10
11+tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.1
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.5.0
26+ , sqlite-simple >= 0.4
2727 , transformers
2828 default-language: Haskell2010
2929 ghc-options: -Wall -pgmL markdown-unlit
doc/cookbook/file-upload/FileUpload.lhs+4−4
@@ -17,7 +17,7 @@ import Control.Exception
1717import Control.Monad
1818import Control.Monad.IO.Class
1919import Data.Text.Encoding (encodeUtf8)
20−import Network.Socket (withSocketsDo)
20+import Network (withSocketsDo)
2121import Network.HTTP.Client hiding (Proxy)
2222import Network.HTTP.Client.MultipartFormData
2323import Network.Wai.Handler.Warp
@@ -90,8 +90,8 @@ startServer = run 8080 (serve api upload)
9090
9191Finally, a main function that brings up our server and
9292sends some test request with `http-client` (and not
93−servant-client this time, as servant-multipart does not
94−yet have support for client generation).
93+servant-client this time, has servant-multipart does not
94+yet have support for client generation.
9595
9696``` haskell
9797main :: IO ()
@@ -126,7 +126,7 @@ Content of "README.md"
126126
127127## Getting Started
128128
129−We have a [tutorial](http://docs.servant.dev/en/stable/tutorial/index.html) that
129+We have a [tutorial](http://haskell-servant.readthedocs.org/en/stable/tutorial/index.html) that
130130introduces the core features of servant. After this article, you should be able
131131to write your first servant webservices, learning the rest from the haddocks'
132132examples.
doc/cookbook/file-upload/file-upload.cabal+4−4
@@ -1,14 +1,14 @@
1−cabal-version: 2.2
21name: cookbook-file-upload
32version: 0.1
43synopsis: File upload cookbook example
5−homepage: http://docs.servant.dev/
6−license: BSD-3-Clause
4+homepage: http://haskell-servant.readthedocs.org/
5+license: BSD3
76license-file: ../../../servant/LICENSE
87author: Servant Contributors
98maintainer: haskell-servant-maintainers@googlegroups.com
109build-type: Simple
11−tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
10+cabal-version: >=1.10
11+tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.1
1212
1313executable cookbook-file-upload
1414 main-is: FileUpload.lhs
doc/cookbook/generic/Generic.lhs+7−42
@@ -7,11 +7,10 @@
77{-# LANGUAGE TypeOperators #-}
88module Main (main, api, getLink, routesLinks, cliGet) where
99
10−import Control.Exception (throwIO)
11−import Control.Monad.Trans.Reader (ReaderT, runReaderT)
12−import Data.Proxy (Proxy (..))
13−import Network.Wai.Handler.Warp (run)
14−import System.Environment (getArgs)
10+import Control.Exception (throwIO)
11+import Data.Proxy (Proxy (..))
12+import Network.Wai.Handler.Warp (run)
13+import System.Environment (getArgs)
1514
1615import Servant
1716import Servant.Client
@@ -43,13 +42,13 @@ api :: Proxy (ToServantApi Routes)
4342api = genericApi (Proxy :: Proxy Routes)
4443```
4544
46−It's recommended to use `genericApi` function, as then you'll get
45+It's recommented to use `genericApi` function, as then you'll get
4746better error message, for example if you forget to `derive Generic`.
4847
4948## Links
5049
5150The clear advantage of record-based generics approach, is that
52−we can get safe links very conveniently. We don't need to define endpoint types,
51+we can get safe links very conviently. We don't need to define endpoint types,
5352as field accessors work as proxies:
5453
5554```haskell
@@ -67,7 +66,7 @@ routesLinks = allFieldLinks
6766## Client
6867
6968Even more power starts to show when we generate a record of client functions.
70−Here we use `genericClientHoist` function, which lets us simultaneously
69+Here we use `genericClientHoist` function, which let us simultaneously
7170hoist the monad, in this case from `ClientM` to `IO`.
7271
7372```haskell
@@ -103,39 +102,5 @@ main = do
103102 ("run":_) -> do
104103 putStrLn "Starting cookbook-generic at http://localhost:8000"
105104 run 8000 app
106− -- see this cookbook below for custom-monad explanation
107− ("run-custom-monad":_) -> do
108− putStrLn "Starting cookbook-generic with a custom monad at http://localhost:8000"
109− run 8000 (appMyMonad AppCustomState)
110105 _ -> putStrLn "To run, pass 'run' argument: cabal new-run cookbook-generic run"
111106```
112−
113−## Using generics together with a custom monad
114−
115−If your app uses a custom monad, here's how you can combine it with
116−generics.
117−
118−```haskell
119−data AppCustomState =
120− AppCustomState
121−
122−type AppM = ReaderT AppCustomState Handler
123−
124−apiMyMonad :: Proxy (ToServantApi Routes)
125−apiMyMonad = genericApi (Proxy :: Proxy Routes)
126−
127−getRouteMyMonad :: Int -> AppM String
128−getRouteMyMonad = return . show
129−
130−putRouteMyMonad :: Int -> AppM Bool
131−putRouteMyMonad = return . odd
132−
133−recordMyMonad :: Routes (AsServerT AppM)
134−recordMyMonad = Routes {_get = getRouteMyMonad, _put = putRouteMyMonad}
135−
136−-- natural transformation
137−nt :: AppCustomState -> AppM a -> Handler a
138−nt s x = runReaderT x s
139−
140−appMyMonad :: AppCustomState -> Application
141−appMyMonad state = genericServeT (nt state) recordMyMonad
doc/cookbook/generic/generic.cabal+4−4
@@ -1,14 +1,14 @@
1−cabal-version: 2.2
21name: cookbook-generic
32version: 0.1
43synopsis: Using custom monad to pass a state between handlers
5−homepage: http://docs.servant.dev/
6−license: BSD-3-Clause
4+homepage: http://haskell-servant.readthedocs.org/
5+license: BSD3
76license-file: ../../../servant/LICENSE
87author: Servant Contributors
98maintainer: haskell-servant-maintainers@googlegroups.com
109build-type: Simple
11−tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
10+cabal-version: >=1.10
11+tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.1
1212
1313executable cookbook-using-custom-monad
1414 main-is: Generic.lhs
doc/cookbook/hoist-server-with-context/HoistServerWithContext.lhs+4−11
@@ -25,15 +25,8 @@ for our logging example below.
2525This recipe uses the following ingredients:
2626
2727```haskell
28−{-# LANGUAGE DataKinds #-}
29−{-# LANGUAGE DeriveGeneric #-}
30−{-# LANGUAGE OverloadedStrings #-}
31−{-# LANGUAGE TypeFamilies #-}
32−{-# LANGUAGE TypeOperators #-}
33−
34−import Prelude ()
35−import Prelude.Compat
36−
28+{-# LANGUAGE OverloadedStrings, TypeFamilies, DataKinds,
29+ DeriveGeneric, TypeOperators #-}
3730import Control.Monad.IO.Class (liftIO)
3831import Control.Monad.Reader
3932import Data.Aeson
@@ -254,7 +247,7 @@ loginHandler cookieSettings jwtSettings form = do
254247 liftIO $ pushLogStrLn logset $ toLogStr logMsg
255248 throwError err401
256249 Just applyCookies -> do
257− let successMsg = logMsg{message = "AdminUser successfully authenticated!"}
250+ let successMsg = logMsg{message = "AdminUser succesfully authenticated!"}
258251 liftIO $ pushLogStrLn logset $ toLogStr successMsg
259252 pure $ applyCookies successMsg
260253loginHandler _ _ _ = throwError err401
@@ -287,7 +280,7 @@ mkApp cfg cs jwts ctx =
287280 (flip runReaderT ctx) (adminServer cs jwts)
288281```
289282
290−One footnote: because we'd like our logs to be in JSON form, we'll also create a `Middleware` object
283+One footenote: because we'd like our logs to be in JSON form, we'll also create a `Middleware` object
291284so that `Warp` *also* will emit logs as JSON. This will ensure *all* logs are emitted as JSON:
292285
293286```haskell
doc/cookbook/hoist-server-with-context/hoist-server-with-context.cabal+5−6
@@ -1,22 +1,21 @@
1−cabal-version: 2.2
21name: cookbook-hoist-server-with-context
32version: 0.0.1
43synopsis: JWT and basic access authentication with a Custom Monad cookbook example
54description: Using servant-auth to support both JWT-based and basic
65 authentication.
7−homepage: http://docs.servant.dev/
8−license: BSD-3-Clause
6+homepage: http://haskell-servant.readthedocs.org/
7+license: BSD3
98license-file: ../../../servant/LICENSE
109author: Servant Contributors
1110maintainer: haskell-servant-maintainers@googlegroups.com
1211category: Servant
1312build-type: Simple
14−tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
13+cabal-version: >=1.10
14+tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.1
1515
1616executable cookbook-hoist-server-with-context
1717 main-is: HoistServerWithContext.lhs
1818 build-depends: base == 4.*
19− , base-compat
2019 , text >= 1.2
2120 , aeson >= 1.2
2221 , data-default
@@ -24,7 +23,7 @@ executable cookbook-hoist-server-with-context
2423 , servant
2524 , servant-server
2625 , servant-auth >= 0.3.2
27− , servant-auth-server >= 0.4.4.0
26+ , servant-auth-server
2827 , time
2928 , warp >= 3.2
3029 , wai >= 3.2
doc/cookbook/https/Https.lhs+5−5
@@ -34,16 +34,16 @@ app = serve api server
3434```
3535
3636It's now time to actually run the `Application`.
37−The [`warp-tls`](https://hackage.haskell.org/package/warp-tls/docs/Network-Wai-Handler-WarpTLS.html)
37+The [`warp-tls`](https://hackage.haskell.org/package/warp-tls-3.2.4/docs/Network-Wai-Handler-WarpTLS.html)
3838package provides two functions for running an `Application`, called
39−[`runTLS`](https://hackage.haskell.org/package/warp-tls/docs/Network-Wai-Handler-WarpTLS.html#v:runTLS)
40−and [`runTLSSocket`](https://hackage.haskell.org/package/warp-tls/docs/Network-Wai-Handler-WarpTLS.html#v:runTLSSocket).
39+[`runTLS`](https://hackage.haskell.org/package/warp-tls-3.2.4/docs/Network-Wai-Handler-WarpTLS.html#v:runTLS)
40+and [`runTLSSocket`](https://hackage.haskell.org/package/warp-tls-3.2.4/docs/Network-Wai-Handler-WarpTLS.html#v:runTLSSocket).
4141We will be using the first one.
4242
4343It takes two arguments,
44−[the TLS settings](https://hackage.haskell.org/package/warp-tls/docs/Network-Wai-Handler-WarpTLS.html#t:TLSSettings)
44+[the TLS settings](https://hackage.haskell.org/package/warp-tls-3.2.4/docs/Network-Wai-Handler-WarpTLS.html#t:TLSSettings)
4545(certificates, keys, ciphers, etc)
46−and [the warp settings](https://hackage.haskell.org/package/warp/docs/Network-Wai-Handler-Warp-Internal.html#t:Settings)
46+and [the warp settings](https://hackage.haskell.org/package/warp-3.2.12/docs/Network-Wai-Handler-Warp-Internal.html#t:Settings)
4747(port, logger, etc).
4848
4949We will be using very simple settings for this example but you are of
doc/cookbook/https/https.cabal+5−5
@@ -1,14 +1,14 @@
1−cabal-version: 2.2
21name: cookbook-https
32version: 0.1
43synopsis: HTTPS cookbook example
5−homepage: http://docs.servant.dev/
6−license: BSD-3-Clause
4+homepage: http://haskell-servant.readthedocs.org/
5+license: BSD3
76license-file: ../../../servant/LICENSE
87author: Servant Contributors
98maintainer: haskell-servant-maintainers@googlegroups.com
109build-type: Simple
11−tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
10+cabal-version: >=1.10
11+tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.1
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.9
20+ , warp-tls >= 3.2
2121 , markdown-unlit >= 0.4
2222 default-language: Haskell2010
2323 ghc-options: -Wall -pgmL markdown-unlit
doc/cookbook/index.rst+2−8
@@ -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 `**#haskell-servant** IRC channel
10−on libera.chat <https://web.libera.chat/#haskell-servant>_ or on
9+or even to just get in touch with us on the **#servant** IRC channel
10+on freenode 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,
@@ -20,15 +20,11 @@ you name it!
2020 structuring-apis/StructuringApis.lhs
2121 generic/Generic.lhs
2222 https/Https.lhs
23− db-mysql-basics/MysqlBasics.lhs
2423 db-sqlite-simple/DBConnection.lhs
2524 db-postgres-pool/PostgresPool.lhs
2625 using-custom-monad/UsingCustomMonad.lhs
2726 using-free-client/UsingFreeClient.lhs
28− custom-errors/CustomErrors.lhs
29− uverb/UVerb.lhs
3027 basic-auth/BasicAuth.lhs
31− basic-streaming/Streaming.lhs
3228 jwt-and-basic-auth/JWTAndBasicAuth.lhs
3329 hoist-server-with-context/HoistServerWithContext.lhs
3430 file-upload/FileUpload.lhs
@@ -36,5 +32,3 @@ you name it!
3632 curl-mock/CurlMock.lhs
3733 sentry/Sentry.lhs
3834 testing/Testing.lhs
39− open-id-connect/OpenIdConnect.lhs
40− managed-resource/ManagedResource.lhs
doc/cookbook/jwt-and-basic-auth/jwt-and-basic-auth.cabal+5−5
@@ -1,17 +1,17 @@
1−cabal-version: 2.2
21name: cookbook-jwt-and-basic-auth
32version: 0.0.1
43synopsis: JWT and basic access authentication cookbook example
54description: Using servant-auth to support both JWT-based and basic
65 authentication.
7−homepage: http://docs.servant.dev/
8−license: BSD-3-Clause
6+homepage: http://haskell-servant.readthedocs.org/
7+license: BSD3
98license-file: ../../../servant/LICENSE
109author: Servant Contributors
1110maintainer: haskell-servant-maintainers@googlegroups.com
1211category: Servant
1312build-type: Simple
14−tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
13+cabal-version: >=1.10
14+tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.1
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.4.*
25+ , servant-auth ==0.3.*
2626 , servant-auth-server >= 0.3.1.0
2727 , warp >= 3.2
2828 , wai >= 3.2
doc/cookbook/managed-resource/ManagedResource.lhsdeleted−114
@@ -1,114 +0,0 @@
1−# Request-lifetime Managed Resources
2−
3−Let's see how we can write a handle that uses a resource managed by Servant. The resource is created automatically by Servant when the server recieves a request, and the resource is automatically destroyed when the server is finished handling a request.
4−
5−As usual, we start with a little bit of throat clearing.
6−
7−
8−``` haskell
9−{-# LANGUAGE DataKinds #-}
10−{-# LANGUAGE TypeOperators #-}
11−import Control.Concurrent
12−import Control.Exception (bracket, throwIO)
13−import Control.Monad.IO.Class
14−import Control.Monad.Trans.Resource
15−import Data.Acquire
16−import Network.HTTP.Client (newManager, defaultManagerSettings)
17−import Network.Wai.Handler.Warp
18−import Servant
19−import Servant.Client
20−import System.IO
21−```
22−
23−Here we define an API type that uses the `WithResource` combinator. The server handler for an endpoint with a `WithResource res` component will receive a value of that type as an argument.
24−
25−``` haskell
26−type API = WithResource Handle :> ReqBody '[PlainText] String :> Post '[JSON] NoContent
27−
28−api :: Proxy API
29−api = Proxy
30−```
31−
32−But this resource value has to come from somewhere. Servant obtains the value using an Acquire provided in the context. The Acquire knows how to both create and destroy resources of a particular type.
33−
34−``` haskell
35−appContext :: Context '[Acquire Handle]
36−appContext = acquireHandle :. EmptyContext
37−
38−acquireHandle :: Acquire Handle
39−acquireHandle = mkAcquire newHandle closeHandle
40−
41−newHandle :: IO Handle
42−newHandle = do
43− putStrLn "opening file"
44− h <- openFile "test.txt" AppendMode
45− putStrLn "opened file"
46− return h
47−
48−closeHandle :: Handle -> IO ()
49−closeHandle h = do
50− putStrLn "closing file"
51− hClose h
52− putStrLn "closed file"
53−```
54−
55−Now we create the handler which will use this resource. This handler will write the request message to the System.IO.Handle which was provided to us. In some situations the handler will succeed, but in some in will fail. In either case, Servant will clean up the resource for us.
56−
57−``` haskell
58−server :: Server API
59−server = writeToFile
60−
61− where writeToFile :: (ReleaseKey, Handle) -> String -> Handler NoContent
62− writeToFile (_, h) msg = case msg of
63− "illegal" -> error "wait, that's illegal!"
64− legalMsg -> liftIO $ do
65− putStrLn "writing file"
66− hPutStrLn h legalMsg
67− putStrLn "wrote file"
68− return NoContent
69−```
70−
71−Finally we run the server in the background while we post messages to it.
72−
73−``` haskell
74−runApp :: IO ()
75−runApp = run 8080 (serveWithContext api appContext $ server)
76−
77−postMsg :: String -> ClientM NoContent
78−postMsg = client api
79−
80−main :: IO ()
81−main = do
82− mgr <- newManager defaultManagerSettings
83− bracket (forkIO $ runApp) killThread $ \_ -> do
84− ms <- flip runClientM (mkClientEnv mgr (BaseUrl Http "localhost" 8080 "")) $ do
85− liftIO $ putStrLn "sending hello message"
86− _ <- postMsg "hello"
87− liftIO $ putStrLn "sending illegal message"
88− _ <- postMsg "illegal"
89− liftIO $ putStrLn "done"
90− print ms
91−```
92−
93−This program prints
94−
95−```
96−sending hello message
97−opening file
98−opened file
99−writing file
100−wrote file
101−closing file
102−closed file
103−sending illegal message
104−opening file
105−opened file
106−closing file
107−closed file
108−wait, that's illegal!
109−CallStack (from HasCallStack):
110− error, called at ManagedResource.lhs:63:24 in main:Main
111−Left (FailureResponse (Request {requestPath = (BaseUrl {baseUrlScheme = Http, baseUrlHost = "localhost", baseUrlPort = 8080, baseUrlPath = ""},""), requestQueryString = fromList [], requestBody = Just ((),text/plain;charset=utf-8), requestAccept = fromList [], requestHeaders = fromList [], requestHttpVersion = HTTP/1.1, requestMethod = "POST"}) (Response {responseStatusCode = Status {statusCode = 500, statusMessage = "Internal Server Error"}, responseHeaders = fromList [("Transfer-Encoding","chunked"),("Date","Thu, 24 Nov 2022 21:04:47 GMT"),("Server","Warp/3.3.23"),("Content-Type","text/plain; charset=utf-8")], responseHttpVersion = HTTP/1.1, responseBody = "Something went wrong"}))
112−```
113−
114−and appends to a file called `test.txt`. We can see from the output that when a legal message is sent, the file is opened, written to, and closed. We can also see that when an illegal message is sent, the file is opened but not written to. Crucially, it is still closed even though the handler threw an exception.
doc/cookbook/managed-resource/managed-resource.cabaldeleted−30
@@ -1,30 +0,0 @@
1−cabal-version: 2.2
2−name: cookbook-managed-resource
3−version: 0.1
4−synopsis: Simple managed resource cookbook example
5−homepage: http://docs.servant.dev/
6−license: BSD-3-Clause
7−license-file: ../../../servant/LICENSE
8−author: Servant Contributors
9−maintainer: haskell-servant-maintainers@googlegroups.com
10−build-type: Simple
11−tested-with: GHC==9.4.2
12−
13−executable cookbook-managed-resource
14− main-is: ManagedResource.lhs
15− build-depends: base == 4.*
16− , text >= 1.2
17− , aeson >= 1.2
18− , servant
19− , servant-client
20− , servant-server
21− , warp >= 3.2
22− , wai >= 3.2
23− , http-types >= 0.12
24− , markdown-unlit >= 0.4
25− , http-client >= 0.5
26− , transformers
27− , resourcet
28− default-language: Haskell2010
29− ghc-options: -Wall -pgmL markdown-unlit
30− build-tool-depends: markdown-unlit:markdown-unlit
doc/cookbook/open-id-connect/OpenIdConnect.cabaldeleted−45
@@ -1,45 +0,0 @@
1−cabal-version: 2.2
2−name: open-id-connect
3−version: 0.1
4−synopsis: OpenId Connect with Servant example
5−homepage: http://haskell-servant.readthedocs.org/
6−license: BSD-3-Clause
7−license-file: ../../../servant/LICENSE
8−author: Servant Contributors
9−maintainer: haskell-servant-maintainers@googlegroups.com
10−build-type: Simple
11−tested-with: GHC==8.6.5
12−
13−executable cookbook-openidconnect
14− main-is: OpenIdConnect.lhs
15− build-depends: base ==4.*
16− , aeson
17− , aeson-pretty
18− , binary
19− , blaze-html
20− , blaze-markup
21− , bytestring
22− , case-insensitive
23− , cereal
24− , containers
25− , generic-lens
26− , http-client
27− , http-client-tls
28− , http-types
29− , jose-jwt
30− , lens
31− , lens-aeson
32− , oidc-client
33− , protolude
34− , random
35− , servant
36− , servant-blaze
37− , servant-server
38− , text
39− , time
40− , vector
41− , wai
42− , warp >= 3.2
43− default-language: Haskell2010
44− ghc-options: -Wall -Wcompat -Wincomplete-uni-patterns -Wredundant-constraints -Wnoncanonical-monad-instances -pgmL markdown-unlit
45− build-tool-depends: markdown-unlit:markdown-unlit >= 0.4
doc/cookbook/open-id-connect/OpenIdConnect.lhsdeleted−472
@@ -1,472 +0,0 @@
1−[OpenID Connect](https://openid.net/connect/)
2−=============================================
3−
4−Use OpenID Connect to authenticate your users.
5−This example use google OIDC provider.
6−It was made for a working with single page application where
7−some login token would be saved in the user agent local storage.
8−
9−Workflow:
10−
11−1. user is presented with a login button,
12−2. when the user clicks on the button it is redirected to the OIDC
13− provider,
14−3. the user login in the OIDC provider,
15−4. the OIDC provider will redirect the user and provide a `code`,
16−5. the server will use this code to make a POST to the OIDC provider
17− and will get back authentication infos,
18−6. The user will get display an HTML page that will save a secret
19− identifying him in the local storage, then it will be redirected to
20− /.
21−
22−Let's put the imports behind us:
23−
24−``` haskell
25−{-# LANGUAGE DataKinds #-}
26−{-# LANGUAGE DeriveGeneric #-}
27−{-# LANGUAGE DuplicateRecordFields #-}
28−{-# LANGUAGE FlexibleContexts #-}
29−{-# LANGUAGE FlexibleInstances #-}
30−{-# LANGUAGE MultiParamTypeClasses #-}
31−{-# LANGUAGE NoImplicitPrelude #-}
32−{-# LANGUAGE OverloadedLists #-}
33−{-# LANGUAGE OverloadedStrings #-}
34−{-# LANGUAGE PartialTypeSignatures #-}
35−{-# LANGUAGE PolyKinds #-}
36−{-# LANGUAGE RankNTypes #-}
37−{-# LANGUAGE RecordWildCards #-}
38−{-# LANGUAGE ScopedTypeVariables #-}
39−{-# LANGUAGE TypeFamilies #-}
40−{-# LANGUAGE TypeOperators #-}
41−{-# LANGUAGE TypeSynonymInstances #-}
42−
43−module Main where
44−
45−import Protolude
46−
47−import Data.Aeson
48− (FromJSON (..), (.:))
49−import qualified Data.Aeson as JSON
50−import qualified Data.Aeson.Types as AeT
51−import qualified Data.ByteString.Lazy as LBS
52−import qualified Data.List as List
53−import qualified Data.Text as Text
54−import Jose.Jwt
55− (Jwt (..), decodeClaims)
56−import Network.HTTP.Client
57− (Manager, newManager)
58−import Network.HTTP.Client.TLS
59− (tlsManagerSettings)
60−import Network.Wai.Handler.Warp
61− (run)
62−import Servant
63−import Servant.HTML.Blaze
64− (HTML)
65−import qualified System.Random as Random
66−import Text.Blaze
67− (ToMarkup (..))
68−import qualified Text.Blaze.Html as H
69−import Text.Blaze.Html5
70− ((!))
71−import qualified Text.Blaze.Html5 as H
72−import qualified Text.Blaze.Html5.Attributes as HA
73−import Text.Blaze.Renderer.Utf8
74− (renderMarkup)
75−import qualified Web.OIDC.Client as O
76−```
77−
78−You'll need to create a new OpenID Connect client in an OpenID Provider.
79−This example was tested with Google.
80−
81−You can find a list of public OIDC provider here:
82−https://connect2id.com/products/nimbus-oauth-openid-connect-sdk/openid-connect-providers
83−
84−I copied some here:
85−
86−- Google: https://developers.google.com/identity/protocols/OpenIDConnect
87− more precisely: https://console.developers.google.com/apis/credentials
88−- Microsoft: https://docs.microsoft.com/en-us/previous-versions/azure/dn645541(v=azure.100)
89−- Yahoo: https://developer.yahoo.com/oauth2/guide/openid_connect/
90−- PayPal: https://developer.paypal.com/docs/integration/direct/identity/log-in-with-paypal/
91−
92−During the configuration you'll need to provide a redirect uri.
93−The redirect_uri should correspond to the uri user will be redirected to
94−after a successful login into the OpenID provider.
95−
96−So during your test, you should certainly just use `http://localhost:3000/login/cb`.
97−In general you should use your own domain name.
98−
99−You'll then be given a `client_id` and a `client_password`.
100−Fill those values in here:
101−
102−``` haskell
103−oidcConf :: OIDCConf
104−oidcConf = OIDCConf { redirectUri = "http://localhost:3000/login/cb"
105− , clientId = "xxxxxxxxxxxx-xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx.apps.googleusercontent.com"
106− , clientPassword = "************************" }
107−```
108−
109−Then we declare our main server:
110−
111−``` haskell
112−main :: IO ()
113−main = do
114− oidcEnv <- initOIDC oidcConf
115− run 3000 (app oidcEnv)
116−
117−type API = IdentityRoutes Customer
118− :<|> Get '[HTML] Homepage
119−
120−api :: Proxy API
121−api = Proxy
122−
123−server :: OIDCEnv -> Server API
124−server oidcEnv = serveOIDC oidcEnv handleOIDCLogin
125− :<|> return Homepage
126−
127−-- | Then main app
128−app :: OIDCEnv -> Application
129−app oidcEnv = serve api (server oidcEnv)
130−```
131−
132−OIDC
133−----
134−
135−That part try to separate concern, and certainly in a real world
136−application that should be in its distinct module.
137−
138−``` haskell
139−-- * OIDC
140−
141−data OIDCConf =
142− OIDCConf { redirectUri :: ByteString
143− , clientId :: ByteString
144− , clientPassword :: ByteString
145− } deriving (Show, Eq)
146−```
147−
148−First we need to initialize OIDC.
149−A short explanation about it:
150−
151−- to complete the workflow we need to make a POST request to the OIDC provider.
152− So we need to create an http manager to make those call properly.
153−- Then in order to prevent replay attack, each time an user wants to login we
154− should provide a random string called the `state`. When the user is
155− redirected to the `redirect_uri`, the OIDC provider should provide the same
156− `state` along a `code` parameter.
157−
158−``` haskell
159−initOIDC :: OIDCConf -> IO OIDCEnv
160−initOIDC OIDCConf{..} = do
161− mgr <- newManager tlsManagerSettings
162− prov <- O.discover "https://accounts.google.com" mgr
163− let oidc = O.setCredentials clientId clientPassword redirectUri (O.newOIDC prov)
164− return OIDCEnv { oidc = oidc
165− , mgr = mgr
166− , genState = genRandomBS
167− , prov = prov
168− , redirectUri = redirectUri
169− , clientId = clientId
170− , clientPassword = clientPassword
171− }
172−
173−data OIDCEnv = OIDCEnv { oidc :: O.OIDC
174− , mgr :: Manager
175− , genState :: IO ByteString
176− , prov :: O.Provider
177− , redirectUri :: ByteString
178− , clientId :: ByteString
179− , clientPassword :: ByteString
180− }
181−```
182−
183−The `IdentityRoutes` are two endpoints:
184−
185−- an endpoint to redirect the users to the OIDC Provider,
186−- another one the user will be redirected to from the OIDC Provider.
187−
188−``` haskell
189−type IdentityRoutes a =
190− "login" :> ( -- redirect User to the OpenID Provider
191− Get '[JSON] NoContent
192− -- render the page that will save the user creds in the user-agent
193− :<|> "cb" :> QueryParam "error" Text
194− :> QueryParam "code" Text
195− :> Get '[HTML] User)
196−
197−-- | gen a 302 redirect helper
198−redirects :: (StringConv s ByteString) => s -> Handler ()
199−redirects url = throwError err302 { errHeaders = [("Location",toS url)]}
200−```
201−
202−That function will generate the URL to redirect the users to when
203−they'll click on the login link: `https://yourdomain/login`.
204−
205−``` haskell
206−genOIDCURL :: OIDCEnv -> IO ByteString
207−genOIDCURL OIDCEnv{..} = do
208− st <- genState -- generate a random string
209− let oidcCreds = O.setCredentials clientId clientPassword redirectUri (O.newOIDC prov)
210− loc <- O.getAuthenticationRequestUrl oidcCreds [O.openId, O.email, O.profile] (Just st) []
211− return (show loc)
212−
213−handleLogin :: OIDCEnv -> Handler NoContent
214−handleLogin oidcenv = do
215− loc <- liftIO (genOIDCURL oidcenv)
216− redirects loc
217− return NoContent
218−```
219−
220−The `AuthInfo` is about the infos we can grab from OIDC provider.
221−
222−To be more precise, the user should come with a `code` (a token) and
223−POSTing that code to the correct OIDC provider endpoint should return a JSON
224−object. One of the fields should be named `id_token` which should be a
225−JWT containing all the information we need. Depending on the scopes we
226−asked we might get more information.
227−
228−``` haskell
229−-- | @AuthInfo@
230−data AuthInfo = AuthInfo { email :: Text
231− , emailVerified :: Bool
232− , name :: Text } deriving (Eq, Show, Generic)
233−
234−instance FromJSON AuthInfo where
235− parseJSON (JSON.Object v) = do
236− email :: Text <- v .: "email"
237− email_verified :: Bool <- v .: "email_verified"
238− name :: Text <- v .: "name"
239− return $ AuthInfo (toS email) email_verified (toS name)
240− parseJSON invalid = AeT.typeMismatch "Coord" invalid
241−instance JSON.ToJSON AuthInfo where
242− toJSON (AuthInfo e ev n) =
243− JSON.object [ "email" JSON..= (toS e :: Text)
244− , "email_verified" JSON..= ev
245− , "name" JSON..= (toS n :: Text)
246− ]
247−
248−type LoginHandler = AuthInfo -> IO (Either Text User)
249−```
250−
251−The `handleLoggedIn` is that part that will retrieve the information from
252−the user once he is redirected from the OIDC Provider after login.
253−
254−If the user is redirected to the `redirect_uri` but with an `error` query
255−parameter then it means something went wrong.
256−If there is no error query param but a `code` query param it means the user
257−successfully logged in. From there we need to make a request to the token
258−endpoint of the OIDC provider. It's a POST that should contain the code
259−as well as the client id and secret.
260−Making this HTTP POST is the responsibility of `requestTokens`.
261−
262−From there we extract the `claims` of the JWT contained in one of the value
263−of the JSON returned by the POST HTTP Request.
264−
265−``` haskell
266−data User = User { userId :: Text
267− , userSecret :: Text
268− , localStorageKey :: Text
269− , redirectUrl :: Maybe Text
270− } deriving (Show,Eq,Ord)
271−
272−handleLoggedIn :: OIDCEnv
273− -> LoginHandler -- ^ handle successful id
274− -> Maybe Text -- ^ error
275− -> Maybe Text -- ^ code
276− -> Handler User
277−handleLoggedIn oidcenv handleSuccessfulId err mcode =
278− case err of
279− Just errorMsg -> forbidden errorMsg
280− Nothing -> case mcode of
281− Just oauthCode -> do
282− tokens <- liftIO $ O.requestTokens (oidc oidcenv) (toS oauthCode) (mgr oidcenv)
283− putText . show . O.claims . O.idToken $ tokens
284− let jwt = toS . unJwt . O.jwt . O.idToken $ tokens
285− eAuthInfo = decodeClaims jwt :: Either O.JwtError (O.JwtHeader,AuthInfo)
286− case eAuthInfo of
287− Left jwtErr -> forbidden $ "JWT decode/check problem: " <> show jwtErr
288− Right (_,authInfo) ->
289− if emailVerified authInfo
290− then do
291− user <- liftIO $ handleSuccessfulId authInfo
292− either forbidden return user
293− else forbidden "Please verify your email"
294− Nothing -> do
295− liftIO $ putText "No code param"
296− forbidden "no code parameter given"
297−```
298−
299−When you render a User with blaze-html, it will generate a page with a js
300−that will put a secret for that user in the local storage. And it will
301−redirect the user to /.
302−
303−``` haskell
304−instance ToMarkup User where
305− toMarkup User{..} = H.docTypeHtml $ do
306− H.head $
307− H.title "Logged In"
308− H.body $ do
309− H.h1 "Logged In"
310− H.p (H.toHtml ("Successful login with id " <> userId))
311− H.script (H.toHtml ("localStorage.setItem('" <> localStorageKey <> "','" <> userSecret <> "');"
312− <> "localStorage.setItem('user-id','" <> userId <> "');"
313− <> "window.location='" <> fromMaybe "/" redirectUrl <> "';" -- redirect the user to /
314− ));
315−
316−serveOIDC :: OIDCEnv -> LoginHandler -> Server (IdentityRoutes a)
317−serveOIDC oidcenv loginHandler =
318− handleLogin oidcenv :<|> handleLoggedIn oidcenv loginHandler
319−
320−-- * Auth
321−type APIKey = ByteString
322−type Account = Text.Text
323−type Conf = [(APIKey,Account)]
324−data Customer = Customer {
325− account :: Account
326− , apiKey :: APIKey
327− , mail :: Maybe Text
328− , fullname :: Maybe Text
329− }
330−```
331−
332−Here is the code that displays the homepage.
333−It should contain a link to the `/login` URL.
334−When the user clicks on this link it will be redirected to Google login page
335−with some generated information.
336−
337−The page also displays the content of the local storage.
338−And in particular the items `api-key` and `user-id`.
339−Those items should be set after a successful login when the user is redirected to
340−`/login/cb`.
341−
342−The logic used generally is to use that api-key to uniquely identify an user.
343−Another option would have been to set a cookie.
344−
345−``` haskell
346−data Homepage = Homepage
347−
348−instance ToMarkup Homepage where
349− toMarkup Homepage = H.docTypeHtml $ do
350− H.head $ do
351− H.title "OpenID Connect Servant Example"
352− H.style (H.toHtml ("body { font-family: monospace; font-size: 18px; }" :: Text.Text))
353− H.body $ do
354− H.h1 "OpenID Connect Servant Example"
355− H.div $
356− H.a ! HA.href "/login" $ "Click here to login"
357− H.ul $ do
358− H.li $ do
359− H.span "API Key in Local storage: "
360− H.script (H.toHtml ("document.write(localStorage.getItem('api-key'));" :: Text.Text))
361− H.li $ do
362− H.span "User ID in Local storage: "
363− H.script (H.toHtml ("document.write(localStorage.getItem('user-id'));" :: Text.Text))
364−```
365−
366−We need some helpers to generate random string for generating state and API Keys.
367−
368−``` haskell
369−-- | generate a random ByteString, not necessarily extremely good randomness
370−-- still the password will be long enough to be very difficult to crack
371−genRandomBS :: IO ByteString
372−genRandomBS = do
373− g <- Random.newStdGen
374− Random.randomRs (0, n) g & take 42 & fmap toChar & readable 0 & toS & return
375− where
376− n = length letters - 1
377− toChar i = letters List.!! i
378− letters = ['A'..'Z'] <> ['0'..'9'] <> ['a'..'z']
379− readable :: Int -> [Char] -> [Char]
380− readable _ [] = []
381− readable i str =
382− let blocksize = case n of
383− 0 -> 8
384− 1 -> 4
385− 2 -> 4
386− 3 -> 4
387− _ -> 12
388− block = take blocksize str
389− rest = drop blocksize str
390− in if List.null rest
391− then str
392− else block <> "-" <> readable (i+1) rest
393−
394−customerFromAuthInfo :: AuthInfo -> IO Customer
395−customerFromAuthInfo authinfo = do
396− apikey <- genRandomBS
397− return Customer { account = toS (email authinfo)
398− , apiKey = apikey
399− , mail = Just (toS (email authinfo))
400− , fullname = Just (toS (name authinfo))
401− }
402−
403−handleOIDCLogin :: LoginHandler
404−handleOIDCLogin authInfo = do
405− custInfo <- customerFromAuthInfo authInfo
406− if emailVerified authInfo
407− then return . Right . customerToUser $ custInfo
408− else return (Left "You emails is not verified by your provider. Please verify your email.")
409− where
410− customerToUser :: Customer -> User
411− customerToUser c =
412− User { userId = toS (account c)
413− , userSecret = toS (apiKey c)
414− , redirectUrl = Nothing
415− , localStorageKey = "api-key"
416− }
417−```
418−
419−`Error` helpers
420−---------------
421−
422−``` haskell
423−data Err = Err { errTitle :: Text
424− , errMsg :: Text }
425−
426−instance ToMarkup Err where
427− toMarkup Err{..} = H.docTypeHtml $ do
428− H.head $ do
429− H.title "Error"
430− H.body $ do
431− H.h1 (H.a ! HA.href "/" $ "Home")
432− H.h2 (H.toHtml errTitle)
433− H.p (H.toHtml errMsg)
434−
435−format :: ToMarkup a => a -> LBS.ByteString
436−format err = toMarkup err & renderMarkup
437−
438−appToErr :: ServerError -> Text -> ServerError
439−appToErr x msg = x
440− { errBody = toS $ format (Err (toS (errReasonPhrase x)) msg)
441− , errHeaders = [("Content-Type","text/html")]}
442−
443−unauthorized :: (MonadError ServerError m) => Text -> m a
444−unauthorized = throwError . unauthorizedErr
445−
446−unauthorizedErr :: Text -> ServerError
447−unauthorizedErr = appToErr err401
448−
449−forbidden :: (MonadError ServerError m) => Text -> m a
450−forbidden = throwError . forbiddenErr
451−
452−forbiddenErr :: Text -> ServerError
453−forbiddenErr = appToErr err403
454−
455−notFound :: ( MonadError ServerError m) => Text -> m a
456−notFound = throwError . notFoundErr
457−
458−notFoundErr :: Text -> ServerError
459−notFoundErr = appToErr err404
460−
461−preconditionFailed :: ( MonadError ServerError m) => Text -> m a
462−preconditionFailed = throwError . preconditionFailedErr
463−
464−preconditionFailedErr :: Text -> ServerError
465−preconditionFailedErr = appToErr err412
466−
467−serverError :: ( MonadError ServerError m) => Text -> m a
468−serverError = throwError . serverErrorErr
469−
470−serverErrorErr :: Text -> ServerError
471−serverErrorErr = appToErr err500
472−```
doc/cookbook/pagination/Pagination.lhs+8−8
@@ -18,7 +18,7 @@ For example: `Range: createdAt 2017-01-15T23:14:67.000Z; offset 5; order desc` i
1818the client is willing to retrieve the next batch of document in descending order that were
1919created after the fifteenth of January, skipping the first 5.
2020
21−As a response, the server may return the list of corresponding documents, and augment the
21+As a response, the server may return the list of corresponding document, and augment the
2222response with 3 headers:
2323
2424- `Accept-Ranges`: A comma-separated list of fields upon which a range can be defined
@@ -127,7 +127,7 @@ defaultRange =
127127 getDefaultRange (Proxy @Color)
128128```
129129
130−Note that `getFieldValue :: Proxy "name" -> Color -> String` is the minimal complete definition
130+Note that `getFieldValue :: Proxy "name" -> Color -> String` is the minimal complete definintion
131131of the class. Yet, you can define `getRangeOptions` to provide different parsing options (see
132132the last section of this guide). In the meantime, we've also defined a `defaultRange` as it will
133133come in handy when defining our handler.
@@ -148,7 +148,7 @@ type MyHeaders =
148148```
149149
150150`PageHeaders` is a type alias provided by the library to declare the necessary response headers
151−we mentioned in introduction. Expanding the alias boils down to the following:
151+we mentionned in introduction. Expanding the alias boils down to the following:
152152
153153``` haskell
154154-- type MyHeaders =
@@ -165,7 +165,7 @@ not, _servant-pagination_ provides an easy way to lift a collection of resources
165165#### Server
166166
167167Time to connect the last bits by defining the server implementation of our colorful API. The `Ranges`
168−type we've defined above (tied to the `Range` HTTP header) indicates the server to parse any `Range`
168+type we've defined above (tight to the `Range` HTTP header) indicates the server to parse any `Range`
169169header, looking for the format defined in introduction with fields and target types we have just declared.
170170If no such header is provided, we will end up receiving `Nothing`. Otherwise, it will be possible
171171to _extract_ a `Range` from our `Ranges`.
@@ -192,7 +192,7 @@ the format we defined, where `<field>` here can only be `name` and `<value>` mus
192192- `Range: <field> [<value>][; offset <o>][; limit <l>][; order <asc|desc>]`
193193
194194Beside the target field, everything is pretty much optional in the `Range` HTTP header. Missing parts
195−are deduced from the `RangeOptions` that are part of the `HasPagination` instance. Therefore, all
195+are deducted from the `RangeOptions` that are part of the `HasPagination` instance. Therefore, all
196196following examples are valid requests to send to our server:
197197
198198- 1 - `curl http://localhost:1442/colors -vH 'Range: name'`
@@ -219,7 +219,7 @@ The previous ranges reads as follows:
219219Note that in the simple above scenario, there's no ambiguity with `extractRange` and `returnRange`
220220because there's only one possible `Range` defined on our resource. Yet, as you've most probably
221221noticed, the `Ranges` combinator accepts a list of fields, each of which must declare a `HasPagination`
222−instance. Doing so will make the other helper functions more ambiguous and type annotations are
222+instance. Doing so will make the other helper functions more ambiguous and type annotation are
223223highly likely to be needed.
224224
225225
@@ -235,8 +235,8 @@ instance HasPagination Color "hex" where
235235#### Parsing Options
236236
237237By default, `servant-pagination` provides an implementation of `getRangeOptions` for each
238−`HasPagination` instance. However, this can be overridden when defining the instance to provide
239−your own options. These options come into play when a `Range` header is received and isn't fully
238+`HasPagination` instance. However, this can be overwritten when defining the instance to provide
239+your own options. This options come into play when a `Range` header is received and isn't fully
240240specified (`limit`, `offset`, `order` are all optional) to provide default fallback values for those.
241241
242242For instance, let's say we wanted to change the default limit to `5` in a new range on
doc/cookbook/pagination/pagination.cabal+5−5
@@ -1,21 +1,21 @@
1−cabal-version: 2.2
21name: cookbook-pagination
32version: 2.1
43synopsis: Pagination with Servant example
5−homepage: http://docs.servant.dev/
6−license: BSD-3-Clause
4+homepage: http://haskell-servant.readthedocs.org/
5+license: BSD3
76license-file: ../../../servant/LICENSE
87author: Servant Contributors
98maintainer: haskell-servant-maintainers@googlegroups.com
109build-type: Simple
11−tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
10+cabal-version: >=1.10
11+tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.1
1212
1313executable cookbook-pagination
1414 main-is: Pagination.lhs
1515 build-tool-depends: markdown-unlit:markdown-unlit
1616 default-language: Haskell2010
1717 ghc-options: -Wall -pgmL markdown-unlit
18− build-depends: base >= 4.9 && <5
18+ build-depends: base >= 4.8 && <4.13
1919 , aeson
2020 , servant
2121 , servant-server
doc/cookbook/sentry/Sentry.lhs+2−2
@@ -79,14 +79,14 @@ It does three things. First it initializes the service which will communicate wi
7979
8080- the Sentry `DSN`, which is obtained when creating a new project on Sentry
8181- a default way to update sentry fields, where we use the identity function
82−- an event transport, which generally would be `sendRecord`, an HTTPS capable transport which uses http-conduit
82+- an event trasport, which generally would be `sendRecord`, an HTTPS capable trasport which uses http-conduit
8383- a fallback handler, which we choose to be `silentFallback` since later we are logging to the console anyway.
8484
8585In the second step it actually sends our message to Sentry with the `register` function. Its arguments are:
8686
8787- the configured Sentry service which we just created
8888- the name of the logger
89−- the error level (see [SentryLevel](https://hackage.haskell.org/package/raven-haskell/docs/System-Log-Raven-Types.html#t:SentryLevel) for the possible options)
89+- the error level (see [SentryLevel](https://hackage.haskell.org/package/raven-haskell-0.1.2.0/docs/System-Log-Raven-Types.html#t:SentryLevel) for the possible options)
9090- the message we want to send
9191- an update function to handle the specific `SentryRecord`
9292
doc/cookbook/sentry/sentry.cabal+4−4
@@ -1,14 +1,14 @@
1−cabal-version: 2.2
21name: cookbook-sentry
32version: 0.1
43synopsis: Collecting runtime exceptions using Sentry
5−homepage: http://docs.servant.dev/
6−license: BSD-3-Clause
4+homepage: http://haskell-servant.readthedocs.org/
5+license: BSD3
76license-file: ../../../servant/LICENSE
87author: Servant Contributors
98maintainer: haskell-servant-maintainers@googlegroups.com
109build-type: Simple
11−tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
10+cabal-version: >=1.10
11+tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.1
1212
1313executable cookbook-sentry
1414 main-is: Sentry.lhs
doc/cookbook/structuring-apis/StructuringApis.lhs+1−1
@@ -144,7 +144,7 @@ simpleAPIServer
144144 :: m [a]
145145 -> (i -> m a)
146146 -> (a -> m NoContent)
147− -> ServerT (SimpleAPI name a i) m
147+ -> Server (SimpleAPI name a i) m
148148simpleAPIServer listAs getA postA =
149149 listAs :<|> getA :<|> postA
150150
doc/cookbook/structuring-apis/structuring-apis.cabal+4−4
@@ -1,14 +1,14 @@
1−cabal-version: 2.2
21name: cookbook-structuring-apis
32version: 0.1
43synopsis: Example that shows how APIs can be structured
5−homepage: http://docs.servant.dev/
6−license: BSD-3-Clause
4+homepage: http://haskell-servant.readthedocs.org/
5+license: BSD3
76license-file: ../../../servant/LICENSE
87author: Servant Contributors
98maintainer: haskell-servant-maintainers@googlegroups.com
109build-type: Simple
11−tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
10+cabal-version: >=1.10
11+tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.1
1212
1313executable cookbook-structuring-apis
1414 main-is: StructuringApis.lhs
doc/cookbook/testing/Testing.lhs+15−13
@@ -142,31 +142,33 @@ of it and see how it responds.
142142Let's write some tests:
143143
144144```haskell
145−withUserApp :: (Warp.Port -> IO ()) -> IO ()
145+withUserApp :: IO () -> IO ()
146146withUserApp action =
147− -- testWithApplication makes sure the action is executed after the server has
148− -- started and is being properly shutdown.
149− Warp.testWithApplication (pure userApp) action
147+ -- we can spin up a server in another thread and kill that thread when done
148+ -- in an exception-safe way
149+ bracket (liftIO $ C.forkIO $ Warp.run 8888 userApp)
150+ C.killThread
151+ (const action)
150152
151153
152154businessLogicSpec :: Spec
153155businessLogicSpec =
154156 -- `around` will start our Server before the tests and turn it off after
155− around withUserApp $ do
157+ around_ withUserApp $ do
156158 -- create a test client function
157159 let createUser = client (Proxy :: Proxy UserApi)
158160 -- create a servant-client ClientEnv
159− baseUrl <- runIO $ parseBaseUrl "http://localhost"
161+ baseUrl <- runIO $ parseBaseUrl "http://localhost:8888"
160162 manager <- runIO $ newManager defaultManagerSettings
161− let clientEnv port = mkClientEnv manager (baseUrl { baseUrlPort = port })
163+ let clientEnv = mkClientEnv manager baseUrl
162164
163165 -- testing scenarios start here
164166 describe "POST /user" $ do
165− it "should create a user with a high enough ID" $ \port -> do
166− result <- runClientM (createUser 50001) (clientEnv port)
167+ it "should create a user with a high enough ID" $ do
168+ result <- runClientM (createUser 50001) clientEnv
167169 result `shouldBe` (Right $ User { name = "some user", user_id = 50001})
168− it "will it fail with a too-small ID?" $ \port -> do
169− result <- runClientM (createUser 4999) (clientEnv port)
170+ it "will it fail with a too-small ID?" $ do
171+ result <- runClientM (createUser 4999) clientEnv
170172 result `shouldBe` (Right $ User { name = "some user", user_id = 50001})
171173```
172174
@@ -232,7 +234,7 @@ clientEnv esHost esPort = do
232234 manager <- newManager defaultManagerSettings
233235 pure $ mkClientEnv manager baseUrl
234236
235−runSearchClient :: Text -> Text -> ClientM a -> IO (Either ClientError a)
237+runSearchClient :: Text -> Text -> ClientM a -> IO (Either ServantError a)
236238runSearchClient esHost esPort = (clientEnv esHost esPort >>=) . runClientM
237239```
238240
@@ -265,7 +267,7 @@ docServer esHost esPort = getDocById esHost esPort
265267-- actions
266268getDocById :: Text -> Text -> Integer -> Handler Value
267269getDocById esHost esPort docId = do
268− -- Our Servant Client function returns Either ClientError Value here:
270+ -- Our Servant Client function returns Either ServantError Value here:
269271 docRes <- liftIO $ runSearchClient esHost esPort (getDocument docId)
270272 case docRes of
271273 Left err -> throwError $ err404 { errBody = "Failed looking up content" }
doc/cookbook/testing/testing.cabal+5−5
@@ -1,16 +1,16 @@
1−cabal-version: 2.2
21name: cookbook-testing
32version: 0.0.1
43synopsis: Common testing patterns in Servant apps
54description: This recipe includes various strategies for writing tests for Servant.
6−homepage: http://docs.servant.dev/
7−license: BSD-3-Clause
5+homepage: http://haskell-servant.readthedocs.org/
6+license: BSD3
87license-file: ../../../servant/LICENSE
98author: Servant Contributors
109maintainer: haskell-servant-maintainers@googlegroups.com
1110category: Servant
1211build-type: Simple
13−tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
12+cabal-version: >=1.10
13+tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.1
1414
1515executable cookbook-testing
1616 main-is: Testing.lhs
@@ -23,7 +23,7 @@ executable cookbook-testing
2323 , servant
2424 , servant-client
2525 , servant-server
26− , servant-quickcheck >= 0.0.10
26+ , servant-quickcheck
2727 , http-client
2828 , http-types >= 0.12
2929 , hspec
doc/cookbook/using-custom-monad/UsingCustomMonad.lhs+1−4
@@ -1,6 +1,6 @@
11# Using a custom monad
22
3−In this section we will create an API for a book shelf without any backing DB storage.
3+In this section we will create and API for a book shelf without any backing DB storage.
44We will keep state in memory and share it between requests using `Reader` monad and `STM`.
55
66We start with a pretty standard set of imports and definition of the model:
@@ -115,6 +115,3 @@ Running cookbook-using-custom-monad...
115115[Book "To Kill a Mockingbird",Book "Harry Potter and the Order of the Phoenix"]
116116[Book "The Picture of Dorian Gray",Book "To Kill a Mockingbird",Book "Harry Potter and the Order of the Phoenix"]
117117```
118−
119−To use `Raw` endpoints, look at the
120−[servant-rawm](http://hackage.haskell.org/package/servant-rawm) package.
doc/cookbook/using-custom-monad/using-custom-monad.cabal+4−4
@@ -1,14 +1,14 @@
1−cabal-version: 2.2
21name: cookbook-using-custom-monad
32version: 0.1
43synopsis: Using custom monad to pass a state between handlers
5−homepage: http://docs.servant.dev/
6−license: BSD-3-Clause
4+homepage: http://haskell-servant.readthedocs.org/
5+license: BSD3
76license-file: ../../../servant/LICENSE
87author: Servant Contributors
98maintainer: haskell-servant-maintainers@googlegroups.com
109build-type: Simple
11−tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
10+cabal-version: >=1.10
11+tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.1
1212
1313executable cookbook-using-custom-monad
1414 main-is: UsingCustomMonad.lhs
doc/cookbook/using-free-client/UsingFreeClient.lhs+9−7
@@ -2,7 +2,7 @@
22
33or simply put: _a practical introduction to `Servant.Client.Free`_.
44
5−Someone asked on IRC how one could access the intermediate Requests (resp. Responses)
5+Someone asked on IRC how one could access the intermediate Requests (resp. Responses)
66produced (resp. received) by client functions derived using servant-client.
77My response to such inquiries is: to extend `servant-client` in an ad-hoc way (e.g for testing or debugging
88purposes), use `Servant.Client.Free`. This recipe shows how.
@@ -99,6 +99,8 @@ test = case getSquare 42 of
9999 putStrLn $ "ERROR: got pure result: " ++ show n
100100 Free (Throw err) ->
101101 putStrLn $ "ERROR: got error right away: " ++ show err
102+ Free (StreamingRequest _req _k) ->
103+ putStrLn $ "ERROR: need to do streaming request" -- TODO: no Show Req :(
102104```
103105
104106We are interested in `RunRequest`, that's what client should block on:
@@ -119,7 +121,7 @@ Now we can use `servant-client`'s internals to convert servant's `Request`
119121to http-client's `Request`, and we can inspect it:
120122
121123```haskell
122− req' <- I.defaultMakeClientRequest burl req
124+ let req' = I.requestToClientRequest burl req
123125 putStrLn $ "Making request: " ++ show req'
124126```
125127
@@ -135,13 +137,13 @@ And we continue by turning http-client's `Response` into servant's `Response`,
135137and calling the continuation. We should get a `Pure` value.
136138
137139```haskell
138− let res = I.clientResponseToResponse id res'
139−
140+ let res = I.clientResponseToResponse res'
141+
140142 case k res of
141143 Pure n ->
142144 putStrLn $ "Expected 1764, got " ++ show n
143− _ ->
144− putStrLn "ERROR: didn't get a response"
145+ _ ->
146+ putStrLn "ERROR: didn't got a response"
145147```
146148
147149So that's it. Using `Free` we can evaluate servant clients step-by-step, and
@@ -153,7 +155,7 @@ and responses available for us to inspect, since `RunClient` only gives us
153155access to one `Request` or `Response` at a time.
154156
155157On the other hand, a "batch collection" of requests and/or responses can be achieved
156−with both free clients and a custom `RunClient` instance rather easily, for example
158+with both free clients and a custom `RunClient` instance rather easily, for example
157159by using a `Writer [(Request, Response)]` monad.
158160
159161Here is an example of running our small `test` against a running server:
doc/cookbook/using-free-client/using-free-client.cabal+4−4
@@ -1,14 +1,14 @@
1−cabal-version: 2.2
21name: cookbook-using-free-client
32version: 0.1
43synopsis: Using Free client
5−homepage: http://docs.servant.dev/
6−license: BSD-3-Clause
4+homepage: http://haskell-servant.readthedocs.org/
5+license: BSD3
76license-file: ../../../servant/LICENSE
87author: Servant Contributors
98maintainer: haskell-servant-maintainers@googlegroups.com
109build-type: Simple
11−tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
10+cabal-version: >=1.10
11+tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.1
1212
1313executable cookbook-using-free-client
1414 main-is: UsingFreeClient.lhs
doc/cookbook/uverb/UVerb.lhsdeleted−223
@@ -1,223 +0,0 @@
1−# Listing alternative responses and exceptions in your API types
2−
3−Servant allows you to talk about the exceptions you throw in your API
4−types. This is not limited to actual exceptions, you can write
5−handlers that respond with arbitrary open unions of types.
6−
7−## Compatibility
8−
9−:warning: This cookbook is compatible with GHC 8.6.1 or higher :warning:
10−
11−## Preliminaries
12−
13−```haskell
14−{-# LANGUAGE ConstraintKinds #-}
15−{-# LANGUAGE DataKinds #-}
16−{-# LANGUAGE DeriveGeneric #-}
17−{-# LANGUAGE DerivingStrategies #-}
18−{-# LANGUAGE DeriveAnyClass #-}
19−{-# LANGUAGE DerivingVia #-}
20−{-# LANGUAGE FlexibleContexts #-}
21−{-# LANGUAGE FlexibleInstances #-}
22−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
23−{-# LANGUAGE InstanceSigs #-}
24−{-# LANGUAGE MultiParamTypeClasses #-}
25−{-# LANGUAGE OverloadedStrings #-}
26−{-# LANGUAGE ScopedTypeVariables #-}
27−{-# LANGUAGE StandaloneDeriving #-}
28−{-# LANGUAGE TypeApplications #-}
29−{-# LANGUAGE TypeFamilies #-}
30−{-# LANGUAGE TypeOperators #-}
31−{-# LANGUAGE UndecidableInstances #-}
32−{-# OPTIONS_GHC -Wall -Wno-orphans #-}
33−
34−import Control.Concurrent (threadDelay)
35−import Control.Concurrent.Async (async)
36−import Control.Monad (when)
37−import Control.Monad.Except (ExceptT (..), MonadError (..), MonadTrans (..), runExceptT)
38−import Data.Aeson (FromJSON (..), ToJSON (..))
39−import Data.Aeson.Encode.Pretty (encodePretty)
40−import Data.String.Conversions (cs)
41−import Data.Swagger (ToSchema)
42−import Data.Typeable (Proxy (Proxy))
43−import qualified GHC.Generics as GHC
44−import qualified Network.HTTP.Client as Client
45−import qualified Network.Wai.Handler.Warp as Warp
46−import Servant.API
47−import Servant.Client
48−import Servant.Server
49−import Servant.Swagger
50−```
51−
52−## The API
53−
54−This looks like a `Verb`-based routing table, except that `UVerb` has
55−no status, and carries a list of response types rather than a single
56−one. Each entry in the list carries its own response code.
57−
58−```haskell
59−type API =
60− "fisx" :> Capture "bool" Bool
61− :> UVerb 'GET '[JSON] '[FisxUser, WithStatus 303 String]
62− :<|> "arian"
63− :> UVerb 'GET '[JSON] '[WithStatus 201 ArianUser]
64−```
65−
66−Here are the details:
67−
68−```haskell
69−data FisxUser = FisxUser {name :: String}
70− deriving (Eq, Show, GHC.Generic)
71−
72−instance ToJSON FisxUser
73−instance FromJSON FisxUser
74−instance ToSchema FisxUser
75−
76−-- | 'HasStatus' allows us to can get around 'WithStatus' if we want
77−-- to, and associate the status code with our resource types directly.
78−--
79−-- (To avoid orphan instances and make it more explicit what's in the
80−-- API and what isn't, we could even introduce a newtype 'Resource'
81−-- that wraps all the types we're using in our routing table, and then
82−-- define lots of 'HasStatus' instances for @Resource This@ and
83−-- @Resource That@.)
84−instance HasStatus FisxUser where
85− type StatusOf FisxUser = 203
86−
87−data ArianUser = ArianUser
88− deriving (Eq, Show, GHC.Generic)
89−
90−instance ToJSON ArianUser
91−instance FromJSON ArianUser
92−instance ToSchema ArianUser
93−```
94−
95−## Server, Client, Swagger
96−
97−You can just respond with any of the elements of the union in handlers.
98−
99−```haskell
100−fisx :: Bool -> Handler (Union '[FisxUser, WithStatus 303 String])
101−fisx True = respond (FisxUser "fisx")
102−fisx False = respond (WithStatus @303 ("still fisx" :: String))
103−
104−arian :: Handler (Union '[WithStatus 201 ArianUser])
105−arian = respond (WithStatus @201 ArianUser)
106−```
107−
108−You can create client functions like you're used to:
109−
110−```
111−fisxClient :: Bool -> ClientM (Union '[FisxUser, WithStatus 303 String])
112−arianClient :: ClientM (Union '[WithStatus 201 ArianUser])
113−(fisxClient :<|> arianClient) = client (Proxy @API)
114−```
115−
116−... and that's basically it! Here are a few sample commands that
117−show you how the swagger docs look like and how you can handle the
118−result unions in clients:
119−
120−```
121−main :: IO ()
122−main = do
123− putStrLn . cs . encodePretty $ toSwagger (Proxy @API)
124− _ <- async . Warp.run 8080 $ serve (Proxy @API) (fisx :<|> arian)
125− threadDelay 50000
126− mgr <- Client.newManager Client.defaultManagerSettings
127− let cenv = mkClientEnv mgr (BaseUrl Http "localhost" 8080 "")
128− result <- runClientM (fisxClient True) cenv
129− print $ foldMapUnion (Proxy @Show) show <$> result
130− print $ matchUnion @FisxUser <$> result
131− print $ matchUnion @(WithStatus 303 String) <$> result
132− pure ()
133−```
134−
135−## Idiomatic exceptions
136−
137−Since `UVerb` (probably) will mostly be used for error-like responses, it may be desirable to be able to early abort handler, like with current servant one would use `throwError` with `ServerError`.
138−
139−```haskell
140−newtype UVerbT xs m a = UVerbT { unUVerbT :: ExceptT (Union xs) m a }
141− deriving (Functor, Applicative, Monad, MonadTrans)
142−
143−-- | Deliberately hide 'ExceptT's 'MonadError' instance to be able to use
144−-- underlying monad's instance.
145−instance MonadError e m => MonadError e (UVerbT xs m) where
146− throwError = lift . throwError
147− catchError (UVerbT act) h = UVerbT $ ExceptT $
148− runExceptT act `catchError` (runExceptT . unUVerbT . h)
149−
150−-- | This combinator runs 'UVerbT'. It applies 'respond' internally, so the handler
151−-- may use the usual 'return'.
152−runUVerbT :: (Monad m, HasStatus x, IsMember x xs) => UVerbT xs m x -> m (Union xs)
153−runUVerbT (UVerbT act) = either id id <$> runExceptT (act >>= respond)
154−
155−-- | Short-circuit 'UVerbT' computation returning one of the response types.
156−throwUVerb :: (Monad m, HasStatus x, IsMember x xs) => x -> UVerbT xs m a
157−throwUVerb = UVerbT . ExceptT . fmap Left . respond
158−```
159−
160−Example usage:
161−
162−```haskell
163−data Foo = Foo Int Int Int
164− deriving (Show, Eq, GHC.Generic, ToJSON)
165− deriving HasStatus via WithStatus 200 Foo
166−
167−data Bar = Bar
168− deriving (Show, Eq, GHC.Generic)
169−
170−instance ToJSON Bar
171−
172−h :: Handler (Union '[Foo, WithStatus 400 Bar])
173−h = runUVerbT $ do
174− when ({- something bad -} True) $
175− throwUVerb $ WithStatus @400 Bar
176−
177− when ({- really bad -} False) $
178− throwError $ err500
179−
180− -- a lot of code here...
181−
182− return $ Foo 1 2 3
183−```
184−
185−## Related Work
186−
187−There is the [issue from
188−2017](https://github.com/haskell-servant/servant/issues/841) that was
189−resolved by the introduction of `UVerb`, with a long discussion on
190−alternative designs.
191−
192−[servant-checked-exceptions](https://hackage.haskell.org/package/servant-checked-exceptions)
193−is a good solution to the problem, but it restricts the user to JSON
194−and a very specific envelop encoding for the union type, which is
195−often not acceptable. (One good reason for this design choice is that
196−it makes writing clients easier, where you need to get to the union
197−type from one representative, and you don't want to run several
198−parsers in the hope that the ones that should will always error out so
199−you can try until the right one returns a value.)
200−
201−[servant-exceptions](https://github.com/ch1bo/servant-exceptions) is
202−another shot at the problem. It is inspired by
203−servant-checked-exceptions, so it may be worth taking a closer look.
204−The README claims that
205−[cardano-sl](https://github.com/input-output-hk/cardano-sl) also has
206−some code for generalized error handling.
207−
208−In an earier version of the `UVerb` implementation, we have used some
209−code from
210−[world-peace](https://hackage.haskell.org/package/world-peace), but
211−that package itself wasn't flexible enough, and we had to use
212−[sop-core](https://hackage.haskell.org/package/sop-core) to implement
213−the `HasServer` instance.
214−
215−Here is a blog post we found on the subject:
216−https://lukwagoallan.com/posts/unifying-servant-server-error-responses
217−
218−(If you have anything else, please add it here or let us know.)
219−
220−```haskell
221−main :: IO ()
222−main = return ()
223−```
doc/cookbook/uverb/uverb.cabaldeleted−35
@@ -1,35 +0,0 @@
1−cabal-version: 2.2
2−name: cookbook-uverb
3−version: 0.0.1
4−synopsis: How to use the 'UVerb' type.
5−description: Listing alternative responses and exceptions in your API types.
6−homepage: http://docs.servant.dev/
7−license: BSD-3-Clause
8−license-file: ../../../servant/LICENSE
9−author: Servant Contributors
10−maintainer: haskell-servant-maintainers@googlegroups.com
11−category: Servant
12−build-type: Simple
13−tested-with: GHC==8.6.5, GHC==8.8.4, GHC==8.10.7
14−
15−executable cookbook-uverb
16− main-is: UVerb.lhs
17− build-depends: base == 4.*
18− , aeson >= 1.2
19− , aeson-pretty >= 0.8.8
20− , async
21− , http-client
22− , mtl
23− , servant
24− , servant-client
25− , servant-server
26− , servant-swagger
27− , string-conversions
28− , swagger2
29− , wai
30− , warp
31− if impl(ghc >= 9)
32− buildable: False
33− default-language: Haskell2010
34− ghc-options: -Wall -pgmL markdown-unlit
35− build-tool-depends: markdown-unlit:markdown-unlit
doc/examples.md+1−1
@@ -8,7 +8,7 @@
88
99- **[servant-examples](https://github.com/sras/servant-examples)**:
1010
11− Similar to [the cookbook](https://docs.servant.dev/en/latest/cookbook/index.html) but
11+ Similar to [the cookbook](https://haskell-servant.readthedocs.io/en/latest/cookbook/index.html) but
1212 with no explanations, for developers who just want to look at code examples to find out how to do X or Y
1313 with servant.
1414
doc/links.rst+3−3
@@ -3,7 +3,7 @@ Helpful Links
33-------------
44
55- the central documentation (this site):
6− `docs.servant.dev <http://docs.servant.dev/>`_
6+ `haskell-servant.readthedocs.org <http://haskell-servant.readthedocs.org/>`_
77
88- the github repo:
99 `github.com/haskell-servant/servant <https://github.com/haskell-servant/servant>`_
@@ -12,13 +12,13 @@ Helpful Links
1212 `https://github.com/haskell-servant/servant/issues <https://github.com/haskell-servant/servant/issues>`_
1313
1414- the irc channel:
15− `#haskell-servant on libera.chat <https://web.libera.chat/#haskell-servant>`_
15+ ``#servant`` on freenode
1616
1717- the mailing list:
1818 `groups.google.com/forum/#!forum/haskell-servant <https://groups.google.com/forum/#!forum/haskell-servant>`_
1919
2020- blog posts and videos and slides of some talks on servant:
21− `www.servant.dev <http://www.servant.dev>`_
21+ `haskell-servant.github.io <http://haskell-servant.github.io>`_
2222
2323- the servant packages on hackage:
2424
doc/requirements.txt+3−4
@@ -1,4 +1,3 @@
1−recommonmark==0.5.0
2−Sphinx==1.8.4
3−sphinx_rtd_theme>=0.4.2
4−jinja2<3.1.0
1+recommonmark==0.4.0
2+Sphinx==1.7.5
3+sphinx_rtd_theme>=0.4.0
doc/tutorial/ApiType.lhs+9−42
@@ -129,23 +129,16 @@ type UserAPI4 = "users" :> Get '[JSON] [User]
129129
130130### `StreamGet` and `StreamPost`
131131
132−*Note*: Streaming has changed considerably in `servant-0.15`.
133−
134132The `StreamGet` and `StreamPost` combinators are defined in terms of the more general `Stream`
135133
136134``` haskell ignore
137−data Stream (method :: k1) (status :: Nat) (framing :: *) (contentType :: *) (a :: *)
138−
139−type StreamGet = Stream 'GET 200
140−type StreamPost = Stream 'POST 200
135+data Stream (method :: k1) (framing :: *) (contentType :: *) a
136+type StreamGet = Stream 'GET
137+type StreamPost = Stream 'POST
141138```
142139
143−These describe endpoints that return a stream of values rather than just a
144−single value. They not only take a single content type as a parameter, but also
145−a framing strategy -- this specifies how the individual results are delineated
146−from one another in the stream. The three standard strategies given with
147−Servant are `NewlineFraming`, `NetstringFraming` and `NoFraming`, but others
148−can be written to match other protocols.
140+These describe endpoints that return a stream of values rather than just a single value. They not only take a single content type as a parameter, but also a framing strategy -- this specifies how the individual results are delineated from one another in the stream. The three standard strategies given with Servant are `NewlineFraming`, `NetstringFraming` and `NoFraming`, but others can be written to match other protocols.
141+
149142
150143### `Capture`
151144
@@ -177,12 +170,13 @@ type UserAPI5 = "user" :> Capture "userid" Integer :> Get '[JSON] User
177170 -- except that we explicitly say that "userid"
178171 -- must be an integer
179172
180− :<|> "user" :> Capture "userid" Integer :> DeleteNoContent
173+ :<|> "user" :> Capture "userid" Integer :> DeleteNoContent '[JSON] NoContent
181174 -- equivalent to 'DELETE /user/:userid'
182175```
183176
184−In the second case, `DeleteNoContent` specifies a 204 response code
185−and that the response will always be empty.
177+In the second case, `DeleteNoContent` specifies a 204 response code,
178+`JSON` specifies the content types on which the handler will match,
179+and `NoContent` says that the response will always be empty.
186180
187181### `QueryParam`, `QueryParams`, `QueryFlag`
188182
@@ -389,30 +383,3 @@ One example for this is if you want to serve a directory of static files along
389383with the rest of your API. But you can plug in everything that is an
390384`Application`, e.g. a whole web application written in any of the web
391385frameworks 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+11−10
@@ -47,6 +47,7 @@ module Authentication where
4747import Data.Aeson (ToJSON)
4848import Data.ByteString (ByteString)
4949import Data.Map (Map, fromList)
50+import Data.Monoid ((<>))
5051import qualified Data.Map as Map
5152import Data.Proxy (Proxy (Proxy))
5253import Data.Text (Text)
@@ -107,7 +108,7 @@ API with "private." Additionally, the private parts of our API use the
107108realm for this authentication is `"foo-realm"`).
108109
109110Unfortunately we're not done. When someone makes a request to our `"private"`
110−API, we're going to need to provide to servant the logic for validating
111+API, we're going to need to provide to servant the logic for validifying
111112usernames and passwords. This adds a certain conceptual wrinkle in servant's
112113design that we'll briefly discuss. If you want the **TL;DR**: we supply a lookup
113114function to servant's new `Context` primitive.
@@ -132,7 +133,7 @@ combinator. Using `Context`, we can supply a function of type
132133handler. This will allow the handler to check authentication and return a `User`
133134to downstream handlers if successful.
134135
135−In practice we wrap `BasicAuthData -> Handler User` into a slightly
136+In practice we wrap `BasicAuthData -> Handler` into a slightly
136137different function to better capture the semantics of basic authentication:
137138
138139``` haskell ignore
@@ -259,7 +260,7 @@ this.
259260
260261Let's implement a trivial authentication scheme. We will protect our API by
261262looking for a cookie named `"servant-auth-cookie"`. This cookie's value will
262−contain a key from which we can lookup an `Account`.
263+contain a key from which we can lookup a `Account`.
263264
264265```haskell
265266-- | An account type that we "fetch from the database" after
@@ -273,7 +274,7 @@ database = fromList [ ("key1", Account "Anne Briggs")
273274 , ("key3", Account "Ghédalia Tazartès")
274275 ]
275276
276−-- | A method that, when given a password, will return an Account.
277+-- | A method that, when given a password, will return a Account.
277278-- This is our bespoke (and bad) authentication logic.
278279lookupAccount :: ByteString -> Handler Account
279280lookupAccount key = case Map.lookup key database of
@@ -317,7 +318,7 @@ genAuthAPI = Proxy
317318
318319Now we need to bring everything together for the server. We have the
319320`AuthHandler Request Account` value and an `AuthProtected` endpoint. To bind these
320−together, we need to provide a [Type Family](https://downloads.haskell.org/~ghc/8.8.1/docs/html/users_guide/glasgow_exts.html#type-families)
321+together, we need to provide a [Type Family](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/type-families.html)
321322instance that tells the `HasServer` instance that our `Context` will supply a
322323`Account` (via `AuthHandler Request Account`) and that downstream combinators will
323324have access to this `Account` value (or an error will be thrown if authentication
@@ -345,7 +346,7 @@ genAuthServerContext = authHandler :. EmptyContext
345346
346347-- | Our API, where we provide all the author-supplied handlers for each end
347348-- point. Note that 'privateDataFunc' is a function that takes 'Account' as an
348−-- argument. We don't worry about the authentication instrumentation here,
349+-- argument. We dont' worry about the authentication instrumentation here,
349350-- that is taken care of by supplying context
350351genAuthServer :: Server AuthGenAPI
351352genAuthServer =
@@ -367,10 +368,10 @@ genAuthMain = run 8080 (serveWithContext genAuthAPI genAuthServerContext genAuth
367368$ curl -XGET localhost:8080/private
368369Missing auth header
369370
370−$ curl -XGET localhost:8080/private -H "Cookie: servant-auth-cookie=key3"
371+$ curl -XGET localhost:8080/private -H "servant-auth-cookie: key3"
371372[{"ssshhh":"this is a secret: Ghédalia Tazartès"}]
372373
373−$ curl -XGET localhost:8080/private -H "Cookie: servant-auth-cookie=bad-key"
374+$ curl -XGET localhost:8080/private -H "servant-auth-cookie: bad-key"
374375Invalid Cookie
375376
376377$ curl -XGET localhost:8080/public
@@ -384,11 +385,11 @@ Creating a generalized, ad-hoc authentication scheme was fairly straight
384385forward:
385386
3863871. use the `AuthProtect` combinator to protect your API.
387−2. choose an application-specific data type used by your server when
388+2. choose a application-specific data type used by your server when
388389authentication is successful (in our case this was `Account`).
3893903. Create a value of `AuthHandler Request Account` which encapsulates the
390391authentication logic (`Request -> Handler Account`). This function
391−will be executed every time a request matches a protected route.
392+will be executed everytime a request matches a protected route.
3923934. Provide an instance of the `AuthServerData` type family, specifying your
393394application-specific data type returned when authentication is successful (in
394395our case this was `Account`).
doc/tutorial/Client.lhs+26−26
@@ -1,9 +1,9 @@
11# Querying an API
22
3−While defining handlers that [serve an API](Server.html) has a lot to it, querying an API is simpler: we do not care about what happens inside the webserver, we just need to know how to talk to it and get a response back. That said, we usually have to write the querying functions by hand because the structure of the API isn't a first class citizen and can't be inspected to generate the client-side functions.
3+While defining handlers that [serve an API](Server.lhs) has a lot to it, querying an API is simpler: we do not care about what happens inside the webserver, we just need to know how to talk to it and get a response back. That said, we usually have to write the querying functions by hand because the structure of the API isn't a first class citizen and can't be inspected to generate the client-side functions.
44
55**servant** however has a way to inspect APIs, because APIs are just Haskell types and (GHC) Haskell lets us do quite a few things with types. In the same way that we look at an API type to deduce the types the handlers should have, we can inspect the structure of the API to *derive* Haskell functions that take one argument for each occurrence of `Capture`, `ReqBody`, `QueryParam`
6−and friends (see [the tutorial introduction](ApiType.html) for an overview). By *derive*, we mean that there's no code generation involved - the functions are defined just by the structure of the API type.
6+and friends (see [the tutorial introduction](ApiType.lhs) for an overview). By *derive*, we mean that there's no code generation involved - the functions are defined just by the structure of the API type.
77
88The source for this tutorial section is a literate Haskell file, so first we need to have some language extensions and imports:
99
@@ -20,9 +20,6 @@ import GHC.Generics
2020import Network.HTTP.Client (newManager, defaultManagerSettings)
2121import Servant.API
2222import Servant.Client
23−import Servant.Types.SourceT (foreach)
24−
25−import qualified Servant.Client.Streaming as S
2623```
2724
2825Also, we need examples for some domain specific data types:
@@ -161,7 +158,7 @@ The types of the arguments for the functions are the same as for (server-side) r
161158## Changing the monad the client functions live in
162159
163160Just like `hoistServer` allows us to change the monad in which request handlers
164−of a web application live, we also have `hoistClient` for changing the monad
161+of a web application live in, we also have `hoistClient` for changing the monad
165162in which _client functions_ live. Consider the following trivial API:
166163
167164``` haskell
@@ -173,7 +170,7 @@ hoistClientAPI = Proxy
173170
174171We already know how to derive client functions for this API, and as we have
175172seen above they all return results in the `ClientM` monad when using `servant-client`.
176−However, `ClientM` is rarely (or never) the actual monad we need to use the client
173+However, `ClientM` rarely (or never) is the actual monad we need to use the client
177174functions in. Sometimes we need to run them in IO, sometimes in a custom monad
178175stack. `hoistClient` is a very simple solution to the problem of "changing" the monad
179176the clients run in.
@@ -220,38 +217,41 @@ getClients clientEnv
220217Consider the following streaming API type:
221218
222219``` haskell
223−type StreamAPI = "positionStream" :> StreamGet NewlineFraming JSON (SourceIO Position)
220+type StreamAPI = "positionStream" :> StreamGet NewlineFraming JSON (ResultStream Position)
224221```
225222
226−Note that we use the same `SourceIO` type as on the server-side
227−(this is different from `servant-0.14`).
228−However, we have to use different client, `Servant.Client.Streaming`,
229−which can stream (but has different API).
223+Note that when we declared an API to serve, we specified a `StreamGenerator` as a producer of streams. Now we specify our result type as a `ResultStream`. With types that can be used both ways, if appropriate adaptors are written (in the form of `ToStreamGenerator` and `BuildFromStream` instances), then this asymmetry isn't necessary. Otherwise, if you want to share the same API across clients and servers, you can parameterize it like so:
224+
225+``` haskell ignore
226+type StreamAPI f = "positionStream" :> StreamGet NewlineFraming JSON (f Position)
227+type ServerStreamAPI = StreamAPI StreamGenerator
228+type ClientStreamAPI = StreamAPI ResultStream
229+```
230230
231231In any case, here's how we write a function to query our API:
232232
233−```haskell
233+``` haskell
234234streamAPI :: Proxy StreamAPI
235235streamAPI = Proxy
236236
237−posStream :: S.ClientM (SourceIO Position)
238−posStream = S.client streamAPI
237+posStream :: ClientM (ResultStream Position)
238+
239+posStream = client streamAPI
239240```
240241
241−We'll get back a `SourceIO Position`. Instead of `runClientM`, the streaming
242−client provides `withClientM`: the underlying HTTP connection is open only
243−until the inner functions exits. Inside the block we can e.g just print out
244−all elements from a `SourceIO`, to give some idea of how to work with them.
242+And here's how to just print out all elements from a `ResultStream`, to give some idea of how to work with them.
245243
246244``` haskell
247−printSourceIO :: Show a => ClientEnv -> S.ClientM (SourceIO a) -> IO ()
248−printSourceIO env c = S.withClientM c env $ \e -> case e of
249− Left err -> putStrLn $ "Error: " ++ show err
250− Right rs -> foreach fail print rs
245+printResultStream :: Show a => ResultStream a -> IO ()
246+printResultStream (ResultStream k) = k $ \getResult ->
247+ let loop = do
248+ r <- getResult
249+ case r of
250+ Nothing -> return ()
251+ Just x -> print x >> loop
252+ in loop
251253```
252254
253−The stream is parsed and provided incrementally. So the above loop prints out
254−each result as soon as it is received on the stream, rather than waiting until
255−they are all available to print them at once.
255+The stream is parsed and provided incrementally. So the above loop prints out each result as soon as it is received on the stream, rather than waiting until they are all available to print them at once.
256256
257257You now know how to use **servant-client**!
doc/tutorial/Docs.lhs+2−2
@@ -77,7 +77,7 @@ instance ToSample HelloMessage where
7777 [ ("When a value is provided for 'name'", HelloMessage "Hello, Alp")
7878 , ("When 'name' is not specified", HelloMessage "Hello, anonymous coward")
7979 ]
80− -- multiple examples to display this time
80+ -- mutliple examples to display this time
8181
8282ci :: ClientInfo
8383ci = ClientInfo "Alp" "alp@foo.com" 26 ["haskell", "mathematics"]
@@ -108,7 +108,7 @@ apiDocs = docs exampleAPI
108108markdown :: API -> String
109109```
110110
111−That lets us see what our API docs look like in markdown, by looking at `markdown apiDocs`.
111+That lets us see what our API docs look down in markdown, by looking at `markdown apiDocs`.
112112
113113````````` text
114114## GET /hello
doc/tutorial/Javascript.lhs+2−2
@@ -228,13 +228,13 @@ data CommonGeneratorOptions = CommonGeneratorOptions
228228 {
229229 -- | function generating function names
230230 functionNameBuilder :: FunctionName -> Text
231− -- | name used when a user wants to send the request body (to let you redefine it)
231+ -- | name used when a user want to send the request body (to let you redefine it)
232232 , requestBody :: Text
233233 -- | name of the callback parameter when the request was successful
234234 , successCallback :: Text
235235 -- | name of the callback parameter when the request reported an error
236236 , errorCallback :: Text
237− -- | namespace on which we define the js function (empty means local var)
237+ -- | namespace on which we define the js function (empty mean local var)
238238 , moduleName :: Text
239239 -- | a prefix that should be prepended to the URL in the generated JS
240240 , urlPrefix :: Text
doc/tutorial/Server.lhs+41−55
@@ -29,7 +29,7 @@ import Prelude.Compat
2929
3030import Control.Monad.Except
3131import Control.Monad.Reader
32−import Data.Aeson
32+import Data.Aeson.Compat
3333import Data.Aeson.Types
3434import Data.Attoparsec.ByteString
3535import Data.ByteString (ByteString)
@@ -46,7 +46,6 @@ import Servant
4646import System.Directory
4747import Text.Blaze
4848import Text.Blaze.Html.Renderer.Utf8
49−import Servant.Types.SourceT (source)
5049import qualified Data.Aeson.Parser
5150import qualified Text.Blaze.Html
5251```
@@ -183,7 +182,7 @@ users2 = [isaac, albert]
183182
184183Now, just like we separate the various endpoints in `UserAPI` with `:<|>`, we
185184are going to separate the handlers with `:<|>` too! They must be provided in
186−the same order as in the API type.
185+the same order as in in the API type.
187186
188187``` haskell
189188server2 :: Server UserAPI2
@@ -313,8 +312,8 @@ For reference, here's a list of some combinators from **servant**:
313312## The `FromHttpApiData`/`ToHttpApiData` classes
314313
315314Wait... How does **servant** know how to decode the `Int`s from the URL? Or how
316−to decode a `ClientInfo` value from the request body? The following three sections will
317−help us answer these questions.
315+to decode a `ClientInfo` value from the request body? This is what this and the
316+following two sections address.
318317
319318`Capture`s and `QueryParam`s are represented by some textual value in URLs.
320319`Header`s are similarly represented by a pair of a header name and a
@@ -599,7 +598,7 @@ $ curl -H 'Accept: text/html' http://localhost:8081/persons
599598
600599## The `Handler` monad
601600
602−At the heart of the handlers is the monad they run in, namely a newtype `Handler` around `ExceptT ServerError IO`
601+At the heart of the handlers is the monad they run in, namely a newtype `Handler` around `ExceptT ServantErr IO`
603602([haddock documentation for `ExceptT`](http://hackage.haskell.org/package/mtl-2.2.1/docs/Control-Monad-Except.html#t:ExceptT)).
604603One might wonder: why this monad? The answer is that it is the
605604simplest monad with the following properties:
@@ -617,12 +616,12 @@ newtype ExceptT e m a = ExceptT (m (Either e a))
617616```
618617
619618In short, this means that a handler of type `Handler a` is simply
620−equivalent to a computation of type `IO (Either ServerError a)`, that is, an IO
619+equivalent to a computation of type `IO (Either ServantErr a)`, that is, an IO
621620action that either returns an error or a result.
622621
623−The module [`Control.Monad.Except`](https://hackage.haskell.org/package/mtl/docs/Control-Monad-Except.html#t:ExceptT)
622+The module [`Control.Monad.Except`](https://hackage.haskell.org/package/mtl-2.2.1/docs/Control-Monad-Except.html#t:ExceptT)
624623from which `ExceptT` comes is worth looking at.
625−Perhaps most importantly, `ExceptT` and `Handler` are instances of `MonadError`, so
624+Perhaps most importantly, `ExceptT` and `Handler` are an instances of `MonadError`, so
626625`throwError` can be used to return an error from your handler (whereas `return`
627626 is enough to return a success).
628627
@@ -632,9 +631,9 @@ kind and abort early. The next two sections cover how to do just that.
632631
633632### Performing IO
634633
635−Other important instances from the list above are `MonadIO m => MonadIO
636−(ExceptT e m)`, and therefore also `MonadIO Handler` as there is a `MonadIO IO` instance.
637−[`MonadIO`](http://hackage.haskell.org/package/base/docs/Control-Monad-IO-Class.html#t:MonadIO)
634+Another important instances from the list above are `MonadIO m => MonadIO
635+(ExceptT e m)`, and therefore also `MonadIO Handler` as there is `MonadIO IO` instance.
636+[`MonadIO`](http://hackage.haskell.org/package/transformers-0.4.3.0/docs/Control-Monad-IO-Class.html)
638637is a class from the **transformers** package defined as:
639638
640639``` haskell ignore
@@ -660,16 +659,16 @@ server5 = do
660659 return (FileContent filecontent)
661660```
662661
663−### Failing, through `ServerError`
662+### Failing, through `ServantErr`
664663
665664If you want to explicitly fail at providing the result promised by an endpoint
666665using the appropriate HTTP status code (not found, unauthorized, etc) and some
667666error message, all you have to do is use the `throwError` function mentioned above
668−and provide it with the appropriate value of type `ServerError`, which is
667+and provide it with the appropriate value of type `ServantErr`, which is
669668defined as:
670669
671670``` haskell ignore
672−data ServerError = ServerError
671+data ServantErr = ServantErr
673672 { errHTTPCode :: Int
674673 , errReasonPhrase :: String
675674 , errBody :: ByteString -- lazy bytestring
@@ -685,7 +684,7 @@ use record update syntax:
685684failingHandler :: Handler ()
686685failingHandler = throwError myerr
687686
688− where myerr :: ServerError
687+ where myerr :: ServantErr
689688 myerr = err503 { errBody = "Sorry dear user." }
690689```
691690
@@ -716,7 +715,7 @@ $ curl --verbose http://localhost:8081/myfile.txt
716715>
717716< HTTP/1.1 404 Not Found
718717[snip]
719−myfile.txt just isn't there, please leave this server alone.
718+myfile.txt just isnt there, please leave this server alone.
720719
721720$ echo Hello > myfile.txt
722721
@@ -818,7 +817,7 @@ If it doesn't exist, the handler will fail with a `404` status code.
818817
819818`serveDirectoryWebApp` uses some standard settings that fit the use case of
820819serving static files for most web apps. You can find out about the other
821−options in the documentation of the `Servant.Server.StaticFiles` module.
820+options in the documentation of the `Servant.Utils.StaticFiles` module.
822821
823822## Nested APIs
824823
@@ -830,7 +829,7 @@ type UserAPI3 = -- view the user with given userid, in JSON
830829 Capture "userid" Int :> Get '[JSON] User
831830
832831 :<|> -- delete the user with given userid. empty response
833− Capture "userid" Int :> DeleteNoContent
832+ Capture "userid" Int :> DeleteNoContent '[JSON] NoContent
834833```
835834
836835We can instead factor out the `userid`:
@@ -838,7 +837,7 @@ We can instead factor out the `userid`:
838837``` haskell
839838type UserAPI4 = Capture "userid" Int :>
840839 ( Get '[JSON] User
841− :<|> DeleteNoContent
840+ :<|> DeleteNoContent '[JSON] NoContent
842841 )
843842```
844843
@@ -896,13 +895,13 @@ type API1 = "users" :>
896895-- we factor out the Request Body
897896type API2 = ReqBody '[JSON] User :>
898897 ( Get '[JSON] User -- just display the same user back, don't register it
899− :<|> PostNoContent -- register the user. empty response
898+ :<|> PostNoContent '[JSON] NoContent -- register the user. empty response
900899 )
901900
902901-- we factor out a Header
903902type API3 = Header "Authorization" Token :>
904903 ( Get '[JSON] SecretData -- get some secret data, if authorized
905− :<|> ReqBody '[JSON] SecretData :> PostNoContent -- add some secret data, if authorized
904+ :<|> ReqBody '[JSON] SecretData :> PostNoContent '[JSON] NoContent -- add some secret data, if authorized
906905 )
907906
908907newtype Token = Token ByteString
@@ -915,11 +914,11 @@ API type only at the end.
915914``` haskell
916915type UsersAPI =
917916 Get '[JSON] [User] -- list users
918− :<|> ReqBody '[JSON] User :> PostNoContent -- add a user
917+ :<|> ReqBody '[JSON] User :> PostNoContent '[JSON] NoContent -- add a user
919918 :<|> Capture "userid" Int :>
920919 ( Get '[JSON] User -- view a user
921− :<|> ReqBody '[JSON] User :> PutNoContent -- update a user
922− :<|> DeleteNoContent -- delete a user
920+ :<|> ReqBody '[JSON] User :> PutNoContent '[JSON] NoContent -- update a user
921+ :<|> DeleteNoContent '[JSON] NoContent -- delete a user
923922 )
924923
925924usersServer :: Server UsersAPI
@@ -948,11 +947,11 @@ usersServer = getUsers :<|> newUser :<|> userOperations
948947``` haskell
949948type ProductsAPI =
950949 Get '[JSON] [Product] -- list products
951− :<|> ReqBody '[JSON] Product :> PostNoContent -- add a product
950+ :<|> ReqBody '[JSON] Product :> PostNoContent '[JSON] NoContent -- add a product
952951 :<|> Capture "productid" Int :>
953952 ( Get '[JSON] Product -- view a product
954− :<|> ReqBody '[JSON] Product :> PutNoContent -- update a product
955− :<|> DeleteNoContent -- delete a product
953+ :<|> ReqBody '[JSON] Product :> PutNoContent '[JSON] NoContent -- update a product
954+ :<|> DeleteNoContent '[JSON] NoContent -- delete a product
956955 )
957956
958957data Product = Product { productId :: Int }
@@ -996,11 +995,11 @@ abstract that away:
996995-- indexed by values of type 'i'
997996type APIFor a i =
998997 Get '[JSON] [a] -- list 'a's
999− :<|> ReqBody '[JSON] a :> PostNoContent -- add an 'a'
998+ :<|> ReqBody '[JSON] a :> PostNoContent '[JSON] NoContent -- add an 'a'
1000999 :<|> Capture "id" i :>
10011000 ( Get '[JSON] a -- view an 'a' given its "identifier" of type 'i'
1002− :<|> ReqBody '[JSON] a :> PutNoContent -- update an 'a'
1003− :<|> DeleteNoContent -- delete an 'a'
1001+ :<|> ReqBody '[JSON] a :> PutNoContent '[JSON] NoContent -- update an 'a'
1002+ :<|> DeleteNoContent '[JSON] NoContent -- delete an 'a'
10041003 )
10051004
10061005-- Build the appropriate 'Server'
@@ -1128,14 +1127,14 @@ This is the webservice in action:
11281127``` bash
11291128$ curl http://localhost:8081/a
113011291797
1131−$ curl http://localhost:8081/b -X GET -d '42.0' -H 'Content-Type: application/json'
1132−true
1130+$ curl http://localhost:8081/b
1131+"hi"
11331132```
11341133
11351134### An arrow is a reader too.
11361135
11371136In previous versions of `servant` we had an `enter` to do what `hoistServer`
1138−does now. `enter` had an ambitious design goals, but was problematic in practice.
1137+does now. `enter` had a ambitious design goals, but was problematic in practice.
11391138
11401139One problematic situation was when the source monad was `(->) r`, yet it's
11411140handy in practice, because `(->) r` is isomorphic to `Reader r`.
@@ -1161,37 +1160,24 @@ app5 = serve readerAPI (hoistServer readerAPI funToHandler funServerT)
11611160
11621161## Streaming endpoints
11631162
1164−We can create endpoints that don't just give back a single result, but give
1165−back a *stream* of results, served one at a time. Stream endpoints only provide
1166−a single content type, and also specify what framing strategy is used to
1167−delineate the results. To serve these results, we need to give back a stream
1168−producer. Adapters can be written to *Pipes*, *Conduit* and the like, or
1169−written directly as `SourceIO`s. SourceIO builds upon servant's own `SourceT`
1170−stream type (it's simpler than *Pipes* or *Conduit*).
1171−The API of a streaming endpoint needs to explicitly specify which sort of
1172−generator it produces. Note that the generator itself is returned by a
1173−`Handler` action, so that additional IO may be done in the creation of one.
1163+We can create endpoints that don't just give back a single result, but give back a *stream* of results, served one at a time. Stream endpoints only provide a single content type, and also specify what framing strategy is used to delineate the results. To serve these results, we need to give back a stream producer. Adapters can be written to `Pipes`, `Conduit` and the like, or written directly as `StreamGenerator`s. StreamGenerators are IO-based continuations that are handed two functions -- the first to write the first result back, and the second to write all subsequent results back. (This is to allow handling of situations where the entire stream is prefixed by a header, or where a boundary is written between elements, but not prior to the first element). The API of a streaming endpoint needs to explicitly specify which sort of generator it produces. Note that the generator itself is returned by a `Handler` action, so that additional IO may be done in the creation of one.
11741164
11751165``` haskell
1176−type StreamAPI = "userStream" :> StreamGet NewlineFraming JSON (SourceIO User)
1166+type StreamAPI = "userStream" :> StreamGet NewlineFraming JSON (StreamGenerator User)
11771167streamAPI :: Proxy StreamAPI
11781168streamAPI = Proxy
11791169
1180−streamUsers :: SourceIO User
1181−streamUsers = source [isaac, albert, albert]
1170+streamUsers :: StreamGenerator User
1171+streamUsers = StreamGenerator $ \sendFirst sendRest -> do
1172+ sendFirst isaac
1173+ sendRest albert
1174+ sendRest albert
11821175
11831176app6 :: Application
11841177app6 = serve streamAPI (return streamUsers)
11851178```
11861179
1187−This simple application returns a stream of `User` values encoded in JSON
1188−format, with each value separated by a newline. In this case, the stream will
1189−consist of the value of `isaac`, followed by the value of `albert`, then the
1190−value of `albert` a second time. Importantly, the stream is written back as
1191−results are produced, rather than all at once. This means first that results
1192−are delivered when they are available, and second, that if an exception
1193−interrupts production of the full stream, nonetheless partial results have
1194−already been written back.
1180+This simple application returns a stream of `User` values encoded in JSON format, with each value separated by a newline. In this case, the stream will consist of the value of `isaac`, followed by the value of `albert`, then the value of `albert` a third time. Importantly, the stream is written back as results are produced, rather than all at once. This means first that results are delivered when they are available, and second, that if an exception interrupts production of the full stream, nonetheless partial results have already been written back.
11951181
11961182## Conclusion
11971183
doc/tutorial/index.rst+20−1
@@ -6,10 +6,29 @@ 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+In fact, the whole tutorial is a `cabal <https://cabal.readthedocs.io/en/latest/>`_
10+project and can be built and played with locally as follows:
11+
12+.. code-block:: bash
13+
14+ $ git clone https://github.com/haskell-servant/servant.git
15+ $ cd servant
16+ # build
17+ $ cabal new-build tutorial
18+ # load in ghci to play with it
19+ $ cabal new-repl tutorial
20+
21+The code can be found in the `*.lhs` files under `doc/tutorial/` in the
22+repository. Feel free to edit it while you're reading this documentation and
23+see the effect of your changes.
24+
25+`Nix <https://nixos.org/nix/>`_ users should feel free to take a look at
26+the `nix/shell.nix` file in the repository and use it to provision a suitable
27+environment to build and run the examples.
28+
929.. toctree::
1030 :maxdepth: 1
1131
12− install.rst
1332 ApiType.lhs
1433 Server.lhs
1534 Client.lhs
doc/tutorial/install.rstdeleted−68
@@ -1,68 +0,0 @@
1−Install
2−========
3−
4−cabal-install
5−--------
6−
7−The whole tutorial is a `cabal <https://cabal.readthedocs.io/en/latest/>`_
8−project and can be built locally as follows:
9−
10−.. code-block:: bash
11−
12− $ git clone https://github.com/haskell-servant/servant.git
13− $ cd servant
14− # build
15− $ cabal new-build tutorial
16− # load in ghci to play with it
17− $ cabal new-repl tutorial
18−
19−stack
20−--------
21−
22−The servant `stack <https://docs.haskellstack.org/en/stable/README/>`_ template includes the working tutorial. To initialize this template, run:
23−
24−.. code-block:: bash
25−
26− $ stack new myproj servant
27− $ cd myproj
28− # build
29− $ stack build
30− # start server
31− $ stack exec myproj-exe
32−
33−The code can be found in the `*.lhs` files under `doc/tutorial/` in the
34−repository. Feel free to edit it while you're reading this documentation and
35−see the effect of your changes.
36−
37−nix
38−--------
39−
40−`Nix <https://nixos.org/nix/>`_ users should feel free to take a look at
41−the `nix/shell.nix` file in the repository and use it to provision a suitable
42−environment to build and run the examples.
43−
44−Note for Ubuntu users
45−--------
46−
47−Ubuntu's packages for `ghc`, `cabal`, and `stack` are years out of date.
48−If the instructions above fail for you,
49−try replacing the Ubuntu packages with up-to-date versions.
50−First remove the installed versions:
51−
52−.. code-block:: bash
53−
54− # remove the obsolete versions
55− $ sudo apt remove ghc haskell-stack cabal-install
56−
57−Then install fresh versions of the Haskell toolchain
58−using the `ghcup <https://www.haskell.org/ghcup/install/>`_ installer.
59−
60−As of February 2022, one easy way to do this is by running a bootstrap script:
61−
62−.. code-block:: bash
63−
64− $ curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh
65−
66−The script is interactive and will prompt you for details about what
67−you want installed and where. To install manually,
68−see `the detailed instructions <https://www.haskell.org/ghcup/install/#manual-install>`_.
doc/tutorial/test/Spec.hs+1−11
@@ -1,11 +1 @@
1−module Main where
2−
3−import qualified JavascriptSpec
4−
5−import Test.Hspec (Spec, hspec, describe)
6−
7−main :: IO ()
8−main = hspec spec
9−
10−spec :: Spec
11−spec = describe "Javascript" JavascriptSpec.spec
1+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
doc/tutorial/tinc.yamlnew file+13
@@ -0,0 +1,13 @@
1+dependencies:
2+ - name: servant
3+ path: ../../servant
4+ - name: servant-server
5+ path: ../../servant-server
6+ - name: servant-client
7+ path: ../../servant-client
8+ - name: servant-js
9+ path: ../../servant-js
10+ - name: servant-docs
11+ path: ../../servant-docs
12+ - name: servant-foreign
13+ path: ../../servant-foreign
doc/tutorial/tutorial.cabal+17−11
@@ -1,20 +1,22 @@
1−cabal-version: 2.2
21name: tutorial
32version: 0.10
43synopsis: The servant tutorial
54description:
65 The servant tutorial can be found at
7− <http://docs.servant.dev/>
8−homepage: http://docs.servant.dev/
6+ <http://haskell-servant.readthedocs.org/>
7+homepage: http://haskell-servant.readthedocs.org/
98category: Servant, Documentation
10−license: BSD-3-Clause
9+license: BSD3
1110license-file: LICENSE
1211author: Servant Contributors
1312maintainer: haskell-servant-maintainers@googlegroups.com
1413build-type: Simple
14+cabal-version: >=1.10
1515tested-with:
16− GHC==8.6.5
17− GHC==8.8.3, GHC ==8.10.7
16+ GHC==8.0.2
17+ GHC==8.2.2
18+ GHC==8.4.4
19+ GHC==8.6.1
1820extra-source-files:
1921 static/index.html
2022 static/ui.js
@@ -32,8 +34,9 @@ library
3234 -- Packages `servant` depends on.
3335 -- We don't need to specify bounds here as this package is never released.
3436 build-depends:
35− base >= 4.7 && <5
37+ base >= 4.7 && <4.13
3638 , aeson
39+ , aeson-compat
3740 , attoparsec
3841 , base-compat
3942 , bytestring
@@ -63,11 +66,12 @@ library
6366 blaze-html >= 0.9.0.1 && < 0.10
6467 , blaze-markup >= 0.8.0.0 && < 0.9
6568 , cookie >= 0.4.3 && < 0.5
66− , js-jquery >= 3.3.1 && < 3.4
67− , lucid >= 2.9.11 && < 2.12
68− , random >= 1.1 && < 1.3
69+ , js-jquery >= 3.2.1 && < 3.3
70+ , lucid >= 2.9.9 && < 2.10
71+ , mtl-compat >= 0.2.1 && < 0.3
72+ , random >= 1.1 && < 1.2
6973 , servant-js >= 0.9 && < 0.10
70− , time >= 1.6.0.1 && < 1.13
74+ , time >= 1.4.2 && < 1.9
7175
7276 -- For legacy tools, we need to specify build-depends too
7377 build-depends: markdown-unlit >= 0.5.0 && <0.6
@@ -80,6 +84,8 @@ test-suite spec
8084 hs-source-dirs: test
8185 main-is: Spec.hs
8286 other-modules: JavascriptSpec
87+ build-tool-depends:
88+ hspec-discover:hspec-discover
8389 build-depends: base
8490 , tutorial
8591 , hspec
ghcjs.nixdeleted−22
@@ -1,22 +0,0 @@
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,21 +21,3 @@ 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.jsondeleted−4
@@ -1,4 +0,0 @@
1−{
2− "rev" : "05f0934825c2a0750d4888c4735f9420c906b388",
3− "sha256" : "1g8c2w0661qn89ajp44znmwfmghbbiygvdzq0rzlvlpdiz28v6gy"
4−}
nix/nixpkgs.nixdeleted−4
@@ -1,4 +0,0 @@
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+18−17
@@ -1,20 +1,21 @@
1−{ compiler ? "ghc8104"
1+{ pkgs ? import <nixpkgs> {}
2+, compiler ? "ghc822"
23, tutorial ? false
3−, pkgs ? import ./nixpkgs.nix
44}:
5−
6− with pkgs;
75
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− }
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+}
servant-auth/README.mddeleted−1
@@ -1 +0,0 @@
1−servant-auth-server/README.lhs
servant-auth/servant-auth-client/.ghcideleted−1
@@ -1 +0,0 @@
1−:set -isrc -itest -idoctest/ghci-wrapper/src
servant-auth/servant-auth-client/CHANGELOG.mddeleted−26
@@ -1,26 +0,0 @@
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/LICENSEdeleted−31
@@ -1,31 +0,0 @@
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.hsdeleted−2
@@ -1,2 +0,0 @@
1−import Distribution.Simple
2−main = defaultMain
servant-auth/servant-auth-client/servant-auth-client.cabaldeleted−80
@@ -1,80 +0,0 @@
1−cabal-version: 2.2
2−name: servant-auth-client
3−version: 0.4.1.0
4−synopsis: servant-client/servant-auth compatibility
5−description: This package provides instances that allow generating clients from
6− <https://hackage.haskell.org/package/servant servant>
7− APIs that use
8− <https://hackage.haskell.org/package/servant-auth servant-auth's> @Auth@ combinator.
9− .
10− For a quick overview of the usage, see the <https://github.com/haskell-servant/servant/tree/master/servant-auth#readme README>.
11−category: Web, Servant, Authentication
12−homepage: https://github.com/haskell-servant/servant/tree/master/servant-auth#readme
13−bug-reports: https://github.com/haskell-servant/servant/issues
14−author: Julian K. Arni
15−maintainer: jkarni@gmail.com
16−copyright: (c) Julian K. Arni
17−license: BSD-3-Clause
18−license-file: LICENSE
19−tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1
20−build-type: Simple
21−extra-source-files:
22− CHANGELOG.md
23−
24−source-repository head
25− type: git
26− location: https://github.com/haskell-servant/servant
27−
28−library
29− hs-source-dirs:
30− src
31− default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
32− ghc-options: -Wall
33− build-depends:
34− base >= 4.10 && < 4.18
35− , bytestring >= 0.10.6.0 && < 0.12
36− , containers >= 0.5.6.2 && < 0.7
37− , servant-auth == 0.4.*
38− , servant >= 0.13 && < 0.20
39− , servant-client-core >= 0.13 && < 0.20
40−
41− exposed-modules:
42− Servant.Auth.Client
43− Servant.Auth.Client.Internal
44− default-language: Haskell2010
45−
46−test-suite spec
47− type: exitcode-stdio-1.0
48− main-is: Spec.hs
49− hs-source-dirs:
50− test
51− default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
52− ghc-options: -Wall
53− build-tool-depends: hspec-discover:hspec-discover >=2.5.5 && <2.10
54−
55− -- dependencies with bounds inherited from the library stanza
56− build-depends:
57− base
58− , servant-client
59− , servant-auth
60− , servant
61− , servant-auth-client
62−
63− -- test dependencies
64− build-depends:
65− hspec >= 2.5.5 && < 2.10
66− , QuickCheck >= 2.11.3 && < 2.15
67− , aeson >= 1.3.1.1 && < 3
68− , bytestring >= 0.10.6.0 && < 0.12
69− , http-client >= 0.5.13.1 && < 0.8
70− , http-types >= 0.12.2 && < 0.13
71− , servant-auth-server >= 0.4.2.0 && < 0.5
72− , servant-server >= 0.13 && < 0.20
73− , time >= 1.5.0.1 && < 1.13
74− , transformers >= 0.4.2.0 && < 0.6
75− , wai >= 3.2.1.2 && < 3.3
76− , warp >= 3.2.25 && < 3.4
77− , jose >= 0.10 && < 0.11
78− other-modules:
79− Servant.Auth.ClientSpec
80− default-language: Haskell2010
servant-auth/servant-auth-client/src/Servant/Auth/Client.hsdeleted−3
@@ -1,3 +0,0 @@
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.hsdeleted−64
@@ -1,64 +0,0 @@
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.hsdeleted−161
@@ -1,161 +0,0 @@
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.hsdeleted−1
@@ -1 +0,0 @@
1−{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
servant-auth/servant-auth-docs/.ghcideleted−1
@@ -1 +0,0 @@
1−:set -isrc -itest -idoctest/ghci-wrapper/src
servant-auth/servant-auth-docs/CHANGELOG.mddeleted−14
@@ -1,14 +0,0 @@
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/LICENSEdeleted−31
@@ -1,31 +0,0 @@
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.hsdeleted−33
@@ -1,33 +0,0 @@
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.cabaldeleted−84
@@ -1,84 +0,0 @@
1−cabal-version: 2.2
2−name: servant-auth-docs
3−version: 0.2.10.0
4−synopsis: servant-docs/servant-auth compatibility
5−description: This package provides instances that allow generating docs from
6− <https://hackage.haskell.org/package/servant servant>
7− APIs that use
8− <https://hackage.haskell.org/package/servant-auth servant-auth's> @Auth@ combinator.
9− .
10− For a quick overview of the usage, see the <https://github.com/haskell-servant/servant/tree/master/servant-auth#readme README>.
11−category: Web, Servant, Authentication
12−homepage: https://github.com/haskell-servant/servant/tree/master/servant-auth#readme
13−bug-reports: https://github.com/haskell-servant/servant/issues
14−author: Julian K. Arni
15−maintainer: jkarni@gmail.com
16−copyright: (c) Julian K. Arni
17−license: BSD-3-Clause
18−license-file: LICENSE
19−tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1
20−build-type: Custom
21−extra-source-files:
22− CHANGELOG.md
23−
24−custom-setup
25− setup-depends:
26− base, Cabal, cabal-doctest >=1.0.6 && <1.1
27−
28−source-repository head
29− type: git
30− location: https://github.com/haskell-servant/servant
31−
32−library
33− hs-source-dirs:
34− src
35− default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
36− ghc-options: -Wall
37− build-depends:
38− base >= 4.10 && < 4.18
39− , servant-docs >= 0.11.2 && < 0.13
40− , servant >= 0.13 && < 0.20
41− , servant-auth == 0.4.*
42− , lens >= 4.16.1 && <5.3
43− exposed-modules:
44− Servant.Auth.Docs
45− default-language: Haskell2010
46−
47−test-suite doctests
48− type: exitcode-stdio-1.0
49− main-is: doctests.hs
50− build-depends:
51− base,
52− servant-auth-docs,
53− doctest >= 0.16 && < 0.21,
54− QuickCheck >= 2.11.3 && < 2.15,
55− template-haskell
56− ghc-options: -Wall -threaded
57− hs-source-dirs: test
58− default-language: Haskell2010
59−
60−test-suite spec
61− type: exitcode-stdio-1.0
62− main-is: Spec.hs
63− hs-source-dirs:
64− test
65− default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
66− ghc-options: -Wall
67− build-tool-depends: hspec-discover:hspec-discover >=2.5.5 && <2.10
68−
69− -- dependencies with bounds inherited from the library stanza
70− build-depends:
71− base
72− , text
73− , servant-docs
74− , servant
75− , servant-auth
76− , lens
77−
78− -- test dependencies
79− build-depends:
80− servant-auth-docs
81− , hspec >= 2.5.5 && < 2.10
82− , QuickCheck >= 2.11.3 && < 2.15
83−
84− default-language: Haskell2010
servant-auth/servant-auth-docs/src/Servant/Auth/Docs.hsdeleted−96
@@ -1,96 +0,0 @@
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.hsdeleted−1
@@ -1 +0,0 @@
1−{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
servant-auth/servant-auth-docs/test/doctests.hsdeleted−12
@@ -1,12 +0,0 @@
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/.ghcideleted−1
@@ -1 +0,0 @@
1−:set -isrc -itest -idoctest/ghci-wrapper/src
servant-auth/servant-auth-server/CHANGELOG.mddeleted−130
@@ -1,130 +0,0 @@
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/LICENSEdeleted−31
@@ -1,31 +0,0 @@
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.lhsdeleted−291
@@ -1,291 +0,0 @@
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.mddeleted−1
@@ -1 +0,0 @@
1−README.lhs
servant-auth/servant-auth-server/Setup.hsdeleted−2
@@ -1,2 +0,0 @@
1−import Distribution.Simple
2−main = defaultMain
servant-auth/servant-auth-server/servant-auth-server.cabaldeleted−135
@@ -1,135 +0,0 @@
1−cabal-version: 2.2
2−name: servant-auth-server
3−version: 0.4.7.0
4−synopsis: servant-server/servant-auth compatibility
5−description: This package provides the required instances for using the @Auth@ combinator
6− in your 'servant' server.
7− .
8− Both cookie- and token- (REST API) based authentication is provided.
9− .
10− For a quick overview of the usage, see the <https://github.com/haskell-servant/servant/tree/master/servant-auth#readme README>.
11−category: Web, Servant, Authentication
12−homepage: https://github.com/haskell-servant/servant/tree/master/servant-auth#readme
13−bug-reports: https://github.com/haskell-servant/servant/issues
14−author: Julian K. Arni
15−maintainer: jkarni@gmail.com
16−copyright: (c) Julian K. Arni
17−license: BSD-3-Clause
18−license-file: LICENSE
19−tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1
20−build-type: Simple
21−extra-source-files:
22− CHANGELOG.md
23−
24−source-repository head
25− type: git
26− location: https://github.com/haskell-servant/servant
27−
28−library
29− hs-source-dirs:
30− src
31− default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
32− ghc-options: -Wall
33− build-depends:
34− base >= 4.10 && < 4.18
35− , aeson >= 1.0.0.1 && < 3
36− , base64-bytestring >= 1.0.0.1 && < 2
37− , blaze-builder >= 0.4.1.0 && < 0.5
38− , bytestring >= 0.10.6.0 && < 0.12
39− , case-insensitive >= 1.2.0.11 && < 1.3
40− , cookie >= 0.4.4 && < 0.5
41− , data-default-class >= 0.1.2.0 && < 0.2
42− , entropy >= 0.4.1.3 && < 0.5
43− , http-types >= 0.12.2 && < 0.13
44− , jose >= 0.10 && < 0.11
45− , lens >= 4.16.1 && < 5.3
46− , memory >= 0.14.16 && < 0.19
47− , monad-time >= 0.3.1.0 && < 0.4
48− , mtl ^>= 2.2.2 || ^>= 2.3.1
49− , servant >= 0.13 && < 0.20
50− , servant-auth == 0.4.*
51− , servant-server >= 0.13 && < 0.20
52− , tagged >= 0.8.4 && < 0.9
53− , text >= 1.2.3.0 && < 2.1
54− , time >= 1.5.0.1 && < 1.13
55− , unordered-containers >= 0.2.9.0 && < 0.3
56− , wai >= 3.2.1.2 && < 3.3
57−
58− if impl(ghc >= 9)
59− build-depends:
60− -- base64-bytestring 1.2.1.0 contains important fix for GHC-9, lower versions
61− -- produce wrong results, thus corrupring JWT via jose package.
62− -- See: https://github.com/haskell/base64-bytestring/pull/46
63− base64-bytestring >= 1.2.1.0
64−
65− exposed-modules:
66− Servant.Auth.Server
67− Servant.Auth.Server.Internal
68− Servant.Auth.Server.Internal.AddSetCookie
69− Servant.Auth.Server.Internal.BasicAuth
70− Servant.Auth.Server.Internal.Class
71− Servant.Auth.Server.Internal.ConfigTypes
72− Servant.Auth.Server.Internal.Cookie
73− Servant.Auth.Server.Internal.FormLogin
74− Servant.Auth.Server.Internal.JWT
75− Servant.Auth.Server.Internal.ThrowAll
76− Servant.Auth.Server.Internal.Types
77− Servant.Auth.Server.SetCookieOrphan
78− default-language: Haskell2010
79−
80−test-suite readme
81− type: exitcode-stdio-1.0
82− main-is: README.lhs
83− default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
84− ghc-options: -Wall -pgmL markdown-unlit
85− build-tool-depends: markdown-unlit:markdown-unlit
86− build-depends:
87− base
88− , servant-auth
89− , servant-auth-server
90− , servant-server
91− , aeson
92− , mtl
93− , warp
94− default-language: Haskell2010
95− if impl(ghcjs)
96− buildable: False
97−
98−test-suite spec
99− type: exitcode-stdio-1.0
100− main-is: Spec.hs
101− hs-source-dirs:
102− test
103− default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
104− ghc-options: -Wall
105− build-tool-depends: hspec-discover:hspec-discover >=2.5.5 && <2.10
106−
107− -- dependencies with bounds inherited from the library stanza
108− build-depends:
109− base
110− , aeson
111− , bytestring
112− , case-insensitive
113− , jose
114− , lens
115− , mtl
116− , time
117− , http-types
118− , wai
119− , servant
120− , servant-server
121− , transformers
122−
123− -- test dependencies
124− build-depends:
125− servant-auth-server
126− , hspec >= 2.5.5 && < 2.10
127− , QuickCheck >= 2.11.3 && < 2.15
128− , http-client >= 0.5.13.1 && < 0.8
129− , lens-aeson >= 1.0.2 && < 1.3
130− , warp >= 3.2.25 && < 3.4
131− , wreq >= 0.5.2.1 && < 0.6
132− , text >= 1.2.3.0 && < 2.1
133− other-modules:
134− Servant.Auth.ServerSpec
135− default-language: Haskell2010
servant-auth/servant-auth-server/src/Servant/Auth/Server.hsdeleted−180
@@ -1,180 +0,0 @@
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.hsdeleted−67
@@ -1,67 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE UndecidableInstances #-}
3−{-# OPTIONS_GHC -fno-warn-orphans #-}
4−
5−module Servant.Auth.Server.Internal where
6−
7−import Control.Monad.Trans (liftIO)
8−import Servant ((:>), Handler, HasServer (..),
9− Proxy (..),
10− HasContextEntry(getContextEntry))
11−import Servant.Auth
12−import Servant.Auth.JWT (ToJWT)
13−
14−import Servant.Auth.Server.Internal.AddSetCookie
15−import Servant.Auth.Server.Internal.Class
16−import Servant.Auth.Server.Internal.Cookie
17−import Servant.Auth.Server.Internal.ConfigTypes
18−import Servant.Auth.Server.Internal.JWT
19−import Servant.Auth.Server.Internal.Types
20−
21−import Servant.Server.Internal (DelayedIO, addAuthCheck, withRequest)
22−
23−instance ( n ~ 'S ('S 'Z)
24− , HasServer (AddSetCookiesApi n api) ctxs, AreAuths auths ctxs v
25− , HasServer api ctxs -- this constraint is needed to implement hoistServer
26− , AddSetCookies n (ServerT api Handler) (ServerT (AddSetCookiesApi n api) Handler)
27− , ToJWT v
28− , HasContextEntry ctxs CookieSettings
29− , HasContextEntry ctxs JWTSettings
30− ) => HasServer (Auth auths v :> api) ctxs where
31− type ServerT (Auth auths v :> api) m = AuthResult v -> ServerT api m
32−
33−#if MIN_VERSION_servant_server(0,12,0)
34− hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
35−#endif
36−
37− route _ context subserver =
38− route (Proxy :: Proxy (AddSetCookiesApi n api))
39− context
40− (fmap go subserver `addAuthCheck` authCheck)
41−
42− where
43− authCheck :: DelayedIO (AuthResult v, SetCookieList ('S ('S 'Z)))
44− authCheck = withRequest $ \req -> liftIO $ do
45− authResult <- runAuthCheck (runAuths (Proxy :: Proxy auths) context) req
46− cookies <- makeCookies authResult
47− return (authResult, cookies)
48−
49− jwtSettings :: JWTSettings
50− jwtSettings = getContextEntry context
51−
52− cookieSettings :: CookieSettings
53− cookieSettings = getContextEntry context
54−
55− makeCookies :: AuthResult v -> IO (SetCookieList ('S ('S 'Z)))
56− makeCookies authResult = do
57− case authResult of
58− (Authenticated v) -> do
59− ejwt <- makeSessionCookie cookieSettings jwtSettings v
60− xsrf <- makeXsrfCookie cookieSettings
61− return $ Just xsrf `SetCookieCons` (ejwt `SetCookieCons` SetCookieNil)
62− _ -> return $ Nothing `SetCookieCons` (Nothing `SetCookieCons` SetCookieNil)
63−
64− go :: (AuthResult v -> ServerT api Handler)
65− -> (AuthResult v, SetCookieList n)
66− -> ServerT (AddSetCookiesApi n api) Handler
67− go fn (authResult, cookies) = addSetCookies cookies $ fn authResult
servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/AddSetCookie.hsdeleted−119
@@ -1,119 +0,0 @@
1−{-# LANGUAGE PolyKinds #-}
2−{-# LANGUAGE TupleSections #-}
3−{-# LANGUAGE UndecidableInstances #-}
4−{-# LANGUAGE CPP #-}
5−
6−module Servant.Auth.Server.Internal.AddSetCookie where
7−
8−import Blaze.ByteString.Builder (toByteString)
9−import qualified Data.ByteString as BS
10−import Data.Tagged (Tagged (..))
11−import qualified Network.HTTP.Types as HTTP
12−import Network.Wai (mapResponseHeaders)
13−import Servant
14−import Servant.API.UVerb.Union
15−import Servant.API.Generic
16−import Servant.Server.Generic
17−import Web.Cookie
18−
19−-- What are we doing here? Well, the idea is to add headers to the response,
20−-- but the headers come from the authentication check. In order to do that, we
21−-- tweak a little the general theme of recursing down the API tree; this time,
22−-- we recurse down a variation of it that adds headers to all the endpoints.
23−-- This involves the usual type-level checks.
24−--
25−-- TODO: If the endpoints already have headers, this will not work as is.
26−
27−data Nat = Z | S Nat
28−
29−type family AddSetCookiesApi (n :: Nat) a where
30− AddSetCookiesApi ('S 'Z) a = AddSetCookieApi a
31− AddSetCookiesApi ('S n) a = AddSetCookiesApi n (AddSetCookieApi a)
32−
33−type family AddSetCookieApiVerb a where
34− AddSetCookieApiVerb (Headers ls a) = Headers (Header "Set-Cookie" SetCookie ': ls) a
35− AddSetCookieApiVerb a = Headers '[Header "Set-Cookie" SetCookie] a
36−
37−#if MIN_VERSION_servant_server(0,18,1)
38−type family MapAddSetCookieApiVerb (as :: [*]) where
39− MapAddSetCookieApiVerb '[] = '[]
40− MapAddSetCookieApiVerb (a ': as) = (AddSetCookieApiVerb a ': MapAddSetCookieApiVerb as)
41−#endif
42−
43−type family AddSetCookieApi a :: *
44−type instance AddSetCookieApi (a :> b) = a :> AddSetCookieApi b
45−type instance AddSetCookieApi (a :<|> b) = AddSetCookieApi a :<|> AddSetCookieApi b
46−#if MIN_VERSION_servant_server(0,19,0)
47−type instance AddSetCookieApi (NamedRoutes api) = AddSetCookieApi (ToServantApi api)
48−#endif
49−type instance AddSetCookieApi (Verb method stat ctyps a)
50− = Verb method stat ctyps (AddSetCookieApiVerb a)
51−#if MIN_VERSION_servant_server(0,18,1)
52−type instance AddSetCookieApi (UVerb method ctyps as)
53− = UVerb method ctyps (MapAddSetCookieApiVerb as)
54−#endif
55−type instance AddSetCookieApi Raw = Raw
56−#if MIN_VERSION_servant_server(0,15,0)
57−type instance AddSetCookieApi (Stream method stat framing ctyps a)
58− = Stream method stat framing ctyps (AddSetCookieApiVerb a)
59−#endif
60−type instance AddSetCookieApi (Headers hs a) = AddSetCookieApiVerb (Headers hs a)
61−
62−data SetCookieList (n :: Nat) :: * where
63− SetCookieNil :: SetCookieList 'Z
64− SetCookieCons :: Maybe SetCookie -> SetCookieList n -> SetCookieList ('S n)
65−
66−class AddSetCookies (n :: Nat) orig new where
67− addSetCookies :: SetCookieList n -> orig -> new
68−
69−instance {-# OVERLAPS #-} AddSetCookies ('S n) oldb newb
70− => AddSetCookies ('S n) (a -> oldb) (a -> newb) where
71− addSetCookies cookies oldfn = addSetCookies cookies . oldfn
72−
73−instance (orig1 ~ orig2) => AddSetCookies 'Z orig1 orig2 where
74− addSetCookies _ = id
75−
76−instance {-# OVERLAPPABLE #-}
77− ( Functor m
78− , AddSetCookies n (m old) (m cookied)
79− , AddHeader "Set-Cookie" SetCookie cookied new
80− ) => AddSetCookies ('S n) (m old) (m new) where
81− addSetCookies (mCookie `SetCookieCons` rest) oldVal =
82− case mCookie of
83− Nothing -> noHeader <$> addSetCookies rest oldVal
84− Just cookie -> addHeader cookie <$> addSetCookies rest oldVal
85−
86−instance {-# OVERLAPS #-}
87− (AddSetCookies ('S n) a a', AddSetCookies ('S n) b b')
88− => AddSetCookies ('S n) (a :<|> b) (a' :<|> b') where
89− addSetCookies cookies (a :<|> b) = addSetCookies cookies a :<|> addSetCookies cookies b
90−
91−instance {-# OVERLAPS #-}
92− ( AddSetCookies ('S n) (ServerT (ToServantApi api) m) cookiedApi
93− , Generic (api (AsServerT m))
94− , GServantProduct (Rep (api (AsServerT m)))
95− , ToServant api (AsServerT m) ~ ServerT (ToServantApi api) m
96− )
97− => AddSetCookies ('S n) (api (AsServerT m)) cookiedApi where
98− addSetCookies cookies = addSetCookies cookies . toServant
99−
100−-- | for @servant <0.11@
101−instance
102− AddSetCookies ('S n) Application Application where
103− addSetCookies cookies r request respond
104− = r request $ respond . mapResponseHeaders (++ mkHeaders cookies)
105−
106−-- | for @servant >=0.11@
107−instance
108− AddSetCookies ('S n) (Tagged m Application) (Tagged m Application) where
109− addSetCookies cookies r = Tagged $ \request respond ->
110− unTagged r request $ respond . mapResponseHeaders (++ mkHeaders cookies)
111−
112−mkHeaders :: SetCookieList x -> [HTTP.Header]
113−mkHeaders x = ("Set-Cookie",) <$> mkCookies x
114− where
115− mkCookies :: forall y. SetCookieList y -> [BS.ByteString]
116− mkCookies SetCookieNil = []
117− mkCookies (SetCookieCons Nothing rest) = mkCookies rest
118− mkCookies (SetCookieCons (Just y) rest)
119− = toByteString (renderSetCookie y) : mkCookies rest
servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/BasicAuth.hsdeleted−59
@@ -1,59 +0,0 @@
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.hsdeleted−72
@@ -1,72 +0,0 @@
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.hsdeleted−127
@@ -1,127 +0,0 @@
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.hsdeleted−183
@@ -1,183 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−module Servant.Auth.Server.Internal.Cookie where
3−
4−import Blaze.ByteString.Builder (toByteString)
5−import Control.Monad (MonadPlus(..), guard)
6−import Control.Monad.Except
7−import Control.Monad.Reader
8−import qualified Crypto.JOSE as Jose
9−import qualified Crypto.JWT as Jose
10−import Data.ByteArray (constEq)
11−import qualified Data.ByteString as BS
12−import qualified Data.ByteString.Base64 as BS64
13−import qualified Data.ByteString.Lazy as BSL
14−import Data.CaseInsensitive (mk)
15−import Data.Maybe (fromMaybe)
16−import Data.Time.Calendar (Day(..))
17−import Data.Time.Clock (UTCTime(..), secondsToDiffTime)
18−import Network.HTTP.Types (methodGet)
19−import Network.HTTP.Types.Header(hCookie)
20−import Network.Wai (Request, requestHeaders, requestMethod)
21−import Servant (AddHeader, addHeader)
22−import System.Entropy (getEntropy)
23−import Web.Cookie
24−
25−import Servant.Auth.JWT (FromJWT (decodeJWT), ToJWT)
26−import Servant.Auth.Server.Internal.ConfigTypes
27−import Servant.Auth.Server.Internal.JWT (makeJWT, verifyJWT)
28−import Servant.Auth.Server.Internal.Types
29−
30−
31−cookieAuthCheck :: FromJWT usr => CookieSettings -> JWTSettings -> AuthCheck usr
32−cookieAuthCheck ccfg jwtSettings = do
33− req <- ask
34− jwtCookie <- maybe mempty return $ do
35− cookies' <- lookup hCookie $ requestHeaders req
36− let cookies = parseCookies cookies'
37− -- Apply the XSRF check if enabled.
38− guard $ fromMaybe True $ do
39− xsrfCookieCfg <- xsrfCheckRequired ccfg req
40− return $ xsrfCookieAuthCheck xsrfCookieCfg req cookies
41− -- session cookie *must* be HttpOnly and Secure
42− lookup (sessionCookieName ccfg) cookies
43− verifiedJWT <- liftIO $ verifyJWT jwtSettings jwtCookie
44− case verifiedJWT of
45− Nothing -> mzero
46− Just v -> return v
47−
48−xsrfCheckRequired :: CookieSettings -> Request -> Maybe XsrfCookieSettings
49−xsrfCheckRequired cookieSettings req = do
50− xsrfCookieCfg <- cookieXsrfSetting cookieSettings
51− let disableForGetReq = xsrfExcludeGet xsrfCookieCfg && requestMethod req == methodGet
52− guard $ not disableForGetReq
53− return xsrfCookieCfg
54−
55−xsrfCookieAuthCheck :: XsrfCookieSettings -> Request -> [(BS.ByteString, BS.ByteString)] -> Bool
56−xsrfCookieAuthCheck xsrfCookieCfg req cookies = fromMaybe False $ do
57− xsrfCookie <- lookup (xsrfCookieName xsrfCookieCfg) cookies
58− xsrfHeader <- lookup (mk $ xsrfHeaderName xsrfCookieCfg) $ requestHeaders req
59− return $ xsrfCookie `constEq` xsrfHeader
60−
61−-- | Makes a cookie to be used for XSRF.
62−makeXsrfCookie :: CookieSettings -> IO SetCookie
63−makeXsrfCookie cookieSettings = case cookieXsrfSetting cookieSettings of
64− Just xsrfCookieSettings -> makeRealCookie xsrfCookieSettings
65− Nothing -> return $ noXsrfTokenCookie cookieSettings
66− where
67− makeRealCookie xsrfCookieSettings = do
68− xsrfValue <- BS64.encode <$> getEntropy 32
69− return
70− $ applyXsrfCookieSettings xsrfCookieSettings
71− $ applyCookieSettings cookieSettings
72− $ def{ setCookieValue = xsrfValue }
73−
74−
75−-- | Alias for 'makeXsrfCookie'.
76−makeCsrfCookie :: CookieSettings -> IO SetCookie
77−makeCsrfCookie = makeXsrfCookie
78−{-# DEPRECATED makeCsrfCookie "Use makeXsrfCookie instead" #-}
79−
80−
81−-- | Makes a cookie with session information.
82−makeSessionCookie :: ToJWT v => CookieSettings -> JWTSettings -> v -> IO (Maybe SetCookie)
83−makeSessionCookie cookieSettings jwtSettings v = do
84− ejwt <- makeJWT v jwtSettings (cookieExpires cookieSettings)
85− case ejwt of
86− Left _ -> return Nothing
87− Right jwt -> return
88− $ Just
89− $ applySessionCookieSettings cookieSettings
90− $ applyCookieSettings cookieSettings
91− $ def{ setCookieValue = BSL.toStrict jwt }
92−
93−noXsrfTokenCookie :: CookieSettings -> SetCookie
94−noXsrfTokenCookie cookieSettings =
95− applyCookieSettings cookieSettings $ def{ setCookieName = "NO-XSRF-TOKEN", setCookieValue = "" }
96−
97−applyCookieSettings :: CookieSettings -> SetCookie -> SetCookie
98−applyCookieSettings cookieSettings setCookie = setCookie
99− { setCookieMaxAge = cookieMaxAge cookieSettings
100− , setCookieExpires = cookieExpires cookieSettings
101− , setCookiePath = cookiePath cookieSettings
102− , setCookieDomain = cookieDomain cookieSettings
103− , setCookieSecure = case cookieIsSecure cookieSettings of
104− Secure -> True
105− NotSecure -> False
106− }
107−
108−applyXsrfCookieSettings :: XsrfCookieSettings -> SetCookie -> SetCookie
109−applyXsrfCookieSettings xsrfCookieSettings setCookie = setCookie
110− { setCookieName = xsrfCookieName xsrfCookieSettings
111− , setCookiePath = xsrfCookiePath xsrfCookieSettings
112− , setCookieHttpOnly = False
113− }
114−
115−applySessionCookieSettings :: CookieSettings -> SetCookie -> SetCookie
116−applySessionCookieSettings cookieSettings setCookie = setCookie
117− { setCookieName = sessionCookieName cookieSettings
118− , setCookieSameSite = case cookieSameSite cookieSettings of
119− AnySite -> anySite
120− SameSiteStrict -> Just sameSiteStrict
121− SameSiteLax -> Just sameSiteLax
122− , setCookieHttpOnly = True
123− }
124− where
125−#if MIN_VERSION_cookie(0,4,5)
126− anySite = Just sameSiteNone
127−#else
128− anySite = Nothing
129−#endif
130−
131−-- | For a JWT-serializable session, returns a function that decorates a
132−-- provided response object with XSRF and session cookies. This should be used
133−-- when a user successfully authenticates with credentials.
134−acceptLogin :: ( ToJWT session
135− , AddHeader "Set-Cookie" SetCookie response withOneCookie
136− , AddHeader "Set-Cookie" SetCookie withOneCookie withTwoCookies )
137− => CookieSettings
138− -> JWTSettings
139− -> session
140− -> IO (Maybe (response -> withTwoCookies))
141−acceptLogin cookieSettings jwtSettings session = do
142− mSessionCookie <- makeSessionCookie cookieSettings jwtSettings session
143− case mSessionCookie of
144− Nothing -> pure Nothing
145− Just sessionCookie -> do
146− xsrfCookie <- makeXsrfCookie cookieSettings
147− return $ Just $ addHeader sessionCookie . addHeader xsrfCookie
148−
149−-- | Arbitrary cookie expiry time set back in history after unix time 0
150−expireTime :: UTCTime
151−expireTime = UTCTime (ModifiedJulianDay 50000) 0
152−
153−-- | Adds headers to a response that clears all session cookies
154−-- | using max-age and expires cookie attributes.
155−clearSession :: ( AddHeader "Set-Cookie" SetCookie response withOneCookie
156− , AddHeader "Set-Cookie" SetCookie withOneCookie withTwoCookies )
157− => CookieSettings
158− -> response
159− -> withTwoCookies
160−clearSession cookieSettings = addHeader clearedSessionCookie . addHeader clearedXsrfCookie
161− where
162− -- According to RFC6265 max-age takes precedence, but IE/Edge ignore it completely so we set both
163− cookieSettingsExpires = cookieSettings
164− { cookieExpires = Just expireTime
165− , cookieMaxAge = Just (secondsToDiffTime 0)
166− }
167− clearedSessionCookie = applySessionCookieSettings cookieSettingsExpires $ applyCookieSettings cookieSettingsExpires def
168− clearedXsrfCookie = case cookieXsrfSetting cookieSettings of
169− Just xsrfCookieSettings -> applyXsrfCookieSettings xsrfCookieSettings $ applyCookieSettings cookieSettingsExpires def
170− Nothing -> noXsrfTokenCookie cookieSettingsExpires
171−
172−makeSessionCookieBS :: ToJWT v => CookieSettings -> JWTSettings -> v -> IO (Maybe BS.ByteString)
173−makeSessionCookieBS a b c = fmap (toByteString . renderSetCookie) <$> makeSessionCookie a b c
174−
175−-- | Alias for 'makeSessionCookie'.
176−makeCookie :: ToJWT v => CookieSettings -> JWTSettings -> v -> IO (Maybe SetCookie)
177−makeCookie = makeSessionCookie
178−{-# DEPRECATED makeCookie "Use makeSessionCookie instead" #-}
179−
180−-- | Alias for 'makeSessionCookieBS'.
181−makeCookieBS :: ToJWT v => CookieSettings -> JWTSettings -> v -> IO (Maybe BS.ByteString)
182−makeCookieBS = makeSessionCookieBS
183−{-# DEPRECATED makeCookieBS "Use makeSessionCookieBS instead" #-}
servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/FormLogin.hsdeleted−3
@@ -1,3 +0,0 @@
1−module Servant.Auth.Server.Internal.FormLogin where
2−
3−
servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/JWT.hsdeleted−68
@@ -1,68 +0,0 @@
1−module Servant.Auth.Server.Internal.JWT where
2−
3−import Control.Lens
4−import Control.Monad (MonadPlus(..), guard)
5−import Control.Monad.Reader
6−import qualified Crypto.JOSE as Jose
7−import qualified Crypto.JWT as Jose
8−import Data.ByteArray (constEq)
9−import qualified Data.ByteString as BS
10−import qualified Data.ByteString.Lazy as BSL
11−import Data.Maybe (fromMaybe)
12−import Data.Time (UTCTime)
13−import Network.Wai (requestHeaders)
14−
15−import Servant.Auth.JWT (FromJWT(..), ToJWT(..))
16−import Servant.Auth.Server.Internal.ConfigTypes
17−import Servant.Auth.Server.Internal.Types
18−
19−
20−-- | A JWT @AuthCheck@. You likely won't need to use this directly unless you
21−-- are protecting a @Raw@ endpoint.
22−jwtAuthCheck :: FromJWT usr => JWTSettings -> AuthCheck usr
23−jwtAuthCheck jwtSettings = do
24− req <- ask
25− token <- maybe mempty return $ do
26− authHdr <- lookup "Authorization" $ requestHeaders req
27− let bearer = "Bearer "
28− (mbearer, rest) = BS.splitAt (BS.length bearer) authHdr
29− guard (mbearer `constEq` bearer)
30− return rest
31− verifiedJWT <- liftIO $ verifyJWT jwtSettings token
32− case verifiedJWT of
33− Nothing -> mzero
34− Just v -> return v
35−
36−-- | Creates a JWT containing the specified data. The data is stored in the
37−-- @dat@ claim. The 'Maybe UTCTime' argument indicates the time at which the
38−-- token expires.
39−makeJWT :: ToJWT a
40− => a -> JWTSettings -> Maybe UTCTime -> IO (Either Jose.Error BSL.ByteString)
41−makeJWT v cfg expiry = Jose.runJOSE $ do
42− bestAlg <- Jose.bestJWSAlg $ signingKey cfg
43− let alg = fromMaybe bestAlg $ jwtAlg cfg
44− ejwt <- Jose.signClaims (signingKey cfg)
45− (Jose.newJWSHeader ((), alg))
46− (addExp $ encodeJWT v)
47−
48− return $ Jose.encodeCompact ejwt
49− where
50− addExp claims = case expiry of
51− Nothing -> claims
52− Just e -> claims & Jose.claimExp ?~ Jose.NumericDate e
53−
54−
55−verifyJWT :: FromJWT a => JWTSettings -> BS.ByteString -> IO (Maybe a)
56−verifyJWT jwtCfg input = do
57− keys <- validationKeys jwtCfg
58− verifiedJWT <- Jose.runJOSE $ do
59− unverifiedJWT <- Jose.decodeCompact (BSL.fromStrict input)
60− Jose.verifyClaims
61− (jwtSettingsToJwtValidationSettings jwtCfg)
62− keys
63− unverifiedJWT
64− return $ case verifiedJWT of
65− Left (_ :: Jose.JWTError) -> Nothing
66− Right v -> case decodeJWT v of
67− Left _ -> Nothing
68− Right v' -> Just v'
servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/ThrowAll.hsdeleted−58
@@ -1,58 +0,0 @@
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.hsdeleted−113
@@ -1,113 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−module Servant.Auth.Server.Internal.Types where
3−
4−import Control.Applicative
5−import Control.Monad (MonadPlus(..), ap)
6−import Control.Monad.Reader
7−import Control.Monad.Time
8−import Data.Monoid (Monoid (..))
9−import Data.Semigroup (Semigroup (..))
10−import Data.Time (getCurrentTime)
11−import GHC.Generics (Generic)
12−import Network.Wai (Request)
13−
14−import qualified Control.Monad.Fail as Fail
15−
16−-- | The result of an authentication attempt.
17−data AuthResult val
18− = BadPassword
19− | NoSuchUser
20− -- | Authentication succeeded.
21− | Authenticated val
22− -- | If an authentication procedure cannot be carried out - if for example it
23− -- expects a password and username in a header that is not present -
24− -- @Indefinite@ is returned. This indicates that other authentication
25− -- methods should be tried.
26− | Indefinite
27− deriving (Eq, Show, Read, Generic, Ord, Functor, Traversable, Foldable)
28−
29−instance Semigroup (AuthResult val) where
30− Indefinite <> y = y
31− x <> _ = x
32−
33−instance Monoid (AuthResult val) where
34− mempty = Indefinite
35− mappend = (<>)
36−
37−instance Applicative AuthResult where
38− pure = return
39− (<*>) = ap
40−
41−instance Monad AuthResult where
42− return = Authenticated
43− Authenticated v >>= f = f v
44− BadPassword >>= _ = BadPassword
45− NoSuchUser >>= _ = NoSuchUser
46− Indefinite >>= _ = Indefinite
47−
48−instance Alternative AuthResult where
49− empty = mzero
50− (<|>) = mplus
51−
52−instance MonadPlus AuthResult where
53− mzero = mempty
54− mplus = (<>)
55−
56−
57−-- | An @AuthCheck@ is the function used to decide the authentication status
58−-- (the 'AuthResult') of a request. Different @AuthCheck@s may be combined as a
59−-- Monoid or Alternative; the semantics of this is that the *first*
60−-- non-'Indefinite' result from left to right is used and the rest are ignored.
61−newtype AuthCheck val = AuthCheck
62− { runAuthCheck :: Request -> IO (AuthResult val) }
63− deriving (Generic, Functor)
64−
65−instance Semigroup (AuthCheck val) where
66− AuthCheck f <> AuthCheck g = AuthCheck $ \x -> do
67− fx <- f x
68− case fx of
69− Indefinite -> g x
70− r -> pure r
71−
72−instance Monoid (AuthCheck val) where
73− mempty = AuthCheck $ const $ return mempty
74− mappend = (<>)
75−
76−instance Applicative AuthCheck where
77− pure = return
78− (<*>) = ap
79−
80−instance Monad AuthCheck where
81− return = AuthCheck . return . return . return
82− AuthCheck ac >>= f = AuthCheck $ \req -> do
83− aresult <- ac req
84− case aresult of
85− Authenticated usr -> runAuthCheck (f usr) req
86− BadPassword -> return BadPassword
87− NoSuchUser -> return NoSuchUser
88− Indefinite -> return Indefinite
89−
90−#if !MIN_VERSION_base(4,13,0)
91− fail = Fail.fail
92−#endif
93−
94−instance Fail.MonadFail AuthCheck where
95− fail _ = AuthCheck . const $ return Indefinite
96−
97−instance MonadReader Request AuthCheck where
98− ask = AuthCheck $ \x -> return (Authenticated x)
99− local f (AuthCheck check) = AuthCheck $ \req -> check (f req)
100−
101−instance MonadIO AuthCheck where
102− liftIO action = AuthCheck $ const $ Authenticated <$> action
103−
104−instance MonadTime AuthCheck where
105− currentTime = liftIO getCurrentTime
106−
107−instance Alternative AuthCheck where
108− empty = mzero
109− (<|>) = mplus
110−
111−instance MonadPlus AuthCheck where
112− mzero = mempty
113− mplus = (<>)
servant-auth/servant-auth-server/src/Servant/Auth/Server/SetCookieOrphan.hsdeleted−3
@@ -1,3 +0,0 @@
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.hsdeleted−634
@@ -1,634 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE TypeApplications #-}
3−module Servant.Auth.ServerSpec (spec) where
4−
5−#if !MIN_VERSION_servant_server(0,16,0)
6−#define ServerError ServantErr
7−#endif
8−
9−import Control.Lens
10−import Control.Monad.IO.Class (liftIO)
11−import Crypto.JOSE (Alg (HS256, None), Error,
12− JWK, JWSHeader,
13− KeyMaterialGenParam (OctGenParam),
14− ToCompact, encodeCompact,
15− genJWK, newJWSHeader, runJOSE)
16−import Crypto.JWT (Audience (..), ClaimsSet,
17− NumericDate (NumericDate),
18− SignedJWT,
19− claimAud, claimNbf,
20− signClaims,
21− emptyClaimsSet,
22− unregisteredClaims)
23−import Data.Aeson (FromJSON, ToJSON, Value,
24− toJSON, encode)
25−import Data.Aeson.Lens (_JSON)
26−import qualified Data.ByteString as BS
27−import qualified Data.ByteString.Lazy as BSL
28−import Data.Text (Text, pack)
29−import Data.CaseInsensitive (mk)
30−import Data.Foldable (find)
31−import Data.Monoid
32−import Data.Time
33−import Data.Time.Clock (getCurrentTime)
34−import GHC.Generics (Generic)
35−import Network.HTTP.Client (cookie_http_only,
36− cookie_name, cookie_value,
37− cookie_expiry_time,
38− destroyCookieJar)
39−import Network.HTTP.Types (Status, status200,
40− status401)
41−import Network.Wai (responseLBS)
42−import Network.Wai.Handler.Warp (testWithApplication)
43−import Network.Wreq (Options, auth, basicAuth,
44− checkResponse,
45− cookieExpiryTime, cookies,
46− defaults, get, getWith, postWith,
47− header, oauth2Bearer,
48− responseBody,
49− responseCookieJar,
50− responseHeader,
51− responseStatus)
52−import Network.Wreq.Types (Postable(..))
53−import Servant hiding (BasicAuth,
54− IsSecure (..), header)
55−import Servant.API.Generic ((:-))
56−import Servant.Auth.Server
57−import Servant.Auth.Server.Internal.Cookie (expireTime)
58−import Servant.Auth.Server.SetCookieOrphan ()
59−#if MIN_VERSION_servant_server(0,15,0)
60−import qualified Servant.Types.SourceT as S
61−#endif
62−import System.IO.Unsafe (unsafePerformIO)
63−import Test.Hspec
64−import Test.QuickCheck
65−import qualified Network.HTTP.Client as HCli
66−
67−
68−
69−spec :: Spec
70−spec = do
71− authSpec
72− cookieAuthSpec
73− jwtAuthSpec
74− throwAllSpec
75− basicAuthSpec
76−
77−------------------------------------------------------------------------------
78−-- * Auth {{{
79−
80−authSpec :: Spec
81−authSpec
82− = describe "The Auth combinator"
83− $ around (testWithApplication . return $ app jwtAndCookieApi) $ do
84−
85− it "returns a 401 if all authentications are Indefinite" $ \port -> do
86− get (url port) `shouldHTTPErrorWith` status401
87−
88− it "succeeds if one authentication suceeds" $ \port -> property $
89− \(user :: User) -> do
90− jwt <- makeJWT user jwtCfg Nothing
91− opts <- addJwtToHeader jwt
92− resp <- getWith opts (url port)
93− resp ^? responseBody . _JSON `shouldBe` Just (length $ name user)
94−
95− it "fails (403) if one authentication fails" $ const $
96− pendingWith "Authentications don't yet fail, only are Indefinite"
97−
98− it "doesn't clobber pre-existing response headers" $ \port -> property $
99− \(user :: User) -> do
100− jwt <- makeJWT user jwtCfg Nothing
101− opts <- addJwtToHeader jwt
102− resp <- getWith opts (url port ++ "/header")
103− resp ^. responseHeader "Blah" `shouldBe` "1797"
104− resp ^. responseHeader "Set-Cookie" `shouldSatisfy` (/= "")
105−
106− context "Raw" $ do
107−
108− it "gets the response body" $ \port -> property $ \(user :: User) -> do
109− jwt <- makeJWT user jwtCfg Nothing
110− opts <- addJwtToHeader jwt
111− resp <- getWith opts (url port ++ "/raw")
112− resp ^. responseBody `shouldBe` "how are you?"
113−
114− it "doesn't clobber pre-existing reponse headers" $ \port -> property $
115− \(user :: User) -> do
116− jwt <- makeJWT user jwtCfg Nothing
117− opts <- addJwtToHeader jwt
118− resp <- getWith opts (url port ++ "/raw")
119− resp ^. responseHeader "hi" `shouldBe` "there"
120− resp ^. responseHeader "Set-Cookie" `shouldSatisfy` (/= "")
121−
122−
123− context "Setting cookies" $ do
124−
125− it "sets cookies that it itself accepts" $ \port -> property $ \user -> do
126− jwt <- createJWT theKey (newJWSHeader ((), HS256))
127− (claims $ toJSON user)
128− opts' <- addJwtToCookie cookieCfg jwt
129− let opts = addCookie (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"])
130− (xsrfField xsrfCookieName cookieCfg <> "=blah")
131− resp <- getWith opts (url port)
132− let (cookieJar:_) = resp ^.. responseCookieJar
133− Just xxsrf = find (\x -> cookie_name x == xsrfField xsrfCookieName cookieCfg)
134− $ destroyCookieJar cookieJar
135− opts2 = defaults
136− & cookies .~ Just cookieJar
137− & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ [cookie_value xxsrf]
138− resp2 <- getWith opts2 (url port)
139− resp2 ^? responseBody . _JSON `shouldBe` Just (length $ name user)
140−
141− it "uses the Expiry from the configuration" $ \port -> property $ \(user :: User) -> do
142− jwt <- createJWT theKey (newJWSHeader ((), HS256))
143− (claims $ toJSON user)
144− opts' <- addJwtToCookie cookieCfg jwt
145− let opts = addCookie (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"])
146− (xsrfField xsrfCookieName cookieCfg <> "=blah")
147− resp <- getWith opts (url port)
148− let (cookieJar:_) = resp ^.. responseCookieJar
149− Just xxsrf = find (\x -> cookie_name x == xsrfField xsrfCookieName cookieCfg)
150− $ destroyCookieJar cookieJar
151− xxsrf ^. cookieExpiryTime `shouldBe` future
152−
153− it "sets the token cookie as HttpOnly" $ \port -> property $ \(user :: User) -> do
154− jwt <- createJWT theKey (newJWSHeader ((), HS256))
155− (claims $ toJSON user)
156− opts' <- addJwtToCookie cookieCfg jwt
157− let opts = addCookie (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"])
158− (xsrfField xsrfCookieName cookieCfg <> "=blah")
159− resp <- getWith opts (url port)
160− let (cookieJar:_) = resp ^.. responseCookieJar
161− Just token = find (\x -> cookie_name x == sessionCookieName cookieCfg)
162− $ destroyCookieJar cookieJar
163− cookie_http_only token `shouldBe` True
164−
165−
166−
167−-- }}}
168−------------------------------------------------------------------------------
169−-- * Cookie Auth {{{
170−
171−cookieAuthSpec :: Spec
172−cookieAuthSpec
173− = describe "The Auth combinator" $ do
174− describe "With XSRF check" $
175− around (testWithApplication . return $ app cookieOnlyApi) $ do
176−
177− it "fails if XSRF header and cookie don't match" $ \port -> property
178− $ \(user :: User) -> do
179− jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)
180− opts' <- addJwtToCookie cookieCfg jwt
181− let opts = addCookie (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"])
182− (xsrfField xsrfCookieName cookieCfg <> "=blerg")
183− getWith opts (url port) `shouldHTTPErrorWith` status401
184−
185− it "fails with no XSRF header or cookie" $ \port -> property
186− $ \(user :: User) -> do
187− jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)
188− opts' <- addJwtToCookie cookieCfg jwt
189− let opts = opts' & checkResponse .~ Just mempty
190− resp <- getWith opts (url port)
191− resp ^. responseStatus `shouldBe` status401
192− (resp ^. responseCookieJar) `shouldNotHaveCookies` ["XSRF-TOKEN"]
193−
194− -- Validating that the XSRF cookie isn't added for UVerb routes either.
195− -- These routes can return a 401 response directly without using throwError / throwAll,
196− -- which revealed a bug:
197− --
198− -- https://github.com/haskell-servant/servant/issues/1570#issuecomment-1076374449
199− resp <- getWith opts (url port ++ "/uverb")
200− resp ^. responseStatus `shouldBe` status401
201− (resp ^. responseCookieJar) `shouldNotHaveCookies` ["XSRF-TOKEN"]
202−
203−
204− it "succeeds if XSRF header and cookie match, and JWT is valid" $ \port -> property
205− $ \(user :: User) -> do
206− jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)
207− opts' <- addJwtToCookie cookieCfg jwt
208− let opts = addCookie (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"])
209− (xsrfField xsrfCookieName cookieCfg <> "=blah")
210− resp <- getWith opts (url port)
211− resp ^? responseBody . _JSON `shouldBe` Just (length $ name user)
212−
213− it "sets and clears the right cookies" $ \port -> property
214− $ \(user :: User) -> do
215− let optsFromResp resp =
216− let jar = resp ^. responseCookieJar
217− Just xsrfCookieValue = cookie_value <$> find (\c -> cookie_name c == xsrfField xsrfCookieName cookieCfg) (destroyCookieJar jar)
218− in defaults
219− & cookies .~ Just jar -- real cookie jars aren't updated by being replaced
220− & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ [xsrfCookieValue]
221−
222− resp <- postWith defaults (url port ++ "/login") user
223− (resp ^. responseCookieJar) `shouldMatchCookieNames`
224− [ sessionCookieName cookieCfg
225− , xsrfField xsrfCookieName cookieCfg
226− ]
227− let loggedInOpts = optsFromResp resp
228−
229− resp <- getWith loggedInOpts (url port)
230− resp ^? responseBody . _JSON `shouldBe` Just (length $ name user)
231−
232− -- logout
233− resp <- getWith loggedInOpts (url port ++ "/logout")
234−
235− -- assert cookies were expired
236− now <- getCurrentTime
237− let assertCookie c = now >= cookie_expiry_time c
238− all assertCookie (destroyCookieJar (resp ^. responseCookieJar)) `shouldBe` True
239−
240− let loggedOutOpts = optsFromResp resp
241− getWith loggedOutOpts (url port) `shouldHTTPErrorWith` status401
242−
243− describe "With no XSRF check for GET requests" $ let
244− noXsrfGet xsrfCfg = xsrfCfg { xsrfExcludeGet = True }
245− cookieCfgNoXsrfGet = cookieCfg { cookieXsrfSetting = fmap noXsrfGet $ cookieXsrfSetting cookieCfg }
246− in around (testWithApplication . return $ appWithCookie cookieOnlyApi cookieCfgNoXsrfGet) $ do
247−
248− it "succeeds with no XSRF header or cookie for GET" $ \port -> property
249− $ \(user :: User) -> do
250− jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)
251− opts <- addJwtToCookie cookieCfgNoXsrfGet jwt
252− resp <- getWith opts (url port)
253− resp ^? responseBody . _JSON `shouldBe` Just (length $ name user)
254−
255− it "fails with no XSRF header or cookie for POST" $ \port -> property
256− $ \(user :: User) number -> do
257− jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)
258− opts <- addJwtToCookie cookieCfgNoXsrfGet jwt
259− postWith opts (url port) (toJSON (number :: Int)) `shouldHTTPErrorWith` status401
260−
261− describe "With no XSRF check at all" $ let
262− cookieCfgNoXsrf = cookieCfg { cookieXsrfSetting = Nothing }
263− in around (testWithApplication . return $ appWithCookie cookieOnlyApi cookieCfgNoXsrf) $ do
264−
265− it "succeeds with no XSRF header or cookie for GET" $ \port -> property
266− $ \(user :: User) -> do
267− jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)
268− opts <- addJwtToCookie cookieCfgNoXsrf jwt
269− resp <- getWith opts (url port)
270− resp ^? responseBody . _JSON `shouldBe` Just (length $ name user)
271−
272− it "succeeds with no XSRF header or cookie for POST" $ \port -> property
273− $ \(user :: User) number -> do
274− jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)
275− opts <- addJwtToCookie cookieCfgNoXsrf jwt
276− resp <- postWith opts (url port) $ toJSON (number :: Int)
277− resp ^? responseBody . _JSON `shouldBe` Just number
278−
279− it "sets and clears the right cookies" $ \port -> property
280− $ \(user :: User) -> do
281− let optsFromResp resp = defaults
282− & cookies .~ Just (resp ^. responseCookieJar) -- real cookie jars aren't updated by being replaced
283−
284− resp <- postWith defaults (url port ++ "/login") user
285− (resp ^. responseCookieJar) `shouldMatchCookieNames`
286− [ sessionCookieName cookieCfg
287− , "NO-XSRF-TOKEN"
288− ]
289− let loggedInOpts = optsFromResp resp
290−
291− resp <- getWith (loggedInOpts) (url port)
292− resp ^? responseBody . _JSON `shouldBe` Just (length $ name user)
293−
294− resp <- getWith loggedInOpts (url port ++ "/logout")
295− (resp ^. responseCookieJar) `shouldMatchCookieNameValues`
296− [ (sessionCookieName cookieCfg, "value")
297− , ("NO-XSRF-TOKEN", "")
298− ]
299−
300− -- assert cookies were expired
301− now <- getCurrentTime
302− let assertCookie c = now >= cookie_expiry_time c
303− all assertCookie (destroyCookieJar (resp ^. responseCookieJar)) `shouldBe` True
304−
305− let loggedOutOpts = optsFromResp resp
306−
307− getWith loggedOutOpts (url port) `shouldHTTPErrorWith` status401
308−
309−-- }}}
310−------------------------------------------------------------------------------
311−-- * JWT Auth {{{
312−
313−jwtAuthSpec :: Spec
314−jwtAuthSpec
315− = describe "The JWT combinator"
316− $ around (testWithApplication . return $ app jwtOnlyApi) $ do
317−
318− it "fails if 'aud' does not match predicate" $ \port -> property $
319− \(user :: User) -> do
320− jwt <- createJWT theKey (newJWSHeader ((), HS256))
321− (claims (toJSON user) & claimAud .~ Just (Audience ["boo"]))
322− opts <- addJwtToHeader (jwt >>= (return . encodeCompact))
323− getWith opts (url port) `shouldHTTPErrorWith` status401
324−
325− it "succeeds if 'aud' does match predicate" $ \port -> property $
326− \(user :: User) -> do
327− jwt <- createJWT theKey (newJWSHeader ((), HS256))
328− (claims (toJSON user) & claimAud .~ Just (Audience ["anythingElse"]))
329− opts <- addJwtToHeader (jwt >>= (return . encodeCompact))
330− resp <- getWith opts (url port)
331− resp ^. responseStatus `shouldBe` status200
332−
333− it "fails if 'nbf' is set to a future date" $ \port -> property $
334− \(user :: User) -> do
335− jwt <- createJWT theKey (newJWSHeader ((), HS256))
336− (claims (toJSON user) & claimNbf .~ Just (NumericDate future))
337− opts <- addJwtToHeader (jwt >>= (return . encodeCompact))
338− getWith opts (url port) `shouldHTTPErrorWith` status401
339−
340− it "fails if 'exp' is set to a past date" $ \port -> property $
341− \(user :: User) -> do
342− jwt <- makeJWT user jwtCfg (Just past)
343− opts <- addJwtToHeader jwt
344− getWith opts (url port) `shouldHTTPErrorWith` status401
345−
346− it "succeeds if 'exp' is set to a future date" $ \port -> property $
347− \(user :: User) -> do
348− jwt <- makeJWT user jwtCfg (Just future)
349− opts <- addJwtToHeader jwt
350− resp <- getWith opts (url port)
351− resp ^. responseStatus `shouldBe` status200
352−
353− it "fails if JWT is not signed" $ \port -> property $ \(user :: User) -> do
354− jwt <- createJWT theKey (newJWSHeader ((), None))
355− (claims $ toJSON user)
356− opts <- addJwtToHeader (jwt >>= (return . encodeCompact))
357− getWith opts (url port) `shouldHTTPErrorWith` status401
358−
359− it "fails if JWT does not use expected algorithm" $ const $
360− pendingWith "Need https://github.com/frasertweedale/hs-jose/issues/19"
361−
362− it "fails if data is not valid JSON" $ \port -> do
363− jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims "{{")
364− opts <- addJwtToHeader (jwt >>= (return .encodeCompact))
365− getWith opts (url port) `shouldHTTPErrorWith` status401
366−
367− it "suceeds as wreq's oauth2Bearer" $ \port -> property $ \(user :: User) -> do
368− jwt <- createJWT theKey (newJWSHeader ((), HS256))
369− (claims $ toJSON user)
370− resp <- case jwt >>= (return . encodeCompact) of
371− Left (e :: Error) -> fail $ show e
372− Right v -> getWith (defaults & auth ?~ oauth2Bearer (BSL.toStrict v)) (url port)
373− resp ^. responseStatus `shouldBe` status200
374−
375−-- }}}
376−------------------------------------------------------------------------------
377−-- * Basic Auth {{{
378−
379−basicAuthSpec :: Spec
380−basicAuthSpec = describe "The BasicAuth combinator"
381− $ around (testWithApplication . return $ app basicAuthApi) $ do
382−
383− it "succeeds with the correct password and username" $ \port -> do
384− resp <- getWith (defaults & auth ?~ basicAuth "ali" "Open sesame") (url port)
385− resp ^. responseStatus `shouldBe` status200
386−
387− it "fails with non-existent user" $ \port -> do
388− getWith (defaults & auth ?~ basicAuth "thief" "Open sesame") (url port)
389− `shouldHTTPErrorWith` status401
390−
391− it "fails with incorrect password" $ \port -> do
392− getWith (defaults & auth ?~ basicAuth "ali" "phatic") (url port)
393− `shouldHTTPErrorWith` status401
394−
395− it "fails with no auth header" $ \port -> do
396− get (url port) `shouldHTTPErrorWith` status401
397−
398−-- }}}
399−------------------------------------------------------------------------------
400−-- * ThrowAll {{{
401−
402−throwAllSpec :: Spec
403−throwAllSpec = describe "throwAll" $ do
404−
405− it "works for plain values" $ do
406− let t :: Either ServerError Int :<|> Either ServerError Bool :<|> Either ServerError String
407− t = throwAll err401
408− t `shouldBe` throwError err401 :<|> throwError err401 :<|> throwError err401
409−
410− it "works for function types" $ property $ \i -> do
411− let t :: Int -> (Either ServerError Bool :<|> Either ServerError String)
412− t = throwAll err401
413− expected _ = throwError err401 :<|> throwError err401
414− t i `shouldBe` expected i
415−
416−-- }}}
417−------------------------------------------------------------------------------
418−-- * API and Server {{{
419−
420−type API auths
421− = Auth auths User :>
422− ( Get '[JSON] Int
423− :<|> ReqBody '[JSON] Int :> Post '[JSON] Int
424− :<|> "named" :> NamedRoutes DummyRoutes
425− :<|> "header" :> Get '[JSON] (Headers '[Header "Blah" Int] Int)
426−#if MIN_VERSION_servant_server(0,15,0)
427− :<|> "stream" :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString)
428−#endif
429− :<|> "raw" :> Raw
430− )
431− :<|> "uverb" :> Auth auths User :> UVerb 'GET '[JSON] '[WithStatus 200 Int, WithStatus 401 Text, WithStatus 403 Text]
432− :<|> "login" :> ReqBody '[JSON] User :> Post '[JSON] (Headers '[ Header "Set-Cookie" SetCookie
433− , Header "Set-Cookie" SetCookie ] NoContent)
434− :<|> "logout" :> Get '[JSON] (Headers '[ Header "Set-Cookie" SetCookie
435− , Header "Set-Cookie" SetCookie ] NoContent)
436−
437−data DummyRoutes mode = DummyRoutes
438− { dummyInt :: mode :- "dummy" :> Get '[JSON] Int
439− } deriving Generic
440−
441−jwtOnlyApi :: Proxy (API '[Servant.Auth.Server.JWT])
442−jwtOnlyApi = Proxy
443−
444−cookieOnlyApi :: Proxy (API '[Cookie])
445−cookieOnlyApi = Proxy
446−
447−basicAuthApi :: Proxy (API '[BasicAuth])
448−basicAuthApi = Proxy
449−
450−jwtAndCookieApi :: Proxy (API '[Servant.Auth.Server.JWT, Cookie])
451−jwtAndCookieApi = Proxy
452−
453−theKey :: JWK
454−theKey = unsafePerformIO . genJWK $ OctGenParam 256
455−{-# NOINLINE theKey #-}
456−
457−
458−cookieCfg :: CookieSettings
459−cookieCfg = def
460− { cookieExpires = Just future
461− , cookieIsSecure = NotSecure
462− , sessionCookieName = "RuncibleSpoon"
463− , cookieXsrfSetting = pure $ def
464− { xsrfCookieName = "TheyDinedOnMince"
465− , xsrfHeaderName = "AndSlicesOfQuince"
466− }
467− }
468−xsrfField :: (XsrfCookieSettings -> a) -> CookieSettings -> a
469−xsrfField f = maybe (error "expected XsrfCookieSettings for test") f . cookieXsrfSetting
470−
471−jwtCfg :: JWTSettings
472−jwtCfg = (defaultJWTSettings theKey) { audienceMatches = \x ->
473− if x == "boo" then DoesNotMatch else Matches }
474−
475−instance FromBasicAuthData User where
476− fromBasicAuthData (BasicAuthData usr pwd) _
477− = return $ if usr == "ali" && pwd == "Open sesame"
478− then Authenticated $ User "ali" "ali@the-thieves-den.com"
479− else Indefinite
480−
481−-- Could be anything, really, but since this is already in the cfg we don't
482−-- have to add it
483−type instance BasicAuthCfg = JWK
484−
485−appWithCookie :: AreAuths auths '[CookieSettings, JWTSettings, JWK] User
486− => Proxy (API auths) -> CookieSettings -> Application
487−appWithCookie api ccfg = serveWithContext api ctx $ server ccfg
488− where
489− ctx = ccfg :. jwtCfg :. theKey :. EmptyContext
490−
491−-- | Takes a proxy parameter indicating which authentication systems to enable.
492−app :: AreAuths auths '[CookieSettings, JWTSettings, JWK] User
493− => Proxy (API auths) -> Application
494−app api = appWithCookie api cookieCfg
495−
496−server :: CookieSettings -> Server (API auths)
497−server ccfg =
498− (\authResult -> case authResult of
499− Authenticated usr -> getInt usr
500− :<|> postInt usr
501− :<|> DummyRoutes { dummyInt = getInt usr }
502− :<|> getHeaderInt
503−#if MIN_VERSION_servant_server(0,15,0)
504− :<|> return (S.source ["bytestring"])
505−#endif
506− :<|> raw
507− Indefinite -> throwAll err401
508− _ -> throwAll err403
509− ) :<|>
510− (\authResult -> case authResult of
511− Authenticated usr -> respond (WithStatus @200 (42 :: Int))
512− Indefinite -> respond (WithStatus @401 $ pack "Authentication required")
513− _ -> respond (WithStatus @403 $ pack "Forbidden")
514− )
515− :<|> getLogin
516− :<|> getLogout
517− where
518− getInt :: User -> Handler Int
519− getInt usr = return . length $ name usr
520−
521− postInt :: User -> Int -> Handler Int
522− postInt _ = return
523−
524− getHeaderInt :: Handler (Headers '[Header "Blah" Int] Int)
525− getHeaderInt = return $ addHeader 1797 17
526−
527− getLogin :: User -> Handler (Headers '[ Header "Set-Cookie" SetCookie
528− , Header "Set-Cookie" SetCookie ] NoContent)
529− getLogin user = do
530− maybeApplyCookies <- liftIO $ acceptLogin ccfg jwtCfg user
531− case maybeApplyCookies of
532− Just applyCookies -> return $ applyCookies NoContent
533− Nothing -> error "cookies failed to apply"
534−
535− getLogout :: Handler (Headers '[ Header "Set-Cookie" SetCookie
536− , Header "Set-Cookie" SetCookie ] NoContent)
537− getLogout = return $ clearSession ccfg NoContent
538−
539− raw :: Server Raw
540− raw =
541−#if MIN_VERSION_servant_server(0,11,0)
542− Tagged $
543−#endif
544− \_req respond ->
545− respond $ responseLBS status200 [("hi", "there")] "how are you?"
546−
547−-- }}}
548−------------------------------------------------------------------------------
549−-- * Utils {{{
550−
551−past :: UTCTime
552−past = parseTimeOrError True defaultTimeLocale "%Y-%m-%d" "1970-01-01"
553−
554−future :: UTCTime
555−future = parseTimeOrError True defaultTimeLocale "%Y-%m-%d" "2070-01-01"
556−
557−addJwtToHeader :: Either Error BSL.ByteString -> IO Options
558−addJwtToHeader jwt = case jwt of
559− Left e -> fail $ show e
560− Right v -> return
561− $ defaults & header "Authorization" .~ ["Bearer " <> BSL.toStrict v]
562−
563−createJWT :: JWK -> JWSHeader () -> ClaimsSet -> IO (Either Error Crypto.JWT.SignedJWT)
564−createJWT k a b = runJOSE $ signClaims k a b
565−
566−addJwtToCookie :: ToCompact a => CookieSettings -> Either Error a -> IO Options
567−addJwtToCookie ccfg jwt = case jwt >>= (return . encodeCompact) of
568− Left e -> fail $ show e
569− Right v -> return
570− $ defaults & header "Cookie" .~ [sessionCookieName ccfg <> "=" <> BSL.toStrict v]
571−
572−addCookie :: Options -> BS.ByteString -> Options
573−addCookie opts cookie' = opts & header "Cookie" %~ \c -> case c of
574− [h] -> [cookie' <> "; " <> h]
575− [] -> [cookie']
576− _ -> error "expecting single cookie header"
577−
578−
579−shouldHTTPErrorWith :: IO a -> Status -> Expectation
580−shouldHTTPErrorWith act stat = act `shouldThrow` \e -> case e of
581−#if MIN_VERSION_http_client(0,5,0)
582− HCli.HttpExceptionRequest _ (HCli.StatusCodeException resp _)
583− -> HCli.responseStatus resp == stat
584−#else
585− HCli.StatusCodeException x _ _ -> x == stat
586−#endif
587− _ -> False
588−
589−shouldMatchCookieNames :: HCli.CookieJar -> [BS.ByteString] -> Expectation
590−shouldMatchCookieNames cj patterns
591− = fmap cookie_name (destroyCookieJar cj)
592− `shouldMatchList` patterns
593−
594−shouldNotHaveCookies :: HCli.CookieJar -> [BS.ByteString] -> Expectation
595−shouldNotHaveCookies cj patterns =
596− sequence_ $ (\cookieName -> cookieNames `shouldNotContain` [cookieName]) <$> patterns
597− where cookieNames :: [BS.ByteString]
598− cookieNames = cookie_name <$> destroyCookieJar cj
599−
600−shouldMatchCookieNameValues :: HCli.CookieJar -> [(BS.ByteString, BS.ByteString)] -> Expectation
601−shouldMatchCookieNameValues cj patterns
602− = fmap ((,) <$> cookie_name <*> cookie_value) (destroyCookieJar cj)
603− `shouldMatchList` patterns
604−
605−url :: Int -> String
606−url port = "http://localhost:" <> show port
607−
608−claims :: Value -> ClaimsSet
609−claims val = emptyClaimsSet & unregisteredClaims . at "dat" .~ Just val
610−-- }}}
611−------------------------------------------------------------------------------
612−-- * Types {{{
613−
614−data User = User
615− { name :: String
616− , _id :: String
617− } deriving (Eq, Show, Read, Generic)
618−
619−instance FromJWT User
620−instance ToJWT User
621−instance FromJSON User
622−instance ToJSON User
623−
624−instance Arbitrary User where
625− arbitrary = User <$> arbitrary <*> arbitrary
626−
627−instance Postable User where
628− postPayload user request = return $ request
629− { HCli.requestBody = HCli.RequestBodyLBS $ encode user
630− , HCli.requestHeaders = (mk "Content-Type", "application/json") : HCli.requestHeaders request
631− }
632−
633−
634−-- }}}
servant-auth/servant-auth-server/test/Spec.hsdeleted−1
@@ -1 +0,0 @@
1−{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
servant-auth/servant-auth-swagger/.ghcideleted−1
@@ -1 +0,0 @@
1−:set -isrc -itest -idoctest/ghci-wrapper/src
servant-auth/servant-auth-swagger/CHANGELOG.mddeleted−24
@@ -1,24 +0,0 @@
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/LICENSEdeleted−31
@@ -1,31 +0,0 @@
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.hsdeleted−2
@@ -1,2 +0,0 @@
1−import Distribution.Simple
2−main = defaultMain
servant-auth/servant-auth-swagger/servant-auth-swagger.cabaldeleted−70
@@ -1,70 +0,0 @@
1−cabal-version: 2.2
2−name: servant-auth-swagger
3−version: 0.2.10.1
4−synopsis: servant-swagger/servant-auth compatibility
5−description: This package provides instances that allow generating swagger2 schemas from
6− <https://hackage.haskell.org/package/servant servant>
7− APIs that use
8− <https://hackage.haskell.org/package/servant-auth servant-auth's> @Auth@ combinator.
9− .
10− For a quick overview of the usage, see the <https://github.com/haskell-servant/servant/tree/master/servant-auth#readme README>.
11−category: Web, Servant, Authentication
12−homepage: https://github.com/haskell-servant/servant/tree/master/servant-auth#readme
13−bug-reports: https://github.com/haskell-servant/servant/issues
14−author: Julian K. Arni
15−maintainer: jkarni@gmail.com
16−copyright: (c) Julian K. Arni
17−license: BSD-3-Clause
18−license-file: LICENSE
19−tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4
20−build-type: Simple
21−extra-source-files:
22− CHANGELOG.md
23−
24−source-repository head
25− type: git
26− location: https://github.com/haskell-servant/servant
27−
28−library
29− hs-source-dirs:
30− src
31− default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
32− ghc-options: -Wall
33− build-depends:
34− base >= 4.10 && < 4.18
35− , text >= 1.2.3.0 && < 2.1
36− , servant-swagger >= 1.1.5 && < 2
37− , swagger2 >= 2.2.2 && < 3
38− , servant >= 0.13 && < 0.20
39− , servant-auth == 0.4.*
40− , lens >= 4.16.1 && < 5.3
41− exposed-modules:
42− Servant.Auth.Swagger
43− default-language: Haskell2010
44−
45−test-suite spec
46− type: exitcode-stdio-1.0
47− main-is: Spec.hs
48− hs-source-dirs:
49− test
50− default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
51− ghc-options: -Wall
52− build-tool-depends: hspec-discover:hspec-discover >= 2.5.5 && <2.10
53− -- dependencies with bounds inherited from the library stanza
54− build-depends:
55− base
56− , text
57− , servant-swagger
58− , swagger2
59− , servant
60− , servant-auth
61− , lens
62−
63− -- test dependencies
64− build-depends:
65− servant-auth-swagger
66− , hspec >= 2.5.5 && < 2.10
67− , QuickCheck >= 2.11.3 && < 2.15
68− other-modules:
69− Servant.Auth.SwaggerSpec
70− default-language: Haskell2010
servant-auth/servant-auth-swagger/src/Servant/Auth/Swagger.hsdeleted−87
@@ -1,87 +0,0 @@
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.hsdeleted−38
@@ -1,38 +0,0 @@
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.hsdeleted−1
@@ -1 +0,0 @@
1−{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
servant-auth/servant-auth/.ghcideleted−1
@@ -1 +0,0 @@
1−:set -isrc -itest -idoctest/ghci-wrapper/src
servant-auth/servant-auth/CHANGELOG.mddeleted−20
@@ -1,20 +0,0 @@
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/LICENSEdeleted−31
@@ -1,31 +0,0 @@
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.hsdeleted−2
@@ -1,2 +0,0 @@
1−import Distribution.Simple
2−main = defaultMain
servant-auth/servant-auth/servant-auth.cabaldeleted−47
@@ -1,47 +0,0 @@
1−cabal-version: 2.2
2−name: servant-auth
3−version: 0.4.1.0
4−synopsis: Authentication combinators for servant
5−description: This package provides an @Auth@ combinator for 'servant'. This combinator
6− allows using different authentication schemes in a straightforward way,
7− and possibly in conjunction with one another.
8− .
9− 'servant-auth' additionally provides concrete authentication schemes, such
10− as Basic Access Authentication, JSON Web Tokens, and Cookies.
11− .
12− For more details on how to use this, see the <https://github.com/haskell-servant/servant/tree/master/servant-auth#readme README>.
13−category: Web, Servant, Authentication
14−homepage: https://github.com/haskell-servant/servant/tree/master/servant-auth#readme
15−bug-reports: https://github.com/haskell-servant/servant/issues
16−author: Julian K. Arni
17−maintainer: jkarni@gmail.com
18−copyright: (c) Julian K. Arni
19−license: BSD-3-Clause
20−license-file: LICENSE
21−tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1
22−build-type: Simple
23−extra-source-files:
24− CHANGELOG.md
25−
26−source-repository head
27− type: git
28− location: https://github.com/haskell-servant/servant
29−
30−library
31− hs-source-dirs:
32− src
33− default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
34− ghc-options: -Wall
35− build-depends:
36− base >= 4.10 && < 4.18
37− , containers >= 0.6 && < 0.7
38− , aeson >= 1.3.1.1 && < 3
39− , jose >= 0.10 && < 0.11
40− , lens >= 4.16.1 && < 5.3
41− , servant >= 0.15 && < 0.20
42− , text >= 1.2.3.0 && < 2.1
43− , unordered-containers >= 0.2.9.0 && < 0.3
44− exposed-modules:
45− Servant.Auth
46− Servant.Auth.JWT
47− default-language: Haskell2010
servant-auth/servant-auth/src/Servant/Auth.hsdeleted−54
@@ -1,54 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4−{-# LANGUAGE TypeFamilies #-}
5−{-# LANGUAGE TypeOperators #-}
6−module Servant.Auth where
7−
8−import Data.Proxy (Proxy(..))
9−import Servant.API ((:>))
10−import Servant.Links (HasLink (..))
11−
12−-- * Authentication
13−
14−-- | @Auth [auth1, auth2] val :> api@ represents an API protected *either* by
15−-- @auth1@ or @auth2@
16−data Auth (auths :: [*]) val
17−
18−-- | A @HasLink@ instance for @Auth@
19−instance HasLink sub => HasLink (Auth (tag :: [*]) value :> sub) where
20−#if MIN_VERSION_servant(0,14,0)
21− type MkLink (Auth (tag :: [*]) value :> sub) a = MkLink sub a
22− toLink toA _ = toLink toA (Proxy :: Proxy sub)
23−#else
24− type MkLink (Auth (tag :: [*]) value :> sub) = MkLink sub
25− toLink _ = toLink (Proxy :: Proxy sub)
26−#endif
27−
28−-- ** Combinators
29−
30−-- | A JSON Web Token (JWT) in the Authorization header:
31−--
32−-- @Authorization: Bearer \<token\>@
33−--
34−-- Note that while the token is signed, it is not encrypted. Therefore do not
35−-- keep in it any information you would not like the client to know.
36−--
37−-- JWTs are described in IETF's <https://tools.ietf.org/html/rfc7519 RFC 7519>
38−data JWT
39−
40−-- | A cookie. The content cookie itself is a JWT. Another cookie is also used,
41−-- the contents of which are expected to be send back to the server in a
42−-- header, for XSRF protection.
43−data Cookie
44−
45−
46−-- We could use 'servant''s BasicAuth, but then we don't get control over the
47−-- documentation, and we'd have to polykind everything. (Also, we don't
48−-- currently depend on servant!)
49−--
50−-- | Basic Auth.
51−data BasicAuth
52−
53−-- | Login via a form.
54−data FormLogin form
servant-auth/servant-auth/src/Servant/Auth/JWT.hsdeleted−40
@@ -1,40 +0,0 @@
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.hsdeleted−1
@@ -1 +0,0 @@
1−{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
servant-client-core/CHANGELOG.md+2−234
@@ -1,238 +1,6 @@
11[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-client-core/CHANGELOG.md)
22[Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)
33
4−Package versions follow the [Package Versioning Policy](https://pvp.haskell.org/): in A.B.C, bumps to either A or B represent major versions.
5−
6−0.19
7−----
8−
9−### Significant changes
10−
11−- Drop support for GHC < 8.6.
12−- Support GHC 9.0 (GHC 9.2 should work as well, but isn't fully tested yet).
13−- Support Aeson 2 ([#1475](https://github.com/haskell-servant/servant/pull/1475)),
14− which fixes a [DOS vulnerability](https://github.com/haskell/aeson/issues/864)
15− related to hash collisions.
16−- Add `NamedRoutes` combinator, making support for records first-class in Servant
17− ([#1388](https://github.com/haskell-servant/servant/pull/1388)).
18−- Add custom type errors for partially applied combinators
19− ([#1289](https://github.com/haskell-servant/servant/pull/1289),
20− [#1486](https://github.com/haskell-servant/servant/pull/1486)).
21−- *servant-client* / *servant-client-core* / *servant-http-streams*: Fix
22− erroneous behavior, where only 2XX status codes would be considered
23− successful, irrelevant of the status parameter specified by the verb
24− combinator. ([#1469](https://github.com/haskell-servant/servant/pull/1469))
25−- *servant-client* / *servant-client-core*: Fix `Show` instance for
26− `Servant.Client.Core.Request`.
27−- *servant-client* / *servant-client-core*: Allow passing arbitrary binary data
28− in Query parameters.
29− ([#1432](https://github.com/haskell-servant/servant/pull/1432)).
30−
31−### Other changes
32−
33−- Various version bumps.
34−
35−0.18.3
36−------
37−
38−### Significant changes
39−
40−- Add response header support to UVerb (#1420)
41−
42−### Other changes
43−
44−- Support GHC-9.0.1.
45−- Bump `bytestring`, `hspec`, `base64-bytestring` and `QuickCheck` dependencies.
46−
47−0.18.2
48−------
49−
50−### Significant changes
51−
52−- Support `Fragment` combinator.
53−
54−0.18.1
55−------
56−
57−### Significant changes
58−
59−- Union verbs
60−
61−### Other changes
62−
63−- Bump "tested-with" ghc versions
64−- Loosen bound on base16-bytestring
65−
66−0.18
67−----
68−
69−### Significant changes
70−
71−- Support for ghc8.8 (#1318, #1326, #1327)
72−
73−
74−0.17
75−----
76−
77−### Significant changes
78−
79−- Add NoContentVerb [#1028](https://github.com/haskell-servant/servant/issues/1028) [#1219](https://github.com/haskell-servant/servant/pull/1219) [#1228](https://github.com/haskell-servant/servant/pull/1228)
80−
81− The `NoContent` API endpoints should now use `NoContentVerb` combinator.
82− The API type changes are usually of the kind
83−
84− ```diff
85− - :<|> PostNoContent '[JSON] NoContent
86− + :<|> PostNoContent
87− ```
88−
89− i.e. one doesn't need to specify the content-type anymore. There is no content.
90−
91−- `Capture` can be `Lenient` [#1155](https://github.com/haskell-servant/servant/issues/1155) [#1156](https://github.com/haskell-servant/servant/pull/1156)
92−
93− You can specify a lenient capture as
94−
95− ```haskell
96− :<|> "capture-lenient" :> Capture' '[Lenient] "foo" Int :> GET
97− ```
98−
99− which will make the capture always succeed. Handlers will be of the
100− type `Either String CapturedType`, where `Left err` represents
101− the possible parse failure.
102−
103−### Other changes
104−
105−- *servant-client* *servant-client-core* *servant-http-streams* Fix Verb with headers checking content type differently [#1200](https://github.com/haskell-servant/servant/issues/1200) [#1204](https://github.com/haskell-servant/servant/pull/1204)
106−
107− For `Verb`s with response `Headers`, the implementation didn't check
108− for the content-type of the response. Now it does.
109−
110−- *servant-client* *servant-http-streams* `HasClient` instance for `Stream` with `Headers` [#1170](https://github.com/haskell-servant/servant/issues/1170) [#1197](https://github.com/haskell-servant/servant/pull/1197)
111−- *servant-client* Redact the authorization header in Show and exceptions [#1238](https://github.com/haskell-servant/servant/pull/1238)
112−
113−0.16
114−----
115−
116−- Rename `ServantError` to `ClientError`, `ServantErr` to `ServerError`
117− [#1131](https://github.com/haskell-servant/servant/pull/1131)
118−
119−- *servant-client-core* Rearrange modules. No more `Internal` modules, whole
120− API is versioned.
121− [#1130](https://github.com/haskell-servant/servant/pull/1130)
122−
123−- *servant-client-core* `RequestBody` is now
124−
125− ```haskell
126− = RequestBodyLBS LBS.ByteString
127− | RequestBodyBS BS.ByteString
128− | RequestBodySource (SourceIO LBS.ByteString)
129− ```
130−
131− i.e. no more replicates `http-client`s API.
132− [#1117](https://github.com/haskell-servant/servant/pull/1117)
133−
134−- *servant-client-core* Keep structured exceptions in `ConnectionError`
135− constructor of `ClientError`
136− [#1115](https://github.com/haskell-servant/servant/pull/1115)
137−
138− ```diff
139− -| ConnectionError Text
140− +| ConnectionError SomeException
141− ```
142−
143−- *servant-client-core* Preserve failing request in `FailureResponse`
144− constructor of `ClientError`
145− [#1114](https://github.com/haskell-servant/servant/pull/1114)
146−
147− ```diff
148− -FailureResponse Response
149− +-- | The server returned an error response including the
150− +-- failing request. 'requestPath' includes the 'BaseUrl' and the
151− +-- path of the request.
152− +FailureResponse (RequestF () (BaseUrl, BS.ByteString)) Response
153− ```
154−
155−- *servant-client* Fix (implement) `StreamBody` instance
156− [#1110](https://github.com/haskell-servant/servant/pull/1110)
157−
158−- *servant-client* Update CookieJar with intermediate request/responses (redirects)
159− [#1104](https://github.com/haskell-servant/servant/pull/1104)
160−
161−0.15
162−----
163−
164−- Streaming refactoring.
165− [#991](https://github.com/haskell-servant/servant/pull/991)
166− [#1076](https://github.com/haskell-servant/servant/pull/1076)
167− [#1077](https://github.com/haskell-servant/servant/pull/1077)
168−
169− The streaming functionality (`Servant.API.Stream`) is refactored to use
170− `servant`'s own `SourceIO` type (see `Servant.Types.SourceT` documentation),
171− which replaces both `StreamGenerator` and `ResultStream` types.
172−
173− New conversion type-classes are `ToSourceIO` and `FromSourceIO`
174− (replacing `ToStreamGenerator` and `BuildFromStream`).
175− There are instances for *conduit*, *pipes* and *machines* in new packages:
176− [servant-conduit](https://hackage.haskell.org/package/servant-conduit)
177− [servant-pipes](https://hackage.haskell.org/package/servant-pipes) and
178− [servant-machines](https://hackage.haskell.org/package/servant-machines)
179− respectively.
180−
181− Writing new framing strategies is simpler. Check existing strategies for examples.
182−
183− This change shouldn't affect you, if you don't use streaming endpoints.
184−
185−- *servant-client* Separate streaming client.
186− [#1066](https://github.com/haskell-servant/servant/pull/1066)
187−
188− We now have two `http-client` based clients,
189− in `Servant.Client` and `Servant.Client.Streaming`.
190−
191− Their API is the same, except for
192− - `Servant.Client` **cannot** request `Stream` endpoints.
193− - `Servant.Client` is *run* by direct
194− `runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a)`
195− - `Servant.Client.Streaming` **can** request `Stream` endpoints.
196− - `Servant.Client.Streaming` is *used* by CPSised
197− `withClientM :: ClientM a -> ClientEnv -> (Either ServantError a -> IO b) -> IO b`
198−
199− To access `Stream` endpoints use `Servant.Client.Streaming` with
200− `withClientM`; otherwise you can continue using `Servant.Client` with `runClientM`.
201− You can use both too, `ClientEnv` and `BaseUrl` types are same for both.
202−
203− **Note:** `Servant.Client.Streaming` doesn't *stream* non-`Stream` endpoints.
204− Requesting ordinary `Verb` endpoints (e.g. `Get`) will block until
205− the whole response is received.
206−
207− There is `Servant.Client.Streaming.runClientM` function, but it has
208− restricted type. `NFData a` constraint prevents using it with
209− `SourceT`, `Conduit` etc. response types.
210−
211− ```haskell
212− runClientM :: NFData a => ClientM a -> ClientEnv -> IO (Either ServantError a)
213− ```
214−
215− This change shouldn't affect you, if you don't use streaming endpoints.
216−
217−- *servant-client-core* Related to the previous:
218− `streamingResponse` is removed from `RunClient`.
219− We have a new type-class:
220−
221− ```haskell
222− class RunClient m => RunStreamingClient m where
223− withStreamingRequest :: Request -> (StreamingResponse -> IO a) -> m a
224− ```
225−
226−- Drop support for GHC older than 8.0
227− [#1008](https://github.com/haskell-servant/servant/pull/1008)
228− [#1009](https://github.com/haskell-servant/servant/pull/1009)
229−
230−- *servant-client-core* Add `NFData (GenResponse a)` and `NFData ServantError` instances.
231− [#1076](https://github.com/haskell-servant/servant/pull/1076)
232−
233−- *servant-client-core* Add `aeson` and `Lift BaseUrl` instances
234− [#1037](https://github.com/haskell-servant/servant/pull/1037)
235−
23640.14.1
2375------
2386
@@ -275,9 +43,9 @@ Package versions follow the [Package Versioning Policy](https://pvp.haskell.org/
27543
27644- *servant-client-core* Add `hoistClient` to `HasClient`.
27745 Just like `hoistServer` allows us to change the monad in which request handlers
278− of a web application live, we also have `hoistClient` for changing the monad
46+ of a web application live in, we also have `hoistClient` for changing the monad
27947 in which *client functions* live.
280− Read [tutorial section for more information](https://docs.servant.dev/en/release-0.14/tutorial/Client.html#changing-the-monad-the-client-functions-live-in).
48+ Read [tutorial section for more information](https://haskell-servant.readthedocs.io/en/release-0.14/tutorial/Client.html#changing-the-monad-the-client-functions-live-in).
28149 ([#936](https://github.com/haskell-servant/servant/pull/936))
28250
28351 iF you have own combinators, you'll need to define a new method of
servant-client-core/LICENSE+1−1
@@ -1,4 +1,4 @@
1−Copyright (c) 2017-2018, Servant Contributors
1+Copyright (c) 2017, Servant Contributors
22
33All rights reserved.
44
servant-client-core/servant-client-core.cabal+39−48
@@ -1,27 +1,27 @@
1−cabal-version: 2.2
21name: servant-client-core
3−version: 0.19
4−
2+version: 0.14.1
53synopsis: Core functionality and class for client function generation for servant APIs
6−category: Servant, Web
74description:
85 This library provides backend-agnostic generation of client functions. For
96 more information, see the README.
10−
11−homepage: http://docs.servant.dev/
12−bug-reports: http://github.com/haskell-servant/servant/issues
13−license: BSD-3-Clause
7+license: BSD3
148license-file: LICENSE
159author: Servant Contributors
1610maintainer: haskell-servant-maintainers@googlegroups.com
17−copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors
11+homepage: http://haskell-servant.readthedocs.org/
12+bug-reports: http://github.com/haskell-servant/servant/issues
13+cabal-version: >=1.10
14+copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2017 Servant Contributors
15+category: Web
1816build-type: Simple
19−tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1
20− , GHCJS ==8.6.0.1
21−
2217extra-source-files:
2318 CHANGELOG.md
2419 README.md
20+tested-with:
21+ GHC==8.0.2
22+ GHC==8.2.2
23+ GHC==8.4.4
24+ GHC==8.6.1
2525
2626source-repository head
2727 type: git
@@ -33,53 +33,45 @@ library
3333 Servant.Client.Free
3434 Servant.Client.Generic
3535 Servant.Client.Core.Reexport
36− Servant.Client.Core.Auth
37− Servant.Client.Core.BaseUrl
38− Servant.Client.Core.BasicAuth
39− Servant.Client.Core.ClientError
40− Servant.Client.Core.HasClient
41− Servant.Client.Core.Request
42− Servant.Client.Core.Response
43− Servant.Client.Core.RunClient
44−
45− other-modules:
46− Servant.Client.Core.Internal
36+ Servant.Client.Core.Internal.Auth
37+ Servant.Client.Core.Internal.BaseUrl
38+ Servant.Client.Core.Internal.BasicAuth
39+ Servant.Client.Core.Internal.ClientF
40+ Servant.Client.Core.Internal.Generic
41+ Servant.Client.Core.Internal.HasClient
42+ Servant.Client.Core.Internal.Request
43+ Servant.Client.Core.Internal.RunClient
4744
4845 -- Bundled with GHC: Lower bound to not force re-installs
4946 -- text and mtl are bundled starting with GHC-8.4
5047 --
5148 -- note: mtl lower bound is so low because of GHC-7.8
5249 build-depends:
53− base >= 4.9 && < 4.18
54− , bytestring >= 0.10.8.1 && < 0.12
55− , constraints >= 0.2 && < 0.14
50+ base >= 4.9 && < 4.13
51+ , bytestring >= 0.10.8.1 && < 0.11
5652 , containers >= 0.5.7.1 && < 0.7
57− , deepseq >= 1.4.2.0 && < 1.5
58− , text >= 1.2.3.0 && < 2.1
59− , transformers >= 0.5.2.0 && < 0.7
60− , template-haskell >= 2.11.1.0 && < 2.20
61−
62− if !impl(ghc >= 8.2)
63− build-depends:
64− bifunctors >= 5.5.3 && < 5.6
53+ , text >= 1.2.3.0 && < 1.3
54+ , transformers >= 0.5.2.0 && < 0.6
55+ , template-haskell >= 2.11.1.0 && < 2.15
6556
6657 -- Servant dependencies
6758 build-depends:
68− servant >= 0.19
59+ servant >= 0.14.1 && <0.15
6960
7061 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.
7162 -- Here can be exceptions if we really need features from the newer versions.
7263 build-depends:
73− aeson >= 1.4.1.0 && < 3
74− , base-compat >= 0.10.5 && < 0.13
75− , base64-bytestring >= 1.0.0.1 && < 1.3
64+ aeson >= 1.4.0.0 && < 1.5
65+ , base-compat >= 0.10.1 && < 0.11
66+ , base64-bytestring >= 1.0.0.1 && < 1.1
7667 , exceptions >= 0.10.0 && < 0.11
77− , free >= 5.1 && < 5.2
78− , http-media >= 0.7.1.3 && < 0.9
79− , http-types >= 0.12.2 && < 0.13
68+ , free >= 5.0.2 && < 5.2
69+ , generics-sop >= 0.4.0.1 && < 0.5
70+ , http-api-data >= 0.3.8.1 && < 0.4
71+ , http-media >= 0.7.1.2 && < 0.8
72+ , http-types >= 0.12.1 && < 0.13
8073 , network-uri >= 2.6.1.0 && < 2.7
8174 , safe >= 0.3.17 && < 0.4
82− , sop-core >= 0.4.0.0 && < 0.6
8375
8476 hs-source-dirs: src
8577 default-language: Haskell2010
@@ -93,7 +85,6 @@ test-suite spec
9385 main-is: Spec.hs
9486 other-modules:
9587 Servant.Client.Core.Internal.BaseUrlSpec
96− Servant.Client.Core.RequestSpec
9788
9889 -- Dependencies inherited from the library. No need to specify bounds.
9990 build-depends:
@@ -101,11 +92,11 @@ test-suite spec
10192 , base-compat
10293 , servant-client-core
10394
104− -- Additional dependencies
95+ -- Additonal dependencies
10596 build-depends:
106− deepseq >= 1.4.2.0 && < 1.5
107− , hspec >= 2.6.0 && < 2.10
108− , QuickCheck >= 2.12.6.1 && < 2.15
97+ deepseq >= 1.3.0.2 && < 1.5
98+ , hspec >= 2.4.1 && < 2.6
99+ , QuickCheck >= 2.12.6.1 && < 2.13
109100
110101 build-tool-depends:
111− hspec-discover:hspec-discover >= 2.6.0 && <2.10
102+ hspec-discover:hspec-discover >= 2.5.1 && <2.6
servant-client-core/src/Servant/Client/Core.hs+16−24
@@ -18,8 +18,6 @@ module Servant.Client.Core
1818 -- * Client generation
1919 clientIn
2020 , HasClient(..)
21− , foldMapUnion
22− , matchUnion
2321
2422 -- * Request
2523 , Request
@@ -34,23 +32,19 @@ module Servant.Client.Core
3432 , AuthClientData
3533
3634 -- * Generic Client
37− , ClientError(..)
35+ , ClientLike(..)
36+ , genericMkClientL
37+ , genericMkClientP
38+ , ServantError(..)
3839 , EmptyClient(..)
3940
41+
4042 -- * Response
4143 , Response
42− , ResponseF (..)
44+ , GenResponse (..)
4345 , RunClient(..)
44− -- * BaseUrl
45− , BaseUrl (..)
46− , Scheme (..)
47− , showBaseUrl
48− , parseBaseUrl
49− , InvalidBaseUrlException (..)
50−
51− -- ** Streaming
52− , RunStreamingClient(..)
53− , StreamingResponse
46+ , module Servant.Client.Core.Internal.BaseUrl
47+ , StreamingResponse(..)
5448
5549 -- * Writing HasClient instances
5650 -- | These functions need not be re-exported by backend libraries.
@@ -59,15 +53,13 @@ module Servant.Client.Core
5953 , appendToPath
6054 , setRequestBodyLBS
6155 , setRequestBody
62− , encodeQueryParamValue
6356 ) where
64−import Servant.Client.Core.Auth
65−import Servant.Client.Core.BaseUrl
66− (BaseUrl (..), InvalidBaseUrlException (..), Scheme (..),
57+import Servant.Client.Core.Internal.Auth
58+import Servant.Client.Core.Internal.BaseUrl
59+ (BaseUrl (..), InvalidBaseUrlException, Scheme (..),
6760 parseBaseUrl, showBaseUrl)
68−import Servant.Client.Core.BasicAuth
69−import Servant.Client.Core.ClientError
70−import Servant.Client.Core.HasClient
71−import Servant.Client.Core.Request
72−import Servant.Client.Core.Response
73−import Servant.Client.Core.RunClient
61+import Servant.Client.Core.Internal.BasicAuth
62+import Servant.Client.Core.Internal.Generic
63+import Servant.Client.Core.Internal.HasClient
64+import Servant.Client.Core.Internal.Request
65+import Servant.Client.Core.Internal.RunClient
servant-client-core/src/Servant/Client/Core/ClientError.hsdeleted−86
@@ -1,86 +0,0 @@
1−{-# LANGUAGE DeriveDataTypeable #-}
2−{-# LANGUAGE DeriveFoldable #-}
3−{-# LANGUAGE DeriveFunctor #-}
4−{-# LANGUAGE DeriveGeneric #-}
5−{-# LANGUAGE DeriveTraversable #-}
6−{-# LANGUAGE MultiParamTypeClasses #-}
7−{-# LANGUAGE OverloadedStrings #-}
8−{-# LANGUAGE RankNTypes #-}
9−{-# LANGUAGE ScopedTypeVariables #-}
10−{-# LANGUAGE TypeFamilies #-}
11−module Servant.Client.Core.ClientError (
12− ClientError (..),
13− ) where
14−
15−import Prelude ()
16−import Prelude.Compat
17−
18−import Control.DeepSeq
19− (NFData (..))
20−import Control.Exception
21− (SomeException (..))
22−import Control.Monad.Catch
23− (Exception)
24−import qualified Data.ByteString as BS
25−import Data.Text
26− (Text)
27−import Data.Typeable
28− (Typeable, typeOf)
29−import GHC.Generics
30− (Generic)
31−import Network.HTTP.Media
32− (MediaType)
33−import Network.HTTP.Types ()
34−
35−import Servant.Client.Core.BaseUrl
36−import Servant.Client.Core.Internal
37− (mediaTypeRnf)
38−import Servant.Client.Core.Request
39−import Servant.Client.Core.Response
40−
41−
42−-- | A type representing possible errors in a request
43−--
44−-- Note that this type substantially changed in 0.12.
45−data ClientError =
46− -- | The server returned an error response including the
47− -- failing request. 'requestPath' includes the 'BaseUrl' and the
48− -- path of the request.
49− FailureResponse (RequestF () (BaseUrl, BS.ByteString)) Response
50− -- | The body could not be decoded at the expected type
51− | DecodeFailure Text Response
52− -- | The content-type of the response is not supported
53− | UnsupportedContentType MediaType Response
54− -- | The content-type header is invalid
55− | InvalidContentTypeHeader Response
56− -- | There was a connection error, and no response was received
57− | ConnectionError SomeException
58− deriving (Show, Generic, Typeable)
59−
60−instance Eq ClientError where
61− FailureResponse req res == FailureResponse req' res' = req == req' && res == res'
62− DecodeFailure t r == DecodeFailure t' r' = t == t' && r == r'
63− UnsupportedContentType mt r == UnsupportedContentType mt' r' = mt == mt' && r == r'
64− InvalidContentTypeHeader r == InvalidContentTypeHeader r' = r == r'
65− ConnectionError exc == ConnectionError exc' = eqSomeException exc exc'
66− where
67− -- returns true, if type of exception is the same
68− eqSomeException (SomeException a) (SomeException b) = typeOf a == typeOf b
69−
70− -- prevent wild card blindness
71− FailureResponse {} == _ = False
72− DecodeFailure {} == _ = False
73− UnsupportedContentType {} == _ = False
74− InvalidContentTypeHeader {} == _ = False
75− ConnectionError {} == _ = False
76−
77−instance Exception ClientError
78−
79−-- | Note: an exception in 'ConnectionError' might not be evaluated fully,
80−-- We only 'rnf' its 'show'ed value.
81−instance NFData ClientError where
82− rnf (FailureResponse req res) = rnf req `seq` rnf res
83− rnf (DecodeFailure err res) = rnf err `seq` rnf res
84− rnf (UnsupportedContentType mt' res) = mediaTypeRnf mt' `seq` rnf res
85− rnf (InvalidContentTypeHeader res) = rnf res
86− rnf (ConnectionError err) = err `seq` rnf (show err)
servant-client-core/src/Servant/Client/Core/Internal.hsdeleted−12
@@ -1,12 +0,0 @@
1−module Servant.Client.Core.Internal where
2−
3−import Control.DeepSeq
4− (rnf)
5−import Network.HTTP.Media
6− (MediaType, mainType, parameters, subType)
7−
8−mediaTypeRnf :: MediaType -> ()
9−mediaTypeRnf mt =
10− rnf (mainType mt) `seq`
11− rnf (subType mt) `seq`
12− rnf (parameters mt)
servant-client-core/src/Servant/Client/Core/Auth.hs → servant-client-core/src/Servant/Client/Core/Internal/Auth.hsrenamed+2−6
@@ -4,13 +4,9 @@
44
55-- | Authentication for clients
66
7−module Servant.Client.Core.Auth (
8− AuthClientData,
9− AuthenticatedRequest (..),
10− mkAuthenticatedRequest,
11− ) where
7+module Servant.Client.Core.Internal.Auth where
128
13−import Servant.Client.Core.Request
9+import Servant.Client.Core.Internal.Request
1410 (Request)
1511
1612-- | For a resource protected by authentication (e.g. AuthProtect), we need
servant-client-core/src/Servant/Client/Core/BaseUrl.hs → servant-client-core/src/Servant/Client/Core/Internal/BaseUrl.hsrenamed+1−12
@@ -2,16 +2,8 @@
22{-# LANGUAGE DeriveGeneric #-}
33{-# LANGUAGE DeriveLift #-}
44{-# LANGUAGE ViewPatterns #-}
5−module Servant.Client.Core.BaseUrl (
6− BaseUrl (..),
7− Scheme (..),
8− showBaseUrl,
9− parseBaseUrl,
10− InvalidBaseUrlException (..),
11− ) where
5+module Servant.Client.Core.Internal.BaseUrl where
126
13−import Control.DeepSeq
14− (NFData (..))
157import Control.Monad.Catch
168 (Exception, MonadThrow, throwM)
179import Data.Aeson
@@ -47,9 +39,6 @@ data BaseUrl = BaseUrl
4739 } deriving (Show, Ord, Generic, Lift, Data)
4840-- TODO: Ord is more precise than Eq
4941-- TODO: Add Hashable instance?
50−--
51−instance NFData BaseUrl where
52− rnf (BaseUrl a b c d) = a `seq` rnf b `seq` rnf c `seq` rnf d
5342
5443instance Eq BaseUrl where
5544 BaseUrl a b c path == BaseUrl a' b' c' path'
servant-client-core/src/Servant/Client/Core/BasicAuth.hs → servant-client-core/src/Servant/Client/Core/Internal/BasicAuth.hsrenamed+5−4
@@ -3,17 +3,18 @@
33{-# LANGUAGE TypeSynonymInstances #-}
44
55-- | Basic Authentication for clients
6−module Servant.Client.Core.BasicAuth (
7− basicAuthReq,
8− ) where
6+
7+module Servant.Client.Core.Internal.BasicAuth where
98
109import Data.ByteString.Base64
1110 (encode)
11+import Data.Monoid
12+ ((<>))
1213import Data.Text.Encoding
1314 (decodeUtf8)
1415import Servant.API.BasicAuth
1516 (BasicAuthData (BasicAuthData))
16−import Servant.Client.Core.Request
17+import Servant.Client.Core.Internal.Request
1718 (Request, addHeader)
1819
1920-- | Authenticate a request using Basic Authentication
servant-client-core/src/Servant/Client/Core/Internal/ClientF.hsnew file+10
@@ -0,0 +1,10 @@
1+{-# LANGUAGE DeriveFunctor #-}
2+module Servant.Client.Core.Internal.ClientF where
3+
4+import Servant.Client.Core.Internal.Request
5+
6+data ClientF a
7+ = RunRequest Request (Response -> a)
8+ | StreamingRequest Request (StreamingResponse -> a)
9+ | Throw ServantError
10+ deriving (Functor)
servant-client-core/src/Servant/Client/Core/Internal/Generic.hsnew file+155
@@ -0,0 +1,155 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE DefaultSignatures #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE TypeFamilies #-}
7+{-# LANGUAGE TypeOperators #-}
8+{-# LANGUAGE UndecidableInstances #-}
9+
10+module Servant.Client.Core.Internal.Generic where
11+
12+import Generics.SOP
13+ (Code, Generic, I (..), NP (..), NS (Z), SOP (..), to)
14+import Servant.API
15+ ((:<|>) (..))
16+
17+-- | This class allows us to match client structure with client functions
18+-- produced with 'client' without explicit pattern-matching.
19+--
20+-- The client structure needs a 'Generics.SOP.Generic' instance.
21+--
22+-- Example:
23+--
24+-- > type API
25+-- > = "foo" :> Capture "x" Int :> Get '[JSON] Int
26+-- > :<|> "bar" :> QueryParam "a" Char :> QueryParam "b" String :> Post '[JSON] [Int]
27+-- > :<|> Capture "nested" Int :> NestedAPI
28+-- >
29+-- > type NestedAPI
30+-- > = Get '[JSON] String
31+-- > :<|> "baz" :> QueryParam "c" Char :> Post '[JSON] ()
32+-- >
33+-- > data APIClient = APIClient
34+-- > { getFoo :: Int -> ClientM Int
35+-- > , postBar :: Maybe Char -> Maybe String -> ClientM [Int]
36+-- > , mkNestedClient :: Int -> NestedClient
37+-- > } deriving GHC.Generic
38+-- >
39+-- > instance Generics.SOP.Generic APIClient
40+-- > instance (Client API ~ client) => ClientLike client APIClient
41+-- >
42+-- > data NestedClient = NestedClient
43+-- > { getString :: ClientM String
44+-- > , postBaz :: Maybe Char -> ClientM ()
45+-- > } deriving GHC.Generic
46+-- >
47+-- > instance Generics.SOP.Generic NestedClient
48+-- > instance (Client NestedAPI ~ client) => ClientLike client NestedClient
49+-- >
50+-- > mkAPIClient :: APIClient
51+-- > mkAPIClient = mkClient (client (Proxy :: Proxy API))
52+--
53+-- By default, left-nested alternatives are expanded:
54+--
55+-- > type API1
56+-- > = "foo" :> Capture "x" Int :> Get '[JSON] Int
57+-- > :<|> "bar" :> QueryParam "a" Char :> Post '[JSON] String
58+-- >
59+-- > type API2
60+-- > = "baz" :> QueryParam "c" Char :> Post '[JSON] ()
61+-- >
62+-- > type API = API1 :<|> API2
63+-- >
64+-- > data APIClient = APIClient
65+-- > { getFoo :: Int -> ClientM Int
66+-- > , postBar :: Maybe Char -> ClientM String
67+-- > , postBaz :: Maybe Char -> ClientM ()
68+-- > } deriving GHC.Generic
69+-- >
70+-- > instance Generics.SOP.Generic APIClient
71+-- > instance (Client API ~ client) => ClientLike client APIClient
72+-- >
73+-- > mkAPIClient :: APIClient
74+-- > mkAPIClient = mkClient (client (Proxy :: Proxy API))
75+--
76+-- If you want to define client for @API1@ as a separate data structure,
77+-- you can use 'genericMkClientP':
78+--
79+-- > data APIClient1 = APIClient1
80+-- > { getFoo :: Int -> ClientM Int
81+-- > , postBar :: Maybe Char -> ClientM String
82+-- > } deriving GHC.Generic
83+-- >
84+-- > instance Generics.SOP.Generic APIClient1
85+-- > instance (Client API1 ~ client) => ClientLike client APIClient1
86+-- >
87+-- > data APIClient = APIClient
88+-- > { mkAPIClient1 :: APIClient1
89+-- > , postBaz :: Maybe Char -> ClientM ()
90+-- > } deriving GHC.Generic
91+-- >
92+-- > instance Generics.SOP.Generic APIClient
93+-- > instance (Client API ~ client) => ClientLike client APIClient where
94+-- > mkClient = genericMkClientP
95+-- >
96+-- > mkAPIClient :: APIClient
97+-- > mkAPIClient = mkClient (client (Proxy :: Proxy API))
98+class ClientLike client custom where
99+ mkClient :: client -> custom
100+ default mkClient :: (Generic custom, Code custom ~ '[xs], GClientList client '[], GClientLikeL (ClientList client '[]) xs)
101+ => client -> custom
102+ mkClient = genericMkClientL
103+
104+instance ClientLike client custom
105+ => ClientLike (a -> client) (a -> custom) where
106+ mkClient c = mkClient . c
107+
108+-- | Match client structure with client functions, regarding left-nested API clients
109+-- as separate data structures.
110+class GClientLikeP client xs where
111+ gMkClientP :: client -> NP I xs
112+
113+instance (GClientLikeP b (y ': xs), ClientLike a x)
114+ => GClientLikeP (a :<|> b) (x ': y ': xs) where
115+ gMkClientP (a :<|> b) = I (mkClient a) :* gMkClientP b
116+
117+instance ClientLike a x => GClientLikeP a '[x] where
118+ gMkClientP a = I (mkClient a) :* Nil
119+
120+-- | Match client structure with client functions, expanding left-nested API clients
121+-- in the same structure.
122+class GClientLikeL (xs :: [*]) (ys :: [*]) where
123+ gMkClientL :: NP I xs -> NP I ys
124+
125+instance GClientLikeL '[] '[] where
126+ gMkClientL Nil = Nil
127+
128+instance (ClientLike x y, GClientLikeL xs ys) => GClientLikeL (x ': xs) (y ': ys) where
129+ gMkClientL (I x :* xs) = I (mkClient x) :* gMkClientL xs
130+
131+type family ClientList (client :: *) (acc :: [*]) :: [*] where
132+ ClientList (a :<|> b) acc = ClientList a (ClientList b acc)
133+ ClientList a acc = a ': acc
134+
135+class GClientList client (acc :: [*]) where
136+ gClientList :: client -> NP I acc -> NP I (ClientList client acc)
137+
138+instance (GClientList b acc, GClientList a (ClientList b acc))
139+ => GClientList (a :<|> b) acc where
140+ gClientList (a :<|> b) acc = gClientList a (gClientList b acc)
141+
142+instance {-# OVERLAPPABLE #-} (ClientList client acc ~ (client ': acc))
143+ => GClientList client acc where
144+ gClientList c acc = I c :* acc
145+
146+-- | Generate client structure from client type, expanding left-nested API (done by default).
147+genericMkClientL :: (Generic custom, Code custom ~ '[xs], GClientList client '[], GClientLikeL (ClientList client '[]) xs)
148+ => client -> custom
149+genericMkClientL = to . SOP . Z . gMkClientL . flip gClientList Nil
150+
151+-- | Generate client structure from client type, regarding left-nested API clients as separate data structures.
152+genericMkClientP :: (Generic custom, Code custom ~ '[xs], GClientLikeP client xs)
153+ => client -> custom
154+genericMkClientP = to . SOP . Z . gMkClientP
155+
servant-client-core/src/Servant/Client/Core/HasClient.hs → servant-client-core/src/Servant/Client/Core/Internal/HasClient.hsrenamed+89−443
@@ -1,4 +1,3 @@
1−{-# LANGUAGE ConstraintKinds #-}
21{-# LANGUAGE DataKinds #-}
32{-# LANGUAGE FlexibleContexts #-}
43{-# LANGUAGE FlexibleInstances #-}
@@ -6,99 +5,59 @@
65{-# LANGUAGE MultiParamTypeClasses #-}
76{-# LANGUAGE OverloadedStrings #-}
87{-# LANGUAGE PolyKinds #-}
9−{-# LANGUAGE QuantifiedConstraints #-}
108{-# LANGUAGE RankNTypes #-}
119{-# LANGUAGE ScopedTypeVariables #-}
12−{-# LANGUAGE TypeApplications #-}
1310{-# LANGUAGE TypeFamilies #-}
1411{-# LANGUAGE TypeOperators #-}
1512{-# LANGUAGE UndecidableInstances #-}
1613
17−module Servant.Client.Core.HasClient (
18− clientIn,
19− HasClient (..),
20− EmptyClient (..),
21− AsClientT,
22− (//),
23− (/:),
24− foldMapUnion,
25− matchUnion,
26− ) where
14+module Servant.Client.Core.Internal.HasClient where
2715
2816import Prelude ()
2917import Prelude.Compat
3018
31−import Control.Arrow
32− (left, (+++))
33−import Control.Monad
34− (unless)
35−import qualified Data.ByteString as BS
36−import qualified Data.ByteString.Lazy as BL
37−import Data.Either
38− (partitionEithers)
39−import Data.Constraint (Dict(..))
19+import Control.Concurrent
20+ (modifyMVar, newMVar)
21+import Control.Monad.IO.Class
22+ (MonadIO (..))
23+import qualified Data.ByteString.Lazy as BL
4024import Data.Foldable
4125 (toList)
4226import Data.List
4327 (foldl')
28+import Data.Proxy
29+ (Proxy (Proxy))
30+import Data.Semigroup
31+ ((<>))
4432import Data.Sequence
4533 (fromList)
46−import qualified Data.Text as T
47−import Network.HTTP.Media
48− (MediaType, matches, parseAccept)
49−import qualified Network.HTTP.Media as Media
50−import qualified Data.Sequence as Seq
51−import Data.SOP.BasicFunctors
52− (I (I), (:.:) (Comp))
53−import Data.SOP.Constraint
54− (All)
55−import Data.SOP.NP
56− (NP (..), cpure_NP)
57−import Data.SOP.NS
58− (NS (S))
5934import Data.String
6035 (fromString)
6136import Data.Text
6237 (Text, pack)
63−import Data.Proxy
64− (Proxy (Proxy))
6538import GHC.TypeLits
66− (KnownNat, KnownSymbol, TypeError, symbolVal)
67−import Network.HTTP.Types
68− (Status)
69−import qualified Network.HTTP.Types as H
39+ (KnownSymbol, symbolVal)
40+import qualified Network.HTTP.Types as H
7041import Servant.API
7142 ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, BasicAuthData,
72− BuildHeadersTo (..), Capture', CaptureAll, Description,
73− EmptyAPI, Fragment, FramingRender (..), FramingUnrender (..),
74− FromSourceIO (..), Header', Headers (..), HttpVersion,
43+ BuildHeadersTo (..), ByteStringParser (..), Capture',
44+ CaptureAll, Description, EmptyAPI, FramingUnrender (..),
45+ FromResultStream (..), Header', Headers (..), HttpVersion,
7546 IsSecure, MimeRender (mimeRender),
76− MimeUnrender (mimeUnrender), NoContent (NoContent),
77− NoContentVerb, QueryFlag, QueryParam', QueryParams, Raw, RawM,
78− ReflectMethod (..), RemoteHost, ReqBody', SBoolI, Stream,
79− StreamBody', Summary, ToHttpApiData, ToSourceIO (..), Vault,
80− Verb, WithNamedContext, WithResource, WithStatus (..), contentType, getHeadersHList,
81− getResponse, toEncodedUrlPiece, toUrlPiece, NamedRoutes)
82−import Servant.API.Generic
83− (GenericMode(..), ToServant, ToServantApi
84− , GenericServant, toServant, fromServant)
47+ MimeUnrender (mimeUnrender), NoContent (NoContent), QueryFlag,
48+ QueryParam', QueryParams, Raw, ReflectMethod (..), RemoteHost,
49+ ReqBody', ResultStream (..), SBoolI, Stream, Summary,
50+ ToHttpApiData, Vault, Verb, WithNamedContext, contentType,
51+ getHeadersHList, getResponse, toQueryParam, toUrlPiece)
8552import Servant.API.ContentTypes
86− (contentTypes, AllMime (allMime), AllMimeUnrender (allMimeUnrender))
87−import Servant.API.Status
88− (statusFromNat)
89−import Servant.API.TypeLevel (FragmentUnique, AtLeastOneFragment)
53+ (contentTypes)
9054import Servant.API.Modifiers
9155 (FoldRequired, RequiredArgument, foldRequiredArgument)
92−import Servant.API.TypeErrors
93−import Servant.API.UVerb
94− (HasStatus, HasStatuses (Statuses, statuses), UVerb, Union, Unique, inject, statusOf, foldMapUnion, matchUnion)
9556
96−import Servant.Client.Core.Auth
97−import Servant.Client.Core.BasicAuth
98−import Servant.Client.Core.ClientError
99−import Servant.Client.Core.Request
100−import Servant.Client.Core.Response
101−import Servant.Client.Core.RunClient
57+import Servant.Client.Core.Internal.Auth
58+import Servant.Client.Core.Internal.BasicAuth
59+import Servant.Client.Core.Internal.Request
60+import Servant.Client.Core.Internal.RunClient
10261
10362-- * Accessing APIs as a Client
10463
@@ -208,7 +167,7 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m api)
208167 clientWithRoute pm (Proxy :: Proxy api)
209168 (appendToPath p req)
210169
211− where p = toEncodedUrlPiece val
170+ where p = (toUrlPiece val)
212171
213172 hoistClientMonad pm _ f cl = \a ->
214173 hoistClientMonad pm (Proxy :: Proxy api) f (cl a)
@@ -243,7 +202,7 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m sublayout)
243202 clientWithRoute pm (Proxy :: Proxy sublayout)
244203 (foldl' (flip appendToPath) req ps)
245204
246− where ps = map toEncodedUrlPiece vals
205+ where ps = map (toUrlPiece) vals
247206
248207 hoistClientMonad pm _ f cl = \as ->
249208 hoistClientMonad pm (Proxy :: Proxy sublayout) f (cl as)
@@ -251,11 +210,10 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m sublayout)
251210instance {-# OVERLAPPABLE #-}
252211 -- Note [Non-Empty Content Types]
253212 ( RunClient m, MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)
254− , KnownNat status
255213 ) => HasClient m (Verb method status cts' a) where
256214 type Client m (Verb method status cts' a) = m a
257215 clientWithRoute _pm Proxy req = do
258− response <- runRequestAcceptStatus (Just [status]) req
216+ response <- runRequest req
259217 { requestAccept = fromList $ toList accept
260218 , requestMethod = method
261219 }
@@ -263,27 +221,14 @@ instance {-# OVERLAPPABLE #-}
263221 where
264222 accept = contentTypes (Proxy :: Proxy ct)
265223 method = reflectMethod (Proxy :: Proxy method)
266− status = statusFromNat (Proxy :: Proxy status)
267224
268225 hoistClientMonad _ _ f ma = f ma
269226
270227instance {-# OVERLAPPING #-}
271− ( RunClient m, ReflectMethod method, KnownNat status
228+ ( RunClient m, ReflectMethod method
272229 ) => HasClient m (Verb method status cts NoContent) where
273230 type Client m (Verb method status cts NoContent)
274231 = m NoContent
275− clientWithRoute _pm Proxy req = do
276− _response <- runRequestAcceptStatus (Just [status]) req { requestMethod = method }
277− return NoContent
278− where method = reflectMethod (Proxy :: Proxy method)
279− status = statusFromNat (Proxy :: Proxy status)
280−
281− hoistClientMonad _ _ f ma = f ma
282−
283−instance (RunClient m, ReflectMethod method) =>
284− HasClient m (NoContentVerb method) where
285− type Client m (NoContentVerb method)
286− = m NoContent
287232 clientWithRoute _pm Proxy req = do
288233 _response <- runRequest req { requestMethod = method }
289234 return NoContent
@@ -293,173 +238,91 @@ instance (RunClient m, ReflectMethod method) =>
293238
294239instance {-# OVERLAPPING #-}
295240 -- Note [Non-Empty Content Types]
296− ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls, KnownNat status
241+ ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls
297242 , ReflectMethod method, cts' ~ (ct ': cts)
298243 ) => HasClient m (Verb method status cts' (Headers ls a)) where
299244 type Client m (Verb method status cts' (Headers ls a))
300245 = m (Headers ls a)
301246 clientWithRoute _pm Proxy req = do
302− response <- runRequestAcceptStatus (Just [status]) req
247+ response <- runRequest req
303248 { requestMethod = method
304249 , requestAccept = fromList $ toList accept
305250 }
306− val <- response `decodedAs` (Proxy :: Proxy ct)
307− return $ Headers { getResponse = val
308− , getHeadersHList = buildHeadersTo . toList $ responseHeaders response
309− }
310− where
311− method = reflectMethod (Proxy :: Proxy method)
312− accept = contentTypes (Proxy :: Proxy ct)
313− status = statusFromNat (Proxy :: Proxy status)
251+ case mimeUnrender (Proxy :: Proxy ct) $ responseBody response of
252+ Left err -> throwServantError $ DecodeFailure (pack err) response
253+ Right val -> return $ Headers
254+ { getResponse = val
255+ , getHeadersHList = buildHeadersTo . toList $ responseHeaders response
256+ }
257+ where method = reflectMethod (Proxy :: Proxy method)
258+ accept = contentTypes (Proxy :: Proxy ct)
314259
315260 hoistClientMonad _ _ f ma = f ma
316261
317262instance {-# OVERLAPPING #-}
318− ( RunClient m, BuildHeadersTo ls, ReflectMethod method, KnownNat status
263+ ( RunClient m, BuildHeadersTo ls, ReflectMethod method
319264 ) => HasClient m (Verb method status cts (Headers ls NoContent)) where
320265 type Client m (Verb method status cts (Headers ls NoContent))
321266 = m (Headers ls NoContent)
322267 clientWithRoute _pm Proxy req = do
323− response <- runRequestAcceptStatus (Just [status]) req { requestMethod = method }
268+ let method = reflectMethod (Proxy :: Proxy method)
269+ response <- runRequest req { requestMethod = method }
324270 return $ Headers { getResponse = NoContent
325271 , getHeadersHList = buildHeadersTo . toList $ responseHeaders response
326272 }
327− where
328− method = reflectMethod (Proxy :: Proxy method)
329− status = statusFromNat (Proxy :: Proxy status)
330273
331274 hoistClientMonad _ _ f ma = f ma
332275
333−data ClientParseError = ClientParseError MediaType String | ClientStatusMismatch | ClientNoMatchingStatus
334− deriving (Eq, Show)
335−
336−class UnrenderResponse (cts :: [*]) (a :: *) where
337− unrenderResponse :: Seq.Seq H.Header -> BL.ByteString -> Proxy cts
338− -> [Either (MediaType, String) a]
339−
340−instance {-# OVERLAPPABLE #-} AllMimeUnrender cts a => UnrenderResponse cts a where
341− unrenderResponse _ body = map parse . allMimeUnrender
342− where parse (mediaType, parser) = left ((,) mediaType) (parser body)
343−
344−instance {-# OVERLAPPING #-} forall cts a h . (UnrenderResponse cts a, BuildHeadersTo h)
345− => UnrenderResponse cts (Headers h a) where
346− unrenderResponse hs body = (map . fmap) setHeaders . unrenderResponse hs body
347− where
348− setHeaders :: a -> Headers h a
349− setHeaders x = Headers x (buildHeadersTo (toList hs))
350−
351−instance {-# OVERLAPPING #-} UnrenderResponse cts a
352− => UnrenderResponse cts (WithStatus n a) where
353− unrenderResponse hs body = (map . fmap) WithStatus . unrenderResponse hs body
354−
355−instance {-# OVERLAPPING #-}
356− ( RunClient m,
357− contentTypes ~ (contentType ': otherContentTypes),
358− -- ('otherContentTypes' should be '_', but even -XPartialTypeSignatures does not seem
359− -- allow this in instance types as of 8.8.3.)
360− as ~ (a ': as'),
361− AllMime contentTypes,
362− ReflectMethod method,
363− All (UnrenderResponse contentTypes) as,
364− All HasStatus as, HasStatuses as',
365− Unique (Statuses as)
366− ) =>
367− HasClient m (UVerb method contentTypes as)
368− where
369− type Client m (UVerb method contentTypes as) = m (Union as)
370−
371− clientWithRoute _ _ request = do
372− let accept = Seq.fromList . allMime $ Proxy @contentTypes
373− -- offering to accept all mime types listed in the api gives best compatibility. eg.,
374− -- we might not own the server implementation, and the server may choose to support
375− -- only part of the api.
376−
377− method = reflectMethod $ Proxy @method
378− acceptStatus = statuses (Proxy @as)
379− response <- runRequestAcceptStatus (Just acceptStatus) request {requestMethod = method, requestAccept = accept}
380− responseContentType <- checkContentTypeHeader response
381− unless (any (matches responseContentType) accept) $ do
382− throwClientError $ UnsupportedContentType responseContentType response
383−
384− let status = responseStatusCode response
385− body = responseBody response
386− headers = responseHeaders response
387− res = tryParsers status $ mimeUnrenders (Proxy @contentTypes) headers body
388− case res of
389− Left errors -> throwClientError $ DecodeFailure (T.pack (show errors)) response
390− Right x -> return x
391− where
392− -- | Given a list of parsers of 'mkres', returns the first one that succeeds and all the
393− -- failures it encountered along the way
394− -- TODO; better name, rewrite haddocs.
395− tryParsers :: forall xs. All HasStatus xs => Status -> NP ([] :.: Either (MediaType, String)) xs -> Either [ClientParseError] (Union xs)
396− tryParsers _ Nil = Left [ClientNoMatchingStatus]
397− tryParsers status (Comp x :* xs)
398− | status == statusOf (Comp x) =
399− case partitionEithers x of
400− (err', []) -> (map (uncurry ClientParseError) err' ++) +++ S $ tryParsers status xs
401− (_, (res : _)) -> Right . inject . I $ res
402− | otherwise = -- no reason to parse in the first place. This ain't the one we're looking for
403− (ClientStatusMismatch :) +++ S $ tryParsers status xs
404−
405− -- | Given a list of types, parses the given response body as each type
406− mimeUnrenders ::
407− forall cts xs.
408− All (UnrenderResponse cts) xs =>
409− Proxy cts ->
410− Seq.Seq H.Header ->
411− BL.ByteString ->
412− NP ([] :.: Either (MediaType, String)) xs
413− mimeUnrenders ctp headers body = cpure_NP
414− (Proxy @(UnrenderResponse cts))
415− (Comp . unrenderResponse headers body $ ctp)
416−
417− hoistClientMonad _ _ nt s = nt s
418−
419276instance {-# OVERLAPPABLE #-}
420− ( RunStreamingClient m, MimeUnrender ct chunk, ReflectMethod method,
421− FramingUnrender framing, FromSourceIO chunk a
422− ) => HasClient m (Stream method status framing ct a) where
277+ ( RunClient m, MonadIO m, MimeUnrender ct a, ReflectMethod method,
278+ FramingUnrender framing a, FromResultStream a b
279+ ) => HasClient m (Stream method status framing ct b) where
423280
424− type Client m (Stream method status framing ct a) = m a
281+ type Client m (Stream method status framing ct b) = m b
425282
426− hoistClientMonad _ _ f ma = f ma
427−
428− clientWithRoute _pm Proxy req = withStreamingRequest req' $ \gres -> do
429− let mimeUnrender' = mimeUnrender (Proxy :: Proxy ct) :: BL.ByteString -> Either String chunk
430− framingUnrender' = framingUnrender (Proxy :: Proxy framing) mimeUnrender'
431− return $ fromSourceIO $ framingUnrender' $ responseBody gres
432− where
433− req' = req
434− { requestAccept = fromList [contentType (Proxy :: Proxy ct)]
435− , requestMethod = reflectMethod (Proxy :: Proxy method)
436− }
437−
438−instance {-# OVERLAPPING #-}
439− ( RunStreamingClient m, MimeUnrender ct chunk, ReflectMethod method,
440− FramingUnrender framing, FromSourceIO chunk a,
441− BuildHeadersTo hs
442− ) => HasClient m (Stream method status framing ct (Headers hs a)) where
443−
444− type Client m (Stream method status framing ct (Headers hs a)) = m (Headers hs a)
283+ clientWithRoute _pm Proxy req = do
284+ sresp <- streamingRequest req
285+ { requestAccept = fromList [contentType (Proxy :: Proxy ct)]
286+ , requestMethod = reflectMethod (Proxy :: Proxy method)
287+ }
288+ liftIO $ fromResultStream $ ResultStream $ \k ->
289+ runStreamingResponse sresp $ \gres -> do
290+ let reader = responseBody gres
291+ let unrender = unrenderFrames (Proxy :: Proxy framing) (Proxy :: Proxy a)
292+ loop bs = do
293+ res <- BL.fromStrict <$> reader
294+ if BL.null res
295+ then return $ parseEOF unrender res
296+ else let sofar = (bs <> res)
297+ in case parseIncremental unrender sofar of
298+ Just x -> return x
299+ Nothing -> loop sofar
300+ (frameParser, remainder) <- loop BL.empty
301+ state <- newMVar remainder
302+ let frameLoop bs = do
303+ res <- BL.fromStrict <$> reader
304+ let addIsEmptyInfo (a, r) = (r, (a, BL.null r && BL.null res))
305+ if BL.null res
306+ then if BL.null bs
307+ then return ("", (Right "", True))
308+ else return . addIsEmptyInfo $ parseEOF frameParser bs
309+ else let sofar = (bs <> res)
310+ in case parseIncremental frameParser sofar of
311+ Just x -> return $ addIsEmptyInfo x
312+ Nothing -> frameLoop sofar
313+
314+ go = processResult <$> modifyMVar state frameLoop
315+ processResult (Right bs,isDone) =
316+ if BL.null bs && isDone
317+ then Nothing
318+ else Just $ case mimeUnrender (Proxy :: Proxy ct) bs :: Either String a of
319+ Left err -> Left err
320+ Right x -> Right x
321+ processResult (Left err, _) = Just (Left err)
322+ k go
445323
446324 hoistClientMonad _ _ f ma = f ma
447325
448− clientWithRoute _pm Proxy req = withStreamingRequest req' $ \gres -> do
449− let mimeUnrender' = mimeUnrender (Proxy :: Proxy ct) :: BL.ByteString -> Either String chunk
450− framingUnrender' = framingUnrender (Proxy :: Proxy framing) mimeUnrender'
451− val = fromSourceIO $ framingUnrender' $ responseBody gres
452− return $ Headers
453− { getResponse = val
454− , getHeadersHList = buildHeadersTo . toList $ responseHeaders gres
455− }
456−
457− where
458− req' = req
459− { requestAccept = fromList [contentType (Proxy :: Proxy ct)]
460− , requestMethod = reflectMethod (Proxy :: Proxy method)
461− }
462−
463326-- | If you use a 'Header' in one of your endpoints in your API,
464327-- the corresponding querying function will automatically take
465328-- an additional argument of the type specified by your 'Header',
@@ -569,7 +432,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequire
569432 (Proxy :: Proxy mods) add (maybe req add) mparam
570433 where
571434 add :: a -> Request
572− add param = appendToQueryString pname (Just $ encodeQueryParamValue param) req
435+ add param = appendToQueryString pname (Just $ toQueryParam param) req
573436
574437 pname :: Text
575438 pname = pack $ symbolVal (Proxy :: Proxy sym)
@@ -618,7 +481,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api)
618481 )
619482
620483 where pname = pack $ symbolVal (Proxy :: Proxy sym)
621− paramlist' = map (Just . encodeQueryParamValue) paramlist
484+ paramlist' = map (Just . toQueryParam) paramlist
622485
623486 hoistClientMonad pm _ f cl = \as ->
624487 hoistClientMonad pm (Proxy :: Proxy api) f (cl as)
@@ -674,16 +537,6 @@ instance RunClient m => HasClient m Raw where
674537
675538 hoistClientMonad _ _ f cl = \meth -> f (cl meth)
676539
677−instance RunClient m => HasClient m RawM where
678− type Client m RawM
679− = H.Method -> m Response
680−
681− clientWithRoute :: Proxy m -> Proxy RawM -> Request -> Client m RawM
682− clientWithRoute _pm Proxy req httpMethod = do
683− runRequest req { requestMethod = httpMethod }
684−
685− hoistClientMonad _ _ f cl = \meth -> f (cl meth)
686−
687540-- | If you use a 'ReqBody' in one of your endpoints in your API,
688541-- the corresponding querying function will automatically take
689542-- an additional argument of the type specified by your 'ReqBody'.
@@ -720,28 +573,6 @@ instance (MimeRender ct a, HasClient m api)
720573 hoistClientMonad pm _ f cl = \a ->
721574 hoistClientMonad pm (Proxy :: Proxy api) f (cl a)
722575
723−instance
724− ( HasClient m api, MimeRender ctype chunk, FramingRender framing, ToSourceIO chunk a
725− ) => HasClient m (StreamBody' mods framing ctype a :> api)
726− where
727−
728− type Client m (StreamBody' mods framing ctype a :> api) = a -> Client m api
729−
730− hoistClientMonad pm _ f cl = \a ->
731− hoistClientMonad pm (Proxy :: Proxy api) f (cl a)
732−
733− clientWithRoute pm Proxy req body
734− = clientWithRoute pm (Proxy :: Proxy api)
735− $ setRequestBody (RequestBodySource sourceIO) (contentType ctypeP) req
736− where
737− ctypeP = Proxy :: Proxy ctype
738− framingP = Proxy :: Proxy framing
739−
740− sourceIO = framingRender
741− framingP
742− (mimeRender ctypeP :: chunk -> BL.ByteString)
743− (toSourceIO body)
744−
745576-- | Make the querying function append @path@ to the request path.
746577instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where
747578 type Client m (path :> api) = Client m api
@@ -750,7 +581,7 @@ instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where
750581 clientWithRoute pm (Proxy :: Proxy api)
751582 (appendToPath p req)
752583
753− where p = toEncodedUrlPiece $ pack $ symbolVal (Proxy :: Proxy path)
584+ where p = pack $ symbolVal (Proxy :: Proxy path)
754585
755586 hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
756587
@@ -786,14 +617,6 @@ instance HasClient m subapi =>
786617
787618 hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy subapi) f cl
788619
789−instance HasClient m subapi =>
790− HasClient m (WithResource res :> subapi) where
791−
792− type Client m (WithResource res :> subapi) = Client m subapi
793− clientWithRoute pm Proxy = clientWithRoute pm (Proxy :: Proxy subapi)
794−
795− hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy subapi) f cl
796−
797620instance ( HasClient m api
798621 ) => HasClient m (AuthProtect tag :> api) where
799622 type Client m (AuthProtect tag :> api)
@@ -805,29 +628,6 @@ instance ( HasClient m api
805628 hoistClientMonad pm _ f cl = \authreq ->
806629 hoistClientMonad pm (Proxy :: Proxy api) f (cl authreq)
807630
808−-- | Ignore @'Fragment'@ in client functions.
809−-- See <https://ietf.org/rfc/rfc2616.html#section-15.1.3> for more details.
810−--
811−-- Example:
812−--
813−-- > type MyApi = "books" :> Fragment Text :> Get '[JSON] [Book]
814−-- >
815−-- > myApi :: Proxy MyApi
816−-- > myApi = Proxy
817−-- >
818−-- > getBooks :: ClientM [Book]
819−-- > getBooks = client myApi
820−-- > -- then you can just use "getBooksBy" to query that endpoint.
821−-- > -- 'getBooks' for all books.
822−instance (AtLeastOneFragment api, FragmentUnique (Fragment a :> api), HasClient m api
823− ) => HasClient m (Fragment a :> api) where
824−
825− type Client m (Fragment a :> api) = Client m api
826−
827− clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api)
828−
829− hoistClientMonad pm _ = hoistClientMonad pm (Proxy :: Proxy api)
830−
831631-- * Basic Authentication
832632
833633instance HasClient m api => HasClient m (BasicAuth realm usr :> api) where
@@ -839,120 +639,6 @@ instance HasClient m api => HasClient m (BasicAuth realm usr :> api) where
839639 hoistClientMonad pm _ f cl = \bauth ->
840640 hoistClientMonad pm (Proxy :: Proxy api) f (cl bauth)
841641
842−-- | A type that specifies that an API record contains a client implementation.
843−data AsClientT (m :: * -> *)
844−instance GenericMode (AsClientT m) where
845− type AsClientT m :- api = Client m api
846−
847−
848−type GClientConstraints api m =
849− ( GenericServant api (AsClientT m)
850− , Client m (ToServantApi api) ~ ToServant api (AsClientT m)
851− )
852−
853−class GClient (api :: * -> *) m where
854− gClientProof :: Dict (GClientConstraints api m)
855−
856−instance GClientConstraints api m => GClient api m where
857− gClientProof = Dict
858−
859−instance
860− ( forall n. GClient api n
861− , HasClient m (ToServantApi api)
862− , RunClient m
863− )
864− => HasClient m (NamedRoutes api) where
865− type Client m (NamedRoutes api) = api (AsClientT m)
866−
867− clientWithRoute :: Proxy m -> Proxy (NamedRoutes api) -> Request -> Client m (NamedRoutes api)
868− clientWithRoute pm _ request =
869− case gClientProof @api @m of
870− Dict -> fromServant $ clientWithRoute pm (Proxy @(ToServantApi api)) request
871−
872− hoistClientMonad
873− :: forall ma mb.
874− Proxy m
875− -> Proxy (NamedRoutes api)
876− -> (forall x. ma x -> mb x)
877− -> Client ma (NamedRoutes api)
878− -> Client mb (NamedRoutes api)
879− hoistClientMonad _ _ nat clientA =
880− case (gClientProof @api @ma, gClientProof @api @mb) of
881− (Dict, Dict) ->
882− fromServant @api @(AsClientT mb) $
883− hoistClientMonad @m @(ToServantApi api) @ma @mb Proxy Proxy nat $
884− toServant @api @(AsClientT ma) clientA
885−
886−infixl 1 //
887−infixl 2 /:
888−
889−-- | Helper to make code using records of clients more readable.
890−--
891−-- Can be mixed with (/:) for supplying arguments.
892−--
893−-- Example:
894−--
895−-- @
896−-- type Api = NamedRoutes RootApi
897−--
898−-- data RootApi mode = RootApi
899−-- { subApi :: mode :- NamedRoutes SubApi
900−-- , …
901−-- } deriving Generic
902−--
903−-- data SubApi mode = SubApi
904−-- { endpoint :: mode :- Get '[JSON] Person
905−-- , …
906−-- } deriving Generic
907−--
908−-- api :: Proxy API
909−-- api = Proxy
910−--
911−-- rootClient :: RootApi (AsClientT ClientM)
912−-- rootClient = client api
913−--
914−-- endpointClient :: ClientM Person
915−-- endpointClient = client \/\/ subApi \/\/ endpoint
916−-- @
917−(//) :: a -> (a -> b) -> b
918−x // f = f x
919−
920−-- | Convenience function for supplying arguments to client functions when
921−-- working with records of clients.
922−--
923−-- Intended to be used in conjunction with '(//)'.
924−--
925−-- Example:
926−--
927−-- @
928−-- type Api = NamedRoutes RootApi
929−--
930−-- data RootApi mode = RootApi
931−-- { subApi :: mode :- Capture "token" String :> NamedRoutes SubApi
932−-- , hello :: mode :- Capture "name" String :> Get '[JSON] String
933−-- , …
934−-- } deriving Generic
935−--
936−-- data SubApi mode = SubApi
937−-- { endpoint :: mode :- Get '[JSON] Person
938−-- , …
939−-- } deriving Generic
940−--
941−-- api :: Proxy API
942−-- api = Proxy
943−--
944−-- rootClient :: RootApi (AsClientT ClientM)
945−-- rootClient = client api
946−--
947−-- hello :: String -> ClientM String
948−-- hello name = rootClient \/\/ hello \/: name
949−--
950−-- endpointClient :: ClientM Person
951−-- endpointClient = client \/\/ subApi \/: "foobar123" \/\/ endpoint
952−-- @
953−(/:) :: (a -> b -> c) -> b -> a -> c
954−(/:) = flip
955−
956642
957643{- Note [Non-Empty Content Types]
958644~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -969,43 +655,3 @@ non-empty lists, but is otherwise more specific, no instance will be overall
969655more specific. This in turn generally means adding yet another instance (one
970656for empty and one for non-empty lists).
971657-}
972−
973−-------------------------------------------------------------------------------
974−-- helpers
975−-------------------------------------------------------------------------------
976−
977−checkContentTypeHeader :: RunClient m => Response -> m MediaType
978−checkContentTypeHeader response =
979− case lookup "Content-Type" $ toList $ responseHeaders response of
980− Nothing -> return $ "application" Media.// "octet-stream"
981− Just t -> case parseAccept t of
982− Nothing -> throwClientError $ InvalidContentTypeHeader response
983− Just t' -> return t'
984−
985−decodedAs :: forall ct a m. (MimeUnrender ct a, RunClient m)
986− => Response -> Proxy ct -> m a
987−decodedAs response ct = do
988− responseContentType <- checkContentTypeHeader response
989− unless (any (matches responseContentType) accept) $
990− throwClientError $ UnsupportedContentType responseContentType response
991− case mimeUnrender ct $ responseBody response of
992− Left err -> throwClientError $ DecodeFailure (T.pack err) response
993− Right val -> return val
994− where
995− accept = toList $ contentTypes ct
996−
997−-------------------------------------------------------------------------------
998−-- Custom type errors
999−-------------------------------------------------------------------------------
1000−
1001−-- Erroring instance for HasClient' when a combinator is not fully applied
1002−instance (RunClient m, TypeError (PartialApplication HasClient arr)) => HasClient m ((arr :: a -> b) :> sub)
1003− where
1004− type Client m (arr :> sub) = TypeError (PartialApplication HasClient arr)
1005− clientWithRoute _ _ _ = error "unreachable"
1006− hoistClientMonad _ _ _ _ = error "unreachable"
1007−
1008−-- Erroring instances for 'HasClient' for unknown API combinators
1009−instance {-# OVERLAPPABLE #-} (RunClient m, TypeError (NoInstanceForSub (HasClient m) ty)) => HasClient m (ty :> sub)
1010−
1011−instance {-# OVERLAPPABLE #-} (RunClient m, TypeError (NoInstanceFor (HasClient m api))) => HasClient m api
servant-client-core/src/Servant/Client/Core/Internal/Request.hsnew file+138
@@ -0,0 +1,138 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DeriveDataTypeable #-}
3+{-# LANGUAGE DeriveFoldable #-}
4+{-# LANGUAGE DeriveFunctor #-}
5+{-# LANGUAGE DeriveGeneric #-}
6+{-# LANGUAGE DeriveTraversable #-}
7+{-# LANGUAGE MultiParamTypeClasses #-}
8+{-# LANGUAGE OverloadedStrings #-}
9+{-# LANGUAGE RankNTypes #-}
10+{-# LANGUAGE ScopedTypeVariables #-}
11+{-# LANGUAGE TypeFamilies #-}
12+
13+module Servant.Client.Core.Internal.Request where
14+
15+import Prelude ()
16+import Prelude.Compat
17+
18+import Control.Monad.Catch
19+ (Exception)
20+import qualified Data.ByteString as BS
21+import qualified Data.ByteString.Builder as Builder
22+import qualified Data.ByteString.Lazy as LBS
23+import Data.Int
24+ (Int64)
25+import Data.Semigroup
26+ ((<>))
27+import qualified Data.Sequence as Seq
28+import Data.Text
29+ (Text)
30+import Data.Text.Encoding
31+ (encodeUtf8)
32+import Data.Typeable
33+ (Typeable)
34+import GHC.Generics
35+ (Generic)
36+import Network.HTTP.Media
37+ (MediaType)
38+import Network.HTTP.Types
39+ (Header, HeaderName, HttpVersion, Method, QueryItem, Status,
40+ http11, methodGet)
41+import Web.HttpApiData
42+ (ToHttpApiData, toEncodedUrlPiece, toHeader)
43+
44+-- | A type representing possible errors in a request
45+--
46+-- Note that this type substantially changed in 0.12.
47+data ServantError =
48+ -- | The server returned an error response
49+ FailureResponse Response
50+ -- | The body could not be decoded at the expected type
51+ | DecodeFailure Text Response
52+ -- | The content-type of the response is not supported
53+ | UnsupportedContentType MediaType Response
54+ -- | The content-type header is invalid
55+ | InvalidContentTypeHeader Response
56+ -- | There was a connection error, and no response was received
57+ | ConnectionError Text
58+ deriving (Eq, Show, Generic, Typeable)
59+
60+instance Exception ServantError
61+
62+data RequestF a = Request
63+ { requestPath :: a
64+ , requestQueryString :: Seq.Seq QueryItem
65+ , requestBody :: Maybe (RequestBody, MediaType)
66+ , requestAccept :: Seq.Seq MediaType
67+ , requestHeaders :: Seq.Seq Header
68+ , requestHttpVersion :: HttpVersion
69+ , requestMethod :: Method
70+ } deriving (Generic, Typeable)
71+
72+type Request = RequestF Builder.Builder
73+
74+-- | The request body. A replica of the @http-client@ @RequestBody@.
75+data RequestBody
76+ = RequestBodyLBS LBS.ByteString
77+ | RequestBodyBS BS.ByteString
78+ | RequestBodyBuilder Int64 Builder.Builder
79+ | RequestBodyStream Int64 ((IO BS.ByteString -> IO ()) -> IO ())
80+ | RequestBodyStreamChunked ((IO BS.ByteString -> IO ()) -> IO ())
81+ | RequestBodyIO (IO RequestBody)
82+ deriving (Generic, Typeable)
83+
84+data GenResponse a = Response
85+ { responseStatusCode :: Status
86+ , responseHeaders :: Seq.Seq Header
87+ , responseHttpVersion :: HttpVersion
88+ , responseBody :: a
89+ } deriving (Eq, Show, Generic, Typeable, Functor, Foldable, Traversable)
90+
91+type Response = GenResponse LBS.ByteString
92+newtype StreamingResponse = StreamingResponse { runStreamingResponse :: forall a. (GenResponse (IO BS.ByteString) -> IO a) -> IO a }
93+
94+-- A GET request to the top-level path
95+defaultRequest :: Request
96+defaultRequest = Request
97+ { requestPath = ""
98+ , requestQueryString = Seq.empty
99+ , requestBody = Nothing
100+ , requestAccept = Seq.empty
101+ , requestHeaders = Seq.empty
102+ , requestHttpVersion = http11
103+ , requestMethod = methodGet
104+ }
105+
106+appendToPath :: Text -> Request -> Request
107+appendToPath p req
108+ = req { requestPath = requestPath req <> "/" <> toEncodedUrlPiece p }
109+
110+appendToQueryString :: Text -- ^ param name
111+ -> Maybe Text -- ^ param value
112+ -> Request
113+ -> Request
114+appendToQueryString pname pvalue req
115+ = req { requestQueryString = requestQueryString req
116+ Seq.|> (encodeUtf8 pname, encodeUtf8 <$> pvalue)}
117+
118+addHeader :: ToHttpApiData a => HeaderName -> a -> Request -> Request
119+addHeader name val req
120+ = req { requestHeaders = requestHeaders req Seq.|> (name, toHeader val)}
121+
122+-- | Set body and media type of the request being constructed.
123+--
124+-- The body is set to the given bytestring using the 'RequestBodyLBS'
125+-- constructor.
126+--
127+-- @since 0.12
128+--
129+setRequestBodyLBS :: LBS.ByteString -> MediaType -> Request -> Request
130+setRequestBodyLBS b t req
131+ = req { requestBody = Just (RequestBodyLBS b, t) }
132+
133+-- | Set body and media type of the request being constructed.
134+--
135+-- @since 0.12
136+--
137+setRequestBody :: RequestBody -> MediaType -> Request -> Request
138+setRequestBody b t req = req { requestBody = Just (b, t) }
servant-client-core/src/Servant/Client/Core/Internal/RunClient.hsnew file+60
@@ -0,0 +1,60 @@
1+{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE MultiParamTypeClasses #-}
3+{-# LANGUAGE OverloadedStrings #-}
4+{-# LANGUAGE ScopedTypeVariables #-}
5+{-# LANGUAGE TypeFamilies #-}
6+-- | Types for possible backends to run client-side `Request` queries
7+module Servant.Client.Core.Internal.RunClient where
8+
9+import Prelude ()
10+import Prelude.Compat
11+
12+import Control.Monad
13+ (unless)
14+import Control.Monad.Free
15+ (Free (..), liftF)
16+import Data.Foldable
17+ (toList)
18+import Data.Proxy
19+ (Proxy)
20+import qualified Data.Text as T
21+import Network.HTTP.Media
22+ (MediaType, matches, parseAccept, (//))
23+import Servant.API
24+ (MimeUnrender, contentTypes, mimeUnrender)
25+
26+import Servant.Client.Core.Internal.ClientF
27+import Servant.Client.Core.Internal.Request
28+ (GenResponse (..), Request, Response, ServantError (..),
29+ StreamingResponse (..))
30+
31+class Monad m => RunClient m where
32+ -- | How to make a request.
33+ runRequest :: Request -> m Response
34+ streamingRequest :: Request -> m StreamingResponse
35+ throwServantError :: ServantError -> m a
36+
37+checkContentTypeHeader :: RunClient m => Response -> m MediaType
38+checkContentTypeHeader response =
39+ case lookup "Content-Type" $ toList $ responseHeaders response of
40+ Nothing -> return $ "application"//"octet-stream"
41+ Just t -> case parseAccept t of
42+ Nothing -> throwServantError $ InvalidContentTypeHeader response
43+ Just t' -> return t'
44+
45+decodedAs :: forall ct a m. (MimeUnrender ct a, RunClient m)
46+ => Response -> Proxy ct -> m a
47+decodedAs response contentType = do
48+ responseContentType <- checkContentTypeHeader response
49+ unless (any (matches responseContentType) accept) $
50+ throwServantError $ UnsupportedContentType responseContentType response
51+ case mimeUnrender contentType $ responseBody response of
52+ Left err -> throwServantError $ DecodeFailure (T.pack err) response
53+ Right val -> return val
54+ where
55+ accept = toList $ contentTypes contentType
56+
57+instance ClientF ~ f => RunClient (Free f) where
58+ runRequest req = liftF (RunRequest req id)
59+ streamingRequest req = liftF (StreamingRequest req id)
60+ throwServantError = liftF . Throw
servant-client-core/src/Servant/Client/Core/Reexport.hs+10−13
@@ -5,19 +5,17 @@ module Servant.Client.Core.Reexport
55 (
66 -- * HasClient
77 HasClient(..)
8− , foldMapUnion
9− , matchUnion
10− , AsClientT
11− , (//)
12− , (/:)
138
149 -- * Response (for @Raw@)
1510 , Response
1611 , StreamingResponse
17− , ResponseF(..)
12+ , GenResponse(..)
1813
19− -- * Data types
20− , ClientError(..)
14+ -- * Generic Client
15+ , ClientLike(..)
16+ , genericMkClientL
17+ , genericMkClientP
18+ , ServantError(..)
2119 , EmptyClient(..)
2220
2321 -- * BaseUrl
@@ -26,11 +24,10 @@ module Servant.Client.Core.Reexport
2624 , showBaseUrl
2725 , parseBaseUrl
2826 , InvalidBaseUrlException
29−
3027 ) where
3128
3229
33−import Servant.Client.Core.BaseUrl
34−import Servant.Client.Core.HasClient
35−import Servant.Client.Core.Response
36−import Servant.Client.Core.ClientError
30+import Servant.Client.Core.Internal.BaseUrl
31+import Servant.Client.Core.Internal.Generic
32+import Servant.Client.Core.Internal.HasClient
33+import Servant.Client.Core.Internal.Request
servant-client-core/src/Servant/Client/Core/Request.hsdeleted−192
@@ -1,192 +0,0 @@
1−{-# LANGUAGE DeriveDataTypeable #-}
2−{-# LANGUAGE DeriveFoldable #-}
3−{-# LANGUAGE DeriveFunctor #-}
4−{-# LANGUAGE DeriveGeneric #-}
5−{-# LANGUAGE DeriveTraversable #-}
6−{-# LANGUAGE MultiParamTypeClasses #-}
7−{-# LANGUAGE OverloadedStrings #-}
8−{-# LANGUAGE RankNTypes #-}
9−{-# LANGUAGE ScopedTypeVariables #-}
10−{-# LANGUAGE TypeFamilies #-}
11−module Servant.Client.Core.Request (
12− Request,
13− RequestF (..),
14− RequestBody (..),
15− defaultRequest,
16− -- ** Modifiers
17− addHeader,
18− appendToPath,
19− appendToQueryString,
20− encodeQueryParamValue,
21− setRequestBody,
22− setRequestBodyLBS,
23− ) where
24−
25−import Prelude ()
26−import Prelude.Compat
27−
28−import Control.DeepSeq
29− (NFData (..))
30−import Data.Bifoldable
31− (Bifoldable (..))
32−import Data.Bifunctor
33− (Bifunctor (..))
34−import Data.Bitraversable
35− (Bitraversable (..), bifoldMapDefault, bimapDefault)
36−import qualified Data.ByteString as BS
37−import Data.ByteString.Builder
38− (Builder)
39−import qualified Data.ByteString.Builder as Builder
40−import qualified Data.ByteString.Lazy as LBS
41−import qualified Data.Sequence as Seq
42−import Data.Text
43− (Text)
44−import Data.Text.Encoding
45− (encodeUtf8)
46−import Data.Typeable
47− (Typeable)
48−import GHC.Generics
49− (Generic)
50−import Network.HTTP.Media
51− (MediaType)
52−import Network.HTTP.Types
53− (Header, HeaderName, HttpVersion (..), Method, QueryItem,
54− http11, methodGet)
55−import Servant.API
56− (ToHttpApiData, toEncodedUrlPiece, toHeader, SourceIO)
57−
58−import Servant.Client.Core.Internal (mediaTypeRnf)
59−
60−data RequestF body path = Request
61− { requestPath :: path
62− , requestQueryString :: Seq.Seq QueryItem
63− , requestBody :: Maybe (body, MediaType)
64− , requestAccept :: Seq.Seq MediaType
65− , requestHeaders :: Seq.Seq Header
66− , requestHttpVersion :: HttpVersion
67− , requestMethod :: Method
68− } deriving (Generic, Typeable, Eq, Functor, Foldable, Traversable)
69−
70−instance (Show a, Show b) =>
71− Show (Servant.Client.Core.Request.RequestF a b) where
72− showsPrec p req
73− = showParen
74− (p >= 11)
75− ( showString "Request {requestPath = "
76− . showsPrec 0 (requestPath req)
77− . showString ", requestQueryString = "
78− . showsPrec 0 (requestQueryString req)
79− . showString ", requestBody = "
80− . showsPrec 0 (requestBody req)
81− . showString ", requestAccept = "
82− . showsPrec 0 (requestAccept req)
83− . showString ", requestHeaders = "
84− . showsPrec 0 (redactSensitiveHeader <$> requestHeaders req)
85− . showString ", requestHttpVersion = "
86− . showsPrec 0 (requestHttpVersion req)
87− . showString ", requestMethod = "
88− . showsPrec 0 (requestMethod req)
89− . showString "}"
90− )
91− where
92− redactSensitiveHeader :: Header -> Header
93− redactSensitiveHeader ("Authorization", _) = ("Authorization", "<REDACTED>")
94− redactSensitiveHeader h = h
95−instance Bifunctor RequestF where bimap = bimapDefault
96−instance Bifoldable RequestF where bifoldMap = bifoldMapDefault
97−instance Bitraversable RequestF where
98− bitraverse f g r = mk
99− <$> traverse (bitraverse f pure) (requestBody r)
100− <*> g (requestPath r)
101− where
102− mk b p = r { requestBody = b, requestPath = p }
103−
104−instance (NFData path, NFData body) => NFData (RequestF body path) where
105− rnf r =
106− rnf (requestPath r)
107− `seq` rnf (requestQueryString r)
108− `seq` rnfB (requestBody r)
109− `seq` rnf (fmap mediaTypeRnf (requestAccept r))
110− `seq` rnf (requestHeaders r)
111− `seq` requestHttpVersion r
112− `seq` rnf (requestMethod r)
113− where
114− rnfB Nothing = ()
115− rnfB (Just (b, mt)) = rnf b `seq` mediaTypeRnf mt
116−
117−type Request = RequestF RequestBody Builder
118−
119−-- | The request body. R replica of the @http-client@ @RequestBody@.
120−data RequestBody
121− = RequestBodyLBS LBS.ByteString
122− | RequestBodyBS BS.ByteString
123− | RequestBodySource (SourceIO LBS.ByteString)
124− deriving (Generic, Typeable)
125−
126−instance Show RequestBody where
127− showsPrec d (RequestBodyLBS lbs) = showParen (d > 10)
128− $ showString "RequestBodyLBS "
129− . showsPrec 11 lbs
130− showsPrec d (RequestBodyBS bs) = showParen (d > 10)
131− $ showString "RequestBodyBS "
132− . showsPrec 11 bs
133− showsPrec d (RequestBodySource _) = showParen (d > 10)
134− $ showString "RequestBodySource <IO>"
135−
136−-- A GET request to the top-level path
137−defaultRequest :: Request
138−defaultRequest = Request
139− { requestPath = ""
140− , requestQueryString = Seq.empty
141− , requestBody = Nothing
142− , requestAccept = Seq.empty
143− , requestHeaders = Seq.empty
144− , requestHttpVersion = http11
145− , requestMethod = methodGet
146− }
147−
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
152−appendToPath p req
153− = req { requestPath = requestPath req <> "/" <> p }
154−
155−-- | Append a query parameter to the request being constructed.
156−--
157−appendToQueryString :: Text -- ^ query param name
158− -> Maybe BS.ByteString -- ^ query param value
159− -> Request
160− -> Request
161−appendToQueryString pname pvalue req
162− = req { requestQueryString = requestQueryString req
163− Seq.|> (encodeUtf8 pname, pvalue)}
164−
165−-- | Encode a query parameter value.
166−--
167−encodeQueryParamValue :: ToHttpApiData a => a -> BS.ByteString
168−encodeQueryParamValue = LBS.toStrict . Builder.toLazyByteString . toEncodedUrlPiece
169−
170−-- | Add header to the request being constructed.
171−--
172−addHeader :: ToHttpApiData a => HeaderName -> a -> Request -> Request
173−addHeader name val req
174− = req { requestHeaders = requestHeaders req Seq.|> (name, toHeader val)}
175−
176−-- | Set body and media type of the request being constructed.
177−--
178−-- The body is set to the given bytestring using the 'RequestBodyLBS'
179−-- constructor.
180−--
181−-- @since 0.12
182−--
183−setRequestBodyLBS :: LBS.ByteString -> MediaType -> Request -> Request
184−setRequestBodyLBS b t req
185− = req { requestBody = Just (RequestBodyLBS b, t) }
186−
187−-- | Set body and media type of the request being constructed.
188−--
189−-- @since 0.12
190−--
191−setRequestBody :: RequestBody -> MediaType -> Request -> Request
192−setRequestBody b t req = req { requestBody = Just (b, t) }
servant-client-core/src/Servant/Client/Core/Response.hsdeleted−53
@@ -1,53 +0,0 @@
1−{-# LANGUAGE DeriveDataTypeable #-}
2−{-# LANGUAGE DeriveFoldable #-}
3−{-# LANGUAGE DeriveFunctor #-}
4−{-# LANGUAGE DeriveGeneric #-}
5−{-# LANGUAGE DeriveTraversable #-}
6−{-# LANGUAGE MultiParamTypeClasses #-}
7−{-# LANGUAGE RankNTypes #-}
8−{-# LANGUAGE ScopedTypeVariables #-}
9−{-# LANGUAGE TypeFamilies #-}
10−
11−module Servant.Client.Core.Response (
12− Response,
13− StreamingResponse,
14− ResponseF (..),
15− ) where
16−
17−import Prelude ()
18−import Prelude.Compat
19−
20−import Control.DeepSeq
21− (NFData (..))
22−import qualified Data.ByteString as BS
23−import qualified Data.ByteString.Lazy as LBS
24−import qualified Data.Sequence as Seq
25−import Data.Typeable
26− (Typeable)
27−import GHC.Generics
28− (Generic)
29−import Network.HTTP.Types
30− (Header, HttpVersion (..), Status (..))
31−
32−import Servant.API.Stream
33− (SourceIO)
34−
35−data ResponseF a = Response
36− { responseStatusCode :: Status
37− , responseHeaders :: Seq.Seq Header
38− , responseHttpVersion :: HttpVersion
39− , responseBody :: a
40− } deriving (Eq, Show, Generic, Typeable, Functor, Foldable, Traversable)
41−
42−instance NFData a => NFData (ResponseF a) where
43− rnf (Response sc hs hv body) =
44− rnfStatus sc `seq`
45− rnf hs `seq`
46− rnfHttpVersion hv `seq`
47− rnf body
48− where
49− rnfStatus (Status code msg) = rnf code `seq` rnf msg
50− rnfHttpVersion (HttpVersion _ _) = () -- HttpVersion fields are strict
51−
52−type Response = ResponseF LBS.ByteString
53−type StreamingResponse = ResponseF (SourceIO BS.ByteString)
servant-client-core/src/Servant/Client/Core/RunClient.hsdeleted−55
@@ -1,55 +0,0 @@
1−{-# LANGUAGE DeriveFunctor #-}
2−{-# LANGUAGE FlexibleContexts #-}
3−{-# LANGUAGE MultiParamTypeClasses #-}
4−{-# LANGUAGE OverloadedStrings #-}
5−{-# LANGUAGE ScopedTypeVariables #-}
6−{-# LANGUAGE TypeFamilies #-}
7−-- | Types for possible backends to run client-side `Request` queries
8−module Servant.Client.Core.RunClient (
9− RunClient (..),
10− runRequest,
11− RunStreamingClient (..),
12− ClientF (..),
13− ) where
14−
15−import Prelude ()
16−import Prelude.Compat
17−
18−import Network.HTTP.Types.Status
19− (Status)
20−import Control.Monad.Free
21− (Free (..), liftF)
22−
23−import Servant.Client.Core.ClientError
24−import Servant.Client.Core.Request
25−import Servant.Client.Core.Response
26−
27−class Monad m => RunClient m where
28− -- | How to make a request, with an optional list of status codes to not throw exceptions
29− -- for (default: [200..299]).
30− runRequestAcceptStatus :: Maybe [Status] -> Request -> m Response
31− throwClientError :: ClientError -> m a
32−
33−-- | How to make a request.
34−runRequest :: RunClient m => Request -> m Response
35−runRequest = runRequestAcceptStatus Nothing
36−
37−class RunClient m => RunStreamingClient m where
38− withStreamingRequest :: Request -> (StreamingResponse -> IO a) -> m a
39−
40−-------------------------------------------------------------------------------
41−-- Free
42−-------------------------------------------------------------------------------
43−
44−-- | 'ClientF' cannot stream.
45−--
46−-- Compare to 'RunClient'.
47−data ClientF a
48− = RunRequest Request (Response -> a)
49− | Throw ClientError
50− deriving (Functor)
51−
52−-- TODO: honour the accept-status argument.
53−instance ClientF ~ f => RunClient (Free f) where
54− runRequestAcceptStatus _ req = liftF (RunRequest req id)
55− throwClientError = liftF . Throw
servant-client-core/src/Servant/Client/Free.hs+1−1
@@ -11,8 +11,8 @@ import Control.Monad.Free
1111import Data.Proxy
1212 (Proxy (..))
1313import Servant.Client.Core
14+import Servant.Client.Core.Internal.ClientF
1415import Servant.Client.Core.Reexport
15−import Servant.Client.Core.RunClient
1616
1717client :: HasClient (Free ClientF) api => Proxy api -> Client (Free ClientF) api
1818client api = api `clientIn` (Proxy :: Proxy (Free ClientF))
servant-client-core/src/Servant/Client/Generic.hs+11−8
@@ -1,10 +1,9 @@
1−{-# OPTIONS_GHC -fno-warn-orphans #-}
2−{-# LANGUAGE FlexibleContexts #-}
3−{-# LANGUAGE KindSignatures #-}
4−{-# LANGUAGE RankNTypes #-}
5−{-# LANGUAGE ScopedTypeVariables #-}
6−{-# LANGUAGE TypeFamilies #-}
7−
1+{-# LANGUAGE ConstraintKinds #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE KindSignatures #-}
4+{-# LANGUAGE RankNTypes #-}
5+{-# LANGUAGE ScopedTypeVariables #-}
6+{-# LANGUAGE TypeFamilies #-}
87module Servant.Client.Generic (
98 AsClientT,
109 genericClient,
@@ -16,7 +15,11 @@ import Data.Proxy
1615
1716import Servant.API.Generic
1817import Servant.Client.Core
19−import Servant.Client.Core.HasClient (AsClientT)
18+
19+-- | A type that specifies that an API reocrd contains a client implementation.
20+data AsClientT (m :: * -> *)
21+instance GenericMode (AsClientT m) where
22+ type AsClientT m :- api = Client m api
2023
2124-- | Generate a record of client functions.
2225genericClient
servant-client-core/test/Servant/Client/Core/Internal/BaseUrlSpec.hs+1−1
@@ -8,7 +8,7 @@ import Prelude.Compat
88import Test.Hspec
99import Test.QuickCheck
1010
11−import Servant.Client.Core.BaseUrl
11+import Servant.Client.Core.Internal.BaseUrl
1212
1313spec :: Spec
1414spec = do
servant-client-core/test/Servant/Client/Core/RequestSpec.hsdeleted−31
@@ -1,31 +0,0 @@
1−{-# OPTIONS_GHC -fno-warn-orphans #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−module Servant.Client.Core.RequestSpec (spec) where
4−
5−
6−import Prelude ()
7−import Prelude.Compat
8−import Control.Monad
9−import Data.List (isInfixOf)
10−import Servant.Client.Core.Request
11−import Test.Hspec
12−
13−newtype DataWithRequest = DataWithRequest (RequestF RequestBody ())
14− deriving Show
15−
16−spec :: Spec
17−spec = do
18− describe "Request" $ do
19− describe "show" $ do
20− it "has parenthesis correctly positioned" $ do
21− let d = DataWithRequest (void defaultRequest)
22− show d `shouldBe` "DataWithRequest (Request {requestPath = ()\
23− \, requestQueryString = fromList []\
24− \, requestBody = Nothing\
25− \, requestAccept = fromList []\
26− \, requestHeaders = fromList []\
27− \, requestHttpVersion = HTTP/1.1\
28− \, requestMethod = \"GET\"})"
29− it "redacts the authorization header" $ do
30− let request = void $ defaultRequest { requestHeaders = pure ("authorization", "secret") }
31− isInfixOf "secret" (show request) `shouldBe` False
servant-client-ghcjs/LICENSE+1−1
@@ -1,4 +1,4 @@
1−Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, 2016-2018 Servant Contributors
1+Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, Servant Contributors
22
33All rights reserved.
44
servant-client-ghcjs/README.md+2−2
@@ -4,12 +4,12 @@ Type safe querying of servant APIs from the browser.
44
55`servant-client-ghcjs` is much like `servant-client`, as both packages allow you to generate functions that query the endpoints of your servant API. Both packages should feel the same in usage. The big difference lies in how they perform the actual requests. `servant-client` (indirectly) uses your operating system's socket mechanisms, whereas `servant-client-ghcjs` uses your browser's [XHR](https://developer.mozilla.org/en-US/docs/Web/API/XMLHttpRequest/Using_XMLHttpRequest) mechanisms to send requests.
66
7−This guide assumes knowledge of servant. Reading its [documentation](http://docs.servant.dev) is recommended if you're new to the subject.
7+This guide assumes knowledge of servant. Reading its [documentation](http://haskell-servant.readthedocs.io) is recommended if you're new to the subject.
88
99## Using servant-client-ghcjs
1010`servant-client-ghcjs` should feel familiar if you've worked with `servant-client`.
1111
12−Take the following API (taken from the [Querying an API](http://docs.servant.dev/en/stable/tutorial/Client.html) section in the servant documentation)
12+Take the following API (taken from the [Querying an API](http://haskell-servant.readthedocs.io/en/stable/tutorial/Client.html) section in the servant documentation)
1313
1414```haskell
1515{-# LANGUAGE DataKinds #-}
servant-client-ghcjs/servant-client-ghcjs.cabal+36−46
@@ -1,64 +1,54 @@
1−cabal-version: 2.2
2−name: servant-client-ghcjs
3−version: 0.16
4−synopsis:
5− Automatic derivation of querying functions for servant webservices for GHCJS
6−
7−category: Servant, Web
1+name: servant-client-ghcjs
2+version: 0.14
3+synopsis: automatical derivation of querying functions for servant webservices for ghcjs
84description:
95 This library lets you automatically derive Haskell functions that
106 let you query each endpoint of a <http://hackage.haskell.org/package/servant servant> webservice.
117 .
12− See <http://docs.servant.dev/en/stable/tutorial/Client.html the client section of the tutorial>.
8+ See <http://haskell-servant.readthedocs.org/en/stable/tutorial/Client.html the client section of the tutorial>.
139 .
1410 <https://github.com/haskell-servant/servant/blob/master/servant-client/CHANGELOG.md CHANGELOG>
15−
16−homepage: http://docs.servant.dev/
17−bug-reports: http://github.com/haskell-servant/servant/issues
18−license: BSD-3-Clause
19−license-file: LICENSE
20−author: Servant Contributors
21−maintainer: haskell-servant-maintainers@googlegroups.com
22−copyright:
23− 2014-2016 Zalora South East Asia Pte Ltd, 2016-2018 Servant Contributors
24−
25−build-type: Simple
26−tested-with: ghc >=7.8
11+license: BSD3
12+license-file: LICENSE
13+author: Servant Contributors
14+maintainer: haskell-servant-maintainers@googlegroups.com
15+copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2017 Servant Contributors
16+category: Servant, Web
17+build-type: Simple
18+cabal-version: >=1.10
19+tested-with: GHC >= 7.8
20+homepage: http://haskell-servant.readthedocs.org/
21+Bug-reports: http://github.com/haskell-servant/servant/issues
2722extra-source-files:
2823 CHANGELOG.md
2924 README.md
30−
3125source-repository head
32− type: git
26+ type: git
3327 location: http://github.com/haskell-servant/servant.git
3428
3529library
3630 exposed-modules:
3731 Servant.Client.Ghcjs
3832 Servant.Client.Internal.XhrClient
39−
40− build-depends:
41− base >=4.11 && <5
42− , bytestring >=0.10 && <0.12
43− , case-insensitive >=1.2.0.0 && <1.3.0.0
44− , containers >=0.5 && <0.7
45− , exceptions >=0.8 && <0.11
46− , ghcjs-base >=0.2.0.0 && <0.3.0.0
47− , ghcjs-prim >=0.1.0.0 && <0.2.0.0
48− , http-media >=0.6.2 && <0.9
49− , http-types >=0.12 && <0.13
50− , monad-control >=1.0.0.4 && <1.1
51− , mtl ^>=2.2.2 || ^>=2.3.1
52− , semigroupoids >=5.3 && <5.4
53− , string-conversions >=0.3 && <0.5
54− , transformers >=0.3 && <0.6
55− , transformers-base >=0.4.4 && <0.5
56−
57− -- strict, as we re-export stuff
5833 build-depends:
59− servant >=0.16 && <0.20
60− , servant-client-core >=0.16 && <0.20
61−
62− hs-source-dirs: src
34+ base >= 4.7 && < 4.12
35+ , bytestring >= 0.10 && < 0.11
36+ , case-insensitive >= 1.2.0.0 && < 1.3.0.0
37+ , containers >= 0.5 && < 0.6
38+ , exceptions >= 0.8 && < 0.11
39+ , ghcjs-base >= 0.2.0.0 && < 0.3.0.0
40+ , ghcjs-prim >= 0.1.0.0 && < 0.2.0.0
41+ , http-media >= 0.6.2 && < 0.8
42+ , http-types >= 0.12 && < 0.13
43+ , monad-control >= 1.0.0.4 && < 1.1
44+ , mtl >= 2.1 && < 2.3
45+ , semigroupoids >= 4.3 && < 5.3
46+ , servant-client-core == 0.14.*
47+ , string-conversions >= 0.3 && < 0.5
48+ , transformers >= 0.3 && < 0.6
49+ , transformers-base >= 0.4.4 && < 0.5
50+ hs-source-dirs: src
6351 default-language: Haskell2010
64− ghc-options: -Wall -Wno-redundant-constraints
52+ ghc-options: -Wall
53+ if impl(ghc >= 8.0)
54+ ghc-options: -Wno-redundant-constraints
servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs+48−52
@@ -18,48 +18,35 @@ import Control.Arrow
1818import Control.Concurrent
1919import Control.Exception
2020import Control.Monad
21−import Control.Monad.Base
22− (MonadBase (..))
23−import Control.Monad.Catch
24− (MonadCatch, MonadThrow)
25−import Control.Monad.Error.Class
26− (MonadError (..))
21+import Control.Monad.Base (MonadBase (..))
22+import Control.Monad.Catch (MonadCatch, MonadThrow)
23+import Control.Monad.Error.Class (MonadError (..))
2724import Control.Monad.Reader
28−import Control.Monad.Trans.Control
29− (MonadBaseControl (..))
25+import Control.Monad.Trans.Control (MonadBaseControl (..))
3026import Control.Monad.Trans.Except
31−import Data.Bifunctor
32− (bimap)
33−import Data.ByteString.Builder
34− (toLazyByteString)
35−import qualified Data.ByteString.Char8 as BS
36−import qualified Data.ByteString.Lazy as BL
27+import Data.ByteString.Builder (toLazyByteString)
28+import qualified Data.ByteString.Char8 as BS
29+import qualified Data.ByteString.Lazy as BL
3730import Data.CaseInsensitive
3831import Data.Char
39−import Data.Foldable
40− (toList)
41−import Data.Functor.Alt
42− (Alt (..))
43−import Data.Proxy
44− (Proxy (..))
45−import qualified Data.Sequence as Seq
32+import Data.Foldable (toList)
33+import Data.Functor.Alt (Alt (..))
34+import Data.IORef (modifyIORef, newIORef, readIORef)
35+import Data.Proxy (Proxy (..))
36+import qualified Data.Sequence as Seq
4637import Data.String.Conversions
47−import Data.Typeable
48− (Typeable)
38+import Data.Typeable (Typeable)
4939import Foreign.StablePtr
5040import GHC.Generics
51−import qualified GHCJS.Buffer as Buffer
41+import qualified GHCJS.Buffer as Buffer
5242import GHCJS.Foreign.Callback
5343import GHCJS.Prim
5444import GHCJS.Types
55−import JavaScript.TypedArray.ArrayBuffer
56− (ArrayBuffer)
45+import JavaScript.TypedArray.ArrayBuffer ( ArrayBuffer )
5746import JavaScript.Web.Location
58−import Network.HTTP.Media
59− (renderHeader)
47+import Network.HTTP.Media (renderHeader)
6048import Network.HTTP.Types
6149import Servant.Client.Core
62−import qualified Servant.Types.SourceT as S
6350
6451newtype JSXMLHttpRequest = JSXMLHttpRequest JSVal
6552
@@ -94,16 +81,16 @@ client api = api `clientIn` (Proxy :: Proxy ClientM)
9481--
9582-- NOTE: Does not support constant space streaming of the request body!
9683newtype ClientM a = ClientM
97− { runClientM' :: ReaderT ClientEnv (ExceptT ClientError IO) a }
84+ { runClientM' :: ReaderT ClientEnv (ExceptT ServantError IO) a }
9885 deriving ( Functor, Applicative, Monad, MonadIO, Generic
99− , MonadReader ClientEnv, MonadError ClientError, MonadThrow
86+ , MonadReader ClientEnv, MonadError ServantError, MonadThrow
10087 , MonadCatch)
10188
10289instance MonadBase IO ClientM where
10390 liftBase = ClientM . liftBase
10491
10592instance MonadBaseControl IO ClientM where
106− type StM ClientM a = Either ClientError a
93+ type StM ClientM a = Either ServantError a
10794
10895 liftBaseWith f = ClientM (liftBaseWith (\g -> f (g . runClientM')))
10996
@@ -120,13 +107,17 @@ instance Exception StreamingNotSupportedException where
120107 displayException _ = "streamingRequest: streaming is not supported!"
121108
122109instance RunClient ClientM where
123− runRequestAcceptStatus = performRequest
124− throwClientError = throwError
110+ runRequest = performRequest
111+ streamingRequest _ = liftIO $ throwIO StreamingNotSupportedException
112+ throwServantError = throwError
125113
126−runClientMOrigin :: ClientM a -> ClientEnv -> IO (Either ClientError a)
114+instance ClientLike (ClientM a) (ClientM a) where
115+ mkClient = id
116+
117+runClientMOrigin :: ClientM a -> ClientEnv -> IO (Either ServantError a)
127118runClientMOrigin cm env = runExceptT $ flip runReaderT env $ runClientM' cm
128119
129−runClientM :: ClientM a -> IO (Either ClientError a)
120+runClientM :: ClientM a -> IO (Either ServantError a)
130121runClientM m = do
131122 curLoc <- getWindowLocation
132123
@@ -152,20 +143,16 @@ runClientM m = do
152143
153144 runClientMOrigin m (ClientEnv (BaseUrl protocol hostname port ""))
154145
155−performRequest :: Maybe [Status] -> Request -> ClientM Response
156−performRequest acceptStatus req = do
146+performRequest :: Request -> ClientM Response
147+performRequest req = do
157148 xhr <- liftIO initXhr
158149 burl <- asks baseUrl
159150 liftIO $ performXhr xhr burl req
160151 resp <- toResponse xhr
161152
162− let status = responseStatusCode resp
163− goodStatus = case acceptStatus of
164− Nothing -> statusIsSuccessful status
165− Just good -> status `elem` good
166− unless goodStatus $ do
167− let f b = (burl, BL.toStrict $ toLazyByteString b)
168− throwError $ FailureResponse (bimap (const ()) f req) resp
153+ let status = statusCode (responseStatusCode resp)
154+ unless (status >= 200 && status < 300) $
155+ throwError $ FailureResponse resp
169156
170157 pure resp
171158
@@ -284,29 +271,38 @@ toBody request = case requestBody request of
284271 where
285272 go :: RequestBody -> IO ArrayBuffer
286273 go x = case x of
287− RequestBodyLBS x -> return $ mBody $ BL.toStrict x
288− RequestBodyBS x -> return $ mBody x
289− RequestBodySource xs -> runExceptT (S.runSourceT xs) >>= \e -> case e of
290− Left err -> fail err
291− Right bss -> return $ mBody $ BL.toStrict $ mconcat bss
274+ RequestBodyLBS x -> return $ mBody $ BL.toStrict x
275+ RequestBodyBS x -> return $ mBody x
276+ RequestBodyBuilder _ x -> return $ mBody $ BL.toStrict $ toLazyByteString x
277+ RequestBodyStream _ x -> mBody <$> readBody x
278+ RequestBodyStreamChunked x -> mBody <$> readBody x
279+ RequestBodyIO x -> x >>= go
292280
293281 mBody :: BS.ByteString -> ArrayBuffer
294282 mBody bs = js_bufferSlice offset len $ Buffer.getArrayBuffer buffer
295283 where
296284 (buffer, offset, len) = Buffer.fromByteString bs
297285
286+ readBody :: ((IO BS.ByteString -> IO ()) -> IO a) -> IO BS.ByteString
287+ readBody writer = do
288+ m <- newIORef mempty
289+ _ <- writer (\bsAct -> do
290+ bs <- bsAct
291+ modifyIORef m (<> bs))
292+ readIORef m
293+
298294foreign import javascript unsafe "$3.slice($1, $1 + $2)"
299295 js_bufferSlice :: Int -> Int -> ArrayBuffer -> ArrayBuffer
300296
301297-- * inspecting the xhr response
302298
303299-- This function is only supposed to handle 'ConnectionError's. Other
304−-- 'ClientError's are created in Servant.Client.Req.
300+-- 'ServantError's are created in Servant.Client.Req.
305301toResponse :: JSXMLHttpRequest -> ClientM Response
306302toResponse xhr = do
307303 status <- liftIO $ getStatus xhr
308304 case status of
309− 0 -> throwError $ ConnectionError (SomeException (userError "connection error"))
305+ 0 -> throwError $ ConnectionError "connection error"
310306 _ -> liftIO $ do
311307 statusText <- cs <$> getStatusText xhr
312308 headers <- parseHeaders <$> getAllResponseHeaders xhr
servant-client-ghcjs/tinc.yamlnew file+5
@@ -0,0 +1,5 @@
1+dependencies:
2+ - name: servant
3+ path: ../servant
4+ - name: servant-server
5+ path: ../servant-server
servant-client/CHANGELOG.md+2−238
@@ -1,242 +1,6 @@
11[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-client/CHANGELOG.md)
22[Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)
33
4−Package versions follow the [Package Versioning Policy](https://pvp.haskell.org/): in A.B.C, bumps to either A or B represent major versions.
5−
6−0.19
7−----
8−
9−### Significant changes
10−
11−- Drop support for GHC < 8.6.
12−- Support GHC 9.0 (GHC 9.2 should work as well, but isn't fully tested yet).
13−- Support Aeson 2 ([#1475](https://github.com/haskell-servant/servant/pull/1475)),
14− which fixes a [DOS vulnerability](https://github.com/haskell/aeson/issues/864)
15− related to hash collisions.
16−- Add `NamedRoutes` combinator, making support for records first-class in Servant
17− ([#1388](https://github.com/haskell-servant/servant/pull/1388)).
18−- Add custom type errors for partially applied combinators
19− ([#1289](https://github.com/haskell-servant/servant/pull/1289),
20− [#1486](https://github.com/haskell-servant/servant/pull/1486)).
21−- *servant-client* / *servant-client-core* / *servant-http-streams*: Fix
22− erroneous behavior, where only 2XX status codes would be considered
23− successful, irrelevant of the status parameter specified by the verb
24− combinator. ([#1469](https://github.com/haskell-servant/servant/pull/1469))
25−- *servant-client* / *servant-client-core*: Fix `Show` instance for
26− `Servant.Client.Core.Request`.
27−- *servant-client* / *servant-client-core*: Allow passing arbitrary binary data
28− in Query parameters.
29− ([#1432](https://github.com/haskell-servant/servant/pull/1432)).
30−
31−### Other changes
32−
33−- Various version bumps.
34−
35−0.18.3
36−------
37−
38−### Significant changes
39−
40−- Add response header support to UVerb (#1420)
41−
42−### Other changes
43−
44−- Support GHC-9.0.1.
45−- Bump `bytestring`, `hspec`, `http-client` and `QuickCheck` dependencies.
46−
47−0.18.2
48−------
49−
50−### Significant changes
51−
52−- Support `Fragment` combinator.
53−
54−0.18.1
55−------
56−
57−### Significant changes
58−
59−- Union verbs
60−
61−### Other changes
62−
63−- Bump "tested-with" ghc versions
64−
65−0.18
66−----
67−
68−### Significant changes
69−
70−- Support for ghc8.8 (#1318, #1326, #1327)
71−
72−
73−0.17
74−----
75−
76−### Significant changes
77−
78−- Add NoContentVerb [#1028](https://github.com/haskell-servant/servant/issues/1028) [#1219](https://github.com/haskell-servant/servant/pull/1219) [#1228](https://github.com/haskell-servant/servant/pull/1228)
79−
80− The `NoContent` API endpoints should now use `NoContentVerb` combinator.
81− The API type changes are usually of the kind
82−
83− ```diff
84− - :<|> PostNoContent '[JSON] NoContent
85− + :<|> PostNoContent
86− ```
87−
88− i.e. one doesn't need to specify the content-type anymore. There is no content.
89−
90−- `Capture` can be `Lenient` [#1155](https://github.com/haskell-servant/servant/issues/1155) [#1156](https://github.com/haskell-servant/servant/pull/1156)
91−
92− You can specify a lenient capture as
93−
94− ```haskell
95− :<|> "capture-lenient" :> Capture' '[Lenient] "foo" Int :> GET
96− ```
97−
98− which will make the capture always succeed. Handlers will be of the
99− type `Either String CapturedType`, where `Left err` represents
100− the possible parse failure.
101−
102−- *servant-client* Added a function to create Client.Request in ClientEnv [#1213](https://github.com/haskell-servant/servant/pull/1213) [#1255](https://github.com/haskell-servant/servant/pull/1255)
103−
104− The new member `makeClientRequest` of `ClientEnv` is used to create
105− `http-client` `Request` from `servant-client-core` `Request`.
106− This functionality can be used for example to set
107− dynamic timeouts for each request.
108−
109−### Other changes
110−
111−- *servant-client* *servant-client-core* *servant-http-streams* Fix Verb with headers checking content type differently [#1200](https://github.com/haskell-servant/servant/issues/1200) [#1204](https://github.com/haskell-servant/servant/pull/1204)
112−
113− For `Verb`s with response `Headers`, the implementation didn't check
114− for the content-type of the response. Now it does.
115−
116−- *servant-client* *servant-http-streams* `HasClient` instance for `Stream` with `Headers` [#1170](https://github.com/haskell-servant/servant/issues/1170) [#1197](https://github.com/haskell-servant/servant/pull/1197)
117−- *servant-client* Redact the authorization header in Show and exceptions [#1238](https://github.com/haskell-servant/servant/pull/1238)
118−
119−
120−
121−0.16.0.1
122−--------
123−
124−- Allow `base-compat-0.11`
125−
126−0.16
127−----
128−
129−- Rename `ServantError` to `ClientError`, `ServantErr` to `ServerError`
130− [#1131](https://github.com/haskell-servant/servant/pull/1131)
131−
132−- *servant-client-core* Rearrange modules. No more `Internal` modules, whole
133− API is versioned.
134− [#1130](https://github.com/haskell-servant/servant/pull/1130)
135−
136−- *servant-client-core* `RequestBody` is now
137−
138− ```haskell
139− = RequestBodyLBS LBS.ByteString
140− | RequestBodyBS BS.ByteString
141− | RequestBodySource (SourceIO LBS.ByteString)
142− ```
143−
144− i.e. no more replicates `http-client`s API.
145− [#1117](https://github.com/haskell-servant/servant/pull/1117)
146−
147−- *servant-client-core* Keep structured exceptions in `ConnectionError`
148− constructor of `ClientError`
149− [#1115](https://github.com/haskell-servant/servant/pull/1115)
150−
151− ```diff
152− -| ConnectionError Text
153− +| ConnectionError SomeException
154− ```
155−
156−- *servant-client-core* Preserve failing request in `FailureResponse`
157− constructor of `ClientError`
158− [#1114](https://github.com/haskell-servant/servant/pull/1114)
159−
160− ```diff
161− -FailureResponse Response
162− +-- | The server returned an error response including the
163− +-- failing request. 'requestPath' includes the 'BaseUrl' and the
164− +-- path of the request.
165− +FailureResponse (RequestF () (BaseUrl, BS.ByteString)) Response
166− ```
167−
168−- *servant-client* Fix (implement) `StreamBody` instance
169− [#1110](https://github.com/haskell-servant/servant/pull/1110)
170−
171−- *servant-client* Update CookieJar with intermediate request/responses (redirects)
172− [#1104](https://github.com/haskell-servant/servant/pull/1104)
173−
174−0.15
175−----
176−
177−- Streaming refactoring.
178− [#991](https://github.com/haskell-servant/servant/pull/991)
179− [#1076](https://github.com/haskell-servant/servant/pull/1076)
180− [#1077](https://github.com/haskell-servant/servant/pull/1077)
181−
182− The streaming functionality (`Servant.API.Stream`) is refactored to use
183− `servant`'s own `SourceIO` type (see `Servant.Types.SourceT` documentation),
184− which replaces both `StreamGenerator` and `ResultStream` types.
185−
186− New conversion type-classes are `ToSourceIO` and `FromSourceIO`
187− (replacing `ToStreamGenerator` and `BuildFromStream`).
188− There are instances for *conduit*, *pipes* and *machines* in new packages:
189− [servant-conduit](https://hackage.haskell.org/package/servant-conduit)
190− [servant-pipes](https://hackage.haskell.org/package/servant-pipes) and
191− [servant-machines](https://hackage.haskell.org/package/servant-machines)
192− respectively.
193−
194− Writing new framing strategies is simpler. Check existing strategies for examples.
195−
196− This change shouldn't affect you, if you don't use streaming endpoints.
197−
198−- *servant-client* Separate streaming client.
199− [#1066](https://github.com/haskell-servant/servant/pull/1066)
200−
201− We now have two `http-client` based clients,
202− in `Servant.Client` and `Servant.Client.Streaming`.
203−
204− Their API is the same, except for
205− - `Servant.Client` **cannot** request `Stream` endpoints.
206− - `Servant.Client` is *run* by direct
207− `runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a)`
208− - `Servant.Client.Streaming` **can** request `Stream` endpoints.
209− - `Servant.Client.Streaming` is *used* by CPSised
210− `withClientM :: ClientM a -> ClientEnv -> (Either ServantError a -> IO b) -> IO b`
211−
212− To access `Stream` endpoints use `Servant.Client.Streaming` with
213− `withClientM`; otherwise you can continue using `Servant.Client` with `runClientM`.
214− You can use both too, `ClientEnv` and `BaseUrl` types are same for both.
215−
216− **Note:** `Servant.Client.Streaming` doesn't *stream* non-`Stream` endpoints.
217− Requesting ordinary `Verb` endpoints (e.g. `Get`) will block until
218− the whole response is received.
219−
220− There is `Servant.Client.Streaming.runClientM` function, but it has
221− restricted type. `NFData a` constraint prevents using it with
222− `SourceT`, `Conduit` etc. response types.
223−
224− ```haskell
225− runClientM :: NFData a => ClientM a -> ClientEnv -> IO (Either ServantError a)
226− ```
227−
228− This change shouldn't affect you, if you don't use streaming endpoints.
229−
230−- Drop support for GHC older than 8.0
231− [#1008](https://github.com/haskell-servant/servant/pull/1008)
232− [#1009](https://github.com/haskell-servant/servant/pull/1009)
233−
234−- *servant-client-core* Add `NFData (GenResponse a)` and `NFData ServantError` instances.
235− [#1076](https://github.com/haskell-servant/servant/pull/1076)
236−
237− *servant-client-core* Add `aeson` and `Lift BaseUrl` instances
238− [#1037](https://github.com/haskell-servant/servant/pull/1037)
239−
24040.14
2415----
2426
@@ -267,9 +31,9 @@ Package versions follow the [Package Versioning Policy](https://pvp.haskell.org/
26731
26832- *servant-client-core* Add `hoistClient` to `HasClient`.
26933 Just like `hoistServer` allows us to change the monad in which request handlers
270− of a web application live, we also have `hoistClient` for changing the monad
34+ of a web application live in, we also have `hoistClient` for changing the monad
27135 in which *client functions* live.
272− Read [tutorial section for more information](https://docs.servant.dev/en/release-0.14/tutorial/Client.html#changing-the-monad-the-client-functions-live-in).
36+ Read [tutorial section for more information](https://haskell-servant.readthedocs.io/en/release-0.14/tutorial/Client.html#changing-the-monad-the-client-functions-live-in).
27337 ([#936](https://github.com/haskell-servant/servant/pull/936))
27438
27539- *servant-client* Add more constructors to `RequestBody`, including
servant-client/LICENSE+1−1
@@ -1,4 +1,4 @@
1−Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, 2016-2018 Servant Contributors
1+Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, Servant Contributors
22
33All rights reserved.
44
servant-client/servant-client.cabal+43−69
@@ -1,32 +1,31 @@
1−cabal-version: 2.2
21name: servant-client
3−version: 0.19
4−
5−synopsis: Automatic derivation of querying functions for servant
6−category: Servant, Web
2+version: 0.14
3+synopsis: automatical derivation of querying functions for servant webservices
74description:
85 This library lets you derive automatically Haskell functions that
96 let you query each endpoint of a <http://hackage.haskell.org/package/servant servant> webservice.
107 .
11− See <http://docs.servant.dev/en/stable/tutorial/Client.html the client section of the tutorial>.
8+ See <http://haskell-servant.readthedocs.org/en/stable/tutorial/Client.html the client section of the tutorial>.
129 .
1310 <https://github.com/haskell-servant/servant/blob/master/servant-client/CHANGELOG.md CHANGELOG>
14−
15−homepage: http://docs.servant.dev/
16−bug-reports: http://github.com/haskell-servant/servant/issues
17−license: BSD-3-Clause
11+license: BSD3
1812license-file: LICENSE
1913author: Servant Contributors
2014maintainer: haskell-servant-maintainers@googlegroups.com
21−copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors
15+copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2017 Servant Contributors
16+category: Servant, Web
2217build-type: Simple
23−tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1
24− , GHCJS ==8.6.0.1
25−
18+cabal-version: >=1.10
19+tested-with:
20+ GHC==8.0.2
21+ GHC==8.2.2
22+ GHC==8.4.4
23+ GHC==8.6.1
24+homepage: http://haskell-servant.readthedocs.org/
25+Bug-reports: http://github.com/haskell-servant/servant/issues
2626extra-source-files:
2727 CHANGELOG.md
2828 README.md
29−
3029source-repository head
3130 type: git
3231 location: http://github.com/haskell-servant/servant.git
@@ -34,46 +33,38 @@ source-repository head
3433library
3534 exposed-modules:
3635 Servant.Client
37− Servant.Client.Streaming
3836 Servant.Client.Internal.HttpClient
39− Servant.Client.Internal.HttpClient.Streaming
4037
4138 -- Bundled with GHC: Lower bound to not force re-installs
4239 -- text and mtl are bundled starting with GHC-8.4
40+ --
41+ -- note: mtl lower bound is so low because of GHC-7.8
4342 build-depends:
44− base >= 4.9 && < 4.18
45− , bytestring >= 0.10.8.1 && < 0.12
46− , containers >= 0.5.7.1 && < 0.7
47− , deepseq >= 1.4.2.0 && < 1.5
48− , mtl ^>= 2.2.2 || ^>= 2.3.1
49− , stm >= 2.4.5.1 && < 2.6
50− , text >= 1.2.3.0 && < 2.1
51− , time >= 1.6.0.1 && < 1.13
52− , transformers >= 0.5.2.0 && < 0.7
53−
54− if !impl(ghc >= 8.2)
55− build-depends:
56− bifunctors >= 5.5.3 && < 5.6
43+ base >= 4.7 && < 4.13
44+ , bytestring >= 0.10.4.0 && < 0.11
45+ , containers >= 0.5.5.1 && < 0.7
46+ , mtl >= 2.1 && < 2.3
47+ , text >= 1.2.3.0 && < 1.3
48+ , time >= 1.4.2 && < 1.9
49+ , transformers >= 0.3.0.0 && < 0.6
5750
58− -- Servant dependencies.
59− -- Strict dependency on `servant-client-core` as we re-export things.
51+ -- Servant dependencies
6052 build-depends:
61− servant >= 0.18 && < 0.20
62− , servant-client-core >= 0.19 && < 0.19.1
53+ servant-client-core == 0.14.*
6354
6455 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.
6556 -- Here can be exceptions if we really need features from the newer versions.
6657 build-depends:
67− base-compat >= 0.10.5 && < 0.13
68− , http-client >= 0.5.13.1 && < 0.8
69− , http-media >= 0.7.1.3 && < 0.9
70− , http-types >= 0.12.2 && < 0.13
58+ base-compat >= 0.10.1 && < 0.11
59+ , http-client >= 0.5.12 && < 0.6
60+ , http-media >= 0.7.1.2 && < 0.8
61+ , http-types >= 0.12.1 && < 0.13
7162 , exceptions >= 0.10.0 && < 0.11
72− , kan-extensions >= 5.2 && < 5.3
7363 , monad-control >= 1.0.2.3 && < 1.1
74− , semigroupoids >= 5.3.1 && < 5.4
64+ , semigroupoids >= 5.2.2 && < 5.4
65+ , stm >= 2.4.5.0 && < 2.6
7566 , transformers-base >= 0.4.5.2 && < 0.5
76− , transformers-compat >= 0.6.2 && < 0.8
67+ , transformers-compat >= 0.6.2 && < 0.7
7768
7869 hs-source-dirs: src
7970 default-language: Haskell2010
@@ -81,24 +72,13 @@ library
8172
8273test-suite spec
8374 type: exitcode-stdio-1.0
84− ghc-options: -Wall -rtsopts -threaded "-with-rtsopts=-T -N2"
75+ ghc-options: -Wall -rtsopts -with-rtsopts=-T
8576 default-language: Haskell2010
86− if impl(ghcjs)
87− buildable: False
8877 hs-source-dirs: test
8978 main-is: Spec.hs
9079 other-modules:
91− Servant.BasicAuthSpec
92− Servant.BrokenSpec
93− Servant.ClientTestUtils
94− Servant.ConnectionErrorSpec
95− Servant.FailSpec
96− Servant.GenAuthSpec
97− Servant.GenericSpec
98− Servant.HoistClientSpec
80+ Servant.ClientSpec
9981 Servant.StreamSpec
100− Servant.SuccessSpec
101− Servant.WrappedApiSpec
10282
10383 -- Dependencies inherited from the library. No need to specify bounds.
10484 build-depends:
@@ -110,30 +90,26 @@ test-suite spec
11090 , http-client
11191 , http-types
11292 , mtl
113− , kan-extensions
11493 , servant-client
11594 , servant-client-core
116− , sop-core
117− , stm
11895 , text
11996 , transformers
12097 , transformers-compat
12198 , wai
12299 , warp
123100
124− -- Additional dependencies
101+ -- Additonal dependencies
125102 build-depends:
126− entropy >= 0.4.1.3 && < 0.5
127− , hspec >= 2.6.0 && < 2.10
128− , HUnit >= 1.6.0.0 && < 1.7
129− , network >= 2.8.0.0 && < 3.2
130− , QuickCheck >= 2.12.6.1 && < 2.15
131− , servant == 0.19.*
132− , servant-server == 0.19.*
133− , tdigest >= 0.2 && < 0.3
103+ generics-sop >= 0.4.0.1 && < 0.5
104+ , hspec >= 2.5.1 && < 2.6
105+ , HUnit >= 1.6 && < 1.7
106+ , network >= 2.8.0.0 && < 2.9
107+ , QuickCheck >= 2.12.6.1 && < 2.13
108+ , servant == 0.14.*
109+ , servant-server == 0.14.*
134110
135111 build-tool-depends:
136− hspec-discover:hspec-discover >= 2.6.0 && < 2.10
112+ hspec-discover:hspec-discover >= 2.5.1 && < 2.6
137113
138114test-suite readme
139115 type: exitcode-stdio-1.0
@@ -142,5 +118,3 @@ test-suite readme
142118 build-tool-depends: markdown-unlit:markdown-unlit
143119 ghc-options: -pgmL markdown-unlit
144120 default-language: Haskell2010
145− if impl(ghcjs)
146− buildable: False
servant-client/src/Servant/Client.hs−1
@@ -9,7 +9,6 @@ module Servant.Client
99 , runClientM
1010 , ClientEnv(..)
1111 , mkClientEnv
12− , defaultMakeClientRequest
1312 , hoistClient
1413 , module Servant.Client.Core.Reexport
1514 ) where
servant-client/src/Servant/Client/Internal/HttpClient.hs+90−148
@@ -14,83 +14,61 @@ module Servant.Client.Internal.HttpClient where
1414import Prelude ()
1515import Prelude.Compat
1616
17−import Control.Concurrent.MVar
18− (modifyMVar, newMVar)
1917import Control.Concurrent.STM.TVar
2018import Control.Exception
21− (SomeException (..), catch)
2219import Control.Monad
23− (unless)
2420import Control.Monad.Base
2521 (MonadBase (..))
2622import Control.Monad.Catch
27− (MonadCatch, MonadThrow, MonadMask)
23+ (MonadCatch, MonadThrow)
2824import Control.Monad.Error.Class
2925 (MonadError (..))
30−import Control.Monad.IO.Class
31− (MonadIO (..))
3226import Control.Monad.Reader
33− (MonadReader, ReaderT, ask, runReaderT)
3427import Control.Monad.STM
35− (STM, atomically)
28+ (atomically)
3629import Control.Monad.Trans.Control
3730 (MonadBaseControl (..))
3831import Control.Monad.Trans.Except
39− (ExceptT, runExceptT)
40−import Data.Bifunctor
41− (bimap)
42−import qualified Data.ByteString as BS
4332import Data.ByteString.Builder
4433 (toLazyByteString)
4534import qualified Data.ByteString.Lazy as BSL
46−import Data.Either
47− (either)
4835import Data.Foldable
49− (foldl',toList)
36+ (for_, toList)
5037import Data.Functor.Alt
5138 (Alt (..))
5239import Data.Maybe
53− (maybe, maybeToList)
40+ (maybeToList)
5441import Data.Proxy
5542 (Proxy (..))
43+import Data.Semigroup
44+ ((<>))
5645import Data.Sequence
5746 (fromList)
5847import Data.String
5948 (fromString)
49+import qualified Data.Text as T
6050import Data.Time.Clock
61− (UTCTime, getCurrentTime)
51+ (getCurrentTime)
6252import GHC.Generics
6353import Network.HTTP.Media
6454 (renderHeader)
6555import Network.HTTP.Types
66− (hContentType, renderQuery, statusIsSuccessful, urlEncode, Status)
56+ (hContentType, renderQuery, statusCode)
6757import Servant.Client.Core
6858
6959import qualified Network.HTTP.Client as Client
70−import qualified Servant.Types.SourceT as S
7160
7261-- | The environment in which a request is run.
73−-- The 'baseUrl' and 'makeClientRequest' function are used to create a @http-client@ request.
74−-- Cookies are then added to that request if a 'CookieJar' is set on the environment.
75−-- Finally the request is executed with the 'manager'.
76−-- The 'makeClientRequest' function can be used to modify the request to execute and set values which
77−-- are not specified on a @servant@ 'Request' like 'responseTimeout' or 'redirectCount'
7862data ClientEnv
7963 = ClientEnv
8064 { manager :: Client.Manager
8165 , baseUrl :: BaseUrl
8266 , cookieJar :: Maybe (TVar Client.CookieJar)
83− , makeClientRequest :: BaseUrl -> Request -> IO Client.Request
84− -- ^ this function can be used to customize the creation of @http-client@ requests from @servant@ requests. Default value: 'defaultMakeClientRequest'
85− -- Note that:
86− -- 1. 'makeClientRequest' exists to allow overriding operational semantics e.g. 'responseTimeout' per request,
87− -- If you need global modifications, you should use 'managerModifyRequest'
88− -- 2. the 'cookieJar', if defined, is being applied after 'makeClientRequest' is called.
8967 }
9068
9169-- | 'ClientEnv' smart constructor.
9270mkClientEnv :: Client.Manager -> BaseUrl -> ClientEnv
93−mkClientEnv mgr burl = ClientEnv mgr burl Nothing defaultMakeClientRequest
71+mkClientEnv mgr burl = ClientEnv mgr burl Nothing
9472
9573-- | Generates a set of client functions for an API.
9674--
@@ -133,16 +111,16 @@ hoistClient = hoistClientMonad (Proxy :: Proxy ClientM)
133111-- | @ClientM@ is the monad in which client functions run. Contains the
134112-- 'Client.Manager' and 'BaseUrl' used for requests in the reader environment.
135113newtype ClientM a = ClientM
136− { unClientM :: ReaderT ClientEnv (ExceptT ClientError IO) a }
114+ { unClientM :: ReaderT ClientEnv (ExceptT ServantError IO) a }
137115 deriving ( Functor, Applicative, Monad, MonadIO, Generic
138− , MonadReader ClientEnv, MonadError ClientError, MonadThrow
139− , MonadCatch, MonadMask)
116+ , MonadReader ClientEnv, MonadError ServantError, MonadThrow
117+ , MonadCatch)
140118
141119instance MonadBase IO ClientM where
142120 liftBase = ClientM . liftBase
143121
144122instance MonadBaseControl IO ClientM where
145− type StM ClientM a = Either ClientError a
123+ type StM ClientM a = Either ServantError a
146124
147125 liftBaseWith f = ClientM (liftBaseWith (\g -> f (g . unClientM)))
148126
@@ -153,16 +131,20 @@ instance Alt ClientM where
153131 a <!> b = a `catchError` \_ -> b
154132
155133instance RunClient ClientM where
156− runRequestAcceptStatus = performRequest
157− throwClientError = throwError
134+ runRequest = performRequest
135+ streamingRequest = performStreamingRequest
136+ throwServantError = throwError
158137
159−runClientM :: ClientM a -> ClientEnv -> IO (Either ClientError a)
138+instance ClientLike (ClientM a) (ClientM a) where
139+ mkClient = id
140+
141+runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a)
160142runClientM cm env = runExceptT $ flip runReaderT env $ unClientM cm
161143
162−performRequest :: Maybe [Status] -> Request -> ClientM Response
163−performRequest acceptStatus req = do
164− ClientEnv m burl cookieJar' createClientRequest <- ask
165− clientRequest <- liftIO $ createClientRequest burl req
144+performRequest :: Request -> ClientM Response
145+performRequest req = do
146+ ClientEnv m burl cookieJar' <- ask
147+ let clientRequest = requestToClientRequest burl req
166148 request <- case cookieJar' of
167149 Nothing -> pure clientRequest
168150 Just cj -> liftIO $ do
@@ -171,82 +153,67 @@ performRequest acceptStatus req = do
171153 oldCookieJar <- readTVar cj
172154 let (newRequest, newCookieJar) =
173155 Client.insertCookiesIntoRequest
174− clientRequest
156+ (requestToClientRequest burl req)
175157 oldCookieJar
176158 now
177159 writeTVar cj newCookieJar
178160 pure newRequest
179161
180− response <- maybe (requestWithoutCookieJar m request) (requestWithCookieJar m request) cookieJar'
181− let status = Client.responseStatus response
182− ourResponse = clientResponseToResponse id response
183− goodStatus = case acceptStatus of
184− Nothing -> statusIsSuccessful status
185− Just good -> status `elem` good
186− unless goodStatus $ do
187− throwError $ mkFailureResponse burl req ourResponse
188− return ourResponse
189− where
190− requestWithoutCookieJar :: Client.Manager -> Client.Request -> ClientM (Client.Response BSL.ByteString)
191− requestWithoutCookieJar m' request' = do
192− eResponse <- liftIO . catchConnectionError $ Client.httpLbs request' m'
193− either throwError return eResponse
194−
195− requestWithCookieJar :: Client.Manager -> Client.Request -> TVar Client.CookieJar -> ClientM (Client.Response BSL.ByteString)
196− requestWithCookieJar m' request' cj = do
197− eResponse <- liftIO . catchConnectionError . Client.withResponseHistory request' m' $ updateWithResponseCookies cj
198− either throwError return eResponse
199−
200− updateWithResponseCookies :: TVar Client.CookieJar -> Client.HistoriedResponse Client.BodyReader -> IO (Client.Response BSL.ByteString)
201− updateWithResponseCookies cj responses = do
202− now <- getCurrentTime
203− bss <- Client.brConsume $ Client.responseBody fRes
204− let fRes' = fRes { Client.responseBody = BSL.fromChunks bss }
205− allResponses = Client.hrRedirects responses <> [(fReq, fRes')]
206− atomically $ mapM_ (updateCookieJar now) allResponses
207− return fRes'
208− where
209− updateCookieJar :: UTCTime -> (Client.Request, Client.Response BSL.ByteString) -> STM ()
210− updateCookieJar now' (req', res') = modifyTVar' cj (fst . Client.updateCookieJar res' req' now')
211−
212− fReq = Client.hrFinalRequest responses
213− fRes = Client.hrFinalResponse responses
214−
215−mkFailureResponse :: BaseUrl -> Request -> ResponseF BSL.ByteString -> ClientError
216−mkFailureResponse burl request =
217− FailureResponse (bimap (const ()) f request)
218− where
219− f b = (burl, BSL.toStrict $ toLazyByteString b)
220−
221−clientResponseToResponse :: (a -> b) -> Client.Response a -> ResponseF b
222−clientResponseToResponse f r = Response
223− { responseStatusCode = Client.responseStatus r
224− , responseBody = f (Client.responseBody r)
225− , responseHeaders = fromList $ Client.responseHeaders r
226− , responseHttpVersion = Client.responseVersion r
227− }
162+ eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request m
163+ case eResponse of
164+ Left err -> throwError err
165+ Right response -> do
166+ for_ cookieJar' $ \cj -> liftIO $ do
167+ now' <- getCurrentTime
168+ atomically $ modifyTVar' cj (fst . Client.updateCookieJar response request now')
169+ let status = Client.responseStatus response
170+ status_code = statusCode status
171+ ourResponse = clientResponseToResponse response
172+ unless (status_code >= 200 && status_code < 300) $
173+ throwError $ FailureResponse ourResponse
174+ return ourResponse
175+
176+performStreamingRequest :: Request -> ClientM StreamingResponse
177+performStreamingRequest req = do
178+ m <- asks manager
179+ burl <- asks baseUrl
180+ let request = requestToClientRequest burl req
181+ return $ StreamingResponse $
182+ \k -> Client.withResponse request m $
183+ \r -> do
184+ let status = Client.responseStatus r
185+ status_code = statusCode status
186+ unless (status_code >= 200 && status_code < 300) $ do
187+ b <- BSL.fromChunks <$> Client.brConsume (Client.responseBody r)
188+ throw $ FailureResponse $ clientResponseToResponse r { Client.responseBody = b }
189+ k (clientResponseToResponse r)
190+
191+clientResponseToResponse :: Client.Response a -> GenResponse a
192+clientResponseToResponse r = Response
193+ { responseStatusCode = Client.responseStatus r
194+ , responseBody = Client.responseBody r
195+ , responseHeaders = fromList $ Client.responseHeaders r
196+ , responseHttpVersion = Client.responseVersion r
197+ }
228198
229−-- | Create a @http-client@ 'Client.Request' from a @servant@ 'Request'
230−-- The 'Client.host', 'Client.path' and 'Client.port' fields are extracted from the 'BaseUrl'
231−-- otherwise the body, headers and query string are derived from the @servant@ 'Request'
232−defaultMakeClientRequest :: BaseUrl -> Request -> IO Client.Request
233−defaultMakeClientRequest burl r = return Client.defaultRequest
234− { Client.method = requestMethod r
235− , Client.host = fromString $ baseUrlHost burl
236− , Client.port = baseUrlPort burl
237− , Client.path = BSL.toStrict
238− $ fromString (baseUrlPath burl)
239− <> toLazyByteString (requestPath r)
240− , Client.queryString = buildQueryString . toList $ requestQueryString r
241− , Client.requestHeaders =
242− maybeToList acceptHdr ++ maybeToList contentTypeHdr ++ headers
243− , Client.requestBody = body
244− , Client.secure = isSecure
245− }
199+requestToClientRequest :: BaseUrl -> Request -> Client.Request
200+requestToClientRequest burl r = Client.defaultRequest
201+ { Client.method = requestMethod r
202+ , Client.host = fromString $ baseUrlHost burl
203+ , Client.port = baseUrlPort burl
204+ , Client.path = BSL.toStrict
205+ $ fromString (baseUrlPath burl)
206+ <> toLazyByteString (requestPath r)
207+ , Client.queryString = renderQuery True . toList $ requestQueryString r
208+ , Client.requestHeaders =
209+ maybeToList acceptHdr ++ maybeToList contentTypeHdr ++ headers
210+ , Client.requestBody = body
211+ , Client.secure = isSecure
212+ }
246213 where
247214 -- Content-Type and Accept are specified by requestBody and requestAccept
248215 headers = filter (\(h, _) -> h /= "Accept" && h /= "Content-Type") $
249− toList $ requestHeaders r
216+ toList $requestHeaders r
250217
251218 acceptHdr
252219 | null hs = Nothing
@@ -255,48 +222,23 @@ defaultMakeClientRequest burl r = return Client.defaultRequest
255222 hs = toList $ requestAccept r
256223
257224 convertBody bd = case bd of
258− RequestBodyLBS body' -> Client.RequestBodyLBS body'
259− RequestBodyBS body' -> Client.RequestBodyBS body'
260− RequestBodySource sourceIO -> Client.RequestBodyStreamChunked givesPopper
261− where
262− givesPopper :: (IO BS.ByteString -> IO ()) -> IO ()
263− givesPopper needsPopper = S.unSourceT sourceIO $ \step0 -> do
264− ref <- newMVar step0
265−
266− -- Note sure we need locking, but it's feels safer.
267− let popper :: IO BS.ByteString
268− popper = modifyMVar ref nextBs
269−
270− needsPopper popper
271−
272− nextBs S.Stop = return (S.Stop, BS.empty)
273− nextBs (S.Error err) = fail err
274− nextBs (S.Skip s) = nextBs s
275− nextBs (S.Effect ms) = ms >>= nextBs
276− nextBs (S.Yield lbs s) = case BSL.toChunks lbs of
277− [] -> nextBs s
278− (x:xs) | BS.null x -> nextBs step'
279− | otherwise -> return (step', x)
280− where
281− step' = S.Yield (BSL.fromChunks xs) s
225+ RequestBodyLBS body' -> Client.RequestBodyLBS body'
226+ RequestBodyBS body' -> Client.RequestBodyBS body'
227+ RequestBodyBuilder size body' -> Client.RequestBodyBuilder size body'
228+ RequestBodyStream size body' -> Client.RequestBodyStream size body'
229+ RequestBodyStreamChunked body' -> Client.RequestBodyStreamChunked body'
230+ RequestBodyIO body' -> Client.RequestBodyIO (convertBody <$> body')
282231
283232 (body, contentTypeHdr) = case requestBody r of
284− Nothing -> (Client.RequestBodyBS "", Nothing)
285− Just (body', typ) -> (convertBody body', Just (hContentType, renderHeader typ))
233+ Nothing -> (Client.RequestBodyLBS "", Nothing)
234+ Just (body', typ)
235+ -> (convertBody body', Just (hContentType, renderHeader typ))
286236
287237 isSecure = case baseUrlScheme burl of
288− Http -> False
289− Https -> True
290−
291− -- Query string builder which does not do any encoding
292− buildQueryString [] = mempty
293− buildQueryString qps = "?" <> foldl' addQueryParam mempty qps
294−
295− addQueryParam qs (k, v) =
296− qs <> (if BS.null qs then mempty else "&") <> urlEncode True k <> foldMap ("=" <>) v
297−
238+ Http -> False
239+ Https -> True
298240
299−catchConnectionError :: IO a -> IO (Either ClientError a)
241+catchConnectionError :: IO a -> IO (Either ServantError a)
300242catchConnectionError action =
301243 catch (Right <$> action) $ \e ->
302− pure . Left . ConnectionError $ SomeException (e :: Client.HttpException)
244+ pure . Left . ConnectionError . T.pack $ show (e :: Client.HttpException)
servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hsdeleted−203
@@ -1,203 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE DeriveGeneric #-}
3−{-# LANGUAGE FlexibleContexts #-}
4−{-# LANGUAGE FlexibleInstances #-}
5−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6−{-# LANGUAGE MultiParamTypeClasses #-}
7−{-# LANGUAGE RankNTypes #-}
8−{-# LANGUAGE ScopedTypeVariables #-}
9−{-# LANGUAGE TypeFamilies #-}
10−module Servant.Client.Internal.HttpClient.Streaming (
11− module Servant.Client.Internal.HttpClient.Streaming,
12− ClientEnv (..),
13− mkClientEnv,
14− clientResponseToResponse,
15− defaultMakeClientRequest,
16− catchConnectionError,
17− ) where
18−
19−import Prelude ()
20−import Prelude.Compat
21−
22−import Control.Concurrent.STM.TVar
23−import Control.DeepSeq
24− (NFData, force)
25−import Control.Exception
26− (evaluate, throwIO)
27−import Control.Monad
28− (unless)
29−import Control.Monad.Base
30− (MonadBase (..))
31−import Control.Monad.Codensity
32− (Codensity (..))
33−import Control.Monad.Error.Class
34− (MonadError (..))
35−import Control.Monad.Reader
36−import Control.Monad.STM
37− (atomically)
38−import Control.Monad.Trans.Except
39−import qualified Data.ByteString as BS
40−import qualified Data.ByteString.Lazy as BSL
41−import Data.Foldable
42− (for_)
43−import Data.Functor.Alt
44− (Alt (..))
45−import Data.Proxy
46− (Proxy (..))
47−import Data.Time.Clock
48− (getCurrentTime)
49−import GHC.Generics
50−import Network.HTTP.Types
51− (Status, statusIsSuccessful)
52−
53−import qualified Network.HTTP.Client as Client
54−
55−import Servant.Client.Core
56−import Servant.Client.Internal.HttpClient
57− (ClientEnv (..), catchConnectionError,
58− clientResponseToResponse, mkClientEnv, mkFailureResponse,
59− defaultMakeClientRequest)
60−import qualified Servant.Types.SourceT as S
61−
62−
63−-- | Generates a set of client functions for an API.
64−--
65−-- Example:
66−--
67−-- > type API = Capture "no" Int :> Get '[JSON] Int
68−-- > :<|> Get '[JSON] [Bool]
69−-- >
70−-- > api :: Proxy API
71−-- > api = Proxy
72−-- >
73−-- > getInt :: Int -> ClientM Int
74−-- > getBools :: ClientM [Bool]
75−-- > getInt :<|> getBools = client api
76−client :: HasClient ClientM api => Proxy api -> Client ClientM api
77−client api = api `clientIn` (Proxy :: Proxy ClientM)
78−
79−-- | Change the monad the client functions live in, by
80−-- supplying a conversion function
81−-- (a natural transformation to be precise).
82−--
83−-- For example, assuming you have some @manager :: 'Manager'@ and
84−-- @baseurl :: 'BaseUrl'@ around:
85−--
86−-- > type API = Get '[JSON] Int :<|> Capture "n" Int :> Post '[JSON] Int
87−-- > api :: Proxy API
88−-- > api = Proxy
89−-- > getInt :: IO Int
90−-- > postInt :: Int -> IO Int
91−-- > getInt :<|> postInt = hoistClient api (flip runClientM cenv) (client api)
92−-- > where cenv = mkClientEnv manager baseurl
93−hoistClient
94− :: HasClient ClientM api
95− => Proxy api
96− -> (forall a. m a -> n a)
97− -> Client m api
98− -> Client n api
99−hoistClient = hoistClientMonad (Proxy :: Proxy ClientM)
100−
101−-- | @ClientM@ is the monad in which client functions run. Contains the
102−-- 'Client.Manager' and 'BaseUrl' used for requests in the reader environment.
103−newtype ClientM a = ClientM
104− { unClientM :: ReaderT ClientEnv (ExceptT ClientError (Codensity IO)) a }
105− deriving ( Functor, Applicative, Monad, MonadIO, Generic
106− , MonadReader ClientEnv, MonadError ClientError)
107−
108−instance MonadBase IO ClientM where
109− liftBase = ClientM . liftIO
110−
111−-- | Try clients in order, last error is preserved.
112−instance Alt ClientM where
113− a <!> b = a `catchError` \_ -> b
114−
115−instance RunClient ClientM where
116− runRequestAcceptStatus = performRequest
117− throwClientError = throwError
118−
119−instance RunStreamingClient ClientM where
120− withStreamingRequest = performWithStreamingRequest
121−
122−withClientM :: ClientM a -> ClientEnv -> (Either ClientError a -> IO b) -> IO b
123−withClientM cm env k =
124− let Codensity f = runExceptT $ flip runReaderT env $ unClientM cm
125− in f k
126−
127−-- | A 'runClientM' variant for streaming client.
128−--
129−-- It allows using this module's 'ClientM' in a direct style.
130−-- The 'NFData' constraint however prevents using this function with genuine
131−-- streaming response types ('SourceT', 'Conduit', pipes 'Proxy' or 'Machine').
132−-- For those you have to use 'withClientM'.
133−--
134−-- /Note:/ we 'force' the result, so the likelihood of accidentally leaking a
135−-- connection is smaller. Use with care.
136−--
137−runClientM :: NFData a => ClientM a -> ClientEnv -> IO (Either ClientError a)
138−runClientM cm env = withClientM cm env (evaluate . force)
139−
140−performRequest :: Maybe [Status] -> Request -> ClientM Response
141−performRequest acceptStatus req = do
142− -- TODO: should use Client.withResponse here too
143− ClientEnv m burl cookieJar' createClientRequest <- ask
144− clientRequest <- liftIO $ createClientRequest burl req
145− request <- case cookieJar' of
146− Nothing -> pure clientRequest
147− Just cj -> liftIO $ do
148− now <- getCurrentTime
149− atomically $ do
150− oldCookieJar <- readTVar cj
151− let (newRequest, newCookieJar) =
152− Client.insertCookiesIntoRequest
153− clientRequest
154− oldCookieJar
155− now
156− writeTVar cj newCookieJar
157− pure newRequest
158−
159− eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request m
160− case eResponse of
161− Left err -> throwError err
162− Right response -> do
163− for_ cookieJar' $ \cj -> liftIO $ do
164− now' <- getCurrentTime
165− atomically $ modifyTVar' cj (fst . Client.updateCookieJar response request now')
166− let status = Client.responseStatus response
167− ourResponse = clientResponseToResponse id response
168− goodStatus = case acceptStatus of
169− Nothing -> statusIsSuccessful status
170− Just good -> status `elem` good
171− unless goodStatus $ do
172− throwError $ mkFailureResponse burl req ourResponse
173− return ourResponse
174−
175−-- | TODO: support UVerb ('acceptStatus' argument, like in 'performRequest' above).
176−performWithStreamingRequest :: Request -> (StreamingResponse -> IO a) -> ClientM a
177−performWithStreamingRequest req k = do
178− ClientEnv m burl cookieJar' createClientRequest <- ask
179− clientRequest <- liftIO $ createClientRequest burl req
180− request <- case cookieJar' of
181− Nothing -> pure clientRequest
182− Just cj -> liftIO $ do
183− now <- getCurrentTime
184− atomically $ do
185− oldCookieJar <- readTVar cj
186− let (newRequest, newCookieJar) =
187− Client.insertCookiesIntoRequest
188− clientRequest
189− oldCookieJar
190− now
191− writeTVar cj newCookieJar
192− pure newRequest
193− ClientM $ lift $ lift $ Codensity $ \k1 ->
194− Client.withResponse request m $ \res -> do
195− let status = Client.responseStatus res
196−
197− -- we throw FailureResponse in IO :(
198− unless (statusIsSuccessful status) $ do
199− b <- BSL.fromChunks <$> Client.brConsume (Client.responseBody res)
200− throwIO $ mkFailureResponse burl req (clientResponseToResponse (const b) res)
201−
202− x <- k (clientResponseToResponse (S.fromAction BS.null) res)
203− k1 x
servant-client/src/Servant/Client/Streaming.hsdeleted−19
@@ -1,19 +0,0 @@
1−-- | This module provides 'client' which can automatically generate
2−-- querying functions for each endpoint just from the type representing your
3−-- API.
4−--
5−-- This client supports streaming operations.
6−module Servant.Client.Streaming
7− ( client
8− , ClientM
9− , withClientM
10− , runClientM
11− , ClientEnv(..)
12− , mkClientEnv
13− , defaultMakeClientRequest
14− , hoistClient
15− , module Servant.Client.Core.Reexport
16− ) where
17−
18−import Servant.Client.Core.Reexport
19−import Servant.Client.Internal.HttpClient.Streaming
servant-client/test/Servant/BasicAuthSpec.hsdeleted−53
@@ -1,53 +0,0 @@
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.BasicAuthSpec (spec) where
19−
20−import Prelude ()
21−import Prelude.Compat
22−
23−import Control.Arrow
24− (left)
25−import Data.Monoid ()
26−import qualified Network.HTTP.Types as HTTP
27−import Test.Hspec
28−
29−import Servant.API
30− (BasicAuthData (..))
31−import Servant.Client
32−import Servant.ClientTestUtils
33−
34−spec :: Spec
35−spec = describe "Servant.BasicAuthSpec" $ do
36− basicAuthSpec
37−
38−basicAuthSpec :: Spec
39−basicAuthSpec = beforeAll (startWaiApp basicAuthServer) $ afterAll endWaiApp $ do
40− context "Authentication works when requests are properly authenticated" $ do
41−
42− it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do
43− let getBasic = client basicAuthAPI
44− let basicAuthData = BasicAuthData "servant" "server"
45− left show <$> runClient (getBasic basicAuthData) baseUrl `shouldReturn` Right alice
46−
47− context "Authentication is rejected when requests are not authenticated properly" $ do
48−
49− it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do
50− let getBasic = client basicAuthAPI
51− let basicAuthData = BasicAuthData "not" "password"
52− Left (FailureResponse _ r) <- runClient (getBasic basicAuthData) baseUrl
53− responseStatusCode r `shouldBe` HTTP.Status 403 "Forbidden"
servant-client/test/Servant/BrokenSpec.hsdeleted−71
@@ -1,71 +0,0 @@
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-http-streams/test/Servant/ClientSpec.hs → servant-client/test/Servant/ClientSpec.hsrenamed+105−71
@@ -12,7 +12,6 @@
1212{-# LANGUAGE RecordWildCards #-}
1313{-# LANGUAGE ScopedTypeVariables #-}
1414{-# LANGUAGE StandaloneDeriving #-}
15−{-# LANGUAGE TypeApplications #-}
1615{-# LANGUAGE TypeFamilies #-}
1716{-# LANGUAGE TypeOperators #-}
1817{-# LANGUAGE UndecidableInstances #-}
@@ -29,27 +28,29 @@ import Control.Arrow
2928 (left)
3029import Control.Concurrent
3130 (ThreadId, forkIO, killThread)
32−import Control.DeepSeq
33− (NFData (..))
3431import Control.Exception
35− (bracket, fromException, IOException)
32+ (bracket)
3633import Control.Monad.Error.Class
3734 (throwError)
3835import Data.Aeson
3936import Data.Char
4037 (chr, isPrint)
4138import Data.Foldable
42− (forM_, toList)
43−import Data.Maybe
44− (isJust)
39+ (forM_)
4540import Data.Monoid ()
4641import Data.Proxy
42+import Data.Semigroup
43+ ((<>))
44+import qualified Generics.SOP as SOP
4745import GHC.Generics
4846 (Generic)
49−import qualified Network.HTTP.Types as HTTP
47+import qualified Network.HTTP.Client as C
48+import qualified Network.HTTP.Types as HTTP
5049import Network.Socket
51−import qualified Network.Wai as Wai
50+import qualified Network.Wai as Wai
5251import Network.Wai.Handler.Warp
52+import System.IO.Unsafe
53+ (unsafePerformIO)
5354import Test.Hspec
5455import Test.Hspec.QuickCheck
5556import Test.HUnit
@@ -63,25 +64,25 @@ import Servant.API
6364 DeleteNoContent, EmptyAPI, FormUrlEncoded, Get, Header,
6465 Headers, JSON, NoContent (NoContent), Post, Put, QueryFlag,
6566 QueryParam, QueryParams, Raw, ReqBody, addHeader, getHeaders)
66−import qualified Servant.Client.Core.Auth as Auth
67−import qualified Servant.Client.Core.Request as Req
68−import Servant.HttpStreams
67+import Servant.API.Internal.Test.ComprehensiveAPI
68+import Servant.Client
69+import qualified Servant.Client.Core.Internal.Auth as Auth
70+import qualified Servant.Client.Core.Internal.Request as Req
6971import Servant.Server
7072import Servant.Server.Experimental.Auth
71−import Servant.Test.ComprehensiveAPI
7273
7374-- This declaration simply checks that all instances are in place.
74−_ = client comprehensiveAPIWithoutStreaming
75+_ = client comprehensiveAPI
7576
7677spec :: Spec
77−spec = describe "Servant.HttpStreams" $ do
78− successSpec
78+spec = describe "Servant.Client" $ do
79+ sucessSpec
7980 failSpec
8081 wrappedApiSpec
8182 basicAuthSpec
8283 genAuthSpec
84+ genericClientSpec
8385 hoistClientSpec
84− connectionErrorSpec
8586
8687-- * test data types
8788
@@ -90,9 +91,6 @@ data Person = Person
9091 , _age :: Integer
9192 } deriving (Eq, Show, Generic)
9293
93−instance NFData Person where
94− rnf (Person n a) = rnf n `seq` rnf a
95−
9694instance ToJSON Person
9795instance FromJSON Person
9896
@@ -113,7 +111,7 @@ type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]
113111type Api =
114112 Get '[JSON] Person
115113 :<|> "get" :> Get '[JSON] Person
116− :<|> "deleteEmpty" :> DeleteNoContent
114+ :<|> "deleteEmpty" :> DeleteNoContent '[JSON] NoContent
117115 :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person
118116 :<|> "captureAll" :> CaptureAll "names" String :> Get '[JSON] [Person]
119117 :<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person
@@ -129,8 +127,7 @@ type Api =
129127 ReqBody '[JSON] [(String, [Rational])] :>
130128 Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])])
131129 :<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool)
132− :<|> "deleteContentType" :> DeleteNoContent
133− :<|> "redirectWithCookie" :> Raw
130+ :<|> "deleteContentType" :> DeleteNoContent '[JSON] NoContent
134131 :<|> "empty" :> EmptyAPI
135132
136133api :: Proxy Api
@@ -151,7 +148,6 @@ getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]
151148 -> ClientM (String, Maybe Int, Bool, [(String, [Rational])])
152149getRespHeaders :: ClientM (Headers TestHeaders Bool)
153150getDeleteContentType :: ClientM NoContent
154−_getRedirectWithCookie :: HTTP.Method -> ClientM Response
155151
156152getRoot
157153 :<|> getGet
@@ -167,7 +163,6 @@ getRoot
167163 :<|> getMultiple
168164 :<|> getRespHeaders
169165 :<|> getDeleteContentType
170− :<|> _getRedirectWithCookie
171166 :<|> EmptyClient = client api
172167
173168server :: Application
@@ -180,8 +175,8 @@ server = serve api (
180175 :<|> return
181176 :<|> (\ name -> case name of
182177 Just "alice" -> return alice
183− Just n -> throwError $ ServerError 400 (n ++ " not found") "" []
184− Nothing -> throwError $ ServerError 400 "missing parameter" "" [])
178+ Just n -> throwError $ ServantErr 400 (n ++ " not found") "" []
179+ Nothing -> throwError $ ServantErr 400 "missing parameter" "" [])
185180 :<|> (\ names -> return (zipWith Person names [0..]))
186181 :<|> return
187182 :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "rawSuccess")
@@ -189,9 +184,9 @@ server = serve api (
189184 :<|> (\ a b c d -> return (a, b, c, d))
190185 :<|> (return $ addHeader 1729 $ addHeader "eg2" True)
191186 :<|> return NoContent
192− :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.found302 [("Location", "testlocation"), ("Set-Cookie", "testcookie=test")] "")
193187 :<|> emptyServer)
194188
189+
195190type FailApi =
196191 "get" :> Raw
197192 :<|> "capture" :> Capture "name" String :> Raw
@@ -252,16 +247,62 @@ genAuthServerContext = genAuthHandler :. EmptyContext
252247genAuthServer :: Application
253248genAuthServer = serveWithContext genAuthAPI genAuthServerContext (const (return alice))
254249
255−runClient :: NFData a => ClientM a -> BaseUrl -> IO (Either ClientError a)
256−runClient x burl = withClientEnvIO burl (runClientM x)
257−
258−runClientUnsafe :: ClientM a -> BaseUrl -> IO (Either ClientError a)
259−runClientUnsafe x burl = withClientEnvIO burl (runClientMUnsafe x)
250+-- * generic client stuff
251+
252+type GenericClientAPI
253+ = QueryParam "sqr" Int :> Get '[JSON] Int
254+ :<|> Capture "foo" String :> NestedAPI1
255+
256+data GenericClient = GenericClient
257+ { getSqr :: Maybe Int -> ClientM Int
258+ , mkNestedClient1 :: String -> NestedClient1
259+ } deriving Generic
260+instance SOP.Generic GenericClient
261+instance (Client ClientM GenericClientAPI ~ client) => ClientLike client GenericClient
262+
263+type NestedAPI1
264+ = QueryParam "int" Int :> NestedAPI2
265+ :<|> QueryParam "id" Char :> Get '[JSON] Char
266+
267+data NestedClient1 = NestedClient1
268+ { mkNestedClient2 :: Maybe Int -> NestedClient2
269+ , idChar :: Maybe Char -> ClientM Char
270+ } deriving Generic
271+instance SOP.Generic NestedClient1
272+instance (Client ClientM NestedAPI1 ~ client) => ClientLike client NestedClient1
273+
274+type NestedAPI2
275+ = "sum" :> Capture "first" Int :> Capture "second" Int :> Get '[JSON] Int
276+ :<|> "void" :> Post '[JSON] ()
277+
278+data NestedClient2 = NestedClient2
279+ { getSum :: Int -> Int -> ClientM Int
280+ , doNothing :: ClientM ()
281+ } deriving Generic
282+instance SOP.Generic NestedClient2
283+instance (Client ClientM NestedAPI2 ~ client) => ClientLike client NestedClient2
284+
285+genericClientServer :: Application
286+genericClientServer = serve (Proxy :: Proxy GenericClientAPI) (
287+ (\ mx -> case mx of
288+ Just x -> return (x*x)
289+ Nothing -> throwError $ ServantErr 400 "missing parameter" "" []
290+ )
291+ :<|> nestedServer1
292+ )
260293 where
261− runClientMUnsafe x env = withClientM x env return
294+ nestedServer1 _str = nestedServer2 :<|> (maybe (throwError $ ServantErr 400 "missing parameter" "" []) return)
295+ nestedServer2 _int = (\ x y -> return (x + y)) :<|> return ()
262296
263−successSpec :: Spec
264−successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
297+{-# NOINLINE manager' #-}
298+manager' :: C.Manager
299+manager' = unsafePerformIO $ C.newManager C.defaultManagerSettings
300+
301+runClient :: ClientM a -> BaseUrl -> IO (Either ServantError a)
302+runClient x baseUrl' = runClientM x (mkClientEnv manager' baseUrl')
303+
304+sucessSpec :: Spec
305+sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
265306 it "Servant.API.Get root" $ \(_, baseUrl) -> do
266307 left show <$> runClient getRoot baseUrl `shouldReturn` Right carol
267308
@@ -286,16 +327,9 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
286327 let p = Person "Clara" 42
287328 left show <$> runClient (getBody p) baseUrl `shouldReturn` Right p
288329
289− it "Servant.API FailureResponse" $ \(_, baseUrl) -> do
290− left show <$> runClient (getQueryParam (Just "alice")) baseUrl `shouldReturn` Right alice
291− Left (FailureResponse req _) <- runClient (getQueryParam (Just "bob")) baseUrl
292− Req.requestPath req `shouldBe` (baseUrl, "/param")
293− toList (Req.requestQueryString req) `shouldBe` [("name", Just "bob")]
294− Req.requestMethod req `shouldBe` HTTP.methodGet
295−
296330 it "Servant.API.QueryParam" $ \(_, baseUrl) -> do
297331 left show <$> runClient (getQueryParam (Just "alice")) baseUrl `shouldReturn` Right alice
298− Left (FailureResponse _ r) <- runClient (getQueryParam (Just "bob")) baseUrl
332+ Left (FailureResponse r) <- runClient (getQueryParam (Just "bob")) baseUrl
299333 responseStatusCode r `shouldBe` HTTP.Status 400 "bob not found"
300334
301335 it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do
@@ -319,7 +353,7 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
319353 res <- runClient (getRawFailure HTTP.methodGet) baseUrl
320354 case res of
321355 Right _ -> assertFailure "expected Left, but got Right"
322− Left (FailureResponse _ r) -> do
356+ Left (FailureResponse r) -> do
323357 responseStatusCode r `shouldBe` HTTP.status400
324358 responseBody r `shouldBe` "rawFailure"
325359 Left e -> assertFailure $ "expected FailureResponse, but got " ++ show e
@@ -341,14 +375,14 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
341375
342376wrappedApiSpec :: Spec
343377wrappedApiSpec = describe "error status codes" $ do
344− let serveW api = serve api $ throwError $ ServerError 500 "error message" "" []
378+ let serveW api = serve api $ throwError $ ServantErr 500 "error message" "" []
345379 context "are correctly handled by the client" $
346380 let test :: (WrappedApi, String) -> Spec
347381 test (WrappedApi api, desc) =
348382 it desc $ bracket (startWaiApp $ serveW api) endWaiApp $ \(_, baseUrl) -> do
349383 let getResponse :: ClientM ()
350384 getResponse = client api
351− Left (FailureResponse _ r) <- runClient getResponse baseUrl
385+ Left (FailureResponse r) <- runClient getResponse baseUrl
352386 responseStatusCode r `shouldBe` (HTTP.Status 500 "error message")
353387 in mapM_ test $
354388 (WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") :
@@ -365,7 +399,7 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
365399 let (_ :<|> _ :<|> getDeleteEmpty :<|> _) = client api
366400 Left res <- runClient getDeleteEmpty baseUrl
367401 case res of
368− FailureResponse _ r | responseStatusCode r == HTTP.status404 -> return ()
402+ FailureResponse r | responseStatusCode r == HTTP.status404 -> return ()
369403 _ -> fail $ "expected 404 response, but got " <> show res
370404
371405 it "reports DecodeFailure" $ \(_, baseUrl) -> do
@@ -375,8 +409,7 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
375409 DecodeFailure _ _ -> return ()
376410 _ -> fail $ "expected DecodeFailure, but got " <> show res
377411
378− -- we don't catch IOException's
379− xit "reports ConnectionError" $ \_ -> do
412+ it "reports ConnectionError" $ \_ -> do
380413 let (getGetWrongHost :<|> _) = client api
381414 Left res <- runClient getGetWrongHost (BaseUrl Http "127.0.0.1" 19872 "")
382415 case res of
@@ -416,7 +449,7 @@ basicAuthSpec = beforeAll (startWaiApp basicAuthServer) $ afterAll endWaiApp $ d
416449 it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do
417450 let getBasic = client basicAuthAPI
418451 let basicAuthData = BasicAuthData "not" "password"
419− Left (FailureResponse _ r) <- runClient (getBasic basicAuthData) baseUrl
452+ Left (FailureResponse r) <- runClient (getBasic basicAuthData) baseUrl
420453 responseStatusCode r `shouldBe` HTTP.Status 403 "Forbidden"
421454
422455genAuthSpec :: Spec
@@ -433,9 +466,25 @@ genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do
433466 it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do
434467 let getProtected = client genAuthAPI
435468 let authRequest = Auth.mkAuthenticatedRequest () (\_ req -> Req.addHeader "Wrong" ("header" :: String) req)
436− Left (FailureResponse _ r) <- runClient (getProtected authRequest) baseUrl
469+ Left (FailureResponse r) <- runClient (getProtected authRequest) baseUrl
437470 responseStatusCode r `shouldBe` (HTTP.Status 401 "Unauthorized")
438471
472+genericClientSpec :: Spec
473+genericClientSpec = beforeAll (startWaiApp genericClientServer) $ afterAll endWaiApp $ do
474+ describe "Servant.Client.Generic" $ do
475+
476+ let GenericClient{..} = mkClient (client (Proxy :: Proxy GenericClientAPI))
477+ NestedClient1{..} = mkNestedClient1 "example"
478+ NestedClient2{..} = mkNestedClient2 (Just 42)
479+
480+ it "works for top-level client inClientM function" $ \(_, baseUrl) -> do
481+ left show <$> runClient (getSqr (Just 5)) baseUrl `shouldReturn` Right 25
482+
483+ it "works for nested clients" $ \(_, baseUrl) -> do
484+ left show <$> runClient (idChar (Just 'c')) baseUrl `shouldReturn` Right 'c'
485+ left show <$> runClient (getSum 3 4) baseUrl `shouldReturn` Right 7
486+ left show <$> runClient doNothing baseUrl `shouldReturn` Right ()
487+
439488-- * hoistClient
440489
441490type HoistClientAPI = Get '[JSON] Int :<|> Capture "n" Int :> Post '[JSON] Int
@@ -452,27 +501,12 @@ hoistClientSpec = beforeAll (startWaiApp hoistClientServer) $ afterAll endWaiApp
452501 it "allows us to GET/POST/... requests in IO instead of ClientM" $ \(_, baseUrl) -> do
453502 let (getInt :<|> postInt)
454503 = hoistClient hoistClientAPI
455− (fmap (either (error . show) id) . flip runClientUnsafe baseUrl)
504+ (fmap (either (error . show) id) . flip runClient baseUrl)
456505 (client hoistClientAPI)
457506
458507 getInt `shouldReturn` 5
459508 postInt 5 `shouldReturn` 5
460509
461−-- * ConnectionError
462−type ConnectionErrorAPI = Get '[JSON] Int
463−
464−connectionErrorAPI :: Proxy ConnectionErrorAPI
465−connectionErrorAPI = Proxy
466−
467−connectionErrorSpec :: Spec
468−connectionErrorSpec = describe "Servant.Client.ClientError" $
469− xit "correctly catches ConnectionErrors when the HTTP request can't go through" $ do
470− let getInt = client connectionErrorAPI
471− let baseUrl' = BaseUrl Http "example.invalid" 80 ""
472− let isHttpError (Left (ConnectionError e)) = isJust $ fromException @IOException e
473− isHttpError _ = False
474− (isHttpError <$> runClient getInt baseUrl') `shouldReturn` True
475−
476510-- * utils
477511
478512startWaiApp :: Application -> IO (ThreadId, BaseUrl)
@@ -480,7 +514,7 @@ startWaiApp app = do
480514 (port, socket) <- openTestSocket
481515 let settings = setPort port $ defaultSettings
482516 thread <- forkIO $ runSettingsSocket settings socket app
483− return (thread, BaseUrl Http "127.0.0.1" port "")
517+ return (thread, BaseUrl Http "localhost" port "")
484518
485519
486520endWaiApp :: (ThreadId, BaseUrl) -> IO ()
@@ -489,8 +523,8 @@ endWaiApp (thread, _) = killThread thread
489523openTestSocket :: IO (Port, Socket)
490524openTestSocket = do
491525 s <- socket AF_INET Stream defaultProtocol
492− let localhost = tupleToHostAddress (127, 0, 0, 1)
493− bind s (SockAddrInet defaultPort localhost)
526+ localhost <- inet_addr "127.0.0.1"
527+ bind s (SockAddrInet aNY_PORT localhost)
494528 listen s 1
495529 port <- socketPort s
496530 return (fromIntegral port, s)
servant-client/test/Servant/ClientTestUtils.hsdeleted−384
@@ -1,384 +0,0 @@
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 #-}
16−{-# OPTIONS_GHC -freduction-depth=100 #-}
17−{-# OPTIONS_GHC -fno-warn-orphans #-}
18−{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
19−
20−module Servant.ClientTestUtils where
21−
22−import Prelude ()
23−import Prelude.Compat
24−
25−import Control.Concurrent
26− (ThreadId, forkIO, killThread)
27−import Control.Monad
28− (join)
29−import Control.Monad.Error.Class
30− (throwError)
31−import Data.Aeson
32−import Data.ByteString
33− (ByteString)
34−import Data.ByteString.Builder
35− (byteString)
36−import qualified Data.ByteString.Lazy as LazyByteString
37−import Data.Char
38− (chr, isPrint)
39−import Data.Monoid ()
40−import Data.Proxy
41−import Data.SOP
42−import Data.Text
43− (Text)
44−import qualified Data.Text as Text
45−import Data.Text.Encoding
46− (decodeUtf8, encodeUtf8)
47−import GHC.Generics
48− (Generic)
49−import qualified Network.HTTP.Client as C
50−import qualified Network.HTTP.Types as HTTP
51−import Network.Socket
52−import qualified Network.Wai as Wai
53−import Network.Wai.Handler.Warp
54−import System.IO.Unsafe
55− (unsafePerformIO)
56−import Test.QuickCheck
57−import Web.FormUrlEncoded
58− (FromForm, ToForm)
59−
60−import Servant.API
61− ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth,
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 ((:-))
69−import Servant.Client
70−import qualified Servant.Client.Core.Auth as Auth
71−import Servant.Server
72−import Servant.Server.Experimental.Auth
73−import Servant.Test.ComprehensiveAPI
74−
75−-- This declaration simply checks that all instances are in place.
76−_ = client comprehensiveAPIWithoutStreaming
77−
78−-- * test data types
79−
80−data Person = Person
81− { _name :: String
82− , _age :: Integer
83− } deriving (Eq, Show, Read, Generic)
84−
85−instance ToJSON Person
86−instance FromJSON Person
87−
88−instance ToForm Person
89−instance FromForm Person
90−
91−instance Arbitrary Person where
92− arbitrary = Person <$> arbitrary <*> arbitrary
93−
94−instance MimeRender PlainText Person where
95− mimeRender _ = LazyByteString.fromStrict . encodeUtf8 . Text.pack . show
96−
97−instance MimeUnrender PlainText Person where
98− mimeUnrender _ =
99− -- This does not handle any errors, but it should be fine for tests
100− Right . read . Text.unpack . decodeUtf8 . LazyByteString.toStrict
101−
102−
103−alice :: Person
104−alice = Person "Alice" 42
105−
106−carol :: Person
107−carol = Person "Carol" 17
108−
109−type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]
110−
111−data RecordRoutes mode = RecordRoutes
112− { version :: mode :- "version" :> Get '[JSON] Int
113− , echo :: mode :- "echo" :> Capture "string" String :> Get '[JSON] String
114− , otherRoutes :: mode :- "other" :> Capture "someParam" Int :> NamedRoutes OtherRoutes
115− } deriving Generic
116−
117−data OtherRoutes mode = OtherRoutes
118− { something :: mode :- "something" :> Get '[JSON] [String]
119− } deriving Generic
120−
121−-- Get for HTTP 307 Temporary Redirect
122−type Get307 = Verb 'GET 307
123−
124−type Api =
125− Get '[JSON] Person
126− :<|> "get" :> Get '[JSON] Person
127− -- This endpoint returns a response with status code 307 Temporary Redirect,
128− -- different from the ones in the 2xx successful class, to test derivation
129− -- of clients' api.
130− :<|> "get307" :> Get307 '[PlainText] Text
131− :<|> "deleteEmpty" :> DeleteNoContent
132− :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person
133− :<|> "captureAll" :> CaptureAll "names" String :> Get '[JSON] [Person]
134− :<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person
135− :<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person
136− -- This endpoint makes use of a 'Raw' server because it is not currently
137− -- possible to handle arbitrary binary query param values with
138− -- @servant-server@
139− :<|> "param-binary" :> QueryParam "payload" UrlEncodedByteString :> Raw
140− :<|> "params" :> QueryParams "names" String :> Get '[JSON] [Person]
141− :<|> "flag" :> QueryFlag "flag" :> Get '[JSON] Bool
142− :<|> "fragment" :> Fragment String :> Get '[JSON] Person
143− :<|> "rawSuccess" :> Raw
144− :<|> "rawSuccessPassHeaders" :> Raw
145− :<|> "rawFailure" :> Raw
146− :<|> "multiple" :>
147− Capture "first" String :>
148− QueryParam "second" Int :>
149− QueryFlag "third" :>
150− ReqBody '[JSON] [(String, [Rational])] :>
151− Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])])
152− :<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool)
153− :<|> "uverb-headers" :> UVerb 'GET '[JSON] '[ WithStatus 200 (Headers TestHeaders Bool), WithStatus 204 String ]
154− :<|> "deleteContentType" :> DeleteNoContent
155− :<|> "redirectWithCookie" :> Raw
156− :<|> "empty" :> EmptyAPI
157− :<|> "uverb-success-or-redirect" :>
158− Capture "bool" Bool :>
159− UVerb 'GET '[PlainText] '[WithStatus 200 Person,
160− WithStatus 301 Text]
161− :<|> "uverb-get-created" :> UVerb 'GET '[PlainText] '[WithStatus 201 Person]
162− :<|> NamedRoutes RecordRoutes
163− :<|> "captureVerbatim" :> Capture "someString" Verbatim :> Get '[PlainText] Text
164−
165−api :: Proxy Api
166−api = Proxy
167−
168−getRoot :: ClientM Person
169−getGet :: ClientM Person
170−getGet307 :: ClientM Text
171−getDeleteEmpty :: ClientM NoContent
172−getCapture :: String -> ClientM Person
173−getCaptureAll :: [String] -> ClientM [Person]
174−getBody :: Person -> ClientM Person
175−getQueryParam :: Maybe String -> ClientM Person
176−getQueryParamBinary :: Maybe UrlEncodedByteString -> HTTP.Method -> ClientM Response
177−getQueryParams :: [String] -> ClientM [Person]
178−getQueryFlag :: Bool -> ClientM Bool
179−getFragment :: ClientM Person
180−getRawSuccess :: HTTP.Method -> ClientM Response
181−getRawSuccessPassHeaders :: HTTP.Method -> ClientM Response
182−getRawFailure :: HTTP.Method -> ClientM Response
183−getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]
184− -> ClientM (String, Maybe Int, Bool, [(String, [Rational])])
185−getRespHeaders :: ClientM (Headers TestHeaders Bool)
186−getUVerbRespHeaders :: ClientM (Union '[ WithStatus 200 (Headers TestHeaders Bool), WithStatus 204 String ])
187−getDeleteContentType :: ClientM NoContent
188−getRedirectWithCookie :: HTTP.Method -> ClientM Response
189−uverbGetSuccessOrRedirect :: Bool
190− -> ClientM (Union '[WithStatus 200 Person,
191− WithStatus 301 Text])
192−uverbGetCreated :: ClientM (Union '[WithStatus 201 Person])
193−recordRoutes :: RecordRoutes (AsClientT ClientM)
194−
195−getRoot
196− :<|> getGet
197− :<|> getGet307
198− :<|> getDeleteEmpty
199− :<|> getCapture
200− :<|> getCaptureAll
201− :<|> getBody
202− :<|> getQueryParam
203− :<|> getQueryParamBinary
204− :<|> getQueryParams
205− :<|> getQueryFlag
206− :<|> getFragment
207− :<|> getRawSuccess
208− :<|> getRawSuccessPassHeaders
209− :<|> getRawFailure
210− :<|> getMultiple
211− :<|> getRespHeaders
212− :<|> getUVerbRespHeaders
213− :<|> getDeleteContentType
214− :<|> getRedirectWithCookie
215− :<|> EmptyClient
216− :<|> uverbGetSuccessOrRedirect
217− :<|> uverbGetCreated
218− :<|> recordRoutes
219− :<|> captureVerbatim = client api
220−
221−server :: Application
222−server = serve api (
223− return carol
224− :<|> return alice
225− :<|> return "redirecting"
226− :<|> return NoContent
227− :<|> (\ name -> return $ Person name 0)
228− :<|> (\ names -> return (zipWith Person names [0..]))
229− :<|> return
230− :<|> (\ name -> case name of
231− Just "alice" -> return alice
232− Just n -> throwError $ ServerError 400 (n ++ " not found") "" []
233− Nothing -> throwError $ ServerError 400 "missing parameter" "" [])
234− :<|> const (Tagged $ \request respond ->
235− respond . maybe (Wai.responseLBS HTTP.notFound404 [] "Missing: payload")
236− (Wai.responseLBS HTTP.ok200 [] . LazyByteString.fromStrict)
237− . join
238− . lookup "payload"
239− $ Wai.queryString request
240− )
241− :<|> (\ names -> return (zipWith Person names [0..]))
242− :<|> return
243− :<|> return alice
244− :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "rawSuccess")
245− :<|> (Tagged $ \ request respond -> (respond $ Wai.responseLBS HTTP.ok200 (Wai.requestHeaders $ request) "rawSuccess"))
246− :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.badRequest400 [] "rawFailure")
247− :<|> (\ a b c d -> return (a, b, c, d))
248− :<|> (return $ addHeader 1729 $ addHeader "eg2" True)
249− :<|> (pure . Z . I . WithStatus $ addHeader 1729 $ addHeader "eg2" True)
250− :<|> return NoContent
251− :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.found302 [("Location", "testlocation"), ("Set-Cookie", "testcookie=test")] "")
252− :<|> emptyServer
253− :<|> (\shouldRedirect -> if shouldRedirect
254− then respond (WithStatus @301 ("redirecting" :: Text))
255− else respond (WithStatus @200 alice ))
256− :<|> respond (WithStatus @201 carol)
257− :<|> RecordRoutes
258− { version = pure 42
259− , echo = pure
260− , otherRoutes = \_ -> OtherRoutes
261− { something = pure ["foo", "bar", "pweet"]
262− }
263− }
264− :<|> pure . decodeUtf8 . unVerbatim
265− )
266−
267−-- * api for testing failures
268−
269−type FailApi =
270− "get" :> Raw
271− :<|> "capture" :> Capture "name" String :> Raw
272− :<|> "body" :> Raw
273− :<|> "headers" :> Raw
274−failApi :: Proxy FailApi
275−failApi = Proxy
276−
277−failServer :: Application
278−failServer = serve failApi (
279− (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "")
280− :<|> (\ _capture -> Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "application/json")] "")
281− :<|> (Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "fooooo")] "")
282− :<|> (Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "application/x-www-form-urlencoded"), ("X-Example1", "1"), ("X-Example2", "foo")] "")
283− )
284−
285−-- * basic auth stuff
286−
287−type BasicAuthAPI =
288− BasicAuth "foo-realm" () :> "private" :> "basic" :> Get '[JSON] Person
289−
290−basicAuthAPI :: Proxy BasicAuthAPI
291−basicAuthAPI = Proxy
292−
293−basicAuthHandler :: BasicAuthCheck ()
294−basicAuthHandler =
295− let check (BasicAuthData username password) =
296− if username == "servant" && password == "server"
297− then return (Authorized ())
298− else return Unauthorized
299− in BasicAuthCheck check
300−
301−basicServerContext :: Context '[ BasicAuthCheck () ]
302−basicServerContext = basicAuthHandler :. EmptyContext
303−
304−basicAuthServer :: Application
305−basicAuthServer = serveWithContext basicAuthAPI basicServerContext (const (return alice))
306−
307−-- * general auth stuff
308−
309−type GenAuthAPI =
310− AuthProtect "auth-tag" :> "private" :> "auth" :> Get '[JSON] Person
311−
312−genAuthAPI :: Proxy GenAuthAPI
313−genAuthAPI = Proxy
314−
315−type instance AuthServerData (AuthProtect "auth-tag") = ()
316−type instance Auth.AuthClientData (AuthProtect "auth-tag") = ()
317−
318−genAuthHandler :: AuthHandler Wai.Request ()
319−genAuthHandler =
320− let handler req = case lookup "AuthHeader" (Wai.requestHeaders req) of
321− Nothing -> throwError (err401 { errBody = "Missing auth header" })
322− Just _ -> return ()
323− in mkAuthHandler handler
324−
325−genAuthServerContext :: Context '[ AuthHandler Wai.Request () ]
326−genAuthServerContext = genAuthHandler :. EmptyContext
327−
328−genAuthServer :: Application
329−genAuthServer = serveWithContext genAuthAPI genAuthServerContext (const (return alice))
330−
331−{-# NOINLINE manager' #-}
332−manager' :: C.Manager
333−manager' = unsafePerformIO $ C.newManager C.defaultManagerSettings
334−
335−runClient :: ClientM a -> BaseUrl -> IO (Either ClientError a)
336−runClient x baseUrl' = runClientM x (mkClientEnv manager' baseUrl')
337−
338−-- * utils
339−
340−startWaiApp :: Application -> IO (ThreadId, BaseUrl)
341−startWaiApp app = do
342− (port, socket) <- openTestSocket
343− let settings = setPort port defaultSettings
344− thread <- forkIO $ runSettingsSocket settings socket app
345− return (thread, BaseUrl Http "localhost" port "")
346−
347−
348−endWaiApp :: (ThreadId, BaseUrl) -> IO ()
349−endWaiApp (thread, _) = killThread thread
350−
351−openTestSocket :: IO (Port, Socket)
352−openTestSocket = do
353− s <- socket AF_INET Stream defaultProtocol
354− let localhost = tupleToHostAddress (127, 0, 0, 1)
355− bind s (SockAddrInet defaultPort localhost)
356− listen s 1
357− port <- socketPort s
358− return (fromIntegral port, s)
359−
360−pathGen :: Gen (NonEmptyList Char)
361−pathGen = fmap NonEmpty path
362− where
363− path = listOf1 $ elements $
364− filter (not . (`elem` ("?%[]/#;" :: String))) $
365− filter isPrint $
366− map chr [0..127]
367−
368−newtype UrlEncodedByteString = UrlEncodedByteString { unUrlEncodedByteString :: ByteString }
369−
370−instance ToHttpApiData UrlEncodedByteString where
371− toEncodedUrlPiece = byteString . HTTP.urlEncode True . unUrlEncodedByteString
372− toUrlPiece = decodeUtf8 . HTTP.urlEncode True . unUrlEncodedByteString
373−
374−instance FromHttpApiData UrlEncodedByteString where
375− parseUrlPiece = pure . UrlEncodedByteString . HTTP.urlDecode True . encodeUtf8
376−
377−newtype Verbatim = Verbatim { unVerbatim :: ByteString }
378−
379−instance ToHttpApiData Verbatim where
380− toEncodedUrlPiece = byteString . unVerbatim
381− toUrlPiece = decodeUtf8 . unVerbatim
382−
383−instance FromHttpApiData Verbatim where
384− parseUrlPiece = pure . Verbatim . encodeUtf8
servant-client/test/Servant/ConnectionErrorSpec.hsdeleted−55
@@ -1,55 +0,0 @@
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 #-}
15−{-# OPTIONS_GHC -freduction-depth=100 #-}
16−{-# OPTIONS_GHC -fno-warn-orphans #-}
17−{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
18−
19−module Servant.ConnectionErrorSpec (spec) where
20−
21−import Prelude ()
22−import Prelude.Compat
23−
24−import Control.Exception
25− (fromException)
26−import Data.Maybe
27− (isJust)
28−import Data.Monoid ()
29−import Data.Proxy
30−import qualified Network.HTTP.Client as C
31−import Test.Hspec
32−
33−import Servant.API
34− (Get, JSON)
35−import Servant.Client
36−import Servant.ClientTestUtils
37−
38−
39−spec :: Spec
40−spec = describe "Servant.ConnectionErrorSpec" $ do
41− connectionErrorSpec
42−
43−type ConnectionErrorAPI = Get '[JSON] Int
44−
45−connectionErrorAPI :: Proxy ConnectionErrorAPI
46−connectionErrorAPI = Proxy
47−
48−connectionErrorSpec :: Spec
49−connectionErrorSpec = describe "Servant.Client.ClientError" $
50− it "correctly catches ConnectionErrors when the HTTP request can't go through" $ do
51− let getInt = client connectionErrorAPI
52− let baseUrl' = BaseUrl Http "example.invalid" 80 ""
53− let isHttpError (Left (ConnectionError e)) = isJust $ fromException @C.HttpException e
54− isHttpError _ = False
55− (isHttpError <$> runClient getInt baseUrl') `shouldReturn` True
servant-client/test/Servant/FailSpec.hsdeleted−79
@@ -1,79 +0,0 @@
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.FailSpec (spec) where
19−
20−import Prelude ()
21−import Prelude.Compat
22−
23−import Data.Monoid ()
24−import qualified Network.HTTP.Types as HTTP
25−import Test.Hspec
26−
27−import Servant.API
28− ((:<|>) ((:<|>)))
29−import Servant.Client
30−import Servant.ClientTestUtils
31−
32−spec :: Spec
33−spec = describe "Servant.FailSpec" $ do
34− failSpec
35−
36−failSpec :: Spec
37−failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
38−
39− context "client returns errors appropriately" $ do
40− it "reports FailureResponse" $ \(_, baseUrl) -> do
41− let (_ :<|> _ :<|> _ :<|> getDeleteEmpty :<|> _) = client api
42− Left res <- runClient getDeleteEmpty baseUrl
43− case res of
44− FailureResponse _ r | responseStatusCode r == HTTP.status404 -> return ()
45− _ -> fail $ "expected 404 response, but got " <> show res
46−
47− it "reports DecodeFailure" $ \(_, baseUrl) -> do
48− let (_ :<|> _ :<|> _ :<|> _ :<|> getCapture :<|> _) = client api
49− Left res <- runClient (getCapture "foo") baseUrl
50− case res of
51− DecodeFailure _ _ -> return ()
52− _ -> fail $ "expected DecodeFailure, but got " <> show res
53−
54− it "reports ConnectionError" $ \_ -> do
55− let (getGetWrongHost :<|> _) = client api
56− Left res <- runClient getGetWrongHost (BaseUrl Http "127.0.0.1" 19872 "")
57− case res of
58− ConnectionError _ -> return ()
59− _ -> fail $ "expected ConnectionError, but got " <> show res
60−
61− it "reports UnsupportedContentType" $ \(_, baseUrl) -> do
62− let (_ :<|> getGet :<|> _ ) = client api
63− Left res <- runClient getGet baseUrl
64− case res of
65− UnsupportedContentType "application/octet-stream" _ -> return ()
66− _ -> fail $ "expected UnsupportedContentType, but got " <> show res
67−
68− it "reports UnsupportedContentType when there are response headers" $ \(_, baseUrl) -> do
69− Left res <- runClient getRespHeaders baseUrl
70− case res of
71− UnsupportedContentType "application/x-www-form-urlencoded" _ -> return ()
72− _ -> fail $ "expected UnsupportedContentType, but got " <> show res
73−
74− it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do
75− let (_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api
76− Left res <- runClient (getBody alice) baseUrl
77− case res of
78− InvalidContentTypeHeader _ -> return ()
79− _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res
servant-client/test/Servant/GenAuthSpec.hsdeleted−54
@@ -1,54 +0,0 @@
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.GenAuthSpec (spec) where
19−
20−import Prelude ()
21−import Prelude.Compat
22−
23−import Control.Arrow
24− (left)
25−import Data.Monoid ()
26−import qualified Network.HTTP.Types as HTTP
27−import Test.Hspec
28−
29−import Servant.Client
30−import qualified Servant.Client.Core.Auth as Auth
31−import qualified Servant.Client.Core.Request as Req
32−import Servant.ClientTestUtils
33−
34−spec :: Spec
35−spec = describe "Servant.GenAuthSpec" $ do
36− genAuthSpec
37−
38−genAuthSpec :: Spec
39−genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do
40− context "Authentication works when requests are properly authenticated" $ do
41−
42− it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do
43− let getProtected = client genAuthAPI
44− let authRequest = Auth.mkAuthenticatedRequest () (\_ req -> Req.addHeader "AuthHeader" ("cool" :: String) req)
45− left show <$> runClient (getProtected authRequest) baseUrl `shouldReturn` Right alice
46−
47− context "Authentication is rejected when requests are not authenticated properly" $ do
48−
49− it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do
50− let getProtected = client genAuthAPI
51− let authRequest = Auth.mkAuthenticatedRequest () (\_ req -> Req.addHeader "Wrong" ("header" :: String) req)
52− Left (FailureResponse _ r) <- runClient (getProtected authRequest) baseUrl
53− responseStatusCode r `shouldBe` HTTP.Status 401 "Unauthorized"
54−
servant-client/test/Servant/GenericSpec.hsdeleted−37
@@ -1,37 +0,0 @@
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/HoistClientSpec.hsdeleted−58
@@ -1,58 +0,0 @@
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 RecordWildCards #-}
11−{-# LANGUAGE ScopedTypeVariables #-}
12−{-# LANGUAGE TypeFamilies #-}
13−{-# LANGUAGE TypeOperators #-}
14−{-# LANGUAGE UndecidableInstances #-}
15−{-# OPTIONS_GHC -freduction-depth=100 #-}
16−{-# OPTIONS_GHC -fno-warn-orphans #-}
17−{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
18−
19−module Servant.HoistClientSpec (spec) where
20−
21−import Prelude ()
22−import Prelude.Compat
23−
24−import Data.Monoid ()
25−import Data.Proxy
26−import Test.Hspec
27−
28−import Servant.API
29− ((:<|>) ((:<|>)), (:>), Capture,
30− Get, JSON, Post)
31−import Servant.Client
32−import Servant.Server
33−import Servant.ClientTestUtils
34−
35−
36−spec :: Spec
37−spec = describe "Servant.HoistClientSpec" $ do
38− hoistClientSpec
39−
40−type HoistClientAPI = Get '[JSON] Int :<|> Capture "n" Int :> Post '[JSON] Int
41−
42−hoistClientAPI :: Proxy HoistClientAPI
43−hoistClientAPI = Proxy
44−
45−hoistClientServer :: Application -- implements HoistClientAPI
46−hoistClientServer = serve hoistClientAPI $ return 5 :<|> return
47−
48−hoistClientSpec :: Spec
49−hoistClientSpec = beforeAll (startWaiApp hoistClientServer) $ afterAll endWaiApp $ do
50− describe "Servant.Client.hoistClient" $ do
51− it "allows us to GET/POST/... requests in IO instead of ClientM" $ \(_, baseUrl) -> do
52− let (getInt :<|> postInt)
53− = hoistClient hoistClientAPI
54− (fmap (either (error . show) id) . flip runClient baseUrl)
55− (client hoistClientAPI)
56−
57− getInt `shouldReturn` 5
58− postInt 5 `shouldReturn` 5
servant-client/test/Servant/StreamSpec.hs+73−109
@@ -22,65 +22,56 @@
2222module Servant.StreamSpec (spec) where
2323
2424import Control.Monad
25− (when)
26−import Control.Monad.Codensity
27− (Codensity (..))
28−import Control.Monad.IO.Class
29− (MonadIO (..))
30−import Control.Monad.Trans.Except
31−import qualified Data.ByteString as BS
25+ (replicateM_, void)
26+import qualified Data.ByteString as BS
3227import Data.Proxy
33−import qualified Data.TDigest as TD
34−import qualified Network.HTTP.Client as C
28+import qualified Network.HTTP.Client as C
3529import Prelude ()
3630import Prelude.Compat
37−import Servant.API
38− ((:<|>) ((:<|>)), (:>), JSON, NetstringFraming, StreamBody,
39− NewlineFraming, NoFraming, OctetStream, SourceIO, StreamGet,
40− )
41−import Servant.Client.Streaming
42−import Servant.Server
43−import Servant.Test.ComprehensiveAPI
44−import Servant.Types.SourceT
45−import System.Entropy
46− (getEntropy, getHardwareEntropy)
31+import System.IO
32+ (IOMode (ReadMode), withFile)
4733import System.IO.Unsafe
4834 (unsafePerformIO)
49−import System.Mem
50− (performGC)
5135import Test.Hspec
52−import Servant.ClientTestUtils (Person(..))
53−import qualified Servant.ClientTestUtils as CT
36+import Test.QuickCheck
37+
38+import Servant.API
39+ ((:<|>) ((:<|>)), (:>), JSON, NetstringFraming,
40+ NewlineFraming, NoFraming, OctetStream, ResultStream (..),
41+ StreamGenerator (..), StreamGet)
42+import Servant.Client
43+import Servant.ClientSpec
44+ (Person (..))
45+import qualified Servant.ClientSpec as CS
46+import Servant.Server
5447
5548#if MIN_VERSION_base(4,10,0)
5649import GHC.Stats
57− (gc, gcdetails_live_bytes, getRTSStats)
50+ (gc, gcdetails_mem_in_use_bytes, getRTSStats)
5851#else
5952import GHC.Stats
6053 (currentBytesUsed, getGCStats)
6154#endif
6255
63−-- This declaration simply checks that all instances are in place.
64−-- Note: this is streaming client
65−_ = client comprehensiveAPI
66−
6756spec :: Spec
68−spec = describe "Servant.Client.Streaming" $ do
57+spec = describe "Servant.Stream" $ do
6958 streamSpec
7059
71−type StreamApi =
72− "streamGetNewline" :> StreamGet NewlineFraming JSON (SourceIO Person)
73− :<|> "streamGetNetstring" :> StreamGet NetstringFraming JSON (SourceIO Person)
74− :<|> "streamALot" :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString)
75− :<|> "streamBody" :> StreamBody NoFraming OctetStream (SourceIO BS.ByteString) :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString)
60+type StreamApi f =
61+ "streamGetNewline" :> StreamGet NewlineFraming JSON (f Person)
62+ :<|> "streamGetNetstring" :> StreamGet NetstringFraming JSON (f Person)
63+ :<|> "streamALot" :> StreamGet NoFraming OctetStream (f BS.ByteString)
64+
65+
66+capi :: Proxy (StreamApi ResultStream)
67+capi = Proxy
7668
77−api :: Proxy StreamApi
78−api = Proxy
69+sapi :: Proxy (StreamApi StreamGenerator)
70+sapi = Proxy
7971
80−getGetNL, getGetNS :: ClientM (SourceIO Person)
81−getGetALot :: ClientM (SourceIO BS.ByteString)
82−getStreamBody :: SourceT IO BS.ByteString -> ClientM (SourceIO BS.ByteString)
83−getGetNL :<|> getGetNS :<|> getGetALot :<|> getStreamBody = client api
72+getGetNL, getGetNS :: ClientM (ResultStream Person)
73+getGetALot :: ClientM (ResultStream BS.ByteString)
74+getGetNL :<|> getGetNS :<|> getGetALot = client capi
8475
8576alice :: Person
8677alice = Person "Alice" 42
@@ -89,95 +80,68 @@ bob :: Person
8980bob = Person "Bob" 25
9081
9182server :: Application
92−server = serve api
93− $ return (source [alice, bob, alice])
94− :<|> return (source [alice, bob, alice])
95− -- 2 ^ (18 + 10) = 256M
96− :<|> return (SourceT ($ lots (powerOfTwo 18)))
97− :<|> return
83+server = serve sapi
84+ $ return (StreamGenerator (\f r -> f alice >> r bob >> r alice))
85+ :<|> return (StreamGenerator (\f r -> f alice >> r bob >> r alice))
86+ :<|> return (StreamGenerator lotsGenerator)
9887 where
99− lots n
100− | n < 0 = Stop
101− | otherwise = Effect $ do
102− let size = powerOfTwo 10
103− mbs <- getHardwareEntropy size
104− bs <- maybe (getEntropy size) pure mbs
105− return (Yield bs (lots (n - 1)))
88+ lotsGenerator f r = do
89+ void $ f ""
90+ void $ withFile "/dev/urandom" ReadMode $
91+ \handle -> streamFiveMBNTimes handle 1000 r
92+ return ()
93+
94+ streamFiveMBNTimes handle left sink
95+ | left <= (0 :: Int) = return ()
96+ | otherwise = do
97+ msg <- BS.hGet handle (megabytes 5)
98+ _ <- sink msg
99+ streamFiveMBNTimes handle (left - 1) sink
100+
106101
107−powerOfTwo :: Int -> Int
108−powerOfTwo = (2 ^)
109102
110103{-# NOINLINE manager' #-}
111104manager' :: C.Manager
112105manager' = unsafePerformIO $ C.newManager C.defaultManagerSettings
113106
114−withClient :: ClientM a -> BaseUrl -> (Either ClientError a -> IO r) -> IO r
115−withClient x baseUrl' = withClientM x (mkClientEnv manager' baseUrl')
107+runClient :: ClientM a -> BaseUrl -> IO (Either ServantError a)
108+runClient x baseUrl' = runClientM x (mkClientEnv manager' baseUrl')
116109
117−testRunSourceIO :: SourceIO a
118− -> IO (Either String [a])
119−testRunSourceIO = runExceptT . runSourceT
110+testRunResultStream :: ResultStream a
111+ -> IO ( Maybe (Either String a)
112+ , Maybe (Either String a)
113+ , Maybe (Either String a)
114+ , Maybe (Either String a))
115+testRunResultStream (ResultStream k)
116+ = k $ \act -> (,,,) <$> act <*> act <*> act <*> act
120117
121118streamSpec :: Spec
122−streamSpec = beforeAll (CT.startWaiApp server) $ afterAll CT.endWaiApp $ do
119+streamSpec = beforeAll (CS.startWaiApp server) $ afterAll CS.endWaiApp $ do
120+
123121 it "works with Servant.API.StreamGet.Newline" $ \(_, baseUrl) -> do
124− withClient getGetNL baseUrl $ \(Right res) ->
125− testRunSourceIO res `shouldReturn` Right [alice, bob, alice]
122+ Right res <- runClient getGetNL baseUrl
123+ let jra = Just (Right alice)
124+ jrb = Just (Right bob)
125+ testRunResultStream res `shouldReturn` (jra, jrb, jra, Nothing)
126126
127127 it "works with Servant.API.StreamGet.Netstring" $ \(_, baseUrl) -> do
128− withClient getGetNS baseUrl $ \(Right res) ->
129− testRunSourceIO res `shouldReturn` Right [alice, bob, alice]
130−
131− it "works with Servant.API.StreamBody" $ \(_, baseUrl) -> do
132− withClient (getStreamBody (source input)) baseUrl $ \(Right res) ->
133− testRunSourceIO res `shouldReturn` Right output
134− where
135− input = ["foo", "", "bar"]
136− output = ["foo", "bar"]
128+ Right res <- runClient getGetNS baseUrl
129+ let jra = Just (Right alice)
130+ jrb = Just (Right bob)
131+ testRunResultStream res `shouldReturn` (jra, jrb, jra, Nothing)
137132
138133{-
139134 it "streams in constant memory" $ \(_, baseUrl) -> do
140− Right rs <- runClient getGetALot baseUrl
141− performGC
142− -- usage0 <- getUsage
143− -- putStrLn $ "Start: " ++ show usage0
144− tdigest <- memoryUsage $ joinCodensitySourceT rs
145−
146− -- putStrLn $ "Median: " ++ show (TD.median tdigest)
147− -- putStrLn $ "Mean: " ++ show (TD.mean tdigest)
148− -- putStrLn $ "Stddev: " ++ show (TD.stddev tdigest)
149−
150− -- forM_ [0.01, 0.1, 0.2, 0.5, 0.8, 0.9, 0.99] $ \q ->
151− -- putStrLn $ "q" ++ show q ++ ": " ++ show (TD.quantile q tdigest)
152−
153− let Just stddev = TD.stddev tdigest
154−
155− -- standard deviation of 100k is ok, we generate 256M of data after all.
156− -- On my machine deviation is 40k-50k
157− stddev `shouldSatisfy` (< 100000)
158−
159−memoryUsage :: SourceT IO BS.ByteString -> IO (TD.TDigest 25)
160−memoryUsage src = unSourceT src $ loop mempty (0 :: Int)
161− where
162− loop !acc !_ Stop = return acc
163− loop !_ !_ (Error err) = fail err -- !
164− loop !acc !n (Skip s) = loop acc n s
165− loop !acc !n (Effect ms) = ms >>= loop acc n
166− loop !acc !n (Yield _bs s) = do
167− usage <- liftIO getUsage
168− -- We perform GC in between as we generate garbage.
169− when (n `mod` 1024 == 0) $ liftIO performGC
170− loop (TD.insert usage acc) (n + 1) s
171−
172−getUsage :: IO Double
173−getUsage = fromIntegral .
135+ Right (ResultStream res) <- runClient getGetALot baseUrl
136+ let consumeNChunks n = replicateM_ n (res void)
137+ consumeNChunks 900
174138#if MIN_VERSION_base(4,10,0)
175− gcdetails_live_bytes . gc <$> getRTSStats
139+ memUsed <- gcdetails_mem_in_use_bytes . gc <$> getRTSStats
176140#else
177− currentBytesUsed <$> getGCStats
141+ memUsed <- currentBytesUsed <$> getGCStats
178142#endif
179143 memUsed `shouldSatisfy` (< megabytes 22)
144+-}
180145
181146megabytes :: Num a => a -> a
182147megabytes n = n * (1000 ^ (2 :: Int))
183−-}
servant-client/test/Servant/SuccessSpec.hsdeleted−208
@@ -1,208 +0,0 @@
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 #-}
15−{-# OPTIONS_GHC -freduction-depth=100 #-}
16−{-# OPTIONS_GHC -fno-warn-orphans #-}
17−{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
18−
19−module Servant.SuccessSpec (spec) where
20−
21−import Prelude ()
22−import Prelude.Compat
23−
24−import Control.Arrow
25− ((+++), left)
26−import Control.Concurrent.STM
27− (atomically)
28−import Control.Concurrent.STM.TVar
29− (newTVar, readTVar)
30−import qualified Data.ByteString as BS
31−import qualified Data.ByteString.Lazy as BL
32−import Data.Foldable
33− (forM_, toList)
34−import Data.Maybe
35− (listToMaybe)
36−import Data.Monoid ()
37−import Data.Text
38− (Text)
39−import Data.Text.Encoding
40− (encodeUtf8)
41−import qualified Network.HTTP.Client as C
42−import qualified Network.HTTP.Types as HTTP
43−import Test.Hspec
44−import Test.Hspec.QuickCheck
45−import Test.HUnit
46−import Test.QuickCheck
47−
48−import Servant.API
49− (NoContent (NoContent), WithStatus (WithStatus), getHeaders, Headers(..))
50−import Servant.Client
51−import qualified Servant.Client.Core.Request as Req
52−import Servant.ClientTestUtils
53−import Servant.Test.ComprehensiveAPI
54−
55−-- This declaration simply checks that all instances are in place.
56−_ = client comprehensiveAPIWithoutStreaming
57−
58−spec :: Spec
59−spec = describe "Servant.SuccessSpec" $ do
60− successSpec
61−
62−successSpec :: Spec
63−successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
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
70−
71− it "get redirection endpoint" $ \(_, baseUrl) -> do
72− left show <$> runClient getGet307 baseUrl `shouldReturn` Right "redirecting"
73−
74− describe "Servant.API.Delete" $ do
75− it "allows empty content type" $ \(_, baseUrl) -> do
76− left show <$> runClient getDeleteEmpty baseUrl `shouldReturn` Right NoContent
77−
78− it "allows content type" $ \(_, baseUrl) -> do
79− left show <$> runClient getDeleteContentType baseUrl `shouldReturn` Right NoContent
80−
81− it "Servant.API.Capture" $ \(_, baseUrl) -> do
82− left show <$> runClient (getCapture "Paula") baseUrl `shouldReturn` Right (Person "Paula" 0)
83−
84− it "Servant.API.CaptureAll" $ \(_, baseUrl) -> do
85− let expected = [Person "Paula" 0, Person "Peta" 1]
86− left show <$> runClient (getCaptureAll ["Paula", "Peta"]) baseUrl `shouldReturn` Right expected
87−
88− it "Servant.API.ReqBody" $ \(_, baseUrl) -> do
89− let p = Person "Clara" 42
90− left show <$> runClient (getBody p) baseUrl `shouldReturn` Right p
91−
92− it "Servant.API FailureResponse" $ \(_, baseUrl) -> do
93− left show <$> runClient (getQueryParam (Just "alice")) baseUrl `shouldReturn` Right alice
94− Left (FailureResponse req _) <- runClient (getQueryParam (Just "bob")) baseUrl
95− Req.requestPath req `shouldBe` (baseUrl, "/param")
96− toList (Req.requestQueryString req) `shouldBe` [("name", Just "bob")]
97− Req.requestMethod req `shouldBe` HTTP.methodGet
98−
99− it "Servant.API.QueryParam" $ \(_, baseUrl) -> do
100− left show <$> runClient (getQueryParam (Just "alice")) baseUrl `shouldReturn` Right alice
101− Left (FailureResponse _ r) <- runClient (getQueryParam (Just "bob")) baseUrl
102− responseStatusCode r `shouldBe` HTTP.Status 400 "bob not found"
103−
104− it "Servant.API.QueryParam binary data" $ \(_, baseUrl) -> do
105− let payload = BS.pack [0, 1, 2, 4, 8, 16, 32, 64, 128]
106− apiCall = getQueryParamBinary (Just $ UrlEncodedByteString payload) HTTP.methodGet
107− (show +++ responseBody) <$> runClient apiCall baseUrl `shouldReturn` Right (BL.fromStrict payload)
108−
109− it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do
110− left show <$> runClient (getQueryParams []) baseUrl `shouldReturn` Right []
111− left show <$> runClient (getQueryParams ["alice", "bob"]) baseUrl
112− `shouldReturn` Right [Person "alice" 0, Person "bob" 1]
113−
114− context "Servant.API.QueryParam.QueryFlag" $
115− forM_ [False, True] $ \ flag -> it (show flag) $ \(_, baseUrl) -> do
116− left show <$> runClient (getQueryFlag flag) baseUrl `shouldReturn` Right flag
117−
118− it "Servant.API.Fragment" $ \(_, baseUrl) -> do
119− left id <$> runClient getFragment baseUrl `shouldReturn` Right alice
120−
121− it "Servant.API.Raw on success" $ \(_, baseUrl) -> do
122− res <- runClient (getRawSuccess HTTP.methodGet) baseUrl
123− case res of
124− Left e -> assertFailure $ show e
125− Right r -> do
126− responseStatusCode r `shouldBe` HTTP.status200
127− responseBody r `shouldBe` "rawSuccess"
128−
129− it "Servant.API.Raw should return a Left in case of failure" $ \(_, baseUrl) -> do
130− res <- runClient (getRawFailure HTTP.methodGet) baseUrl
131− case res of
132− Right _ -> assertFailure "expected Left, but got Right"
133− Left (FailureResponse _ r) -> do
134− responseStatusCode r `shouldBe` HTTP.status400
135− responseBody r `shouldBe` "rawFailure"
136− Left e -> assertFailure $ "expected FailureResponse, but got " ++ show e
137−
138− it "Returns headers appropriately" $ \(_, baseUrl) -> do
139− res <- runClient getRespHeaders baseUrl
140− case res of
141− Left e -> assertFailure $ show e
142− Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]
143−
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−
153− it "Stores Cookie in CookieJar after a redirect" $ \(_, baseUrl) -> do
154− mgr <- C.newManager C.defaultManagerSettings
155− cj <- atomically . newTVar $ C.createCookieJar []
156− _ <- runClientM (getRedirectWithCookie HTTP.methodGet) (ClientEnv mgr baseUrl (Just cj) defaultMakeClientRequest)
157− cookie <- listToMaybe . C.destroyCookieJar <$> atomically (readTVar cj)
158− C.cookie_name <$> cookie `shouldBe` Just "testcookie"
159− C.cookie_value <$> cookie `shouldBe` Just "test"
160−
161− it "Can modify the outgoing Request using the ClientEnv" $ \(_, baseUrl) -> do
162− mgr <- C.newManager C.defaultManagerSettings
163− -- In proper situation, extra headers should probably be visible in API type.
164− -- However, testing for response timeout is difficult, so we test with something which is easy to observe
165− let createClientRequest url r = fmap (\req -> req { C.requestHeaders = [("X-Added-Header", "XXX")] })
166− (defaultMakeClientRequest url r)
167− clientEnv = (mkClientEnv mgr baseUrl) { makeClientRequest = createClientRequest }
168− res <- runClientM (getRawSuccessPassHeaders HTTP.methodGet) clientEnv
169− case res of
170− Left e ->
171− assertFailure $ show e
172− Right r ->
173− ("X-Added-Header", "XXX") `elem` toList (responseHeaders r) `shouldBe` True
174−
175− modifyMaxSuccess (const 20) $ do
176− it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \(_, baseUrl) ->
177− property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->
178− ioProperty $ do
179− result <- left show <$> runClient (getMultiple cap num flag body) baseUrl
180− return $
181− result === Right (cap, num, flag, body)
182−
183− context "With a route that can either return success or redirect" $ do
184− it "Redirects when appropriate" $ \(_, baseUrl) -> do
185− eitherResponse <- runClient (uverbGetSuccessOrRedirect True) baseUrl
186− case eitherResponse of
187− Left clientError -> fail $ show clientError
188− Right response -> matchUnion response `shouldBe` Just (WithStatus @301 @Text "redirecting")
189−
190− it "Returns a proper response when appropriate" $ \(_, baseUrl) -> do
191− eitherResponse <- runClient (uverbGetSuccessOrRedirect False) baseUrl
192− case eitherResponse of
193− Left clientError -> fail $ show clientError
194− Right response -> matchUnion response `shouldBe` Just (WithStatus @200 alice)
195−
196− context "with a route that uses uverb but only has a single response" $
197− it "returns the expected response" $ \(_, baseUrl) -> do
198− eitherResponse <- runClient (uverbGetCreated) baseUrl
199− case eitherResponse of
200− Left clientError -> fail $ show clientError
201− Right response -> matchUnion response `shouldBe` Just (WithStatus @201 carol)
202−
203− it "encodes URL pieces following ToHttpApiData instance" $ \(_, baseUrl) -> do
204− let textOrig = "*"
205− eitherResponse <- runClient (captureVerbatim $ Verbatim $ encodeUtf8 textOrig) baseUrl
206− case eitherResponse of
207− Left clientError -> fail $ show clientError
208− Right textBack -> textBack `shouldBe` textOrig
servant-client/test/Servant/WrappedApiSpec.hsdeleted−63
@@ -1,63 +0,0 @@
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.WrappedApiSpec (spec) where
19−
20−import Prelude ()
21−import Prelude.Compat
22−
23−import Control.Exception
24− (bracket)
25−import Control.Monad.Error.Class
26− (throwError)
27−import Data.Monoid ()
28−import Data.Proxy
29−import qualified Network.HTTP.Types as HTTP
30−import Test.Hspec
31−
32−import Servant.API
33− (Delete, Get, JSON, Post, Put)
34−import Servant.Client
35−import Servant.Server
36−import Servant.ClientTestUtils
37−
38−spec :: Spec
39−spec = describe "Servant.WrappedApiSpec" $ do
40− wrappedApiSpec
41−
42−data WrappedApi where
43− WrappedApi :: (HasServer (api :: *) '[], Server api ~ Handler a,
44− HasClient ClientM api, Client ClientM api ~ ClientM ()) =>
45− Proxy api -> WrappedApi
46−
47−wrappedApiSpec :: Spec
48−wrappedApiSpec = describe "error status codes" $ do
49− let serveW api = serve api $ throwError $ ServerError 500 "error message" "" []
50− context "are correctly handled by the client" $
51− let test :: (WrappedApi, String) -> Spec
52− test (WrappedApi api, desc) =
53− it desc $ bracket (startWaiApp $ serveW api) endWaiApp $ \(_, baseUrl) -> do
54− let getResponse :: ClientM ()
55− getResponse = client api
56− Left (FailureResponse _ r) <- runClient getResponse baseUrl
57− responseStatusCode r `shouldBe` HTTP.Status 500 "error message"
58− in mapM_ test $
59− (WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") :
60− (WrappedApi (Proxy :: Proxy (Get '[JSON] ())), "Get") :
61− (WrappedApi (Proxy :: Proxy (Post '[JSON] ())), "Post") :
62− (WrappedApi (Proxy :: Proxy (Put '[JSON] ())), "Put") :
63− []
servant-client/tinc.yamlnew file+5
@@ -0,0 +1,5 @@
1+dependencies:
2+ - name: servant
3+ path: ../servant
4+ - name: servant-server
5+ path: ../servant-server
servant-conduit/CHANGELOG.mddeleted−4
@@ -1,4 +0,0 @@
1−0.15
2−----
3−
4−- First release with support for `servant-0.15` `Stream` refactoring.
servant-conduit/LICENSEdeleted−30
@@ -1,30 +0,0 @@
1−Copyright (c) 2018, Servant Contributors
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 Servant Contributors 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.
servant-conduit/README.mddeleted−3
@@ -1,3 +0,0 @@
1−# servant-conduit - Servant Stream support for conduit
2−
3−![servant](https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png)
servant-conduit/Setup.hsdeleted−2
@@ -1,2 +0,0 @@
1−import Distribution.Simple
2−main = defaultMain
servant-conduit/example/Main.hsdeleted−103
@@ -1,103 +0,0 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE DeriveGeneric #-}
3−{-# LANGUAGE TypeOperators #-}
4−module Main (main) where
5−
6−import Prelude ()
7−import Prelude.Compat
8−
9−import Control.Concurrent
10− (threadDelay)
11−import Control.Monad.IO.Class
12− (MonadIO (..))
13−import Control.Monad.Trans.Resource
14− (ResourceT)
15−import qualified Data.ByteString as BS
16−import Data.Maybe
17− (fromMaybe)
18−import Network.HTTP.Client
19− (defaultManagerSettings, newManager)
20−import Network.Wai
21− (Application)
22−import System.Environment
23− (getArgs, lookupEnv)
24−import Text.Read
25− (readMaybe)
26−
27−import Data.Conduit
28−import qualified Data.Conduit.Combinators as C
29−import Servant
30−import Servant.Client.Streaming
31−import Servant.Conduit ()
32−
33−import qualified Network.Wai.Handler.Warp as Warp
34−
35−type FastAPI = "get" :> Capture "num" Int :> StreamGet NewlineFraming JSON (ConduitT () Int IO ())
36−
37−type API = FastAPI
38− :<|> "slow" :> Capture "num" Int :> StreamGet NewlineFraming JSON (ConduitT () Int IO ())
39− -- monad can be ResourceT IO too.
40− :<|> "readme" :> StreamGet NoFraming OctetStream (ConduitT () BS.ByteString (ResourceT IO) ())
41− -- we can have streaming request body
42− :<|> "proxy"
43− :> StreamBody NoFraming OctetStream (ConduitT () BS.ByteString IO ())
44− :> StreamPost NoFraming OctetStream (ConduitT () BS.ByteString IO ())
45−
46−api :: Proxy API
47−api = Proxy
48−
49−server :: Server API
50−server = fast :<|> slow :<|> readme :<|> proxy
51− where
52− fast n = liftIO $ do
53− putStrLn $ "/get/" ++ show n
54− return $ fastConduit n
55−
56− slow n = liftIO $ do
57− putStrLn $ "/slow/" ++ show n
58− return $ slowConduit n
59−
60− readme = liftIO $ do
61− putStrLn "/proxy"
62− return (C.sourceFile "README.md")
63−
64− proxy c = liftIO $ do
65− putStrLn "/proxy"
66− return c
67−
68− -- for some reason unfold leaks?
69− fastConduit = C.unfold mk where
70− mk m
71− | m < 0 = Nothing
72− | otherwise = Just (m, pred m)
73−
74− slowConduit m = fastConduit m .| C.mapM (<$ threadDelay 1000000)
75−
76−app :: Application
77−app = serve api server
78−
79−cli :: Client ClientM FastAPI
80−cli :<|> _ :<|> _ :<|> _ = client api
81−
82−main :: IO ()
83−main = do
84− args <- getArgs
85− case args of
86− ("server":_) -> do
87− putStrLn "Starting servant-conduit:example at http://localhost:8000"
88− port <- fromMaybe 8000 . (>>= readMaybe) <$> lookupEnv "PORT"
89− Warp.run port app
90− ("client":ns:_) -> do
91− n <- maybe (fail $ "not a number: " ++ ns) pure $ readMaybe ns
92− mgr <- newManager defaultManagerSettings
93− burl <- parseBaseUrl "http://localhost:8000/"
94− withClientM (cli n) (mkClientEnv mgr burl) $ \me -> case me of
95− Left err -> print err
96− Right c -> do
97− x <- connect c $ C.foldl (\p _ -> p + 1) (0 :: Int)
98− print x
99− _ -> do
100− putStrLn "Try:"
101− putStrLn "cabal new-run servant-conduit:example server"
102− putStrLn "cabal new-run servant-conduit:example client 10"
103− putStrLn "time curl -H 'Accept: application/json' localhost:8000/slow/5"
servant-conduit/servant-conduit.cabaldeleted−62
@@ -1,62 +0,0 @@
1−cabal-version: 2.2
2−name: servant-conduit
3−version: 0.15.1
4−
5−synopsis: Servant Stream support for conduit.
6−category: Servant, Web, Enumerator
7−description: Servant Stream support for conduit.
8− .
9− Provides 'ToSourceIO' and 'FromSourceIO' instances for 'ConduitT'.
10−
11−homepage: http://docs.servant.dev/
12−bug-reports: http://github.com/haskell-servant/servant/issues
13−license: BSD-3-Clause
14−license-file: LICENSE
15−author: Servant Contributors
16−maintainer: haskell-servant-maintainers@googlegroups.com
17−copyright: 2018-2019 Servant Contributors
18−build-type: Simple
19−tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2
20−
21−extra-source-files:
22− CHANGELOG.md
23−
24−source-repository head
25− type: git
26− location: http://github.com/haskell-servant/servant.git
27−
28−library
29− exposed-modules: Servant.Conduit
30− build-depends:
31− base >=4.9 && <5
32− , bytestring >=0.10.8.1 && <0.12
33− , conduit >=1.3.1 && <1.4
34− , mtl ^>=2.2.2 || ^>=2.3.1
35− , resourcet >=1.2.2 && <1.4
36− , servant >=0.15 && <0.20
37− , unliftio-core >=0.1.2.0 && <0.3
38− hs-source-dirs: src
39− default-language: Haskell2010
40− ghc-options: -Wall
41−
42−test-suite example
43− type: exitcode-stdio-1.0
44− main-is: Main.hs
45− hs-source-dirs:
46− example
47− ghc-options: -Wall -rtsopts -threaded
48− build-depends:
49− base
50− , base-compat
51− , bytestring
52− , conduit
53− , http-media
54− , resourcet
55− , servant
56− , servant-conduit
57− , servant-server >=0.15 && <0.20
58− , servant-client >=0.15 && <0.20
59− , wai >=3.2.1.2 && <3.3
60− , warp >=3.2.25 && <3.4
61− , http-client
62− default-language: Haskell2010
servant-conduit/src/Servant/Conduit.hsdeleted−72
@@ -1,72 +0,0 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE FlexibleInstances #-}
3−{-# LANGUAGE GADTs #-}
4−{-# LANGUAGE MultiParamTypeClasses #-}
5−{-# LANGUAGE RankNTypes #-}
6−{-# LANGUAGE ScopedTypeVariables #-}
7−{-# LANGUAGE UndecidableInstances #-}
8−{-# OPTIONS_GHC -Wno-orphans #-}
9−-- | This module exports 'ToSourceIO' and 'FromSourceIO' for 'ConduitT' instances.
10−module Servant.Conduit (
11− ConduitToSourceIO (..),
12− ) where
13−
14−import Control.Monad.IO.Class
15− (MonadIO (..))
16−import Control.Monad.IO.Unlift
17− (MonadUnliftIO (..))
18−import Control.Monad.Trans.Resource
19− (ResourceT, runResourceT)
20−import Data.Conduit.Internal
21− (ConduitT (..), Pipe (..))
22−import Servant.API.Stream
23−import qualified Servant.Types.SourceT as S
24−
25−-- | Helper class to implement @'ToSourceIO' 'ConduitT'@ instance
26−-- for various monads.
27−class ConduitToSourceIO m where
28− conduitToSourceIO :: ConduitT i o m () -> SourceIO o
29−
30−instance ConduitToSourceIO IO where
31− conduitToSourceIO (ConduitT con) = S.SourceT ($ go (con Done)) where
32− go p0 = case p0 of
33− Done () -> S.Stop
34− HaveOutput p o -> S.Yield o (go p)
35− NeedInput _ip up -> S.Skip (go (up ()))
36− PipeM m -> S.Effect $ fmap go m
37− Leftover p _l -> S.Skip (go p)
38−
39−instance m ~ IO => ConduitToSourceIO (ResourceT m) where
40− conduitToSourceIO (ConduitT con) =
41− S.SourceT $ \k ->
42− runResourceT $ withRunInIO $ \runRes ->
43− k (go runRes (con Done))
44− where
45− go :: (forall x. ResourceT m x -> m x)
46− -> Pipe i i o () (ResourceT m) ()
47− -> S.StepT IO o
48− go _ (Done ()) = S.Stop
49− go runRes (HaveOutput p o) = S.Yield o (go runRes p)
50− go runRes (NeedInput _ip up) = S.Skip (go runRes (up ()))
51− go runRes (PipeM m) = S.Effect $ runRes $ fmap (go runRes) m
52− go runRes (Leftover p _l) = S.Skip (go runRes p)
53−
54−instance (ConduitToSourceIO m, r ~ ())
55− => ToSourceIO o (ConduitT i o m r)
56− where
57− toSourceIO = conduitToSourceIO
58−
59−instance (MonadIO m, r ~ ()) => FromSourceIO o (ConduitT i o m r) where
60− fromSourceIO src =
61− ConduitT $ \con ->
62− PipeM $ liftIO $ S.unSourceT src $ \step ->
63− loop con step
64− where
65− loop :: MonadIO m => (() -> Pipe i i o () m b) -> S.StepT IO o -> IO (Pipe i i o () m b)
66− loop con S.Stop = return (con ())
67− loop _con (S.Error err) = fail err
68− loop con (S.Skip s) = loop con s
69− loop con (S.Effect ms) = ms >>= loop con
70− loop con (S.Yield x s) = return (HaveOutput (PipeM (liftIO $ loop con s)) x)
71−
72− {-# SPECIALIZE INLINE fromSourceIO :: SourceIO o -> ConduitT i o IO () #-}
servant-docs/CHANGELOG.md−91
@@ -1,97 +1,6 @@
11[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-docs/CHANGELOG.md)
22[Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)
33
4−0.12
5−----
6−
7−### Significant changes
8−
9−- Generate sample cURL requests
10− ([#1401](https://github.com/haskell-servant/servant/pull/1401/files)).
11− Breaking change: requires sample header values to be supplied with `headers`.
12−
13−0.11.9
14−------
15−
16−### Significant changes
17−
18−- Use Capture Description if available (#1423).
19−
20−### Other changes
21−
22−- Support GHC-9.0.1.
23−- Bump `bytestring` and `lens` dependencies.
24−
25−0.11.8
26−------
27−
28−### Significant changes
29−
30−- Support `Fragment` combinator.
31−
32−0.11.7
33−------
34−
35−### Significant changes
36−
37−- Add instance for ToSample NonEmpty
38−
39−### Other changes
40−
41−- Bump "tested-with" ghc versions
42−- Fix servant-docs code sample in README
43−
44−0.11.5
45−----
46−
47−
48−- Add NoContentVerb [#1028](https://github.com/haskell-servant/servant/issues/1028) [#1219](https://github.com/haskell-servant/servant/pull/1219) [#1228](https://github.com/haskell-servant/servant/pull/1228)
49−
50− The `NoContent` API endpoints should now use `NoContentVerb` combinator.
51− The API type changes are usually of the kind
52−
53− ```diff
54− - :<|> PostNoContent '[JSON] NoContent
55− + :<|> PostNoContent
56− ```
57−
58− i.e. one doesn't need to specify the content-type anymore. There is no content.
59−
60−- `Capture` can be `Lenient` [#1155](https://github.com/haskell-servant/servant/issues/1155) [#1156](https://github.com/haskell-servant/servant/pull/1156)
61−
62− You can specify a lenient capture as
63−
64− ```haskell
65− :<|> "capture-lenient" :> Capture' '[Lenient] "foo" Int :> GET
66− ```
67−
68− which will make the capture always succeed. Handlers will be of the
69− type `Either String CapturedType`, where `Left err` represents
70− the possible parse failure.
71−
72−- *servant-docs* Merge documentation from duplicate routes [#1240](https://github.com/haskell-servant/servant/issues/1240) [#1241](https://github.com/haskell-servant/servant/pull/1241)
73−
74− Servant supports defining the same route multiple times with different
75− content-types and result-types, but servant-docs was only documenting
76− the first of copy of such duplicated routes. It now combines the
77− documentation from all the copies.
78−
79− Unfortunately, it is not yet possible for the documentation to specify
80− multiple status codes.
81−
82−- *servant-docs* Prevent race-conditions in testing [#1194](https://github.com/haskell-servant/servant/pull/1194)
83−
84−0.11.4
85−------
86−
87−- Drop dependency on `control-monad-omega` in favor of `Data.Universe.Helpers` from `universe-base`.
88−
89−0.11.3
90−------
91−
92−- Support `servant-0.15`
93− - Instances for 'Stream' and 'StreamBody'
94−
9540.11.2
965------
976
servant-docs/LICENSE+1−1
@@ -1,4 +1,4 @@
1−Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, 2016-2018 Servant Contributors
1+Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, Servant Contributors
22
33All rights reserved.
44
servant-docs/README.md+11−44
@@ -2,56 +2,24 @@
22
33![servant](https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png)
44
5−Generate API docs for your _servant_ webservice. Feel free to also take a look at [servant-pandoc](https://github.com/mpickering/servant-pandoc) which uses this package to target a broad range of output formats using the excellent **pandoc**.
5+Generate API docs for your *servant* webservice. Feel free to also take a look at [servant-pandoc](https://github.com/mpickering/servant-pandoc) which uses this package to target a broad range of output formats using the excellent **pandoc**.
66
77## Example
88
99See [here](https://github.com/haskell-servant/servant/blob/master/servant-docs/example/greet.md) for the output of the following program.
1010
11−```haskell
11+``` haskell
1212{-# LANGUAGE DataKinds #-}
13−{-# LANGUAGE DeriveGeneric #-}
14−{-# LANGUAGE FlexibleInstances #-}
15−{-# LANGUAGE MultiParamTypeClasses #-}
16−{-# LANGUAGE OverloadedStrings #-}
1713{-# LANGUAGE PolyKinds #-}
1814{-# LANGUAGE TypeFamilies #-}
15+{-# LANGUAGE DeriveGeneric #-}
1916{-# LANGUAGE TypeOperators #-}
17+{-# LANGUAGE FlexibleInstances #-}
18+{-# LANGUAGE OverloadedStrings #-}
2019
21−import Data.Aeson (FromJSON, ToJSON)
22−import Data.Proxy (Proxy (..))
23−import Data.String.Conversions (cs)
24−import Data.Text (Text)
25−import GHC.Generics (Generic)
26−import Servant.API
27− ( (:<|>),
28− (:>),
29− Capture,
30− Delete,
31− Get,
32− JSON,
33− MimeRender,
34− PlainText,
35− Post,
36− QueryParam,
37− ReqBody,
38− mimeRender,
39− )
20+import Data.Proxy
21+import Data.Text
4022import Servant.Docs
41− ( API,
42− DocCapture (..),
43− DocQueryParam (..),
44− ParamKind (..),
45− ToCapture,
46− ToParam,
47− ToSample,
48− docs,
49− markdown,
50− singleSample,
51− toCapture,
52− toParam,
53− toSamples,
54− )
5523
5624-- our type for a Greeting message
5725data Greet = Greet { _msg :: Text }
@@ -61,7 +29,6 @@ data Greet = Greet { _msg :: Text }
6129-- 'MimeRender' instance for 'JSON'.
6230instance FromJSON Greet
6331instance ToJSON Greet
64−instance ToSample ()
6532
6633-- We can also implement 'MimeRender' explicitly for additional formats.
6734instance MimeRender PlainText Greet where
@@ -69,7 +36,8 @@ instance MimeRender PlainText Greet where
6936
7037-- we provide a sample value for the 'Greet' type
7138instance ToSample Greet where
72− toSamples _ = singleSample g
39+ toSample = Just g
40+
7341 where g = Greet "Hello, haskeller!"
7442
7543instance ToParam (QueryParam "capital" Bool) where
@@ -77,7 +45,6 @@ instance ToParam (QueryParam "capital" Bool) where
7745 DocQueryParam "capital"
7846 ["true", "false"]
7947 "Get the greeting message in uppercase (true) or not (false). Default is false."
80− Normal
8148
8249instance ToCapture (Capture "name" Text) where
8350 toCapture _ = DocCapture "name" "name of the person to greet"
@@ -88,8 +55,8 @@ instance ToCapture (Capture "greetid" Text) where
8855-- API specification
8956type TestApi =
9057 "hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get '[JSON,PlainText] Greet
91− :<|> "greet" :> ReqBody '[JSON] Greet :> Post '[JSON] Greet
92− :<|> "delete" :> Capture "greetid" Text :> Delete '[JSON] ()
58+ :<|> "greet" :> RQBody '[JSON] Greet :> Post '[JSON] Greet
59+ :<|> "delete" :> Capture "greetid" Text :> Delete '[] ()
9360
9461testApi :: Proxy TestApi
9562testApi = Proxy
servant-docs/example/greet.hs+4−4
@@ -75,7 +75,7 @@ intro2 = DocIntro "This title is below the last"
7575-- API specification
7676type TestApi =
7777 -- GET /hello/:name?capital={true, false} returns a Greet as JSON or PlainText
78− "hello" :> Capture "name" Text :> Header "X-Num-Fairies" Int :> QueryParam "capital" Bool :> Get '[JSON, PlainText] Greet
78+ "hello" :> Capture "name" Text :> 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 <>~ [("X-Num-Unicorns", "1")]
96+ defAction & headers <>~ ["unicorns"]
9797 & notes <>~ [ DocNote "Title" ["This is some text"]
98− , DocNote "Second section" ["And some more"]
98+ , DocNote "Second secton" ["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 $ markdownWith (defRenderingOptions { _renderCurlBasePath = Just "http://localhost:80" }) docsGreet
112+main = putStrLn $ markdown docsGreet
servant-docs/example/greet.md+27−55
@@ -10,144 +10,116 @@ You'll also note that multiple intros are possible.
1010
1111## POST /greet
1212
13−### Request:
13+#### Request:
1414
1515- Supported content types are:
1616
17− - `application/json;charset=utf-8`
1817 - `application/json`
1918
20−- If you use ?capital=true (`application/json;charset=utf-8`, `application/json`):
19+- Example: `application/json`
2120
2221```javascript
2322"HELLO, HASKELLER"
2423```
2524
26−- If you use ?capital=false (`application/json;charset=utf-8`, `application/json`):
25+#### Response:
2726
28−```javascript
29−"Hello, haskeller"
30−```
31−
32−### Response:
33−
34−- Status code 200
27+- Status code 201
3528- Headers: [("X-Example","1729")]
3629
3730- Supported content types are:
3831
39− - `application/json;charset=utf-8`
4032 - `application/json`
4133
42−- If you use ?capital=true (`application/json;charset=utf-8`, `application/json`):
34+- If you use ?capital=true
4335
4436```javascript
4537"HELLO, HASKELLER"
4638```
4739
48−- If you use ?capital=false (`application/json;charset=utf-8`, `application/json`):
40+- If you use ?capital=false
4941
5042```javascript
5143"Hello, haskeller"
5244```
5345
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−
6346## DELETE /greet/:greetid
6447
65−### Title
48+#### Title
6649
6750This is some text
6851
69−### Second section
52+#### Second secton
7053
7154And some more
7255
73−### Captures:
56+#### Captures:
7457
7558- *greetid*: identifier of the greet msg to remove
7659
77−### Headers:
7860
79−- This endpoint is sensitive to the value of the **X-Num-Unicorns** HTTP header.
61+- This endpoint is sensitive to the value of the **unicorns** HTTP header.
8062
81−### Response:
63+#### Response:
8264
8365- Status code 200
8466- Headers: []
8567
8668- Supported content types are:
8769
88− - `application/json;charset=utf-8`
8970 - `application/json`
9071
91−- Example (`application/json;charset=utf-8`, `application/json`):
72+- Response body as below.
9273
9374```javascript
94−
95−```
96−
97−### Sample Request:
98−
99−```bash
100−curl -XDELETE \
101− -H "X-Num-Unicorns: 1" \
102− http://localhost:80/greet/:greetid
75+[]
10376```
10477
10578## GET /hello/:name
10679
107−### Captures:
80+#### Captures:
10881
10982- *name*: name of the person to greet
11083
111−### Headers:
112−
113−- This endpoint is sensitive to the value of the **X-Num-Fairies** HTTP header.
114−
115−### GET Parameters:
84+#### GET Parameters:
11685
11786- capital
11887 - **Values**: *true, false*
11988 - **Description**: Get the greeting message in uppercase (true) or not (false).Default is false.
12089
12190
122−### Response:
91+#### Response:
12392
12493- Status code 200
12594- Headers: []
12695
12796- Supported content types are:
12897
129− - `application/json;charset=utf-8`
13098 - `application/json`
13199 - `text/plain;charset=utf-8`
132100
133−- If you use ?capital=true (`application/json;charset=utf-8`, `application/json`, `text/plain;charset=utf-8`):
101+- If you use ?capital=true
134102
135103```javascript
136104"HELLO, HASKELLER"
137105```
138106
139−- If you use ?capital=false (`application/json;charset=utf-8`, `application/json`):
107+- If you use ?capital=true
108+
109+```
110+"HELLO, HASKELLER"
111+```
112+
113+- If you use ?capital=false
140114
141115```javascript
142116"Hello, haskeller"
143117```
144118
145−### Sample Request:
119+- If you use ?capital=false
146120
147−```bash
148−curl -XGET \
149− -H "X-Num-Fairies: 1729" \
150− http://localhost:80/hello/:name
121+```
122+"Hello, haskeller"
151123```
152124
153125
servant-docs/golden/comprehensive.mddeleted−610
@@ -1,610 +0,0 @@
1−## GET /
2−
3−### Response:
4−
5−- Status code 200
6−- Headers: []
7−
8−- Supported content types are:
9−
10− - `application/json;charset=utf-8`
11− - `application/json`
12−
13−- Example (`application/json;charset=utf-8`, `application/json`):
14−
15−```javascript
16−
17−```
18−
19−## GET /alternative/left
20−
21−### Response:
22−
23−- Status code 200
24−- Headers: []
25−
26−- Supported content types are:
27−
28− - `application/json;charset=utf-8`
29− - `application/json`
30−
31−- Example (`application/json;charset=utf-8`, `application/json`):
32−
33−```javascript
34−
35−```
36−
37−## GET /alternative/right
38−
39−### Response:
40−
41−- Status code 200
42−- Headers: []
43−
44−- Supported content types are:
45−
46− - `application/json;charset=utf-8`
47− - `application/json`
48−
49−- Example (`application/json;charset=utf-8`, `application/json`):
50−
51−```javascript
52−
53−```
54−
55−## GET /capture/:bar
56−
57−### Captures:
58−
59−- *bar*: example description
60−
61−### Response:
62−
63−- Status code 200
64−- Headers: []
65−
66−- Supported content types are:
67−
68− - `application/json;charset=utf-8`
69− - `application/json`
70−
71−- Example (`application/json;charset=utf-8`, `application/json`):
72−
73−```javascript
74−
75−```
76−
77−## GET /capture-all/:foo
78−
79−### Captures:
80−
81−- *foo*: Capture all foo Int
82−
83−### Response:
84−
85−- Status code 200
86−- Headers: []
87−
88−- Supported content types are:
89−
90− - `application/json;charset=utf-8`
91− - `application/json`
92−
93−- Example (`application/json;charset=utf-8`, `application/json`):
94−
95−```javascript
96−
97−```
98−
99−## GET /capture-lenient/:foo
100−
101−### Captures:
102−
103−- *foo*: Capture foo Int
104−
105−### Response:
106−
107−- Status code 200
108−- Headers: []
109−
110−- Supported content types are:
111−
112− - `application/json;charset=utf-8`
113− - `application/json`
114−
115−- Example (`application/json;charset=utf-8`, `application/json`):
116−
117−```javascript
118−
119−```
120−
121−## GET /description
122−
123−### foo
124−
125−
126−### Response:
127−
128−- Status code 200
129−- Headers: []
130−
131−- Supported content types are:
132−
133− - `application/json;charset=utf-8`
134− - `application/json`
135−
136−- Example (`application/json;charset=utf-8`, `application/json`):
137−
138−```javascript
139−
140−```
141−
142−## GET /flag
143−
144−### GET Parameters:
145−
146−- foo
147− - **Description**: QueryFlag
148− - This parameter is a **flag**. This means no value is expected to be associated to this parameter.
149−
150−
151−### Response:
152−
153−- Status code 200
154−- Headers: []
155−
156−- Supported content types are:
157−
158− - `application/json;charset=utf-8`
159− - `application/json`
160−
161−- Example (`application/json;charset=utf-8`, `application/json`):
162−
163−```javascript
164−
165−```
166−
167−## GET /foo
168−
169−### Response:
170−
171−- Status code 200
172−- Headers: []
173−
174−- Supported content types are:
175−
176− - `application/json;charset=utf-8`
177− - `application/json`
178−
179−- Example (`application/json;charset=utf-8`, `application/json`):
180−
181−```javascript
182−
183−```
184−
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−
207−## GET /get-int
208−
209−### Response:
210−
211−- Status code 200
212−- Headers: []
213−
214−- Supported content types are:
215−
216− - `application/json;charset=utf-8`
217− - `application/json`
218−
219−- Example (`application/json;charset=utf-8`, `application/json`):
220−
221−```javascript
222−17
223−```
224−
225−## GET /header
226−
227−### Headers:
228−
229−- This endpoint is sensitive to the value of the **foo** HTTP header.
230−
231−### Response:
232−
233−- Status code 200
234−- Headers: []
235−
236−- Supported content types are:
237−
238− - `application/json;charset=utf-8`
239− - `application/json`
240−
241−- Example (`application/json;charset=utf-8`, `application/json`):
242−
243−```javascript
244−
245−```
246−
247−## GET /header-lenient
248−
249−### Headers:
250−
251−- This endpoint is sensitive to the value of the **bar** HTTP header.
252−
253−### Response:
254−
255−- Status code 200
256−- Headers: []
257−
258−- Supported content types are:
259−
260− - `application/json;charset=utf-8`
261− - `application/json`
262−
263−- Example (`application/json;charset=utf-8`, `application/json`):
264−
265−```javascript
266−
267−```
268−
269−## GET /http-version
270−
271−### Response:
272−
273−- Status code 200
274−- Headers: []
275−
276−- Supported content types are:
277−
278− - `application/json;charset=utf-8`
279− - `application/json`
280−
281−- Example (`application/json;charset=utf-8`, `application/json`):
282−
283−```javascript
284−
285−```
286−
287−## GET /is-secure
288−
289−### Response:
290−
291−- Status code 200
292−- Headers: []
293−
294−- Supported content types are:
295−
296− - `application/json;charset=utf-8`
297− - `application/json`
298−
299−- Example (`application/json;charset=utf-8`, `application/json`):
300−
301−```javascript
302−
303−```
304−
305−## GET /named-context
306−
307−### Response:
308−
309−- Status code 200
310−- Headers: []
311−
312−- Supported content types are:
313−
314− - `application/json;charset=utf-8`
315− - `application/json`
316−
317−- Example (`application/json;charset=utf-8`, `application/json`):
318−
319−```javascript
320−
321−```
322−
323−## GET /param
324−
325−### GET Parameters:
326−
327−- foo
328− - **Values**: *1, 2, 3*
329− - **Description**: QueryParams Int
330−
331−
332−### Response:
333−
334−- Status code 200
335−- Headers: []
336−
337−- Supported content types are:
338−
339− - `application/json;charset=utf-8`
340− - `application/json`
341−
342−- Example (`application/json;charset=utf-8`, `application/json`):
343−
344−```javascript
345−
346−```
347−
348−## GET /param-lenient
349−
350−### GET Parameters:
351−
352−- bar
353− - **Values**: *1, 2, 3*
354− - **Description**: QueryParams Int
355−
356−
357−### Response:
358−
359−- Status code 200
360−- Headers: []
361−
362−- Supported content types are:
363−
364− - `application/json;charset=utf-8`
365− - `application/json`
366−
367−- Example (`application/json;charset=utf-8`, `application/json`):
368−
369−```javascript
370−
371−```
372−
373−## GET /params
374−
375−### GET Parameters:
376−
377−- foo
378− - **Values**: *1, 2, 3*
379− - **Description**: QueryParams Int
380− - This parameter is a **list**. All GET parameters with the name foo[] will forward their values in a list to the handler.
381−
382−
383−### Response:
384−
385−- Status code 200
386−- Headers: []
387−
388−- Supported content types are:
389−
390− - `application/json;charset=utf-8`
391− - `application/json`
392−
393−- Example (`application/json;charset=utf-8`, `application/json`):
394−
395−```javascript
396−
397−```
398−
399−## POST /post-int
400−
401−### Response:
402−
403−- Status code 204
404−- Headers: []
405−
406−- Supported content types are:
407−
408− - `application/json;charset=utf-8`
409− - `application/json`
410−
411−- Example (`application/json;charset=utf-8`, `application/json`):
412−
413−```javascript
414−17
415−```
416−
417−## POST /post-no-content
418−
419−### Response:
420−
421−- Status code 204
422−- Headers: []
423−
424−- No response body
425−
426−## GET /raw
427−
428−### Response:
429−
430−- Status code 200
431−- Headers: []
432−
433−- No response body
434−
435−## GET /remote-host
436−
437−### Response:
438−
439−- Status code 200
440−- Headers: []
441−
442−- Supported content types are:
443−
444− - `application/json;charset=utf-8`
445− - `application/json`
446−
447−- Example (`application/json;charset=utf-8`, `application/json`):
448−
449−```javascript
450−
451−```
452−
453−## GET /req-body
454−
455−### Request:
456−
457−- Supported content types are:
458−
459− - `application/json;charset=utf-8`
460− - `application/json`
461−
462−- Example (`application/json;charset=utf-8`, `application/json`):
463−
464−```javascript
465−17
466−```
467−
468−### Response:
469−
470−- Status code 200
471−- Headers: []
472−
473−- Supported content types are:
474−
475− - `application/json;charset=utf-8`
476− - `application/json`
477−
478−- Example (`application/json;charset=utf-8`, `application/json`):
479−
480−```javascript
481−
482−```
483−
484−## GET /req-body-lenient
485−
486−### Request:
487−
488−- Supported content types are:
489−
490− - `application/json;charset=utf-8`
491− - `application/json`
492−
493−- Example (`application/json;charset=utf-8`, `application/json`):
494−
495−```javascript
496−17
497−```
498−
499−### Response:
500−
501−- Status code 200
502−- Headers: []
503−
504−- Supported content types are:
505−
506− - `application/json;charset=utf-8`
507− - `application/json`
508−
509−- Example (`application/json;charset=utf-8`, `application/json`):
510−
511−```javascript
512−
513−```
514−
515−## GET /res-headers
516−
517−### Response:
518−
519−- Status code 200
520−- Headers: [("foo","17")]
521−
522−- Supported content types are:
523−
524− - `application/json;charset=utf-8`
525− - `application/json`
526−
527−- Example (`application/json;charset=utf-8`, `application/json`):
528−
529−```javascript
530−
531−```
532−
533−## GET /resource
534−
535−### Response:
536−
537−- Status code 200
538−- Headers: []
539−
540−- Supported content types are:
541−
542− - `application/json;charset=utf-8`
543− - `application/json`
544−
545−- Example (`application/json;charset=utf-8`, `application/json`):
546−
547−```javascript
548−
549−```
550−
551−## GET /streaming
552−
553−### Request:
554−
555−- Supported content types are:
556−
557− - `application/json;charset=utf-8`
558− - `application/json`
559−
560−### Response:
561−
562−- Status code 200
563−- Headers: []
564−
565−- Supported content types are:
566−
567− - `application/json;charset=utf-8`
568− - `application/json`
569−
570−- No response body
571−
572−## GET /summary
573−
574−### foo
575−
576−
577−### Response:
578−
579−- Status code 200
580−- Headers: []
581−
582−- Supported content types are:
583−
584− - `application/json;charset=utf-8`
585− - `application/json`
586−
587−- Example (`application/json;charset=utf-8`, `application/json`):
588−
589−```javascript
590−
591−```
592−
593−## GET /vault
594−
595−### Response:
596−
597−- Status code 200
598−- Headers: []
599−
600−- Supported content types are:
601−
602− - `application/json;charset=utf-8`
603− - `application/json`
604−
605−- Example (`application/json;charset=utf-8`, `application/json`):
606−
607−```javascript
608−
609−```
610−
servant-docs/servant-docs.cabal+31−32
@@ -1,31 +1,31 @@
1−cabal-version: 2.2
21name: servant-docs
3−version: 0.12
4−
2+version: 0.11.2
3+x-revision: 5
54synopsis: generate API docs for your servant webservice
6−category: Servant, Web
75description:
86 Library for generating API docs from a servant API definition.
97 .
108 Runnable example <https://github.com/haskell-servant/servant/blob/master/servant-docs/example/greet.hs here>.
119 .
1210 <https://github.com/haskell-servant/servant/blob/master/servant-docs/CHANGELOG.md CHANGELOG>
13−
14−homepage: http://docs.servant.dev/
15−bug-reports: http://github.com/haskell-servant/servant/issues
16−license: BSD-3-Clause
11+license: BSD3
1712license-file: LICENSE
1813author: Servant Contributors
1914maintainer: haskell-servant-maintainers@googlegroups.com
20−copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors
15+copyright: 2014-2016 Zalora South East Asia Pte Ltd, Servant Contributors
16+category: Servant, Web
2117build-type: Simple
22−tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1
23−
18+cabal-version: >=1.10
19+tested-with:
20+ GHC==8.0.2
21+ GHC==8.2.2
22+ GHC==8.4.4
23+ GHC==8.6.1
24+homepage: http://haskell-servant.readthedocs.org/
25+Bug-reports: http://github.com/haskell-servant/servant/issues
2426extra-source-files:
2527 CHANGELOG.md
2628 README.md
27− golden/comprehensive.md
28−
2929source-repository head
3030 type: git
3131 location: http://github.com/haskell-servant/servant.git
@@ -41,28 +41,28 @@ library
4141 --
4242 -- note: mtl lower bound is so low because of GHC-7.8
4343 build-depends:
44− base >= 4.9 && < 4.18
45− , bytestring >= 0.10.8.1 && < 0.12
46− , text >= 1.2.3.0 && < 2.1
44+ base >= 4.7 && < 4.13
45+ , bytestring >= 0.10.4.0 && < 0.11
46+ , text >= 1.2.3.0 && < 1.3
4747
4848 -- Servant dependencies
4949 build-depends:
50− servant >= 0.18 && <0.20
50+ servant == 0.13.* || ==0.14.*
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 && < 3
55+ aeson >= 1.2.3.0 && < 1.5
5656 , aeson-pretty >= 0.8.5 && < 0.9
57− , base-compat >= 0.10.5 && < 0.13
58− , case-insensitive >= 1.2.0.11 && < 1.3
59− , hashable >= 1.2.7.0 && < 1.5
60− , http-media >= 0.7.1.3 && < 0.9
61− , http-types >= 0.12.2 && < 0.13
62− , lens >= 4.17 && < 5.3
57+ , base-compat >= 0.9.3 && < 0.11
58+ , case-insensitive >= 1.2.0.10 && < 1.3
59+ , control-monad-omega >= 0.3.1 && < 0.4
60+ , hashable >= 1.2.6.1 && < 1.3
61+ , http-media >= 0.7.0 && < 0.8
62+ , http-types >= 0.12 && < 0.13
63+ , lens >= 4.15.4 && < 4.18
6364 , string-conversions >= 0.4.0.1 && < 0.5
64− , universe-base >= 1.1.1 && < 1.2
65− , unordered-containers >= 0.2.9.0 && < 0.3
65+ , unordered-containers >= 0.2.8.0 && < 0.3
6666
6767 hs-source-dirs: src
6868 default-language: Haskell2010
@@ -93,16 +93,15 @@ test-suite spec
9393 -- Dependencies inherited from the library. No need to specify bounds.
9494 build-depends:
9595 base
96− , base-compat
9796 , aeson
9897 , lens
9998 , servant
10099 , servant-docs
101100 , string-conversions
102101
103− -- Additional dependencies
102+ -- Additonal dependencies
104103 build-depends:
105− tasty >= 1.1.0.4 && < 1.5,
106− tasty-golden >= 2.3.2 && < 2.4,
107− tasty-hunit >= 0.10.0.1 && < 0.11,
108− transformers >= 0.5.2.0 && < 0.6
104+ hspec >= 2.4.4 && < 2.6
105+
106+ build-tool-depends:
107+ hspec-discover:hspec-discover >=2.4.4 && <2.6
servant-docs/src/Servant/Docs/Internal.hs+72−229
@@ -25,14 +25,15 @@ import Control.Applicative
2525import Control.Arrow
2626 (second)
2727import Control.Lens
28− (makeLenses, mapped, each, over, set, to, toListOf, traversed, view,
29− _1, (%~), (&), (.~), (<>~), (^.), (|>))
28+ (makeLenses, mapped, over, traversed, view, (%~), (&), (.~),
29+ (<>~), (^.), (|>))
30+import qualified Control.Monad.Omega as Omega
3031import qualified Data.ByteString.Char8 as BSC
3132import Data.ByteString.Lazy.Char8
3233 (ByteString)
3334import qualified Data.CaseInsensitive as CI
3435import Data.Foldable
35− (fold, toList)
36+ (fold)
3637import Data.Hashable
3738 (Hashable)
3839import Data.HashMap.Strict
@@ -50,21 +51,17 @@ import Data.Ord
5051 (comparing)
5152import Data.Proxy
5253 (Proxy (Proxy))
54+import Data.Semigroup
55+ (Semigroup (..))
5356import Data.String.Conversions
5457 (cs)
5558import Data.Text
5659 (Text, unpack)
5760import GHC.Generics
58− (Generic, Rep, K1(K1), M1(M1), U1(U1), V1,
59− (:*:)((:*:)), (:+:)(L1, R1))
60−import qualified GHC.Generics as G
6161import GHC.TypeLits
6262import Servant.API
6363import Servant.API.ContentTypes
6464import Servant.API.TypeLevel
65−import Servant.API.Generic
66−
67−import qualified Data.Universe.Helpers as U
6865
6966import qualified Data.HashMap.Strict as HM
7067import qualified Data.Text as T
@@ -77,15 +74,14 @@ import qualified Network.HTTP.Types as HTTP
7774-- or any 'Endpoint' value you want using the 'path' and 'method'
7875-- lenses to tweak.
7976--
80−-- >>> defEndpoint
81−-- "GET" /
82−--
83−-- >>> defEndpoint & path <>~ ["foo"]
84−-- "GET" /foo
85−--
86−-- >>> defEndpoint & path <>~ ["foo"] & method .~ HTTP.methodPost
87−-- "POST" /foo
88−--
77+-- @
78+-- λ> 'defEndpoint'
79+-- GET /
80+-- λ> 'defEndpoint' & 'path' '<>~' ["foo"]
81+-- GET /foo
82+-- λ> 'defEndpoint' & 'path' '<>~' ["foo"] & 'method' '.~' 'HTTP.methodPost'
83+-- POST /foo
84+-- @
8985data Endpoint = Endpoint
9086 { _path :: [String] -- type collected
9187 , _method :: HTTP.Method -- type collected
@@ -106,15 +102,14 @@ showPath ps = concatMap ('/' :) ps
106102--
107103-- Here's how you can modify it:
108104--
109−-- >>> defEndpoint
110−-- "GET" /
111−--
112−-- >>> defEndpoint & path <>~ ["foo"]
113−-- "GET" /foo
114−--
115−-- >>> defEndpoint & path <>~ ["foo"] & method .~ HTTP.methodPost
116−-- "POST" /foo
117−--
105+-- @
106+-- λ> 'defEndpoint'
107+-- GET /
108+-- λ> 'defEndpoint' & 'path' '<>~' ["foo"]
109+-- GET /foo
110+-- λ> 'defEndpoint' & 'path' '<>~' ["foo"] & 'method' '.~' 'HTTP.methodPost'
111+-- POST /foo
112+-- @
118113defEndpoint :: Endpoint
119114defEndpoint = Endpoint [] HTTP.methodGet
120115
@@ -131,8 +126,7 @@ instance Semigroup API where
131126 (<>) = mappend
132127
133128instance Monoid API where
134− API a1 b1 `mappend` API a2 b2 = API (a1 `mappend` a2)
135− (HM.unionWith combineAction b1 b2)
129+ API a1 b1 `mappend` API a2 b2 = API (a1 `mappend` a2) (b1 `mappend` b2)
136130 mempty = API mempty mempty
137131
138132-- | An empty 'API'
@@ -161,20 +155,6 @@ data DocQueryParam = DocQueryParam
161155 , _paramKind :: ParamKind
162156 } deriving (Eq, Ord, Show)
163157
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−
178158-- | An introductory paragraph for your documentation. You can pass these to
179159-- 'docsWithIntros'.
180160data DocIntro = DocIntro
@@ -240,14 +220,12 @@ data ParamKind = Normal | List | Flag
240220-- want to write a 'ToSample' instance for the type that'll be represented
241221-- as encoded data in the response.
242222--
243−-- Can be tweaked with four lenses.
244−--
245−-- >>> defResponse
246−-- Response {_respStatus = 200, _respTypes = [], _respBody = [], _respHeaders = []}
247−--
248−-- >>> defResponse & respStatus .~ 204 & respBody .~ [("If everything goes well", "application/json", "{ \"status\": \"ok\" }")]
249−-- Response {_respStatus = 204, _respTypes = [], _respBody = [("If everything goes well",application/json,"{ \"status\": \"ok\" }")], _respHeaders = []}
223+-- Can be tweaked with three lenses.
250224--
225+-- > λ> defResponse
226+-- > Response {_respStatus = 200, _respTypes = [], _respBody = []}
227+-- > λ> defResponse & respStatus .~ 204 & respBody .~ [("If everything goes well", "{ \"status\": \"ok\" }")]
228+-- > Response {_respStatus = 204, _respTypes = [], _respBody = [("If everything goes well", "{ \"status\": \"ok\" }")]}
251229data Response = Response
252230 { _respStatus :: Int
253231 , _respTypes :: [M.MediaType]
@@ -255,25 +233,14 @@ data Response = Response
255233 , _respHeaders :: [HTTP.Header]
256234 } deriving (Eq, Ord, Show)
257235
258−-- | Combine two Responses, we can't make a monoid because merging Status breaks
259−-- the laws.
260−--
261−-- As such, we invent a non-commutative, left associative operation
262−-- 'combineResponse' to mush two together taking the status from the very left.
263−combineResponse :: Response -> Response -> Response
264−Response s ts bs hs `combineResponse` Response _ ts' bs' hs'
265− = Response s (ts <> ts') (bs <> bs') (hs <> hs')
266−
267236-- | Default response: status code 200, no response body.
268237--
269−-- Can be tweaked with four lenses.
270−--
271−-- >>> defResponse
272−-- Response {_respStatus = 200, _respTypes = [], _respBody = [], _respHeaders = []}
273−--
274−-- >>> defResponse & respStatus .~ 204
275−-- Response {_respStatus = 204, _respTypes = [], _respBody = [], _respHeaders = []}
238+-- Can be tweaked with two lenses.
276239--
240+-- > λ> defResponse
241+-- > Response {_respStatus = 200, _respBody = Nothing}
242+-- > λ> defResponse & respStatus .~ 204 & respBody .~ Just "[]"
243+-- > Response {_respStatus = 204, _respBody = Just "[]"}
277244defResponse :: Response
278245defResponse = Response
279246 { _respStatus = 200
@@ -295,9 +262,8 @@ defResponse = Response
295262data Action = Action
296263 { _authInfo :: [DocAuthentication] -- user supplied info
297264 , _captures :: [DocCapture] -- type collected + user supplied info
298− , _headers :: [HTTP.Header] -- type collected
265+ , _headers :: [Text] -- type collected
299266 , _params :: [DocQueryParam] -- type collected + user supplied info
300− , _fragment :: Maybe DocFragment -- type collected + user supplied info
301267 , _notes :: [DocNote] -- user supplied
302268 , _mxParams :: [(String, [DocQueryParam])] -- type collected + user supplied info
303269 , _rqtypes :: [M.MediaType] -- type collected
@@ -309,30 +275,27 @@ data Action = Action
309275-- laws.
310276--
311277-- As such, we invent a non-commutative, left associative operation
312−-- 'combineAction' to mush two together taking the response from the very left.
278+-- 'combineAction' to mush two together taking the response, body and content
279+-- types from the very left.
313280combineAction :: Action -> Action -> Action
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')
281+Action a c h p n m ts body resp `combineAction` Action a' c' h' p' n' m' _ _ _ =
282+ Action (a <> a') (c <> c') (h <> h') (p <> p') (n <> n') (m <> m') ts body resp
317283
318284-- | Default 'Action'. Has no 'captures', no query 'params', expects
319285-- no request body ('rqbody') and the typical response is 'defResponse'.
320286--
321287-- Tweakable with lenses.
322288--
323−-- >>> defAction
324−-- Action {_authInfo = [], _captures = [], _headers = [], _params = [], _fragment = Nothing, _notes = [], _mxParams = [], _rqtypes = [], _rqbody = [], _response = Response {_respStatus = 200, _respTypes = [], _respBody = [], _respHeaders = []}}
325−--
326−-- >>> defAction & response.respStatus .~ 201
327−-- Action {_authInfo = [], _captures = [], _headers = [], _params = [], _fragment = Nothing, _notes = [], _mxParams = [], _rqtypes = [], _rqbody = [], _response = Response {_respStatus = 201, _respTypes = [], _respBody = [], _respHeaders = []}}
328−--
289+-- > λ> defAction
290+-- > Action {_captures = [], _headers = [], _params = [], _mxParams = [], _rqbody = Nothing, _response = Response {_respStatus = 200, _respBody = Nothing}}
291+-- > λ> defAction & response.respStatus .~ 201
292+-- > Action {_captures = [], _headers = [], _params = [], _mxParams = [], _rqbody = Nothing, _response = Response {_respStatus = 201, _respBody = Nothing}}
329293defAction :: Action
330294defAction =
331295 Action []
332296 []
333297 []
334298 []
335− Nothing
336299 []
337300 []
338301 []
@@ -356,14 +319,12 @@ data ShowContentTypes = AllContentTypes -- ^ For each example, show each conten
356319--
357320-- @since 0.11.1
358321data RenderingOptions = RenderingOptions
359− { _requestExamples :: !ShowContentTypes
322+ { _requestExamples :: !ShowContentTypes
360323 -- ^ How many content types to display for request body examples?
361− , _responseExamples :: !ShowContentTypes
324+ , _responseExamples :: !ShowContentTypes
362325 -- ^ How many content types to display for response body examples?
363− , _notesHeading :: !(Maybe String)
326+ , _notesHeading :: !(Maybe String)
364327 -- ^ 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`).
367328 } deriving (Show)
368329
369330-- | Default API generation options.
@@ -375,10 +336,9 @@ data RenderingOptions = RenderingOptions
375336-- @since 0.11.1
376337defRenderingOptions :: RenderingOptions
377338defRenderingOptions = RenderingOptions
378− { _requestExamples = AllContentTypes
379− , _responseExamples = AllContentTypes
380− , _notesHeading = Nothing
381− , _renderCurlBasePath = Nothing
339+ { _requestExamples = AllContentTypes
340+ , _responseExamples = AllContentTypes
341+ , _notesHeading = Nothing
382342 }
383343
384344-- gimme some lenses
@@ -388,7 +348,6 @@ makeLenses ''API
388348makeLenses ''Endpoint
389349makeLenses ''DocCapture
390350makeLenses ''DocQueryParam
391−makeLenses ''DocFragment
392351makeLenses ''DocIntro
393352makeLenses ''DocNote
394353makeLenses ''Response
@@ -398,8 +357,7 @@ makeLenses ''RenderingOptions
398357-- | Generate the docs for a given API that implements 'HasDocs'. This is the
399358-- default way to create documentation.
400359--
401−-- > docs == docsWithOptions defaultDocOptions
402−--
360+-- prop> docs == docsWithOptions defaultDocOptions
403361docs :: HasDocs api => Proxy api -> API
404362docs p = docsWithOptions p defaultDocOptions
405363
@@ -415,9 +373,9 @@ docsWithOptions p = docsFor p (defEndpoint, defAction)
415373-- > extra :: ExtraInfo TestApi
416374-- > extra =
417375-- > extraInfo (Proxy :: Proxy ("greet" :> Capture "greetid" Text :> Delete)) $
418−-- > defAction & headers <>~ [("X-Num-Unicorns", 1)]
376+-- > defAction & headers <>~ ["unicorns"]
419377-- > & notes <>~ [ DocNote "Title" ["This is some text"]
420−-- > , DocNote "Second section" ["And some more"]
378+-- > , DocNote "Second secton" ["And some more"]
421379-- > ]
422380
423381extraInfo :: (IsIn endpoint api, HasLink endpoint, HasDocs endpoint)
@@ -447,7 +405,7 @@ docsWith opts intros (ExtraInfo endpoints) p =
447405 & apiEndpoints %~ HM.unionWith (flip combineAction) endpoints
448406
449407
450−-- | Generate the docs for a given API that implements 'HasDocs' with any
408+-- | Generate the docs for a given API that implements 'HasDocs' with with any
451409-- number of introduction(s)
452410docsWithIntros :: HasDocs api => [DocIntro] -> Proxy api -> API
453411docsWithIntros intros = docsWith defaultDocOptions intros mempty
@@ -510,22 +468,22 @@ samples = map ("",)
510468
511469-- | Default sample Generic-based inputs/outputs.
512470defaultSamples :: forall a. (Generic a, GToSample (Rep a)) => Proxy a -> [(Text, a)]
513−defaultSamples _ = second G.to <$> gtoSamples (Proxy :: Proxy (Rep a))
471+defaultSamples _ = Omega.runOmega $ second to <$> gtoSamples (Proxy :: Proxy (Rep a))
514472
515473-- | @'ToSample'@ for Generics.
516474--
517−-- Note: we use combinators from "Universe.Data.Helpers" for more productive sample generation.
475+-- The use of @'Omega'@ allows for more productive sample generation.
518476class GToSample t where
519− gtoSamples :: proxy t -> [(Text, t x)]
477+ gtoSamples :: proxy t -> Omega.Omega (Text, t x)
520478
521479instance GToSample U1 where
522− gtoSamples _ = singleSample U1
480+ gtoSamples _ = Omega.each (singleSample U1)
523481
524482instance GToSample V1 where
525483 gtoSamples _ = empty
526484
527485instance (GToSample p, GToSample q) => GToSample (p :*: q) where
528− gtoSamples _ = U.cartesianProduct render ps qs
486+ gtoSamples _ = render <$> ps <*> qs
529487 where
530488 ps = gtoSamples (Proxy :: Proxy p)
531489 qs = gtoSamples (Proxy :: Proxy q)
@@ -534,13 +492,13 @@ instance (GToSample p, GToSample q) => GToSample (p :*: q) where
534492 | otherwise = (ta <> ", " <> tb, a :*: b)
535493
536494instance (GToSample p, GToSample q) => GToSample (p :+: q) where
537− gtoSamples _ = lefts U.+++ rights
495+ gtoSamples _ = lefts <|> rights
538496 where
539497 lefts = second L1 <$> gtoSamples (Proxy :: Proxy p)
540498 rights = second R1 <$> gtoSamples (Proxy :: Proxy q)
541499
542500instance ToSample a => GToSample (K1 i a) where
543− gtoSamples _ = second K1 <$> toSamples (Proxy :: Proxy a)
501+ gtoSamples _ = second K1 <$> Omega.each (toSamples (Proxy :: Proxy a))
544502
545503instance (GToSample f) => GToSample (M1 i a f) where
546504 gtoSamples _ = second M1 <$> gtoSamples (Proxy :: Proxy f)
@@ -608,15 +566,6 @@ class ToCapture c where
608566class ToAuthInfo a where
609567 toAuthInfo :: Proxy a -> DocAuthentication
610568
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−
620569-- | Generate documentation in Markdown format for
621570-- the given 'API'.
622571--
@@ -646,7 +595,7 @@ markdown = markdownWith defRenderingOptions
646595--
647596-- @since 0.11.1
648597markdownWith :: RenderingOptions -> API -> String
649−markdownWith RenderingOptions{..} api = unlines $
598+markdownWith RenderingOptions{..} api = unlines $
650599 introsStr (api ^. apiIntros)
651600 ++ (concatMap (uncurry printEndpoint) . sort . HM.toList $ api ^. apiEndpoints)
652601
@@ -657,12 +606,10 @@ markdownWith RenderingOptions{..} api = unlines $
657606 notesStr (action ^. notes) ++
658607 authStr (action ^. authInfo) ++
659608 capturesStr (action ^. captures) ++
660− headersStr (toListOf (headers . each . _1 . to (T.pack . BSC.unpack . CI.original)) action) ++
609+ headersStr (action ^. headers) ++
661610 paramsStr meth (action ^. params) ++
662− fragmentStr (action ^. fragment) ++
663611 rqbodyStr (action ^. rqtypes) (action ^. rqbody) ++
664612 responseStr (action ^. response) ++
665− maybe [] (curlStr endpoint (action ^. headers) (action ^. rqbody)) _renderCurlBasePath ++
666613 []
667614
668615 where str = "## " ++ BSC.unpack meth
@@ -762,14 +709,6 @@ markdownWith RenderingOptions{..} api = unlines $
762709
763710 where values = param ^. paramValues
764711
765− fragmentStr :: Maybe DocFragment -> [String]
766− fragmentStr Nothing = []
767− fragmentStr (Just frag) =
768− [ "### Fragment:", ""
769− , "- *" ++ (frag ^. fragSymbol) ++ "*: " ++ (frag ^. fragDesc)
770− , ""
771− ]
772−
773712 rqbodyStr :: [M.MediaType] -> [(Text, M.MediaType, ByteString)]-> [String]
774713 rqbodyStr [] [] = []
775714 rqbodyStr types s =
@@ -818,11 +757,12 @@ markdownWith RenderingOptions{..} api = unlines $
818757 ("text", "css") -> "css"
819758 (_, _) -> ""
820759
760+
821761 contentStr mime_type body =
822762 "" :
823− "```" <> markdownForType mime_type :
763+ " ```" <> markdownForType mime_type :
824764 cs body :
825− "```" :
765+ " ```" :
826766 "" :
827767 []
828768
@@ -842,36 +782,6 @@ markdownWith RenderingOptions{..} api = unlines $
842782 xs ->
843783 formatBodies _responseExamples xs
844784
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−
875785-- * Instances
876786
877787-- | The generated docs for @a ':<|>' b@ just appends the docs
@@ -895,7 +805,7 @@ instance HasDocs EmptyAPI where
895805-- | @"books" :> 'Capture' "isbn" Text@ will appear as
896806-- @/books/:isbn@ in the docs.
897807instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs api)
898− => HasDocs (Capture' '[] sym a :> api) where
808+ => HasDocs (Capture' mods sym a :> api) where
899809
900810 docsFor Proxy (endpoint, action) =
901811 docsFor subApiP (endpoint', action')
@@ -907,28 +817,6 @@ instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs api)
907817 endpoint' = over path (\p -> p ++ [":" ++ symbolVal symP]) endpoint
908818 symP = Proxy :: Proxy sym
909819
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−
932820
933821-- | @"books" :> 'CaptureAll' "isbn" Text@ will appear as
934822-- @/books/:isbn@ in the docs.
@@ -962,25 +850,12 @@ instance {-# OVERLAPPABLE #-}
962850 status = fromInteger $ natVal (Proxy :: Proxy status)
963851 p = Proxy :: Proxy a
964852
965−instance (ReflectMethod method) =>
966− HasDocs (NoContentVerb method) where
967− docsFor Proxy (endpoint, action) DocOptions{..} =
968− single endpoint' action'
969−
970− where endpoint' = endpoint & method .~ method'
971− action' = action & response.respStatus .~ 204
972− & response.respTypes .~ []
973− & response.respBody .~ []
974− & response.respHeaders .~ []
975− method' = reflectMethod (Proxy :: Proxy method)
976−
977853-- | TODO: mention the endpoint is streaming, its framing strategy
978854--
979855-- Also there are no samples.
980−--
981−-- TODO: AcceptFraming for content-type
982856instance {-# OVERLAPPABLE #-}
983− (Accept ct, KnownNat status, ReflectMethod method)
857+ (MimeRender ct a, KnownNat status
858+ , ReflectMethod method)
984859 => HasDocs (Stream method status framing ct a) where
985860 docsFor Proxy (endpoint, action) DocOptions{..} =
986861 single endpoint' action'
@@ -991,6 +866,7 @@ instance {-# OVERLAPPABLE #-}
991866 t = Proxy :: Proxy '[ct]
992867 method' = reflectMethod (Proxy :: Proxy method)
993868 status = fromInteger $ natVal (Proxy :: Proxy status)
869+ p = Proxy :: Proxy a
994870
995871instance {-# OVERLAPPING #-}
996872 (ToSample a, AllMimeRender (ct ': cts) a, KnownNat status
@@ -1010,17 +886,14 @@ instance {-# OVERLAPPING #-}
1010886 status = fromInteger $ natVal (Proxy :: Proxy status)
1011887 p = Proxy :: Proxy a
1012888
1013−instance (ToHttpApiData a, ToSample a, KnownSymbol sym, HasDocs api)
889+instance (KnownSymbol sym, HasDocs api)
1014890 => HasDocs (Header' mods sym a :> api) where
1015891 docsFor Proxy (endpoint, action) =
1016892 docsFor subApiP (endpoint, action')
1017893
1018894 where subApiP = Proxy :: Proxy api
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>"
895+ action' = over headers (|> headername) action
896+ headername = T.pack $ symbolVal (Proxy :: Proxy sym)
1024897
1025898instance (KnownSymbol sym, ToParam (QueryParam' mods sym a), HasDocs api)
1026899 => HasDocs (QueryParam' mods sym a :> api) where
@@ -1053,15 +926,6 @@ instance (KnownSymbol sym, ToParam (QueryFlag sym), HasDocs api)
1053926 paramP = Proxy :: Proxy (QueryFlag sym)
1054927 action' = over params (|> toParam paramP) action
1055928
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
1065929
1066930instance HasDocs Raw where
1067931 docsFor _proxy (endpoint, action) _ =
@@ -1094,6 +958,7 @@ instance (KnownSymbol desc, HasDocs api)
1094958-- both are even defined) for any particular type.
1095959instance (ToSample a, AllMimeRender (ct ': cts) a, HasDocs api)
1096960 => HasDocs (ReqBody' mods (ct ': cts) a :> api) where
961+
1097962 docsFor Proxy (endpoint, action) opts@DocOptions{..} =
1098963 docsFor subApiP (endpoint, action') opts
1099964
@@ -1104,18 +969,6 @@ instance (ToSample a, AllMimeRender (ct ': cts) a, HasDocs api)
1104969 t = Proxy :: Proxy (ct ': cts)
1105970 p = Proxy :: Proxy a
1106971
1107−-- | TODO: this instance is incomplete.
1108−instance (HasDocs api, Accept ctype) => HasDocs (StreamBody' mods framing ctype a :> api) where
1109− docsFor Proxy (endpoint, action) opts =
1110− docsFor subApiP (endpoint, action') opts
1111− where
1112− subApiP = Proxy :: Proxy api
1113−
1114− action' :: Action
1115− action' = action & rqtypes .~ toList (contentTypes t)
1116−
1117− t = Proxy :: Proxy ctype
1118−
1119972instance (KnownSymbol path, HasDocs api) => HasDocs (path :> api) where
1120973
1121974 docsFor Proxy (endpoint, action) =
@@ -1144,9 +997,6 @@ instance HasDocs api => HasDocs (Vault :> api) where
1144997instance HasDocs api => HasDocs (WithNamedContext name context api) where
1145998 docsFor Proxy = docsFor (Proxy :: Proxy api)
1146999
1147−instance HasDocs api => HasDocs (WithResource res :> api) where
1148− docsFor Proxy = docsFor (Proxy :: Proxy api)
1149−
11501000instance (ToAuthInfo (BasicAuth realm usr), HasDocs api) => HasDocs (BasicAuth realm usr :> api) where
11511001 docsFor Proxy (endpoint, action) =
11521002 docsFor (Proxy :: Proxy api) (endpoint, action')
@@ -1154,9 +1004,6 @@ instance (ToAuthInfo (BasicAuth realm usr), HasDocs api) => HasDocs (BasicAuth r
11541004 authProxy = Proxy :: Proxy (BasicAuth realm usr)
11551005 action' = over authInfo (|> toAuthInfo authProxy) action
11561006
1157−instance HasDocs (ToServantApi api) => HasDocs (NamedRoutes api) where
1158− docsFor Proxy = docsFor (Proxy :: Proxy (ToServantApi api))
1159−
11601007-- ToSample instances for simple types
11611008instance ToSample NoContent
11621009instance ToSample Bool
@@ -1173,7 +1020,6 @@ instance (ToSample a, ToSample b, ToSample c, ToSample d, ToSample e, ToSample f
11731020instance ToSample a => ToSample (Maybe a)
11741021instance (ToSample a, ToSample b) => ToSample (Either a b)
11751022instance ToSample a => ToSample [a]
1176−instance ToSample a => ToSample (NonEmpty a)
11771023
11781024-- ToSample instances for Control.Applicative types
11791025instance ToSample a => ToSample (Const a b)
@@ -1187,6 +1033,3 @@ instance ToSample a => ToSample (Product a)
11871033instance ToSample a => ToSample (First a)
11881034instance ToSample a => ToSample (Last a)
11891035instance ToSample a => ToSample (Dual a)
1190−
1191−-- $setup
1192−-- >>> :set -XOverloadedStrings
servant-docs/src/Servant/Docs/Internal/Pretty.hs−19
@@ -18,7 +18,6 @@ import Data.Proxy
1818import Network.HTTP.Media
1919 ((//))
2020import Servant.API
21−import Servant.API.Verbs
2221
2322-- | PrettyJSON content type.
2423data PrettyJSON
@@ -47,24 +46,6 @@ type family Pretty (api :: k) :: k where
4746 Pretty (Put cs r) = Put (Pretty cs) r
4847 Pretty (Delete cs r) = Delete (Pretty cs) r
4948 Pretty (Patch cs r) = Patch (Pretty cs) r
50− Pretty (GetPartialContent cs r) = GetPartialContent (Pretty cs) r
51− Pretty (PutResetContent cs r) = PutResetContent (Pretty cs) r
52− Pretty (PatchResetContent cs r) = PatchResetContent (Pretty cs) r
53− Pretty (DeleteResetContent cs r) = DeleteResetContent (Pretty cs) r
54− Pretty (PostResetContent cs r) = PostResetContent (Pretty cs) r
55− Pretty (GetResetContent cs r) = GetResetContent (Pretty cs) r
56− Pretty (PutNonAuthoritative cs r) = PutNonAuthoritative (Pretty cs) r
57− Pretty (PatchNonAuthoritative cs r) = PatchNonAuthoritative (Pretty cs) r
58− Pretty (DeleteNonAuthoritative cs r) = DeleteNonAuthoritative (Pretty cs) r
59− Pretty (PostNonAuthoritative cs r) = PostNonAuthoritative (Pretty cs) r
60− Pretty (GetNonAuthoritative cs r) = GetNonAuthoritative (Pretty cs) r
61− Pretty (PutAccepted cs r) = PutAccepted (Pretty cs) r
62− Pretty (PatchAccepted cs r) = PatchAccepted (Pretty cs) r
63− Pretty (DeleteAccepted cs r) = DeleteAccepted (Pretty cs) r
64− Pretty (PostAccepted cs r) = PostAccepted (Pretty cs) r
65− Pretty (GetAccepted cs r) = GetAccepted (Pretty cs) r
66− Pretty (PutCreated cs r) = PutCreated (Pretty cs) r
67− Pretty (PostCreated cs r) = PostCreated (Pretty cs) r
6849 Pretty (ReqBody cs r) = ReqBody (Pretty cs) r
6950 Pretty (JSON ': xs) = PrettyJSON ': xs
7051 Pretty (x ': xs) = x ': Pretty xs
servant-docs/test/Servant/DocsSpec.hs+25−97
@@ -1,77 +1,55 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE DeriveFunctor #-}
3−{-# LANGUAGE DeriveGeneric #-}
4−{-# LANGUAGE FlexibleContexts #-}
5−{-# LANGUAGE FlexibleInstances #-}
6−{-# LANGUAGE GADTs #-}
7−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
8−{-# LANGUAGE MultiParamTypeClasses #-}
9−{-# LANGUAGE OverloadedStrings #-}
10−{-# LANGUAGE TypeOperators #-}
11−{-# LANGUAGE TypeSynonymInstances #-}
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE OverloadedStrings #-}
7+{-# LANGUAGE TypeOperators #-}
8+{-# LANGUAGE TypeSynonymInstances #-}
129{-# OPTIONS_GHC -fno-warn-orphans #-}
1310{-# OPTIONS_GHC -freduction-depth=100 #-}
1411
1512module Servant.DocsSpec where
1613
1714import Control.Lens
18− ((&), (<>~))
19−import Control.Monad
20− (unless)
21−import Control.Monad.Trans.Writer
22− (Writer, runWriter, tell)
2315import Data.Aeson
24−import Data.List
25− (isInfixOf)
16+import Data.Monoid
2617import Data.Proxy
2718import Data.String.Conversions
2819 (cs)
2920import GHC.Generics
30−import Prelude ()
31−import Prelude.Compat
32−import Test.Tasty
33− (TestName, TestTree, testGroup)
34−import Test.Tasty.Golden
35− (goldenVsString)
36−import Test.Tasty.HUnit
37− (Assertion, HasCallStack, assertFailure, testCase, (@?=))
21+import Test.Hspec
3822
3923import Servant.API
24+import Servant.API.Internal.Test.ComprehensiveAPI
4025import Servant.Docs.Internal
41−import Servant.Test.ComprehensiveAPI
4226
4327-- * comprehensive api
4428
4529-- This declaration simply checks that all instances are in place.
46−comprehensiveDocs :: API
47−comprehensiveDocs = docs comprehensiveAPI
30+_ = docs comprehensiveAPI
4831
4932instance ToParam (QueryParam' mods "foo" Int) where
50− toParam _ = DocQueryParam "foo" ["1","2","3"] "QueryParams Int" Normal
33+ toParam = error "unused"
5134instance ToParam (QueryParam' mods "bar" Int) where
52− toParam _ = DocQueryParam "bar" ["1","2","3"] "QueryParams Int" Normal
35+ toParam = error "unused"
5336instance ToParam (QueryParams "foo" Int) where
54− toParam _ = DocQueryParam "foo" ["1","2","3"] "QueryParams Int" List
37+ toParam = error "unused"
5538instance ToParam (QueryFlag "foo") where
56− toParam _ = DocQueryParam "foo" [] "QueryFlag" Flag
39+ toParam = error "unused"
5740instance ToCapture (Capture "foo" Int) where
58− toCapture _ = DocCapture "foo" "Capture foo Int"
41+ toCapture = error "unused"
5942instance ToCapture (CaptureAll "foo" Int) where
60− toCapture _ = DocCapture "foo" "Capture all foo Int"
61−instance ToFragment (Fragment Int) where
62− toFragment _ = DocFragment "foo" "Fragment Int"
43+ toCapture = error "unused"
6344
6445-- * specs
6546
66−spec :: TestTree
47+spec :: Spec
6748spec = describe "Servant.Docs" $ do
68− golden "comprehensive API" "golden/comprehensive.md" (markdown comprehensiveDocs)
6949
7050 describe "markdown" $ do
71− let md1 = markdown (docs (Proxy :: Proxy TestApi1))
72− tests1 md1
73− let md2 = markdown (docs (Proxy :: Proxy TestApi2))
74− tests2 md2
51+ let md = markdown (docs (Proxy :: Proxy TestApi1))
52+ tests md
7553
7654 describe "markdown with extra info" $ do
7755 let
@@ -83,7 +61,7 @@ spec = describe "Servant.Docs" $ do
8361 (Proxy :: Proxy (ReqBody '[JSON] String :> Post '[JSON] Datatype1))
8462 (defAction & notes <>~ [DocNote "Post data" ["Posts some Json data"]])
8563 md = markdown (docsWith defaultDocOptions [] extra (Proxy :: Proxy TestApi1))
86− tests1 md
64+ tests md
8765 it "contains the extra info provided" $ do
8866 md `shouldContain` "Get an Integer"
8967 md `shouldContain` "Post data"
@@ -111,7 +89,7 @@ spec = describe "Servant.Docs" $ do
11189
11290
11391 where
114− tests1 md = do
92+ tests md = do
11593 it "mentions supported content-types" $ do
11694 md `shouldContain` "application/json"
11795 md `shouldContain` "text/plain;charset=utf-8"
@@ -126,21 +104,14 @@ spec = describe "Servant.Docs" $ do
126104 it "mentions headers" $ do
127105 md `shouldContain` "- This endpoint is sensitive to the value of the **X-Test** HTTP header."
128106
129− it "contains response samples - dt1field1" $
130− md `shouldContain` "\"dt1field1\":\"field 1\""
131− it "contains response samples - dt1field2" $
132− md `shouldContain` "\"dt1field2\":13"
107+ it "contains response samples" $
108+ md `shouldContain` "{\"dt1field1\":\"field 1\",\"dt1field2\":13}"
133109 it "contains request body samples" $
134110 md `shouldContain` "17"
135111
136112 it "does not generate any docs mentioning the 'empty-api' path" $
137113 md `shouldNotContain` "empty-api"
138114
139− tests2 md = do
140− it "mentions the content-types from both copies of the route" $ do
141− md `shouldContain` "application/json"
142− md `shouldContain` "text/plain;charset=utf-8"
143−
144115
145116-- * APIs
146117
@@ -167,10 +138,6 @@ type TestApi1 = Get '[JSON, PlainText] (Headers '[Header "Location" String] Int)
167138 :<|> Header "X-Test" Int :> Put '[JSON] Int
168139 :<|> "empty-api" :> EmptyAPI
169140
170−type TestApi2 = "duplicate-endpoint" :> Get '[JSON] Datatype1
171− :<|> "duplicate-endpoint" :> Get '[PlainText] Int
172−
173−
174141data TT = TT1 | TT2 deriving (Show, Eq)
175142data UT = UT1 | UT2 deriving (Show, Eq)
176143
@@ -179,42 +146,3 @@ instance ToSample TT where
179146
180147instance ToSample UT where
181148 toSamples _ = [("yks", UT1), ("kaks", UT2)]
182−
183−-------------------------------------------------------------------------------
184−-- HSpec like DSL for tasty
185−-------------------------------------------------------------------------------
186−
187−newtype TestTreeM a = TestTreeM (Writer [TestTree] a)
188− deriving (Functor, Applicative, Monad)
189−
190−runTestTreeM :: TestTreeM () -> [TestTree]
191−runTestTreeM (TestTreeM m) = snd (runWriter m)
192−
193−class Describe r where
194− describe :: TestName -> TestTreeM () -> r
195−
196−instance a ~ () => Describe (TestTreeM a) where
197− describe n t = TestTreeM $ tell [ describe n t ]
198−
199−instance Describe TestTree where
200− describe n t = testGroup n $ runTestTreeM t
201−
202−it :: TestName -> Assertion -> TestTreeM ()
203−it n assertion = TestTreeM $ tell [ testCase n assertion ]
204−
205−shouldBe :: (Eq a, Show a, HasCallStack) => a -> a -> Assertion
206−shouldBe = (@?=)
207−
208−shouldContain :: (Eq a, Show a, HasCallStack) => [a] -> [a] -> Assertion
209−shouldContain = compareWith (flip isInfixOf) "does not contain"
210−
211−shouldNotContain :: (Eq a, Show a, HasCallStack) => [a] -> [a] -> Assertion
212−shouldNotContain = compareWith (\x y -> not (isInfixOf y x)) "contains"
213−
214−compareWith :: (Show a, Show b, HasCallStack) => (a -> b -> Bool) -> String -> a -> b -> Assertion
215−compareWith f msg x y = unless (f x y) $ assertFailure $
216− show x ++ " " ++ msg ++ " " ++ show y
217−
218−golden :: TestName -> FilePath -> String -> TestTreeM ()
219−golden n fp contents = TestTreeM $ tell
220− [ goldenVsString n fp (return (cs contents)) ]
servant-docs/test/Spec.hs+1−8
@@ -1,8 +1 @@
1−module Main (main) where
2−
3−import Test.Tasty
4− (defaultMain)
5−import qualified Servant.DocsSpec
6−
7−main :: IO ()
8−main = defaultMain Servant.DocsSpec.spec
1+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
servant-docs/tinc.yamlnew file+3
@@ -0,0 +1,3 @@
1+dependencies:
2+ - name: servant
3+ path: ../servant
servant-foreign/CHANGELOG.md−99
@@ -1,105 +1,6 @@
11[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-foreign/CHANGELOG.md)
22[Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)
33
4−0.15.4
5−------
6−
7−### Significant changes
8−
9−- Documentation improvements.
10−
11−### Other changes
12−
13−- Support GHC-9.0.1.
14−- Bump `lens` and `hspec` dependencies.
15−
16−0.15.3
17−------
18−
19−### Significant changes
20−
21−- Support `Fragment` combinator.
22−
23−0.15.2
24−------
25−
26−* Support `servant-0.18`.
27−
28−0.15.1
29−------
30−
31−* Support `servant-0.17`
32−
33−0.15
34−----
35−
36−- *servant-foreign* Add support so `HasForeign` can be implemented for
37− `MultipartForm` from [`servant-multipart`](http://hackage.haskell.org/package/servant-multipart)
38− [#1035](https://github.com/haskell-servant/servant/pull/1035)
39−
40−- Drop support for GHC older than 8.0
41− [#1008](https://github.com/haskell-servant/servant/pull/1008)
42− [#1009](https://github.com/haskell-servant/servant/pull/1009)
43−
44−
45−0.11.1
46−------
47−
48−- Add missing `Semigroup` instances
49−
50−0.11
51−----
52−
53−### Breaking changes
54−
55−- *servant* Add `Servant.API.Modifiers`
56− ([#873](https://github.com/haskell-servant/servant/pull/873))
57−- Make foreign client Header arguments have the representation of 'Maybe' in those languages
58− ([#843](https://github.com/haskell-servant/servant/pull/843))
59−
60−0.10.2
61−------
62−
63−### Changes
64−
65−* Add instances for `Description` and `Summary` combinators
66− ([#767](https://github.com/haskell-servant/servant/pull/767))
67−* Derive Data for all types
68− ([#809](https://github.com/haskell-servant/servant/pull/809))
69−
70−0.10.1
71−------
72−
73−### Changes
74−
75−* Don't drop samples in `HasDocs ReqBody` instance
76− ([#755](https://github.com/haskell-servant/servant/pull/755/files)).
77− *Breaking change in an `Internal` module*.
78−
79−0.10
80−----
81−
82−### Breaking changes
83−
84−* Do not apply JavaScript specific mangling to the names.
85− ([#191](https://github.com/haskell-servant/servant/issues/191))
86−
87−0.7.1
88−-----
89−
90−* Support GHC 8.0
91−0.15
92−----
93−
94−- *servant-foreign* Add support so `HasForeign` can be implemented for
95− `MultipartForm` from [`servant-multipart`](http://hackage.haskell.org/package/servant-multipart)
96− [#1035](https://github.com/haskell-servant/servant/pull/1035)
97−
98−- Drop support for GHC older than 8.0
99− [#1008](https://github.com/haskell-servant/servant/pull/1008)
100− [#1009](https://github.com/haskell-servant/servant/pull/1009)
101−
102−
10340.11.1
1045------
1056
servant-foreign/LICENSE+1−1
@@ -1,4 +1,4 @@
1−Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, 2016-2018 Servant Contributors
1+Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, Servant Contributors
22
33All rights reserved.
44
servant-foreign/servant-foreign.cabal+22−20
@@ -1,9 +1,7 @@
1−cabal-version: 2.2
21name: servant-foreign
3−version: 0.15.4
4−
2+version: 0.11.1
3+x-revision: 3
54synopsis: Helpers for generating clients for servant APIs in any programming language
6−category: Servant, Web
75description:
86 Helper types and functions for generating client functions for servant APIs in any programming language
97 .
@@ -12,20 +10,23 @@ description:
1210 See the servant-js package for an example
1311 .
1412 <https://github.com/haskell-servant/servant/blob/master/servant-foreign/CHANGELOG.md CHANGELOG>
15−
16−homepage: http://docs.servant.dev/
17−bug-reports: http://github.com/haskell-servant/servant/issues
18−license: BSD-3-Clause
13+license: BSD3
1914license-file: LICENSE
2015author: Servant Contributors
2116maintainer: haskell-servant-maintainers@googlegroups.com
22−copyright: 2015-2019 Servant Contributors
17+copyright: 2015-2016 Servant Contributors
18+category: Servant, Web
2319build-type: Simple
24−tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1
25−
20+cabal-version: >=1.10
2621extra-source-files:
2722 CHANGELOG.md
2823 README.md
24+bug-reports: http://github.com/haskell-servant/servant/issues
25+tested-with:
26+ GHC==8.0.2
27+ GHC==8.2.2
28+ GHC==8.4.4
29+ GHC==8.6.1
2930
3031source-repository head
3132 type: git
@@ -41,19 +42,19 @@ library
4142 --
4243 -- note: mtl lower bound is so low because of GHC-7.8
4344 build-depends:
44− base >= 4.9 && < 4.18
45− , text >= 1.2.3.0 && < 2.1
45+ base >= 4.7 && <4.13
46+ , text >= 1.2.3.0 && < 1.3
4647
4748 -- Servant dependencies
4849 build-depends:
49− servant >=0.18 && <0.20
50+ servant == 0.13.* || ==0.14.*
5051
5152 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.
5253 -- Here can be exceptions if we really need features from the newer versions.
5354 build-depends:
54− base-compat >= 0.10.5 && < 0.13
55− , lens >= 4.17 && < 5.3
56− , http-types >= 0.12.2 && < 0.13
55+ base-compat >= 0.9.3 && <0.11
56+ , lens >= 4.15.4 && <4.18
57+ , http-types >= 0.12 && < 0.13
5758
5859 hs-source-dirs: src
5960 default-language: Haskell2010
@@ -72,9 +73,10 @@ test-suite spec
7273 , servant
7374 , servant-foreign
7475
75− -- Additional dependencies
76+ -- Additonal dependencies
7677 build-depends:
77− hspec >= 2.6.0 && <2.10
78+ hspec >= 2.4.4 && <2.6
79+
7880 build-tool-depends:
79− hspec-discover:hspec-discover >=2.6.0 && <2.10
81+ hspec-discover:hspec-discover >=2.4.4 && <2.6
8082 default-language: Haskell2010
servant-foreign/src/Servant/Foreign.hs+18−23
@@ -1,32 +1,19 @@
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).
53module Servant.Foreign
6− (
7− -- * Main API
8− listFromAPI
4+ ( ArgType(..)
5+ , HeaderArg(..)
6+ , QueryArg(..)
97 , Req(..)
10− , defReq
11− , HasForeignType(..)
12− , GenerateList(..)
13− , HasForeign(..)
14− , NoTypes
15− -- * Subtypes of 'Req'
16− , Url(..)
17− , Path
188 , Segment(..)
199 , SegmentType(..)
20− , isCapture
21− , captureArg
22− , QueryArg(..)
23− , ArgType(..)
24− , HeaderArg(..)
10+ , Url(..)
11+ -- aliases
12+ , Path
2513 , Arg(..)
2614 , FunctionName(..)
27− , ReqBodyContentType(..)
2815 , PathSegment(..)
29− -- * Lenses
16+ -- lenses
3017 , argName
3118 , argType
3219 , argPath
@@ -34,7 +21,6 @@ module Servant.Foreign
3421 , reqMethod
3522 , reqHeaders
3623 , reqBody
37− , reqBodyContentType
3824 , reqReturnType
3925 , reqFuncName
4026 , path
@@ -42,7 +28,7 @@ module Servant.Foreign
4228 , queryArgName
4329 , queryArgType
4430 , headerArg
45− -- * Prisms
31+ -- prisms
4632 , _PathSegment
4733 , _HeaderArg
4834 , _ReplaceHeaderArg
@@ -51,7 +37,16 @@ module Servant.Foreign
5137 , _Normal
5238 , _Flag
5339 , _List
54− -- * Re-exports
40+ -- rest of it
41+ , HasForeign(..)
42+ , HasForeignType(..)
43+ , GenerateList(..)
44+ , NoTypes
45+ , captureArg
46+ , isCapture
47+ , defReq
48+ , listFromAPI
49+ -- re-exports
5550 , module Servant.API
5651 , module Servant.Foreign.Inflections
5752 ) where
servant-foreign/src/Servant/Foreign/Inflections.hs+13−18
@@ -13,37 +13,27 @@ module Servant.Foreign.Inflections
1313import Control.Lens hiding
1414 (cons)
1515import qualified Data.Char as C
16+import Data.Monoid
1617import Data.Text hiding
1718 (map)
1819import Prelude hiding
1920 (head, tail)
2021import Servant.Foreign.Internal
2122
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−
2823concatCaseL :: Getter FunctionName Text
2924concatCaseL = _FunctionName . to mconcat
3025
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
26+-- | Function name builder that simply concat each part together
27+concatCase :: FunctionName -> Text
28+concatCase = view concatCaseL
3729
3830snakeCaseL :: Getter FunctionName Text
3931snakeCaseL = _FunctionName . to (intercalate "_")
4032
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
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
4737
4838camelCaseL :: Getter FunctionName Text
4939camelCaseL = _FunctionName . to convert
@@ -52,3 +42,8 @@ camelCaseL = _FunctionName . to convert
5242 convert (p:ps) = mconcat $ p : map capitalize ps
5343 capitalize "" = ""
5444 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+35−169
@@ -13,6 +13,8 @@
1313{-# LANGUAGE TypeOperators #-}
1414{-# LANGUAGE UndecidableInstances #-}
1515
16+-- | Generalizes all the data needed to make code generation work with
17+-- arbitrary programming languages.
1618module Servant.Foreign.Internal where
1719
1820import Prelude ()
@@ -23,6 +25,8 @@ import Control.Lens
2325import Data.Data
2426 (Data)
2527import Data.Proxy
28+import Data.Semigroup
29+ (Semigroup)
2630import Data.String
2731import Data.Text
2832import Data.Text.Encoding
@@ -36,75 +40,50 @@ import Servant.API.Modifiers
3640 (RequiredArgument)
3741import Servant.API.TypeLevel
3842
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`.
4243newtype FunctionName = FunctionName { unFunctionName :: [Text] }
4344 deriving (Data, Show, Eq, Semigroup, Monoid, Typeable)
4445
4546makePrisms ''FunctionName
4647
47−-- | See documentation of 'Arg'
4848newtype PathSegment = PathSegment { unPathSegment :: Text }
4949 deriving (Data, Show, Eq, IsString, Semigroup, Monoid, Typeable)
5050
5151makePrisms ''PathSegment
5252
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
53+data Arg f = Arg
5754 { _argName :: PathSegment
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− }
55+ , _argType :: f }
6456 deriving (Data, Eq, Show, Typeable)
6557
6658makeLenses ''Arg
6759
68−argPath :: Getter (Arg ftype) Text
60+argPath :: Getter (Arg f) Text
6961argPath = argName . _PathSegment
7062
71−data SegmentType ftype
63+data SegmentType f
7264 = Static PathSegment
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@.
65+ -- ^ a static path segment. like "/foo"
66+ | Cap (Arg f)
67+ -- ^ a capture. like "/:userid"
8468 deriving (Data, Eq, Show, Typeable)
8569
8670makePrisms ''SegmentType
8771
88−-- | A part of the Url’s path.
89−newtype Segment ftype = Segment { unSegment :: SegmentType ftype }
72+newtype Segment f = Segment { unSegment :: SegmentType f }
9073 deriving (Data, Eq, Show, Typeable)
9174
9275makePrisms ''Segment
9376
94−-- | Whether a segment is a 'Cap'.
95−isCapture :: Segment ftype -> Bool
77+isCapture :: Segment f -> Bool
9678isCapture (Segment (Cap _)) = True
9779isCapture _ = False
9880
99−-- | Crashing Arg extraction from segment, TODO: remove
100−captureArg :: Segment ftype -> Arg ftype
81+captureArg :: Segment f -> Arg f
10182captureArg (Segment (Cap s)) = s
10283captureArg _ = error "captureArg called on non capture"
10384
104−-- TODO: remove, unnecessary indirection
105−type Path ftype = [Segment ftype]
85+type Path f = [Segment f]
10686
107−-- | Type of a 'QueryArg'.
10887data ArgType
10988 = Normal
11089 | Flag
@@ -113,41 +92,18 @@ data ArgType
11392
11493makePrisms ''ArgType
11594
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
95+data QueryArg f = QueryArg
96+ { _queryArgName :: Arg f
13597 , _queryArgType :: ArgType
136− -- ^ one of normal/plain, list or flag
13798 }
13899 deriving (Data, Eq, Show, Typeable)
139100
140101makeLenses ''QueryArg
141102
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
103+data HeaderArg f = HeaderArg
104+ { _headerArg :: Arg f }
149105 | ReplaceHeaderArg
150− { _headerArg :: Arg ftype
106+ { _headerArg :: Arg f
151107 , _headerPattern :: Text
152108 }
153109 deriving (Data, Eq, Show, Typeable)
@@ -156,78 +112,31 @@ makeLenses ''HeaderArg
156112
157113makePrisms ''HeaderArg
158114
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@
115+data Url f = Url
116+ { _path :: Path f
117+ , _queryStr :: [QueryArg f]
175118 }
176119 deriving (Data, Eq, Show, Typeable)
177120
178−defUrl :: Url ftype
179−defUrl = Url [] [] Nothing
121+defUrl :: Url f
122+defUrl = Url [] []
180123
181124makeLenses ''Url
182125
183−-- | See documentation of '_reqBodyContentType'
184−data ReqBodyContentType = ReqBodyJSON | ReqBodyMultipart
185− deriving (Data, Eq, Show, Read)
186−
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
195− , _reqMethod :: HTTP.Method
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
203− , _reqFuncName :: FunctionName
204− -- ^ The URL segments rendered in a way that they can be easily concatenated into a canonical function name
205− , _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]@
126+data Req f = Req
127+ { _reqUrl :: Url f
128+ , _reqMethod :: HTTP.Method
129+ , _reqHeaders :: [HeaderArg f]
130+ , _reqBody :: Maybe f
131+ , _reqReturnType :: Maybe f
132+ , _reqFuncName :: FunctionName
224133 }
225134 deriving (Data, Eq, Show, Typeable)
226135
227136makeLenses ''Req
228137
229138defReq :: Req ftype
230−defReq = Req defUrl "GET" [] Nothing Nothing (FunctionName []) ReqBodyJSON
139+defReq = Req defUrl "GET" [] Nothing Nothing (FunctionName [])
231140
232141-- | 'HasForeignType' maps Haskell types with types in the target
233142-- language of your backend. For example, let's say you're
@@ -244,7 +153,7 @@ defReq = Req defUrl "GET" [] Nothing Nothing (FunctionName []) ReqBodyJSON
244153-- >
245154-- > -- Or for example in case of lists
246155-- > instance HasForeignType LangX Text a => HasForeignType LangX Text [a] where
247−-- > typeFor lang ftype _ = "listX of " <> typeFor lang ftype (Proxy :: Proxy a)
156+-- > typeFor lang type _ = "listX of " <> typeFor lang ftype (Proxy :: Proxy a)
248157--
249158-- Finally to generate list of information about all the endpoints for
250159-- an API you create a function of a form:
@@ -264,16 +173,11 @@ defReq = Req defUrl "GET" [] Nothing Nothing (FunctionName []) ReqBodyJSON
264173class HasForeignType lang ftype a where
265174 typeFor :: Proxy lang -> Proxy ftype -> Proxy a -> ftype
266175
267−-- | The language definition without any foreign types. It can be used for dynamic languages which do not /do/ type annotations.
268176data NoTypes
269177
270−-- | Use if the foreign language does not have any types.
271−instance HasForeignType NoTypes NoContent a where
178+instance HasForeignType NoTypes NoContent ftype where
272179 typeFor _ _ _ = NoContent
273180
274−-- | Implementation of the Servant framework types.
275−--
276−-- Relevant instances: Everything containing 'HasForeignType'.
277181class HasForeign lang ftype (api :: *) where
278182 type Foreign ftype api :: *
279183 foreignFor :: Proxy lang -> Proxy ftype -> Proxy api -> Req ftype -> Foreign ftype api
@@ -336,19 +240,6 @@ instance (Elem JSON list, HasForeignType lang ftype a, ReflectMethod method)
336240 method = reflectMethod (Proxy :: Proxy method)
337241 methodLC = toLower $ decodeUtf8 method
338242
339−instance (HasForeignType lang ftype NoContent, ReflectMethod method)
340− => HasForeign lang ftype (NoContentVerb method) where
341− type Foreign ftype (NoContentVerb method) = Req ftype
342−
343− foreignFor lang Proxy Proxy req =
344− req & reqFuncName . _FunctionName %~ (methodLC :)
345− & reqMethod .~ method
346− & reqReturnType .~ Just retType
347− where
348− retType = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy NoContent)
349− method = reflectMethod (Proxy :: Proxy method)
350− methodLC = toLower $ decodeUtf8 method
351−
352243-- | TODO: doesn't taking framing into account.
353244instance (ct ~ JSON, HasForeignType lang ftype a, ReflectMethod method)
354245 => HasForeign lang ftype (Stream method status framing ct a) where
@@ -416,16 +307,6 @@ instance
416307 { _argName = PathSegment str
417308 , _argType = typeFor lang ftype (Proxy :: Proxy Bool) }
418309
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−
429310instance HasForeign lang ftype Raw where
430311 type Foreign ftype Raw = HTTP.Method -> Req ftype
431312
@@ -441,14 +322,6 @@ instance (Elem JSON list, HasForeignType lang ftype a, HasForeign lang ftype api
441322 foreignFor lang ftype (Proxy :: Proxy api) $
442323 req & reqBody .~ (Just $ typeFor lang ftype (Proxy :: Proxy a))
443324
444−instance
445− ( HasForeign lang ftype api
446− ) => HasForeign lang ftype (StreamBody' mods framing ctype a :> api)
447− where
448− type Foreign ftype (StreamBody' mods framing ctype a :> api) = Foreign ftype api
449−
450− foreignFor _lang Proxy Proxy _req = error "HasForeign @StreamBody"
451−
452325instance (KnownSymbol path, HasForeign lang ftype api)
453326 => HasForeign lang ftype (path :> api) where
454327 type Foreign ftype (path :> api) = Foreign ftype api
@@ -487,13 +360,6 @@ instance HasForeign lang ftype api =>
487360
488361 foreignFor lang ftype Proxy = foreignFor lang ftype (Proxy :: Proxy api)
489362
490−instance HasForeign lang ftype api =>
491− HasForeign lang ftype (WithResource res :> api) where
492−
493− type Foreign ftype (WithResource res :> api) = Foreign ftype api
494−
495− foreignFor lang ftype Proxy = foreignFor lang ftype (Proxy :: Proxy api)
496−
497363instance HasForeign lang ftype api
498364 => HasForeign lang ftype (HttpVersion :> api) where
499365 type Foreign ftype (HttpVersion :> api) = Foreign ftype api
servant-foreign/test/Servant/ForeignSpec.hs+4−12
@@ -11,11 +11,11 @@
1111
1212module Servant.ForeignSpec where
1313
14+import Data.Monoid
15+ ((<>))
1416import Data.Proxy
17+import Servant.API.Internal.Test.ComprehensiveAPI
1518import Servant.Foreign
16−import Servant.Test.ComprehensiveAPI
17−import Servant.Types.SourceT
18− (SourceT)
1919
2020import Test.Hspec
2121
@@ -51,9 +51,6 @@ instance HasForeignType LangX String (Headers ctyps NoContent) where
5151instance HasForeignType LangX String Int where
5252 typeFor _ _ _ = "intX"
5353
54−instance HasForeignType LangX String (SourceT m a) where
55− typeFor _ _ _ = "streamTX"
56−
5754instance HasForeignType LangX String Bool where
5855 typeFor _ _ _ = "boolX"
5956
@@ -89,7 +86,6 @@ listFromAPISpec = describe "listFromAPI" $ do
8986 { _reqUrl = Url
9087 [ Segment $ Static "test" ]
9188 [ QueryArg (Arg "flag" "boolX") Flag ]
92− Nothing
9389 , _reqMethod = "GET"
9490 , _reqHeaders = [HeaderArg $ Arg "header" "maybe listX of stringX"]
9591 , _reqBody = Nothing
@@ -102,7 +98,6 @@ listFromAPISpec = describe "listFromAPI" $ do
10298 { _reqUrl = Url
10399 [ Segment $ Static "test" ]
104100 [ QueryArg (Arg "param" "maybe intX") Normal ]
105− Nothing
106101 , _reqMethod = "POST"
107102 , _reqHeaders = []
108103 , _reqBody = Just "listX of stringX"
@@ -114,9 +109,8 @@ listFromAPISpec = describe "listFromAPI" $ do
114109 shouldBe putReq $ defReq
115110 { _reqUrl = Url
116111 [ Segment $ Static "test" ]
117− -- Should this be |intX| or |listX of intX| ?
112+ -- Shoud this be |intX| or |listX of intX| ?
118113 [ QueryArg (Arg "params" "listX of intX") List ]
119− Nothing
120114 , _reqMethod = "PUT"
121115 , _reqHeaders = []
122116 , _reqBody = Just "stringX"
@@ -130,7 +124,6 @@ listFromAPISpec = describe "listFromAPI" $ do
130124 [ Segment $ Static "test"
131125 , Segment $ Cap (Arg "id" "intX") ]
132126 []
133− Nothing
134127 , _reqMethod = "DELETE"
135128 , _reqHeaders = []
136129 , _reqBody = Nothing
@@ -144,7 +137,6 @@ listFromAPISpec = describe "listFromAPI" $ do
144137 [ Segment $ Static "test"
145138 , Segment $ Cap (Arg "ids" "listX of intX") ]
146139 []
147− Nothing
148140 , _reqMethod = "GET"
149141 , _reqHeaders = []
150142 , _reqBody = Nothing
servant-foreign/tinc.yamlnew file+3
@@ -0,0 +1,3 @@
1+dependencies:
2+ - name: servant
3+ path: ../servant
servant-http-streams/CHANGELOG.mddeleted−98
@@ -1,98 +0,0 @@
1− [The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-http-streams/CHANGELOG.md)
2−[Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)
3−
4−0.18.4
5−------
6−
7−### Significant changes
8−
9−- *servant-client* / *servant-client-core* / *servant-http-streams*:
10− Fix erroneous behavior, where only 2XX status codes would be considered
11− successful, irrelevant of the status parameter specified by the verb
12− combinator. ([#1469](https://github.com/haskell-servant/servant/pull/1469))
13−
14−0.18.3
15−------
16−
17−### Other changes
18−
19−- Support GHC-9.0.1.
20−- Fix test suite running in CI.
21−- Bump `bytestring` and `hspec` dependencies.
22−
23−0.18.2
24−------
25−
26−### Significant changes
27−
28−- Support `servant-client-core` 0.18.2.
29−
30−0.18.1
31−------
32−
33−### Significant changes
34−
35−- Union verbs
36−
37−### Other changes
38−
39−- Bump "tested-with" ghc versions
40−
41−0.18
42−----
43−
44−### Significant changes
45−
46−- Support for ghc8.8 (#1318, #1326, #1327)
47−
48−
49−0.17
50−----
51−
52−### Significant changes
53−
54−- Add NoContentVerb [#1028](https://github.com/haskell-servant/servant/issues/1028) [#1219](https://github.com/haskell-servant/servant/pull/1219) [#1228](https://github.com/haskell-servant/servant/pull/1228)
55−
56− The `NoContent` API endpoints should now use `NoContentVerb` combinator.
57− The API type changes are usually of the kind
58−
59− ```diff
60− - :<|> PostNoContent '[JSON] NoContent
61− + :<|> PostNoContent
62− ```
63−
64− i.e. one doesn't need to specify the content-type anymore. There is no content.
65−
66−- `Capture` can be `Lenient` [#1155](https://github.com/haskell-servant/servant/issues/1155) [#1156](https://github.com/haskell-servant/servant/pull/1156)
67−
68− You can specify a lenient capture as
69−
70− ```haskell
71− :<|> "capture-lenient" :> Capture' '[Lenient] "foo" Int :> GET
72− ```
73−
74− which will make the capture always succeed. Handlers will be of the
75− type `Either String CapturedType`, where `Left err` represents
76− the possible parse failure.
77−
78−### Other changes
79−
80−- *servant-client* *servant-client-core* *servant-http-streams* Fix Verb with headers checking content type differently [#1200](https://github.com/haskell-servant/servant/issues/1200) [#1204](https://github.com/haskell-servant/servant/pull/1204)
81−
82− For `Verb`s with response `Headers`, the implementation didn't check
83− for the content-type of the response. Now it does.
84−
85−- *servant-client* *servant-http-streams* `HasClient` instance for `Stream` with `Headers` [#1170](https://github.com/haskell-servant/servant/issues/1170) [#1197](https://github.com/haskell-servant/servant/pull/1197)
86−- *servant-client* Redact the authorization header in Show and exceptions [#1238](https://github.com/haskell-servant/servant/pull/1238)
87−
88−
89−
90−0.16.0.1
91−--------
92−
93−- Allow `base-compat-0.11`
94−
95−0.16
96−----
97−
98−- Initial release
servant-http-streams/LICENSEdeleted−30
@@ -1,30 +0,0 @@
1−Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, 2016-2018 Servant Contributors
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 Zalora South East Asia Pte Ltd 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.
servant-http-streams/README.lhsdeleted−1
@@ -1 +0,0 @@
1−README.md
servant-http-streams/README.mddeleted−44
@@ -1,44 +0,0 @@
1−# servant-client
2−
3−![servant](https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png)
4−
5−This library lets you automatically derive Haskell functions that let you query each endpoint of a *servant* webservice.
6−
7−## Example
8−
9−``` haskell
10−{-# LANGUAGE DataKinds #-}
11−{-# LANGUAGE TypeOperators #-}
12−
13−import Data.Proxy
14−import Data.Text
15−import Servant.API
16−import Servant.HttpStreams
17−
18−
19−type Book = Text
20−
21−type MyApi = "books" :> Get '[JSON] [Book] -- GET /books
22− :<|> "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book -- POST /books
23−
24−myApi :: Proxy MyApi
25−myApi = Proxy
26−
27−-- 'client' allows you to produce operations to query an API from a client.
28−postNewBook :: Book -> ClientM Book
29−getAllBooks :: ClientM [Book]
30−(getAllBooks :<|> postNewBook) = client myApi
31−
32−-- the IOException happens already in withClientEnvIO
33−main' :: IO ()
34−main' = do
35− let burl = BaseUrl Http "localhost" 8081 ""
36− withClientEnvIO burl $ \env -> do
37− res <- runClientM getAllBooks env
38− case res of
39− Left err -> putStrLn $ "Error: " ++ show err
40− Right books -> print books
41−
42−main :: IO ()
43−main = return ()
44−```
servant-http-streams/Setup.hsdeleted−2
@@ -1,2 +0,0 @@
1−import Distribution.Simple
2−main = defaultMain
servant-http-streams/servant-http-streams.cabaldeleted−132
@@ -1,132 +0,0 @@
1−cabal-version: 2.2
2−name: servant-http-streams
3−version: 0.18.4
4−
5−synopsis: Automatic derivation of querying functions for servant
6−category: Servant, Web
7−description:
8− This library lets you derive automatically Haskell functions that
9− let you query each endpoint of a <http://hackage.haskell.org/package/servant servant> webservice.
10− .
11− See <http://docs.servant.dev/en/stable/tutorial/Client.html the client section of the tutorial>.
12− .
13− <https://github.com/haskell-servant/servant/blob/master/servant-client/CHANGELOG.md CHANGELOG>
14−
15−homepage: http://docs.servant.dev/
16−bug-reports: http://github.com/haskell-servant/servant/issues
17−license: BSD-3-Clause
18−license-file: LICENSE
19−author: Servant Contributors
20−maintainer: haskell-servant-maintainers@googlegroups.com
21−copyright: 2019 Servant Contributors
22−build-type: Simple
23−tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1
24−
25−extra-source-files:
26− CHANGELOG.md
27− README.md
28−
29−source-repository head
30− type: git
31− location: http://github.com/haskell-servant/servant.git
32−
33−library
34− exposed-modules:
35− Servant.HttpStreams
36− Servant.HttpStreams.Internal
37−
38− -- Bundled with GHC: Lower bound to not force re-installs
39− -- text and mtl are bundled starting with GHC-8.4
40− build-depends:
41− base >= 4.9 && < 4.18
42− , bytestring >= 0.10.8.1 && < 0.12
43− , containers >= 0.5.7.1 && < 0.7
44− , deepseq >= 1.4.2.0 && < 1.5
45− , mtl ^>= 2.2.2 || ^>= 2.3.1
46− , text >= 1.2.3.0 && < 2.1
47− , time >= 1.6.0.1 && < 1.13
48− , transformers >= 0.5.2.0 && < 0.7
49−
50− if !impl(ghc >= 8.2)
51− build-depends:
52− bifunctors >= 5.5.3 && < 5.6
53−
54− -- Servant dependencies.
55− -- Strict dependency on `servant-client-core` as we re-export things.
56− build-depends:
57− servant >= 0.18 && < 0.20
58− , servant-client-core >= 0.18.3 && <0.20
59−
60− -- Other dependencies: Lower bound around what is in the latest Stackage LTS.
61− -- Here can be exceptions if we really need features from the newer versions.
62− build-depends:
63− base-compat >= 0.10.5 && < 0.13
64− , case-insensitive
65− , http-streams >= 0.8.6.1 && < 0.9
66− , http-media >= 0.7.1.3 && < 0.9
67− , io-streams >= 1.5.0.1 && < 1.6
68− , http-types >= 0.12.2 && < 0.13
69− , http-common >= 0.8.2.0 && < 0.9
70− , exceptions >= 0.10.0 && < 0.11
71− , kan-extensions >= 5.2 && < 5.3
72− , monad-control >= 1.0.2.3 && < 1.1
73− , semigroupoids >= 5.3.1 && < 5.4
74− , transformers-base >= 0.4.5.2 && < 0.5
75− , transformers-compat >= 0.6.2 && < 0.8
76−
77− hs-source-dirs: src
78− default-language: Haskell2010
79− ghc-options: -Wall -Wno-redundant-constraints
80−
81−test-suite spec
82− type: exitcode-stdio-1.0
83− ghc-options: -Wall -rtsopts -threaded "-with-rtsopts=-T -N2"
84− default-language: Haskell2010
85− hs-source-dirs: test
86− main-is: Spec.hs
87− other-modules:
88− Servant.ClientSpec
89− Servant.StreamSpec
90−
91− -- Dependencies inherited from the library. No need to specify bounds.
92− build-depends:
93− base
94− , aeson
95− , base-compat
96− , bytestring
97− , http-api-data
98− , http-streams
99− , deepseq
100− , http-types
101− , mtl
102− , kan-extensions
103− , servant-http-streams
104− , servant-client-core
105− , stm
106− , text
107− , transformers
108− , transformers-compat
109− , wai
110− , warp
111−
112− -- Additional dependencies
113− build-depends:
114− entropy >= 0.4.1.3 && < 0.5
115− , hspec >= 2.6.0 && < 2.10
116− , HUnit >= 1.6.0.0 && < 1.7
117− , network >= 2.8.0.0 && < 3.2
118− , QuickCheck >= 2.12.6.1 && < 2.15
119− , servant == 0.19.*
120− , servant-server == 0.19.*
121− , tdigest >= 0.2 && < 0.3
122−
123− build-tool-depends:
124− hspec-discover:hspec-discover >= 2.6.0 && < 2.10
125−
126−test-suite readme
127− type: exitcode-stdio-1.0
128− main-is: README.lhs
129− build-depends: base, servant, http-streams, text, servant-http-streams, markdown-unlit
130− build-tool-depends: markdown-unlit:markdown-unlit
131− ghc-options: -pgmL markdown-unlit
132− default-language: Haskell2010
servant-http-streams/src/Servant/HttpStreams.hsdeleted−19
@@ -1,19 +0,0 @@
1−
2−
3−-- | This module provides 'client' which can automatically generate
4−-- querying functions for each endpoint just from the type representing your
5−-- API.
6−module Servant.HttpStreams
7− ( client
8− , ClientM
9− , withClientM
10− , runClientM
11− , ClientEnv(..)
12− , mkClientEnv
13− , withClientEnvIO
14− , hoistClient
15− , module Servant.Client.Core.Reexport
16− ) where
17−
18−import Servant.Client.Core.Reexport
19−import Servant.HttpStreams.Internal
servant-http-streams/src/Servant/HttpStreams/Internal.hsdeleted−258
@@ -1,258 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE DeriveDataTypeable #-}
3−{-# LANGUAGE DeriveGeneric #-}
4−{-# LANGUAGE FlexibleContexts #-}
5−{-# LANGUAGE FlexibleInstances #-}
6−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7−{-# LANGUAGE MultiParamTypeClasses #-}
8−{-# LANGUAGE OverloadedStrings #-}
9−{-# LANGUAGE RankNTypes #-}
10−{-# LANGUAGE ScopedTypeVariables #-}
11−{-# LANGUAGE TypeFamilies #-}
12−module Servant.HttpStreams.Internal where
13−
14−import Prelude ()
15−import Prelude.Compat
16−
17−import Control.DeepSeq
18− (NFData, force)
19−import Control.Exception
20− (IOException, SomeException (..), catch, evaluate, throwIO)
21−import Control.Monad
22− (unless)
23−import Control.Monad.Base
24− (MonadBase (..))
25−import Control.Monad.Codensity
26− (Codensity (..))
27−import Control.Monad.Error.Class
28− (MonadError (..))
29−import Control.Monad.IO.Class
30− (MonadIO (..))
31−import Control.Monad.Reader
32− (MonadReader, ReaderT, ask, runReaderT)
33−import Control.Monad.Trans.Class
34− (lift)
35−import Control.Monad.Trans.Except
36− (ExceptT, runExceptT)
37−import Data.Bifunctor
38− (bimap, first)
39−import Data.ByteString.Builder
40− (toLazyByteString)
41−import qualified Data.ByteString.Builder as B
42−import qualified Data.ByteString.Lazy as BSL
43−import qualified Data.CaseInsensitive as CI
44−import Data.Foldable
45− (for_, toList)
46−import Data.Functor.Alt
47− (Alt (..))
48−import Data.Maybe
49− (maybeToList)
50−import Data.Proxy
51− (Proxy (..))
52−import Data.Sequence
53− (fromList)
54−import Data.String
55− (fromString)
56−import GHC.Generics
57−import Network.HTTP.Media
58− (renderHeader)
59−import Network.HTTP.Types
60− (Status (..), hContentType, http11, renderQuery, statusIsSuccessful)
61−import Servant.Client.Core
62−
63−import qualified Network.Http.Client as Client
64−import qualified Network.Http.Types as Client
65−import qualified Servant.Types.SourceT as S
66−import qualified System.IO.Streams as Streams
67−
68−-- | The environment in which a request is run.
69−--
70−-- 'ClientEnv' carries an open connection. See 'withClientEnvIO'.
71−--
72−data ClientEnv
73− = ClientEnv
74− { baseUrl :: BaseUrl
75− , connection :: Client.Connection
76− }
77−
78−-- | 'ClientEnv' smart constructor.
79−mkClientEnv :: BaseUrl -> Client.Connection -> ClientEnv
80−mkClientEnv = ClientEnv
81−
82−-- | Open a connection to 'BaseUrl'.
83−withClientEnvIO :: BaseUrl -> (ClientEnv -> IO r) -> IO r
84−withClientEnvIO burl k = Client.withConnection open $ \conn ->
85− k (mkClientEnv burl conn)
86− where
87− open = Client.openConnection (fromString $ baseUrlHost burl) (fromIntegral $ baseUrlPort burl)
88−
89−-- | Generates a set of client functions for an API.
90−--
91−-- Example:
92−--
93−-- > type API = Capture "no" Int :> Get '[JSON] Int
94−-- > :<|> Get '[JSON] [Bool]
95−-- >
96−-- > api :: Proxy API
97−-- > api = Proxy
98−-- >
99−-- > getInt :: Int -> ClientM Int
100−-- > getBools :: ClientM [Bool]
101−-- > getInt :<|> getBools = client api
102−client :: HasClient ClientM api => Proxy api -> Client ClientM api
103−client api = api `clientIn` (Proxy :: Proxy ClientM)
104−
105−-- | Change the monad the client functions live in, by
106−-- supplying a conversion function
107−-- (a natural transformation to be precise).
108−--
109−-- For example, assuming you have some @manager :: 'Manager'@ and
110−-- @baseurl :: 'BaseUrl'@ around:
111−--
112−-- > type API = Get '[JSON] Int :<|> Capture "n" Int :> Post '[JSON] Int
113−-- > api :: Proxy API
114−-- > api = Proxy
115−-- > getInt :: IO Int
116−-- > postInt :: Int -> IO Int
117−-- > getInt :<|> postInt = hoistClient api (flip runClientM cenv) (client api)
118−-- > where cenv = mkClientEnv manager baseurl
119−hoistClient
120− :: HasClient ClientM api
121− => Proxy api
122− -> (forall a. m a -> n a)
123− -> Client m api
124− -> Client n api
125−hoistClient = hoistClientMonad (Proxy :: Proxy ClientM)
126−
127−-- | @ClientM@ is the monad in which client functions run. Contains the
128−-- 'Client.Manager' and 'BaseUrl' used for requests in the reader environment.
129−newtype ClientM a = ClientM
130− { unClientM :: ReaderT ClientEnv (ExceptT ClientError (Codensity IO)) a }
131− deriving ( Functor, Applicative, Monad, MonadIO, Generic
132− , MonadReader ClientEnv, MonadError ClientError)
133−
134−instance MonadBase IO ClientM where
135− liftBase = ClientM . liftIO
136−
137−-- | Try clients in order, last error is preserved.
138−instance Alt ClientM where
139− a <!> b = a `catchError` \_ -> b
140−
141−instance RunClient ClientM where
142− runRequestAcceptStatus = performRequest
143− throwClientError = throwError
144−
145−instance RunStreamingClient ClientM where
146− withStreamingRequest = performWithStreamingRequest
147−
148−runClientM :: NFData a => ClientM a -> ClientEnv -> IO (Either ClientError a)
149−runClientM cm env = withClientM cm env (evaluate . force)
150−
151−withClientM :: ClientM a -> ClientEnv -> (Either ClientError a -> IO b) -> IO b
152−withClientM cm env k =
153− let Codensity f = runExceptT $ flip runReaderT env $ unClientM cm
154− in f k
155−
156−performRequest :: Maybe [Status] -> Request -> ClientM Response
157−performRequest acceptStatus req = do
158− ClientEnv burl conn <- ask
159− let (req', body) = requestToClientRequest burl req
160− x <- ClientM $ lift $ lift $ Codensity $ \k -> do
161− Client.sendRequest conn req' body
162− Client.receiveResponse conn $ \res' body' -> do
163− let status = toEnum $ Client.getStatusCode res'
164− lbs <- BSL.fromChunks <$> Streams.toList body'
165− let res'' = clientResponseToResponse res' lbs
166− goodStatus = case acceptStatus of
167− Nothing -> statusIsSuccessful status
168− Just good -> status `elem` good
169− if goodStatus
170− then k (Right res'')
171− else k (Left (mkFailureResponse burl req res''))
172−
173− either throwError pure x
174−
175−performWithStreamingRequest :: Request -> (StreamingResponse -> IO a) -> ClientM a
176−performWithStreamingRequest req k = do
177− ClientEnv burl conn <- ask
178− let (req', body) = requestToClientRequest burl req
179− ClientM $ lift $ lift $ Codensity $ \k1 -> do
180− Client.sendRequest conn req' body
181− Client.receiveResponseRaw conn $ \res' body' -> do
182− -- check status code
183− let status = toEnum $ Client.getStatusCode res'
184− unless (statusIsSuccessful status) $ do
185− lbs <- BSL.fromChunks <$> Streams.toList body'
186− throwIO $ mkFailureResponse burl req (clientResponseToResponse res' lbs)
187−
188− x <- k (clientResponseToResponse res' (fromInputStream body'))
189− k1 x
190−
191−mkFailureResponse :: BaseUrl -> Request -> ResponseF BSL.ByteString -> ClientError
192−mkFailureResponse burl request =
193− FailureResponse (bimap (const ()) f request)
194− where
195− f b = (burl, BSL.toStrict $ toLazyByteString b)
196−
197−clientResponseToResponse :: Client.Response -> body -> ResponseF body
198−clientResponseToResponse r body = Response
199− { responseStatusCode = Status (Client.getStatusCode r) (Client.getStatusMessage r)
200− , responseBody = body
201− , responseHeaders = fromList $ map (first CI.mk) $ Client.retrieveHeaders $ Client.getHeaders r
202− , responseHttpVersion = http11 -- guess
203− }
204−
205−requestToClientRequest :: BaseUrl -> Request -> (Client.Request, Streams.OutputStream B.Builder -> IO ())
206−requestToClientRequest burl r = (request, body)
207− where
208− request = Client.buildRequest1 $ do
209− Client.http (Client.Method $ requestMethod r)
210− $ fromString (baseUrlPath burl)
211− <> BSL.toStrict (toLazyByteString (requestPath r))
212− <> renderQuery True (toList (requestQueryString r))
213− -- We are connected, but we still need to know what we try to query
214− Client.setHostname (fromString $ baseUrlHost burl) (fromIntegral $ baseUrlPort burl)
215− for_ (maybeToList acceptHdr ++ maybeToList contentTypeHdr ++ headers) $ \(hn, hv) ->
216− Client.setHeader (CI.original hn) hv
217−
218− -- body is always chunked
219− Client.setTransferEncoding
220−
221− -- Content-Type and Accept are specified by requestBody and requestAccept
222− headers = filter (\(h, _) -> h /= "Accept" && h /= "Content-Type") $
223− toList $ requestHeaders r
224−
225− acceptHdr
226− | null hs = Nothing
227− | otherwise = Just ("Accept", renderHeader hs)
228− where
229− hs = toList $ requestAccept r
230−
231− convertBody bd os = case bd of
232− RequestBodyLBS body' ->
233− Streams.writeTo os (Just (B.lazyByteString body'))
234− RequestBodyBS body' ->
235− Streams.writeTo os (Just (B.byteString body'))
236− RequestBodySource sourceIO ->
237− toOutputStream sourceIO os
238−
239− (body, contentTypeHdr) = case requestBody r of
240− Nothing -> (Client.emptyBody, Nothing)
241− Just (body', typ) -> (convertBody body', Just (hContentType, renderHeader typ))
242−
243−catchConnectionError :: IO a -> IO (Either ClientError a)
244−catchConnectionError action =
245− catch (Right <$> action) $ \e ->
246− pure . Left . ConnectionError $ SomeException (e :: IOException)
247−
248−fromInputStream :: Streams.InputStream b -> S.SourceT IO b
249−fromInputStream is = S.SourceT $ \k -> k loop where
250− loop = S.Effect $ maybe S.Stop (flip S.Yield loop) <$> Streams.read is
251−
252−toOutputStream :: S.SourceT IO BSL.ByteString -> Streams.OutputStream B.Builder -> IO ()
253−toOutputStream (S.SourceT k) os = k loop where
254− loop S.Stop = return ()
255− loop (S.Error err) = fail err
256− loop (S.Skip s) = loop s
257− loop (S.Effect mx) = mx >>= loop
258− loop (S.Yield x s) = Streams.write (Just (B.lazyByteString x)) os >> loop s
servant-http-streams/test/Servant/StreamSpec.hsdeleted−110
@@ -1,110 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE ConstraintKinds #-}
3−{-# LANGUAGE DataKinds #-}
4−{-# LANGUAGE DeriveGeneric #-}
5−{-# LANGUAGE FlexibleContexts #-}
6−{-# LANGUAGE FlexibleInstances #-}
7−{-# LANGUAGE FunctionalDependencies #-}
8−{-# LANGUAGE GADTs #-}
9−{-# LANGUAGE MultiParamTypeClasses #-}
10−{-# LANGUAGE OverloadedStrings #-}
11−{-# LANGUAGE PolyKinds #-}
12−{-# LANGUAGE RecordWildCards #-}
13−{-# LANGUAGE ScopedTypeVariables #-}
14−{-# LANGUAGE StandaloneDeriving #-}
15−{-# LANGUAGE TypeFamilies #-}
16−{-# LANGUAGE TypeOperators #-}
17−{-# LANGUAGE UndecidableInstances #-}
18−{-# OPTIONS_GHC -freduction-depth=100 #-}
19−{-# OPTIONS_GHC -fno-warn-orphans #-}
20−{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
21−
22−module Servant.StreamSpec (spec) where
23−
24−import Control.Monad.Trans.Except
25−import qualified Data.ByteString as BS
26−import Data.Proxy
27−import Prelude ()
28−import Prelude.Compat
29−import Servant.API
30− ((:<|>) ((:<|>)), (:>), JSON, NetstringFraming,
31− NewlineFraming, NoFraming, OctetStream, SourceIO, StreamBody,
32− StreamGet)
33−import Servant.ClientSpec
34− (Person (..))
35−import qualified Servant.ClientSpec as CS
36−import Servant.HttpStreams
37−import Servant.Server
38−import Servant.Types.SourceT
39−import System.Entropy
40− (getEntropy, getHardwareEntropy)
41−import Test.Hspec
42−
43−
44−spec :: Spec
45−spec = describe "Servant.HttpStreams streaming" $ do
46− streamSpec
47−
48−type StreamApi =
49− "streamGetNewline" :> StreamGet NewlineFraming JSON (SourceIO Person)
50− :<|> "streamGetNetstring" :> StreamGet NetstringFraming JSON (SourceIO Person)
51− :<|> "streamALot" :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString)
52− :<|> "streamBody" :> StreamBody NoFraming OctetStream (SourceIO BS.ByteString) :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString)
53−
54−api :: Proxy StreamApi
55−api = Proxy
56−
57−getGetNL, getGetNS :: ClientM (SourceIO Person)
58−_getGetALot :: ClientM (SourceIO BS.ByteString)
59−getStreamBody :: SourceT IO BS.ByteString -> ClientM (SourceIO BS.ByteString)
60−getGetNL :<|> getGetNS :<|> _getGetALot :<|> getStreamBody = client api
61−
62−alice :: Person
63−alice = Person "Alice" 42
64−
65−bob :: Person
66−bob = Person "Bob" 25
67−
68−server :: Application
69−server = serve api
70− $ return (source [alice, bob, alice])
71− :<|> return (source [alice, bob, alice])
72− -- 2 ^ (18 + 10) = 256M
73− :<|> return (SourceT ($ lots (powerOfTwo 18)))
74− :<|> return
75− where
76− lots n
77− | n < 0 = Stop
78− | otherwise = Effect $ do
79− let size = powerOfTwo 10
80− mbs <- getHardwareEntropy size
81− bs <- maybe (getEntropy size) pure mbs
82− return (Yield bs (lots (n - 1)))
83−
84−powerOfTwo :: Int -> Int
85−powerOfTwo = (2 ^)
86−
87−withClient :: ClientM a -> BaseUrl -> (Either ClientError a -> IO r) -> IO r
88−withClient x burl k = do
89− withClientEnvIO burl $ \env -> withClientM x env k
90−
91−testRunSourceIO :: SourceIO a
92− -> IO (Either String [a])
93−testRunSourceIO = runExceptT . runSourceT
94−
95−streamSpec :: Spec
96−streamSpec = beforeAll (CS.startWaiApp server) $ afterAll CS.endWaiApp $ do
97− it "works with Servant.API.StreamGet.Newline" $ \(_, baseUrl) -> do
98− withClient getGetNL baseUrl $ \(Right res) ->
99− testRunSourceIO res `shouldReturn` Right [alice, bob, alice]
100−
101− it "works with Servant.API.StreamGet.Netstring" $ \(_, baseUrl) -> do
102− withClient getGetNS baseUrl $ \(Right res) ->
103− testRunSourceIO res `shouldReturn` Right [alice, bob, alice]
104−
105− it "works with Servant.API.StreamBody" $ \(_, baseUrl) -> do
106− withClient (getStreamBody (source input)) baseUrl $ \(Right res) ->
107− testRunSourceIO res `shouldReturn` Right output
108− where
109− input = ["foo", "", "bar"]
110− output = ["foo", "bar"]
servant-http-streams/test/Spec.hsdeleted−1
@@ -1 +0,0 @@
1−{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
servant-machines/CHANGELOG.mddeleted−4
@@ -1,4 +0,0 @@
1−0.15
2−----
3−
4−- First release with support for `servant-0.15` `Stream` refactoring.
servant-machines/LICENSEdeleted−30
@@ -1,30 +0,0 @@
1−Copyright (c) 2018, Servant Contributors
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 Servant Contributors 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.
servant-machines/README.mddeleted−3
@@ -1,3 +0,0 @@
1−# servant-machines - Servant Stream support for machines
2−
3−![servant](https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png)
servant-machines/Setup.hsdeleted−2
@@ -1,2 +0,0 @@
1−import Distribution.Simple
2−main = defaultMain
servant-machines/example/Main.hsdeleted−98
@@ -1,98 +0,0 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE DeriveGeneric #-}
3−{-# LANGUAGE TypeOperators #-}
4−module Main (main) where
5−
6−import Prelude ()
7−import Prelude.Compat
8−
9−import Control.Concurrent
10− (threadDelay)
11−import Control.Monad.IO.Class
12− (MonadIO (..))
13−import qualified Data.ByteString as BS
14−import Data.Maybe
15− (fromMaybe)
16−import Data.Void
17− (Void)
18−import Network.HTTP.Client
19− (defaultManagerSettings, newManager)
20−import Network.Wai
21− (Application)
22−import System.Environment
23− (getArgs, lookupEnv)
24−import Text.Read
25− (readMaybe)
26−
27−import Data.Machine
28−import Servant
29−import Servant.Client.Streaming
30−import Servant.Machines ()
31−
32−import qualified Network.Wai.Handler.Warp as Warp
33−
34−type FastAPI = "get" :> Capture "num" Int :> StreamGet NewlineFraming JSON (MachineT IO (Is Void) Int)
35−
36−type API = FastAPI
37− :<|> "slow" :> Capture "num" Int :> StreamGet NewlineFraming JSON (MachineT IO (Is Void) Int)
38− :<|> "proxy"
39− :> StreamBody NoFraming OctetStream (MachineT IO (Is Void) BS.ByteString)
40− :> StreamPost NoFraming OctetStream (MachineT IO (Is Void) BS.ByteString)
41−
42−api :: Proxy API
43−api = Proxy
44−
45−server :: Server API
46−server = fast :<|> slow :<|> proxy
47− where
48− fast n = liftIO $ do
49− putStrLn ("/get/" ++ show n)
50− return $ fastMachine n
51−
52− slow n = liftIO $ do
53− putStrLn ("/slow/" ++ show n)
54− return $ slowMachine n
55−
56− proxy c = liftIO $ do
57− putStrLn "/proxy"
58− return c
59−
60− -- for some reason unfold leaks?
61− fastMachine m
62− | m < 0 = MachineT (return Stop)
63− | otherwise = MachineT (return (Yield m (fastMachine (m - 1))))
64−
65− slowMachine m
66− | m < 0 = MachineT (return Stop)
67− | otherwise = MachineT $ do
68− threadDelay 1000000
69− return (Yield m (slowMachine (m - 1)))
70−
71−app :: Application
72−app = serve api server
73−
74−cli :: Client ClientM FastAPI
75−cli :<|> _ = client api
76−
77−main :: IO ()
78−main = do
79− args <- getArgs
80− case args of
81− ("server":_) -> do
82− putStrLn "Starting servant-machines:example at http://localhost:8000"
83− port <- fromMaybe 8000 . (>>= readMaybe) <$> lookupEnv "PORT"
84− Warp.run port app
85− ("client":ns:_) -> do
86− n <- maybe (fail $ "not a number: " ++ ns) pure $ readMaybe ns
87− mgr <- newManager defaultManagerSettings
88− burl <- parseBaseUrl "http://localhost:8000/"
89− withClientM (cli n) (mkClientEnv mgr burl) $ \me -> case me of
90− Left err -> print err
91− Right m -> do
92− x <- runT $ fold (\p _ -> p + 1) (0 :: Int) <~ m
93− print x
94− _ -> do
95− putStrLn "Try:"
96− putStrLn "cabal new-run servant-machines:example server"
97− putStrLn "cabal new-run servant-machines:example client 10"
98− putStrLn "time curl -H 'Accept: application/json' localhost:8000/slow/5"
servant-machines/servant-machines.cabaldeleted−59
@@ -1,59 +0,0 @@
1−cabal-version: 2.2
2−name: servant-machines
3−version: 0.15.1
4−
5−synopsis: Servant Stream support for machines
6−category: Servant, Web, Enumerator
7−description: Servant Stream support for machines.
8− .
9− Provides 'ToSourceIO' and 'FromSourceIO' instances for 'MachineT'.
10−
11−homepage: http://docs.servant.dev/
12−bug-reports: http://github.com/haskell-servant/servant/issues
13−license: BSD-3-Clause
14−license-file: LICENSE
15−author: Servant Contributors
16−maintainer: haskell-servant-maintainers@googlegroups.com
17−copyright: 2018-2019 Servant Contributors
18−build-type: Simple
19−tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2
20−
21−extra-source-files:
22− CHANGELOG.md
23−
24−source-repository head
25− type: git
26− location: http://github.com/haskell-servant/servant.git
27−
28−library
29− exposed-modules: Servant.Machines
30− build-depends:
31− base >=4.9 && <5
32− , bytestring >=0.10.8.1 && <0.12
33− , machines >=0.6.4 && <0.8
34− , mtl ^>=2.2.2 || ^>=2.3.1
35− , servant >=0.15 && <0.20
36− hs-source-dirs: src
37− default-language: Haskell2010
38− ghc-options: -Wall
39−
40−test-suite example
41− type: exitcode-stdio-1.0
42− main-is: Main.hs
43− hs-source-dirs:
44− example
45− ghc-options: -Wall -rtsopts -threaded
46− build-depends:
47− base
48− , base-compat
49− , bytestring
50− , http-media
51− , servant
52− , machines
53− , servant-machines
54− , servant-server >=0.15 && <0.20
55− , servant-client >=0.15 && <0.20
56− , wai >=3.2.1.2 && <3.3
57− , warp >=3.2.25 && <3.4
58− , http-client
59− default-language: Haskell2010
servant-machines/src/Servant/Machines.hsdeleted−46
@@ -1,46 +0,0 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE FlexibleInstances #-}
3−{-# LANGUAGE GADTs #-}
4−{-# LANGUAGE MultiParamTypeClasses #-}
5−{-# LANGUAGE ScopedTypeVariables #-}
6−{-# LANGUAGE UndecidableInstances #-}
7−{-# OPTIONS_GHC -Wno-orphans #-}
8−-- | This module exports 'ToSourceIO' and 'FromSourceIO' for 'MachineT' instances.
9−module Servant.Machines (
10− MachineToSourceIO (..),
11− ) where
12−
13−import Control.Monad.IO.Class
14− (MonadIO (..))
15−import Data.Machine
16− (MachineT (..), Step (..))
17−import Servant.API.Stream
18−import qualified Servant.Types.SourceT as S
19−
20−-- | Helper class to implement @'ToSourceIO' 'MachineT'@ instance
21−-- for various monads.
22−class MachineToSourceIO m where
23− machineToSourceIO :: MachineT m k o -> S.SourceT IO o
24−
25−instance MachineToSourceIO IO where
26− machineToSourceIO ma = S.SourceT ($ go ma) where
27− go (MachineT m) = S.Effect $ do
28− step <- m
29− case step of
30− Stop -> return S.Stop
31− Yield x m' -> return (S.Yield x (go m'))
32− Await _ _ m' -> return (S.Skip (go m'))
33−
34−instance MachineToSourceIO m => ToSourceIO o (MachineT m k o) where
35− toSourceIO = machineToSourceIO
36−
37−instance MonadIO m => FromSourceIO o (MachineT m k o) where
38− fromSourceIO src = MachineT $ liftIO $ S.unSourceT src go
39− where
40− go :: S.StepT IO o -> IO (Step k o (MachineT m k o))
41− go S.Stop = return Stop
42− go (S.Error err) = fail err
43− go (S.Skip s) = go s
44− go (S.Effect ms) = ms >>= go
45− go (S.Yield x s) = return (Yield x (MachineT (liftIO (go s))))
46− {-# SPECIALIZE INLINE fromSourceIO :: SourceIO o -> MachineT IO k o #-}
servant-pipes/CHANGELOG.mddeleted−22
@@ -1,22 +0,0 @@
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−
12−0.15.1
13−------
14−
15−- `FromSourceIO Proxy` (`ListT`) instance `fail`s in `IO`, not in `m`.
16− This works around `MonadFail` proposal, and makes `servant-pipes`
17− behave like `servant-conduit` and `servant-machines`.
18−
19−0.15
20−----
21−
22−- First release with support for `servant-0.15` `Stream` refactoring.
servant-pipes/LICENSEdeleted−30
@@ -1,30 +0,0 @@
1−Copyright (c) 2018, Servant Contributors
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 Servant Contributors 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.
servant-pipes/README.mddeleted−3
@@ -1,3 +0,0 @@
1−# servant-pipes - Servant Stream support for pipes
2−
3−![servant](https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png)
servant-pipes/Setup.hsdeleted−2
@@ -1,2 +0,0 @@
1−import Distribution.Simple
2−main = defaultMain
servant-pipes/example/Main.hsdeleted−107
@@ -1,107 +0,0 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE DeriveGeneric #-}
3−{-# LANGUAGE TypeOperators #-}
4−module Main (main) where
5−
6−import Prelude ()
7−import Prelude.Compat
8−
9−import Control.Concurrent
10− (threadDelay)
11−import Control.Monad.IO.Class
12− (MonadIO (..))
13−import qualified Data.ByteString as BS
14−import Data.Maybe
15− (fromMaybe)
16−import Network.HTTP.Client
17− (defaultManagerSettings, newManager)
18−import Network.Wai
19− (Application)
20−import System.Environment
21− (getArgs, lookupEnv)
22−import System.IO
23− (IOMode (..))
24−import Text.Read
25− (readMaybe)
26−
27−import qualified Pipes as P
28−import Pipes.ByteString as PBS
29−import qualified Pipes.Prelude as P
30−import Pipes.Safe
31− (SafeT)
32−import qualified Pipes.Safe.Prelude as P
33−import Servant
34−import Servant.Client.Streaming
35−import Servant.Pipes ()
36−
37−import qualified Network.Wai.Handler.Warp as Warp
38−
39−type FastAPI = "get" :> Capture "num" Int :> StreamGet NewlineFraming JSON (P.Producer Int IO ())
40−
41−-- TODO: Change IO to something with MonadError ServantUnrenderError
42−type API = FastAPI
43− :<|> "slow" :> Capture "num" Int :> StreamGet NewlineFraming JSON (P.Producer Int IO ())
44− -- monad can be SafeT IO too.
45− :<|> "readme" :> StreamGet NoFraming OctetStream (P.Producer BS.ByteString (SafeT IO) ())
46− -- we can have streaming request body
47− :<|> "proxy"
48− :> StreamBody NoFraming OctetStream (P.Producer BS.ByteString IO ())
49− :> StreamPost NoFraming OctetStream (P.Producer BS.ByteString IO ())
50−
51−api :: Proxy API
52−api = Proxy
53−
54−server :: Server API
55−server = fast :<|> slow :<|> readme :<|> proxy
56− where
57− fast n = liftIO $ do
58− putStrLn ("/get/" ++ show n)
59− return $ fastPipe n
60−
61− slow n = liftIO $ do
62− putStrLn ("/slow/" ++ show n)
63− return $ slowPipe n
64−
65− readme = liftIO $ do
66− putStrLn "/readme"
67− return $ P.withFile "README.md" ReadMode $ \h -> PBS.fromHandle h
68−
69− proxy c = liftIO $ do
70− putStrLn "/proxy"
71− return c
72−
73− -- for some reason unfold leaks?
74− fastPipe m
75− | m < 0 = return ()
76− | otherwise = P.yield m >> fastPipe (m - 1)
77−
78− slowPipe m = fastPipe m P.>-> P.mapM (<$ threadDelay 1000000)
79−
80−app :: Application
81−app = serve api server
82−
83−cli :: Client ClientM FastAPI
84−cli :<|> _ :<|> _ :<|> _ = client api
85−
86−main :: IO ()
87−main = do
88− args <- getArgs
89− case args of
90− ("server":_) -> do
91− putStrLn "Starting servant-pipes:example at http://localhost:8000"
92− port <- fromMaybe 8000 . (>>= readMaybe) <$> lookupEnv "PORT"
93− Warp.run port app
94− ("client":ns:_) -> do
95− n <- maybe (fail $ "not a number: " ++ ns) pure $ readMaybe ns
96− mgr <- newManager defaultManagerSettings
97− burl <- parseBaseUrl "http://localhost:8000/"
98− withClientM (cli n) (mkClientEnv mgr burl) $ \me -> case me of
99− Left err -> print err
100− Right p -> do
101− x <- P.fold (\c _ -> c + 1) (0 :: Int) id p
102− print x
103− _ -> do
104− putStrLn "Try:"
105− putStrLn "cabal new-run servant-pipes:example server"
106− putStrLn "cabal new-run servant-pipes:example client 10"
107− putStrLn "time curl -H 'Accept: application/json' localhost:8000/slow/5"
servant-pipes/servant-pipes.cabaldeleted−63
@@ -1,63 +0,0 @@
1−cabal-version: 2.2
2−name: servant-pipes
3−version: 0.15.3
4−
5−synopsis: Servant Stream support for pipes
6−category: Servant, Web, Pipes
7−description: Servant Stream support for pipes.
8− .
9− Provides 'ToSourceIO' and 'FromSourceIO' instances for 'Proxy' and 'SafeT'.
10−
11−homepage: http://docs.servant.dev/
12−bug-reports: http://github.com/haskell-servant/servant/issues
13−license: BSD-3-Clause
14−license-file: LICENSE
15−author: Servant Contributors
16−maintainer: haskell-servant-maintainers@googlegroups.com
17−copyright: 2018-2019 Servant Contributors
18−build-type: Simple
19−tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2
20−
21−extra-source-files:
22− CHANGELOG.md
23−
24−source-repository head
25− type: git
26− location: http://github.com/haskell-servant/servant.git
27−
28−library
29− exposed-modules: Servant.Pipes
30− build-depends:
31− base >=4.9 && <5
32− , bytestring >=0.10.8.1 && <0.12
33− , pipes >=4.3.9 && <4.4
34− , pipes-safe >=2.3.1 && <2.4
35− , mtl ^>=2.2.2 || ^>=2.3.1
36− , monad-control >=1.0.2.3 && <1.1
37− , servant >=0.15 && <0.20
38− hs-source-dirs: src
39− default-language: Haskell2010
40− ghc-options: -Wall
41−
42−test-suite example
43− type: exitcode-stdio-1.0
44− main-is: Main.hs
45− hs-source-dirs:
46− example
47− ghc-options: -Wall -rtsopts -threaded
48− build-depends:
49− base
50− , base-compat
51− , bytestring
52− , http-media
53− , servant
54− , pipes
55− , pipes-safe
56− , servant-pipes
57− , pipes-bytestring >=2.1.6 && <2.2
58− , servant-server >=0.15 && <0.20
59− , servant-client >=0.15 && <0.20
60− , wai >=3.2.1.2 && <3.3
61− , warp >=3.2.25 && <3.4
62− , http-client
63− default-language: Haskell2010
servant-pipes/src/Servant/Pipes.hsdeleted−75
@@ -1,75 +0,0 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE FlexibleInstances #-}
3−{-# LANGUAGE GADTs #-}
4−{-# LANGUAGE MultiParamTypeClasses #-}
5−{-# LANGUAGE RankNTypes #-}
6−{-# LANGUAGE ScopedTypeVariables #-}
7−{-# LANGUAGE UndecidableInstances #-}
8−{-# OPTIONS_GHC -Wno-orphans #-}
9−-- | This module exports 'ToSourceIO' and 'FromSourceIO' for 'Proxy' and 'SafeT' instances.
10−module Servant.Pipes (
11− PipesToSourceIO (..),
12− ) where
13−
14−import Control.Monad.IO.Class
15− (MonadIO (..))
16−import Control.Monad.Trans.Control
17− (liftBaseWith)
18−import Pipes
19− (ListT (..))
20−import Pipes.Internal
21− (Proxy (..), X, closed)
22−import Pipes.Safe
23− (SafeT, runSafeT)
24−import Servant.API.Stream
25−import qualified Servant.Types.SourceT as S
26−
27−-- | Helper class to implement @'ToSourceIO' 'Proxy'@ instance
28−-- for various monads.
29−class PipesToSourceIO m where
30− pipesToSourceIO :: Proxy X () () b m () -> SourceIO b
31−
32−instance PipesToSourceIO IO where
33− pipesToSourceIO ma = S.SourceT ($ go ma) where
34− go :: Proxy X () () b IO () -> S.StepT IO b
35− go (Pure ()) = S.Stop
36− go (M p) = S.Effect (fmap go p)
37− go (Request v _) = closed v
38− go (Respond b n) = S.Yield b (go (n ()))
39−
40−instance m ~ IO => PipesToSourceIO (SafeT m) where
41− pipesToSourceIO ma =
42− S.SourceT $ \k ->
43− runSafeT $ liftBaseWith $ \runSafe ->
44− k (go runSafe ma)
45− where
46− go :: (forall x. SafeT m x -> m x)
47− -> Proxy X () () b (SafeT m) ()
48− -> S.StepT IO b
49− go _ (Pure ()) = S.Stop
50− go runSafe (M p) = S.Effect $ runSafe $ fmap (go runSafe) p
51− go _ (Request v _) = closed v
52− go runSafe (Respond b n) = S.Yield b (go runSafe (n ()))
53−
54−instance (PipesToSourceIO m, a' ~ X, a ~ (), b' ~ (), r ~ ())
55− => ToSourceIO b (Proxy a' a b' b m r)
56− where
57− toSourceIO = pipesToSourceIO
58−
59−instance PipesToSourceIO m => ToSourceIO a (ListT m a) where
60− toSourceIO = pipesToSourceIO . enumerate
61−
62−instance (MonadIO m, a' ~ X, a ~ (), b' ~ (), r ~ ())
63− => FromSourceIO b (Proxy a' a b' b m r)
64− where
65− fromSourceIO src = M $ liftIO $ S.unSourceT src (return . go) where
66− go :: S.StepT IO b -> Proxy X () () b m ()
67− go S.Stop = Pure ()
68− go (S.Error err) = M (liftIO (fail err))
69− go (S.Skip s) = go s -- drives
70− go (S.Effect ms) = M (liftIO (fmap go ms))
71− go (S.Yield x s) = Respond x (const (go s))
72− {-# SPECIALIZE INLINE fromSourceIO :: SourceIO x -> Proxy X () () x IO () #-}
73−
74−instance MonadIO m => FromSourceIO a (ListT m a) where
75− fromSourceIO = Select . fromSourceIO
servant-server/CHANGELOG.md−193
@@ -1,199 +1,6 @@
11[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-server/CHANGELOG.md)
22[Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)
33
4−Package versions follow the [Package Versioning Policy](https://pvp.haskell.org/): in A.B.C, bumps to either A or B represent major versions.
5−
6−0.19.2
7−------
8−
9−Compatibility with GHC 9.4, see [PR #1592](https://github.com/haskell-servant/servant/pull/1592).
10−
11−0.19.1
12−------
13−
14−- Add `MonadFail` instance for `Handler` wrt [#1545](https://github.com/haskell-servant/servant/issues/1545)
15−- Support GHC 9.2 [#1525](https://github.com/haskell-servant/servant/issues/1525)
16−- Add capture hints in `Router` type for debug and display purposes [PR #1556] (https://github.com/haskell-servant/servant/pull/1556)
17−
18−0.19
19−----
20−
21−### Significant changes
22−
23−- Drop support for GHC < 8.6.
24−- Support GHC 9.0 (GHC 9.2 should work as well, but isn't fully tested yet).
25−- Support Aeson 2 ([#1475](https://github.com/haskell-servant/servant/pull/1475)),
26− which fixes a [DOS vulnerability](https://github.com/haskell/aeson/issues/864)
27− related to hash collisions.
28−- Add `NamedRoutes` combinator, making support for records first-class in Servant
29− ([#1388](https://github.com/haskell-servant/servant/pull/1388)).
30−- Add custom type errors for partially applied combinators
31− ([#1289](https://github.com/haskell-servant/servant/pull/1289),
32− [#1486](https://github.com/haskell-servant/servant/pull/1486)).
33−
34−0.18.3
35−------
36−
37−### Significant changes
38−
39−- Add response header support to UVerb (#1420)
40−
41−### Other changes
42−
43−- Support GHC-9.0.1.
44−- Bump `bytestring`, `hspec` and `base64-bytestring` dependencies.
45−
46−0.18.2
47−------
48−
49−### Significant changes
50−
51−- Support `Fragment` combinator.
52−
53−0.18.1
54−------
55−
56−### Significant changes
57−
58−- Union verbs
59−
60−### Other changes
61−
62−- Bump "tested-with" ghc versions
63−- Allow newer dependencies
64−
65−0.18
66−----
67−
68−### Significant changes
69−
70−- Support for ghc8.8 (#1318, #1326, #1327)
71−
72−- Configurable error messages for automatic errors thrown by servant,
73− like "no route" or "could not parse json body" (#1312, #1326, #1327)
74−
75−
76−0.17
77−----
78−
79−### Significant changes
80−
81−- Add NoContentVerb [#1028](https://github.com/haskell-servant/servant/issues/1028) [#1219](https://github.com/haskell-servant/servant/pull/1219) [#1228](https://github.com/haskell-servant/servant/pull/1228)
82−
83− The `NoContent` API endpoints should now use `NoContentVerb` combinator.
84− The API type changes are usually of the kind
85−
86− ```diff
87− - :<|> PostNoContent '[JSON] NoContent
88− + :<|> PostNoContent
89− ```
90−
91− i.e. one doesn't need to specify the content-type anymore. There is no content.
92−
93−- `Capture` can be `Lenient` [#1155](https://github.com/haskell-servant/servant/issues/1155) [#1156](https://github.com/haskell-servant/servant/pull/1156)
94−
95− You can specify a lenient capture as
96−
97− ```haskell
98− :<|> "capture-lenient" :> Capture' '[Lenient] "foo" Int :> GET
99− ```
100−
101− which will make the capture always succeed. Handlers will be of the
102− type `Either String CapturedType`, where `Left err` represents
103− the possible parse failure.
104−
105−- *servant-server* use queryString to parse QueryParam, QueryParams and QueryFlag [#1249](https://github.com/haskell-servant/servant/pull/1249) [#1262](https://github.com/haskell-servant/servant/pull/1262)
106−
107− Some APIs need query parameters rewriting, e.g. in order to support
108− for multiple casing (camel, snake, etc) or something to that effect.
109−
110− This could be easily achieved by using WAI Middleware and modifying
111− request's `Query`. But QueryParam, QueryParams and QueryFlag use
112− `rawQueryString`. By using `queryString` rather then `rawQueryString`
113− we can enable such rewritings.
114−
115−- *servant* *servant-server* Make packages `build-type: Simple` [#1263](https://github.com/haskell-servant/servant/pull/1263)
116−
117− We used `build-type: Custom`, but it's problematic e.g.
118− for cross-compiling. The benefit is small, as the doctests
119− can be run other ways too (though not so conveniently).
120−
121−0.16.2
122−------
123−
124−* `singleton-bool-0.1.5` (`SBool` is re-exported)
125− - Add `discreteBool :: Dec (a :~: b)` (GHC-7.8+)
126− - Add `Show`, `Eq`, `Ord` `SBool b` instances.
127−* dependencies update
128−
129−0.16.1
130−------
131−
132−* Use `http-api-data-0.4.1` (a part of its API is re-exported)
133− [#1181](https://github.com/haskell-servant/servant/pull/1181)
134−
135−0.16
136−----
137−
138−- Rename `ServantError` to `ClientError`, `ServantErr` to `ServerError`
139− [#1131](https://github.com/haskell-servant/servant/pull/1131)
140−- *servant-server* Reorder HTTP failure code priorities
141− [#1103](https://github.com/haskell-servant/servant/pull/1103)
142−- *servant-server* Re-organise internal modules
143− [#1139](https://github.com/haskell-servant/servant/pull/1139)
144−- Allow `network-3.0`
145− [#1107](https://github.com/haskell-servant/servant/pull/1107)
146−
147−0.15
148−----
149−
150−- Streaming refactoring.
151− [#991](https://github.com/haskell-servant/servant/pull/991)
152− [#1076](https://github.com/haskell-servant/servant/pull/1076)
153− [#1077](https://github.com/haskell-servant/servant/pull/1077)
154−
155− The streaming functionality (`Servant.API.Stream`) is refactored to use
156− `servant`'s own `SourceIO` type (see `Servant.Types.SourceT` documentation),
157− which replaces both `StreamGenerator` and `ResultStream` types.
158−
159− New conversion type-classes are `ToSourceIO` and `FromSourceIO`
160− (replacing `ToStreamGenerator` and `BuildFromStream`).
161− There are instances for *conduit*, *pipes* and *machines* in new packages:
162− [servant-conduit](https://hackage.haskell.org/package/servant-conduit)
163− [servant-pipes](https://hackage.haskell.org/package/servant-pipes) and
164− [servant-machines](https://hackage.haskell.org/package/servant-machines)
165− respectively.
166−
167− Writing new framing strategies is simpler. Check existing strategies for examples.
168−
169− This change shouldn't affect you, if you don't use streaming endpoints.
170−
171−- Drop support for GHC older than 8.0
172− [#1008](https://github.com/haskell-servant/servant/pull/1008)
173− [#1009](https://github.com/haskell-servant/servant/pull/1009)
174−
175−- *servant* NewlineFraming encodes newline after each element (i.e last)
176− [#1079](https://github.com/haskell-servant/servant/pull/1079)
177− [#1011](https://github.com/haskell-servant/servant/issues/1011)
178−
179−- *servant* Add `lookupResponseHeader :: ... => Headers headers r -> ResponseHeader h a`
180− [#1064](https://github.com/haskell-servant/servant/pull/1064)
181−
182−- *servant-server* Add `MonadMask Handler`
183− [#1068](https://github.com/haskell-servant/servant/pull/1068)
184−
185−- *servant* Export `GetHeaders'`
186− [#1052](https://github.com/haskell-servant/servant/pull/1052)
187−
188−- *servant* Add `Bitraversable` and other `Bi-` instances for `:<|>`
189− [#1032](https://github.com/haskell-servant/servant/pull/1032)
190−
191−- *servant* Add `PutCreated` method type alias
192− [#1024](https://github.com/haskell-servant/servant/pull/1024)
193−
194−- *servant* Add `ToSourceIO (NonEmpty a)` instance
195− [#988](https://github.com/haskell-servant/servant/pull/988)
196−
19740.14.1
1985------
1996
servant-server/LICENSE+1−1
@@ -1,4 +1,4 @@
1−Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, 2016-2018 Servant Contributors
1+Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, Servant Contributors
22
33All rights reserved.
44
servant-server/README.md+1−1
@@ -6,4 +6,4 @@ This library lets you *implement* an HTTP server with handlers for each endpoint
66
77## Getting started
88
9−We've written a [tutorial](http://docs.servant.dev/en/stable/tutorial/index.html) guide that introduces the core types and features of servant. After this article, you should be able to write your first servant webservices, learning the rest from the haddocks' examples.
9+We've written a [tutorial](http://haskell-servant.readthedocs.org/en/stable/tutorial/index.html) guide that introduces the core types and features of servant. After this article, you should be able to write your first servant webservices, learning the rest from the haddocks' examples.
servant-server/Setup.hs+32−1
@@ -1,2 +1,33 @@
1−import Distribution.Simple
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 ()
231main = defaultMain
32+
33+#endif
servant-server/example/README.md+1−1
@@ -1,2 +1,2 @@
11- `greet.hs` shows how to write a simple webservice, run it, query it with automatically-derived haskell functions and print the (generated) markdown documentation for the API.
2−- `greet.md` contains the aforementioned generated documentation.
2+- `greet.md` contains the aforementionned generated documentation.
servant-server/example/greet.hs+3−19
@@ -1,15 +1,12 @@
11{-# LANGUAGE DataKinds #-}
22{-# LANGUAGE DeriveGeneric #-}
3−{-# LANGUAGE RecordWildCards #-}
43{-# LANGUAGE OverloadedStrings #-}
54{-# LANGUAGE PolyKinds #-}
65{-# LANGUAGE TypeFamilies #-}
76{-# LANGUAGE TypeOperators #-}
87
9−import Prelude ()
10−import Prelude.Compat
11−
128import Data.Aeson
9+import Data.Monoid
1310import Data.Proxy
1411import Data.Text
1512import GHC.Generics
@@ -17,7 +14,6 @@ import Network.Wai
1714import Network.Wai.Handler.Warp
1815
1916import Servant
20−import Servant.Server.Generic ()
2117
2218-- * Example
2319
@@ -40,14 +36,6 @@ type TestApi =
4036 -- DELETE /greet/:greetid
4137 :<|> "greet" :> Capture "greetid" Text :> Delete '[JSON] NoContent
4238
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−
5139testApi :: Proxy TestApi
5240testApi = Proxy
5341
@@ -58,13 +46,9 @@ testApi = Proxy
5846--
5947-- Each handler runs in the 'Handler' monad.
6048server :: Server TestApi
61−server = helloH :<|> postGreetH :<|> deleteGreetH :<|> otherRoutes
62− where otherRoutes = OtherRoutes {..}
63−
64− bye name = pure $ "Bye, " <> name <> " !"
65− version = pure 42
49+server = helloH :<|> postGreetH :<|> deleteGreetH
6650
67− helloH name Nothing = helloH name (Just False)
51+ where helloH name Nothing = helloH name (Just False)
6852 helloH name (Just False) = return . Greet $ "Hello, " <> name
6953 helloH name (Just True) = return . Greet . toUpper $ "Hello, " <> name
7054
servant-server/servant-server.cabal+71−55
@@ -1,30 +1,31 @@
1−cabal-version: 2.2
21name: servant-server
3−version: 0.19.2
4−
2+version: 0.14.1
53synopsis: A family of combinators for defining webservices APIs and serving them
6−category: Servant, Web
74description:
85 A family of combinators for defining webservices APIs and serving them
96 .
10− You can learn about the basics in the <http://docs.servant.dev/en/stable/tutorial/index.html tutorial>.
7+ You can learn about the basics in the <http://haskell-servant.readthedocs.org/en/stable/tutorial/index.html tutorial>.
118 .
129 <https://github.com/haskell-servant/servant/blob/master/servant-server/example/greet.hs Here>
1310 is a runnable example, with comments, that defines a dummy API and implements
1411 a webserver that serves this API, using this package.
1512 .
1613 <https://github.com/haskell-servant/servant/blob/master/servant-server/CHANGELOG.md CHANGELOG>
17−
18−homepage: http://docs.servant.dev/
19−bug-reports: http://github.com/haskell-servant/servant/issues
20−license: BSD-3-Clause
14+homepage: http://haskell-servant.readthedocs.org/
15+Bug-reports: http://github.com/haskell-servant/servant/issues
16+license: BSD3
2117license-file: LICENSE
2218author: Servant Contributors
2319maintainer: haskell-servant-maintainers@googlegroups.com
24−copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors
25−build-type: Simple
26−tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.4 || ==9.4.3
27−
20+copyright: 2014-2016 Zalora South East Asia Pte Ltd, Servant Contributors
21+category: Servant, Web
22+build-type: Custom
23+cabal-version: >=1.10
24+tested-with:
25+ GHC==8.0.2
26+ GHC==8.2.2
27+ GHC==8.4.4
28+ GHC==8.6.1
2829extra-source-files:
2930 CHANGELOG.md
3031 README.md
@@ -33,6 +34,12 @@ source-repository head
3334 type: git
3435 location: http://github.com/haskell-servant/servant.git
3536
37+custom-setup
38+ setup-depends:
39+ base >= 4 && <5,
40+ Cabal,
41+ cabal-doctest >= 1.0.6 && <1.1
42+
3643library
3744 exposed-modules:
3845 Servant
@@ -42,16 +49,11 @@ library
4249 Servant.Server.Internal
4350 Servant.Server.Internal.BasicAuth
4451 Servant.Server.Internal.Context
45− Servant.Server.Internal.Delayed
46− Servant.Server.Internal.DelayedIO
47− Servant.Server.Internal.ErrorFormatter
4852 Servant.Server.Internal.Handler
49− Servant.Server.Internal.RouteResult
5053 Servant.Server.Internal.Router
5154 Servant.Server.Internal.RoutingApplication
52− Servant.Server.Internal.ServerError
55+ Servant.Server.Internal.ServantErr
5356 Servant.Server.StaticFiles
54− Servant.Server.UVerb
5557
5658 -- deprecated
5759 exposed-modules:
@@ -59,45 +61,48 @@ library
5961
6062 -- Bundled with GHC: Lower bound to not force re-installs
6163 -- text and mtl are bundled starting with GHC-8.4
64+ --
65+ -- note: mtl lower bound is so low because of GHC-7.8
6266 build-depends:
63− base >= 4.9 && < 4.18
64− , bytestring >= 0.10.8.1 && < 0.12
65− , constraints >= 0.2 && < 0.14
66− , containers >= 0.5.7.1 && < 0.7
67− , mtl ^>= 2.2.2 || ^>= 2.3.1
68− , text >= 1.2.3.0 && < 2.1
69− , transformers >= 0.5.2.0 && < 0.7
70− , filepath >= 1.4.1.1 && < 1.5
67+ base >= 4.7 && < 4.13
68+ , bytestring >= 0.10.4.0 && < 0.11
69+ , containers >= 0.5.5.1 && < 0.7
70+ , mtl >= 2.1 && < 2.3
71+ , text >= 1.2.3.0 && < 1.3
72+ , transformers >= 0.3.0.0 && < 0.6
73+ , filepath >= 1.3.0.2 && < 1.5
74+
75+ if !impl(ghc >= 8.0)
76+ build-depends:
77+ semigroups >= 0.18.4 && < 0.19
7178
7279 -- Servant dependencies
73− -- strict dependency as we re-export 'servant' things.
7480 build-depends:
75− servant >= 0.19 && < 0.20
76− , http-api-data >= 0.4.1 && < 0.5.1
81+ servant >= 0.14.1 && <0.15
7782
7883 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.
7984 -- Here can be exceptions if we really need features from the newer versions.
8085 build-depends:
81− base-compat >= 0.10.5 && < 0.13
82− , base64-bytestring >= 1.0.0.1 && < 1.3
86+ base-compat >= 0.10.1 && < 0.11
87+ , base64-bytestring >= 1.0.0.1 && < 1.1
8388 , exceptions >= 0.10.0 && < 0.11
84− , http-media >= 0.7.1.3 && < 0.9
85− , http-types >= 0.12.2 && < 0.13
86− , network-uri >= 2.6.1.0 && < 2.8
89+ , http-api-data >= 0.3.8.1 && < 0.4
90+ , http-media >= 0.7.1.2 && < 0.8
91+ , http-types >= 0.12.1 && < 0.13
92+ , network-uri >= 2.6.1.0 && < 2.7
8793 , monad-control >= 1.0.2.3 && < 1.1
88− , network >= 2.8 && < 3.2
89− , sop-core >= 0.4.0.0 && < 0.6
94+ , network >= 2.6.3.5 && < 2.9
9095 , string-conversions >= 0.4.0.1 && < 0.5
91− , resourcet >= 1.2.2 && < 1.4
92− , tagged >= 0.8.6 && < 0.9
93− , transformers-base >= 0.4.5.2 && < 0.5
94− , wai >= 3.2.2.1 && < 3.3
95− , wai-app-static >= 3.1.6.2 && < 3.2
96+ , resourcet >= 1.1.11 && < 1.3
97+ , tagged >= 0.8.5 && < 0.9
98+ , transformers-base >= 0.4.4 && < 0.5
99+ , transformers-compat >= 0.6.2 && < 0.7
100+ , wai >= 3.2.1.1 && < 3.3
101+ , wai-app-static >= 3.1.6.1 && < 3.2
96102 , word8 >= 0.1.3 && < 0.2
97103
98104 hs-source-dirs: src
99105 default-language: Haskell2010
100−
101106 ghc-options: -Wall -Wno-redundant-constraints
102107
103108executable greet
@@ -107,15 +112,14 @@ executable greet
107112 default-language: Haskell2010
108113 build-depends:
109114 base
110− , base-compat
111115 , servant
112116 , servant-server
113117 , wai
114118 , text
115119
116120 build-depends:
117− aeson >= 1.4.1.0 && < 3
118− , warp >= 3.2.25 && < 3.4
121+ aeson >= 1.3.1.1 && < 1.5
122+ , warp >= 3.2.13 && < 3.3
119123
120124test-suite spec
121125 type: exitcode-stdio-1.0
@@ -148,23 +152,35 @@ test-suite spec
148152 , safe
149153 , servant
150154 , servant-server
151− , sop-core
152155 , string-conversions
153156 , text
154157 , transformers
155158 , transformers-compat
156159 , wai
157160
158− -- Additional dependencies
161+ -- Additonal dependencies
159162 build-depends:
160− aeson >= 1.4.1.0 && < 3
161− , directory >= 1.3.0.0 && < 1.4
162− , hspec >= 2.6.0 && < 2.10
163− , hspec-wai >= 0.10.1 && < 0.12
164− , QuickCheck >= 2.12.6.1 && < 2.15
163+ aeson >= 1.3.1.1 && < 1.5
164+ , directory >= 1.2.1.0 && < 1.4
165+ , hspec >= 2.5.1 && < 2.6
166+ , hspec-wai >= 0.9.0 && < 0.10
167+ , QuickCheck >= 2.12.6.1 && < 2.13
165168 , should-not-typecheck >= 2.1.0 && < 2.2
166169 , temporary >= 1.3 && < 1.4
167− , wai-extra >= 3.0.24.3 && < 3.2
170+ , wai-extra >= 3.0.21.0 && < 3.1
168171
169172 build-tool-depends:
170− hspec-discover:hspec-discover >= 2.6.0 && <2.10
173+ hspec-discover:hspec-discover >= 2.5.1 && <2.6
174+
175+test-suite doctests
176+ build-depends:
177+ base
178+ , servant-server
179+ , doctest >= 0.16.0 && <0.17
180+ type: exitcode-stdio-1.0
181+ main-is: test/doctests.hs
182+ buildable: True
183+ default-language: Haskell2010
184+ ghc-options: -Wall -threaded
185+ if impl(ghc >= 8.2)
186+ x-doctest-options: -fdiagnostics-color=never
servant-server/src/Servant/Server.hs+12−65
@@ -1,10 +1,8 @@
1−{-# LANGUAGE ConstraintKinds #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE FlexibleContexts #-}
4−{-# LANGUAGE RankNTypes #-}
5−{-# LANGUAGE ScopedTypeVariables #-}
6−{-# LANGUAGE TypeFamilies #-}
7−{-# LANGUAGE TypeOperators #-}
1+{-# LANGUAGE ConstraintKinds #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE RankNTypes #-}
5+{-# LANGUAGE TypeFamilies #-}
86
97-- | This module lets you implement 'Server's for defined APIs. You'll
108-- most likely just need 'serve'.
@@ -12,8 +10,6 @@ module Servant.Server
1210 ( -- * Run a wai application from an API
1311 serve
1412 , serveWithContext
15− , serveWithContextT
16− , ServerContext
1713
1814 , -- * Construct a wai Application from an API
1915 toApplication
@@ -39,8 +35,6 @@ module Servant.Server
3935 -- * Context
4036 , Context(..)
4137 , HasContextEntry(getContextEntry)
42− , type (.++)
43− , (.++)
4438 -- ** NamedContext
4539 , NamedContext(..)
4640 , descendIntoNamedContext
@@ -55,7 +49,7 @@ module Servant.Server
5549 -- , mkAuthHandler
5650
5751 -- * Default error type
58− , ServerError(..)
52+ , ServantErr(..)
5953 -- ** 3XX
6054 , err300
6155 , err301
@@ -92,28 +86,9 @@ module Servant.Server
9286 , err504
9387 , err505
9488
95− -- * Formatting of errors from combinators
96− --
97− -- | You can configure how Servant will render errors that occur while parsing the request.
98−
99− , ErrorFormatter
100− , NotFoundErrorFormatter
101− , ErrorFormatters
102−
103− , bodyParserErrorFormatter
104− , urlParseErrorFormatter
105− , headerParseErrorFormatter
106− , notFoundErrorFormatter
107−
108− , DefaultErrorFormatters
109− , defaultErrorFormatters
110−
111− , getAcceptHeader
112−
11389 -- * Re-exports
11490 , Application
11591 , Tagged (..)
116− , module Servant.Server.UVerb
11792
11893 ) where
11994
@@ -126,26 +101,16 @@ import Data.Text
126101import Network.Wai
127102 (Application)
128103import Servant.Server.Internal
129−import Servant.Server.UVerb
130104
131105
132106-- * Implementing Servers
133107
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−
143108-- | 'serve' allows you to implement an API and produce a wai 'Application'.
144109--
145110-- Example:
146111--
147112-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books
148−-- > :<|> "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book -- POST /books
113+-- > :<|> "books" :> ReqBody Book :> Post '[JSON] Book -- POST /books
149114-- >
150115-- > server :: Server MyApi
151116-- > server = listAllBooks :<|> postBook
@@ -164,27 +129,10 @@ type ServerContext context =
164129serve :: (HasServer api '[]) => Proxy api -> Server api -> Application
165130serve p = serveWithContext p EmptyContext
166131
167−-- | Like 'serve', but allows you to pass custom context.
168−--
169−-- 'defaultErrorFormatters' will always be appended to the end of the passed context,
170−-- but if you pass your own formatter, it will override the default one.
171−serveWithContext :: ( HasServer api context
172− , ServerContext context
173− )
132+serveWithContext :: (HasServer api context)
174133 => Proxy api -> Context context -> Server api -> Application
175−serveWithContext p context = serveWithContextT p context id
176−
177−-- | A general 'serve' function that allows you to pass a custom context and hoisting function to
178−-- apply on all routes.
179−serveWithContextT ::
180− forall api context m.
181− (HasServer api context, ServerContext context) =>
182− Proxy api -> Context context -> (forall x. m x -> Handler x) -> ServerT api m -> Application
183−serveWithContextT p context toHandler server =
184− toApplication (runRouter format404 (route p context (emptyDelayed router)))
185− where
186− router = Route $ hoistServerWithContext p (Proxy :: Proxy context) toHandler server
187− format404 = notFoundErrorFormatter . getContextEntry . mkContextWithErrorFormatter $ context
134+serveWithContext p context server =
135+ toApplication (runRouter (route p context (emptyDelayed (Route server))))
188136
189137-- | Hoist server implementation.
190138--
@@ -235,7 +183,7 @@ hoistServer p = hoistServerWithContext p (Proxy :: Proxy '[])
235183-- > │ └─ e/
236184-- > │ └─•
237185-- > ├─ b/
238−-- > │ └─ <x::Int>/
186+-- > │ └─ <capture>/
239187-- > │ ├─•
240188-- > │ ┆
241189-- > │ └─•
@@ -252,8 +200,7 @@ hoistServer p = hoistServerWithContext p (Proxy :: Proxy '[])
252200--
253201-- [@─•@] Leaves reflect endpoints.
254202--
255−-- [@\<x::Int\>/@] This is a delayed capture of a single
256−-- path component named @x@, of expected type @Int@.
203+-- [@\<capture\>/@] This is a delayed capture of a path component.
257204--
258205-- [@\<raw\>@] This is a part of the API we do not know anything about.
259206--
servant-server/src/Servant/Server/Experimental/Auth.hs+6−5
@@ -1,6 +1,5 @@
11{-# OPTIONS_GHC -fno-warn-orphans #-}
22{-# LANGUAGE DeriveDataTypeable #-}
3−{-# LANGUAGE DeriveFunctor #-}
43{-# LANGUAGE DeriveGeneric #-}
54{-# LANGUAGE FlexibleContexts #-}
65{-# LANGUAGE FlexibleInstances #-}
@@ -28,9 +27,11 @@ import Servant
2827 ((:>))
2928import Servant.API.Experimental.Auth
3029import Servant.Server.Internal
31− (DelayedIO, Handler, HasContextEntry, HasServer (..),
32− addAuthCheck, delayedFailFatal, getContextEntry, runHandler,
33− withRequest)
30+ (HasContextEntry, HasServer (..), getContextEntry)
31+import Servant.Server.Internal.Handler
32+ (Handler, runHandler)
33+import Servant.Server.Internal.RoutingApplication
34+ (DelayedIO, addAuthCheck, delayedFailFatal, withRequest)
3435
3536-- * General Auth
3637
@@ -45,7 +46,7 @@ type family AuthServerData a :: *
4546-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE
4647newtype AuthHandler r usr = AuthHandler
4748 { unAuthHandler :: r -> Handler usr }
48− deriving (Functor, Generic, Typeable)
49+ deriving (Generic, Typeable)
4950
5051-- | NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE
5152mkAuthHandler :: (r -> Handler usr) -> AuthHandler r usr
servant-server/src/Servant/Server/Generic.hs+19−59
@@ -1,29 +1,34 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE FlexibleContexts #-}
3−{-# LANGUAGE RankNTypes #-}
4−{-# LANGUAGE ScopedTypeVariables #-}
5−{-# LANGUAGE TypeFamilies #-}
6−{-# LANGUAGE TypeOperators #-}
7−
1+{-# LANGUAGE ConstraintKinds #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE KindSignatures #-}
5+{-# LANGUAGE ScopedTypeVariables #-}
6+{-# LANGUAGE TypeFamilies #-}
7+{-# LANGUAGE TypeOperators #-}
8+{-# LANGUAGE UndecidableInstances #-}
89-- | @since 0.14.1
910module Servant.Server.Generic (
1011 AsServerT,
1112 AsServer,
1213 genericServe,
13− genericServeT,
14− genericServeTWithContext,
1514 genericServer,
16− genericServerT
15+ genericServerT,
1716 ) where
1817
1918import Data.Proxy
2019 (Proxy (..))
2120
22−import Servant.Server
2321import Servant.API.Generic
24−import Servant.Server.Internal
22+import Servant.Server
23+
24+-- | A type that specifies that an API record contains a server implementation.
25+data AsServerT (m :: * -> *)
26+instance GenericMode (AsServerT m) where
27+ type AsServerT m :- api = ServerT api m
2528
26−-- | Transform a record of routes into a WAI 'Application'.
29+type AsServer = AsServerT Handler
30+
31+-- | Transform record of routes into a WAI 'Application'.
2732genericServe
2833 :: forall routes.
2934 ( HasServer (ToServantApi routes) '[]
@@ -33,60 +38,15 @@ genericServe
3338 => routes AsServer -> Application
3439genericServe = serve (Proxy :: Proxy (ToServantApi routes)) . genericServer
3540
36−-- | Transform a record of routes with custom monad into a WAI 'Application',
37−-- by providing a transformation to bring each handler back in the 'Handler'
38−-- monad.
39−genericServeT
40− :: forall (routes :: * -> *) (m :: * -> *).
41− ( GenericServant routes (AsServerT m)
42− , GenericServant routes AsApi
43− , HasServer (ToServantApi routes) '[]
44− , ServerT (ToServantApi routes) m ~ ToServant routes (AsServerT m)
45− )
46− => (forall a. m a -> Handler a) -- ^ 'hoistServer' argument to come back to 'Handler'
47− -> routes (AsServerT m) -- ^ your record full of request handlers
48− -> Application
49−genericServeT f server = serve p $ hoistServer p f (genericServerT server)
50− where
51− p = genericApi (Proxy :: Proxy routes)
52−
53−-- | Transform a record of routes with custom monad into a WAI 'Application',
54−-- while using the given 'Context' to serve the application (contexts are typically
55−-- used by auth-related combinators in servant, e.g to hold auth checks) and the given
56−-- transformation to map all the handlers back to the 'Handler' monad.
57−genericServeTWithContext
58− :: forall (routes :: * -> *) (m :: * -> *) (ctx :: [*]).
59− ( GenericServant routes (AsServerT m)
60− , GenericServant routes AsApi
61− , HasServer (ToServantApi routes) ctx
62− , HasContextEntry (ctx .++ DefaultErrorFormatters) ErrorFormatters
63− , ServerT (ToServantApi routes) m ~ ToServant routes (AsServerT m)
64− )
65− => (forall a. m a -> Handler a) -- ^ 'hoistServer' argument to come back to 'Handler'
66− -> routes (AsServerT m) -- ^ your record full of request handlers
67− -> Context ctx -- ^ the 'Context' to serve the application with
68− -> Application
69−genericServeTWithContext f server ctx =
70− serveWithContext p ctx $
71− hoistServerWithContext p pctx f (genericServerT server)
72− where
73− p = genericApi (Proxy :: Proxy routes)
74− pctx = Proxy :: Proxy ctx
75−
76−-- | Transform a record of endpoints into a 'Server'.
41+-- | Transform record of endpoints into a 'Server'.
7742genericServer
7843 :: GenericServant routes AsServer
7944 => routes AsServer
8045 -> ToServant routes AsServer
8146genericServer = toServant
8247
83−-- | Transform a record of endpoints into a @'ServerT' m@.
84−--
85−-- You can see an example usage of this function
86−-- <https://docs.servant.dev/en/stable/cookbook/generic/Generic.html#using-generics-together-with-a-custom-monad in the Servant Cookbook>.
8748genericServerT
8849 :: GenericServant routes (AsServerT m)
8950 => routes (AsServerT m)
9051 -> ToServant routes (AsServerT m)
9152genericServerT = toServant
92−
servant-server/src/Servant/Server/Internal.hs+143−376
@@ -1,54 +1,49 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE ConstraintKinds #-}
31{-# LANGUAGE CPP #-}
2+{-# LANGUAGE ConstraintKinds #-}
43{-# LANGUAGE DataKinds #-}
54{-# LANGUAGE DeriveDataTypeable #-}
65{-# LANGUAGE FlexibleContexts #-}
76{-# LANGUAGE FlexibleInstances #-}
8−{-# LANGUAGE InstanceSigs #-}
9−{-# LANGUAGE LambdaCase #-}
107{-# LANGUAGE MultiParamTypeClasses #-}
118{-# LANGUAGE OverloadedStrings #-}
129{-# LANGUAGE PolyKinds #-}
13−{-# LANGUAGE QuantifiedConstraints #-}
1410{-# LANGUAGE RankNTypes #-}
1511{-# LANGUAGE ScopedTypeVariables #-}
1612{-# LANGUAGE TupleSections #-}
17−{-# LANGUAGE TypeApplications #-}
1813{-# LANGUAGE TypeFamilies #-}
1914{-# LANGUAGE TypeOperators #-}
2015{-# LANGUAGE UndecidableInstances #-}
2116
17+#if MIN_VERSION_base(4,9,0) && __GLASGOW_HASKELL__ >= 802
18+#define HAS_TYPE_ERROR
19+#endif
20+
2221module Servant.Server.Internal
2322 ( module Servant.Server.Internal
2423 , module Servant.Server.Internal.BasicAuth
2524 , module Servant.Server.Internal.Context
26− , module Servant.Server.Internal.Delayed
27− , module Servant.Server.Internal.DelayedIO
28− , module Servant.Server.Internal.ErrorFormatter
2925 , module Servant.Server.Internal.Handler
3026 , module Servant.Server.Internal.Router
31− , module Servant.Server.Internal.RouteResult
3227 , module Servant.Server.Internal.RoutingApplication
33− , module Servant.Server.Internal.ServerError
28+ , module Servant.Server.Internal.ServantErr
3429 ) where
3530
3631import Control.Monad
3732 (join, when)
3833import Control.Monad.Trans
39− (liftIO, lift)
34+ (liftIO)
4035import Control.Monad.Trans.Resource
41− (runResourceT, ReleaseKey)
42−import Data.Acquire
36+ (runResourceT)
4337import qualified Data.ByteString as B
4438import qualified Data.ByteString.Builder as BB
4539import qualified Data.ByteString.Char8 as BC8
4640import qualified Data.ByteString.Lazy as BL
47−import Data.Constraint (Constraint, Dict(..))
4841import Data.Either
4942 (partitionEithers)
5043import Data.Maybe
5144 (fromMaybe, isNothing, mapMaybe, maybeToList)
45+import Data.Semigroup
46+ ((<>))
5247import Data.String
5348 (IsString (..))
5449import Data.String.Conversions
@@ -57,70 +52,53 @@ import Data.Tagged
5752 (Tagged (..), retag, untag)
5853import qualified Data.Text as T
5954import Data.Typeable
60−import GHC.Generics
6155import GHC.TypeLits
62− (KnownNat, KnownSymbol, TypeError, symbolVal)
56+ (KnownNat, KnownSymbol, natVal, symbolVal)
6357import qualified Network.HTTP.Media as NHM
6458import Network.HTTP.Types hiding
6559 (Header, ResponseHeaders)
6660import Network.Socket
6761 (SockAddr)
6862import Network.Wai
69− (Application, Request, Response, ResponseReceived, httpVersion, isSecure, lazyRequestBody,
70− queryString, remoteHost, getRequestBodyChunk, requestHeaders,
71− requestMethod, responseLBS, responseStream, vault)
63+ (Application, Request, httpVersion, isSecure, lazyRequestBody,
64+ rawQueryString, remoteHost, requestHeaders, requestMethod,
65+ responseLBS, responseStream, vault)
7266import Prelude ()
7367import Prelude.Compat
7468import Servant.API
75− ((:<|>) (..), (:>), Accept (..), BasicAuth, Capture',
76− CaptureAll, Description, EmptyAPI, Fragment,
77− FramingRender (..), FramingUnrender (..), FromSourceIO (..),
78− Header', If, IsSecure (..), NoContentVerb, QueryFlag,
79− QueryParam', QueryParams, Raw, RawM, ReflectMethod (reflectMethod),
80− RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO,
81− Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb,
82− WithNamedContext, WithResource, NamedRoutes)
83−import Servant.API.Generic (GenericMode(..), ToServant, ToServantApi, GServantProduct, toServant, fromServant)
69+ ((:<|>) (..), (:>), Accept (..), BasicAuth,
70+ BoundaryStrategy (..), Capture', CaptureAll, Description,
71+ EmptyAPI, FramingRender (..), Header', If, IsSecure (..),
72+ QueryFlag, QueryParam', QueryParams, Raw,
73+ ReflectMethod (reflectMethod), RemoteHost, ReqBody',
74+ SBool (..), SBoolI (..), Stream, StreamGenerator (..),
75+ Summary, ToStreamGenerator (..), Vault, Verb,
76+ WithNamedContext)
8477import Servant.API.ContentTypes
8578 (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),
86− AllMime, MimeRender (..), MimeUnrender (..), NoContent,
87− canHandleAcceptH)
79+ AllMime, MimeRender (..), canHandleAcceptH)
8880import Servant.API.Modifiers
8981 (FoldLenient, FoldRequired, RequestArgument,
9082 unfoldRequestArgument)
9183import Servant.API.ResponseHeaders
9284 (GetHeaders, Headers, getHeaders, getResponse)
93−import Servant.API.Status
94− (statusFromNat)
95−import qualified Servant.Types.SourceT as S
96−import Servant.API.TypeErrors
9785import Web.HttpApiData
98− (FromHttpApiData, parseHeader, parseQueryParam, parseUrlPiece,
99− parseUrlPieces)
100−import Data.Kind
101− (Type)
86+ (FromHttpApiData, parseHeader, parseQueryParam,
87+ parseUrlPieceMaybe, parseUrlPieces)
10288
10389import Servant.Server.Internal.BasicAuth
10490import Servant.Server.Internal.Context
105−import Servant.Server.Internal.Delayed
106−import Servant.Server.Internal.DelayedIO
107−import Servant.Server.Internal.ErrorFormatter
10891import Servant.Server.Internal.Handler
10992import Servant.Server.Internal.Router
110−import Servant.Server.Internal.RouteResult
11193import Servant.Server.Internal.RoutingApplication
112−import Servant.Server.Internal.ServerError
94+import Servant.Server.Internal.ServantErr
11395
96+#ifdef HAS_TYPE_ERROR
11497import GHC.TypeLits
11598 (ErrorMessage (..), TypeError)
116−import Servant.API.TypeLevel
117− (AtLeastOneFragment, FragmentUnique)
99+#endif
118100
119101class HasServer api context where
120− -- | The type of a server for this API, given a monad to run effects in.
121− --
122− -- Note that the result kind is @*@, so it is /not/ a monad transformer, unlike
123− -- what the @T@ in the name might suggest.
124102 type ServerT api (m :: * -> *) :: *
125103
126104 route ::
@@ -182,31 +160,22 @@ instance (HasServer a context, HasServer b context) => HasServer (a :<|> b) cont
182160-- > server = getBook
183161-- > where getBook :: Text -> Handler Book
184162-- > getBook isbn = ...
185−instance (KnownSymbol capture, FromHttpApiData a, Typeable a
186− , HasServer api context, SBoolI (FoldLenient mods)
187− , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
188− )
163+instance (KnownSymbol capture, FromHttpApiData a, HasServer api context)
189164 => HasServer (Capture' mods capture a :> api) context where
190165
191166 type ServerT (Capture' mods capture a :> api) m =
192− If (FoldLenient mods) (Either String a) a -> ServerT api m
167+ a -> ServerT api m
193168
194169 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
195170
196171 route Proxy context d =
197− CaptureRouter [hint] $
172+ CaptureRouter $
198173 route (Proxy :: Proxy api)
199174 context
200− (addCapture d $ \ txt -> withRequest $ \ request ->
201− case ( sbool :: SBool (FoldLenient mods)
202− , parseUrlPiece txt :: Either T.Text a) of
203− (SFalse, Left e) -> delayedFail $ formatError rep request $ cs e
204− (SFalse, Right v) -> return v
205− (STrue, piece) -> return $ (either (Left . cs) Right) piece)
206− where
207− rep = typeRep (Proxy :: Proxy Capture')
208− formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
209− hint = CaptureHint (T.pack $ symbolVal $ Proxy @capture) (typeRep (Proxy :: Proxy a))
175+ (addCapture d $ \ txt -> case parseUrlPieceMaybe txt of
176+ Nothing -> delayedFail err400
177+ Just v -> return v
178+ )
210179
211180-- | If you use 'CaptureAll' in one of the endpoints for your API,
212181-- this automatically requires your server-side handler to be a
@@ -225,10 +194,7 @@ instance (KnownSymbol capture, FromHttpApiData a, Typeable a
225194-- > server = getSourceFile
226195-- > where getSourceFile :: [Text] -> Handler Book
227196-- > getSourceFile pathSegments = ...
228−instance (KnownSymbol capture, FromHttpApiData a, Typeable a
229− , HasServer api context
230− , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
231− )
197+instance (KnownSymbol capture, FromHttpApiData a, HasServer api context)
232198 => HasServer (CaptureAll capture a :> api) context where
233199
234200 type ServerT (CaptureAll capture a :> api) m =
@@ -237,53 +203,13 @@ instance (KnownSymbol capture, FromHttpApiData a, Typeable a
237203 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
238204
239205 route Proxy context d =
240− CaptureAllRouter [hint] $
206+ CaptureAllRouter $
241207 route (Proxy :: Proxy api)
242208 context
243− (addCapture d $ \ txts -> withRequest $ \ request ->
244− case parseUrlPieces txts of
245− Left e -> delayedFail $ formatError rep request $ cs e
246− Right v -> return v
209+ (addCapture d $ \ txts -> case parseUrlPieces txts of
210+ Left _ -> delayedFail err400
211+ Right v -> return v
247212 )
248− where
249− rep = typeRep (Proxy :: Proxy CaptureAll)
250− formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
251− hint = CaptureHint (T.pack $ symbolVal $ Proxy @capture) (typeRep (Proxy :: Proxy [a]))
252−
253−-- | If you use 'WithResource' in one of the endpoints for your API Servant
254−-- will provide the handler for this endpoint an argument of the specified type.
255−-- The lifespan of this resource will be automatically managed by Servant. This
256−-- resource will be created before the handler starts and it will be destoyed
257−-- after it ends. A new resource is created for each request to the endpoint.
258−
259−-- The creation and destruction are done using a 'Data.Acquire.Acquire'
260−-- provided via server 'Context'.
261−--
262−-- Example
263−--
264−-- > type MyApi = WithResource Handle :> "writeToFile" :> Post '[JSON] NoContent
265−-- >
266−-- > server :: Server MyApi
267−-- > server = writeToFile
268−-- > where writeToFile :: (ReleaseKey, Handle) -> Handler NoContent
269−-- > writeToFile (_, h) = hPutStrLn h "message"
270−--
271−-- In addition to the resource, the handler will also receive a 'ReleaseKey'
272−-- which can be used to deallocate the resource before the end of the request
273−-- if desired.
274−
275−instance (HasServer api ctx, HasContextEntry ctx (Acquire a))
276− => HasServer (WithResource a :> api) ctx where
277−
278− type ServerT (WithResource a :> api) m = (ReleaseKey, a) -> ServerT api m
279−
280− hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy @api) pc nt . s
281−
282− route Proxy context d = route (Proxy @api) context (d `addParameterCheck` allocateResource)
283− where
284− allocateResource :: DelayedIO (ReleaseKey, a)
285− allocateResource = DelayedIO $ lift $ allocateAcquire (getContextEntry context)
286−
287213
288214
289215allowedMethodHead :: Method -> Request -> Bool
@@ -304,10 +230,10 @@ methodCheck method request
304230-- body check is no longer an option. However, we now run the accept
305231-- check before the body check and can therefore afford to make it
306232-- recoverable.
307−acceptCheck :: (AllMime list) => Proxy list -> AcceptHeader -> DelayedIO ()
233+acceptCheck :: (AllMime list) => Proxy list -> B.ByteString -> DelayedIO ()
308234acceptCheck proxy accH
309− | canHandleAcceptH proxy accH = return ()
310− | otherwise = delayedFail err406
235+ | canHandleAcceptH proxy (AcceptHeader accH) = return ()
236+ | otherwise = delayedFail err406
311237
312238methodRouter :: (AllCTRender ctypes a)
313239 => (b -> ([(HeaderName, B.ByteString)], a))
@@ -317,28 +243,17 @@ methodRouter :: (AllCTRender ctypes a)
317243methodRouter splitHeaders method proxy status action = leafRouter route'
318244 where
319245 route' env request respond =
320− let accH = getAcceptHeader request
246+ let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
321247 in runAction (action `addMethodCheck` methodCheck method request
322248 `addAcceptCheck` acceptCheck proxy accH
323249 ) env request respond $ \ output -> do
324250 let (headers, b) = splitHeaders output
325− case handleAcceptH proxy accH b of
251+ case handleAcceptH proxy (AcceptHeader accH) b of
326252 Nothing -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does
327253 Just (contentT, body) ->
328254 let bdy = if allowedMethodHead method request then "" else body
329255 in Route $ responseLBS status ((hContentType, cs contentT) : headers) bdy
330256
331−noContentRouter :: Method
332− -> Status
333− -> Delayed env (Handler b)
334− -> Router env
335−noContentRouter method status action = leafRouter route'
336− where
337− route' env request respond =
338− runAction (action `addMethodCheck` methodCheck method request)
339− env request respond $ \ _output ->
340− Route $ responseLBS status [] ""
341−
342257instance {-# OVERLAPPABLE #-}
343258 ( AllCTRender ctypes a, ReflectMethod method, KnownNat status
344259 ) => HasServer (Verb method status ctypes a) context where
@@ -348,7 +263,7 @@ instance {-# OVERLAPPABLE #-}
348263
349264 route Proxy _ = methodRouter ([],) method (Proxy :: Proxy ctypes) status
350265 where method = reflectMethod (Proxy :: Proxy method)
351− status = statusFromNat (Proxy :: Proxy status)
266+ status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
352267
353268instance {-# OVERLAPPING #-}
354269 ( AllCTRender ctypes a, ReflectMethod method, KnownNat status
@@ -360,46 +275,37 @@ instance {-# OVERLAPPING #-}
360275
361276 route Proxy _ = methodRouter (\x -> (getHeaders x, getResponse x)) method (Proxy :: Proxy ctypes) status
362277 where method = reflectMethod (Proxy :: Proxy method)
363− status = statusFromNat (Proxy :: Proxy status)
364−
365−instance (ReflectMethod method) =>
366− HasServer (NoContentVerb method) context where
367−
368− type ServerT (NoContentVerb method) m = m NoContent
369− hoistServerWithContext _ _ nt s = nt s
278+ status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
370279
371− route Proxy _ = noContentRouter method status204
372− where method = reflectMethod (Proxy :: Proxy method)
373280
374281instance {-# OVERLAPPABLE #-}
375− ( MimeRender ctype chunk, ReflectMethod method, KnownNat status,
376− FramingRender framing, ToSourceIO chunk a
377− ) => HasServer (Stream method status framing ctype a) context where
282+ ( MimeRender ctype a, ReflectMethod method, KnownNat status,
283+ FramingRender framing ctype, ToStreamGenerator b a
284+ ) => HasServer (Stream method status framing ctype b) context where
378285
379− type ServerT (Stream method status framing ctype a) m = m a
286+ type ServerT (Stream method status framing ctype b) m = m b
380287 hoistServerWithContext _ _ nt s = nt s
381288
382289 route Proxy _ = streamRouter ([],) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)
383290 where method = reflectMethod (Proxy :: Proxy method)
384− status = statusFromNat (Proxy :: Proxy status)
385−
291+ status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
386292
387293instance {-# OVERLAPPING #-}
388− ( MimeRender ctype chunk, ReflectMethod method, KnownNat status,
389− FramingRender framing, ToSourceIO chunk a,
390− GetHeaders (Headers h a)
391− ) => HasServer (Stream method status framing ctype (Headers h a)) context where
294+ ( MimeRender ctype a, ReflectMethod method, KnownNat status,
295+ FramingRender framing ctype, ToStreamGenerator b a,
296+ GetHeaders (Headers h b)
297+ ) => HasServer (Stream method status framing ctype (Headers h b)) context where
392298
393− type ServerT (Stream method status framing ctype (Headers h a)) m = m (Headers h a)
299+ type ServerT (Stream method status framing ctype (Headers h b)) m = m (Headers h b)
394300 hoistServerWithContext _ _ nt s = nt s
395301
396302 route Proxy _ = streamRouter (\x -> (getHeaders x, getResponse x)) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)
397303 where method = reflectMethod (Proxy :: Proxy method)
398− status = statusFromNat (Proxy :: Proxy status)
304+ status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
399305
400306
401−streamRouter :: forall ctype a c chunk env framing. (MimeRender ctype chunk, FramingRender framing, ToSourceIO chunk a) =>
402− (c -> ([(HeaderName, B.ByteString)], a))
307+streamRouter :: (MimeRender ctype a, FramingRender framing ctype, ToStreamGenerator b a) =>
308+ (c -> ([(HeaderName, B.ByteString)], b))
403309 -> Method
404310 -> Status
405311 -> Proxy framing
@@ -407,7 +313,7 @@ streamRouter :: forall ctype a c chunk env framing. (MimeRender ctype chunk, Fra
407313 -> Delayed env (Handler c)
408314 -> Router env
409315streamRouter splitHeaders method status framingproxy ctypeproxy action = leafRouter $ \env request respond ->
410− let AcceptHeader accH = getAcceptHeader request
316+ let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
411317 cmediatype = NHM.matchAccept [contentType ctypeproxy] accH
412318 accCheck = when (isNothing cmediatype) $ delayedFail err406
413319 contentHeader = (hContentType, NHM.renderHeader . maybeToList $ cmediatype)
@@ -415,19 +321,28 @@ streamRouter splitHeaders method status framingproxy ctypeproxy action = leafRou
415321 `addAcceptCheck` accCheck
416322 ) env request respond $ \ output ->
417323 let (headers, fa) = splitHeaders output
418− sourceT = toSourceIO fa
419− S.SourceT kStepLBS = framingRender framingproxy (mimeRender ctypeproxy :: chunk -> BL.ByteString) sourceT
420− in Route $ responseStream status (contentHeader : headers) $ \write flush -> do
421− let loop S.Stop = flush
422− loop (S.Error err) = fail err -- TODO: throw better error
423− loop (S.Skip s) = loop s
424− loop (S.Effect ms) = ms >>= loop
425− loop (S.Yield lbs s) = do
426− write (BB.lazyByteString lbs)
427− flush
428− loop s
429−
430− kStepLBS loop
324+ k = getStreamGenerator . toStreamGenerator $ fa in
325+ Route $ responseStream status (contentHeader : headers) $ \write flush -> do
326+ write . BB.lazyByteString $ header framingproxy ctypeproxy
327+ case boundary framingproxy ctypeproxy of
328+ BoundaryStrategyBracket f ->
329+ let go x = let bs = mimeRender ctypeproxy x
330+ (before, after) = f bs
331+ in write ( BB.lazyByteString before
332+ <> BB.lazyByteString bs
333+ <> BB.lazyByteString after) >> flush
334+ in k go go
335+ BoundaryStrategyIntersperse sep -> k
336+ (\x -> do
337+ write . BB.lazyByteString . mimeRender ctypeproxy $ x
338+ flush)
339+ (\x -> do
340+ write . (BB.lazyByteString sep <>) . BB.lazyByteString . mimeRender ctypeproxy $ x
341+ flush)
342+ BoundaryStrategyGeneral f ->
343+ let go = (>> flush) . write . BB.lazyByteString . f . mimeRender ctypeproxy
344+ in k go go
345+ write . BB.lazyByteString $ trailer framingproxy ctypeproxy
431346
432347-- | If you use 'Header' in one of the endpoints for your API,
433348-- this automatically requires your server-side handler to be a function
@@ -452,7 +367,6 @@ streamRouter splitHeaders method status framingproxy ctypeproxy action = leafRou
452367instance
453368 (KnownSymbol sym, FromHttpApiData a, HasServer api context
454369 , SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)
455− , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
456370 )
457371 => HasServer (Header' mods sym a :> api) context where
458372------
@@ -464,9 +378,6 @@ instance
464378 route Proxy context subserver = route (Proxy :: Proxy api) context $
465379 subserver `addHeaderCheck` withRequest headerCheck
466380 where
467− rep = typeRep (Proxy :: Proxy Header')
468− formatError = headerParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
469−
470381 headerName :: IsString n => n
471382 headerName = fromString $ symbolVal (Proxy :: Proxy sym)
472383
@@ -477,13 +388,15 @@ instance
477388 mev :: Maybe (Either T.Text a)
478389 mev = fmap parseHeader $ lookup headerName (requestHeaders req)
479390
480− errReq = delayedFailFatal $ formatError rep req
481− $ "Header " <> headerName <> " is required"
391+ errReq = delayedFailFatal err400
392+ { errBody = "Header " <> headerName <> " is required"
393+ }
482394
483− errSt e = delayedFailFatal $ formatError rep req
484− $ cs $ "Error parsing header "
485− <> headerName
486− <> " failed: " <> e
395+ errSt e = delayedFailFatal err400
396+ { errBody = cs $ "Error parsing header "
397+ <> headerName
398+ <> " failed: " <> e
399+ }
487400
488401-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,
489402-- this automatically requires your server-side handler to be a function
@@ -509,7 +422,6 @@ instance
509422instance
510423 ( KnownSymbol sym, FromHttpApiData a, HasServer api context
511424 , SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)
512− , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
513425 )
514426 => HasServer (QueryParam' mods sym a :> api) context where
515427------
@@ -519,12 +431,9 @@ instance
519431 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
520432
521433 route Proxy context subserver =
522− let querytext = queryToQueryText . queryString
434+ let querytext req = parseQueryText $ rawQueryString req
523435 paramname = cs $ symbolVal (Proxy :: Proxy sym)
524436
525− rep = typeRep (Proxy :: Proxy QueryParam')
526− formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
527−
528437 parseParam :: Request -> DelayedIO (RequestArgument mods a)
529438 parseParam req =
530439 unfoldRequestArgument (Proxy :: Proxy mods) errReq errSt mev
@@ -532,12 +441,14 @@ instance
532441 mev :: Maybe (Either T.Text a)
533442 mev = fmap parseQueryParam $ join $ lookup paramname $ querytext req
534443
535− errReq = delayedFailFatal $ formatError rep req
536− $ cs $ "Query parameter " <> paramname <> " is required"
444+ errReq = delayedFailFatal err400
445+ { errBody = cs $ "Query parameter " <> paramname <> " is required"
446+ }
537447
538− errSt e = delayedFailFatal $ formatError rep req
539− $ cs $ "Error parsing query parameter "
540− <> paramname <> " failed: " <> e
448+ errSt e = delayedFailFatal err400
449+ { errBody = cs $ "Error parsing query parameter "
450+ <> paramname <> " failed: " <> e
451+ }
541452
542453 delayed = addParameterCheck subserver . withRequest $ \req ->
543454 parseParam req
@@ -563,8 +474,7 @@ instance
563474-- > server = getBooksBy
564475-- > where getBooksBy :: [Text] -> Handler [Book]
565476-- > getBooksBy authors = ...return all books by these authors...
566−instance (KnownSymbol sym, FromHttpApiData a, HasServer api context
567− , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters)
477+instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)
568478 => HasServer (QueryParams sym a :> api) context where
569479
570480 type ServerT (QueryParams sym a :> api) m =
@@ -575,23 +485,21 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer api context
575485 route Proxy context subserver = route (Proxy :: Proxy api) context $
576486 subserver `addParameterCheck` withRequest paramsCheck
577487 where
578− rep = typeRep (Proxy :: Proxy QueryParams)
579− formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
580−
581488 paramname = cs $ symbolVal (Proxy :: Proxy sym)
582489 paramsCheck req =
583490 case partitionEithers $ fmap parseQueryParam params of
584491 ([], parsed) -> return parsed
585− (errs, _) -> delayedFailFatal $ formatError rep req
586− $ cs $ "Error parsing query parameter(s) "
587− <> paramname <> " failed: "
588− <> T.intercalate ", " errs
492+ (errs, _) -> delayedFailFatal err400
493+ { errBody = cs $ "Error parsing query parameter(s) "
494+ <> paramname <> " failed: "
495+ <> T.intercalate ", " errs
496+ }
589497 where
590498 params :: [T.Text]
591499 params = mapMaybe snd
592500 . filter (looksLikeParam . fst)
593− . queryToQueryText
594− . queryString
501+ . parseQueryText
502+ . rawQueryString
595503 $ req
596504
597505 looksLikeParam name = name == paramname || name == (paramname <> "[]")
@@ -617,7 +525,7 @@ instance (KnownSymbol sym, HasServer api context)
617525 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
618526
619527 route Proxy context subserver =
620− let querytext = queryToQueryText . queryString
528+ let querytext r = parseQueryText $ rawQueryString r
621529 param r = case lookup paramname (querytext r) of
622530 Just Nothing -> True -- param is there, with no value
623531 Just (Just v) -> examine v -- param with a value
@@ -653,42 +561,13 @@ instance HasServer Raw context where
653561 Fail a -> respond $ Fail a
654562 FailFatal e -> respond $ FailFatal e
655563
656−-- | Just pass the request to the underlying application and serve its response.
657−--
658−-- Example:
659−--
660−-- > type MyApi = "images" :> Raw
661−-- >
662−-- > server :: Server MyApi
663−-- > server = serveDirectory "/var/www/images"
664−instance HasServer RawM context where
665− type ServerT RawM m = Request -> (Response -> IO ResponseReceived) -> m ResponseReceived
666−
667− route
668− :: Proxy RawM
669− -> Context context
670− -> Delayed env (Request -> (Response -> IO ResponseReceived) -> Handler ResponseReceived) -> Router env
671− route _ _ handleDelayed = RawRouter $ \env request respond -> runResourceT $ do
672− routeResult <- runDelayed handleDelayed env request
673− let respond' = liftIO . respond
674− liftIO $ case routeResult of
675− Route handler -> runHandler (handler request (respond . Route)) >>=
676− \case
677− Left e -> respond' $ FailFatal e
678− Right a -> pure a
679− Fail e -> respond' $ Fail e
680− FailFatal e -> respond' $ FailFatal e
681−
682− hoistServerWithContext _ _ f srvM = \req respond -> f (srvM req respond)
683−
684−
685564-- | If you use 'ReqBody' in one of the endpoints for your API,
686565-- this automatically requires your server-side handler to be a function
687566-- that takes an argument of the type specified by 'ReqBody'.
688567-- The @Content-Type@ header is inspected, and the list provided is used to
689568-- attempt deserialization. If the request does not have a @Content-Type@
690569-- header, it is treated as @application/octet-stream@ (as specified in
691−-- [RFC 7231 section 3.1.1.5](http://tools.ietf.org/html/rfc7231#section-3.1.1.5)).
570+-- <http://tools.ietf.org/html/rfc7231#section-3.1.1.5 RFC7231>.
692571-- This lets servant worry about extracting it from the request and turning
693572-- it into a value of the type you specify.
694573--
@@ -704,7 +583,6 @@ instance HasServer RawM context where
704583-- > where postBook :: Book -> Handler Book
705584-- > postBook book = ...insert into your db...
706585instance ( AllCTUnrender list a, HasServer api context, SBoolI (FoldLenient mods)
707− , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
708586 ) => HasServer (ReqBody' mods list a :> api) context where
709587
710588 type ServerT (ReqBody' mods list a :> api) m =
@@ -716,9 +594,6 @@ instance ( AllCTUnrender list a, HasServer api context, SBoolI (FoldLenient mods
716594 = route (Proxy :: Proxy api) context $
717595 addBodyCheck subserver ctCheck bodyCheck
718596 where
719− rep = typeRep (Proxy :: Proxy ReqBody')
720− formatError = bodyParserErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
721−
722597 -- Content-Type check, we only lookup we can try to parse the request body
723598 ctCheck = withRequest $ \ request -> do
724599 -- See HTTP RFC 2616, section 7.2.1
@@ -737,34 +612,9 @@ instance ( AllCTUnrender list a, HasServer api context, SBoolI (FoldLenient mods
737612 case sbool :: SBool (FoldLenient mods) of
738613 STrue -> return mrqbody
739614 SFalse -> case mrqbody of
740− Left e -> delayedFailFatal $ formatError rep request e
615+ Left e -> delayedFailFatal err400 { errBody = cs e }
741616 Right v -> return v
742617
743−instance
744− ( FramingUnrender framing, FromSourceIO chunk a, MimeUnrender ctype chunk
745− , HasServer api context
746− ) => HasServer (StreamBody' mods framing ctype a :> api) context
747− where
748− type ServerT (StreamBody' mods framing ctype a :> api) m = a -> ServerT api m
749−
750− hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
751−
752− route Proxy context subserver = route (Proxy :: Proxy api) context $
753− addBodyCheck subserver ctCheck bodyCheck
754− where
755− ctCheck :: DelayedIO (SourceIO chunk -> a)
756− -- TODO: do content-type check
757− ctCheck = return fromSourceIO
758−
759− bodyCheck :: (SourceIO chunk -> a) -> DelayedIO a
760− bodyCheck fromRS = withRequest $ \req -> do
761− let mimeUnrender' = mimeUnrender (Proxy :: Proxy ctype) :: BL.ByteString -> Either String chunk
762− let framingUnrender' = framingUnrender (Proxy :: Proxy framing) mimeUnrender' :: SourceIO B.ByteString -> SourceIO chunk
763− let body = getRequestBodyChunk req
764− let rs = S.fromAction B.null body
765− let rs' = fromRS $ framingUnrender' rs
766− return rs'
767−
768618-- | Make sure the incoming request starts with @"/path"@, strip it and
769619-- pass the rest of the request path to @api@.
770620instance (KnownSymbol path, HasServer api context) => HasServer (path :> api) context where
@@ -829,12 +679,12 @@ data EmptyServer = EmptyServer deriving (Typeable, Eq, Show, Bounded, Enum)
829679emptyServer :: ServerT EmptyAPI m
830680emptyServer = Tagged EmptyServer
831681
832−-- | The server for an `EmptyAPI` is `emptyServer`.
682+-- | The server for an `EmptyAPI` is `emptyAPIServer`.
833683--
834684-- > type MyApi = "nothing" :> EmptyApi
835685-- >
836686-- > server :: Server MyApi
837−-- > server = emptyServer
687+-- > server = emptyAPIServer
838688instance HasServer EmptyAPI context where
839689 type ServerT EmptyAPI m = Tagged m EmptyServer
840690
@@ -863,10 +713,7 @@ instance ( KnownSymbol realm
863713-- * helpers
864714
865715ct_wildcard :: B.ByteString
866−ct_wildcard = "*" <> "/" <> "*"
867−
868−getAcceptHeader :: Request -> AcceptHeader
869−getAcceptHeader = AcceptHeader . fromMaybe ct_wildcard . lookup hAccept . requestHeaders
716+ct_wildcard = "*" <> "/" <> "*" -- Because CPP
870717
871718-- * General Authentication
872719
@@ -891,19 +738,39 @@ instance (HasContextEntry context (NamedContext name subContext), HasServer subA
891738 hoistServerWithContext _ _ nt s = hoistServerWithContext (Proxy :: Proxy subApi) (Proxy :: Proxy subContext) nt s
892739
893740-------------------------------------------------------------------------------
894−-- Custom type errors
741+-- TypeError helpers
895742-------------------------------------------------------------------------------
896743
897−-- Erroring instance for 'HasServer' when a combinator is not fully applied
898−instance TypeError (PartialApplication
899−#if __GLASGOW_HASKELL__ >= 904
900− @(Type -> [Type] -> Constraint)
901−#endif
902− HasServer arr) => HasServer ((arr :: a -> b) :> sub) context
744+#ifdef HAS_TYPE_ERROR
745+-- | This instance catches mistakes when there are non-saturated
746+-- type applications on LHS of ':>'.
747+--
748+-- >>> serve (Proxy :: Proxy (Capture "foo" :> Get '[JSON] Int)) (error "...")
749+-- ...
750+-- ...Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'.
751+-- ...Maybe you haven't applied enough arguments to
752+-- ...Capture' '[] "foo"
753+-- ...
754+--
755+-- >>> undefined :: Server (Capture "foo" :> Get '[JSON] Int)
756+-- ...
757+-- ...Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'.
758+-- ...Maybe you haven't applied enough arguments to
759+-- ...Capture' '[] "foo"
760+-- ...
761+--
762+instance TypeError (HasServerArrowKindError arr) => HasServer ((arr :: k -> l) :> api) context
903763 where
904− type ServerT (arr :> sub) _ = TypeError (PartialApplication (HasServer :: * -> [*] -> Constraint) arr)
905− route = error "unreachable"
906− hoistServerWithContext _ _ _ _ = error "unreachable"
764+ type ServerT (arr :> api) m = TypeError (HasServerArrowKindError arr)
765+ -- it doens't really matter what sub route we peak
766+ route _ _ _ = error "servant-server panic: impossible happened in HasServer (arr :> api)"
767+ hoistServerWithContext _ _ _ = id
768+
769+-- Cannot have TypeError here, otherwise use of this symbol will error :)
770+type HasServerArrowKindError arr =
771+ 'Text "Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'."
772+ ':$$: 'Text "Maybe you haven't applied enough arguments to"
773+ ':$$: 'ShowType arr
907774
908775-- | This instance prevents from accidentally using '->' instead of ':>'
909776--
@@ -937,107 +804,7 @@ type HasServerArrowTypeError a b =
937804 ':$$: 'ShowType a
938805 ':$$: 'Text "and"
939806 ':$$: 'ShowType b
940−
941−-- Erroring instances for 'HasServer' for unknown API combinators
942−
943−-- XXX: This omits the @context@ parameter, e.g.:
944−--
945−-- "There is no instance for HasServer (Bool :> …)". Do we care ?
946−instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub
947−#if __GLASGOW_HASKELL__ >= 904
948− @(Type -> [Type] -> Constraint)
949807#endif
950− HasServer ty) => HasServer (ty :> sub) context
951−
952−instance {-# OVERLAPPABLE #-} TypeError (NoInstanceFor (HasServer api context)) => HasServer api context
953−
954−-- | Ignore @'Fragment'@ in server handlers.
955−-- See <https://ietf.org/rfc/rfc2616.html#section-15.1.3> for more details.
956−--
957−-- Example:
958−--
959−-- > type MyApi = "books" :> Fragment Text :> Get '[JSON] [Book]
960−-- >
961−-- > server :: Server MyApi
962−-- > server = getBooks
963−-- > where getBooks :: Handler [Book]
964−-- > getBooks = ...return all books...
965−instance (AtLeastOneFragment api, FragmentUnique (Fragment a1 :> api), HasServer api context)
966− => HasServer (Fragment a1 :> api) context where
967− type ServerT (Fragment a1 :> api) m = ServerT api m
968−
969− route _ = route (Proxy :: Proxy api)
970−
971− hoistServerWithContext _ = hoistServerWithContext (Proxy :: Proxy api)
972808
973809-- $setup
974810-- >>> import Servant
975−
976−-- | A type that specifies that an API record contains a server implementation.
977−data AsServerT (m :: * -> *)
978−instance GenericMode (AsServerT m) where
979− type AsServerT m :- api = ServerT api m
980−
981−type AsServer = AsServerT Handler
982−
983−
984−-- | Set of constraints required to convert to / from vanilla server types.
985−type GServerConstraints api m =
986− ( ToServant api (AsServerT m) ~ ServerT (ToServantApi api) m
987− , GServantProduct (Rep (api (AsServerT m)))
988− )
989−
990−-- | This class is a necessary evil: in the implementation of 'HasServer' for
991−-- @'NamedRoutes' api@, we essentially need the quantified constraint @forall
992−-- m. 'GServerConstraints' m@ to hold.
993−--
994−-- We cannot require do that directly as the definition of 'GServerConstraints'
995−-- contains type family applications ('Rep' and 'ServerT'). The trick is to hide
996−-- those type family applications behind a typeclass providing evidence for
997−-- @'GServerConstraints' api m@ in the form of a dictionary, and require that
998−-- @forall m. 'GServer' api m@ instead.
999−--
1000−-- Users shouldn't have to worry about this class, as the only possible instance
1001−-- is provided in this module for all record APIs.
1002−
1003−class GServer (api :: * -> *) (m :: * -> *) where
1004− gServerProof :: Dict (GServerConstraints api m)
1005−
1006−instance
1007− ( ToServant api (AsServerT m) ~ ServerT (ToServantApi api) m
1008− , GServantProduct (Rep (api (AsServerT m)))
1009− ) => GServer api m where
1010− gServerProof = Dict
1011−
1012−instance
1013− ( HasServer (ToServantApi api) context
1014− , forall m. Generic (api (AsServerT m))
1015− , forall m. GServer api m
1016− ) => HasServer (NamedRoutes api) context where
1017−
1018− type ServerT (NamedRoutes api) m = api (AsServerT m)
1019−
1020− route
1021− :: Proxy (NamedRoutes api)
1022− -> Context context
1023− -> Delayed env (api (AsServerT Handler))
1024− -> Router env
1025− route _ ctx delayed =
1026− case gServerProof @api @Handler of
1027− Dict -> route (Proxy @(ToServantApi api)) ctx (toServant <$> delayed)
1028−
1029− hoistServerWithContext
1030− :: forall m n. Proxy (NamedRoutes api)
1031− -> Proxy context
1032− -> (forall x. m x -> n x)
1033− -> api (AsServerT m)
1034− -> api (AsServerT n)
1035− hoistServerWithContext _ pctx nat server =
1036− case (gServerProof @api @m, gServerProof @api @n) of
1037− (Dict, Dict) ->
1038− fromServant servantSrvN
1039− where
1040− servantSrvM :: ServerT (ToServantApi api) m =
1041− toServant server
1042− servantSrvN :: ServerT (ToServantApi api) n =
1043− hoistServerWithContext (Proxy @(ToServantApi api)) pctx nat servantSrvM
servant-server/src/Servant/Server/Internal/BasicAuth.hs+6−4
@@ -9,9 +9,11 @@ import Control.Monad
99 (guard)
1010import Control.Monad.Trans
1111 (liftIO)
12−import qualified Data.ByteString as BS
12+import qualified Data.ByteString as BS
1313import Data.ByteString.Base64
1414 (decodeLenient)
15+import Data.Monoid
16+ ((<>))
1517import Data.Typeable
1618 (Typeable)
1719import Data.Word8
@@ -24,13 +26,13 @@ import Network.Wai
2426
2527import Servant.API.BasicAuth
2628 (BasicAuthData (BasicAuthData))
27−import Servant.Server.Internal.DelayedIO
28−import Servant.Server.Internal.ServerError
29+import Servant.Server.Internal.RoutingApplication
30+import Servant.Server.Internal.ServantErr
2931
3032-- * Basic Auth
3133
3234-- | servant-server's current implementation of basic authentication is not
33−-- immune to certain kinds of timing attacks. Decoding payloads does not take
35+-- immune to certian kinds of timing attacks. Decoding payloads does not take
3436-- a fixed amount of time.
3537
3638-- | The result of authentication/authorization
servant-server/src/Servant/Server/Internal/Context.hs+9−24
@@ -1,12 +1,11 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE FlexibleContexts #-}
3−{-# LANGUAGE FlexibleInstances #-}
4−{-# LANGUAGE GADTs #-}
5−{-# LANGUAGE KindSignatures #-}
6−{-# LANGUAGE MultiParamTypeClasses #-}
7−{-# LANGUAGE ScopedTypeVariables #-}
8−{-# LANGUAGE TypeFamilies #-}
9−{-# LANGUAGE TypeOperators #-}
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE GADTs #-}
5+{-# LANGUAGE KindSignatures #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE ScopedTypeVariables #-}
8+{-# LANGUAGE TypeOperators #-}
109
1110module Servant.Server.Internal.Context where
1211
@@ -21,7 +20,7 @@ import GHC.TypeLits
2120--
2221-- If you are using combinators that require a non-empty 'Context' you have to
2322-- use 'Servant.Server.serveWithContext' and pass it a 'Context' that contains all
24−-- the values your combinators need. A 'Context' is essentially a heterogeneous
23+-- the values your combinators need. A 'Context' is essentially a heterogenous
2524-- list and accessing the elements is being done by type (see 'getContextEntry').
2625-- The parameter of the type 'Context' is a type-level list reflecting the types
2726-- of the contained context entries. To create a 'Context' with entries, use the
@@ -46,20 +45,6 @@ instance Eq (Context '[]) where
4645instance (Eq a, Eq (Context as)) => Eq (Context (a ': as)) where
4746 x1 :. y1 == x2 :. y2 = x1 == x2 && y1 == y2
4847
49−-- | Append two type-level lists.
50−--
51−-- Hint: import it as
52−--
53−-- > import Servant.Server (type (.++))
54−type family (.++) (l1 :: [*]) (l2 :: [*]) where
55− '[] .++ a = a
56− (a ': as) .++ b = a ': (as .++ b)
57−
58−-- | Append two contexts.
59−(.++) :: Context l1 -> Context l2 -> Context (l1 .++ l2)
60−EmptyContext .++ a = a
61−(a :. as) .++ b = a :. (as .++ b)
62−
6348-- | This class is used to access context entries in 'Context's. 'getContextEntry'
6449-- returns the first value where the type matches:
6550--
servant-server/src/Servant/Server/Internal/Delayed.hsdeleted−272
@@ -1,272 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE FlexibleInstances #-}
3−{-# LANGUAGE GADTs #-}
4−{-# LANGUAGE MultiParamTypeClasses #-}
5−{-# LANGUAGE RecordWildCards #-}
6−{-# LANGUAGE TypeFamilies #-}
7−{-# LANGUAGE TypeOperators #-}
8−{-# LANGUAGE UndecidableInstances #-}
9−module Servant.Server.Internal.Delayed where
10−
11−import Control.Monad.IO.Class
12− (MonadIO (..))
13−import Control.Monad.Reader
14− (ask)
15−import Control.Monad.Trans.Resource
16− (ResourceT, runResourceT)
17−import Network.Wai
18− (Request, Response)
19−
20−import Servant.Server.Internal.DelayedIO
21−import Servant.Server.Internal.Handler
22−import Servant.Server.Internal.RouteResult
23−import Servant.Server.Internal.ServerError
24−
25−-- | A 'Delayed' is a representation of a handler with scheduled
26−-- delayed checks that can trigger errors.
27−--
28−-- Why would we want to delay checks?
29−--
30−-- There are two reasons:
31−--
32−-- 1. In a straight-forward implementation, the order in which we
33−-- perform checks will determine the error we generate. This is
34−-- because once an error occurs, we would abort and not perform
35−-- any subsequent checks, but rather return the current error.
36−--
37−-- This is not a necessity: we could continue doing other checks,
38−-- and choose the preferred error. However, that would in general
39−-- mean more checking, which leads us to the other reason.
40−--
41−-- 2. We really want to avoid doing certain checks too early. For
42−-- example, captures involve parsing, and are much more costly
43−-- than static route matches. In particular, if several paths
44−-- contain the "same" capture, we'd like as much as possible to
45−-- avoid trying the same parse many times. Also tricky is the
46−-- request body. Again, this involves parsing, but also, WAI makes
47−-- obtaining the request body a side-effecting operation. We
48−-- could/can work around this by manually caching the request body,
49−-- but we'd rather keep the number of times we actually try to
50−-- decode the request body to an absolute minimum.
51−--
52−-- We prefer to have the following relative priorities of error
53−-- codes:
54−--
55−-- @
56−-- 404
57−-- 405 (bad method)
58−-- 401 (unauthorized)
59−-- 415 (unsupported media type)
60−-- 406 (not acceptable)
61−-- 400 (bad request)
62−-- @
63−--
64−-- Therefore, while routing, we delay most checks so that they
65−-- will ultimately occur in the right order.
66−--
67−-- A 'Delayed' contains many delayed blocks of tests, and
68−-- the actual handler:
69−--
70−-- 1. Delayed captures. These can actually cause 404, and
71−-- while they're costly, they should be done first among the
72−-- delayed checks (at least as long as we do not decouple the
73−-- check order from the error reporting, see above). Delayed
74−-- captures can provide inputs to the actual handler.
75−--
76−-- 2. Method check(s). This can cause a 405. On success,
77−-- it does not provide an input for the handler. Method checks
78−-- are comparatively cheap.
79−--
80−-- 3. Authentication checks. This can cause 401.
81−--
82−-- 4. Accept and content type header checks. These checks
83−-- can cause 415 and 406 errors.
84−--
85−-- 5. Query parameter checks. They require parsing and can cause 400 if the
86−-- parsing fails. Query parameter checks provide inputs to the handler
87−--
88−-- 6. Header Checks. They also require parsing and can cause 400 if parsing fails.
89−--
90−-- 7. Body check. The request body check can cause 400.
91−--
92−data Delayed env c where
93− Delayed :: { capturesD :: env -> DelayedIO captures
94− , methodD :: DelayedIO ()
95− , authD :: DelayedIO auth
96− , acceptD :: DelayedIO ()
97− , contentD :: DelayedIO contentType
98− , paramsD :: DelayedIO params
99− , headersD :: DelayedIO headers
100− , bodyD :: contentType -> DelayedIO body
101− , serverD :: captures
102− -> params
103− -> headers
104− -> auth
105− -> body
106− -> Request
107− -> RouteResult c
108− } -> Delayed env c
109−
110−instance Functor (Delayed env) where
111− fmap f Delayed{..} =
112− Delayed
113− { serverD = \ c p h a b req -> f <$> serverD c p h a b req
114− , ..
115− } -- Note [Existential Record Update]
116−
117−-- | A 'Delayed' without any stored checks.
118−emptyDelayed :: RouteResult a -> Delayed env a
119−emptyDelayed result =
120− Delayed (const r) r r r r r r (const r) (\ _ _ _ _ _ _ -> result)
121− where
122− r = return ()
123−
124−-- | Add a capture to the end of the capture block.
125−addCapture :: Delayed env (a -> b)
126− -> (captured -> DelayedIO a)
127− -> Delayed (captured, env) b
128−addCapture Delayed{..} new =
129− Delayed
130− { capturesD = \ (txt, env) -> (,) <$> capturesD env <*> new txt
131− , serverD = \ (x, v) p h a b req -> ($ v) <$> serverD x p h a b req
132− , ..
133− } -- Note [Existential Record Update]
134−
135−-- | Add a parameter check to the end of the params block
136−addParameterCheck :: Delayed env (a -> b)
137− -> DelayedIO a
138− -> Delayed env b
139−addParameterCheck Delayed {..} new =
140− Delayed
141− { paramsD = (,) <$> paramsD <*> new
142− , serverD = \c (p, pNew) h a b req -> ($ pNew) <$> serverD c p h a b req
143− , ..
144− }
145−
146−-- | Add a parameter check to the end of the params block
147−addHeaderCheck :: Delayed env (a -> b)
148− -> DelayedIO a
149− -> Delayed env b
150−addHeaderCheck Delayed {..} new =
151− Delayed
152− { headersD = (,) <$> headersD <*> new
153− , serverD = \c p (h, hNew) a b req -> ($ hNew) <$> serverD c p h a b req
154− , ..
155− }
156−
157−-- | Add a method check to the end of the method block.
158−addMethodCheck :: Delayed env a
159− -> DelayedIO ()
160− -> Delayed env a
161−addMethodCheck Delayed{..} new =
162− Delayed
163− { methodD = methodD <* new
164− , ..
165− } -- Note [Existential Record Update]
166−
167−-- | Add an auth check to the end of the auth block.
168−addAuthCheck :: Delayed env (a -> b)
169− -> DelayedIO a
170− -> Delayed env b
171−addAuthCheck Delayed{..} new =
172− Delayed
173− { authD = (,) <$> authD <*> new
174− , serverD = \ c p h (y, v) b req -> ($ v) <$> serverD c p h y b req
175− , ..
176− } -- Note [Existential Record Update]
177−
178−-- | Add a content type and body checks around parameter checks.
179−--
180−-- We'll report failed content type check (415), before trying to parse
181−-- query parameters (400). Which, in turn, happens before request body parsing.
182−addBodyCheck :: Delayed env (a -> b)
183− -> DelayedIO c -- ^ content type check
184− -> (c -> DelayedIO a) -- ^ body check
185− -> Delayed env b
186−addBodyCheck Delayed{..} newContentD newBodyD =
187− Delayed
188− { contentD = (,) <$> contentD <*> newContentD
189− , bodyD = \(content, c) -> (,) <$> bodyD content <*> newBodyD c
190− , serverD = \ c p h a (z, v) req -> ($ v) <$> serverD c p h a z req
191− , ..
192− } -- Note [Existential Record Update]
193−
194−
195−-- | Add an accept header check before handling parameters.
196−-- In principle, we'd like
197−-- to take a bad body (400) response take precedence over a
198−-- failed accept check (406). BUT to allow streaming the body,
199−-- we cannot run the body check and then still backtrack.
200−-- We therefore do the accept check before the body check,
201−-- when we can still backtrack. There are other solutions to
202−-- this, but they'd be more complicated (such as delaying the
203−-- body check further so that it can still be run in a situation
204−-- where we'd otherwise report 406).
205−addAcceptCheck :: Delayed env a
206− -> DelayedIO ()
207− -> Delayed env a
208−addAcceptCheck Delayed{..} new =
209− Delayed
210− { acceptD = acceptD *> new
211− , ..
212− } -- Note [Existential Record Update]
213−
214−-- | Many combinators extract information that is passed to
215−-- the handler without the possibility of failure. In such a
216−-- case, 'passToServer' can be used.
217−passToServer :: Delayed env (a -> b) -> (Request -> a) -> Delayed env b
218−passToServer Delayed{..} x =
219− Delayed
220− { serverD = \ c p h a b req -> ($ x req) <$> serverD c p h a b req
221− , ..
222− } -- Note [Existential Record Update]
223−
224−-- | Run a delayed server. Performs all scheduled operations
225−-- in order, and passes the results from the capture and body
226−-- blocks on to the actual handler.
227−--
228−-- This should only be called once per request; otherwise the guarantees about
229−-- effect and HTTP error ordering break down.
230−runDelayed :: Delayed env a
231− -> env
232− -> Request
233− -> ResourceT IO (RouteResult a)
234−runDelayed Delayed{..} env = runDelayedIO $ do
235− r <- ask
236− c <- capturesD env
237− methodD
238− a <- authD
239− acceptD
240− content <- contentD
241− p <- paramsD -- Has to be before body parsing, but after content-type checks
242− h <- headersD
243− b <- bodyD content
244− liftRouteResult (serverD c p h a b r)
245−
246−-- | Runs a delayed server and the resulting action.
247−-- Takes a continuation that lets us send a response.
248−-- Also takes a continuation for how to turn the
249−-- result of the delayed server into a response.
250−runAction :: Delayed env (Handler a)
251− -> env
252− -> Request
253− -> (RouteResult Response -> IO r)
254− -> (a -> RouteResult Response)
255− -> IO r
256−runAction action env req respond k = runResourceT $
257− runDelayed action env req >>= go >>= liftIO . respond
258− where
259− go (Fail e) = return $ Fail e
260− go (FailFatal e) = return $ FailFatal e
261− go (Route a) = liftIO $ do
262− e <- runHandler a
263− case e of
264− Left err -> return . Route $ responseServerError err
265− Right x -> return $! k x
266−
267−{- Note [Existential Record Update]
268−~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
269−
270−Due to GHC issue <https://ghc.haskell.org/trac/ghc/ticket/2595 2595>, we cannot
271−do the more succinct thing - just update the records we actually change.
272−-}
servant-server/src/Servant/Server/Internal/DelayedIO.hsdeleted−71
@@ -1,71 +0,0 @@
1−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2−{-# LANGUAGE MultiParamTypeClasses #-}
3−{-# LANGUAGE TypeFamilies #-}
4−module Servant.Server.Internal.DelayedIO where
5−
6−import Control.Monad.Base
7− (MonadBase (..))
8−import Control.Monad.Catch
9− (MonadThrow (..))
10−import Control.Monad.Reader
11− (MonadReader (..), ReaderT (..), runReaderT)
12−import Control.Monad.Trans
13− (MonadIO (..), MonadTrans (..))
14−import Control.Monad.Trans.Control
15− (MonadBaseControl (..))
16−import Control.Monad.Trans.Resource
17− (MonadResource (..), ResourceT, runInternalState,
18− transResourceT, withInternalState)
19−import Network.Wai
20− (Request)
21−
22−import Servant.Server.Internal.RouteResult
23−import Servant.Server.Internal.ServerError
24−
25−-- | Computations used in a 'Delayed' can depend on the
26−-- incoming 'Request', may perform 'IO', and result in a
27−-- 'RouteResult', meaning they can either succeed, fail
28−-- (with the possibility to recover), or fail fatally.
29−--
30−newtype DelayedIO a = DelayedIO { runDelayedIO' :: ReaderT Request (ResourceT (RouteResultT IO)) a }
31− deriving
32− ( Functor, Applicative, Monad
33− , MonadIO, MonadReader Request
34− , MonadThrow
35− , MonadResource
36− )
37−
38−instance MonadBase IO DelayedIO where
39− liftBase = liftIO
40−
41−liftRouteResult :: RouteResult a -> DelayedIO a
42−liftRouteResult x = DelayedIO $ lift . lift $ RouteResultT . return $ x
43−
44−instance MonadBaseControl IO DelayedIO where
45− -- type StM DelayedIO a = StM (ReaderT Request (ResourceT (RouteResultT IO))) a
46− -- liftBaseWith f = DelayedIO $ liftBaseWith $ \g -> f (g . runDelayedIO')
47− -- restoreM = DelayedIO . restoreM
48−
49− type StM DelayedIO a = RouteResult a
50− liftBaseWith f = DelayedIO $ ReaderT $ \req -> withInternalState $ \s ->
51− liftBaseWith $ \runInBase -> f $ \x ->
52− runInBase (runInternalState (runReaderT (runDelayedIO' x) req) s)
53− restoreM = DelayedIO . lift . withInternalState . const . restoreM
54−
55−
56−runDelayedIO :: DelayedIO a -> Request -> ResourceT IO (RouteResult a)
57−runDelayedIO m req = transResourceT runRouteResultT $ runReaderT (runDelayedIO' m) req
58−
59−-- | Fail with the option to recover.
60−delayedFail :: ServerError -> DelayedIO a
61−delayedFail err = liftRouteResult $ Fail err
62−
63−-- | Fail fatally, i.e., without any option to recover.
64−delayedFailFatal :: ServerError -> DelayedIO a
65−delayedFailFatal err = liftRouteResult $ FailFatal err
66−
67−-- | Gain access to the incoming request.
68−withRequest :: (Request -> DelayedIO a) -> DelayedIO a
69−withRequest f = do
70− req <- ask
71− f req
servant-server/src/Servant/Server/Internal/ErrorFormatter.hsdeleted−87
@@ -1,87 +0,0 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE PolyKinds #-}
3−{-# LANGUAGE RankNTypes #-}
4−{-# LANGUAGE TypeOperators #-}
5−
6−module Servant.Server.Internal.ErrorFormatter
7− ( ErrorFormatters(..)
8− , ErrorFormatter
9− , NotFoundErrorFormatter
10−
11− , DefaultErrorFormatters
12− , defaultErrorFormatters
13−
14− , MkContextWithErrorFormatter
15− , mkContextWithErrorFormatter
16− ) where
17−
18−import Data.String.Conversions
19− (cs)
20−import Data.Typeable
21−import Network.Wai.Internal
22− (Request)
23−
24−import Servant.API
25− (Capture, ReqBody)
26−import Servant.Server.Internal.Context
27−import Servant.Server.Internal.ServerError
28−
29−-- | 'Context' that contains default error formatters.
30−type DefaultErrorFormatters = '[ErrorFormatters]
31−
32−-- | A collection of error formatters for different situations.
33−--
34−-- If you need to override one of them, use 'defaultErrorFormatters' with record update syntax.
35−data ErrorFormatters = ErrorFormatters
36− { -- | Format error from parsing the request body.
37− bodyParserErrorFormatter :: ErrorFormatter
38− -- | Format error from parsing url parts or query parameters.
39− , urlParseErrorFormatter :: ErrorFormatter
40− -- | Format error from parsing request headers.
41− , headerParseErrorFormatter :: ErrorFormatter
42− -- | Format error for not found URLs.
43− , notFoundErrorFormatter :: NotFoundErrorFormatter
44− }
45−
46−-- | Default formatters will just return HTTP 400 status code with error
47−-- message as response body.
48−defaultErrorFormatters :: ErrorFormatters
49−defaultErrorFormatters = ErrorFormatters
50− { bodyParserErrorFormatter = err400Formatter
51− , urlParseErrorFormatter = err400Formatter
52− , headerParseErrorFormatter = err400Formatter
53− , notFoundErrorFormatter = const err404
54− }
55−
56−-- | A custom formatter for errors produced by parsing combinators like
57−-- 'ReqBody' or 'Capture'.
58−--
59−-- A 'TypeRep' argument described the concrete combinator that raised
60−-- the error, allowing formatter to customize the message for different
61−-- combinators.
62−--
63−-- A full 'Request' is also passed so that the formatter can react to @Accept@ header,
64−-- for example.
65−type ErrorFormatter = TypeRep -> Request -> String -> ServerError
66−
67−-- | This formatter does not get neither 'TypeRep' nor error message.
68−type NotFoundErrorFormatter = Request -> ServerError
69−
70−type MkContextWithErrorFormatter (ctx :: [*]) = ctx .++ DefaultErrorFormatters
71−
72−mkContextWithErrorFormatter :: forall (ctx :: [*]). Context ctx -> Context (MkContextWithErrorFormatter ctx)
73−mkContextWithErrorFormatter ctx = ctx .++ (defaultErrorFormatters :. EmptyContext)
74−
75−-- Internal
76−
77−err400Formatter :: ErrorFormatter
78−err400Formatter _ _ e = err400 { errBody = cs e }
79−
80−-- These definitions suppress "unused import" warning.
81−-- The imorts are needed for Haddock to correctly link to them.
82−_RB :: Proxy ReqBody
83−_RB = Proxy
84−_C :: Proxy Capture
85−_C = Proxy
86−_CT :: Proxy Context
87−_CT = Proxy
servant-server/src/Servant/Server/Internal/Handler.hs+9−14
@@ -11,37 +11,32 @@ import Prelude.Compat
1111import Control.Monad.Base
1212 (MonadBase (..))
1313import Control.Monad.Catch
14− (MonadCatch, MonadMask, MonadThrow)
14+ (MonadCatch, MonadThrow)
1515import Control.Monad.Error.Class
16− (MonadError, throwError)
16+ (MonadError)
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)
2523import GHC.Generics
2624 (Generic)
27−import Servant.Server.Internal.ServerError
28− (ServerError, errBody, err500)
25+import Servant.Server.Internal.ServantErr
26+ (ServantErr)
2927
30−newtype Handler a = Handler { runHandler' :: ExceptT ServerError IO a }
28+newtype Handler a = Handler { runHandler' :: ExceptT ServantErr IO a }
3129 deriving
3230 ( Functor, Applicative, Monad, MonadIO, Generic
33− , MonadError ServerError
34− , MonadThrow, MonadCatch, MonadMask
31+ , MonadError ServantErr
32+ , MonadThrow, MonadCatch
3533 )
3634
37−instance MonadFail Handler where
38− fail str = throwError err500 { errBody = fromString str }
39−
4035instance MonadBase IO Handler where
4136 liftBase = Handler . liftBase
4237
4338instance MonadBaseControl IO Handler where
44− type StM Handler a = Either ServerError a
39+ type StM Handler a = Either ServantErr a
4540
4641 -- liftBaseWith :: (RunInBase Handler IO -> IO a) -> Handler a
4742 liftBaseWith f = Handler (liftBaseWith (\g -> f (g . runHandler')))
@@ -49,5 +44,5 @@ instance MonadBaseControl IO Handler where
4944 -- restoreM :: StM Handler a -> Handler a
5045 restoreM st = Handler (restoreM st)
5146
52−runHandler :: Handler a -> IO (Either ServerError a)
47+runHandler :: Handler a -> IO (Either ServantErr a)
5348runHandler = runExceptT . runHandler'
servant-server/src/Servant/Server/Internal/RouteResult.hsdeleted−76
@@ -1,76 +0,0 @@
1−{-# LANGUAGE DeriveFunctor #-}
2−{-# LANGUAGE FlexibleInstances #-}
3−{-# LANGUAGE MultiParamTypeClasses #-}
4−{-# LANGUAGE TypeFamilies #-}
5−{-# LANGUAGE UndecidableInstances #-}
6−module Servant.Server.Internal.RouteResult where
7−
8−import Control.Monad
9− (ap, liftM)
10−import Control.Monad.Base
11− (MonadBase (..))
12−import Control.Monad.Catch
13− (MonadThrow (..))
14−import Control.Monad.Trans
15− (MonadIO (..), MonadTrans (..))
16−import Control.Monad.Trans.Control
17− (ComposeSt, MonadBaseControl (..), MonadTransControl (..),
18− defaultLiftBaseWith, defaultRestoreM)
19−
20−import Servant.Server.Internal.ServerError
21−
22−-- | The result of matching against a path in the route tree.
23−data RouteResult a =
24− Fail ServerError -- ^ Keep trying other paths.
25− -- The 'ServantError' should only be 404, 405 or 406.
26− | FailFatal !ServerError -- ^ Don't try other paths.
27− | Route !a
28− deriving (Eq, Show, Read, Functor)
29−
30−instance Applicative RouteResult where
31− pure = return
32− (<*>) = ap
33−
34−instance Monad RouteResult where
35− return = Route
36− Route a >>= f = f a
37− Fail e >>= _ = Fail e
38− FailFatal e >>= _ = FailFatal e
39−
40−newtype RouteResultT m a = RouteResultT { runRouteResultT :: m (RouteResult a) }
41− deriving (Functor)
42−
43−instance MonadTrans RouteResultT where
44− lift = RouteResultT . liftM Route
45−
46−instance (Functor m, Monad m) => Applicative (RouteResultT m) where
47− pure = return
48− (<*>) = ap
49−
50−instance Monad m => Monad (RouteResultT m) where
51− return = RouteResultT . return . Route
52− m >>= k = RouteResultT $ do
53− a <- runRouteResultT m
54− case a of
55− Fail e -> return $ Fail e
56− FailFatal e -> return $ FailFatal e
57− Route b -> runRouteResultT (k b)
58−
59−instance MonadIO m => MonadIO (RouteResultT m) where
60− liftIO = lift . liftIO
61−
62−instance MonadBase b m => MonadBase b (RouteResultT m) where
63− liftBase = lift . liftBase
64−
65−instance MonadBaseControl b m => MonadBaseControl b (RouteResultT m) where
66− type StM (RouteResultT m) a = ComposeSt RouteResultT m a
67− liftBaseWith = defaultLiftBaseWith
68− restoreM = defaultRestoreM
69−
70−instance MonadTransControl RouteResultT where
71− type StT RouteResultT a = RouteResult a
72− liftWith f = RouteResultT $ liftM return $ f runRouteResultT
73− restoreT = RouteResultT
74−
75−instance MonadThrow m => MonadThrow (RouteResultT m) where
76− throwM = lift . throwM
servant-server/src/Servant/Server/Internal/Router.hs+37−85
@@ -4,45 +4,20 @@
44{-# LANGUAGE OverloadedStrings #-}
55module Servant.Server.Internal.Router where
66
7−import Prelude ()
8−import Prelude.Compat
9−
10−import Data.Function
11− (on)
12−import Data.List
13− (nub)
147import Data.Map
158 (Map)
169import qualified Data.Map as M
10+import Data.Monoid
1711import Data.Text
1812 (Text)
1913import qualified Data.Text as T
20−import Data.Typeable
21− (TypeRep)
2214import Network.Wai
2315 (Response, pathInfo)
24−import Servant.Server.Internal.ErrorFormatter
25−import Servant.Server.Internal.RouteResult
2616import Servant.Server.Internal.RoutingApplication
27−import Servant.Server.Internal.ServerError
17+import Servant.Server.Internal.ServantErr
2818
2919type Router env = Router' env RoutingApplication
3020
31−-- | Holds information about pieces of url that are captured as variables.
32−data CaptureHint = CaptureHint
33− { captureName :: Text
34− -- ^ Holds the name of the captured variable
35− , captureType :: TypeRep
36− -- ^ Holds the type of the captured variable
37− }
38− deriving (Show, Eq)
39−
40−toCaptureTag :: CaptureHint -> Text
41−toCaptureTag hint = captureName hint <> "::" <> (T.pack . show) (captureType hint)
42−
43−toCaptureTags :: [CaptureHint] -> Text
44−toCaptureTags hints = "<" <> T.intercalate "|" (map toCaptureTag hints) <> ">"
45−
4621-- | Internal representation of a router.
4722--
4823-- The first argument describes an environment type that is
@@ -55,23 +30,12 @@ data Router' env a =
5530 -- ^ the map contains routers for subpaths (first path component used
5631 -- for lookup and removed afterwards), the list contains handlers
5732 -- for the empty path, to be tried in order
58− | CaptureRouter [CaptureHint] (Router' (Text, env) a)
33+ | CaptureRouter (Router' (Text, env) a)
5934 -- ^ first path component is passed to the child router in its
60− -- environment and removed afterwards.
61− -- The first argument is a list of hints for all variables that can be
62− -- captured by the router. The fact that it is a list is counter-intuitive,
63− -- because the 'Capture' combinator only allows to capture a single varible,
64− -- with a single name and a single type. However, the 'choice' smart
65− -- constructor may merge two 'Capture' combinators with different hints, thus
66− -- forcing the type to be '[CaptureHint]'.
67− -- Because 'CaptureRouter' is built from a 'Capture' combinator, the list of
68− -- hints should always be non-empty.
69− | CaptureAllRouter [CaptureHint] (Router' ([Text], env) a)
35+ -- environment and removed afterwards
36+ | CaptureAllRouter (Router' ([Text], env) a)
7037 -- ^ all path components are passed to the child router in its
7138 -- environment and are removed afterwards
72− -- The first argument is a hint for the list of variables that can be
73− -- captured by the router. Note that the 'captureType' field of the hint
74− -- should always be '[a]' for some 'a'.
7539 | RawRouter (env -> a)
7640 -- ^ to be used for routes we do not know anything about
7741 | Choice (Router' env a) (Router' env a)
@@ -99,8 +63,8 @@ leafRouter l = StaticRouter M.empty [l]
9963choice :: Router' env a -> Router' env a -> Router' env a
10064choice (StaticRouter table1 ls1) (StaticRouter table2 ls2) =
10165 StaticRouter (M.unionWith choice table1 table2) (ls1 ++ ls2)
102−choice (CaptureRouter hints1 router1) (CaptureRouter hints2 router2) =
103− CaptureRouter (nub $ hints1 ++ hints2) (choice router1 router2)
66+choice (CaptureRouter router1) (CaptureRouter router2) =
67+ CaptureRouter (choice router1 router2)
10468choice router1 (Choice router2 router3) = Choice (choice router1 router2) router3
10569choice router1 router2 = Choice router1 router2
10670
@@ -114,11 +78,7 @@ choice router1 router2 = Choice router1 router2
11478--
11579data RouterStructure =
11680 StaticRouterStructure (Map Text RouterStructure) Int
117− | CaptureRouterStructure [CaptureHint] RouterStructure
118− -- ^ The first argument holds information about variables
119− -- that are captured by the router. There may be several hints
120− -- if several routers have been aggregated by the 'choice'
121− -- smart constructor.
81+ | CaptureRouterStructure RouterStructure
12282 | RawRouterStructure
12383 | ChoiceStructure RouterStructure RouterStructure
12484 deriving (Eq, Show)
@@ -132,11 +92,11 @@ data RouterStructure =
13292routerStructure :: Router' env a -> RouterStructure
13393routerStructure (StaticRouter m ls) =
13494 StaticRouterStructure (fmap routerStructure m) (length ls)
135−routerStructure (CaptureRouter hints router) =
136− CaptureRouterStructure hints $
95+routerStructure (CaptureRouter router) =
96+ CaptureRouterStructure $
13797 routerStructure router
138−routerStructure (CaptureAllRouter hints router) =
139− CaptureRouterStructure hints $
98+routerStructure (CaptureAllRouter router) =
99+ CaptureRouterStructure $
140100 routerStructure router
141101routerStructure (RawRouter _) =
142102 RawRouterStructure
@@ -148,8 +108,8 @@ routerStructure (Choice r1 r2) =
148108-- | Compare the structure of two routers.
149109--
150110sameStructure :: Router' env a -> Router' env b -> Bool
151−sameStructure router1 router2 =
152− routerStructure router1 == routerStructure router2
111+sameStructure r1 r2 =
112+ routerStructure r1 == routerStructure r2
153113
154114-- | Provide a textual representation of the
155115-- structure of a router.
@@ -160,8 +120,7 @@ routerLayout router =
160120 where
161121 mkRouterLayout :: Bool -> RouterStructure -> [Text]
162122 mkRouterLayout c (StaticRouterStructure m n) = mkSubTrees c (M.toList m) n
163− mkRouterLayout c (CaptureRouterStructure hints r) =
164− mkSubTree c (toCaptureTags hints) (mkRouterLayout False r)
123+ mkRouterLayout c (CaptureRouterStructure r) = mkSubTree c "<capture>" (mkRouterLayout False r)
165124 mkRouterLayout c RawRouterStructure =
166125 if c then ["├─ <raw>"] else ["└─ <raw>"]
167126 mkRouterLayout c (ChoiceStructure r1 r2) =
@@ -189,52 +148,52 @@ tweakResponse :: (RouteResult Response -> RouteResult Response) -> Router env ->
189148tweakResponse f = fmap (\a -> \req cont -> a req (cont . f))
190149
191150-- | Interpret a router as an application.
192−runRouter :: NotFoundErrorFormatter -> Router () -> RoutingApplication
193−runRouter fmt r = runRouterEnv fmt r ()
151+runRouter :: Router () -> RoutingApplication
152+runRouter r = runRouterEnv r ()
194153
195−runRouterEnv :: NotFoundErrorFormatter -> Router env -> env -> RoutingApplication
196−runRouterEnv fmt router env request respond =
154+runRouterEnv :: Router env -> env -> RoutingApplication
155+runRouterEnv router env request respond =
197156 case router of
198157 StaticRouter table ls ->
199158 case pathInfo request of
200− [] -> runChoice fmt ls env request respond
159+ [] -> runChoice ls env request respond
201160 -- This case is to handle trailing slashes.
202− [""] -> runChoice fmt ls env request respond
161+ [""] -> runChoice ls env request respond
203162 first : rest | Just router' <- M.lookup first table
204163 -> let request' = request { pathInfo = rest }
205− in runRouterEnv fmt router' env request' respond
206− _ -> respond $ Fail $ fmt request
207− CaptureRouter _ router' ->
164+ in runRouterEnv router' env request' respond
165+ _ -> respond $ Fail err404
166+ CaptureRouter router' ->
208167 case pathInfo request of
209− [] -> respond $ Fail $ fmt request
168+ [] -> respond $ Fail err404
210169 -- This case is to handle trailing slashes.
211− [""] -> respond $ Fail $ fmt request
170+ [""] -> respond $ Fail err404
212171 first : rest
213172 -> let request' = request { pathInfo = rest }
214− in runRouterEnv fmt router' (first, env) request' respond
215− CaptureAllRouter _ router' ->
173+ in runRouterEnv router' (first, env) request' respond
174+ CaptureAllRouter router' ->
216175 let segments = pathInfo request
217176 request' = request { pathInfo = [] }
218− in runRouterEnv fmt router' (segments, env) request' respond
177+ in runRouterEnv router' (segments, env) request' respond
219178 RawRouter app ->
220179 app env request respond
221180 Choice r1 r2 ->
222− runChoice fmt [runRouterEnv fmt r1, runRouterEnv fmt r2] env request respond
181+ runChoice [runRouterEnv r1, runRouterEnv r2] env request respond
223182
224183-- | Try a list of routing applications in order.
225184-- We stop as soon as one fails fatally or succeeds.
226185-- If all fail normally, we pick the "best" error.
227186--
228−runChoice :: NotFoundErrorFormatter -> [env -> RoutingApplication] -> env -> RoutingApplication
229−runChoice fmt ls =
187+runChoice :: [env -> RoutingApplication] -> env -> RoutingApplication
188+runChoice ls =
230189 case ls of
231− [] -> \ _ request respond -> respond (Fail $ fmt request)
190+ [] -> \ _ _ respond -> respond (Fail err404)
232191 [r] -> r
233192 (r : rs) ->
234193 \ env request respond ->
235194 r env request $ \ response1 ->
236195 case response1 of
237− Fail _ -> runChoice fmt rs env request $ \ response2 ->
196+ Fail _ -> runChoice rs env request $ \ response2 ->
238197 respond $ highestPri response1 response2
239198 _ -> respond response1
240199 where
@@ -247,14 +206,7 @@ runChoice fmt ls =
247206
248207-- Priority on HTTP codes.
249208--
209+-- It just so happens that 404 < 405 < 406 as far as
210+-- we are concerned here, so we can use (<).
250211worseHTTPCode :: Int -> Int -> Bool
251−worseHTTPCode = on (<) toPriority
252− where
253− toPriority :: Int -> Int
254− toPriority 404 = 0 -- not found
255− toPriority 405 = 1 -- method not allowed
256− toPriority 401 = 2 -- unauthorized
257− toPriority 415 = 3 -- unsupported media type
258− toPriority 406 = 4 -- not acceptable
259− toPriority 400 = 6 -- bad request
260− toPriority _ = 5
212+worseHTTPCode = (<)
servant-server/src/Servant/Server/Internal/RoutingApplication.hs+383−4
@@ -1,20 +1,399 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DeriveFunctor #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE GADTs #-}
5+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE RecordWildCards #-}
8+{-# LANGUAGE TypeFamilies #-}
9+{-# LANGUAGE TypeOperators #-}
10+{-# LANGUAGE UndecidableInstances #-}
111module Servant.Server.Internal.RoutingApplication where
212
13+import Control.Monad
14+ (ap, liftM)
15+import Control.Monad.Base
16+ (MonadBase (..))
17+import Control.Monad.Catch
18+ (MonadThrow (..))
19+import Control.Monad.Reader
20+ (MonadReader (..), ReaderT (..), runReaderT)
21+import Control.Monad.Trans
22+ (MonadIO (..), MonadTrans (..))
23+import Control.Monad.Trans.Control
24+ (ComposeSt, MonadBaseControl (..), MonadTransControl (..),
25+ defaultLiftBaseWith, defaultRestoreM)
26+import Control.Monad.Trans.Resource
27+ (MonadResource (..), ResourceT, runInternalState,
28+ runResourceT, transResourceT, withInternalState)
329import Network.Wai
430 (Application, Request, Response, ResponseReceived)
531import Prelude ()
632import Prelude.Compat
7−import Servant.Server.Internal.RouteResult
8−import Servant.Server.Internal.ServerError
33+import Servant.Server.Internal.Handler
34+import Servant.Server.Internal.ServantErr
935
1036type RoutingApplication =
1137 Request -- ^ the request, the field 'pathInfo' may be modified by url routing
1238 -> (RouteResult Response -> IO ResponseReceived) -> IO ResponseReceived
1339
40+-- | The result of matching against a path in the route tree.
41+data RouteResult a =
42+ Fail ServantErr -- ^ Keep trying other paths. The @ServantErr@
43+ -- should only be 404, 405 or 406.
44+ | FailFatal !ServantErr -- ^ Don't try other paths.
45+ | Route !a
46+ deriving (Eq, Show, Read, Functor)
47+
48+instance Applicative RouteResult where
49+ pure = return
50+ (<*>) = ap
51+
52+instance Monad RouteResult where
53+ return = Route
54+ Route a >>= f = f a
55+ Fail e >>= _ = Fail e
56+ FailFatal e >>= _ = FailFatal e
57+
58+newtype RouteResultT m a = RouteResultT { runRouteResultT :: m (RouteResult a) }
59+ deriving (Functor)
60+
61+instance MonadTrans RouteResultT where
62+ lift = RouteResultT . liftM Route
63+
64+instance (Functor m, Monad m) => Applicative (RouteResultT m) where
65+ pure = return
66+ (<*>) = ap
67+
68+instance Monad m => Monad (RouteResultT m) where
69+ return = RouteResultT . return . Route
70+ m >>= k = RouteResultT $ do
71+ a <- runRouteResultT m
72+ case a of
73+ Fail e -> return $ Fail e
74+ FailFatal e -> return $ FailFatal e
75+ Route b -> runRouteResultT (k b)
76+
77+instance MonadIO m => MonadIO (RouteResultT m) where
78+ liftIO = lift . liftIO
79+
80+instance MonadBase b m => MonadBase b (RouteResultT m) where
81+ liftBase = lift . liftBase
82+
83+instance MonadBaseControl b m => MonadBaseControl b (RouteResultT m) where
84+ type StM (RouteResultT m) a = ComposeSt RouteResultT m a
85+ liftBaseWith = defaultLiftBaseWith
86+ restoreM = defaultRestoreM
87+
88+instance MonadTransControl RouteResultT where
89+ type StT RouteResultT a = RouteResult a
90+ liftWith f = RouteResultT $ liftM return $ f runRouteResultT
91+ restoreT = RouteResultT
92+
93+instance MonadThrow m => MonadThrow (RouteResultT m) where
94+ throwM = lift . throwM
95+
1496toApplication :: RoutingApplication -> Application
1597toApplication ra request respond = ra request routingRespond
1698 where
1799 routingRespond :: RouteResult Response -> IO ResponseReceived
18− routingRespond (Fail err) = respond $ responseServerError err
19− routingRespond (FailFatal err) = respond $ responseServerError err
100+ routingRespond (Fail err) = respond $ responseServantErr err
101+ routingRespond (FailFatal err) = respond $ responseServantErr err
20102 routingRespond (Route v) = respond v
103+
104+-- | A 'Delayed' is a representation of a handler with scheduled
105+-- delayed checks that can trigger errors.
106+--
107+-- Why would we want to delay checks?
108+--
109+-- There are two reasons:
110+--
111+-- 1. In a straight-forward implementation, the order in which we
112+-- perform checks will determine the error we generate. This is
113+-- because once an error occurs, we would abort and not perform
114+-- any subsequent checks, but rather return the current error.
115+--
116+-- This is not a necessity: we could continue doing other checks,
117+-- and choose the preferred error. However, that would in general
118+-- mean more checking, which leads us to the other reason.
119+--
120+-- 2. We really want to avoid doing certain checks too early. For
121+-- example, captures involve parsing, and are much more costly
122+-- than static route matches. In particular, if several paths
123+-- contain the "same" capture, we'd like as much as possible to
124+-- avoid trying the same parse many times. Also tricky is the
125+-- request body. Again, this involves parsing, but also, WAI makes
126+-- obtaining the request body a side-effecting operation. We
127+-- could/can work around this by manually caching the request body,
128+-- but we'd rather keep the number of times we actually try to
129+-- decode the request body to an absolute minimum.
130+--
131+-- We prefer to have the following relative priorities of error
132+-- codes:
133+--
134+-- @
135+-- 404
136+-- 405 (bad method)
137+-- 401 (unauthorized)
138+-- 415 (unsupported media type)
139+-- 406 (not acceptable)
140+-- 400 (bad request)
141+-- @
142+--
143+-- Therefore, while routing, we delay most checks so that they
144+-- will ultimately occur in the right order.
145+--
146+-- A 'Delayed' contains many delayed blocks of tests, and
147+-- the actual handler:
148+--
149+-- 1. Delayed captures. These can actually cause 404, and
150+-- while they're costly, they should be done first among the
151+-- delayed checks (at least as long as we do not decouple the
152+-- check order from the error reporting, see above). Delayed
153+-- captures can provide inputs to the actual handler.
154+--
155+-- 2. Method check(s). This can cause a 405. On success,
156+-- it does not provide an input for the handler. Method checks
157+-- are comparatively cheap.
158+--
159+-- 3. Authentication checks. This can cause 401.
160+--
161+-- 4. Accept and content type header checks. These checks
162+-- can cause 415 and 406 errors.
163+--
164+-- 5. Query parameter checks. They require parsing and can cause 400 if the
165+-- parsing fails. Query parameter checks provide inputs to the handler
166+--
167+-- 6. Header Checks. They also require parsing and can cause 400 if parsing fails.
168+--
169+-- 7. Body check. The request body check can cause 400.
170+--
171+data Delayed env c where
172+ Delayed :: { capturesD :: env -> DelayedIO captures
173+ , methodD :: DelayedIO ()
174+ , authD :: DelayedIO auth
175+ , acceptD :: DelayedIO ()
176+ , contentD :: DelayedIO contentType
177+ , paramsD :: DelayedIO params
178+ , headersD :: DelayedIO headers
179+ , bodyD :: contentType -> DelayedIO body
180+ , serverD :: captures
181+ -> params
182+ -> headers
183+ -> auth
184+ -> body
185+ -> Request
186+ -> RouteResult c
187+ } -> Delayed env c
188+
189+instance Functor (Delayed env) where
190+ fmap f Delayed{..} =
191+ Delayed
192+ { serverD = \ c p h a b req -> f <$> serverD c p h a b req
193+ , ..
194+ } -- Note [Existential Record Update]
195+
196+-- | Computations used in a 'Delayed' can depend on the
197+-- incoming 'Request', may perform 'IO, and result in a
198+-- 'RouteResult, meaning they can either suceed, fail
199+-- (with the possibility to recover), or fail fatally.
200+--
201+newtype DelayedIO a = DelayedIO { runDelayedIO' :: ReaderT Request (ResourceT (RouteResultT IO)) a }
202+ deriving
203+ ( Functor, Applicative, Monad
204+ , MonadIO, MonadReader Request
205+ , MonadThrow
206+ , MonadResource
207+ )
208+
209+instance MonadBase IO DelayedIO where
210+ liftBase = liftIO
211+
212+liftRouteResult :: RouteResult a -> DelayedIO a
213+liftRouteResult x = DelayedIO $ lift . lift $ RouteResultT . return $ x
214+
215+instance MonadBaseControl IO DelayedIO where
216+ -- type StM DelayedIO a = StM (ReaderT Request (ResourceT (RouteResultT IO))) a
217+ -- liftBaseWith f = DelayedIO $ liftBaseWith $ \g -> f (g . runDelayedIO')
218+ -- restoreM = DelayedIO . restoreM
219+
220+ type StM DelayedIO a = RouteResult a
221+ liftBaseWith f = DelayedIO $ ReaderT $ \req -> withInternalState $ \s ->
222+ liftBaseWith $ \runInBase -> f $ \x ->
223+ runInBase (runInternalState (runReaderT (runDelayedIO' x) req) s)
224+ restoreM = DelayedIO . lift . withInternalState . const . restoreM
225+
226+
227+runDelayedIO :: DelayedIO a -> Request -> ResourceT IO (RouteResult a)
228+runDelayedIO m req = transResourceT runRouteResultT $ runReaderT (runDelayedIO' m) req
229+
230+-- | A 'Delayed' without any stored checks.
231+emptyDelayed :: RouteResult a -> Delayed env a
232+emptyDelayed result =
233+ Delayed (const r) r r r r r r (const r) (\ _ _ _ _ _ _ -> result)
234+ where
235+ r = return ()
236+
237+-- | Fail with the option to recover.
238+delayedFail :: ServantErr -> DelayedIO a
239+delayedFail err = liftRouteResult $ Fail err
240+
241+-- | Fail fatally, i.e., without any option to recover.
242+delayedFailFatal :: ServantErr -> DelayedIO a
243+delayedFailFatal err = liftRouteResult $ FailFatal err
244+
245+-- | Gain access to the incoming request.
246+withRequest :: (Request -> DelayedIO a) -> DelayedIO a
247+withRequest f = do
248+ req <- ask
249+ f req
250+
251+-- | Add a capture to the end of the capture block.
252+addCapture :: Delayed env (a -> b)
253+ -> (captured -> DelayedIO a)
254+ -> Delayed (captured, env) b
255+addCapture Delayed{..} new =
256+ Delayed
257+ { capturesD = \ (txt, env) -> (,) <$> capturesD env <*> new txt
258+ , serverD = \ (x, v) p h a b req -> ($ v) <$> serverD x p h a b req
259+ , ..
260+ } -- Note [Existential Record Update]
261+
262+-- | Add a parameter check to the end of the params block
263+addParameterCheck :: Delayed env (a -> b)
264+ -> DelayedIO a
265+ -> Delayed env b
266+addParameterCheck Delayed {..} new =
267+ Delayed
268+ { paramsD = (,) <$> paramsD <*> new
269+ , serverD = \c (p, pNew) h a b req -> ($ pNew) <$> serverD c p h a b req
270+ , ..
271+ }
272+
273+-- | Add a parameter check to the end of the params block
274+addHeaderCheck :: Delayed env (a -> b)
275+ -> DelayedIO a
276+ -> Delayed env b
277+addHeaderCheck Delayed {..} new =
278+ Delayed
279+ { headersD = (,) <$> headersD <*> new
280+ , serverD = \c p (h, hNew) a b req -> ($ hNew) <$> serverD c p h a b req
281+ , ..
282+ }
283+
284+-- | Add a method check to the end of the method block.
285+addMethodCheck :: Delayed env a
286+ -> DelayedIO ()
287+ -> Delayed env a
288+addMethodCheck Delayed{..} new =
289+ Delayed
290+ { methodD = methodD <* new
291+ , ..
292+ } -- Note [Existential Record Update]
293+
294+-- | Add an auth check to the end of the auth block.
295+addAuthCheck :: Delayed env (a -> b)
296+ -> DelayedIO a
297+ -> Delayed env b
298+addAuthCheck Delayed{..} new =
299+ Delayed
300+ { authD = (,) <$> authD <*> new
301+ , serverD = \ c p h (y, v) b req -> ($ v) <$> serverD c p h y b req
302+ , ..
303+ } -- Note [Existential Record Update]
304+
305+-- | Add a content type and body checks around parameter checks.
306+--
307+-- We'll report failed content type check (415), before trying to parse
308+-- query parameters (400). Which, in turn, happens before request body parsing.
309+addBodyCheck :: Delayed env (a -> b)
310+ -> DelayedIO c -- ^ content type check
311+ -> (c -> DelayedIO a) -- ^ body check
312+ -> Delayed env b
313+addBodyCheck Delayed{..} newContentD newBodyD =
314+ Delayed
315+ { contentD = (,) <$> contentD <*> newContentD
316+ , bodyD = \(content, c) -> (,) <$> bodyD content <*> newBodyD c
317+ , serverD = \ c p h a (z, v) req -> ($ v) <$> serverD c p h a z req
318+ , ..
319+ } -- Note [Existential Record Update]
320+
321+
322+-- | Add an accept header check before handling parameters.
323+-- In principle, we'd like
324+-- to take a bad body (400) response take precedence over a
325+-- failed accept check (406). BUT to allow streaming the body,
326+-- we cannot run the body check and then still backtrack.
327+-- We therefore do the accept check before the body check,
328+-- when we can still backtrack. There are other solutions to
329+-- this, but they'd be more complicated (such as delaying the
330+-- body check further so that it can still be run in a situation
331+-- where we'd otherwise report 406).
332+addAcceptCheck :: Delayed env a
333+ -> DelayedIO ()
334+ -> Delayed env a
335+addAcceptCheck Delayed{..} new =
336+ Delayed
337+ { acceptD = acceptD *> new
338+ , ..
339+ } -- Note [Existential Record Update]
340+
341+-- | Many combinators extract information that is passed to
342+-- the handler without the possibility of failure. In such a
343+-- case, 'passToServer' can be used.
344+passToServer :: Delayed env (a -> b) -> (Request -> a) -> Delayed env b
345+passToServer Delayed{..} x =
346+ Delayed
347+ { serverD = \ c p h a b req -> ($ x req) <$> serverD c p h a b req
348+ , ..
349+ } -- Note [Existential Record Update]
350+
351+-- | Run a delayed server. Performs all scheduled operations
352+-- in order, and passes the results from the capture and body
353+-- blocks on to the actual handler.
354+--
355+-- This should only be called once per request; otherwise the guarantees about
356+-- effect and HTTP error ordering break down.
357+runDelayed :: Delayed env a
358+ -> env
359+ -> Request
360+ -> ResourceT IO (RouteResult a)
361+runDelayed Delayed{..} env = runDelayedIO $ do
362+ r <- ask
363+ c <- capturesD env
364+ methodD
365+ a <- authD
366+ acceptD
367+ content <- contentD
368+ p <- paramsD -- Has to be before body parsing, but after content-type checks
369+ h <- headersD
370+ b <- bodyD content
371+ liftRouteResult (serverD c p h a b r)
372+
373+-- | Runs a delayed server and the resulting action.
374+-- Takes a continuation that lets us send a response.
375+-- Also takes a continuation for how to turn the
376+-- result of the delayed server into a response.
377+runAction :: Delayed env (Handler a)
378+ -> env
379+ -> Request
380+ -> (RouteResult Response -> IO r)
381+ -> (a -> RouteResult Response)
382+ -> IO r
383+runAction action env req respond k = runResourceT $
384+ runDelayed action env req >>= go >>= liftIO . respond
385+ where
386+ go (Fail e) = return $ Fail e
387+ go (FailFatal e) = return $ FailFatal e
388+ go (Route a) = liftIO $ do
389+ e <- runHandler a
390+ case e of
391+ Left err -> return . Route $ responseServantErr err
392+ Right x -> return $! k x
393+
394+{- Note [Existential Record Update]
395+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
396+
397+Due to GHC issue <https://ghc.haskell.org/trac/ghc/ticket/2595 2595>, we cannot
398+do the more succint thing - just update the records we actually change.
399+-}
servant-server/src/Servant/Server/Internal/ServerError.hs → servant-server/src/Servant/Server/Internal/ServantErr.hsrenamed+74−76
@@ -1,7 +1,7 @@
11{-# LANGUAGE DeriveDataTypeable #-}
22{-# LANGUAGE OverloadedStrings #-}
33{-# LANGUAGE RecordWildCards #-}
4−module Servant.Server.Internal.ServerError where
4+module Servant.Server.Internal.ServantErr where
55
66import Control.Exception
77 (Exception)
@@ -13,18 +13,16 @@ import qualified Network.HTTP.Types as HTTP
1313import Network.Wai
1414 (Response, responseLBS)
1515
16−data ServerError = ServerError
17− { errHTTPCode :: Int
18− , errReasonPhrase :: String
19− , errBody :: LBS.ByteString
20− , errHeaders :: [HTTP.Header]
21− }
22− deriving (Show, Eq, Read, Typeable)
16+data ServantErr = ServantErr { errHTTPCode :: Int
17+ , errReasonPhrase :: String
18+ , errBody :: LBS.ByteString
19+ , errHeaders :: [HTTP.Header]
20+ } deriving (Show, Eq, Read, Typeable)
2321
24−instance Exception ServerError
22+instance Exception ServantErr
2523
26−responseServerError :: ServerError -> Response
27−responseServerError ServerError{..} = responseLBS status errHeaders errBody
24+responseServantErr :: ServantErr -> Response
25+responseServantErr ServantErr{..} = responseLBS status errHeaders errBody
2826 where
2927 status = HTTP.mkStatus errHTTPCode (BS.pack errReasonPhrase)
3028
@@ -35,8 +33,8 @@ responseServerError ServerError{..} = responseLBS status errHeaders errBody
3533-- > failingHandler :: Handler ()
3634-- > failingHandler = throwError $ err300 { errBody = "I can't choose." }
3735--
38−err300 :: ServerError
39−err300 = ServerError { errHTTPCode = 300
36+err300 :: ServantErr
37+err300 = ServantErr { errHTTPCode = 300
4038 , errReasonPhrase = "Multiple Choices"
4139 , errBody = ""
4240 , errHeaders = []
@@ -49,8 +47,8 @@ err300 = ServerError { errHTTPCode = 300
4947-- > failingHandler :: Handler ()
5048-- > failingHandler = throwError err301
5149--
52−err301 :: ServerError
53−err301 = ServerError { errHTTPCode = 301
50+err301 :: ServantErr
51+err301 = ServantErr { errHTTPCode = 301
5452 , errReasonPhrase = "Moved Permanently"
5553 , errBody = ""
5654 , errHeaders = []
@@ -63,8 +61,8 @@ err301 = ServerError { errHTTPCode = 301
6361-- > failingHandler :: Handler ()
6462-- > failingHandler = throwError err302
6563--
66−err302 :: ServerError
67−err302 = ServerError { errHTTPCode = 302
64+err302 :: ServantErr
65+err302 = ServantErr { errHTTPCode = 302
6866 , errReasonPhrase = "Found"
6967 , errBody = ""
7068 , errHeaders = []
@@ -77,8 +75,8 @@ err302 = ServerError { errHTTPCode = 302
7775-- > failingHandler :: Handler ()
7876-- > failingHandler = throwError err303
7977--
80−err303 :: ServerError
81−err303 = ServerError { errHTTPCode = 303
78+err303 :: ServantErr
79+err303 = ServantErr { errHTTPCode = 303
8280 , errReasonPhrase = "See Other"
8381 , errBody = ""
8482 , errHeaders = []
@@ -91,8 +89,8 @@ err303 = ServerError { errHTTPCode = 303
9189-- > failingHandler :: Handler ()
9290-- > failingHandler = throwError err304
9391--
94−err304 :: ServerError
95−err304 = ServerError { errHTTPCode = 304
92+err304 :: ServantErr
93+err304 = ServantErr { errHTTPCode = 304
9694 , errReasonPhrase = "Not Modified"
9795 , errBody = ""
9896 , errHeaders = []
@@ -105,8 +103,8 @@ err304 = ServerError { errHTTPCode = 304
105103-- > failingHandler :: Handler ()
106104-- > failingHandler = throwError err305
107105--
108−err305 :: ServerError
109−err305 = ServerError { errHTTPCode = 305
106+err305 :: ServantErr
107+err305 = ServantErr { errHTTPCode = 305
110108 , errReasonPhrase = "Use Proxy"
111109 , errBody = ""
112110 , errHeaders = []
@@ -119,8 +117,8 @@ err305 = ServerError { errHTTPCode = 305
119117-- > failingHandler :: Handler ()
120118-- > failingHandler = throwError err307
121119--
122−err307 :: ServerError
123−err307 = ServerError { errHTTPCode = 307
120+err307 :: ServantErr
121+err307 = ServantErr { errHTTPCode = 307
124122 , errReasonPhrase = "Temporary Redirect"
125123 , errBody = ""
126124 , errHeaders = []
@@ -133,8 +131,8 @@ err307 = ServerError { errHTTPCode = 307
133131-- > failingHandler :: Handler ()
134132-- > failingHandler = throwError $ err400 { errBody = "Your request makes no sense to me." }
135133--
136−err400 :: ServerError
137−err400 = ServerError { errHTTPCode = 400
134+err400 :: ServantErr
135+err400 = ServantErr { errHTTPCode = 400
138136 , errReasonPhrase = "Bad Request"
139137 , errBody = ""
140138 , errHeaders = []
@@ -147,8 +145,8 @@ err400 = ServerError { errHTTPCode = 400
147145-- > failingHandler :: Handler ()
148146-- > failingHandler = throwError $ err401 { errBody = "Your credentials are invalid." }
149147--
150−err401 :: ServerError
151−err401 = ServerError { errHTTPCode = 401
148+err401 :: ServantErr
149+err401 = ServantErr { errHTTPCode = 401
152150 , errReasonPhrase = "Unauthorized"
153151 , errBody = ""
154152 , errHeaders = []
@@ -161,8 +159,8 @@ err401 = ServerError { errHTTPCode = 401
161159-- > failingHandler :: Handler ()
162160-- > failingHandler = throwError $ err402 { errBody = "You have 0 credits. Please give me $$$." }
163161--
164−err402 :: ServerError
165−err402 = ServerError { errHTTPCode = 402
162+err402 :: ServantErr
163+err402 = ServantErr { errHTTPCode = 402
166164 , errReasonPhrase = "Payment Required"
167165 , errBody = ""
168166 , errHeaders = []
@@ -175,8 +173,8 @@ err402 = ServerError { errHTTPCode = 402
175173-- > failingHandler :: Handler ()
176174-- > failingHandler = throwError $ err403 { errBody = "Please login first." }
177175--
178−err403 :: ServerError
179−err403 = ServerError { errHTTPCode = 403
176+err403 :: ServantErr
177+err403 = ServantErr { errHTTPCode = 403
180178 , errReasonPhrase = "Forbidden"
181179 , errBody = ""
182180 , errHeaders = []
@@ -187,10 +185,10 @@ err403 = ServerError { errHTTPCode = 403
187185-- Example:
188186--
189187-- > failingHandler :: Handler ()
190−-- > failingHandler = throwError $ err404 { errBody = "Are you lost?" }
188+-- > failingHandler = throwError $ err404 { errBody = "(╯°□°）╯︵ ┻━┻)." }
191189--
192−err404 :: ServerError
193−err404 = ServerError { errHTTPCode = 404
190+err404 :: ServantErr
191+err404 = ServantErr { errHTTPCode = 404
194192 , errReasonPhrase = "Not Found"
195193 , errBody = ""
196194 , errHeaders = []
@@ -203,8 +201,8 @@ err404 = ServerError { errHTTPCode = 404
203201-- > failingHandler :: Handler ()
204202-- > failingHandler = throwError $ err405 { errBody = "Your account privileges does not allow for this. Please pay $$$." }
205203--
206−err405 :: ServerError
207−err405 = ServerError { errHTTPCode = 405
204+err405 :: ServantErr
205+err405 = ServantErr { errHTTPCode = 405
208206 , errReasonPhrase = "Method Not Allowed"
209207 , errBody = ""
210208 , errHeaders = []
@@ -217,8 +215,8 @@ err405 = ServerError { errHTTPCode = 405
217215-- > failingHandler :: Handler ()
218216-- > failingHandler = throwError err406
219217--
220−err406 :: ServerError
221−err406 = ServerError { errHTTPCode = 406
218+err406 :: ServantErr
219+err406 = ServantErr { errHTTPCode = 406
222220 , errReasonPhrase = "Not Acceptable"
223221 , errBody = ""
224222 , errHeaders = []
@@ -231,8 +229,8 @@ err406 = ServerError { errHTTPCode = 406
231229-- > failingHandler :: Handler ()
232230-- > failingHandler = throwError err407
233231--
234−err407 :: ServerError
235−err407 = ServerError { errHTTPCode = 407
232+err407 :: ServantErr
233+err407 = ServantErr { errHTTPCode = 407
236234 , errReasonPhrase = "Proxy Authentication Required"
237235 , errBody = ""
238236 , errHeaders = []
@@ -245,8 +243,8 @@ err407 = ServerError { errHTTPCode = 407
245243-- > failingHandler :: Handler ()
246244-- > failingHandler = throwError $ err409 { errBody = "Transaction conflicts with 59879cb56c7c159231eeacdd503d755f7e835f74" }
247245--
248−err409 :: ServerError
249−err409 = ServerError { errHTTPCode = 409
246+err409 :: ServantErr
247+err409 = ServantErr { errHTTPCode = 409
250248 , errReasonPhrase = "Conflict"
251249 , errBody = ""
252250 , errHeaders = []
@@ -259,8 +257,8 @@ err409 = ServerError { errHTTPCode = 409
259257-- > failingHandler :: Handler ()
260258-- > failingHandler = throwError $ err410 { errBody = "I know it was here at some point, but.. I blame bad luck." }
261259--
262−err410 :: ServerError
263−err410 = ServerError { errHTTPCode = 410
260+err410 :: ServantErr
261+err410 = ServantErr { errHTTPCode = 410
264262 , errReasonPhrase = "Gone"
265263 , errBody = ""
266264 , errHeaders = []
@@ -273,8 +271,8 @@ err410 = ServerError { errHTTPCode = 410
273271-- > failingHandler :: Handler ()
274272-- > failingHandler = throwError err411
275273--
276−err411 :: ServerError
277−err411 = ServerError { errHTTPCode = 411
274+err411 :: ServantErr
275+err411 = ServantErr { errHTTPCode = 411
278276 , errReasonPhrase = "Length Required"
279277 , errBody = ""
280278 , errHeaders = []
@@ -287,8 +285,8 @@ err411 = ServerError { errHTTPCode = 411
287285-- > failingHandler :: Handler ()
288286-- > failingHandler = throwError $ err412 { errBody = "Precondition fail: x < 42 && y > 57" }
289287--
290−err412 :: ServerError
291−err412 = ServerError { errHTTPCode = 412
288+err412 :: ServantErr
289+err412 = ServantErr { errHTTPCode = 412
292290 , errReasonPhrase = "Precondition Failed"
293291 , errBody = ""
294292 , errHeaders = []
@@ -301,8 +299,8 @@ err412 = ServerError { errHTTPCode = 412
301299-- > failingHandler :: Handler ()
302300-- > failingHandler = throwError $ err413 { errBody = "Request exceeded 64k." }
303301--
304−err413 :: ServerError
305−err413 = ServerError { errHTTPCode = 413
302+err413 :: ServantErr
303+err413 = ServantErr { errHTTPCode = 413
306304 , errReasonPhrase = "Request Entity Too Large"
307305 , errBody = ""
308306 , errHeaders = []
@@ -315,8 +313,8 @@ err413 = ServerError { errHTTPCode = 413
315313-- > failingHandler :: Handler ()
316314-- > failingHandler = throwError $ err414 { errBody = "Maximum length is 64." }
317315--
318−err414 :: ServerError
319−err414 = ServerError { errHTTPCode = 414
316+err414 :: ServantErr
317+err414 = ServantErr { errHTTPCode = 414
320318 , errReasonPhrase = "Request-URI Too Large"
321319 , errBody = ""
322320 , errHeaders = []
@@ -329,8 +327,8 @@ err414 = ServerError { errHTTPCode = 414
329327-- > failingHandler :: Handler ()
330328-- > failingHandler = throwError $ err415 { errBody = "Supported media types: gif, png" }
331329--
332−err415 :: ServerError
333−err415 = ServerError { errHTTPCode = 415
330+err415 :: ServantErr
331+err415 = ServantErr { errHTTPCode = 415
334332 , errReasonPhrase = "Unsupported Media Type"
335333 , errBody = ""
336334 , errHeaders = []
@@ -343,8 +341,8 @@ err415 = ServerError { errHTTPCode = 415
343341-- > failingHandler :: Handler ()
344342-- > failingHandler = throwError $ err416 { errBody = "Valid range is [0, 424242]." }
345343--
346−err416 :: ServerError
347−err416 = ServerError { errHTTPCode = 416
344+err416 :: ServantErr
345+err416 = ServantErr { errHTTPCode = 416
348346 , errReasonPhrase = "Request range not satisfiable"
349347 , errBody = ""
350348 , errHeaders = []
@@ -357,8 +355,8 @@ err416 = ServerError { errHTTPCode = 416
357355-- > failingHandler :: Handler ()
358356-- > failingHandler = throwError $ err417 { errBody = "I found a quux in the request. This isn't going to work." }
359357--
360−err417 :: ServerError
361−err417 = ServerError { errHTTPCode = 417
358+err417 :: ServantErr
359+err417 = ServantErr { errHTTPCode = 417
362360 , errReasonPhrase = "Expectation Failed"
363361 , errBody = ""
364362 , errHeaders = []
@@ -371,8 +369,8 @@ err417 = ServerError { errHTTPCode = 417
371369-- > failingHandler :: Handler ()
372370-- > failingHandler = throwError $ err418 { errBody = "Apologies, this is not a webserver but a teapot." }
373371--
374−err418 :: ServerError
375−err418 = ServerError { errHTTPCode = 418
372+err418 :: ServantErr
373+err418 = ServantErr { errHTTPCode = 418
376374 , errReasonPhrase = "I'm a teapot"
377375 , errBody = ""
378376 , errHeaders = []
@@ -385,8 +383,8 @@ err418 = ServerError { errHTTPCode = 418
385383-- > failingHandler :: Handler ()
386384-- > failingHandler = throwError $ err422 { errBody = "I understood your request, but can't process it." }
387385--
388−err422 :: ServerError
389−err422 = ServerError { errHTTPCode = 422
386+err422 :: ServantErr
387+err422 = ServantErr { errHTTPCode = 422
390388 , errReasonPhrase = "Unprocessable Entity"
391389 , errBody = ""
392390 , errHeaders = []
@@ -399,8 +397,8 @@ err422 = ServerError { errHTTPCode = 422
399397-- > failingHandler :: Handler ()
400398-- > failingHandler = throwError $ err500 { errBody = "Exception in module A.B.C:55. Have a great day!" }
401399--
402−err500 :: ServerError
403−err500 = ServerError { errHTTPCode = 500
400+err500 :: ServantErr
401+err500 = ServantErr { errHTTPCode = 500
404402 , errReasonPhrase = "Internal Server Error"
405403 , errBody = ""
406404 , errHeaders = []
@@ -413,8 +411,8 @@ err500 = ServerError { errHTTPCode = 500
413411-- > failingHandler :: Handler ()
414412-- > failingHandler = throwError $ err501 { errBody = "/v1/foo is not supported with quux in the request." }
415413--
416−err501 :: ServerError
417−err501 = ServerError { errHTTPCode = 501
414+err501 :: ServantErr
415+err501 = ServantErr { errHTTPCode = 501
418416 , errReasonPhrase = "Not Implemented"
419417 , errBody = ""
420418 , errHeaders = []
@@ -427,8 +425,8 @@ err501 = ServerError { errHTTPCode = 501
427425-- > failingHandler :: Handler ()
428426-- > failingHandler = throwError $ err502 { errBody = "Tried gateway foo, bar, and baz. None responded." }
429427--
430−err502 :: ServerError
431−err502 = ServerError { errHTTPCode = 502
428+err502 :: ServantErr
429+err502 = ServantErr { errHTTPCode = 502
432430 , errReasonPhrase = "Bad Gateway"
433431 , errBody = ""
434432 , errHeaders = []
@@ -441,8 +439,8 @@ err502 = ServerError { errHTTPCode = 502
441439-- > failingHandler :: Handler ()
442440-- > failingHandler = throwError $ err503 { errBody = "We're rewriting in PHP." }
443441--
444−err503 :: ServerError
445−err503 = ServerError { errHTTPCode = 503
442+err503 :: ServantErr
443+err503 = ServantErr { errHTTPCode = 503
446444 , errReasonPhrase = "Service Unavailable"
447445 , errBody = ""
448446 , errHeaders = []
@@ -455,8 +453,8 @@ err503 = ServerError { errHTTPCode = 503
455453-- > failingHandler :: Handler ()
456454-- > failingHandler = throwError $ err504 { errBody = "Backend foobar did not respond in 5 seconds." }
457455--
458−err504 :: ServerError
459−err504 = ServerError { errHTTPCode = 504
456+err504 :: ServantErr
457+err504 = ServantErr { errHTTPCode = 504
460458 , errReasonPhrase = "Gateway Time-out"
461459 , errBody = ""
462460 , errHeaders = []
@@ -469,8 +467,8 @@ err504 = ServerError { errHTTPCode = 504
469467-- > failingHandler :: Handler ()
470468-- > failingHandler = throwError $ err505 { errBody = "I support HTTP/4.0 only." }
471469--
472−err505 :: ServerError
473−err505 = ServerError { errHTTPCode = 505
470+err505 :: ServantErr
471+err505 = ServantErr { errHTTPCode = 505
474472 , errReasonPhrase = "HTTP Version not supported"
475473 , errBody = ""
476474 , errHeaders = []
servant-server/src/Servant/Server/UVerb.hsdeleted−116
@@ -1,116 +0,0 @@
1−{-# LANGUAGE ConstraintKinds #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE FlexibleContexts #-}
4−{-# LANGUAGE FlexibleInstances #-}
5−{-# LANGUAGE InstanceSigs #-}
6−{-# LANGUAGE KindSignatures #-}
7−{-# LANGUAGE MultiParamTypeClasses #-}
8−{-# LANGUAGE OverloadedStrings #-}
9−{-# LANGUAGE RankNTypes #-}
10−{-# LANGUAGE ScopedTypeVariables #-}
11−{-# LANGUAGE TypeApplications #-}
12−{-# LANGUAGE TypeFamilies #-}
13−{-# LANGUAGE TypeOperators #-}
14−{-# LANGUAGE UndecidableInstances #-}
15−
16−{-# OPTIONS_GHC -Wno-orphans #-}
17−{-# OPTIONS_GHC -Wno-redundant-constraints #-}
18−
19−module Servant.Server.UVerb
20− ( respond,
21− IsServerResource,
22− )
23−where
24−
25−import qualified Data.ByteString as B
26−import Data.Proxy (Proxy (Proxy))
27−import Data.SOP (I (I))
28−import Data.SOP.Constraint (All, And)
29−import Data.String.Conversions (LBS, cs)
30−import Network.HTTP.Types (Status, HeaderName, hContentType)
31−import Network.Wai (responseLBS, Request)
32−import Servant.API (ReflectMethod, reflectMethod)
33−import Servant.API.ContentTypes (AllCTRender (handleAcceptH), AllMime)
34−import Servant.API.ResponseHeaders (GetHeaders (..), Headers (..))
35−import Servant.API.UVerb (HasStatus, IsMember, Statuses, UVerb, Union, Unique, WithStatus (..), foldMapUnion, inject, statusOf)
36−import Servant.Server.Internal (Context, Delayed, Handler, HasServer (..), RouteResult (FailFatal, Route), Router, Server, ServerT, acceptCheck, addAcceptCheck, addMethodCheck, allowedMethodHead, err406, getAcceptHeader, leafRouter, methodCheck, runAction)
37−
38−
39−-- | 'return' for 'UVerb' handlers. Takes a value of any of the members of the open union,
40−-- and will construct a union value in an 'Applicative' (eg. 'Server').
41−respond ::
42− forall (x :: *) (xs :: [*]) (f :: * -> *).
43− (Applicative f, HasStatus x, IsMember x xs) =>
44− x ->
45− f (Union xs)
46−respond = pure . inject . I
47−
48−class IsServerResource (cts :: [*]) a where
49− resourceResponse :: Request -> Proxy cts -> a -> Maybe (LBS, LBS)
50− resourceHeaders :: Proxy cts -> a -> [(HeaderName, B.ByteString)]
51−
52−instance {-# OVERLAPPABLE #-} AllCTRender cts a
53− => IsServerResource cts a where
54− resourceResponse request p res = handleAcceptH p (getAcceptHeader request) res
55− resourceHeaders _ _ = []
56−
57−instance {-# OVERLAPPING #-} (IsServerResource cts a, GetHeaders (Headers h a))
58− => IsServerResource cts (Headers h a) where
59− resourceResponse request p res = resourceResponse request p (getResponse res)
60− resourceHeaders cts res = getHeaders res ++ resourceHeaders cts (getResponse res)
61−
62−instance {-# OVERLAPPING #-} IsServerResource cts a
63− => IsServerResource cts (WithStatus n a) where
64− resourceResponse request p (WithStatus x) = resourceResponse request p x
65− resourceHeaders cts (WithStatus x) = resourceHeaders cts x
66−
67−encodeResource :: forall a cts . (IsServerResource cts a, HasStatus a)
68− => Request -> Proxy cts -> a
69− -> (Status, Maybe (LBS, LBS), [(HeaderName, B.ByteString)])
70−encodeResource request cts res = (statusOf (Proxy @a),
71− resourceResponse request cts res,
72− resourceHeaders cts res)
73−
74−type IsServerResourceWithStatus cts = IsServerResource cts `And` HasStatus
75−
76−instance
77− ( ReflectMethod method,
78− AllMime contentTypes,
79− All (IsServerResourceWithStatus contentTypes) as,
80− Unique (Statuses as) -- for consistency with servant-swagger (server would work fine
81− -- without; client is a bit of a corner case, because it dispatches
82− -- the parser based on the status code. with this uniqueness
83− -- constraint it won't have to run more than one parser in weird
84− -- corner cases.
85− ) =>
86− HasServer (UVerb method contentTypes as) context
87− where
88− type ServerT (UVerb method contentTypes as) m = m (Union as)
89−
90− hoistServerWithContext _ _ nt s = nt s
91−
92− route ::
93− forall env.
94− Proxy (UVerb method contentTypes as) ->
95− Context context ->
96− Delayed env (Server (UVerb method contentTypes as)) ->
97− Router env
98− route _proxy _ctx action = leafRouter route'
99− where
100− method = reflectMethod (Proxy @method)
101− route' env request cont = do
102− let action' :: Delayed env (Handler (Union as))
103− action' =
104− action
105− `addMethodCheck` methodCheck method request
106− `addAcceptCheck` acceptCheck (Proxy @contentTypes) (getAcceptHeader request)
107−
108− runAction action' env request cont $ \(output :: Union as) -> do
109− let cts = Proxy @contentTypes
110− pickResource :: Union as -> (Status, Maybe (LBS, LBS), [(HeaderName, B.ByteString)])
111− pickResource = foldMapUnion (Proxy @(IsServerResourceWithStatus contentTypes)) (encodeResource request cts)
112− case pickResource output of
113− (_, Nothing, _) -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does
114− (status, Just (contentT, body), headers) ->
115− let bdy = if allowedMethodHead method request then "" else body
116− in Route $ responseLBS status ((hContentType, cs contentT) : headers) bdy
servant-server/test/Servant/Server/ErrorSpec.hs+2−58

This diff is too big to show here.

servant-server/test/Servant/Server/Internal/ContextSpec.hs+1−1

This diff is too big to show here.

servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs+3−3

This diff is too big to show here.

servant-server/test/Servant/Server/RouterSpec.hs+16−162

This diff is too big to show here.

servant-server/test/Servant/ServerSpec.hs+140−356

This diff is too big to show here.

servant-server/test/doctests.hsnew file+27

This diff is too big to show here.

servant-server/tinc.yamlnew file+3

This diff is too big to show here.

servant-swagger/CHANGELOG.mddeleted−143

This diff is too big to show here.

servant-swagger/LICENSEdeleted−28

This diff is too big to show here.

servant-swagger/README.mddeleted−46

This diff is too big to show here.

servant-swagger/Setup.hsdeleted−33

This diff is too big to show here.

servant-swagger/example/LICENSEdeleted−28

This diff is too big to show here.

servant-swagger/example/example.cabaldeleted−62

This diff is too big to show here.

servant-swagger/example/server/Main.hsdeleted−11

This diff is too big to show here.

servant-swagger/example/src/Todo.hsdeleted−73

This diff is too big to show here.

servant-swagger/example/swagger.jsondeleted−158

This diff is too big to show here.

servant-swagger/example/test/Spec.hsdeleted−1

This diff is too big to show here.

servant-swagger/example/test/TodoSpec.hsdeleted−28

This diff is too big to show here.

servant-swagger/servant-swagger.cabaldeleted−127

This diff is too big to show here.

servant-swagger/src/Servant/Swagger.hsdeleted−188

This diff is too big to show here.

servant-swagger/src/Servant/Swagger/Internal.hsdeleted−492

This diff is too big to show here.

servant-swagger/src/Servant/Swagger/Internal/Orphans.hsdeleted−27

This diff is too big to show here.

servant-swagger/src/Servant/Swagger/Internal/Test.hsdeleted−207

This diff is too big to show here.

servant-swagger/src/Servant/Swagger/Internal/TypeLevel.hsdeleted−9

This diff is too big to show here.

servant-swagger/src/Servant/Swagger/Internal/TypeLevel/API.hsdeleted−86

This diff is too big to show here.

servant-swagger/src/Servant/Swagger/Internal/TypeLevel/Every.hsdeleted−63

This diff is too big to show here.

servant-swagger/src/Servant/Swagger/Internal/TypeLevel/TMap.hsdeleted−37

This diff is too big to show here.

servant-swagger/src/Servant/Swagger/Test.hsdeleted−13

This diff is too big to show here.

servant-swagger/src/Servant/Swagger/TypeLevel.hsdeleted−15

This diff is too big to show here.

servant-swagger/test/Servant/SwaggerSpec.hsdeleted−489

This diff is too big to show here.

servant-swagger/test/Spec.hsdeleted−1

This diff is too big to show here.

servant-swagger/test/doctests.hsdeleted−12

This diff is too big to show here.

servant/CHANGELOG.md+11−541

This diff is too big to show here.

servant/LICENSE+1−1

This diff is too big to show here.

servant/Setup.hs+32−1

This diff is too big to show here.

servant/servant.cabal+73−73

This diff is too big to show here.

servant/src/Servant/API.hs+13−33

This diff is too big to show here.

servant/src/Servant/API/Alternative.hs+2

This diff is too big to show here.

servant/src/Servant/API/ContentTypes.hs+3−7

This diff is too big to show here.

servant/src/Servant/API/Description.hs+2−2

This diff is too big to show here.

servant/src/Servant/API/Fragment.hsdeleted−25

This diff is too big to show here.

servant/src/Servant/API/Header.hs+1−1

This diff is too big to show here.

servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hsnew file+50

This diff is too big to show here.

servant/src/Servant/API/Modifiers.hs+2

This diff is too big to show here.

servant/src/Servant/API/NamedRoutes.hsdeleted−10

This diff is too big to show here.

servant/src/Servant/API/Raw.hs+2−6

This diff is too big to show here.

servant/src/Servant/API/ResponseHeaders.hs+9−86

This diff is too big to show here.

servant/src/Servant/API/Status.hsdeleted−160

This diff is too big to show here.

servant/src/Servant/API/Stream.hs+173−195

This diff is too big to show here.

servant/src/Servant/API/TypeErrors.hsdeleted−40

This diff is too big to show here.

servant/src/Servant/API/TypeLevel.hs+13−63

This diff is too big to show here.

servant/src/Servant/API/UVerb.hsdeleted−127

This diff is too big to show here.

servant/src/Servant/API/UVerb/Union.hsdeleted−147

This diff is too big to show here.

servant/src/Servant/API/Verbs.hs+6−13

This diff is too big to show here.

servant/src/Servant/API/WithResource.hsdeleted−3

This diff is too big to show here.

servant/src/Servant/Links.hs+16−122

This diff is too big to show here.

servant/src/Servant/Test/ComprehensiveAPI.hsdeleted−81

This diff is too big to show here.

servant/src/Servant/Types/SourceT.hsdeleted−384

This diff is too big to show here.

servant/src/Servant/Utils/Links.hsnew file+6

This diff is too big to show here.

servant/test/Servant/API/ContentTypesSpec.hs+6−31

This diff is too big to show here.

servant/test/Servant/API/ResponseHeadersSpec.hs−11

This diff is too big to show here.

servant/test/Servant/API/StreamSpec.hsdeleted−99

This diff is too big to show here.

servant/test/Servant/LinksSpec.hs+3−20

This diff is too big to show here.

servant/test/doctests.hsnew file+27

This diff is too big to show here.

stack.yaml+10−9

This diff is too big to show here.

stack.yaml.lockdeleted−19

This diff is too big to show here.

streaming-benchmark.shdeleted−268

This diff is too big to show here.