git.iko.soy/servant
on 52f27de help sign in
aaeee88
swap
0 ahead, 768 behind
.github/FUNDING.ymldeleted−12
since splitsnapshots
unifiedsplit
@@ -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 @@
1**/*/dist
1**/*/dist
2−*~
3−dist-*
2+dist-newstyle
4.ghc.environment.*
3.ghc.environment.*
5/bin
4/bin
6/lib
5/lib
@@ -30,11 +29,3 @@ doc/_build
30doc/venv
29doc/venv
31doc/tutorial/static/api.js
30doc/tutorial/static/api.js
32doc/tutorial/static/jq.js
31doc/tutorial/static/jq.js
33−shell.nix
34−.hspec-failures
35−
36−# nix
37−result*
38−
39−# local versions of things
40−servant-multipart
.stylish-haskell.yaml+5−118
@@ -15,14 +15,6 @@ steps:
15 # # true.
15 # # true.
16 # add_language_pragma: true
16 # add_language_pragma: true
17
17
18− # Align the right hand side of some elements. This is quite conservative
19− # and only applies to statements where each element occupies a single
20− # line.
21− - simple_align:
22− cases: false
23− top_level_patterns: false
24− records: false
25−
26 # Import cleanup
18 # Import cleanup
27 - imports:
19 - imports:
28 # There are different ways we can align names and lists.
20 # There are different ways we can align names and lists.
@@ -41,91 +33,6 @@ steps:
41 # Default: global.
33 # Default: global.
42 align: global
34 align: global
43
35
44− # Folowing options affect only import list alignment.
45− #
46− # List align has following options:
47− #
48− # - after_alias: Import list is aligned with end of import including
49− # 'as' and 'hiding' keywords.
50− #
51− # > import qualified Data.List as List (concat, foldl, foldr, head,
52− # > init, last, length)
53− #
54− # - with_alias: Import list is aligned with start of alias or hiding.
55− #
56− # > import qualified Data.List as List (concat, foldl, foldr, head,
57− # > init, last, length)
58− #
59− # - new_line: Import list starts always on new line.
60− #
61− # > import qualified Data.List as List
62− # > (concat, foldl, foldr, head, init, last, length)
63− #
64− # Default: after_alias
65− list_align: new_line
66−
67− # Long list align style takes effect when import is too long. This is
68− # determined by 'columns' setting.
69− #
70− # - inline: This option will put as much specs on same line as possible.
71− #
72− # - new_line: Import list will start on new line.
73− #
74− # - new_line_multiline: Import list will start on new line when it's
75− # short enough to fit to single line. Otherwise it'll be multiline.
76− #
77− # - multiline: One line per import list entry.
78− # Type with contructor list acts like single import.
79− #
80− # > import qualified Data.Map as M
81− # > ( empty
82− # > , singleton
83− # > , ...
84− # > , delete
85− # > )
86− #
87− # Default: inline
88− long_list_align: new_line
89−
90− # Align empty list (importing instances)
91− #
92− # Empty list align has following options
93− #
94− # - inherit: inherit list_align setting
95− #
96− # - right_after: () is right after the module name:
97− #
98− # > import Vector.Instances ()
99− #
100− # Default: inherit
101− empty_list_align: right_after
102−
103− # List padding determines indentation of import list on lines after import.
104− # This option affects 'long_list_align'.
105− #
106− # - <integer>: constant value
107− #
108− # - module_name: align under start of module name.
109− # Useful for 'file' and 'group' align settings.
110− list_padding: module_name
111−
112− # Separate lists option affects formating of import list for type
113− # or class. The only difference is single space between type and list
114− # of constructors, selectors and class functions.
115− #
116− # - true: There is single space between Foldable type and list of it's
117− # functions.
118− #
119− # > import Data.Foldable (Foldable (fold, foldl, foldMap))
120− #
121− # - false: There is no space between Foldable type and list of it's
122− # functions.
123− #
124− # > import Data.Foldable (Foldable(fold, foldl, foldMap))
125− #
126− # Default: true
127− separate_lists: true
128−
129 # Language pragmas
36 # Language pragmas
130 - language_pragmas:
37 - language_pragmas:
131 # We can generate different styles of language pragma lists.
38 # We can generate different styles of language pragma lists.
@@ -140,20 +47,13 @@ steps:
140 # Default: vertical.
47 # Default: vertical.
141 style: vertical
48 style: vertical
142
49
143− # Align affects alignment of closing pragma brackets.
144− #
145− # - true: Brackets are aligned in same collumn.
146− #
147− # - false: Brackets are not aligned together. There is only one space
148− # between actual import and closing bracket.
149− #
150− # Default: true
151− align: true
152−
153 # stylish-haskell can detect redundancy of some language pragmas. If this
50 # stylish-haskell can detect redundancy of some language pragmas. If this
154 # is set to true, it will remove those redundant pragmas. Default: true.
51 # is set to true, it will remove those redundant pragmas. Default: true.
155 remove_redundant: true
52 remove_redundant: true
156
53
54+ # Align the types in record declarations
55+ - records: {}
56+
157 # Replace tabs by spaces. This is disabled by default.
57 # Replace tabs by spaces. This is disabled by default.
158 # - tabs:
58 # - tabs:
159 # # Number of spaces to use for each tab. Default: 8, as specified by the
59 # # Number of spaces to use for each tab. Default: 8, as specified by the
@@ -167,24 +67,11 @@ steps:
167# to. Different steps take this into account. Default: 80.
67# to. Different steps take this into account. Default: 80.
168columns: 80
68columns: 80
169
69
170−# By default, line endings are converted according to the OS. You can override
171−# preferred format here.
172−#
173−# - native: Native newline format. CRLF on Windows, LF on other OSes.
174−#
175−# - lf: Convert to LF ("\n").
176−#
177−# - crlf: Convert to CRLF ("\r\n").
178−#
179−# Default: native.
180−newline: lf
181−
182# Sometimes, language extensions are specified in a cabal file or from the
70# Sometimes, language extensions are specified in a cabal file or from the
183# command line instead of using language pragmas in the file. stylish-haskell
71# command line instead of using language pragmas in the file. stylish-haskell
184# needs to be aware of these, so it can parse the file correctly.
72# needs to be aware of these, so it can parse the file correctly.
185#
73#
186# No language extensions are enabled by default.
74# No language extensions are enabled by default.
187language_extensions:
75language_extensions:
188− - FlexibleContexts
189− - TemplateHaskell
76+ - TemplateHaskell
190− - QuasiQuotes
77+ - QuasiQuotes
.travis.ymlnew file+171
@@ -0,0 +1,171 @@
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' '--max-backjumps=10000' 'cabal.project'
4+#
5+# For more information, see https://github.com/hvr/multi-ghc-travis
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+ - release-0.12
17+
18+cache:
19+ directories:
20+ - $HOME/.cabal/packages
21+ - $HOME/.cabal/store
22+
23+before_cache:
24+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log
25+ # remove files that are regenerated by 'cabal update'
26+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.*
27+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json
28+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache
29+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar
30+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx
31+
32+ - rm -rfv $HOME/.cabal/packages/head.hackage
33+
34+matrix:
35+ include:
36+ - compiler: "ghc-7.8.4"
37+ # env: TEST=--disable-tests BENCH=--disable-benchmarks
38+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-7.8.4], sources: [hvr-ghc]}}
39+ - compiler: "ghc-7.10.3"
40+ # env: TEST=--disable-tests BENCH=--disable-benchmarks
41+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-7.10.3], sources: [hvr-ghc]}}
42+ - compiler: "ghc-8.0.2"
43+ # env: TEST=--disable-tests BENCH=--disable-benchmarks
44+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.0.2], sources: [hvr-ghc]}}
45+ - compiler: "ghc-8.2.2"
46+ # env: TEST=--disable-tests BENCH=--disable-benchmarks
47+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.2.2], sources: [hvr-ghc]}}
48+
49+before_install:
50+ - HC=${CC}
51+ - HCPKG=${HC/ghc/ghc-pkg}
52+ - unset CC
53+ - ROOTDIR=$(pwd)
54+ - mkdir -p $HOME/.local/bin
55+ - "PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$HOME/local/bin:$PATH"
56+ - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') ))
57+ - echo $HCNUMVER
58+
59+install:
60+ - cabal --version
61+ - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"
62+ - BENCH=${BENCH---enable-benchmarks}
63+ - TEST=${TEST---enable-tests}
64+ - HADDOCK=${HADDOCK-true}
65+ - INSTALLED=${INSTALLED-true}
66+ - GHCHEAD=${GHCHEAD-false}
67+ - CABALNEWBUILDOPTS=--max-backjumps=10000
68+ - travis_retry cabal update -v
69+ - "sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config"
70+ - rm -fv cabal.project cabal.project.local
71+ - "if [ $HCNUMVER -ge 70800 ]; then sed -i.bak 's/-- ghc-options:.*/ghc-options: -j2/' ${HOME}/.cabal/config; fi"
72+ - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$'
73+ - "printf 'packages: \"servant\" \"servant-client\" \"servant-client-core\" \"servant-docs\" \"servant-foreign\" \"servant-server\" \"doc/tutorial\" \"doc/cookbook/db-postgres-pool\" \"doc/cookbook/jwt-and-basic-auth\" \"doc/cookbook/db-sqlite-simple\" \"doc/cookbook/basic-auth\" \"doc/cookbook/https\" \"doc/cookbook/structuring-apis\" \"doc/cookbook/using-custom-monad\" \"doc/cookbook/file-upload\"\\n' > cabal.project"
74+ - "echo 'constraints: foundation >=0.0.14,memory <0.14.12 || >0.14.12' >> cabal.project"
75+ - "echo 'allow-newer: servant-js:servant,servant-js:servant-foreign,servant-auth-server:http-types,servant-multipart:lens,servant-multipart:resourcet,servant-multipart:servant,servant-multipart:servant-server,servant-auth-server:servant-server' >> cabal.project"
76+ - cat cabal.project
77+ - if [ -f "servant/configure.ac" ]; then
78+ (cd "servant" && autoreconf -i);
79+ fi
80+ - if [ -f "servant-client/configure.ac" ]; then
81+ (cd "servant-client" && autoreconf -i);
82+ fi
83+ - if [ -f "servant-client-core/configure.ac" ]; then
84+ (cd "servant-client-core" && autoreconf -i);
85+ fi
86+ - if [ -f "servant-docs/configure.ac" ]; then
87+ (cd "servant-docs" && autoreconf -i);
88+ fi
89+ - if [ -f "servant-foreign/configure.ac" ]; then
90+ (cd "servant-foreign" && autoreconf -i);
91+ fi
92+ - if [ -f "servant-server/configure.ac" ]; then
93+ (cd "servant-server" && autoreconf -i);
94+ fi
95+ - if [ -f "doc/tutorial/configure.ac" ]; then
96+ (cd "doc/tutorial" && autoreconf -i);
97+ fi
98+ - if [ -f "doc/cookbook/db-postgres-pool/configure.ac" ]; then
99+ (cd "doc/cookbook/db-postgres-pool" && autoreconf -i);
100+ fi
101+ - if [ -f "doc/cookbook/jwt-and-basic-auth/configure.ac" ]; then
102+ (cd "doc/cookbook/jwt-and-basic-auth" && autoreconf -i);
103+ fi
104+ - if [ -f "doc/cookbook/db-sqlite-simple/configure.ac" ]; then
105+ (cd "doc/cookbook/db-sqlite-simple" && autoreconf -i);
106+ fi
107+ - if [ -f "doc/cookbook/basic-auth/configure.ac" ]; then
108+ (cd "doc/cookbook/basic-auth" && autoreconf -i);
109+ fi
110+ - if [ -f "doc/cookbook/https/configure.ac" ]; then
111+ (cd "doc/cookbook/https" && autoreconf -i);
112+ fi
113+ - if [ -f "doc/cookbook/structuring-apis/configure.ac" ]; then
114+ (cd "doc/cookbook/structuring-apis" && autoreconf -i);
115+ fi
116+ - if [ -f "doc/cookbook/using-custom-monad/configure.ac" ]; then
117+ (cd "doc/cookbook/using-custom-monad" && autoreconf -i);
118+ fi
119+ - if [ -f "doc/cookbook/file-upload/configure.ac" ]; then
120+ (cd "doc/cookbook/file-upload" && autoreconf -i);
121+ fi
122+ - rm -f cabal.project.freeze
123+ - 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/db-postgres-pool"/dist "doc/cookbook/jwt-and-basic-auth"/dist "doc/cookbook/db-sqlite-simple"/dist "doc/cookbook/basic-auth"/dist "doc/cookbook/https"/dist "doc/cookbook/structuring-apis"/dist "doc/cookbook/using-custom-monad"/dist "doc/cookbook/file-upload"/dist
124+ - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
125+
126+# Here starts the actual work to be performed for the package under test;
127+# any command which exits with a non-zero exit code causes the build to fail.
128+script:
129+ # test that source-distributions can be generated
130+ - echo Packaging... && echo -en 'travis_fold:start:sdist\\r'
131+ - (cd "servant" && cabal sdist)
132+ - (cd "servant-client" && cabal sdist)
133+ - (cd "servant-client-core" && cabal sdist)
134+ - (cd "servant-docs" && cabal sdist)
135+ - (cd "servant-foreign" && cabal sdist)
136+ - (cd "servant-server" && cabal sdist)
137+ - (cd "doc/tutorial" && cabal sdist)
138+ - (cd "doc/cookbook/db-postgres-pool" && cabal sdist)
139+ - (cd "doc/cookbook/jwt-and-basic-auth" && cabal sdist)
140+ - (cd "doc/cookbook/db-sqlite-simple" && cabal sdist)
141+ - (cd "doc/cookbook/basic-auth" && cabal sdist)
142+ - (cd "doc/cookbook/https" && cabal sdist)
143+ - (cd "doc/cookbook/structuring-apis" && cabal sdist)
144+ - (cd "doc/cookbook/using-custom-monad" && cabal sdist)
145+ - (cd "doc/cookbook/file-upload" && cabal sdist)
146+ - echo -en 'travis_fold:end:sdist\\r'
147+ - echo Unpacking... && echo -en 'travis_fold:start:unpack\\r'
148+ - mv "servant"/dist/servant-*.tar.gz "servant-client"/dist/servant-client-*.tar.gz "servant-client-core"/dist/servant-client-core-*.tar.gz "servant-docs"/dist/servant-docs-*.tar.gz "servant-foreign"/dist/servant-foreign-*.tar.gz "servant-server"/dist/servant-server-*.tar.gz "doc/tutorial"/dist/tutorial-*.tar.gz "doc/cookbook/db-postgres-pool"/dist/cookbook-db-postgres-pool-*.tar.gz "doc/cookbook/jwt-and-basic-auth"/dist/cookbook-jwt-and-basic-auth-*.tar.gz "doc/cookbook/db-sqlite-simple"/dist/cookbook-db-sqlite-simple-*.tar.gz "doc/cookbook/basic-auth"/dist/cookbook-basic-auth-*.tar.gz "doc/cookbook/https"/dist/cookbook-https-*.tar.gz "doc/cookbook/structuring-apis"/dist/cookbook-structuring-apis-*.tar.gz "doc/cookbook/using-custom-monad"/dist/cookbook-using-custom-monad-*.tar.gz "doc/cookbook/file-upload"/dist/cookbook-file-upload-*.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-db-postgres-pool-*/*.cabal cookbook-jwt-and-basic-auth-*/*.cabal cookbook-db-sqlite-simple-*/*.cabal cookbook-basic-auth-*/*.cabal cookbook-https-*/*.cabal cookbook-structuring-apis-*/*.cabal cookbook-using-custom-monad-*/*.cabal cookbook-file-upload-*/*.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-js:servant,servant-js:servant-foreign,servant-auth-server:http-types,servant-multipart:lens,servant-multipart:resourcet,servant-multipart:servant,servant-multipart:servant-server,servant-auth-server:servant-server' >> cabal.project"
154+ - cat cabal.project
155+ - echo -en 'travis_fold:end:unpack\\r'
156+
157+
158+ - echo Building with tests and benchmarks... && echo -en 'travis_fold:start:build-everything\\r'
159+ # build & run tests, build benchmarks
160+ - cabal new-build -w ${HC} ${TEST} ${BENCH} ${CABALNEWBUILDOPTS} all
161+ - echo -en 'travis_fold:end:build-everything\\r'
162+ - if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} ${BENCH} ${CABALNEWBUILDOPTS} all; fi
163+
164+ - echo Haddock... && echo -en 'travis_fold:start:haddock\\r'
165+ # haddock
166+ - rm -rf ./dist-newstyle
167+ - if $HADDOCK; then cabal new-haddock -w ${HC} ${TEST} ${BENCH} ${CABALNEWBUILDOPTS} all; else echo "Skipping haddock generation";fi
168+
169+ - echo -en 'travis_fold:end:haddock\\r'
170+# REGENDATA ["--config=cabal.make-travis-yml","--output=.travis.yml","--max-backjumps=10000","cabal.project"]
171+# EOF
CONTRIBUTING.md+5−34
@@ -21,7 +21,6 @@ Or `nix`:
21./scripts/generate-nix-files.sh # Get up-to-date shell.nix files
21./scripts/generate-nix-files.sh # Get up-to-date shell.nix files
22```
22```
23
23
24−To build the docs, see `doc/README.md`.
25
24
26## General
25## General
27
26
@@ -35,34 +34,8 @@ Some things we like:
35Though we aren't sticklers for style, the `.stylish-haskell.yaml` and `HLint.hs`
34Though we aren't sticklers for style, the `.stylish-haskell.yaml` and `HLint.hs`
36files in the repository provide a good baseline for consistency.
35files in the repository provide a good baseline for consistency.
37
36
38−**Important**: please do not modify the versions of the servant packages you are sending patches for.
37+Please include a description of the changes in your PR in the `CHANGELOG.md` of
39−
38+the packages you've changed. And of course, write tests!
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−```
66
39
67## PR process
40## PR process
68
41
@@ -79,10 +52,8 @@ not been a timely response to a PR, you can ping the Maintainers group (with
79We encourage people to experiment with new combinators and instances - it is
52We encourage people to experiment with new combinators and instances - it is
80one of the most powerful ways of using `servant`, and a wonderful way of
53one of the most powerful ways of using `servant`, and a wonderful way of
81getting to know it better. If you do write a new combinator, we would love to
54getting to know it better. If you do write a new combinator, we would love to
82−know about it! Either hop on
55+know about it! Either hop on #servant on freenode and let us know, or open an
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
56+issue with the `news` tag (which we will close when we read it).
85−read it).
86
57
87As for adding them to the main repo: maintaining combinators can be expensive,
58As for adding them to the main repo: maintaining combinators can be expensive,
88since official combinators must have instances for all classes (and new classes
59since official combinators must have instances for all classes (and new classes
@@ -105,7 +76,7 @@ the `news` label if you make a new package so we can know about it!
105
76
106## Release policy
77## Release policy
107
78
108−We are currently moving to a more aggressive release policy, so that you can get
79+We are currently moving to a more aggresive release policy, so that you can get
109what you contribute from Hackage fairly soon. However, note that prior to major
80what you contribute from Hackage fairly soon. However, note that prior to major
110releases it may take some time in between releases.
81releases it may take some time in between releases.
111
82
README.md+36−27
@@ -4,18 +4,37 @@
4
4
5## Getting Started
5## Getting Started
6
6
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
8introduces the core features of servant. After this article, you should be able
8introduces the core features of servant. After this article, you should be able
9to write your first servant webservices, learning the rest from the haddocks'
9to write your first servant webservices, learning the rest from the haddocks'
10examples.
10examples.
11
11
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/).
13Other blog posts, videos and slides can be found on the
13Other blog posts, videos and slides can be found on the
14−[website](http://www.servant.dev/).
14+[website](http://haskell-servant.github.io/).
15
15
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
17list](https://groups.google.com/forum/#!forum/haskell-servant).
17list](https://groups.google.com/forum/#!forum/haskell-servant).
18
18
19+## Version history
20+
21+This table lists the versions of some `servant-` libraries at the point of
22+release of `servant` package.
23+
24+| | **0.10** | **0.11** | **0.12** |
25+| ------------------- | -------- |----------|----------|
26+| servant | 0.10 | 0.11 | 0.12 |
27+| servant-blaze | 0.7.1 | ? | ? |
28+| servant-cassava | 0.7 | ? | ? |
29+| servant-client | 0.10 | 0.11 | 0.12 |
30+| servant-docs | 0.10 | 0.11 | 0.11.1 |
31+| servant-foreign | 0.10 | 0.10.0.1 | 0.10.2 |
32+| servant-js | 0.9.1 | ? | ? |
33+| servant-lucid | 0.7.1 | ? | ? |
34+| servant-mock | 0.8.1.1 | ? | ? |
35+| servant-server | 0.10 | 0.11 | 0.12 |
36+| servant-swagger | 1.1.2.1 | ? | ? |
37+
19## Contributing
38## Contributing
20
39
21See `CONTRIBUTING.md`
40See `CONTRIBUTING.md`
@@ -24,7 +43,7 @@ See `CONTRIBUTING.md`
24
43
25- Update changelog and bump versions in `master`
44- Update changelog and bump versions in `master`
26 - `git log --oneline v0.12.. | grep 'Merge pull request'` is a good starting point (use correct previous release tag)
45 - `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`
46+- Create a release branch, e.g. `release-0.13`, and *protect it* from accidental force pushes.
28 - Release branch is useful for backporting fixes from `master`
47 - Release branch is useful for backporting fixes from `master`
29- Smoke test in [`servant-universe`](https://github.com/phadej/servant-universe)
48- Smoke test in [`servant-universe`](https://github.com/phadej/servant-universe)
30 - `git submodule foreach git checkout master` and `git submodule foreach git pull` to get newest of everything.
49 - `git submodule foreach git checkout master` and `git submodule foreach git pull` to get newest of everything.
@@ -32,7 +51,7 @@ See `CONTRIBUTING.md`
32 - It's a good idea to separate these steps, as tests often pass, if they compile :)
51 - It's a good idea to separate these steps, as tests often pass, if they compile :)
33 - See `cabal.project` to selectively `allow-newer`
52 - See `cabal.project` to selectively `allow-newer`
34 - If some packages are broken, on your discretisation there are two options:
53 - 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.
54+ - Fix them and make PRs: it's good idea to test against older `servant` version too.
36 - Temporarily comment out broken package
55 - Temporarily comment out broken package
37 - If you make a commit for `servant-universe`, you can use it as submodule in private projects to test even more
56 - If you make a commit for `servant-universe`, you can use it as submodule in private projects to test even more
38- When ripples are cleared out:
57- When ripples are cleared out:
@@ -40,32 +59,22 @@ See `CONTRIBUTING.md`
40 - `git push --tags`
59 - `git push --tags`
41 - `cabal sdist` and `cabal upload`
60 - `cabal sdist` and `cabal upload`
42
61
43−## TechEmpower framework benchmarks
62+## travis
44
63
45−We develop and maintain the servant TFB entry in https://github.com/haskell-servant/FrameworkBenchmarks/
64+`.travis.yml` is generated using `make-travis-yml` tool, in
65+[multi-ghc-travis](https://github.com/haskell-hvr/multi-ghc-travis) repository.
46
66
47−To verify (i.e. compile and test that it works)
67+To regenerate the script use (*note:* atm you need to comment `doc/cookbook/` packages).
48
68
49−```sh
50−./tfb --mode verify --test servant servant-beam servant-psql-simple --type json plaintext db fortune
51```
69```
52−
70+runghc ~/Documents/other-haskell/multi-ghc-travis/make_travis_yml_2.hs regenerate
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
57```
71```
58
72
59−To compare with `reitit` (Clojure framework)
73+In case Travis jobs fail due failing build of dependency, you can temporarily
74+add `constraints` to the `cabal.project`, and regenerate the `.travis.yml`.
75+For example, the following will disallow single `troublemaker-13.37` package version:
60
76
61−```sh
62−./tfb --mode benchmark --test reitit reitit-async reitit-jdbc servant servant-beam servant-psql-simple --type json plaintext db fortune
63```
77```
64−
78+constraints:
65−You can see the visualised results at https://www.techempower.com/benchmarks/#section=test
79+ troublemaker <13.37 && > 13.37
66−
80+```
67−## Nix
68−
69−A developer shell.nix file is provided in the `nix` directory
70−
71−See [nix/README.md](nix/README.md)
cabal.ghcjs.projectdeleted−14
@@ -1,14 +0,0 @@
1−-- Using https://launchpad.net/~hvr/+archive/ubuntu/ghcjs
2−
3−packages:
4− servant/
5− servant-client/
6− servant-client-core/
7−
8−-- we need to tell cabal we are using GHCJS
9−compiler: ghcjs
10−tests: True
11−
12−-- Constraints so that reflex-platform provided packages are selected.
13−constraints: attoparsec == 0.13.2.2
14−constraints: hashable == 1.3.0.0
cabal.make-travis-ymlnew file+15
@@ -0,0 +1,15 @@
1+folds: all-but-test
2+branches: master release-0.12
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+build-with-installed-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+15−46
@@ -1,54 +1,23 @@
1−packages:
1+packages: servant/
2− servant/
3− servant-auth/servant-auth
4− servant-auth/servant-auth-client
5− servant-auth/servant-auth-docs
6− servant-auth/servant-auth-server
7− servant-auth/servant-auth-swagger
8−
9 servant-client/
2 servant-client/
10 servant-client-core/
3 servant-client-core/
11− servant-http-streams/
12 servant-docs/
4 servant-docs/
13 servant-foreign/
5 servant-foreign/
14 servant-server/
6 servant-server/
15− servant-swagger/
16 doc/tutorial/
7 doc/tutorial/
8+ doc/cookbook/*/*.cabal
17
9
18−-- servant streaming
10+allow-newer:
19−packages:
20− servant-machines/
21− servant-conduit/
11+ servant-js:servant,
22− servant-pipes/
12+ servant-js:servant-foreign,
23−
13+ servant-auth-server:http-types,
24−-- servant GHCJS
14+ servant-multipart:lens,
25−-- packages:
15+ servant-multipart:resourcet,
26−-- servant-jsaddle/
16+ servant-multipart:servant,
27−
17+ servant-multipart:servant-server,
28−-- Cookbooks
18+ servant-auth-server:servant-server
29−packages:
30− doc/cookbook/basic-auth
31− doc/cookbook/curl-mock
32− doc/cookbook/custom-errors
33− doc/cookbook/basic-streaming
34− doc/cookbook/db-postgres-pool
35− doc/cookbook/db-sqlite-simple
36− doc/cookbook/file-upload
37− doc/cookbook/generic
38− doc/cookbook/hoist-server-with-context
39− 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
46− doc/cookbook/structuring-apis
47− doc/cookbook/using-custom-monad
48− doc/cookbook/using-free-client
49− -- doc/cookbook/open-id-connect
50− doc/cookbook/managed-resource
51
19
52−tests: True
20+constraints:
53−optimization: False
21+ -- see https://github.com/haskell-infra/hackage-trustees/issues/119
54−-- reorder-goals: True
22+ foundation >=0.0.14,
23+ memory <0.14.12 || >0.14.12
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+206−12
@@ -1,22 +1,216 @@
1−# Minimal makefile for Sphinx documentation
1+# Makefile for Sphinx documentation
2#
2#
3
3
4# You can set these variables from the command line.
4# You can set these variables from the command line.
5SPHINXOPTS =
5SPHINXOPTS =
6SPHINXBUILD = sphinx-build
6SPHINXBUILD = sphinx-build
7−SPHINXPROJ = Servant
7+PAPER =
8−SOURCEDIR = .
9BUILDDIR = _build
8BUILDDIR = _build
10
9
11−# Put it first so that "make" without argument is like "make help".
10+# User-friendly check for sphinx-build
11+ifeq ($(shell which $(SPHINXBUILD) >/dev/null 2>&1; echo $$?), 1)
12+$(error The '$(SPHINXBUILD)' command was not found. Make sure you have Sphinx installed, then set the SPHINXBUILD environment variable to point to the full path of the '$(SPHINXBUILD)' executable. Alternatively you can add the directory with the executable to your PATH. If you don't have Sphinx installed, grab it from http://sphinx-doc.org/)
13+endif
14+
15+# Internal variables.
16+PAPEROPT_a4 = -D latex_paper_size=a4
17+PAPEROPT_letter = -D latex_paper_size=letter
18+ALLSPHINXOPTS = -d $(BUILDDIR)/doctrees $(PAPEROPT_$(PAPER)) $(SPHINXOPTS) .
19+# the i18n builder cannot share the environment and doctrees with the others
20+I18NSPHINXOPTS = $(PAPEROPT_$(PAPER)) $(SPHINXOPTS) .
21+
22+.PHONY: help
12help:
23help:
13− @if [ ! -d venv ]; then echo "WARNING: There is no venv directory, did you forget to 'virtualenv venv'. Check README.md."; fi
24+ @echo "Please use \`make <target>' where <target> is one of"
14− @if [ ! "z$$(which $(SPHINXBUILD))" = "z$$(pwd)/venv/bin/sphinx-build" ]; then echo "WARNING: Did you forgot to 'source venv/bin/activate'"; fi
25+ @echo " html to make standalone HTML files"
26+ @echo " dirhtml to make HTML files named index.html in directories"
27+ @echo " singlehtml to make a single large HTML file"
28+ @echo " pickle to make pickle files"
29+ @echo " json to make JSON files"
30+ @echo " htmlhelp to make HTML files and a HTML help project"
31+ @echo " qthelp to make HTML files and a qthelp project"
32+ @echo " applehelp to make an Apple Help Book"
33+ @echo " devhelp to make HTML files and a Devhelp project"
34+ @echo " epub to make an epub"
35+ @echo " latex to make LaTeX files, you can set PAPER=a4 or PAPER=letter"
36+ @echo " latexpdf to make LaTeX files and run them through pdflatex"
37+ @echo " latexpdfja to make LaTeX files and run them through platex/dvipdfmx"
38+ @echo " text to make text files"
39+ @echo " man to make manual pages"
40+ @echo " texinfo to make Texinfo files"
41+ @echo " info to make Texinfo files and run them through makeinfo"
42+ @echo " gettext to make PO message catalogs"
43+ @echo " changes to make an overview of all changed/added/deprecated items"
44+ @echo " xml to make Docutils-native XML files"
45+ @echo " pseudoxml to make pseudoxml-XML files for display purposes"
46+ @echo " linkcheck to check all external links for integrity"
47+ @echo " doctest to run all doctests embedded in the documentation (if enabled)"
48+ @echo " coverage to run coverage check of the documentation (if enabled)"
49+
50+.PHONY: clean
51+clean:
52+ rm -rf $(BUILDDIR)/*
53+
54+.PHONY: html
55+html:
56+ $(SPHINXBUILD) -b html $(ALLSPHINXOPTS) $(BUILDDIR)/html
57+ @echo
58+ @echo "Build finished. The HTML pages are in $(BUILDDIR)/html."
59+
60+.PHONY: dirhtml
61+dirhtml:
62+ $(SPHINXBUILD) -b dirhtml $(ALLSPHINXOPTS) $(BUILDDIR)/dirhtml
63+ @echo
64+ @echo "Build finished. The HTML pages are in $(BUILDDIR)/dirhtml."
65+
66+.PHONY: singlehtml
67+singlehtml:
68+ $(SPHINXBUILD) -b singlehtml $(ALLSPHINXOPTS) $(BUILDDIR)/singlehtml
69+ @echo
70+ @echo "Build finished. The HTML page is in $(BUILDDIR)/singlehtml."
71+
72+.PHONY: pickle
73+pickle:
74+ $(SPHINXBUILD) -b pickle $(ALLSPHINXOPTS) $(BUILDDIR)/pickle
75+ @echo
76+ @echo "Build finished; now you can process the pickle files."
77+
78+.PHONY: json
79+json:
80+ $(SPHINXBUILD) -b json $(ALLSPHINXOPTS) $(BUILDDIR)/json
81+ @echo
82+ @echo "Build finished; now you can process the JSON files."
83+
84+.PHONY: htmlhelp
85+htmlhelp:
86+ $(SPHINXBUILD) -b htmlhelp $(ALLSPHINXOPTS) $(BUILDDIR)/htmlhelp
87+ @echo
88+ @echo "Build finished; now you can run HTML Help Workshop with the" \
89+ ".hhp project file in $(BUILDDIR)/htmlhelp."
90+
91+.PHONY: qthelp
92+qthelp:
93+ $(SPHINXBUILD) -b qthelp $(ALLSPHINXOPTS) $(BUILDDIR)/qthelp
94+ @echo
95+ @echo "Build finished; now you can run "qcollectiongenerator" with the" \
96+ ".qhcp project file in $(BUILDDIR)/qthelp, like this:"
97+ @echo "# qcollectiongenerator $(BUILDDIR)/qthelp/generics-eot.qhcp"
98+ @echo "To view the help file:"
99+ @echo "# assistant -collectionFile $(BUILDDIR)/qthelp/generics-eot.qhc"
100+
101+.PHONY: applehelp
102+applehelp:
103+ $(SPHINXBUILD) -b applehelp $(ALLSPHINXOPTS) $(BUILDDIR)/applehelp
104+ @echo
105+ @echo "Build finished. The help book is in $(BUILDDIR)/applehelp."
106+ @echo "N.B. You won't be able to view it unless you put it in" \
107+ "~/Library/Documentation/Help or install it in your application" \
108+ "bundle."
109+
110+.PHONY: devhelp
111+devhelp:
112+ $(SPHINXBUILD) -b devhelp $(ALLSPHINXOPTS) $(BUILDDIR)/devhelp
113+ @echo
114+ @echo "Build finished."
115+ @echo "To view the help file:"
116+ @echo "# mkdir -p $$HOME/.local/share/devhelp/generics-eot"
117+ @echo "# ln -s $(BUILDDIR)/devhelp $$HOME/.local/share/devhelp/generics-eot"
118+ @echo "# devhelp"
119+
120+.PHONY: epub
121+epub:
122+ $(SPHINXBUILD) -b epub $(ALLSPHINXOPTS) $(BUILDDIR)/epub
123+ @echo
124+ @echo "Build finished. The epub file is in $(BUILDDIR)/epub."
125+
126+.PHONY: latex
127+latex:
128+ $(SPHINXBUILD) -b latex $(ALLSPHINXOPTS) $(BUILDDIR)/latex
129+ @echo
130+ @echo "Build finished; the LaTeX files are in $(BUILDDIR)/latex."
131+ @echo "Run \`make' in that directory to run these through (pdf)latex" \
132+ "(use \`make latexpdf' here to do that automatically)."
133+
134+.PHONY: latexpdf
135+latexpdf:
136+ $(SPHINXBUILD) -b latex $(ALLSPHINXOPTS) $(BUILDDIR)/latex
137+ @echo "Running LaTeX files through pdflatex..."
138+ $(MAKE) -C $(BUILDDIR)/latex all-pdf
139+ @echo "pdflatex finished; the PDF files are in $(BUILDDIR)/latex."
140+
141+.PHONY: latexpdfja
142+latexpdfja:
143+ $(SPHINXBUILD) -b latex $(ALLSPHINXOPTS) $(BUILDDIR)/latex
144+ @echo "Running LaTeX files through platex and dvipdfmx..."
145+ $(MAKE) -C $(BUILDDIR)/latex all-pdf-ja
146+ @echo "pdflatex finished; the PDF files are in $(BUILDDIR)/latex."
147+
148+.PHONY: text
149+text:
150+ $(SPHINXBUILD) -b text $(ALLSPHINXOPTS) $(BUILDDIR)/text
151+ @echo
152+ @echo "Build finished. The text files are in $(BUILDDIR)/text."
153+
154+.PHONY: man
155+man:
156+ $(SPHINXBUILD) -b man $(ALLSPHINXOPTS) $(BUILDDIR)/man
157+ @echo
158+ @echo "Build finished. The manual pages are in $(BUILDDIR)/man."
159+
160+.PHONY: texinfo
161+texinfo:
162+ $(SPHINXBUILD) -b texinfo $(ALLSPHINXOPTS) $(BUILDDIR)/texinfo
163+ @echo
164+ @echo "Build finished. The Texinfo files are in $(BUILDDIR)/texinfo."
165+ @echo "Run \`make' in that directory to run these through makeinfo" \
166+ "(use \`make info' here to do that automatically)."
167+
168+.PHONY: info
169+info:
170+ $(SPHINXBUILD) -b texinfo $(ALLSPHINXOPTS) $(BUILDDIR)/texinfo
171+ @echo "Running Texinfo files through makeinfo..."
172+ make -C $(BUILDDIR)/texinfo info
173+ @echo "makeinfo finished; the Info files are in $(BUILDDIR)/texinfo."
174+
175+.PHONY: gettext
176+gettext:
177+ $(SPHINXBUILD) -b gettext $(I18NSPHINXOPTS) $(BUILDDIR)/locale
178+ @echo
179+ @echo "Build finished. The message catalogs are in $(BUILDDIR)/locale."
180+
181+.PHONY: changes
182+changes:
183+ $(SPHINXBUILD) -b changes $(ALLSPHINXOPTS) $(BUILDDIR)/changes
184+ @echo
185+ @echo "The overview file is in $(BUILDDIR)/changes."
186+
187+.PHONY: linkcheck
188+linkcheck:
189+ $(SPHINXBUILD) -b linkcheck $(ALLSPHINXOPTS) $(BUILDDIR)/linkcheck
190+ @echo
191+ @echo "Link check complete; look for any errors in the above output " \
192+ "or in $(BUILDDIR)/linkcheck/output.txt."
193+
194+.PHONY: doctest
195+doctest:
196+ $(SPHINXBUILD) -b doctest $(ALLSPHINXOPTS) $(BUILDDIR)/doctest
197+ @echo "Testing of doctests in the sources finished, look at the " \
198+ "results in $(BUILDDIR)/doctest/output.txt."
199+
200+.PHONY: coverage
201+coverage:
15− @$(SPHINXBUILD) -M help "$(SOURCEDIR)" "$(BUILDDIR)" $(SPHINXOPTS) $(O)
202+ $(SPHINXBUILD) -b coverage $(ALLSPHINXOPTS) $(BUILDDIR)/coverage
203+ @echo "Testing of coverage in the sources finished, look at the " \
204+ "results in $(BUILDDIR)/coverage/python.txt."
16
205
17−.PHONY: help Makefile
206+.PHONY: xml
207+xml:
208+ $(SPHINXBUILD) -b xml $(ALLSPHINXOPTS) $(BUILDDIR)/xml
209+ @echo
210+ @echo "Build finished. The XML files are in $(BUILDDIR)/xml."
18
211
19−# Catch-all target: route all unknown targets to Sphinx using the new
212+.PHONY: pseudoxml
20−# "make mode" option. $(O) is meant as a shortcut for $(SPHINXOPTS).
213+pseudoxml:
21−%: Makefile
22− @$(SPHINXBUILD) -M $@ "$(SOURCEDIR)" "$(BUILDDIR)" $(SPHINXOPTS) $(O)
214+ $(SPHINXBUILD) -b pseudoxml $(ALLSPHINXOPTS) $(BUILDDIR)/pseudoxml
215+ @echo
216+ @echo "Build finished. The pseudo-XML files are in $(BUILDDIR)/pseudoxml."
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+176−53
@@ -1,7 +1,7 @@
1# -*- coding: utf-8 -*-
1# -*- coding: utf-8 -*-
2#
2#
3−# Servant documentation build configuration file, created by
3+# servant documentation build configuration file, created by
4−# sphinx-quickstart on Fri Jul 6 11:38:51 2018.
4+# sphinx-quickstart on Mon Nov 23 13:24:36 2015.
5#
5#
6# This file is execfile()d with the current directory set to its
6# This file is execfile()d with the current directory set to its
7# containing dir.
7# containing dir.
@@ -12,21 +12,20 @@
12# All configuration values have a default; values that are commented out
12# All configuration values have a default; values that are commented out
13# serve to show the default.
13# serve to show the default.
14
14
15+import sys
16+import os
17+import shlex
18+from recommonmark.parser import CommonMarkParser
19+
15# If extensions (or modules to document with autodoc) are in another directory,
20# If extensions (or modules to document with autodoc) are in another directory,
16# add these directories to sys.path here. If the directory is relative to the
21# add these directories to sys.path here. If the directory is relative to the
17# documentation root, use os.path.abspath to make it absolute, like shown here.
22# documentation root, use os.path.abspath to make it absolute, like shown here.
18−#
19−# import os
20−# import sys
21−# sys.path.insert(0, os.path.abspath('.'))
23+#sys.path.insert(0, os.path.abspath('.'))
22−from recommonmark.parser import CommonMarkParser
23−
24
24
25# -- General configuration ------------------------------------------------
25# -- General configuration ------------------------------------------------
26
26
27# If your documentation needs a minimal Sphinx version, state it here.
27# If your documentation needs a minimal Sphinx version, state it here.
28−#
29−# needs_sphinx = '1.0'
28+#needs_sphinx = '1.0'
30
29
31# Add any Sphinx extension module names here, as strings. They can be
30# Add any Sphinx extension module names here, as strings. They can be
32# extensions coming with Sphinx (named 'sphinx.ext.*') or your custom
31# extensions coming with Sphinx (named 'sphinx.ext.*') or your custom
@@ -38,15 +37,17 @@ templates_path = ['_templates']
38
37
39# The suffix(es) of source filenames.
38# The suffix(es) of source filenames.
40# You can specify multiple suffix as a list of string:
39# You can specify multiple suffix as a list of string:
41−#
42−source_suffix = ['.rst', '.md', '.lhs']
40+source_suffix = ['.md', '.rst', '.lhs']
41+
42+# The encoding of source files.
43+#source_encoding = 'utf-8-sig'
43
44
44# The master toctree document.
45# The master toctree document.
45master_doc = 'index'
46master_doc = 'index'
46
47
47# General information about the project.
48# General information about the project.
48−project = u'Servant'
49+project = u'servant'
49−copyright = u'2022, Servant Contributors'
50+copyright = u'2016, Servant Contributors'
50author = u'Servant Contributors'
51author = u'Servant Contributors'
51
52
52# The version info for the project you're documenting, acts as replacement for
53# The version info for the project you're documenting, acts as replacement for
@@ -54,9 +55,9 @@ author = u'Servant Contributors'
54# built documents.
55# built documents.
55#
56#
56# The short X.Y version.
57# The short X.Y version.
57−# version = u'0.14'
58+# version = 'latest'
58# The full version, including alpha/beta/rc tags.
59# The full version, including alpha/beta/rc tags.
59−# release = u'0.14'
60+# release = 'latest'
60
61
61# The language for content autogenerated by Sphinx. Refer to documentation
62# The language for content autogenerated by Sphinx. Refer to documentation
62# for a list of supported languages.
63# for a list of supported languages.
@@ -65,14 +66,45 @@ author = u'Servant Contributors'
65# Usually you set "language" from the command line for these cases.
66# Usually you set "language" from the command line for these cases.
66language = None
67language = None
67
68
69+# There are two options for replacing |today|: either, you set today to some
70+# non-false value, then it is used:
71+#today = ''
72+# Else, today_fmt is used as the format for a strftime call.
73+#today_fmt = '%B %d, %Y'
74+
68# List of patterns, relative to source directory, that match files and
75# List of patterns, relative to source directory, that match files and
69# directories to ignore when looking for source files.
76# directories to ignore when looking for source files.
70−# This patterns also effect to html_static_path and html_extra_path
71−exclude_patterns = ['_build', 'Thumbs.db', '.DS_Store']
77+exclude_patterns = ['_build', 'venv']
78+
79+# The reST default role (used for this markup: `text`) to use for all
80+# documents.
81+#default_role = None
82+
83+# If true, '()' will be appended to :func: etc. cross-reference text.
84+#add_function_parentheses = True
85+
86+# If true, the current module name will be prepended to all description
87+# unit titles (such as .. function::).
88+#add_module_names = True
89+
90+# If true, sectionauthor and moduleauthor directives will be shown in the
91+# output. They are ignored by default.
92+#show_authors = False
72
93
73# The name of the Pygments (syntax highlighting) style to use.
94# The name of the Pygments (syntax highlighting) style to use.
74pygments_style = 'sphinx'
95pygments_style = 'sphinx'
75
96
97+def setup(app):
98+ from sphinx.highlighting import lexers
99+ from pygments.lexers import HaskellLexer
100+ lexers['haskell ignore'] = HaskellLexer(stripnl=False)
101+
102+# A list of ignored prefixes for module index sorting.
103+#modindex_common_prefix = []
104+
105+# If true, keep warnings as "system message" paragraphs in the built documents.
106+#keep_warnings = False
107+
76# If true, `todo` and `todoList` produce output, else they produce nothing.
108# If true, `todo` and `todoList` produce output, else they produce nothing.
77todo_include_todos = False
109todo_include_todos = False
78
110
@@ -81,77 +113,157 @@ todo_include_todos = False
81
113
82# The theme to use for HTML and HTML Help pages. See the documentation for
114# The theme to use for HTML and HTML Help pages. See the documentation for
83# a list of builtin themes.
115# a list of builtin themes.
84−#
85html_theme = 'sphinx_rtd_theme'
116html_theme = 'sphinx_rtd_theme'
86
117
87# Theme options are theme-specific and customize the look and feel of a theme
118# Theme options are theme-specific and customize the look and feel of a theme
88# further. For a list of options available for each theme, see the
119# further. For a list of options available for each theme, see the
89# documentation.
120# documentation.
90−#
91−# html_theme_options = {}
121+#html_theme_options = {}
122+
123+# Add any paths that contain custom themes here, relative to this directory.
124+#html_theme_path = []
125+
126+# The name for this set of Sphinx documents. If None, it defaults to
127+# "<project> v<release> documentation".
128+#html_title = None
129+
130+# A shorter title for the navigation bar. Default is the same as html_title.
131+#html_short_title = None
132+
133+# The name of an image file (relative to this directory) to place at the top
134+# of the sidebar.
135+#html_logo = None
136+
137+# The name of an image file (within the static path) to use as favicon of the
138+# docs. This file should be a Windows icon file (.ico) being 16x16 or 32x32
139+# pixels large.
140+#html_favicon = None
92
141
93# Add any paths that contain custom static files (such as style sheets) here,
142# Add any paths that contain custom static files (such as style sheets) here,
94# relative to this directory. They are copied after the builtin static files,
143# relative to this directory. They are copied after the builtin static files,
95# so a file named "default.css" will overwrite the builtin "default.css".
144# so a file named "default.css" will overwrite the builtin "default.css".
96html_static_path = ['_static']
145html_static_path = ['_static']
97
146
98−# Custom sidebar templates, must be a dictionary that maps document names
147+# Add any extra paths that contain custom files (such as robots.txt or
99−# to template names.
148+# .htaccess) here, relative to this directory. These files are copied
100−#
149+# directly to the root of the documentation.
101−# This is required for the alabaster theme
150+#html_extra_path = []
102−# refs: http://alabaster.readthedocs.io/en/latest/installation.html#sidebars
103−html_sidebars = {
104− '**': [
105− 'relations.html', # needs 'show_related': True theme option to display
106− 'searchbox.html',
107− ]
108−}
109
151
152+# If not '', a 'Last updated on:' timestamp is inserted at every page bottom,
153+# using the given strftime format.
154+#html_last_updated_fmt = '%b %d, %Y'
110
155
111−# -- Options for HTMLHelp output ------------------------------------------
156+# If true, SmartyPants will be used to convert quotes and dashes to
157+# typographically correct entities.
158+#html_use_smartypants = True
112
159
113−# Output file base name for HTML help builder.
160+# Custom sidebar templates, maps document names to template names.
114−htmlhelp_basename = 'Servantdoc'
161+#html_sidebars = {}
162+
163+# Additional templates that should be rendered to pages, maps page names to
164+# template names.
165+#html_additional_pages = {}
166+
167+# If false, no module index is generated.
168+#html_domain_indices = True
169+
170+# If false, no index is generated.
171+#html_use_index = True
172+
173+# If true, the index is split into individual pages for each letter.
174+#html_split_index = False
175+
176+# If true, links to the reST sources are added to the pages.
177+#html_show_sourcelink = True
178+
179+# If true, "Created using Sphinx" is shown in the HTML footer. Default is True.
180+#html_show_sphinx = True
181+
182+# If true, "(C) Copyright ..." is shown in the HTML footer. Default is True.
183+#html_show_copyright = True
184+
185+# If true, an OpenSearch description file will be output, and all pages will
186+# contain a <link> tag referring to it. The value of this option must be the
187+# base URL from which the finished HTML is served.
188+#html_use_opensearch = ''
189+
190+# This is the file name suffix for HTML files (e.g. ".xhtml").
191+#html_file_suffix = None
192+
193+# Language to be used for generating the HTML full-text search index.
194+# Sphinx supports the following languages:
195+# 'da', 'de', 'en', 'es', 'fi', 'fr', 'hu', 'it', 'ja'
196+# 'nl', 'no', 'pt', 'ro', 'ru', 'sv', 'tr'
197+#html_search_language = 'en'
198+
199+# A dictionary with options for the search language support, empty by default.
200+# Now only 'ja' uses this config value
201+#html_search_options = {'type': 'default'}
115
202
203+# The name of a javascript file (relative to the configuration directory) that
204+# implements a search results scorer. If empty, the default will be used.
205+#html_search_scorer = 'scorer.js'
206+
207+# Output file base name for HTML help builder.
208+htmlhelp_basename = 'servantdoc'
116
209
117# -- Options for LaTeX output ---------------------------------------------
210# -- Options for LaTeX output ---------------------------------------------
118
211
119latex_elements = {
212latex_elements = {
120− # The paper size ('letterpaper' or 'a4paper').
213+# The paper size ('letterpaper' or 'a4paper').
121− #
122− # 'papersize': 'letterpaper',
214+#'papersize': 'letterpaper',
123
215
124− # The font size ('10pt', '11pt' or '12pt').
216+# The font size ('10pt', '11pt' or '12pt').
125− #
126− # 'pointsize': '10pt',
217+#'pointsize': '10pt',
127
218
128− # Additional stuff for the LaTeX preamble.
219+# Additional stuff for the LaTeX preamble.
129− #
130− # 'preamble': '',
220+#'preamble': '',
131
221
132− # Latex figure (float) alignment
222+# Latex figure (float) alignment
133− #
134− # 'figure_align': 'htbp',
223+#'figure_align': 'htbp',
135}
224}
136
225
137# Grouping the document tree into LaTeX files. List of tuples
226# Grouping the document tree into LaTeX files. List of tuples
138# (source start file, target name, title,
227# (source start file, target name, title,
139# author, documentclass [howto, manual, or own class]).
228# author, documentclass [howto, manual, or own class]).
140latex_documents = [
229latex_documents = [
141− (master_doc, 'Servant.tex', u'Servant Documentation',
230+ (master_doc, 'servant.tex', u'servant Documentation',
142 u'Servant Contributors', 'manual'),
231 u'Servant Contributors', 'manual'),
143]
232]
144
233
234+# The name of an image file (relative to this directory) to place at the top of
235+# the title page.
236+#latex_logo = None
237+
238+# For "manual" documents, if this is true, then toplevel headings are parts,
239+# not chapters.
240+#latex_use_parts = False
241+
242+# If true, show page references after internal links.
243+#latex_show_pagerefs = False
244+
245+# If true, show URL addresses after external links.
246+#latex_show_urls = False
247+
248+# Documents to append as an appendix to all manuals.
249+#latex_appendices = []
250+
251+# If false, no module index is generated.
252+#latex_domain_indices = True
253+
145
254
146# -- Options for manual page output ---------------------------------------
255# -- Options for manual page output ---------------------------------------
147
256
148# One entry per manual page. List of tuples
257# One entry per manual page. List of tuples
149# (source start file, name, description, authors, manual section).
258# (source start file, name, description, authors, manual section).
150man_pages = [
259man_pages = [
151− (master_doc, 'servant', u'Servant Documentation',
260+ (master_doc, 'servant', u'servant Documentation',
152 [author], 1)
261 [author], 1)
153]
262]
154
263
264+# If true, show URL addresses after external links.
265+#man_show_urls = False
266+
155
267
156# -- Options for Texinfo output -------------------------------------------
268# -- Options for Texinfo output -------------------------------------------
157
269
@@ -159,13 +271,24 @@ man_pages = [
159# (source start file, target name, title, author,
271# (source start file, target name, title, author,
160# dir menu entry, description, category)
272# dir menu entry, description, category)
161texinfo_documents = [
273texinfo_documents = [
162− (master_doc, 'Servant', u'Servant Documentation',
274+ (master_doc, 'servant', u'servant Documentation',
163− author, 'Servant', 'One line description of project.',
275+ author, 'servant', 'One line description of project.',
164− 'Miscellaneous'),
276+ 'Miscellaneous'),
165]
277]
166
278
167−# -- Markdown -------------------------------------------------------------
279+# Documents to append as an appendix to all manuals.
280+#texinfo_appendices = []
281+
282+# If false, no module index is generated.
283+#texinfo_domain_indices = True
284+
285+# How to display URL addresses: 'footnote', 'no', or 'inline'.
286+#texinfo_show_urls = 'footnote'
287+
288+# If true, do not generate a @detailmenu in the "Top" node's menu.
289+#texinfo_no_detailmenu = False
168
290
169source_parsers = {
291source_parsers = {
292+ '.md': CommonMarkParser,
170 '.lhs': CommonMarkParser,
293 '.lhs': CommonMarkParser,
171}
294}
doc/cookbook/basic-auth/basic-auth.cabal+4−4
@@ -1,14 +1,14 @@
1−cabal-version: 2.2
2name: cookbook-basic-auth
1name: cookbook-basic-auth
3version: 0.1
2version: 0.1
4synopsis: Basic Authentication cookbook example
3synopsis: Basic Authentication cookbook example
5−homepage: http://docs.servant.dev/
4+homepage: http://haskell-servant.readthedocs.org/
6−license: BSD-3-Clause
5+license: BSD3
7license-file: ../../../servant/LICENSE
6license-file: ../../../servant/LICENSE
8author: Servant Contributors
7author: Servant Contributors
9maintainer: haskell-servant-maintainers@googlegroups.com
8maintainer: haskell-servant-maintainers@googlegroups.com
10build-type: Simple
9build-type: Simple
10+cabal-version: >=1.10
11−tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
11+tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2
12
12
13executable cookbook-basic-auth
13executable cookbook-basic-auth
14 main-is: BasicAuth.lhs
14 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−7
@@ -1,19 +1,12 @@
1packages:
1packages:
2 basic-auth/
2 basic-auth/
3− curl-mock/
4− db-mysql-basics/
5 db-sqlite-simple/
3 db-sqlite-simple/
6 db-postgres-pool/
4 db-postgres-pool/
7 using-custom-monad/
5 using-custom-monad/
8 jwt-and-basic-auth/
6 jwt-and-basic-auth/
9− hoist-server-with-context/
10 file-upload/
7 file-upload/
11 structuring-apis/
8 structuring-apis/
12 https/
9 https/
13− pagination/
14− sentry/
15− testing/
16− open-id-connect/
17 ../../servant
10 ../../servant
18 ../../servant-server
11 ../../servant-server
19 ../../servant-client-core
12 ../../servant-client-core
doc/cookbook/cabal.project.localdeleted

No changes to the content.

doc/cookbook/curl-mock/CurlMock.lhsdeleted−205
@@ -1,205 +0,0 @@
1−# Generating mock curl calls
2−
3−In 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.
5−Especially post requests with a request body are tedious to send manually.
6−
7−Also, we will learn how to use the servant-foreign library to generate stuff from servant APIs.
8−
9−
10−Language extensions and imports:
11−``` haskell
12−{-# LANGUAGE DataKinds #-}
13−{-# LANGUAGE DeriveGeneric #-}
14−{-# LANGUAGE FlexibleContexts #-}
15−{-# LANGUAGE FlexibleInstances #-}
16−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
17−{-# LANGUAGE MultiParamTypeClasses #-}
18−{-# LANGUAGE OverloadedStrings #-}
19−{-# LANGUAGE RankNTypes #-}
20−{-# LANGUAGE RecordWildCards #-}
21−{-# LANGUAGE ScopedTypeVariables #-}
22−{-# LANGUAGE TypeOperators #-}
23−
24−import Control.Lens ((^.))
25−import Data.Aeson
26−import Data.Aeson.Text
27−import Data.Proxy (Proxy (Proxy))
28−import Data.Text (Text)
29−import Data.Text.Encoding (decodeUtf8)
30−import qualified Data.Text.IO as T.IO
31−import qualified Data.Text.Lazy as LazyT
32−import GHC.Generics
33−import Servant ((:<|>), (:>), Get, JSON,
34− Post, ReqBody)
35−import Servant.Foreign (Foreign, GenerateList,
36− HasForeign, HasForeignType, Req,
37− Segment, SegmentType (Cap, Static),
38− argName, listFromAPI, path,
39− reqBody, reqMethod, reqUrl, typeFor,
40− unPathSegment, unSegment,)
41−import Test.QuickCheck.Arbitrary
42−import Test.QuickCheck.Arbitrary.Generic
43−import Test.QuickCheck.Gen (generate)
44−import qualified Data.Text as T
45−
46−```
47−
48−
49−Let's define our API:
50−
51−``` haskell
52−type UserAPI = "users" :> Get '[JSON] [User]
53− :<|> "new" :> "user" :> ReqBody '[JSON] User :> Post '[JSON] ()
54−
55−data User = User
56− { name :: String
57− , age :: Int
58− , email :: String
59− } deriving (Eq, Show, Generic)
60−
61−instance Arbitrary User where
62− arbitrary = genericArbitrary
63− shrink = genericShrink
64−instance ToJSON User
65−instance FromJSON User
66−```
67−
68−Notice the `Arbitrary User` instance which we will later need to create mock data.
69−
70−Also, the obligatory servant boilerplate:
71−
72−``` haskell
73−api :: Proxy UserAPI
74−api = Proxy
75−```
76−
77−
78−## servant-foreign and the HasForeignType Class
79−
80−Servant-foreign allows us to look into the API we designed.
81−The entry point is `listFromAPI` which takes three types and returns a list of endpoints:
82−
83−``` haskell ignore
84−listFromAPI :: (HasForeign lang ftype api, GenerateList ftype (Foreign ftype api)) => Proxy lang -> Proxy ftype -> Proxy api -> [Req ftype]
85−```
86−
87−This 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−We will not go into details here, but this allows us to create a value of type `ftype` for any type `a` in our API.
90−
91−In our case we want to create a mock of every type `a`.
92−
93−We create a new datatype that holds our mocked value. Well, not the mocked value itself. To mock it we need IO (random). So the promise of a mocked value after some IO is performed:
94−
95−``` haskell
96−data NoLang
97−
98−data Mocked = Mocked (IO Text)
99−```
100−
101−Now, we create an instance of `HasForeignType` for `NoLang` and `Mocked` for every `a` that implements `ToJSON` and `Arbitrary`:
102−``` haskell
103−instance (ToJSON a, Arbitrary a) => HasForeignType NoLang Mocked a where
104− typeFor _ _ _ =
105− Mocked (genText (Proxy :: Proxy a))
106−```
107−
108−What does `genText` do? It generates an arbitrary value of type `a` and encodes it as text. (And does some lazy to non-lazy text transformation we do not care about):
109−
110−``` haskell
111−genText :: (ToJSON a, Arbitrary a) => Proxy a -> IO Text
112−genText p =
113− fmap (\v -> LazyT.toStrict $ encodeToLazyText v) (genArb p)
114−
115−genArb :: Arbitrary a => Proxy a -> IO a
116−genArb _ =
117− generate arbitrary
118−```
119−
120−### Generating curl calls for every endpoint
121−
122−Everything is prepared now and we can start generating some curl calls.
123−
124−``` haskell
125−generateCurl :: (GenerateList Mocked (Foreign Mocked api), HasForeign NoLang Mocked api)
126− => Proxy api
127− -> Text
128− -> IO Text
129−generateCurl p host =
130− fmap T.unlines body
131− where
132− body = mapM (generateEndpoint host)
133− $ listFromAPI (Proxy :: Proxy NoLang) (Proxy :: Proxy Mocked) p
134−```
135−
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.
138−
139−``` haskell
140−generateEndpoint :: Text -> Req Mocked -> IO Text
141−generateEndpoint host req =
142− case maybeBody of
143− Just body ->
144− body >>= \b -> return $ T.intercalate " " [ "curl", "-X", method, "-d", "'" <> b <> "'"
145− , "-H 'Content-Type: application/json'", host <> "/" <> url ]
146− Nothing ->
147− return $ T.intercalate " " [ "curl", "-X", method, host <> "/" <> url ]
148− where
149− method = decodeUtf8 $ req ^. reqMethod
150−
151− url = T.intercalate "/" $ map segment (req ^. reqUrl . path)
152−
153− maybeBody = fmap (\(Mocked io) -> io) (req ^. reqBody)
154−
155−```
156−`servant-foreign` offers a multitude of lenses to be used with `Req`-values.
157−
158−`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).
160−
161−But how do we get our mocked json string? This seems to be a bit to short to be true:
162−
163−``` haskell ignore
164−maybeBody = fmap (\(Mocked io) -> io) (req ^. reqBody)
165−```
166−
167−But it is that simple!
168−The docs say `reqBody` gives us a `Maybe f`. What is `f`, you ask? As defined in `generateCurl`, `f` is `Mocked` and contains a `IO Text`. How is this `Mocked` value created? The `HasForeignType::typeFor` does it!
169−
170−Of course only if the endpoint has a request body.
171−
172−
173−Some (incomplete) code for url segments:
174−``` haskell
175−segment :: Segment Mocked -> Text
176−segment seg =
177− case unSegment seg of
178− Static p ->
179− unPathSegment p
180−
181− Cap arg ->
182− -- Left as exercise for the reader: Mock args in the url
183− unPathSegment $ arg ^. argName
184−```
185−
186−And now, lets hook it all up in our main function:
187−
188−``` haskell
189−main :: IO ()
190−main =
191− generateCurl api "localhost:8081" >>= T.IO.putStrLn
192−```
193−
194−Done:
195−
196−``` curl
197−curl -X GET localhost:8081/users
198−curl -X POST -d '{"email":"wV򝣀_b򆎘:z񁊞򲙲!(3DM V","age":10,"name":"=|W"}' -H 'Content-Type: application/json' localhost:8081/new/user
199−
200−```
201−
202−This 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.
204−
205−Also, we now know how to use `HasForeignType` and `listFromAPI` to generate anything we want.
doc/cookbook/curl-mock/curl-mock.cabaldeleted−29
@@ -1,29 +0,0 @@
1−cabal-version: 2.2
2−name: cookbook-curl-mock
3−version: 0.1
4−synopsis: Generate curl mock requests 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==8.6.5, GHC==8.8.3, GHC ==8.10.7
12−
13−executable cookbock-curl-mock
14− if impl(ghc >= 9.2)
15− -- generic-arbitrary is incompatible
16− buildable: False
17− main-is: CurlMock.lhs
18− build-depends: base == 4.*
19− , aeson
20− , lens
21− , text
22− , servant
23− , servant-server
24− , servant-foreign
25− , QuickCheck
26− , generic-arbitrary
27− default-language: Haskell2010
28− ghc-options: -Wall -pgmL markdown-unlit
29− build-tool-depends: markdown-unlit:markdown-unlit
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/PostgresPool.lhs+1−1
@@ -61,7 +61,7 @@ to flexibly set up a whole bunch of PostgreSQL connections tailored to our
61needs and then to forget about it all by simply asking for a connection
61needs and then to forget about it all by simply asking for a connection
62using `withResource`.
62using `withResource`.
63
63
64−The handlers are straightforward. One takes care of inserting a new
64+The handlers are straighforward. One takes care of inserting a new
65value in the database while the other fetches all messages and returns
65value in the database while the other fetches all messages and returns
66them. We also provide a function for serving our web app given a PostgreSQL
66them. We also provide a function for serving our web app given a PostgreSQL
67connection pool, which simply calls servant-server's `serve` function.
67connection pool, which simply calls servant-server's `serve` function.
doc/cookbook/db-postgres-pool/db-postgres-pool.cabal+4−4
@@ -1,14 +1,14 @@
1−cabal-version: 2.2
2name: cookbook-db-postgres-pool
1name: cookbook-db-postgres-pool
3version: 0.1
2version: 0.1
4synopsis: Simple PostgreSQL connection pool cookbook example
3synopsis: Simple PostgreSQL connection pool cookbook example
5−homepage: http://docs.servant.dev/
4+homepage: http://haskell-servant.readthedocs.org/
6−license: BSD-3-Clause
5+license: BSD3
7license-file: ../../../servant/LICENSE
6license-file: ../../../servant/LICENSE
8author: Servant Contributors
7author: Servant Contributors
9maintainer: haskell-servant-maintainers@googlegroups.com
8maintainer: haskell-servant-maintainers@googlegroups.com
10build-type: Simple
9build-type: Simple
10+cabal-version: >=1.10
11−tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
11+tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2
12
12
13executable cookbook-db-postgres-pool
13executable cookbook-db-postgres-pool
14 main-is: PostgresPool.lhs
14 main-is: PostgresPool.lhs
doc/cookbook/db-sqlite-simple/DBConnection.lhs+2−2
@@ -42,9 +42,9 @@ initDB dbfile = withConnection dbfile $ \conn ->
42 "CREATE TABLE IF NOT EXISTS messages (msg text not null)"
42 "CREATE TABLE IF NOT EXISTS messages (msg text not null)"
43```
43```
44
44
45−Next, our server implementation. It will be parametrised (take as an
45+Next, our server implementation. It will be parametrised (take as
46argument) by the name of the file that contains our SQLite database.
46argument) by the name of the file that contains our SQLite database.
47−The handlers are straightforward. One takes care of inserting a new
47+The handlers are straighforward. One takes care of inserting a new
48value in the database while the other fetches all messages and returns
48value in the database while the other fetches all messages and returns
49them. We also provide a function for serving our web app given an
49them. We also provide a function for serving our web app given an
50SQLite database file, which simply calls servant-server's `serve` function.
50SQLite database file, which simply calls servant-server's `serve` function.
doc/cookbook/db-sqlite-simple/db-sqlite-simple.cabal+5−5
@@ -1,14 +1,14 @@
1−cabal-version: 2.2
2name: cookbook-db-sqlite-simple
1name: cookbook-db-sqlite-simple
3version: 0.1
2version: 0.1
4synopsis: Simple SQLite DB cookbook example
3synopsis: Simple SQLite DB cookbook example
5−homepage: http://docs.servant.dev/
4+homepage: http://haskell-servant.readthedocs.org/
6−license: BSD-3-Clause
5+license: BSD3
7license-file: ../../../servant/LICENSE
6license-file: ../../../servant/LICENSE
8author: Servant Contributors
7author: Servant Contributors
9maintainer: haskell-servant-maintainers@googlegroups.com
8maintainer: haskell-servant-maintainers@googlegroups.com
10build-type: Simple
9build-type: Simple
10+cabal-version: >=1.10
11−tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
11+tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2
12
12
13executable cookbook-db-sqlite-simple
13executable cookbook-db-sqlite-simple
14 main-is: DBConnection.lhs
14 main-is: DBConnection.lhs
@@ -23,7 +23,7 @@ executable cookbook-db-sqlite-simple
23 , http-types >= 0.12
23 , http-types >= 0.12
24 , markdown-unlit >= 0.4
24 , markdown-unlit >= 0.4
25 , http-client >= 0.5
25 , http-client >= 0.5
26− , sqlite-simple >= 0.4.5.0
26+ , sqlite-simple >= 0.4
27 , transformers
27 , transformers
28 default-language: Haskell2010
28 default-language: Haskell2010
29 ghc-options: -Wall -pgmL markdown-unlit
29 ghc-options: -Wall -pgmL markdown-unlit
doc/cookbook/file-upload/FileUpload.lhs+5−5
@@ -17,7 +17,7 @@ import Control.Exception
17import Control.Monad
17import Control.Monad
18import Control.Monad.IO.Class
18import Control.Monad.IO.Class
19import Data.Text.Encoding (encodeUtf8)
19import Data.Text.Encoding (encodeUtf8)
20−import Network.Socket (withSocketsDo)
20+import Network (withSocketsDo)
21import Network.HTTP.Client hiding (Proxy)
21import Network.HTTP.Client hiding (Proxy)
22import Network.HTTP.Client.MultipartFormData
22import Network.HTTP.Client.MultipartFormData
23import Network.Wai.Handler.Warp
23import Network.Wai.Handler.Warp
@@ -48,7 +48,7 @@ dedicated `ReqBody`-like combinator named
48This combinator takes two parameters. The first one is the
48This combinator takes two parameters. The first one is the
49"backend" to use. Currently, you only have the choice between
49"backend" to use. Currently, you only have the choice between
50`Mem` and `Tmp`. The former loads the entire input in memory,
50`Mem` and `Tmp`. The former loads the entire input in memory,
51−even the uploaded files, while `Tmp` will stream uploaded
51+even the uploadedd files, while `Tmp` will stream uploaded
52files to some temporary directory.
52files to some temporary directory.
53
53
54The second parameter is the type you want the multipart data
54The second parameter is the type you want the multipart data
@@ -90,8 +90,8 @@ startServer = run 8080 (serve api upload)
90
90
91Finally, a main function that brings up our server and
91Finally, a main function that brings up our server and
92sends some test request with `http-client` (and not
92sends some test request with `http-client` (and not
93−servant-client this time, as servant-multipart does not
93+servant-client this time, has servant-multipart does not
94−yet have support for client generation).
94+yet have support for client generation.
95
95
96``` haskell
96``` haskell
97main :: IO ()
97main :: IO ()
@@ -126,7 +126,7 @@ Content of "README.md"
126
126
127## Getting Started
127## Getting Started
128
128
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
130introduces the core features of servant. After this article, you should be able
130introduces the core features of servant. After this article, you should be able
131to write your first servant webservices, learning the rest from the haddocks'
131to write your first servant webservices, learning the rest from the haddocks'
132examples.
132examples.
doc/cookbook/file-upload/file-upload.cabal+4−4
@@ -1,14 +1,14 @@
1−cabal-version: 2.2
2name: cookbook-file-upload
1name: cookbook-file-upload
3version: 0.1
2version: 0.1
4synopsis: File upload cookbook example
3synopsis: File upload cookbook example
5−homepage: http://docs.servant.dev/
4+homepage: http://haskell-servant.readthedocs.org/
6−license: BSD-3-Clause
5+license: BSD3
7license-file: ../../../servant/LICENSE
6license-file: ../../../servant/LICENSE
8author: Servant Contributors
7author: Servant Contributors
9maintainer: haskell-servant-maintainers@googlegroups.com
8maintainer: haskell-servant-maintainers@googlegroups.com
10build-type: Simple
9build-type: Simple
10+cabal-version: >=1.10
11−tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
11+tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2
12
12
13executable cookbook-file-upload
13executable cookbook-file-upload
14 main-is: FileUpload.lhs
14 main-is: FileUpload.lhs
doc/cookbook/generic/Generic.lhsdeleted−141
@@ -1,141 +0,0 @@
1−# Using generics
2−
3−```haskell
4−{-# LANGUAGE DataKinds #-}
5−{-# LANGUAGE DeriveGeneric #-}
6−{-# LANGUAGE RankNTypes #-}
7−{-# LANGUAGE TypeOperators #-}
8−module Main (main, api, getLink, routesLinks, cliGet) where
9−
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)
15−
16−import Servant
17−import Servant.Client
18−
19−import Servant.API.Generic
20−import Servant.Client.Generic
21−import Servant.Server.Generic
22−```
23−
24−The usage is simple, if you only need a collection of routes.
25−First you define a record with field types prefixed by a parameter `route`:
26−
27−```haskell
28−data Routes route = Routes
29− { _get :: route :- Capture "id" Int :> Get '[JSON] String
30− , _put :: route :- ReqBody '[JSON] Int :> Put '[JSON] Bool
31− }
32− deriving (Generic)
33−```
34−
35−Then we'll use this data type to define API, links, server and client.
36−
37−## API
38−
39−You can get a `Proxy` of the API using `genericApi`:
40−
41−```haskell
42−api :: Proxy (ToServantApi Routes)
43−api = genericApi (Proxy :: Proxy Routes)
44−```
45−
46−It's recommended to use `genericApi` function, as then you'll get
47−better error message, for example if you forget to `derive Generic`.
48−
49−## Links
50−
51−The 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,
53−as field accessors work as proxies:
54−
55−```haskell
56−getLink :: Int -> Link
57−getLink = fieldLink _get
58−```
59−
60−We can also get all links at once, as a record:
61−
62−```haskell
63−routesLinks :: Routes (AsLink Link)
64−routesLinks = allFieldLinks
65−```
66−
67−## Client
68−
69−Even more power starts to show when we generate a record of client functions.
70−Here we use `genericClientHoist` function, which lets us simultaneously
71−hoist the monad, in this case from `ClientM` to `IO`.
72−
73−```haskell
74−cliRoutes :: Routes (AsClientT IO)
75−cliRoutes = genericClientHoist
76− (\x -> runClientM x env >>= either throwIO return)
77− where
78− env = error "undefined environment"
79−
80−cliGet :: Int -> IO String
81−cliGet = _get cliRoutes
82−```
83−
84−## Server
85−
86−Finally, probably the most handy usage: we can convert record of handlers into
87−the server implementation:
88−
89−```haskell
90−record :: Routes AsServer
91−record = Routes
92− { _get = return . show
93− , _put = return . odd
94− }
95−
96−app :: Application
97−app = genericServe record
98−
99−main :: IO ()
100−main = do
101− args <- getArgs
102− case args of
103− ("run":_) -> do
104− putStrLn "Starting cookbook-generic at http://localhost:8000"
105− 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)
110− _ -> putStrLn "To run, pass 'run' argument: cabal new-run cookbook-generic run"
111−```
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.cabaldeleted−25
@@ -1,25 +0,0 @@
1−cabal-version: 2.2
2−name: cookbook-generic
3−version: 0.1
4−synopsis: Using custom monad to pass a state between handlers
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-using-custom-monad
14− main-is: Generic.lhs
15− build-depends: base == 4.*
16− , servant
17− , servant-client
18− , servant-client-core
19− , servant-server
20− , base-compat
21− , warp >= 3.2
22− , transformers >= 0.3
23− default-language: Haskell2010
24− ghc-options: -Wall -pgmL markdown-unlit
25− build-tool-depends: markdown-unlit:markdown-unlit >= 0.4
doc/cookbook/hoist-server-with-context/HoistServerWithContext.lhsdeleted−413
@@ -1,413 +0,0 @@
1−# Hoist Server With Context for Custom Monads
2−
3−In this example we'll combine some of the patterns we've seen in other examples
4−in order to demonstrate using a custom monad with Servant's `Context` and the function
5−`hoistServerWithContext`.
6−
7−`hoistServerWithContext` is a pattern you may encounter if you are trying to use a library such as
8−[servant-auth-server](https://hackage.haskell.org/package/servant-auth-server) along
9−with your own custom monad.
10−
11−In this example, our custom monad will be based on the commonly used `ReaderT env IO a` stack.
12−We'll create an `AppCtx` to represent our `env` and include some logging utilities as well as
13−other variables we'd like to have available.
14−
15−In addition, in order to demonstrate a custom `Context`, we'll also include authentication in
16−our example. As noted previously (in [jwt-and-basic-auth](../jwt-and-basic-auth/JWTAndBasicAuth.lhs)),
17−while basic authentication comes with Servant itself,
18−[servant-auth](https://hackage.haskell.org/package/servant-auth) and
19−[servant-auth-server](https://hackage.haskell.org/package/servant-auth-server)
20−packages are needed for JWT-based authentication.
21−
22−Finally, we're going to use [fast-logger](http://hackage.haskell.org/package/fast-logger)
23−for our logging example below.
24−
25−This recipe uses the following ingredients:
26−
27−```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−
37−import Control.Monad.IO.Class (liftIO)
38−import Control.Monad.Reader
39−import Data.Aeson
40−import Data.Default
41−import Data.Proxy
42−import Data.Text
43−import Data.Time.Clock ( UTCTime, getCurrentTime )
44−import GHC.Generics
45−import Network.Wai (Middleware)
46−import Network.Wai.Handler.Warp as Warp
47−import Network.Wai.Middleware.RequestLogger
48−import Network.Wai.Middleware.RequestLogger.JSON
49−import Servant as S
50−import Servant.Auth as SA
51−import Servant.Auth.Server as SAS
52−import System.Log.FastLogger ( ToLogStr(..)
53− , LoggerSet
54− , defaultBufSize
55− , newStdoutLoggerSet
56− , flushLogStr
57− , pushLogStrLn )
58−
59−
60−port :: Int
61−port = 3001
62−```
63−
64−## Custom Monad
65−
66−Let's say we'd like to create a custom monad based on `ReaderT env` in order to hold
67−access to a config object as well as some logging utilities.
68−
69−With that, we could define an `AppCtx` and `AppM` like this:
70−
71−```haskell
72−type AppM = ReaderT AppCtx Handler
73−
74−data AppCtx = AppCtx {
75− _getConfig :: SiteConfig
76− , _getLogger :: LoggerSet
77− }
78−
79−data SiteConfig = SiteConfig {
80− environment :: !Text
81− , version :: !Text
82− , adminUsername :: !Text
83− , adminPasswd :: !Text
84−} deriving (Generic, Show)
85−```
86−
87−This `SiteConfig` is a simple example: it refers to our deployment environment as well as an
88−application version. For instance, we may do something different based on the environment our app is
89−deployed into. When emitting log messages, we may want to include information about
90−the deployed version of our application.
91−
92−In addition, we're going to identify a single admin user in our config and use
93−that definition to authenticate requests inside our handlers. This is not too
94−flexible (and probably not too secure...), but it works as a simple example.
95−
96−## Logging
97−
98−A common contemporary pattern is to emit log messages as JSON for later ingestion
99−into a database like Elasticsearch.
100−
101−To emit JSON log messages, we'll create a `LogMessage` object and make it so we can turn it
102−into a JSON-encoded `LogStr` (a type from `fast-logger`).
103−
104−```haskell
105−data LogMessage = LogMessage {
106− message :: !Text
107− , timestamp :: !UTCTime
108− , level :: !Text
109− , lversion :: !Text
110− , lenvironment :: !Text
111−} deriving (Eq, Show, Generic)
112−
113−instance FromJSON LogMessage
114−instance ToJSON LogMessage where
115− toEncoding = genericToEncoding defaultOptions
116−
117−instance ToLogStr LogMessage where
118− toLogStr = toLogStr . encode
119−```
120−
121−Eventually, when we'd like to emit a log message inside one of our Handlers, it'll look like this:
122−
123−```haskell
124−sampleHandler :: AppM LogMessage
125−sampleHandler = do
126− config <- asks _getConfig
127− logset <- asks _getLogger
128−
129− tstamp <- liftIO getCurrentTime
130− let logMsg = LogMessage { message = "let's do some logging!"
131− , timestamp = tstamp
132− , level = "info"
133− , lversion = version config
134− , lenvironment = environment config
135− }
136− -- emit log message
137− liftIO $ pushLogStrLn logset $ toLogStr logMsg
138− -- return handler result (for simplicity, result is also a LogMessage)
139− pure logMsg
140−```
141−
142−## Authentication
143−
144−To demonstrate the other part of this recipe, we are going to use a simple
145−representation of a user, someone who may have access to an admin section of our site:
146−
147−```haskell
148−data AdminUser = AdminUser { name :: Text }
149− deriving (Eq, Show, Read, Generic)
150−```
151−
152−The following instances are needed for JWT:
153−
154−```haskell
155−instance ToJSON AdminUser
156−instance FromJSON AdminUser
157−instance SAS.ToJWT AdminUser
158−instance SAS.FromJWT AdminUser
159−```
160−
161−## API
162−
163−Now we can define our API.
164−
165−We'll have an `admin` endpoint and a `login` endpoint that takes a `LoginForm`:
166−
167−```haskell
168−type AdminApi =
169− "admin" :> Get '[JSON] LogMessage
170−
171−type LoginApi =
172− "login"
173− :> ReqBody '[JSON] LoginForm
174− :> Post '[JSON] (Headers '[ Header "Set-Cookie" SetCookie, Header "Set-Cookie" SetCookie] LogMessage)
175−
176−data LoginForm = LoginForm {
177− username :: Text
178− , password :: Text
179−} deriving (Eq, Show, Generic)
180−
181−instance ToJSON LoginForm
182−instance FromJSON LoginForm
183−```
184−
185−We can combine both APIs into one like so:
186−
187−```haskell
188−type AdminAndLogin auths = (SAS.Auth auths AdminUser :> AdminApi) :<|> LoginApi
189−```
190−
191−## Server
192−
193−When we define our server, we'll have to define handlers for the `AdminApi` and the `LoginApi` and
194−we'll have to supply `JWTSettings` and `CookieSettings` so our `login` handler can authenticate users:
195−
196−```haskell
197−adminServer :: SAS.CookieSettings -> SAS.JWTSettings -> ServerT (AdminAndLogin auths) AppM
198−adminServer cs jwts = adminHandler :<|> loginHandler cs jwts
199−```
200−
201−The `admin` route should receive an authenticated `AdminUser` as an argument
202−or it should return a `401`:
203−
204−```haskell
205−adminHandler :: AuthResult AdminUser -> AppM LogMessage
206−adminHandler (SAS.Authenticated adminUser) = do
207− config <- asks _getConfig
208− logset <- asks _getLogger
209−
210− tstamp <- liftIO getCurrentTime
211− let logMsg = LogMessage { message = "Admin User accessing admin: " <> name adminUser
212− , timestamp = tstamp
213− , level = "info"
214− , lversion = version config
215− , lenvironment = environment config
216− }
217− -- emit log message
218− liftIO $ pushLogStrLn logset $ toLogStr logMsg
219− -- return handler result (for simplicity, result is a LogMessage)
220− pure logMsg
221−adminHandler _ = throwError err401
222−```
223−
224−By contrast, the `login` handler is waiting for a `POST` with a login form.
225−
226−If login is successful, it will set session cookies and return a value.
227−
228−Here we're going to include lots of log messages:
229−
230−```haskell
231−loginHandler :: CookieSettings
232− -> JWTSettings
233− -> LoginForm
234− -> AppM (Headers '[ Header "Set-Cookie" SetCookie, Header "Set-Cookie" SetCookie] LogMessage)
235−loginHandler cookieSettings jwtSettings form = do
236− config <- asks _getConfig
237− logset <- asks _getLogger
238−
239− tstamp <- liftIO getCurrentTime
240− let logMsg = LogMessage { message = "AdminUser login attempt failed!"
241− , timestamp = tstamp
242− , level = "info"
243− , lversion = version config
244− , lenvironment = environment config
245− }
246− case validateLogin config form of
247− Nothing -> do
248− liftIO $ pushLogStrLn logset $ toLogStr logMsg
249− throwError err401
250− Just usr -> do
251− mApplyCookies <- liftIO $ SAS.acceptLogin cookieSettings jwtSettings usr
252− case mApplyCookies of
253− Nothing -> do
254− liftIO $ pushLogStrLn logset $ toLogStr logMsg
255− throwError err401
256− Just applyCookies -> do
257− let successMsg = logMsg{message = "AdminUser successfully authenticated!"}
258− liftIO $ pushLogStrLn logset $ toLogStr successMsg
259− pure $ applyCookies successMsg
260−loginHandler _ _ _ = throwError err401
261−
262−validateLogin :: SiteConfig -> LoginForm -> Maybe AdminUser
263−validateLogin config (LoginForm uname passwd ) =
264− if (uname == adminUsername config) && (passwd == adminPasswd config)
265− then Just $ AdminUser uname
266− else Nothing
267−```
268−
269−## `serveWithContext` and `hoistServerWithContext`
270−
271−In order to build a working server, we'll need to `hoist` our custom monad
272−into Servant's Handler monad. We'll also need to pass in the proper context to ensure
273−authentication will work.
274−
275−This will require both `serveWithContext` and `hoistServerWithContext`.
276−
277−Let's define the function which will create our `Application`:
278−
279−```haskell
280−adminLoginApi :: Proxy (AdminAndLogin '[JWT])
281−adminLoginApi = Proxy
282−
283−mkApp :: Context '[SAS.CookieSettings, SAS.JWTSettings] -> CookieSettings -> JWTSettings -> AppCtx -> Application
284−mkApp cfg cs jwts ctx =
285− serveWithContext adminLoginApi cfg $
286− hoistServerWithContext adminLoginApi (Proxy :: Proxy '[SAS.CookieSettings, SAS.JWTSettings])
287− (flip runReaderT ctx) (adminServer cs jwts)
288−```
289−
290−One footnote: because we'd like our logs to be in JSON form, we'll also create a `Middleware` object
291−so that `Warp` *also* will emit logs as JSON. This will ensure *all* logs are emitted as JSON:
292−
293−```haskell
294−jsonRequestLogger :: IO Middleware
295−jsonRequestLogger =
296− mkRequestLogger $ def { outputFormat = CustomOutputFormatWithDetails formatAsJSON }
297−```
298−
299−We now have all the pieces we need to serve our application inside a `main` function:
300−
301−```haskell
302−main :: IO ()
303−main = do
304− -- typically, we'd create our config from environment variables
305− -- but we're going to just make one here
306− let config = SiteConfig "dev" "1.0.0" "admin" "secretPassword"
307−
308− warpLogger <- jsonRequestLogger
309− appLogger <- newStdoutLoggerSet defaultBufSize
310−
311− tstamp <- getCurrentTime
312− myKey <- generateKey
313−
314− let lgmsg = LogMessage {
315− message = "My app starting up!"
316− , timestamp = tstamp
317− , level = "info"
318− , lversion = version config
319− , lenvironment = environment config
320− }
321− pushLogStrLn appLogger (toLogStr lgmsg) >> flushLogStr appLogger
322−
323− let ctx = AppCtx config appLogger
324−
325− warpSettings = Warp.defaultSettings
326− portSettings = Warp.setPort port warpSettings
327− settings = Warp.setTimeout 55 portSettings
328− jwtCfg = defaultJWTSettings myKey
329− cookieCfg = if environment config == "dev"
330− then defaultCookieSettings{cookieIsSecure=SAS.NotSecure}
331− else defaultCookieSettings
332− cfg = cookieCfg :. jwtCfg :. EmptyContext
333−
334− Warp.runSettings settings $ warpLogger $ mkApp cfg cookieCfg jwtCfg ctx
335−```
336−
337−
338−## Usage
339−
340−Now we can run it and try it out with `curl`. In one terminal, let's run our application
341−and see what our log output looks like:
342−
343−```$ ./cookbook-hoist-server-with-context
344−{"message":"My app starting up!","timestamp":"2018-10-04T00:33:12.482568Z","level":"info","lversion":"1.0.0","lenvironment":"dev"}
345−```
346−
347−In another terminal, let's ensure that it fails with `err401` if
348−we're not authenticated:
349−
350−```
351−$ curl -v 'http://localhost:3001/admin'
352−…
353−< HTTP/1.1 401 Unauthorized
354−```
355−
356−```
357−$ curl -v -XPOST 'http://localhost:3001/login' \
358− -H "Content-Type:application/json" \
359− -d '{"username": "bad", "password": "wrong"}'
360−…
361−< HTTP/1.1 401 Unauthorized
362−```
363−
364−And in the other terminal with our log messages (from our JSON `Middleware`):
365−
366−```
367−{"time":"03/Oct/2018:17:35:56 -0700","response":{"status":401,"size":null,"body":""},"request":{"httpVersion":"1.1","path":"/admin","size":0,"body":"","durationMs":0.22,"remoteHost":{"hostAddress":"127.0.0.1","port":51029},"headers":[["Host","localhost:3001"],["User-Agent","curl/7.60.0"],["Accept","*/*"]],"queryString":[],"method":"GET"}}
368−```
369−
370−Now let's see that authentication works, and that we get JWTs:
371−
372−```
373−$ curl -v -XPOST 'http://localhost:3001/login' \
374− -H "Content-Type:application/json" \
375− -d '{"username": "admin", "password": "secretPassword"}'
376−…
377−< HTTP/1.1 200 OK
378−...
379−< Server: Warp/3.2.25
380−< Content-Type: application/json;charset=utf-8
381−< Set-Cookie: JWT-Cookie=eyJhbGciOiJIUzUxMiJ9.eyJkYXQiOnsibmFtZSI6ImFkbWluIn19.SIoRcABKSO4mXnRifzqPWlHJUhVwuy32Qon7s1E_c3vHOsLXdXyX4V4eXOw9tMFoeIqgsXMZucqoFb36vAdKwQ; Path=/; HttpOnly; SameSite=Lax
382−< Set-Cookie: XSRF-TOKEN=y5PmrYHX3ywFUCwGRQqHh1TDheTLiQpwRQB3FFRd8N4=; Path=/
383−...
384−{"message":"AdminUser succesfully authenticated!","timestamp":"2018-10-04T00:37:44.455441Z","level":"info","lversion":"1.0.0","lenvironment":"dev"}
385−```
386−
387−And in the other terminal with our log messages (note that logging out passwords is insecure...):
388−
389−```
390−{"message":"AdminUser succesfully authenticated!","timestamp":"2018-10-04T00:37:44.455441Z","level":"info","lversion":"1.0.0","lenvironment":"dev"}
391−{"time":"03/Oct/2018:17:37:44 -0700","response":{"status":200,"size":null,"body":null},"request":{"httpVersion":"1.1","path":"/login","size":51,"body":"{\"username\": \"admin\", \"password\": \"secretPassword\"}","durationMs":0.23,"remoteHost":{"hostAddress":"127.0.0.1","port":51044},"headers":[["Host","localhost:3001"],["User-Agent","curl/7.60.0"],["Accept","*/*"],["Content-Type","application/json"],["Content-Length","51"]],"queryString":[],"method":"POST"}}
392−```
393−
394−Finally, let's make sure we can access a protected resource with our tokens:
395−
396−```
397−$ export jwt=eyJhbGciOiJIUzUxMiJ9.eyJkYXQiOnsibmFtZSI6ImFkbWluIn19.SIoRcABKSO4mXnRifzqPWlHJUhVwuy32Qon7s1E_c3vHOsLXdXyX4V4eXOw9tMFoeIqgsXMZucqoFb36vAdKwQ
398−$ curl -v \
399− -H "Authorization: Bearer $jwt" \
400− 'http://localhost:3001/admin'
401−…
402−< HTTP/1.1 200 OK
403−{"message":"Admin User accessing admin: admin","timestamp":"2018-10-04T00:58:07.216605Z","level":"info","lversion":"1.0.0","lenvironment":"dev"}
404−```
405−
406−And we should see this message logged-out as well:
407−
408−```
409−{"message":"Admin User accessing admin: admin","timestamp":"2018-10-04T00:58:07.216605Z","level":"info","lversion":"1.0.0","lenvironment":"dev"}
410−```
411−
412−This program is available as a cabal project
413−[here](https://github.com/haskell-servant/servant/tree/master/doc/cookbook/hoist-server-with-context).
doc/cookbook/hoist-server-with-context/hoist-server-with-context.cabaldeleted−37
@@ -1,37 +0,0 @@
1−cabal-version: 2.2
2−name: cookbook-hoist-server-with-context
3−version: 0.0.1
4−synopsis: JWT and basic access authentication with a Custom Monad cookbook example
5−description: Using servant-auth to support both JWT-based and basic
6− authentication.
7−homepage: http://docs.servant.dev/
8−license: BSD-3-Clause
9−license-file: ../../../servant/LICENSE
10−author: Servant Contributors
11−maintainer: haskell-servant-maintainers@googlegroups.com
12−category: Servant
13−build-type: Simple
14−tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
15−
16−executable cookbook-hoist-server-with-context
17− main-is: HoistServerWithContext.lhs
18− build-depends: base == 4.*
19− , base-compat
20− , text >= 1.2
21− , aeson >= 1.2
22− , data-default
23− , fast-logger
24− , servant
25− , servant-server
26− , servant-auth >= 0.3.2
27− , servant-auth-server >= 0.4.4.0
28− , time
29− , warp >= 3.2
30− , wai >= 3.2
31− , wai-extra
32− , http-types >= 0.12
33− , bytestring >= 0.10.4
34− , mtl
35− default-language: Haskell2010
36− ghc-options: -Wall -pgmL markdown-unlit
37− build-tool-depends: markdown-unlit:markdown-unlit
doc/cookbook/https/Https.lhs+5−5
@@ -34,16 +34,16 @@ app = serve api server
34```
34```
35
35
36It's now time to actually run the `Application`.
36It'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)
38package provides two functions for running an `Application`, called
38package 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)
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/docs/Network-Wai-Handler-WarpTLS.html#v:runTLSSocket).
40+and [`runTLSSocket`](https://hackage.haskell.org/package/warp-tls-3.2.4/docs/Network-Wai-Handler-WarpTLS.html#v:runTLSSocket).
41We will be using the first one.
41We will be using the first one.
42
42
43It takes two arguments,
43It 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)
45(certificates, keys, ciphers, etc)
45(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)
47(port, logger, etc).
47(port, logger, etc).
48
48
49We will be using very simple settings for this example but you are of
49We 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
2name: cookbook-https
1name: cookbook-https
3version: 0.1
2version: 0.1
4synopsis: HTTPS cookbook example
3synopsis: HTTPS cookbook example
5−homepage: http://docs.servant.dev/
4+homepage: http://haskell-servant.readthedocs.org/
6−license: BSD-3-Clause
5+license: BSD3
7license-file: ../../../servant/LICENSE
6license-file: ../../../servant/LICENSE
8author: Servant Contributors
7author: Servant Contributors
9maintainer: haskell-servant-maintainers@googlegroups.com
8maintainer: haskell-servant-maintainers@googlegroups.com
10build-type: Simple
9build-type: Simple
10+cabal-version: >=1.10
11−tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
11+tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2
12
12
13executable cookbook-https
13executable cookbook-https
14 main-is: Https.lhs
14 main-is: Https.lhs
@@ -17,7 +17,7 @@ executable cookbook-https
17 , servant-server
17 , servant-server
18 , wai >= 3.2
18 , wai >= 3.2
19 , warp >= 3.2
19 , warp >= 3.2
20− , warp-tls >= 3.2.9
20+ , warp-tls >= 3.2
21 , markdown-unlit >= 0.4
21 , markdown-unlit >= 0.4
22 default-language: Haskell2010
22 default-language: Haskell2010
23 ghc-options: -Wall -pgmL markdown-unlit
23 ghc-options: -Wall -pgmL markdown-unlit
doc/cookbook/index.rst+2−15
@@ -6,8 +6,8 @@ how to solve many common problems with servant. If you're
6interested in contributing examples of your own, feel free
6interested in contributing examples of your own, feel free
7to open an issue or a pull request on
7to open an issue or a pull request on
8`our github repository <https://github.com/haskell-servant/servant>`_
8`our github repository <https://github.com/haskell-servant/servant>`_
9−or even to just get in touch with us on the `**#haskell-servant** IRC channel
9+or even to just get in touch with us on the **#servant** IRC channel
10−on libera.chat <https://web.libera.chat/#haskell-servant>_ or on
10+on freenode or on
11`the mailing list <https://groups.google.com/forum/#!forum/haskell-servant>`_.
11`the mailing list <https://groups.google.com/forum/#!forum/haskell-servant>`_.
12
12
13The scope is very wide. Simple and fancy authentication schemes,
13The scope is very wide. Simple and fancy authentication schemes,
@@ -18,23 +18,10 @@ you name it!
18 :maxdepth: 1
18 :maxdepth: 1
19
19
20 structuring-apis/StructuringApis.lhs
20 structuring-apis/StructuringApis.lhs
21− generic/Generic.lhs
22 https/Https.lhs
21 https/Https.lhs
23− db-mysql-basics/MysqlBasics.lhs
24 db-sqlite-simple/DBConnection.lhs
22 db-sqlite-simple/DBConnection.lhs
25 db-postgres-pool/PostgresPool.lhs
23 db-postgres-pool/PostgresPool.lhs
26 using-custom-monad/UsingCustomMonad.lhs
24 using-custom-monad/UsingCustomMonad.lhs
27− using-free-client/UsingFreeClient.lhs
28− custom-errors/CustomErrors.lhs
29− uverb/UVerb.lhs
30 basic-auth/BasicAuth.lhs
25 basic-auth/BasicAuth.lhs
31− basic-streaming/Streaming.lhs
32 jwt-and-basic-auth/JWTAndBasicAuth.lhs
26 jwt-and-basic-auth/JWTAndBasicAuth.lhs
33− hoist-server-with-context/HoistServerWithContext.lhs
34 file-upload/FileUpload.lhs
27 file-upload/FileUpload.lhs
35− pagination/Pagination.lhs
36− curl-mock/CurlMock.lhs
37− sentry/Sentry.lhs
38− 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+8−5
@@ -1,19 +1,22 @@
1−cabal-version: 2.2
2name: cookbook-jwt-and-basic-auth
1name: cookbook-jwt-and-basic-auth
3version: 0.0.1
2version: 0.0.1
4synopsis: JWT and basic access authentication cookbook example
3synopsis: JWT and basic access authentication cookbook example
5description: Using servant-auth to support both JWT-based and basic
4description: Using servant-auth to support both JWT-based and basic
6 authentication.
5 authentication.
7−homepage: http://docs.servant.dev/
6+homepage: http://haskell-servant.readthedocs.org/
8−license: BSD-3-Clause
7+license: BSD3
9license-file: ../../../servant/LICENSE
8license-file: ../../../servant/LICENSE
10author: Servant Contributors
9author: Servant Contributors
11maintainer: haskell-servant-maintainers@googlegroups.com
10maintainer: haskell-servant-maintainers@googlegroups.com
12category: Servant
11category: Servant
13build-type: Simple
12build-type: Simple
13+cabal-version: >=1.10
14−tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
14+tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2
15
15
16executable cookbook-jwt-and-basic-auth
16executable cookbook-jwt-and-basic-auth
17+ if !impl(ghc >= 7.10)
18+ buildable: False
19+
17 main-is: JWTAndBasicAuth.lhs
20 main-is: JWTAndBasicAuth.lhs
18 build-depends: base == 4.*
21 build-depends: base == 4.*
19 , text >= 1.2
22 , text >= 1.2
@@ -22,7 +25,7 @@ executable cookbook-jwt-and-basic-auth
22 , servant
25 , servant
23 , servant-client
26 , servant-client
24 , servant-server
27 , servant-server
25− , servant-auth == 0.4.*
28+ , servant-auth ==0.3.*
26 , servant-auth-server >= 0.3.1.0
29 , servant-auth-server >= 0.3.1.0
27 , warp >= 3.2
30 , warp >= 3.2
28 , wai >= 3.2
31 , 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.lhsdeleted−250
@@ -1,250 +0,0 @@
1−# Pagination
2−
3−## Overview
4−
5−Let's see an approach to typed pagination with *Servant* using [servant-pagination](https://hackage.haskell.org/package/servant-pagination).
6−
7−This module offers opinionated helpers to declare a type-safe and a flexible pagination
8−mechanism for Servant APIs. This design, inspired by [Heroku's API](https://devcenter.heroku.com/articles/platform-api-reference#ranges),
9−provides a small framework to communicate about a possible pagination feature of an endpoint,
10−enabling a client to consume the API in different fashions (pagination with offset / limit,
11−endless scroll using last referenced resources, ascending and descending ordering, etc.)
12−
13−Therefore, client can provide a `Range` header with their request with the following format:
14−
15−- `Range: <field> [<value>][; offset <o>][; limit <l>][; order <asc|desc>]`
16−
17−For example: `Range: createdAt 2017-01-15T23:14:67.000Z; offset 5; order desc` indicates that
18−the client is willing to retrieve the next batch of document in descending order that were
19−created after the fifteenth of January, skipping the first 5.
20−
21−As a response, the server may return the list of corresponding documents, and augment the
22−response with 3 headers:
23−
24−- `Accept-Ranges`: A comma-separated list of fields upon which a range can be defined
25−- `Content-Range`: Actual range corresponding to the content being returned
26−- `Next-Range`: Indicate what should be the next `Range` header in order to retrieve the next range
27−
28−For example:
29−
30−- `Accept-Ranges: createdAt, modifiedAt`
31−- `Content-Range: createdAt 2017-01-15T23:14:51.000Z..2017-02-18T06:10:23.000Z`
32−- `Next-Range: createdAt 2017-02-19T12:56:28.000Z; offset 0; limit 100; order desc`
33−
34−
35−## Getting Started
36−
37−Code-wise the integration is quite seamless and unobtrusive. `servant-pagination` provides a
38−`Ranges (fields :: [Symbol]) (resource :: *) -> *` data-type for declaring available ranges
39−on a group of _fields_ and a target _resource_. To each combination (resource + field) is
40−associated a given type `RangeType (resource :: *) (field :: Symbol) -> *` as described by
41−the type-family in the `HasPagination` type-class.
42−
43−So, let's start with some imports and extensions to get this out of the way:
44−
45−``` haskell
46−{-# LANGUAGE DataKinds #-}
47−{-# LANGUAGE DeriveGeneric #-}
48−{-# LANGUAGE FlexibleInstances #-}
49−{-# LANGUAGE MultiParamTypeClasses #-}
50−{-# LANGUAGE TypeApplications #-}
51−{-# LANGUAGE TypeFamilies #-}
52−{-# LANGUAGE TypeOperators #-}
53−
54−import Data.Aeson
55− (ToJSON, genericToJSON)
56−import Data.Maybe
57− (fromMaybe)
58−import Data.Proxy
59− (Proxy (..))
60−import GHC.Generics
61− (Generic)
62−import Servant
63− ((:>), GetPartialContent, Handler, Header, Headers, JSON, Server, addHeader)
64−import Servant.Pagination
65− (HasPagination (..), PageHeaders, Range (..), Ranges, RangeOptions(..),
66− applyRange, extractRange, returnRange)
67−
68−import qualified Data.Aeson as Aeson
69−import qualified Network.Wai.Handler.Warp as Warp
70−import qualified Servant
71−import qualified Servant.Pagination as Pagination
72−```
73−
74−
75−#### Declaring the Resource
76−
77−Servant APIs are rather resource-oriented, and so is `servant-pagination`. This
78−guide shows a basic example working with `JSON` (as you could tell from the
79−import list already). To make the world a <span style='text-decoration:
80−line-through'>better</span> colored place, let's create an API to retrieve
81−colors -- with pagination.
82−
83−``` haskell
84−data Color = Color
85− { name :: String
86− , rgb :: [Int]
87− , hex :: String
88− } deriving (Eq, Show, Generic)
89−
90−instance ToJSON Color where
91− toJSON =
92− genericToJSON Aeson.defaultOptions
93−
94−colors :: [Color]
95−colors =
96− [ Color "Black" [0, 0, 0] "#000000"
97− , Color "Blue" [0, 0, 255] "#0000ff"
98− , Color "Green" [0, 128, 0] "#008000"
99− , Color "Grey" [128, 128, 128] "#808080"
100− , Color "Purple" [128, 0, 128] "#800080"
101− , Color "Red" [255, 0, 0] "#ff0000"
102− , Color "Yellow" [255, 255, 0] "#ffff00"
103− ]
104−```
105−
106−#### Declaring the Ranges
107−
108−Now that we have defined our _resource_ (a.k.a `Color`), we are ready to declare a new `Range`
109−that will operate on a "name" field (genuinely named after the `name` fields from the `Color`
110−record).
111−For that, we need to tell `servant-pagination` two things:
112−
113−- What is the type of the corresponding `Range` values
114−- How do we get one of these values from our resource
115−
116−This is done via defining an instance of `HasPagination` as follows:
117−
118−``` haskell
119−instance HasPagination Color "name" where
120− type RangeType Color "name" = String
121− getFieldValue _ = name
122− -- getRangeOptions :: Proxy "name" -> Proxy Color -> RangeOptions
123− -- getDefaultRange :: Proxy Color -> Range "name" String
124−
125−defaultRange :: Range "name" String
126−defaultRange =
127− getDefaultRange (Proxy @Color)
128−```
129−
130−Note that `getFieldValue :: Proxy "name" -> Color -> String` is the minimal complete definition
131−of the class. Yet, you can define `getRangeOptions` to provide different parsing options (see
132−the last section of this guide). In the meantime, we've also defined a `defaultRange` as it will
133−come in handy when defining our handler.
134−
135−#### API
136−
137−Good, we have a resource, we have a `Range` working on that resource, we can now declare our
138−API using other Servant combinators we already know:
139−
140−``` haskell
141−type API =
142− "colors"
143− :> Header "Range" (Ranges '["name"] Color)
144− :> GetPartialContent '[JSON] (Headers MyHeaders [Color])
145−
146−type MyHeaders =
147− Header "Total-Count" Int ': PageHeaders '["name"] Color
148−```
149−
150−`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:
152−
153−``` haskell
154−-- type MyHeaders =
155−-- '[ Header "Total-Count" Int
156−-- , Header "Accept-Ranges" (AcceptRanges '["name"])
157−-- , Header "Content-Range" (ContentRange '["name"] Color)
158−-- , Header "Next-Range" (Ranges '["name"] Color)
159−-- ]
160−```
161−
162−As a result, we will need to provide all those headers with the response in our handler. Worry
163−not, _servant-pagination_ provides an easy way to lift a collection of resources into such handler.
164−
165−#### Server
166−
167−Time 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`
169−header, looking for the format defined in introduction with fields and target types we have just declared.
170−If no such header is provided, we will end up receiving `Nothing`. Otherwise, it will be possible
171−to _extract_ a `Range` from our `Ranges`.
172−
173−``` haskell
174−server :: Server API
175−server = handler
176− where
177− handler :: Maybe (Ranges '["name"] Color) -> Handler (Headers MyHeaders [Color])
178− handler mrange = do
179− let range =
180− fromMaybe defaultRange (mrange >>= extractRange)
181−
182− addHeader (length colors) <$> returnRange range (applyRange range colors)
183−
184−main :: IO ()
185−main =
186− Warp.run 1442 $ Servant.serve (Proxy @API) server
187−```
188−
189−Let's try it out using different ranges to observe the server's behavior. As a reminder, here's
190−the format we defined, where `<field>` here can only be `name` and `<value>` must parse to a `String`:
191−
192−- `Range: <field> [<value>][; offset <o>][; limit <l>][; order <asc|desc>]`
193−
194−Beside 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
196−following examples are valid requests to send to our server:
197−
198−- 1 - `curl http://localhost:1442/colors -vH 'Range: name'`
199−- 2 - `curl http://localhost:1442/colors -vH 'Range: name; limit 2'`
200−- 3 - `curl http://localhost:1442/colors -vH 'Range: name Green; order asc; offset 1'`
201−
202−Considering the following default options:
203−
204−- `defaultRangeLimit: 100`
205−- `defaultRangeOffset: 0`
206−- `defaultRangeOrder: RangeDesc`
207−
208−The previous ranges reads as follows:
209−
210−- 1 - The first 100 colors, ordered by descending names
211−- 2 - The first 2 colors, ordered by descending names
212−- 3 - The 100 colors after `Green` (not included), ordered by ascending names.
213−
214−
215−## Going Forward
216−
217−#### Multiple Ranges
218−
219−Note that in the simple above scenario, there's no ambiguity with `extractRange` and `returnRange`
220−because there's only one possible `Range` defined on our resource. Yet, as you've most probably
221−noticed, 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
223−highly likely to be needed.
224−
225−
226−``` haskell
227−instance HasPagination Color "hex" where
228− type RangeType Color "hex" = String
229− getFieldValue _ = hex
230−
231−-- to then define: Ranges '["name", "hex"] Color
232−```
233−
234−
235−#### Parsing Options
236−
237−By 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
240−specified (`limit`, `offset`, `order` are all optional) to provide default fallback values for those.
241−
242−For instance, let's say we wanted to change the default limit to `5` in a new range on
243−`"rgb"`, we could tweak the corresponding `HasPagination` instance as follows:
244−
245−``` haskell
246−instance HasPagination Color "rgb" where
247− type RangeType Color "rgb" = Int
248− getFieldValue _ = sum . rgb
249− getRangeOptions _ _ = Pagination.defaultOptions { defaultRangeLimit = 5 }
250−```
doc/cookbook/pagination/pagination.cabaldeleted−23
@@ -1,23 +0,0 @@
1−cabal-version: 2.2
2−name: cookbook-pagination
3−version: 2.1
4−synopsis: Pagination with Servant 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==8.6.5, GHC==8.8.3, GHC ==8.10.7
12−
13−executable cookbook-pagination
14− main-is: Pagination.lhs
15− build-tool-depends: markdown-unlit:markdown-unlit
16− default-language: Haskell2010
17− ghc-options: -Wall -pgmL markdown-unlit
18− build-depends: base >= 4.9 && <5
19− , aeson
20− , servant
21− , servant-server
22− , servant-pagination >= 2.1.0 && < 3.0.0
23− , warp
doc/cookbook/sentry/Sentry.lhsdeleted−116
@@ -1,116 +0,0 @@
1−# Error logging with Sentry
2−
3−In this recipe we will use [Sentry](https://sentry.io) to collect the runtime exceptions generated by our application. We will use the [raven-haskell](https://hackage.haskell.org/package/raven-haskell) package, which is a client for a Sentry event server. Mind that this package is not present on [Stackage](https://www.stackage.org/), so if we are using [Stack](https://docs.haskellstack.org) we’ll need to add it to our `extra-deps` section in the `stack.yaml` file.
4−
5−To exemplify this we will need the following imports
6−
7−```haskell
8−{-# LANGUAGE DataKinds #-}
9−{-# LANGUAGE TypeOperators #-}
10−
11−import Control.Exception (Exception,
12− SomeException, throw)
13−import Data.ByteString.Char8 (unpack)
14−import Network.Wai (Request, rawPathInfo,
15− requestHeaderHost)
16−import Network.Wai.Handler.Warp (defaultOnException,
17− defaultSettings,
18− runSettings,
19− setOnException,
20− setPort)
21−import Servant
22−import System.Log.Raven (initRaven, register,
23− silentFallback)
24−import System.Log.Raven.Transport.HttpConduit (sendRecord)
25−import System.Log.Raven.Types (SentryLevel (Error),
26− SentryRecord (..))
27−```
28−
29−Just for the sake of the example we will use the following API which will throw an exception
30−
31−```haskell
32−type API = "break" :> Get '[JSON] ()
33−
34−data MyException = MyException deriving (Show)
35−
36−instance Exception MyException
37−
38−server = breakHandler
39− where breakHandler :: Handler ()
40− breakHandler = do
41− throw MyException
42− return ()
43−```
44−
45−First thing we need to do if we want to intercept and log this exception, we need to look in the section of our code where we run the `warp` application, and instead of using the simple `run` function from `warp`, we use the `runSettings` functions which allows to customise the handling of requests
46−
47−```haskell
48−main :: IO ()
49−main =
50− let
51− settings =
52− setPort 8080 $
53− setOnException sentryOnException $
54− defaultSettings
55− in
56− runSettings settings $ serve (Proxy :: Proxy API) server
57−```
58−
59−The definition of the `sentryOnException` function could look as follows
60−
61−```haskell
62−sentryOnException :: Maybe Request -> SomeException -> IO ()
63−sentryOnException mRequest exception = do
64− sentryService <- initRaven
65− "https://username:password@senty.host/id"
66− id
67− sendRecord
68− silentFallback
69− register
70− sentryService
71− "myLogger"
72− Error
73− (formatMessage mRequest exception)
74− (recordUpdate mRequest exception)
75− defaultOnException mRequest exception
76−```
77−
78−It does three things. First it initializes the service which will communicate with Sentry. The parameters it receives are:
79−
80−- the Sentry `DSN`, which is obtained when creating a new project on Sentry
81−- 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
83−- a fallback handler, which we choose to be `silentFallback` since later we are logging to the console anyway.
84−
85−In the second step it actually sends our message to Sentry with the `register` function. Its arguments are:
86−
87−- the configured Sentry service which we just created
88−- 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)
90−- the message we want to send
91−- an update function to handle the specific `SentryRecord`
92−
93−Eventually it just delegates the error handling to the default warp mechanism.
94−
95−The function `formatMessage` simply uses the request and the exception to return a string with the error message.
96−
97−```haskell
98−formatMessage :: Maybe Request -> SomeException -> String
99−formatMessage Nothing exception = "Exception before request could be parsed: " ++ show exception
100−formatMessage (Just request) exception = "Exception " ++ show exception ++ " while handling request " ++ show request
101−```
102−
103−The only piece left now is the `recordUpdate` function which allows to decorate with other [attributes](https://docs.sentry.io/clientdev/attributes/) the default `SentryRecord`.
104−
105−```haskell
106−recordUpdate :: Maybe Request -> SomeException -> SentryRecord -> SentryRecord
107−recordUpdate Nothing exception record = record
108−recordUpdate (Just request) exception record = record
109− { srCulprit = Just $ unpack $ rawPathInfo request
110− , srServerName = fmap unpack $ requestHeaderHost request
111− }
112−```
113−
114−In this examples we set the raw path as the culprit and we use the `Host` header to populate the server name field.
115−
116−You can try to run this code using the `cookbook-sentry` executable. You should obtain a `MyException` error in the console and, if you provided a valid Sentry DSN, you should also find your error in the Sentry interface.
doc/cookbook/sentry/sentry.cabaldeleted−24
@@ -1,24 +0,0 @@
1−cabal-version: 2.2
2−name: cookbook-sentry
3−version: 0.1
4−synopsis: Collecting runtime exceptions using Sentry
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-sentry
14− main-is: Sentry.lhs
15− build-depends: base == 4.*
16− , bytestring
17− , markdown-unlit >= 0.4
18− , raven-haskell >= 0.1.2
19− , servant-server
20− , warp >= 3.2
21− , wai >= 3.2
22− default-language: Haskell2010
23− ghc-options: -Wall -pgmL markdown-unlit
24− build-tool-depends: markdown-unlit:markdown-unlit
doc/cookbook/structuring-apis/StructuringApis.lhs+3−13
@@ -66,9 +66,9 @@ a server for `FactoringAPI` (without the `'`) reflects the
66server must be a function that takes an `Int` (the `Capture`) and
66server must be a function that takes an `Int` (the `Capture`) and
67returns two values glued with `:<|>`, one of type `Maybe Int -> Handler Int`
67returns two values glued with `:<|>`, one of type `Maybe Int -> Handler Int`
68and the other of type `Handler Int`. Let's provide such a server
68and the other of type `Handler Int`. Let's provide such a server
69−implementation, with those "nested types".
69+implementation.
70
70
71−**Tip**: you can load this module in ghci and ask for the concrete
71+_Note_: you can load this module in ghci and ask for the concrete
72type that `Server FactoringAPI` "resolves to" by typing
72type that `Server FactoringAPI` "resolves to" by typing
73`:kind! Server FactoringAPI`.
73`:kind! Server FactoringAPI`.
74
74
@@ -82,16 +82,6 @@ factoringServer x = getXY :<|> postX
82 postX = return (x - 1)
82 postX = return (x - 1)
83```
83```
84
84
85−If you want to avoid the "nested types" and the need to manually
86−dispatch the arguments (like `x` above) to the different request
87−handlers, and would just like to be able to declare the API type
88−as above but pretending that the `Capture` is not factored out,
89−that every combinator is "distributed" (i.e that all endpoints
90−are specified like `FactoringAPI'` above), then you should
91−look at `flatten` from the
92−[servant-flatten](https://hackage.haskell.org/package/servant-flatten)
93−package.
94−
95Next come the two sub-APIs defined in terms of this `SimpleAPI`
85Next come the two sub-APIs defined in terms of this `SimpleAPI`
96type, but with different parameters. That type is just a good old
86type, but with different parameters. That type is just a good old
97Haskell type synonym that abstracts away a pretty common structure in
87Haskell type synonym that abstracts away a pretty common structure in
@@ -144,7 +134,7 @@ simpleAPIServer
144 :: m [a]
134 :: m [a]
145 -> (i -> m a)
135 -> (i -> m a)
146 -> (a -> m NoContent)
136 -> (a -> m NoContent)
147− -> ServerT (SimpleAPI name a i) m
137+ -> Server (SimpleAPI name a i) m
148simpleAPIServer listAs getA postA =
138simpleAPIServer listAs getA postA =
149 listAs :<|> getA :<|> postA
139 listAs :<|> getA :<|> postA
150
140
doc/cookbook/structuring-apis/structuring-apis.cabal+4−4
@@ -1,14 +1,14 @@
1−cabal-version: 2.2
2name: cookbook-structuring-apis
1name: cookbook-structuring-apis
3version: 0.1
2version: 0.1
4synopsis: Example that shows how APIs can be structured
3synopsis: Example that shows how APIs can be structured
5−homepage: http://docs.servant.dev/
4+homepage: http://haskell-servant.readthedocs.org/
6−license: BSD-3-Clause
5+license: BSD3
7license-file: ../../../servant/LICENSE
6license-file: ../../../servant/LICENSE
8author: Servant Contributors
7author: Servant Contributors
9maintainer: haskell-servant-maintainers@googlegroups.com
8maintainer: haskell-servant-maintainers@googlegroups.com
10build-type: Simple
9build-type: Simple
10+cabal-version: >=1.10
11−tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
11+tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2
12
12
13executable cookbook-structuring-apis
13executable cookbook-structuring-apis
14 main-is: StructuringApis.lhs
14 main-is: StructuringApis.lhs
doc/cookbook/testing/Testing.lhsdeleted−506
@@ -1,506 +0,0 @@
1−# How To Test Servant Applications
2−
3−Even with a nicely structured API that passes Haskell's strict type checker,
4−it's a good idea to write some tests for your application.
5−
6−In this recipe we'll work through some common testing strategies and provide
7−examples of utlizing these testing strategies in order to test Servant
8−applications.
9−
10−## Testing strategies
11−
12−There are many testing strategies you may wish to employ when testing your
13−Servant application, but included below are three common testing patterns:
14−
15−- We'll use `servant-client` to derive client functions and then send valid
16−requests to our API, running in another thread. This is great for testing
17−that our **business logic** is correctly implemented with only valid HTTP
18−requests.
19−
20−- We'll also use `hspec-wai` to make **arbitrary HTTP requests**, in order to
21−test how our application may respond to invalid or otherwise unexpected
22−requests.
23−
24−- Finally, we can also use `servant-quickcheck` for **whole-API tests**, in order
25−to assert that our entire application conforms to **best practices**.
26−
27−## Useful Libraries
28−
29−The following libraries will often come in handy when we decide to test our
30−Servant applications:
31−
32−- [hspec](https://hspec.github.io/)
33−- [hspec-wai](http://hackage.haskell.org/package/hspec-wai)
34−- [QuickCheck](http://hackage.haskell.org/package/QuickCheck)
35−- [servant-quickcheck](https://hackage.haskell.org/package/servant-quickcheck)
36−
37−## Imports and Our Testing Module
38−
39−This recipe starts with the following ingredients:
40−
41−```haskell
42−{-# LANGUAGE OverloadedStrings, TypeFamilies, DataKinds,
43− DeriveGeneric, TypeOperators #-}
44−import Prelude ()
45−import Prelude.Compat
46−
47−import qualified Control.Concurrent as C
48−import Control.Concurrent.MVar
49−import Control.Exception (bracket)
50−import Control.Lens hiding (Context)
51−import Data.Aeson
52−import Data.Aeson.Lens
53−import qualified Data.HashMap.Strict as HM
54−import Data.Text (Text, unpack)
55−import GHC.Generics
56−import Network.HTTP.Client hiding (Proxy)
57−import Network.HTTP.Types
58−import Network.Wai
59−import qualified Network.Wai.Handler.Warp as Warp
60−
61−import Servant
62−import Servant.Client
63−import Servant.Server
64−import Servant.QuickCheck
65−import Servant.QuickCheck.Internal (serverDoesntSatisfy)
66−
67−import Test.Hspec
68−import Test.Hspec.Wai
69−import Test.Hspec.Wai.Matcher
70−```
71−
72−We're going to produce different `Spec`s that represent different
73−aspects of our application, and we'll ask `hspec` to run all of our different
74−`Spec`s. This is a common organizational method for testing modules:
75−
76−```haskell
77−spec :: Spec
78−spec = do
79− businessLogicSpec
80− thirdPartyResourcesSpec
81− servantQuickcheckSpec
82−```
83−
84−Often, codebases will use `hspec`'s
85−[autodiscover pragma](http://hspec.github.io/hspec-discover.html)
86−to find all testing modules and `Spec`s inside, but we're going to
87−explicitly make a `main` function to run our tests because we have only one
88−`spec` defined above:
89−
90−```haskell
91−main :: IO ()
92−main = hspec spec
93−```
94−
95−## Testing Your Business Logic
96−
97−Let's say we have an API that looks something like this:
98−
99−```haskell
100−data User = User {
101− name :: Text
102− , user_id :: Integer
103− } deriving (Eq, Show, Generic)
104−
105−instance FromJSON User
106−instance ToJSON User
107−
108−type UserApi =
109− -- One endpoint: create a user
110− "user" :> Capture "userId" Integer :> Post '[JSON] User
111−```
112−
113−A real server would likely use a database to store, retrieve, and validate
114−users, but we're going to do something really simple merely to have something
115−to test. With that said, here's a sample handler, server, and `Application`
116−for the endpoint described above:
117−
118−```haskell
119−userApp :: Application
120−userApp = serve (Proxy :: Proxy UserApi) userServer
121−
122−userServer :: Server UserApi
123−userServer = createUser
124−
125−createUser :: Integer -> Handler User
126−createUser userId = do
127− if userId > 5000
128− then pure $ User { name = "some user", user_id = userId }
129− else throwError $ err400 { errBody = "userId is too small" }
130−```
131−
132−### Strategy 1: Spin Up a Server, Create a Client, Make Some Requests
133−
134−One of the benefits of Servant's type-level DSL for describing APIs is that
135−once you have provided a type-level description of your API, you can create
136−clients, documentation, or other tools for it somewhat magically.
137−
138−In this case, we'd like to *test* our server, so we can use `servant-client`
139−to create a client, after which we'll run our server, and then make requests
140−of it and see how it responds.
141−
142−Let's write some tests:
143−
144−```haskell
145−withUserApp :: (Warp.Port -> IO ()) -> IO ()
146−withUserApp 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
150−
151−
152−businessLogicSpec :: Spec
153−businessLogicSpec =
154− -- `around` will start our Server before the tests and turn it off after
155− around withUserApp $ do
156− -- create a test client function
157− let createUser = client (Proxy :: Proxy UserApi)
158− -- create a servant-client ClientEnv
159− baseUrl <- runIO $ parseBaseUrl "http://localhost"
160− manager <- runIO $ newManager defaultManagerSettings
161− let clientEnv port = mkClientEnv manager (baseUrl { baseUrlPort = port })
162−
163− -- testing scenarios start here
164− 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− 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− result `shouldBe` (Right $ User { name = "some user", user_id = 50001})
171−```
172−
173−### Running These Tests
174−
175−Let's run our tests and see what happens:
176−
177−```
178−$ cabal new-test all
179−POST /user
180− should create a user with a high enough ID
181− should fail with a too-small ID FAILED [1]
182−
183− Failures:
184−
185− Testing.lhs:129:7:
186− 1) POST /user should fail with a too-small ID
187− expected: Right (User {name = "some user", user_id = 50001})
188− but got: Left (FailureResponse (Response {responseStatusCode = Status {statusCode = 400, statusMessage = "Bad Request"}, responseHeaders = fromList [("Transfer-Encoding","chunked"),("Date","Fri, 12 Oct 2018 04:36:22 GMT"),("Server","Warp/3.2.25")], responseHttpVersion = HTTP/1.1, responseBody = "userId is too small"}))
189−
190− To rerun use: --match "/POST /user/should fail with a too-small ID/"
191−```
192−
193−Hmm. One passed and one failed! It looks like I *was* expecting a success
194−response in the second test, but I actually got a failure. We should fix that,
195−but first I'd like to introduce `hspec-wai`, which will give us different
196−mechanisms for making requests of our application and validating the responses
197−we get. We're also going to spin up a fake Elasticsearch server, so that our
198−server can think it's talking to a real database.
199−
200−
201−## *Mocking* 3rd Party Resources
202−
203−Often our web applications will need to make their own web
204−requests to other 3rd-party applications. These requests provide a lot
205−of opportunity for failure and so we'd like to test that the right
206−messages and failure values (in addition to success values) are returned
207−from our application.
208−
209−### Define the 3rd-Party Resource
210−
211−With Servant's type-level API definitions, assuming you've already defined the
212−API you want to mock, it's relatively trivial to create a simple server for
213−the purposes of running tests. For instance, consider an API server that needs
214−to get data out of Elasticsearch. Let's first define the Elasticsearch server
215−and client using Servant API descriptions:
216−
217−```haskell
218−type SearchAPI =
219− -- We're using Aeson's Generic JSON `Value` to make things easier on
220− -- ourselves. We're also representing only one Elasticsearch endpoint:
221− -- get item by id
222− "myIndex" :> "myDocType" :> Capture "docId" Integer :> Get '[JSON] Value
223−
224−-- Here's our Servant Client function
225−getDocument = client (Proxy :: Proxy SearchAPI)
226−
227−-- We can use these helpers when we want to make requests
228−-- using our client function
229−clientEnv :: Text -> Text -> IO ClientEnv
230−clientEnv esHost esPort = do
231− baseUrl <- parseBaseUrl $ unpack $ esHost <> ":" <> esPort
232− manager <- newManager defaultManagerSettings
233− pure $ mkClientEnv manager baseUrl
234−
235−runSearchClient :: Text -> Text -> ClientM a -> IO (Either ClientError a)
236−runSearchClient esHost esPort = (clientEnv esHost esPort >>=) . runClientM
237−```
238−
239−### Servant Server Example Using this 3rd-Party Resource
240−
241−So we've got an Elasticsearch server and a client to talk to it. Let's now
242−build a simple app server that uses this client to retrieve documents. This
243−is somewhat contrived, but hopefully it illustrates the typical three-tier
244−application architecture.
245−
246−One note: we're also going to take advantage of `lens-aeson` here, which may
247−look a bit foreign. The gist of it is that we're going to traverse a JSON
248−`Value` from Elasticsearch and try to extract some kind of document to
249−return.
250−
251−Imagine, then, that this is our real server implementation:
252−
253−```haskell
254−type DocApi =
255− "docs" :> Capture "docId" Integer :> Get '[JSON] Value
256−
257−docsApp :: Text -> Text -> Application
258−docsApp esHost esPort = serve (Proxy :: Proxy DocApi) $ docServer esHost esPort
259−
260−docServer :: Text -> Text -> Server DocApi
261−docServer esHost esPort = getDocById esHost esPort
262−
263−-- Our Handler tries to get a doc from Elasticsearch and then tries to parse
264−-- it. Unfortunately, there's a lot of opportunity for failure in these
265−-- actions
266−getDocById :: Text -> Text -> Integer -> Handler Value
267−getDocById esHost esPort docId = do
268− -- Our Servant Client function returns Either ClientError Value here:
269− docRes <- liftIO $ runSearchClient esHost esPort (getDocument docId)
270− case docRes of
271− Left err -> throwError $ err404 { errBody = "Failed looking up content" }
272− Right value -> do
273− -- we'll either fail to parse our document or we'll return it
274− case value ^? _Object . ix "_source" of
275− Nothing -> throwError $ err400 { errBody = "Failed parsing content" }
276− Just obj -> pure obj
277−```
278−
279−### Testing Our Backend
280−
281−So the above represents our application and is close to a server we may
282−actually deploy. How then shall we test this application?
283−
284−Ideally, we'd like it to make requests of a *real* Elasticsearch server, but
285−we certainly don't want our tests to trigger requests to a live, production
286−database. In addition, we don't want to depend on our real Elasticsearch
287−server having specific, consistent results for us to test against, because
288−that would make our tests flaky (and flaky tests are sometimes described as
289−worse than not having tests at all).
290−
291−One solution to this is to create a trivial Elasticsearch server as part of
292−our testing code. We can do this relatively easily because we already have
293−an API definition for it above. With a *real* server, we can then let our own
294−application make requests of it and we'll simulate different scenarios in
295−order to make sure our application responds the way we expect it to.
296−
297−Let's start with some helpers which will allow us to run a testing version
298−of our Elasticsearch server in another thread:
299−
300−```haskell
301−-- | We'll run the Elasticsearch server so we can test behaviors
302−withElasticsearch :: IO () -> IO ()
303−withElasticsearch action =
304− bracket (liftIO $ C.forkIO $ Warp.run 9999 esTestApp)
305− C.killThread
306− (const action)
307−
308−esTestApp :: Application
309−esTestApp = serve (Proxy :: Proxy SearchAPI) esTestServer
310−
311−esTestServer :: Server SearchAPI
312−esTestServer = getESDocument
313−
314−-- This is the *mock* handler we're going to use. We create it
315−-- here specifically to trigger different behavior in our tests.
316−getESDocument :: Integer -> Handler Value
317−getESDocument docId
318− -- arbitrary things we can use in our tests to simulate failure:
319− -- we want to trigger different code paths.
320− | docId > 1000 = throwError err500
321− | docId > 500 = pure . Object $ HM.fromList [("bad", String "data")]
322− | otherwise = pure $ Object $ HM.fromList [("_source", Object $ HM.fromList [("a", String "b")])]
323−```
324−
325−Now, we should be ready to write some tests.
326−
327−In this case, we're going to use `hspec-wai`, which will give us a simple way
328−to run our application, make requests, and make assertions against the
329−responses we receive.
330−
331−Hopefully, this will simplify our testing code:
332−
333−```haskell
334−thirdPartyResourcesSpec :: Spec
335−thirdPartyResourcesSpec = around_ withElasticsearch $ do
336− -- we call `with` from `hspec-wai` and pass *real* `Application`
337− with (pure $ docsApp "localhost" "9999") $ do
338− describe "GET /docs" $ do
339− it "should be able to get a document" $
340− -- `get` is a function from hspec-wai`.
341− get "/docs/1" `shouldRespondWith` 200
342− it "should be able to handle connection failures" $
343− get "/docs/1001" `shouldRespondWith` 404
344− it "should be able to handle parsing failures" $
345− get "/docs/501" `shouldRespondWith` 400
346− it "should be able to handle odd HTTP requests" $
347− -- we can also make all kinds of arbitrary custom requests to see how
348− -- our server responds using the `request` function:
349− -- request :: Method -> ByteString -> [Header]
350− -- -> LB.ByteString -> WaiSession SResponse
351− request methodPost "/docs/501" [] "{" `shouldRespondWith` 405
352− it "we can also do more with the Response using hspec-wai's matchers" $
353− -- see also `MatchHeader` and JSON-matching tools as well...
354− get "/docs/1" `shouldRespondWith` 200 { matchBody = MatchBody bodyMatcher }
355−
356−bodyMatcher :: [Network.HTTP.Types.Header] -> Body -> Maybe String
357−bodyMatcher _ body = case (decode body :: Maybe Value) of
358− -- success in this case means we return `Nothing`
359− Just val | val == (Object $ HM.fromList [("a", String "b")]) -> Nothing
360− _ -> Just "This is how we represent failure: this message will be printed"
361−```
362−
363−Out of the box, `hspec-wai` provides a lot of useful tools for us to run tests
364−against our application. What happens when we run these tests?
365−
366−```
367−$ cabal new-test all
368−...
369−
370−GET /docs
371− should be able to get a document
372− should be able to handle connection failures
373− should be able to handle parsing failures
374− should be able to handle odd HTTP requests
375− we can also do more with the Response using hspec-wai's matchers
376−```
377−
378−Fortunately, they all passed! Let's move to another strategy: whole-API
379−testing.
380−
381−## Servant Quickcheck
382−
383−[`servant-quickcheck`](https://github.com/haskell-servant/servant-quickcheck)
384−is a project that allows users to write tests for whole Servant APIs using
385−quickcheck-style property-checking mechanisms.
386−
387−`servant-quickcheck` is great for asserting API-wide rules, such as "no
388−endpoint throws a 500" or "all 301 status codes also come with a Location
389−header". The project even comes with a number of predicates that reference
390−the [RFCs they originate from](https://github.com/haskell-servant/servant-quickcheck/blob/master/src/Servant/QuickCheck/Internal/Predicates.hs).
391−
392−In other words, it's one way to assert that your APIs conform to specs and
393−best practices.
394−
395−### Quickcheckable API
396−
397−Let's make an API and a server to demonstrate how to use `servant-quickcheck`:
398−
399−```haskell
400−type API = ReqBody '[JSON] String :> Post '[JSON] String
401− :<|> Get '[JSON] Int
402− :<|> BasicAuth "some-realm" () :> Get '[JSON] ()
403−
404−api :: Proxy API
405−api = Proxy
406−
407−server :: IO (Server API)
408−server = do
409− mvar <- newMVar ""
410− return $ (\x -> liftIO $ swapMVar mvar x)
411− :<|> (liftIO $ readMVar mvar >>= return . length)
412− :<|> (const $ return ())
413−```
414−
415−### Using `servant-quickcheck`
416−
417−Let's build some tests for our API using `servant-quickcheck`.
418−
419−Similar to the above examples, we're going to create `Spec`s, but in this
420−case, we'll rely on a number of predicates available from `servant-quickcheck`
421−to see if our API server conforms to best practices:
422−
423−```haskell
424−-- Let's set some QuickCheck values
425−args :: Args
426−args = defaultArgs { maxSuccess = 500 }
427−
428−-- Here's a Servant Context object we'll use
429−ctx :: Context '[BasicAuthCheck ()]
430−ctx = BasicAuthCheck (const . return $ NoSuchUser) :. EmptyContext
431−
432−
433−servantQuickcheckSpec :: Spec
434−servantQuickcheckSpec = describe "" $ do
435− it "API demonstrates best practices" $
436− -- `withServerServer` and `withServantServerAndContext` come from `servant-quickcheck`
437− withServantServerAndContext api ctx server $ \burl ->
438− -- `serverSatisfies` and the predicates also come from `servant-quickcheck`
439− serverSatisfies api burl args (unauthorizedContainsWWWAuthenticate
440− <%> not500
441− <%> onlyJsonObjects -- this one isn't true!
442− <%> mempty)
443−
444− it "API doesn't have these things implemented yet" $
445− withServantServerAndContext api ctx server $ \burl -> do
446− serverDoesntSatisfy api burl args (getsHaveCacheControlHeader
447− <%> notAllowedContainsAllowHeader
448− <%> mempty)
449−```
450−
451−Let's see what happens when we run these tests:
452−
453−
454−```
455− API demonstrates best practices FAILED [2]
456−+++ OK, passed 500 tests.
457− API doesn't have these things implemented yet
458−
459− src/Servant/QuickCheck/Internal/QuickCheck.hs:143:11:
460− 2) Main[339:25] API demonstrates best practices
461− Failed:
462− Just Predicate failed
463− Predicate: onlyJsonObjects
464−
465− Response:
466− Status code: 200
467− Headers: "Transfer-Encoding": "chunked"
468− "Date": "Fri, 12 Oct 2018 04:36:22 GMT"
469− "Server": "Warp/3.2.25"
470− "Content-Type": "application/json;charset=utf-8"
471− Body: ""
472−
473− To rerun use: --match "/Main[339:25]/API demonstrates best practices/"
474−
475−Randomized with seed 1046277487
476−
477−Finished in 0.4306 seconds
478−```
479−
480−Hmm. It looks like we *thought* our API only returned JSON objects, which is a
481−best practice, but in fact, we *did* have an endpoint that returned an empty
482−body, which you can see in the printed response above: `Body: ""`. We should
483−consider revising our API to only return top-level JSON Objects in the future!
484−
485−### Other Cool Things
486−
487−`servant-quickcheck` also has a cool mechanism where you can compare two API
488−servers to demonstrate that they respond identically to requests. This may be
489−useful if you are planning to rewrite one API in another language or with
490−another web framework. You have to specify whether you're looking for
491−`jsonEquality` vs regular `ByteString` equality, though.
492−
493−## Conclusion
494−
495−There are lots of techniques for testing and we only covered a few here.
496−
497−Useful libraries such as `hspec-wai` have ways of running Wai `Application`s
498−and sending requests to them, while Servant's type-level DSL for defining APIs
499−allows us to more easily mock out servers and to derive clients, which will
500−only craft valid requests.
501−
502−Lastly, if you want a broad overview of where your application fits in with
503−regard to best practices, consider using `servant-quickcheck`.
504−
505−This program is available as a cabal project
506−[here](https://github.com/haskell-servant/servant/tree/master/doc/cookbook/testing).
doc/cookbook/testing/testing.cabaldeleted−38
@@ -1,38 +0,0 @@
1−cabal-version: 2.2
2−name: cookbook-testing
3−version: 0.0.1
4−synopsis: Common testing patterns in Servant apps
5−description: This recipe includes various strategies for writing tests for Servant.
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.3, GHC ==8.10.7
14−
15−executable cookbook-testing
16− main-is: Testing.lhs
17− build-depends: base == 4.*
18− , base-compat
19− , text >= 1.2
20− , aeson >= 1.2
21− , lens-aeson
22− , lens
23− , servant
24− , servant-client
25− , servant-server
26− , servant-quickcheck >= 0.0.10
27− , http-client
28− , http-types >= 0.12
29− , hspec
30− , hspec-wai
31− , QuickCheck
32− , unordered-containers
33− , warp >= 3.2
34− , wai >= 3.2
35− , wai-extra
36− default-language: Haskell2010
37− ghc-options: -Wall -pgmL markdown-unlit
38− build-tool-depends: markdown-unlit:markdown-unlit
doc/cookbook/using-custom-monad/UsingCustomMonad.lhs+1−4
@@ -1,6 +1,6 @@
1# Using a custom monad
1# Using a custom monad
2
2
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.
4We will keep state in memory and share it between requests using `Reader` monad and `STM`.
4We will keep state in memory and share it between requests using `Reader` monad and `STM`.
5
5
6We start with a pretty standard set of imports and definition of the model:
6We start with a pretty standard set of imports and definition of the model:
@@ -115,6 +115,3 @@ Running cookbook-using-custom-monad...
115[Book "To Kill a Mockingbird",Book "Harry Potter and the Order of the Phoenix"]
115[Book "To Kill a Mockingbird",Book "Harry Potter and the Order of the Phoenix"]
116[Book "The Picture of Dorian Gray",Book "To Kill a Mockingbird",Book "Harry Potter and the Order of the Phoenix"]
116[Book "The Picture of Dorian Gray",Book "To Kill a Mockingbird",Book "Harry Potter and the Order of the Phoenix"]
117```
117```
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
2name: cookbook-using-custom-monad
1name: cookbook-using-custom-monad
3version: 0.1
2version: 0.1
4synopsis: Using custom monad to pass a state between handlers
3synopsis: Using custom monad to pass a state between handlers
5−homepage: http://docs.servant.dev/
4+homepage: http://haskell-servant.readthedocs.org/
6−license: BSD-3-Clause
5+license: BSD3
7license-file: ../../../servant/LICENSE
6license-file: ../../../servant/LICENSE
8author: Servant Contributors
7author: Servant Contributors
9maintainer: haskell-servant-maintainers@googlegroups.com
8maintainer: haskell-servant-maintainers@googlegroups.com
10build-type: Simple
9build-type: Simple
10+cabal-version: >=1.10
11−tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
11+tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2
12
12
13executable cookbook-using-custom-monad
13executable cookbook-using-custom-monad
14 main-is: UsingCustomMonad.lhs
14 main-is: UsingCustomMonad.lhs
doc/cookbook/using-free-client/UsingFreeClient.lhsdeleted−192
@@ -1,192 +0,0 @@
1−# Inspecting, debugging, simulating clients and more
2−
3−or simply put: _a practical introduction to `Servant.Client.Free`_.
4−
5−Someone asked on IRC how one could access the intermediate Requests (resp. Responses)
6−produced (resp. received) by client functions derived using servant-client.
7−My response to such inquiries is: to extend `servant-client` in an ad-hoc way (e.g for testing or debugging
8−purposes), use `Servant.Client.Free`. This recipe shows how.
9−
10−First the module header, but this time We'll comment the imports.
11−
12−```haskell
13−{-# LANGUAGE DataKinds #-}
14−{-# LANGUAGE TypeOperators #-}
15−module Main (main) where
16−```
17−
18−We will primarily use `Servant.Client.Free`, it doesn't re-export anything
19−from `free` package, so we need to import it as well.
20−
21−```haskell
22−import Control.Monad.Free
23−import Servant.Client.Free
24−```
25−
26−Also we'll use `servant-client` internals, which uses `http-client`,
27−so let's import them *qualified*
28−
29−```haskell
30−import qualified Servant.Client.Internal.HttpClient as I
31−import qualified Network.HTTP.Client as HTTP
32−```
33−
34−The rest of the imports are for a server we implement here for completeness.
35−
36−```haskell
37−import Servant
38−import Network.Wai.Handler.Warp (run)
39−import System.Environment (getArgs)
40−```
41−
42−## API & Main
43−
44−We'll work with a very simple API:
45−
46−```haskell
47−type API = "square" :> Capture "n" Int :> Get '[JSON] Int
48−
49−api :: Proxy API
50−api = Proxy
51−```
52−
53−Next we implement a `main`. If passed `"server"` it will run `server`, if passed
54−`"client"` it will run a `test` function (to be defined next). This should be
55−pretty straightforward:
56−
57−```haskell
58−main :: IO ()
59−main = do
60− args <- getArgs
61− case args of
62− ("server":_) -> do
63− putStrLn "Starting cookbook-using-free-client at http://localhost:8000"
64− run 8000 $ serve api $ \n -> return (n * n)
65− ("client":_) ->
66− test
67− _ -> do
68− putStrLn "Try:"
69− putStrLn "cabal new-run cookbook-using-free-client server"
70− putStrLn "cabal new-run cookbook-using-free-client client"
71−```
72−
73−## Test
74−
75−In the client part, we will use a `Servant.Client.Free` client.
76−Because we have a single endpoint API, we'll get a single client function,
77−running in the `Free ClientF` (free) monad:
78−
79−```haskell
80−getSquare :: Int -> Free ClientF Int
81−getSquare = client api
82−```
83−
84−Such clients are "client functions without a backend", so to speak,
85−or where the backend has been abstracted out. To be more precise, `ClientF` is a functor that
86−precisely represents the operations servant-client-core needs from an http client backend.
87−So if we are to emulate one or augment what such a backend does, it will be by interpreting
88−all those operations, the way we want to. This also means we get access to the requests and
89−responses and can do anything we want with them, right when they are produced or consumed,
90−respectively.
91−
92−Next, we can write our small test. We'll pass a value to `getSquare` and inspect
93−the `Free` structure. The first three possibilities are self-explanatory:
94−
95−```haskell
96−test :: IO ()
97−test = case getSquare 42 of
98− Pure n ->
99− putStrLn $ "ERROR: got pure result: " ++ show n
100− Free (Throw err) ->
101− putStrLn $ "ERROR: got error right away: " ++ show err
102−```
103−
104−We are interested in `RunRequest`, that's what client should block on:
105−
106−```haskell
107− Free (RunRequest req k) -> do
108−```
109−
110−Then we need to prepare the context, get HTTP (connection) `Manager`
111−and `BaseUrl`:
112−
113−```haskell
114− burl <- parseBaseUrl "http://localhost:8000"
115− mgr <- HTTP.newManager HTTP.defaultManagerSettings
116−```
117−
118−Now we can use `servant-client`'s internals to convert servant's `Request`
119−to http-client's `Request`, and we can inspect it:
120−
121−```haskell
122− req' <- I.defaultMakeClientRequest burl req
123− putStrLn $ "Making request: " ++ show req'
124−```
125−
126−`servant-client`'s request does a little more, but this is good enough for
127−our demo. We get back an http-client `Response` which we can also inspect.
128−
129−```haskell
130− res' <- HTTP.httpLbs req' mgr
131− putStrLn $ "Got response: " ++ show res'
132−```
133−
134−And we continue by turning http-client's `Response` into servant's `Response`,
135−and calling the continuation. We should get a `Pure` value.
136−
137−```haskell
138− let res = I.clientResponseToResponse id res'
139−
140− case k res of
141− Pure n ->
142− putStrLn $ "Expected 1764, got " ++ show n
143− _ ->
144− putStrLn "ERROR: didn't get a response"
145−```
146−
147−So that's it. Using `Free` we can evaluate servant clients step-by-step, and
148−validate that the client functions or the HTTP client backend does what we expect
149−(e.g by printing requests/responses on the fly). In fact, using `Servant.Client.Free`
150−is a little simpler than defining a custom `RunClient` instance, especially
151−for those cases where it is handy to have the full sequence of client calls
152−and responses available for us to inspect, since `RunClient` only gives us
153−access to one `Request` or `Response` at a time.
154−
155−On 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
157−by using a `Writer [(Request, Response)]` monad.
158−
159−Here is an example of running our small `test` against a running server:
160−
161−```
162−Making request: Request {
163− host = "localhost"
164− port = 8000
165− secure = False
166− requestHeaders = [("Accept","application/json;charset=utf-8,application/json")]
167− path = "/square/42"
168− queryString = ""
169− method = "GET"
170− proxy = Nothing
171− rawBody = False
172− redirectCount = 10
173− responseTimeout = ResponseTimeoutDefault
174− requestVersion = HTTP/1.1
175−}
176−
177−Got response: Response
178− { responseStatus = Status {statusCode = 200, statusMessage = "OK"}
179− , responseVersion = HTTP/1.1
180− , responseHeaders =
181− [ ("Transfer-Encoding","chunked")
182− , ("Date","Thu, 05 Jul 2018 21:12:41 GMT")
183− , ("Server","Warp/3.2.22")
184− , ("Content-Type","application/json;charset=utf-8")
185− ]
186− , responseBody = "1764"
187− , responseCookieJar = CJ {expose = []}
188− , responseClose' = ResponseClose
189− }
190−
191−Expected 1764, got 1764
192−```
doc/cookbook/using-free-client/using-free-client.cabaldeleted−26
@@ -1,26 +0,0 @@
1−cabal-version: 2.2
2−name: cookbook-using-free-client
3−version: 0.1
4−synopsis: Using Free client
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-using-free-client
14− main-is: UsingFreeClient.lhs
15− build-depends: base >= 4.9 && <5
16− , free
17− , servant
18− , servant-client
19− , http-client
20− , servant-client-core
21− , base-compat
22− , servant-server
23− , warp >= 3.2
24− default-language: Haskell2010
25− ghc-options: -Wall -pgmL markdown-unlit
26− build-tool-depends: markdown-unlit:markdown-unlit >= 0.4
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−16
@@ -6,11 +6,6 @@
6 including a test-suite using [**hspec**](http://hspec.github.io/) and
6 including a test-suite using [**hspec**](http://hspec.github.io/) and
7 **servant-client**.
7 **servant-client**.
8
8
9−- **[servant-examples](https://github.com/sras/servant-examples)**:
10−
11− Similar to [the cookbook](https://docs.servant.dev/en/latest/cookbook/index.html) but
12− with no explanations, for developers who just want to look at code examples to find out how to do X or Y
13− with servant.
14
9
15- **[stack-templates](https://github.com/commercialhaskell/stack-templates)**
10- **[stack-templates](https://github.com/commercialhaskell/stack-templates)**
16
11
@@ -37,7 +32,7 @@
37
32
38 An example consisting of
33 An example consisting of
39
34
40− - a backend that uses `servant`
35+ - a backend in uses `haskell-servant`
41 - a frontend written in [PureScript](http://www.purescript.org/) using
36 - a frontend written in [PureScript](http://www.purescript.org/) using
42 [servant-purescript](https://github.com/eskimor/servant-purescript) to generate
37 [servant-purescript](https://github.com/eskimor/servant-purescript) to generate
43 an API wrapper in PureScript to interface the web API with
38 an API wrapper in PureScript to interface the web API with
@@ -48,13 +43,3 @@
48 An example for a web server written with **servant-server** and
43 An example for a web server written with **servant-server** and
49 [persistent](https://www.stackage.org/package/persistent) for writing data
44 [persistent](https://www.stackage.org/package/persistent) for writing data
50 into a database.
45 into a database.
51−
52−- **[full-example-servant-elm-auth-yeshql-postgresql](https://github.com/aRkadeFR/FlashCard)**:
53−
54− A full open source website written with **servant-server**, yeshql, postgresql and elm 0.19.
55−
56−
57−- [`import Servant` github search](https://github.com/search?q=%22import+Servant%22+language%3AHaskell&type=Code)
58−
59− It has thousands of results and can be a good way to see how people use servant in their projects or even to discover
60− servant-related libraries.
doc/index.rst+9−11
@@ -3,24 +3,22 @@ servant – A Type-Level Web DSL
3
3
4.. image:: https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png
4.. image:: https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png
5
5
6−**servant** is a set of Haskell libraries for writing *type-safe* web
6+**servant** is a set of packages for declaring web APIs at the type-level and
7−applications but also *deriving* clients (in Haskell and other languages) or
7+then using those API specifications to:
8−generating documentation for them, and more.
9
8
10−This is achieved by taking as input a description of the web API
9+- write servers (this part of **servant** can be considered a web framework),
11−as a Haskell type. Servant is then able to check that your server-side request
10+- obtain client functions (in haskell),
12−handlers indeed implement your web API faithfully, or to automatically derive
11+- generate client functions for other programming languages,
13−Haskell functions that can hit a web application that implements this API,
12+- generate documentation for your web applications
14−generate a Swagger description or code for client functions in some other
13+- and more...
15−languages directly.
16
14
17−If you would like to learn more, click the tutorial link below.
15+All in a type-safe manner.
18
16
19.. toctree::
17.. toctree::
20 :maxdepth: 2
18 :maxdepth: 2
21
19
20+ introduction.rst
22 tutorial/index.rst
21 tutorial/index.rst
23 cookbook/index.rst
22 cookbook/index.rst
24 examples.md
23 examples.md
25 links.rst
24 links.rst
26− principles.rst
doc/principles.rst → doc/introduction.rstrenamed+2−2
@@ -1,5 +1,5 @@
1−Principles
1+Introduction
2−----------
2+------------
3
3
4**servant** has the following guiding principles:
4**servant** has the following guiding principles:
5
5
doc/links.rst+3−3
@@ -3,7 +3,7 @@ Helpful Links
3-------------
3-------------
4
4
5- the central documentation (this site):
5- the central documentation (this site):
6− `docs.servant.dev <http://docs.servant.dev/>`_
6+ `haskell-servant.readthedocs.org <http://haskell-servant.readthedocs.org/>`_
7
7
8- the github repo:
8- the github repo:
9 `github.com/haskell-servant/servant <https://github.com/haskell-servant/servant>`_
9 `github.com/haskell-servant/servant <https://github.com/haskell-servant/servant>`_
@@ -12,13 +12,13 @@ Helpful Links
12 `https://github.com/haskell-servant/servant/issues <https://github.com/haskell-servant/servant/issues>`_
12 `https://github.com/haskell-servant/servant/issues <https://github.com/haskell-servant/servant/issues>`_
13
13
14- the irc channel:
14- the irc channel:
15− `#haskell-servant on libera.chat <https://web.libera.chat/#haskell-servant>`_
15+ ``#servant`` on freenode
16
16
17- the mailing list:
17- the mailing list:
18 `groups.google.com/forum/#!forum/haskell-servant <https://groups.google.com/forum/#!forum/haskell-servant>`_
18 `groups.google.com/forum/#!forum/haskell-servant <https://groups.google.com/forum/#!forum/haskell-servant>`_
19
19
20- blog posts and videos and slides of some talks on servant:
20- 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>`_
22
22
23- the servant packages on hackage:
23- the servant packages on hackage:
24
24
doc/requirements.txt+25−4
@@ -1,4 +1,25 @@
1+alabaster==0.7.7
2+argh==0.26.1
3+Babel==2.2.0
4+backports-abc==0.4
5+backports.ssl-match-hostname==3.5.0.1
6+certifi==2015.11.20.1
7+CommonMark==0.5.4
8+docutils==0.12
9+Jinja2==2.8
10+livereload==2.4.1
11+MarkupSafe==0.23
12+pathtools==0.1.2
13+Pygments==2.2.0
14+pytz==2015.7
15+PyYAML==3.11
1−recommonmark==0.5.0
16+recommonmark==0.4.0
17+singledispatch==3.4.0.3
18+six==1.10.0
19+snowballstemmer==1.2.1
2−Sphinx==1.8.4
20+Sphinx==1.3.6
3−sphinx_rtd_theme>=0.4.2
21+sphinx-autobuild==0.5.2
4−jinja2<3.1.0
22+sphinx-rtd-theme==0.1.9
23+tornado==4.3
24+watchdog==0.8.3
25+wheel==0.26.0
doc/tutorial/ApiType.lhs+9−42
@@ -129,23 +129,16 @@ type UserAPI4 = "users" :> Get '[JSON] [User]
129
129
130### `StreamGet` and `StreamPost`
130### `StreamGet` and `StreamPost`
131
131
132−*Note*: Streaming has changed considerably in `servant-0.15`.
133−
134The `StreamGet` and `StreamPost` combinators are defined in terms of the more general `Stream`
132The `StreamGet` and `StreamPost` combinators are defined in terms of the more general `Stream`
135
133
136``` haskell ignore
134``` haskell ignore
137−data Stream (method :: k1) (status :: Nat) (framing :: *) (contentType :: *) (a :: *)
135+data Stream (method :: k1) (framing :: *) (contentType :: *) a
138−
139−type StreamGet = Stream 'GET 200
136+type StreamGet = Stream 'GET
140−type StreamPost = Stream 'POST 200
137+type StreamPost = Stream 'POST
141```
138```
142
139
143−These describe endpoints that return a stream of values rather than just a
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 deliniated from one another in the stream. The two standard strategies given with Servant are `NewlineFraming` and `NetstringFraming`, but others can be written to match other protocols.
144−single value. They not only take a single content type as a parameter, but also
141+
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.
149
142
150### `Capture`
143### `Capture`
151
144
@@ -177,12 +170,13 @@ type UserAPI5 = "user" :> Capture "userid" Integer :> Get '[JSON] User
177 -- except that we explicitly say that "userid"
170 -- except that we explicitly say that "userid"
178 -- must be an integer
171 -- must be an integer
179
172
180− :<|> "user" :> Capture "userid" Integer :> DeleteNoContent
173+ :<|> "user" :> Capture "userid" Integer :> DeleteNoContent '[JSON] NoContent
181 -- equivalent to 'DELETE /user/:userid'
174 -- equivalent to 'DELETE /user/:userid'
182```
175```
183
176
184−In the second case, `DeleteNoContent` specifies a 204 response code
177+In the second case, `DeleteNoContent` specifies a 204 response code,
178+`JSON` specifies the content types on which the handler will match,
185−and that the response will always be empty.
179+and `NoContent` says that the response will always be empty.
186
180
187### `QueryParam`, `QueryParams`, `QueryFlag`
181### `QueryParam`, `QueryParams`, `QueryFlag`
188
182
@@ -389,30 +383,3 @@ One example for this is if you want to serve a directory of static files along
389with the rest of your API. But you can plug in everything that is an
383with the rest of your API. But you can plug in everything that is an
390`Application`, e.g. a whole web application written in any of the web
384`Application`, e.g. a whole web application written in any of the web
391frameworks that support `wai`.
385frameworks 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−12
@@ -47,6 +47,7 @@ module Authentication where
47import Data.Aeson (ToJSON)
47import Data.Aeson (ToJSON)
48import Data.ByteString (ByteString)
48import Data.ByteString (ByteString)
49import Data.Map (Map, fromList)
49import Data.Map (Map, fromList)
50+import Data.Monoid ((<>))
50import qualified Data.Map as Map
51import qualified Data.Map as Map
51import Data.Proxy (Proxy (Proxy))
52import Data.Proxy (Proxy (Proxy))
52import Data.Text (Text)
53import Data.Text (Text)
@@ -107,7 +108,7 @@ API with "private." Additionally, the private parts of our API use the
107realm for this authentication is `"foo-realm"`).
108realm for this authentication is `"foo-realm"`).
108
109
109Unfortunately we're not done. When someone makes a request to our `"private"`
110Unfortunately 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
111usernames and passwords. This adds a certain conceptual wrinkle in servant's
112usernames and passwords. This adds a certain conceptual wrinkle in servant's
112design that we'll briefly discuss. If you want the **TL;DR**: we supply a lookup
113design that we'll briefly discuss. If you want the **TL;DR**: we supply a lookup
113function to servant's new `Context` primitive.
114function to servant's new `Context` primitive.
@@ -132,7 +133,7 @@ combinator. Using `Context`, we can supply a function of type
132handler. This will allow the handler to check authentication and return a `User`
133handler. This will allow the handler to check authentication and return a `User`
133to downstream handlers if successful.
134to downstream handlers if successful.
134
135
135−In practice we wrap `BasicAuthData -> Handler User` into a slightly
136+In practice we wrap `BasicAuthData -> Handler` into a slightly
136different function to better capture the semantics of basic authentication:
137different function to better capture the semantics of basic authentication:
137
138
138``` haskell ignore
139``` haskell ignore
@@ -259,7 +260,7 @@ this.
259
260
260Let's implement a trivial authentication scheme. We will protect our API by
261Let's implement a trivial authentication scheme. We will protect our API by
261looking for a cookie named `"servant-auth-cookie"`. This cookie's value will
262looking 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`.
263
264
264```haskell
265```haskell
265-- | An account type that we "fetch from the database" after
266-- | An account type that we "fetch from the database" after
@@ -273,7 +274,7 @@ database = fromList [ ("key1", Account "Anne Briggs")
273 , ("key3", Account "Ghédalia Tazartès")
274 , ("key3", Account "Ghédalia Tazartès")
274 ]
275 ]
275
276
276−-- | A method that, when given a password, will return an Account.
277+-- | A method that, when given a password, will return a Account.
277-- This is our bespoke (and bad) authentication logic.
278-- This is our bespoke (and bad) authentication logic.
278lookupAccount :: ByteString -> Handler Account
279lookupAccount :: ByteString -> Handler Account
279lookupAccount key = case Map.lookup key database of
280lookupAccount key = case Map.lookup key database of
@@ -317,7 +318,7 @@ genAuthAPI = Proxy
317
318
318Now we need to bring everything together for the server. We have the
319Now we need to bring everything together for the server. We have the
319`AuthHandler Request Account` value and an `AuthProtected` endpoint. To bind these
320`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)
321instance that tells the `HasServer` instance that our `Context` will supply a
322instance that tells the `HasServer` instance that our `Context` will supply a
322`Account` (via `AuthHandler Request Account`) and that downstream combinators will
323`Account` (via `AuthHandler Request Account`) and that downstream combinators will
323have access to this `Account` value (or an error will be thrown if authentication
324have access to this `Account` value (or an error will be thrown if authentication
@@ -345,7 +346,7 @@ genAuthServerContext = authHandler :. EmptyContext
345
346
346-- | Our API, where we provide all the author-supplied handlers for each end
347-- | Our API, where we provide all the author-supplied handlers for each end
347-- point. Note that 'privateDataFunc' is a function that takes 'Account' as an
348-- 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,
349-- that is taken care of by supplying context
350-- that is taken care of by supplying context
350genAuthServer :: Server AuthGenAPI
351genAuthServer :: Server AuthGenAPI
351genAuthServer =
352genAuthServer =
@@ -367,10 +368,10 @@ genAuthMain = run 8080 (serveWithContext genAuthAPI genAuthServerContext genAuth
367$ curl -XGET localhost:8080/private
368$ curl -XGET localhost:8080/private
368Missing auth header
369Missing auth header
369
370
370−$ curl -XGET localhost:8080/private -H "Cookie: servant-auth-cookie=key3"
371+$ curl -XGET localhost:8080/private -H "servant-auth-cookie: key3"
371[{"ssshhh":"this is a secret: Ghédalia Tazartès"}]
372[{"ssshhh":"this is a secret: Ghédalia Tazartès"}]
372
373
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"
374Invalid Cookie
375Invalid Cookie
375
376
376$ curl -XGET localhost:8080/public
377$ curl -XGET localhost:8080/public
@@ -384,11 +385,11 @@ Creating a generalized, ad-hoc authentication scheme was fairly straight
384forward:
385forward:
385
386
3861. use the `AuthProtect` combinator to protect your API.
3871. 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
388authentication is successful (in our case this was `Account`).
389authentication is successful (in our case this was `Account`).
3893. Create a value of `AuthHandler Request Account` which encapsulates the
3903. Create a value of `AuthHandler Request Account` which encapsulates the
390authentication logic (`Request -> Handler Account`). This function
391authentication 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.
3924. Provide an instance of the `AuthServerData` type family, specifying your
3934. Provide an instance of the `AuthServerData` type family, specifying your
393application-specific data type returned when authentication is successful (in
394application-specific data type returned when authentication is successful (in
394our case this was `Account`).
395our case this was `Account`).
@@ -408,8 +409,6 @@ As of `0.5`, *servant-client* comes with support for basic authentication!
408Endpoints protected by Basic Authentication will require a value of type
409Endpoints protected by Basic Authentication will require a value of type
409`BasicAuthData` to complete the request.
410`BasicAuthData` to complete the request.
410
411
411−You can find more comprehensive Basic Authentication example in the [Cookbook](../cookbook/basic-auth/BasicAuth.html).
412−
413### Generalized Authentication
412### Generalized Authentication
414
413
415Servant `0.5` also shipped with support for generalized authentication. Similar
414Servant `0.5` also shipped with support for generalized authentication. Similar
doc/tutorial/Client.lhs+23−80
@@ -1,9 +1,9 @@
1# Querying an API
1# Querying an API
2
2
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.
4
4
5**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`
5**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.
7
7
8The source for this tutorial section is a literate Haskell file, so first we need to have some language extensions and imports:
8The source for this tutorial section is a literate Haskell file, so first we need to have some language extensions and imports:
9
9
@@ -20,9 +20,6 @@ import GHC.Generics
20import Network.HTTP.Client (newManager, defaultManagerSettings)
20import Network.HTTP.Client (newManager, defaultManagerSettings)
21import Servant.API
21import Servant.API
22import Servant.Client
22import Servant.Client
23−import Servant.Types.SourceT (foreach)
24−
25−import qualified Servant.Client.Streaming as S
26```
23```
27
24
28Also, we need examples for some domain specific data types:
25Also, we need examples for some domain specific data types:
@@ -158,100 +155,46 @@ Email {from = "great@company.com", to = "alp@foo.com", subject = "Hey Alp, we mi
158
155
159The types of the arguments for the functions are the same as for (server-side) request handlers.
156The types of the arguments for the functions are the same as for (server-side) request handlers.
160
157
161−## Changing the monad the client functions live in
158+## Querying Streaming APIs.
162
159
163−Just 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
165−in which _client functions_ live. Consider the following trivial API:
160+Consider the following streaming API type:
166
161
167``` haskell
162``` haskell
168−type HoistClientAPI = Get '[JSON] Int :<|> Capture "n" Int :> Post '[JSON] Int
163+type StreamAPI = "positionStream" :> StreamGet NewlineFraming JSON (ResultStream Position)
169−
170−hoistClientAPI :: Proxy HoistClientAPI
171−hoistClientAPI = Proxy
172```
164```
173
165
174−We already know how to derive client functions for this API, and as we have
166+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:
175−seen 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
177−functions in. Sometimes we need to run them in IO, sometimes in a custom monad
178−stack. `hoistClient` is a very simple solution to the problem of "changing" the monad
179−the clients run in.
180
167
181``` haskell ignore
168``` haskell ignore
182−hoistClient
183− :: HasClient ClientM api -- we need a valid API
184− => Proxy api -- a Proxy to the API type
185− -> (forall a. m a -> n a) -- a "monad conversion function" (natural transformation)
186− -> Client m api -- clients in the source monad
187− -> Client n api -- result: clients in the target monad
188−```
189−
190−The "conversion function" argument above, just like the ones given to `hoistServer`, must
191−be able to turn an `m a` into an `n a` for any choice of type `a`.
192−
193−Let's see this in action on our example. We first derive our client functions as usual,
194−with all of them returning a result in `ClientM`.
195−
196−``` haskell
197−getIntClientM :: ClientM Int
198−postIntClientM :: Int -> ClientM Int
199−getIntClientM :<|> postIntClientM = client hoistClientAPI
200−```
201−
202−And we finally decide that we want the handlers to run in IO instead, by
203−"post-applying" `runClientM` to a fixed client environment.
204−
205−``` haskell
206−-- our conversion function has type: forall a. ClientM a -> IO a
207−-- the result has type:
208−-- Client IO HoistClientAPI = IO Int :<|> (Int -> IO Int)
209−getClients :: ClientEnv -> Client IO HoistClientAPI
210−getClients clientEnv
211− = hoistClient hoistClientAPI
212− ( fmap (either (error . show) id)
213− . flip runClientM clientEnv
214− )
215− (client hoistClientAPI)
216−```
217−
218−## Querying Streaming APIs.
219−
220−Consider the following streaming API type:
221−
222−``` haskell
223−type StreamAPI = "positionStream" :> StreamGet NewlineFraming JSON (SourceIO Position)
169+type StreamAPI f = "positionStream" :> StreamGet NewlineFraming JSON (f Position)
170+type ServerStreamAPI = StreamAPI StreamGenerator
171+type ClientStreamAPI = StreamAPI ResultStream
224```
172```
225
173
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).
230−
231In any case, here's how we write a function to query our API:
174In any case, here's how we write a function to query our API:
232
175
233−```haskell
176+``` haskell
234streamAPI :: Proxy StreamAPI
177streamAPI :: Proxy StreamAPI
235streamAPI = Proxy
178streamAPI = Proxy
236
179
237−posStream :: S.ClientM (SourceIO Position)
180+posStream :: ClientM (ResultStream Position)
181+
238−posStream = S.client streamAPI
182+posStream = client streamAPI
239```
183```
240
184
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.
185+And here's how to just print out all elements from a `ResultStream`, to give some idea of how to work with them.
245
186
246``` haskell
187``` haskell
247−printSourceIO :: Show a => ClientEnv -> S.ClientM (SourceIO a) -> IO ()
188+printResultStream :: Show a => ResultStream a -> IO ()
248−printSourceIO env c = S.withClientM c env $ \e -> case e of
189+printResultStream (ResultStream k) = k $ \getResult ->
249− Left err -> putStrLn $ "Error: " ++ show err
190+ let loop = do
250− Right rs -> foreach fail print rs
191+ r <- getResult
192+ case r of
193+ Nothing -> return ()
194+ Just x -> print x >> loop
195+ in loop
251```
196```
252
197
253−The stream is parsed and provided incrementally. So the above loop prints out
198+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.
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.
256
199
257You now know how to use **servant-client**!
200You now know how to use **servant-client**!
doc/tutorial/Docs.lhs+2−2
@@ -77,7 +77,7 @@ instance ToSample HelloMessage where
77 [ ("When a value is provided for 'name'", HelloMessage "Hello, Alp")
77 [ ("When a value is provided for 'name'", HelloMessage "Hello, Alp")
78 , ("When 'name' is not specified", HelloMessage "Hello, anonymous coward")
78 , ("When 'name' is not specified", HelloMessage "Hello, anonymous coward")
79 ]
79 ]
80− -- multiple examples to display this time
80+ -- mutliple examples to display this time
81
81
82ci :: ClientInfo
82ci :: ClientInfo
83ci = ClientInfo "Alp" "alp@foo.com" 26 ["haskell", "mathematics"]
83ci = ClientInfo "Alp" "alp@foo.com" 26 ["haskell", "mathematics"]
@@ -108,7 +108,7 @@ apiDocs = docs exampleAPI
108markdown :: API -> String
108markdown :: API -> String
109```
109```
110
110
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`.
112
112
113````````` text
113````````` text
114## GET /hello
114## GET /hello
doc/tutorial/Javascript.lhs+4−3
@@ -228,13 +228,13 @@ data CommonGeneratorOptions = CommonGeneratorOptions
228 {
228 {
229 -- | function generating function names
229 -- | function generating function names
230 functionNameBuilder :: FunctionName -> Text
230 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)
232 , requestBody :: Text
232 , requestBody :: Text
233 -- | name of the callback parameter when the request was successful
233 -- | name of the callback parameter when the request was successful
234 , successCallback :: Text
234 , successCallback :: Text
235 -- | name of the callback parameter when the request reported an error
235 -- | name of the callback parameter when the request reported an error
236 , errorCallback :: Text
236 , 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)
238 , moduleName :: Text
238 , moduleName :: Text
239 -- | a prefix that should be prepended to the URL in the generated JS
239 -- | a prefix that should be prepended to the URL in the generated JS
240 , urlPrefix :: Text
240 , urlPrefix :: Text
@@ -477,7 +477,7 @@ data AngularOptions = AngularOptions
477 }
477 }
478```
478```
479
479
480−## Custom function name builder
480+# Custom function name builder
481
481
482Servant comes with three name builders included:
482Servant comes with three name builders included:
483
483
@@ -518,3 +518,4 @@ var get_books = function(q, onSuccess, onError)
518}
518}
519
519
520```
520```
521+
doc/tutorial/Server.lhs+47−55
@@ -29,7 +29,7 @@ import Prelude.Compat
29
29
30import Control.Monad.Except
30import Control.Monad.Except
31import Control.Monad.Reader
31import Control.Monad.Reader
32−import Data.Aeson
32+import Data.Aeson.Compat
33import Data.Aeson.Types
33import Data.Aeson.Types
34import Data.Attoparsec.ByteString
34import Data.Attoparsec.ByteString
35import Data.ByteString (ByteString)
35import Data.ByteString (ByteString)
@@ -46,7 +46,6 @@ import Servant
46import System.Directory
46import System.Directory
47import Text.Blaze
47import Text.Blaze
48import Text.Blaze.Html.Renderer.Utf8
48import Text.Blaze.Html.Renderer.Utf8
49−import Servant.Types.SourceT (source)
50import qualified Data.Aeson.Parser
49import qualified Data.Aeson.Parser
51import qualified Text.Blaze.Html
50import qualified Text.Blaze.Html
52```
51```
@@ -96,6 +95,12 @@ users1 =
96 ]
95 ]
97```
96```
98
97
98+Let's also write our API type.
99+
100+``` haskell ignore
101+type UserAPI1 = "users" :> Get '[JSON] [User]
102+```
103+
99We can now take care of writing the actual webservice that will handle requests
104We can now take care of writing the actual webservice that will handle requests
100to such an API. This one will be very simple, being reduced to just a single
105to such an API. This one will be very simple, being reduced to just a single
101endpoint. The type of the web application is determined by the API type,
106endpoint. The type of the web application is determined by the API type,
@@ -183,7 +188,7 @@ users2 = [isaac, albert]
183
188
184Now, just like we separate the various endpoints in `UserAPI` with `:<|>`, we
189Now, just like we separate the various endpoints in `UserAPI` with `:<|>`, we
185are going to separate the handlers with `:<|>` too! They must be provided in
190are going to separate the handlers with `:<|>` too! They must be provided in
186−the same order as in the API type.
191+the same order as in in the API type.
187
192
188``` haskell
193``` haskell
189server2 :: Server UserAPI2
194server2 :: Server UserAPI2
@@ -313,8 +318,8 @@ For reference, here's a list of some combinators from **servant**:
313## The `FromHttpApiData`/`ToHttpApiData` classes
318## The `FromHttpApiData`/`ToHttpApiData` classes
314
319
315Wait... How does **servant** know how to decode the `Int`s from the URL? Or how
320Wait... 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
321+to decode a `ClientInfo` value from the request body? This is what this and the
317−help us answer these questions.
322+following two sections address.
318
323
319`Capture`s and `QueryParam`s are represented by some textual value in URLs.
324`Capture`s and `QueryParam`s are represented by some textual value in URLs.
320`Header`s are similarly represented by a pair of a header name and a
325`Header`s are similarly represented by a pair of a header name and a
@@ -599,7 +604,7 @@ $ curl -H 'Accept: text/html' http://localhost:8081/persons
599
604
600## The `Handler` monad
605## The `Handler` monad
601
606
602−At the heart of the handlers is the monad they run in, namely a newtype `Handler` around `ExceptT ServerError IO`
607+At the heart of the handlers is the monad they run in, namely a newtype `Handler` around `ExceptT ServantErr IO`
603([haddock documentation for `ExceptT`](http://hackage.haskell.org/package/mtl-2.2.1/docs/Control-Monad-Except.html#t:ExceptT)).
608([haddock documentation for `ExceptT`](http://hackage.haskell.org/package/mtl-2.2.1/docs/Control-Monad-Except.html#t:ExceptT)).
604One might wonder: why this monad? The answer is that it is the
609One might wonder: why this monad? The answer is that it is the
605simplest monad with the following properties:
610simplest monad with the following properties:
@@ -617,12 +622,12 @@ newtype ExceptT e m a = ExceptT (m (Either e a))
617```
622```
618
623
619In short, this means that a handler of type `Handler a` is simply
624In 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
625+equivalent to a computation of type `IO (Either ServantErr a)`, that is, an IO
621action that either returns an error or a result.
626action that either returns an error or a result.
622
627
623−The module [`Control.Monad.Except`](https://hackage.haskell.org/package/mtl/docs/Control-Monad-Except.html#t:ExceptT)
628+The module [`Control.Monad.Except`](https://hackage.haskell.org/package/mtl-2.2.1/docs/Control-Monad-Except.html#t:ExceptT)
624from which `ExceptT` comes is worth looking at.
629from which `ExceptT` comes is worth looking at.
625−Perhaps most importantly, `ExceptT` and `Handler` are instances of `MonadError`, so
630+Perhaps most importantly, `ExceptT` and `Handler` are an instances of `MonadError`, so
626`throwError` can be used to return an error from your handler (whereas `return`
631`throwError` can be used to return an error from your handler (whereas `return`
627 is enough to return a success).
632 is enough to return a success).
628
633
@@ -632,9 +637,9 @@ kind and abort early. The next two sections cover how to do just that.
632
637
633### Performing IO
638### Performing IO
634
639
635−Other important instances from the list above are `MonadIO m => MonadIO
640+Another 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.
641+(ExceptT e m)`, and therefore also `MonadIO Handler` as there is `MonadIO IO` instance..
637−[`MonadIO`](http://hackage.haskell.org/package/base/docs/Control-Monad-IO-Class.html#t:MonadIO)
642+[`MonadIO`](http://hackage.haskell.org/package/transformers-0.4.3.0/docs/Control-Monad-IO-Class.html)
638is a class from the **transformers** package defined as:
643is a class from the **transformers** package defined as:
639
644
640``` haskell ignore
645``` haskell ignore
@@ -660,16 +665,16 @@ server5 = do
660 return (FileContent filecontent)
665 return (FileContent filecontent)
661```
666```
662
667
663−### Failing, through `ServerError`
668+### Failing, through `ServantErr`
664
669
665If you want to explicitly fail at providing the result promised by an endpoint
670If you want to explicitly fail at providing the result promised by an endpoint
666using the appropriate HTTP status code (not found, unauthorized, etc) and some
671using the appropriate HTTP status code (not found, unauthorized, etc) and some
667error message, all you have to do is use the `throwError` function mentioned above
672error 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
673+and provide it with the appropriate value of type `ServantErr`, which is
669defined as:
674defined as:
670
675
671``` haskell ignore
676``` haskell ignore
672−data ServerError = ServerError
677+data ServantErr = ServantErr
673 { errHTTPCode :: Int
678 { errHTTPCode :: Int
674 , errReasonPhrase :: String
679 , errReasonPhrase :: String
675 , errBody :: ByteString -- lazy bytestring
680 , errBody :: ByteString -- lazy bytestring
@@ -685,7 +690,7 @@ use record update syntax:
685failingHandler :: Handler ()
690failingHandler :: Handler ()
686failingHandler = throwError myerr
691failingHandler = throwError myerr
687
692
688− where myerr :: ServerError
693+ where myerr :: ServantErr
689 myerr = err503 { errBody = "Sorry dear user." }
694 myerr = err503 { errBody = "Sorry dear user." }
690```
695```
691
696
@@ -716,7 +721,7 @@ $ curl --verbose http://localhost:8081/myfile.txt
716>
721>
717< HTTP/1.1 404 Not Found
722< HTTP/1.1 404 Not Found
718[snip]
723[snip]
719−myfile.txt just isn't there, please leave this server alone.
724+myfile.txt just isnt there, please leave this server alone.
720
725
721$ echo Hello > myfile.txt
726$ echo Hello > myfile.txt
722
727
@@ -818,7 +823,7 @@ If it doesn't exist, the handler will fail with a `404` status code.
818
823
819`serveDirectoryWebApp` uses some standard settings that fit the use case of
824`serveDirectoryWebApp` uses some standard settings that fit the use case of
820serving static files for most web apps. You can find out about the other
825serving static files for most web apps. You can find out about the other
821−options in the documentation of the `Servant.Server.StaticFiles` module.
826+options in the documentation of the `Servant.Utils.StaticFiles` module.
822
827
823## Nested APIs
828## Nested APIs
824
829
@@ -830,7 +835,7 @@ type UserAPI3 = -- view the user with given userid, in JSON
830 Capture "userid" Int :> Get '[JSON] User
835 Capture "userid" Int :> Get '[JSON] User
831
836
832 :<|> -- delete the user with given userid. empty response
837 :<|> -- delete the user with given userid. empty response
833− Capture "userid" Int :> DeleteNoContent
838+ Capture "userid" Int :> DeleteNoContent '[JSON] NoContent
834```
839```
835
840
836We can instead factor out the `userid`:
841We can instead factor out the `userid`:
@@ -838,7 +843,7 @@ We can instead factor out the `userid`:
838``` haskell
843``` haskell
839type UserAPI4 = Capture "userid" Int :>
844type UserAPI4 = Capture "userid" Int :>
840 ( Get '[JSON] User
845 ( Get '[JSON] User
841− :<|> DeleteNoContent
846+ :<|> DeleteNoContent '[JSON] NoContent
842 )
847 )
843```
848```
844
849
@@ -896,13 +901,13 @@ type API1 = "users" :>
896-- we factor out the Request Body
901-- we factor out the Request Body
897type API2 = ReqBody '[JSON] User :>
902type API2 = ReqBody '[JSON] User :>
898 ( Get '[JSON] User -- just display the same user back, don't register it
903 ( Get '[JSON] User -- just display the same user back, don't register it
899− :<|> PostNoContent -- register the user. empty response
904+ :<|> PostNoContent '[JSON] NoContent -- register the user. empty response
900 )
905 )
901
906
902-- we factor out a Header
907-- we factor out a Header
903type API3 = Header "Authorization" Token :>
908type API3 = Header "Authorization" Token :>
904 ( Get '[JSON] SecretData -- get some secret data, if authorized
909 ( Get '[JSON] SecretData -- get some secret data, if authorized
905− :<|> ReqBody '[JSON] SecretData :> PostNoContent -- add some secret data, if authorized
910+ :<|> ReqBody '[JSON] SecretData :> PostNoContent '[JSON] NoContent -- add some secret data, if authorized
906 )
911 )
907
912
908newtype Token = Token ByteString
913newtype Token = Token ByteString
@@ -915,11 +920,11 @@ API type only at the end.
915``` haskell
920``` haskell
916type UsersAPI =
921type UsersAPI =
917 Get '[JSON] [User] -- list users
922 Get '[JSON] [User] -- list users
918− :<|> ReqBody '[JSON] User :> PostNoContent -- add a user
923+ :<|> ReqBody '[JSON] User :> PostNoContent '[JSON] NoContent -- add a user
919 :<|> Capture "userid" Int :>
924 :<|> Capture "userid" Int :>
920 ( Get '[JSON] User -- view a user
925 ( Get '[JSON] User -- view a user
921− :<|> ReqBody '[JSON] User :> PutNoContent -- update a user
926+ :<|> ReqBody '[JSON] User :> PutNoContent '[JSON] NoContent -- update a user
922− :<|> DeleteNoContent -- delete a user
927+ :<|> DeleteNoContent '[JSON] NoContent -- delete a user
923 )
928 )
924
929
925usersServer :: Server UsersAPI
930usersServer :: Server UsersAPI
@@ -948,11 +953,11 @@ usersServer = getUsers :<|> newUser :<|> userOperations
948``` haskell
953``` haskell
949type ProductsAPI =
954type ProductsAPI =
950 Get '[JSON] [Product] -- list products
955 Get '[JSON] [Product] -- list products
951− :<|> ReqBody '[JSON] Product :> PostNoContent -- add a product
956+ :<|> ReqBody '[JSON] Product :> PostNoContent '[JSON] NoContent -- add a product
952 :<|> Capture "productid" Int :>
957 :<|> Capture "productid" Int :>
953 ( Get '[JSON] Product -- view a product
958 ( Get '[JSON] Product -- view a product
954− :<|> ReqBody '[JSON] Product :> PutNoContent -- update a product
959+ :<|> ReqBody '[JSON] Product :> PutNoContent '[JSON] NoContent -- update a product
955− :<|> DeleteNoContent -- delete a product
960+ :<|> DeleteNoContent '[JSON] NoContent -- delete a product
956 )
961 )
957
962
958data Product = Product { productId :: Int }
963data Product = Product { productId :: Int }
@@ -996,11 +1001,11 @@ abstract that away:
996-- indexed by values of type 'i'
1001-- indexed by values of type 'i'
997type APIFor a i =
1002type APIFor a i =
998 Get '[JSON] [a] -- list 'a's
1003 Get '[JSON] [a] -- list 'a's
999− :<|> ReqBody '[JSON] a :> PostNoContent -- add an 'a'
1004+ :<|> ReqBody '[JSON] a :> PostNoContent '[JSON] NoContent -- add an 'a'
1000 :<|> Capture "id" i :>
1005 :<|> Capture "id" i :>
1001 ( Get '[JSON] a -- view an 'a' given its "identifier" of type 'i'
1006 ( Get '[JSON] a -- view an 'a' given its "identifier" of type 'i'
1002− :<|> ReqBody '[JSON] a :> PutNoContent -- update an 'a'
1007+ :<|> ReqBody '[JSON] a :> PutNoContent '[JSON] NoContent -- update an 'a'
1003− :<|> DeleteNoContent -- delete an 'a'
1008+ :<|> DeleteNoContent '[JSON] NoContent -- delete an 'a'
1004 )
1009 )
1005
1010
1006-- Build the appropriate 'Server'
1011-- Build the appropriate 'Server'
@@ -1128,14 +1133,14 @@ This is the webservice in action:
1128``` bash
1133``` bash
1129$ curl http://localhost:8081/a
1134$ curl http://localhost:8081/a
11301797
11351797
1131−$ curl http://localhost:8081/b -X GET -d '42.0' -H 'Content-Type: application/json'
1136+$ curl http://localhost:8081/b
1132−true
1137+"hi"
1133```
1138```
1134
1139
1135### An arrow is a reader too.
1140### An arrow is a reader too.
1136
1141
1137In previous versions of `servant` we had an `enter` to do what `hoistServer`
1142In 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.
1143+does now. `enter` had a ambitious design goals, but was problematic in practice.
1139
1144
1140One problematic situation was when the source monad was `(->) r`, yet it's
1145One problematic situation was when the source monad was `(->) r`, yet it's
1141handy in practice, because `(->) r` is isomorphic to `Reader r`.
1146handy in practice, because `(->) r` is isomorphic to `Reader r`.
@@ -1161,37 +1166,24 @@ app5 = serve readerAPI (hoistServer readerAPI funToHandler funServerT)
1161
1166
1162## Streaming endpoints
1167## Streaming endpoints
1163
1168
1164−We can create endpoints that don't just give back a single result, but give
1169+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.
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.
1174
1170
1175``` haskell
1171``` haskell
1176−type StreamAPI = "userStream" :> StreamGet NewlineFraming JSON (SourceIO User)
1172+type StreamAPI = "userStream" :> StreamGet NewlineFraming JSON (StreamGenerator User)
1177streamAPI :: Proxy StreamAPI
1173streamAPI :: Proxy StreamAPI
1178streamAPI = Proxy
1174streamAPI = Proxy
1179
1175
1180−streamUsers :: SourceIO User
1176+streamUsers :: StreamGenerator User
1181−streamUsers = source [isaac, albert, albert]
1177+streamUsers = StreamGenerator $ \sendFirst sendRest -> do
1178+ sendFirst isaac
1179+ sendRest albert
1180+ sendRest albert
1182
1181
1183app6 :: Application
1182app6 :: Application
1184app6 = serve streamAPI (return streamUsers)
1183app6 = serve streamAPI (return streamUsers)
1185```
1184```
1186
1185
1187−This simple application returns a stream of `User` values encoded in JSON
1186+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.
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.
1195
1187
1196## Conclusion
1188## Conclusion
1197
1189
doc/tutorial/index.rst+3−3
@@ -3,13 +3,13 @@ Tutorial
3
3
4This is an introductory tutorial to **servant**. Whilst browsing is fine, it makes more sense if you read the sections in order, or at least read the first section before anything else.
4This is an introductory tutorial to **servant**. Whilst browsing is fine, it makes more sense if you read the sections in order, or at least read the first section before anything else.
5
5
6−Any comments, issues or feedback about the tutorial can be submitted
6+(Any comments, issues or feedback about the tutorial can be submitted
7−to `servant's issue tracker <http://github.com/haskell-servant/servant/issues>`_.
7+to `servant's issue tracker <http://github.com/haskell-servant/servant/issues>`_.)
8+
8
9
9.. toctree::
10.. toctree::
10 :maxdepth: 1
11 :maxdepth: 1
11
12
12− install.rst
13 ApiType.lhs
13 ApiType.lhs
14 Server.lhs
14 Server.lhs
15 Client.lhs
15 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
1+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
2−
3−import qualified JavascriptSpec
4−
5−import Test.Hspec (Spec, hspec, describe)
6−
7−main :: IO ()
8−main = hspec spec
9−
10−spec :: Spec
11−spec = describe "Javascript" JavascriptSpec.spec
doc/tutorial/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+19−13
@@ -1,20 +1,22 @@
1−cabal-version: 2.2
2name: tutorial
1name: tutorial
3version: 0.10
2version: 0.10
4synopsis: The servant tutorial
3synopsis: The servant tutorial
5description:
4description:
6 The servant tutorial can be found at
5 The servant tutorial can be found at
7− <http://docs.servant.dev/>
6+ <http://haskell-servant.readthedocs.org/>
8−homepage: http://docs.servant.dev/
7+homepage: http://haskell-servant.readthedocs.org/
9category: Servant, Documentation
8category: Servant, Documentation
10−license: BSD-3-Clause
9+license: BSD3
11license-file: LICENSE
10license-file: LICENSE
12author: Servant Contributors
11author: Servant Contributors
13maintainer: haskell-servant-maintainers@googlegroups.com
12maintainer: haskell-servant-maintainers@googlegroups.com
14build-type: Simple
13build-type: Simple
14+cabal-version: >=1.10
15tested-with:
15tested-with:
16− GHC==8.6.5
16+ GHC==7.8.4
17− GHC==8.8.3, GHC ==8.10.7
17+ GHC==7.10.3
18+ GHC==8.0.2
19+ GHC==8.2.2
18extra-source-files:
20extra-source-files:
19 static/index.html
21 static/index.html
20 static/ui.js
22 static/ui.js
@@ -32,8 +34,9 @@ library
32 -- Packages `servant` depends on.
34 -- Packages `servant` depends on.
33 -- We don't need to specify bounds here as this package is never released.
35 -- We don't need to specify bounds here as this package is never released.
34 build-depends:
36 build-depends:
35− base >= 4.7 && <5
37+ base >= 4.7 && <4.11
36 , aeson
38 , aeson
39+ , aeson-compat
37 , attoparsec
40 , attoparsec
38 , base-compat
41 , base-compat
39 , bytestring
42 , bytestring
@@ -63,15 +66,16 @@ library
63 blaze-html >= 0.9.0.1 && < 0.10
66 blaze-html >= 0.9.0.1 && < 0.10
64 , blaze-markup >= 0.8.0.0 && < 0.9
67 , blaze-markup >= 0.8.0.0 && < 0.9
65 , cookie >= 0.4.3 && < 0.5
68 , cookie >= 0.4.3 && < 0.5
66− , js-jquery >= 3.3.1 && < 3.4
69+ , js-jquery >= 3.2.1 && < 3.3
67− , lucid >= 2.9.11 && < 2.12
70+ , lucid >= 2.9.9 && < 2.10
71+ , mtl-compat >= 0.2.1 && < 0.3
68− , random >= 1.1 && < 1.3
72+ , random >= 1.1 && < 1.2
69 , servant-js >= 0.9 && < 0.10
73 , servant-js >= 0.9 && < 0.10
70− , time >= 1.6.0.1 && < 1.13
74+ , time >= 1.4.2 && < 1.9
71
75
72 -- For legacy tools, we need to specify build-depends too
76 -- For legacy tools, we need to specify build-depends too
73− build-depends: markdown-unlit >= 0.5.0 && <0.6
77+ build-depends: markdown-unlit >= 0.4.1 && <0.5
74− build-tool-depends: markdown-unlit:markdown-unlit >= 0.5.0 && <0.6
78+ build-tool-depends: markdown-unlit:markdown-unlit >= 0.4.1 && <0.5
75
79
76test-suite spec
80test-suite spec
77 type: exitcode-stdio-1.0
81 type: exitcode-stdio-1.0
@@ -80,6 +84,8 @@ test-suite spec
80 hs-source-dirs: test
84 hs-source-dirs: test
81 main-is: Spec.hs
85 main-is: Spec.hs
82 other-modules: JavascriptSpec
86 other-modules: JavascriptSpec
87+ build-tool-depends:
88+ hspec-discover:hspec-discover
83 build-depends: base
89 build-depends: base
84 , tutorial
90 , tutorial
85 , hspec
91 , 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:
21``` sh
21``` sh
22$ nix-shell nix/shell.nix --argstr compiler ghcHEAD
22$ nix-shell nix/shell.nix --argstr compiler ghcHEAD
23```
23```
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+{ pkgs ? import <nixpkgs> {}
1−{ compiler ? "ghc8104"
2+, compiler ? "ghc821"
2, tutorial ? false
3, tutorial ? false
3−, pkgs ? import ./nixpkgs.nix
4}:
4}:
5−
6− with pkgs;
7
5
6+with pkgs;
7+
8− let
8+let
9− ghc = haskell.packages.${compiler}.ghcWithPackages (_: []);
9+ ghc = haskell.packages.${compiler}.ghcWithPackages (_: []);
10− docstuffs = python3.withPackages (ps: with ps; [ recommonmark sphinx sphinx_rtd_theme ]);
10+ docstuffs = python3.withPackages (ps: with ps; [ recommonmark sphinx sphinx_rtd_theme ]);
11− in
11+in
12+
12− stdenv.mkDerivation {
13+stdenv.mkDerivation {
13− name = "servant-dev";
14+ name = "servant-dev";
14− buildInputs = [ ghc zlib python3 wget cabal-install postgresql openssl stack haskellPackages.hspec-discover ]
15+ buildInputs = [ ghc zlib python3 wget ]
15− ++ (if tutorial then [docstuffs postgresql] else []);
16+ ++ (if tutorial then [docstuffs postgresql] else []);
16− shellHook = ''
17+ shellHook = ''
17− eval $(grep export ${ghc}/bin/ghc)
18+ eval $(grep export ${ghc}/bin/ghc)
18− export LD_LIBRARY_PATH=$LD_LIBRARY_PATH:"${zlib}/lib";
19+ export LD_LIBRARY_PATH="${zlib}/lib";
19− '';
20+ '';
20− }
21+}
scripts/README.mdnew file+8
@@ -0,0 +1,8 @@
1+The release process works roughly like this:
2+
3+``` bash
4+./scripts/bump-versions.sh <type-of-bump>
5+git commit
6+./scripts/upload.hs
7+git tag <version> && git push --tags
8+```
scripts/bump-versions.shnew file+62
@@ -0,0 +1,62 @@
1+#!/usr/bin/env bash
2+#===============================================================================
3+#
4+# FILE: bump-versions.sh
5+#
6+# USAGE: ./bump-versions.sh
7+#
8+# DESCRIPTION: Bump the versions for all servant packages
9+#
10+# OPTIONS: See usage
11+# REQUIREMENTS: bumper, bash >= 4
12+# CREATED: 11.05.2015 21:36
13+# REVISION: ---
14+#===============================================================================
15+
16+set -o nounset
17+set -o errexit
18+
19+DIR=$( dirname $( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd ))
20+. "${DIR}/scripts/lib/common.sh"
21+
22+usage () {
23+ echo " bump-versions.sh <POSITION> [-d|--dry-run]"
24+ echo " | [-h|--help]"
25+ echo " Bumps the specified positional version of all servant packages."
26+ echo " POSITION is a number between 0 and 3, inclusive."
27+ exit 0
28+}
29+
30+if [ $# -eq 0 ] ; then
31+ echo "expecting one or more arguments. Got 0"
32+ usage
33+elif [ $# -gt 2 ] ; then
34+ echo "expecting one or more arguments"
35+ usage
36+fi
37+
38+versions_equal
39+
40+while [ "${1:-unset}" != "unset" ] ; do
41+ case "$1" in
42+ -h | --help) usage ;;
43+ -d | --dry-run) DRY_RUN=true
44+ shift ;;
45+ 0) if POSITION="none" ; then POSITION=0 ; else usage ; fi
46+ shift ;;
47+ 1) if POSITION="none" ; then POSITION=1 ; else usage ; fi
48+ shift ;;
49+ 2) if POSITION="none" ; then POSITION=2 ; else usage ; fi
50+ shift ;;
51+ 3) if POSITION="none" ; then POSITION=3 ; else usage ; fi
52+ shift ;;
53+ *) usage ;;
54+ esac
55+done
56+
57+if $DRY_RUN ; then
58+ echo "Would have bumped position ${POSITION} on these packages:"
59+ ( cd "$ROOT" && bumper --dry-run -"$POSITION" $(join , $SOURCES tutorial) )
60+else
61+ ( cd "$ROOT" && bumper -"$POSITION" $(join , $SOURCES tutorial) )
62+fi
scripts/ci-cron.shnew file+20
@@ -0,0 +1,20 @@
1+#!/usr/bin/env bash
2+
3+set -o nounset
4+set -o errexit
5+set -o verbose
6+
7+export PATH=$(stack path --bin-path):$PATH
8+
9+stack install cabal-install
10+cabal update
11+
12+for package in $(cat sources.txt) ; do
13+ echo testing $package
14+ pushd $package
15+ tinc
16+ cabal configure --enable-tests --disable-optimization --ghc-options='-Werror'
17+ cabal build
18+ cabal test
19+ popd
20+done
scripts/clear-sandbox.shnew file+26
@@ -0,0 +1,26 @@
1+#!/usr/bin/env bash
2+#===============================================================================
3+#
4+# FILE: clear-sandbox.sh
5+#
6+# USAGE: ./clear-sandbox.sh
7+#
8+# DESCRIPTION: Clear sandbox at top-level and at all packages
9+#
10+# REQUIREMENTS: bash >= 4
11+#===============================================================================
12+
13+set -o nounset
14+set -o errexit
15+
16+DIR=$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )
17+. "$DIR"/lib/common.sh
18+
19+clear_sandbox () {
20+ rm -rf .cabal-sandbox cabal.sandbox.config
21+ for s in ${SOURCES[@]} ; do
22+ (cd "$s" && rm -rf cabal.sandbox.config dist)
23+ done
24+}
25+
26+clear_sandbox
scripts/generate-nix-files.shnew file+48
@@ -0,0 +1,48 @@
1+#!/usr/bin/env bash
2+#===============================================================================
3+#
4+# FILE: generate-nix-files.sh
5+#
6+# USAGE: ./generate-nix-files.sh
7+#
8+# DESCRIPTION: Update nix files at top-level and add all packages
9+#
10+# REQUIREMENTS: bash >= 4, cabal2nix(nix tool)
11+#===============================================================================
12+
13+set -o nounset
14+set -o errexit
15+
16+DIR=$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )
17+. "$DIR"/lib/common.sh
18+SHELLNIX="shell.nix"
19+
20+write-package-shell-nix () {
21+ rm -rf $SHELLNIX
22+ echo -e "let" >> $SHELLNIX
23+ echo -e " pkgs = import <nixpkgs> {};" >> $SHELLNIX
24+ echo -e "" >> $SHELLNIX
25+ echo -e " haskellPackages = pkgs.haskellPackages.override {" >> $SHELLNIX
26+ echo -e " overrides = self: super: {" >> $SHELLNIX
27+ for n in ${SOURCES[@]} ; do
28+ if [[ $1 != $n ]]; then
29+ echo -e " $n = pkgs.haskell.lib.dontCheck (pkgs.haskell.lib.appendConfigureFlag (self.callPackage ../$n {}) \"--ghc-options=-Werror\");" >> $SHELLNIX
30+ fi
31+ done
32+ echo -e " $1 = pkgs.haskell.lib.appendConfigureFlag (self.callPackage ./. {}) \"--ghc-options=-Werror\";" >> $SHELLNIX
33+ echo -e " };" >> $SHELLNIX
34+ echo -e " };" >> $SHELLNIX
35+ echo -e "" >> $SHELLNIX
36+ echo -e "in haskellPackages.$s.env" >> $SHELLNIX
37+}
38+
39+update-nix-files () {
40+ for s in ${SOURCES[@]} ; do
41+ pushd "$s" > /dev/null
42+ cabal2nix . > default.nix
43+ write-package-shell-nix $s
44+ popd > /dev/null
45+ done
46+}
47+
48+update-nix-files
scripts/lib/common.shnew file+56
@@ -0,0 +1,56 @@
1+#!/bin/bash -
2+#===============================================================================
3+#
4+# FILE: lib/common.sh
5+#
6+# DESCRIPTION: Common functions for servant's shell scripts
7+# Meant to be sourced rather than run.
8+#
9+# REQUIREMENTS: bash >= 4
10+#===============================================================================
11+
12+
13+DIR=$( dirname $( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd ))
14+ROOT=$( dirname $DIR )
15+DRY_RUN=false
16+POSITION="none"
17+SOURCES_TXT="$( dirname $DIR)/sources.txt"
18+CABAL=${CABAL:-cabal}
19+TRAVIS=${TRAVIS:-false}
20+
21+declare -a SOURCES
22+SOURCES=$(awk -F= '{print $1}' "$SOURCES_TXT")
23+
24+join () { local IFS="$1"; shift; echo "$*"; }
25+
26+versions_equal () {
27+ local NUM=$(cd "$ROOT" && find . -name 'servant*.cabal' | xargs grep "^version:" | awk '{ print $2 }' | uniq -c | wc -l)
28+ if [ 1 -eq $NUM ] ; then
29+ return 0
30+ else
31+ echo "versions of packages are not all the same!" && exit 1
32+ fi
33+}
34+
35+travis_retry() {
36+ # From
37+ # https://github.com/travis-ci/travis-build/blob/18bd04e965b9bfaa49cd6bdcd8dcb1513b8d2fcd/lib/travis/build/templates/header.sh
38+ local result=0
39+ local count=1
40+ while [ $count -le 3 ]; do
41+ [ $result -ne 0 ] && {
42+ echo -e "\n${ANSI_RED}The command \"$@\" failed. Retrying, $count of 3.${ANSI_RESET}\n" >&2
43+ }
44+ "$@"
45+ result=$?
46+ [ $result -eq 0 ] && break
47+ count=$(($count + 1))
48+ sleep 1
49+ done
50+
51+ [ $count -gt 3 ] && {
52+ echo -e "\n${ANSI_RED}The command \"$@\" failed 3 times.${ANSI_RESET}\n" >&2
53+ }
54+
55+ return $result
56+}
scripts/start-sandbox.shnew file+26
@@ -0,0 +1,26 @@
1+#!/usr/bin/env bash
2+#===============================================================================
3+#
4+# FILE: start-sandbox.sh
5+#
6+# USAGE: ./start-sandbox.sh
7+#
8+# DESCRIPTION: Create sandbox at top-level and add all packages as add-source
9+#
10+# REQUIREMENTS: bash >= 4
11+#===============================================================================
12+
13+set -o nounset
14+set -o errexit
15+
16+DIR=$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )
17+. "$DIR"/lib/common.sh
18+
19+prepare_sandbox () {
20+ $CABAL sandbox init
21+ for s in ${SOURCES[@]} ; do
22+ (cd "$s" && $CABAL sandbox init --sandbox=../.cabal-sandbox && $CABAL sandbox add-source .)
23+ done
24+}
25+
26+prepare_sandbox
scripts/test-all.shnew file+46
@@ -0,0 +1,46 @@
1+#!/usr/bin/env bash
2+#===============================================================================
3+#
4+# FILE: test-all.sh
5+#
6+# USAGE: ./test-all.sh
7+#
8+# DESCRIPTION: Run tests for all source directories listed in $SOURCES.
9+# Uses local versions of those sources.
10+#
11+# REQUIREMENTS: bash >= 4
12+#===============================================================================
13+
14+set -o nounset
15+set -o errexit
16+
17+DIR=$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )
18+. "$DIR"/lib/common.sh
19+
20+GHC_FLAGS="-Werror"
21+
22+prepare_sandbox () {
23+ $CABAL sandbox init
24+ for s in ${SOURCES[@]} ; do
25+ (cd "$s" && $CABAL sandbox init --sandbox=../.cabal-sandbox/ && $CABAL sandbox add-source .)
26+ done
27+ if $TRAVIS ; then
28+ travis_retry $CABAL install --enable-tests ${SOURCES[@]}
29+ else
30+ $CABAL install --max-backjumps -1 --reorder-goals --enable-tests ${SOURCES[@]}
31+ fi
32+}
33+
34+test_each () {
35+ for s in ${SOURCES[@]} ; do
36+ echo "Testing $s..."
37+ pushd "$s"
38+ $CABAL configure --enable-tests --ghc-options="$GHC_FLAGS"
39+ $CABAL build
40+ $CABAL test
41+ popd
42+ done
43+}
44+
45+prepare_sandbox
46+test_each
scripts/test-stack.shnew file+11
@@ -0,0 +1,11 @@
1+#!/usr/bin/env bash
2+
3+set -o nounset
4+set -o errexit
5+
6+for stack_file in stack*.yaml ; do
7+ echo testing $stack_file...
8+ export STACK_YAML=$stack_file
9+ stack setup
10+ stack test --fast --ghc-options="-Werror"
11+done
scripts/upload.hsnew file+14
@@ -0,0 +1,14 @@
1+#!/usr/bin/env stack
2+{- stack
3+--resolver lts-3.10
4+--install-ghc runghc
5+-}
6+
7+import Data.Foldable
8+import System.Process
9+
10+main :: IO ()
11+main = do
12+ sources <- words <$> readFile "sources.txt"
13+ forM_ sources $ \ source -> do
14+ callCommand ("stack upload --no-signature " ++ source)
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/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−292
@@ -1,298 +1,6 @@
1[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-client-core/CHANGELOG.md)
1[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-client-core/CHANGELOG.md)
2[Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)
2[Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)
3
3
4−Package versions follow the [Package Versioning Policy](https://pvp.haskell.org/): in A.B.C, bumps to either A or B represent major versions.
5−
6−0.19
7−----
8−
9−### Significant changes
10−
11−- Drop support for GHC < 8.6.
12−- Support GHC 9.0 (GHC 9.2 should work as well, but isn't fully tested yet).
13−- Support Aeson 2 ([#1475](https://github.com/haskell-servant/servant/pull/1475)),
14− which fixes a [DOS vulnerability](https://github.com/haskell/aeson/issues/864)
15− related to hash collisions.
16−- Add `NamedRoutes` combinator, making support for records first-class in Servant
17− ([#1388](https://github.com/haskell-servant/servant/pull/1388)).
18−- Add custom type errors for partially applied combinators
19− ([#1289](https://github.com/haskell-servant/servant/pull/1289),
20− [#1486](https://github.com/haskell-servant/servant/pull/1486)).
21−- *servant-client* / *servant-client-core* / *servant-http-streams*: Fix
22− erroneous behavior, where only 2XX status codes would be considered
23− successful, irrelevant of the status parameter specified by the verb
24− combinator. ([#1469](https://github.com/haskell-servant/servant/pull/1469))
25−- *servant-client* / *servant-client-core*: Fix `Show` instance for
26− `Servant.Client.Core.Request`.
27−- *servant-client* / *servant-client-core*: Allow passing arbitrary binary data
28− in Query parameters.
29− ([#1432](https://github.com/haskell-servant/servant/pull/1432)).
30−
31−### Other changes
32−
33−- Various version bumps.
34−
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−
236−0.14.1
237−------
238−
239−- Merge in `servant-generic` (by [Patrick Chilton](https://github.com/chpatrick))
240− into `servant` (`Servant.API.Generic`),
241− `servant-client-code` (`Servant.Client.Generic`)
242− and `servant-server` (`Servant.Server.Generic`).
243−
244−0.14
245−----
246−
247−- `Stream` takes a status code argument
248−
249− ```diff
250− -Stream method framing ctype a
251− +Stream method status framing ctype a
252− ```
253−
254− ([#966](https://github.com/haskell-servant/servant/pull/966)
255− [#972](https://github.com/haskell-servant/servant/pull/972))
256−
257−- `ToStreamGenerator` definition changed, so it's possible to write an instance
258− for conduits.
259−
260− ```diff
261− -class ToStreamGenerator f a where
262− - toStreamGenerator :: f a -> StreamGenerator a
263− +class ToStreamGenerator a b | a -> b where
264− + toStreamGenerator :: a -> StreamGenerator b
265− ```
266−
267− ([#959](https://github.com/haskell-servant/servant/pull/959))
268−
269−- Added `NoFraming` streaming strategy
270− ([#959](https://github.com/haskell-servant/servant/pull/959))
271−
272−- *servant-client-core* Free `Client` implementation.
273− Useful for testing `HasClient` instances.
274− ([#920](https://github.com/haskell-servant/servant/pull/920))
275−
276−- *servant-client-core* Add `hoistClient` to `HasClient`.
277− 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
279− 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).
281− ([#936](https://github.com/haskell-servant/servant/pull/936))
282−
283− iF you have own combinators, you'll need to define a new method of
284− `HasClient` class, for example:
285−
286− ```haskell
287− type Client m (MyCombinator :> api) = MyValue :> Client m api
288− hoistClientMonad pm _ nt cl = hoistClientMonad pm (Proxy :: Proxy api) nt . cl
289− ```
290−
291−0.13.0.1
292−--------
293−
294−- Support `base-compat-0.10`
295−
2960.13
40.13
297----
5----
298
6
servant-client-core/LICENSE+1−1
@@ -1,4 +1,4 @@
1−Copyright (c) 2017-2018, Servant Contributors
1+Copyright (c) 2017, Servant Contributors
2
2
3All rights reserved.
3All rights reserved.
4
4
servant-client-core/Setup.hs+1−1
@@ -1,2 +1,2 @@
1−import Distribution.Simple
1+import Distribution.Simple
2main = defaultMain
2main = defaultMain
servant-client-core/include/overlapping-compat.hnew file+8
@@ -0,0 +1,8 @@
1+#if __GLASGOW_HASKELL__ >= 710
2+#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}
3+#define OVERLAPPING_ {-# OVERLAPPING #-}
4+#else
5+{-# LANGUAGE OverlappingInstances #-}
6+#define OVERLAPPABLE_
7+#define OVERLAPPING_
8+#endif
servant-client-core/servant-client-core.cabal+42−51
@@ -1,27 +1,28 @@
1−cabal-version: 2.2
2name: servant-client-core
1name: servant-client-core
3−version: 0.19
2+version: 0.13
4−
5synopsis: Core functionality and class for client function generation for servant APIs
3synopsis: Core functionality and class for client function generation for servant APIs
6−category: Servant, Web
7description:
4description:
8 This library provides backend-agnostic generation of client functions. For
5 This library provides backend-agnostic generation of client functions. For
9 more information, see the README.
6 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
14license-file: LICENSE
8license-file: LICENSE
15author: Servant Contributors
9author: Servant Contributors
16maintainer: haskell-servant-maintainers@googlegroups.com
10maintainer: haskell-servant-maintainers@googlegroups.com
11+homepage: http://haskell-servant.readthedocs.org/
12+bug-reports: http://github.com/haskell-servant/servant/issues
13+cabal-version: >=1.10
17−copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors
14+copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2017 Servant Contributors
15+category: Web
18build-type: Simple
16build-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−
22extra-source-files:
17extra-source-files:
18+ include/*.h
23 CHANGELOG.md
19 CHANGELOG.md
24 README.md
20 README.md
21+tested-with:
22+ GHC==7.8.4
23+ GHC==7.10.3
24+ GHC==8.0.2
25+ GHC==8.2.2
25
26
26source-repository head
27source-repository head
27 type: git
28 type: git
@@ -30,60 +31,51 @@ source-repository head
30library
31library
31 exposed-modules:
32 exposed-modules:
32 Servant.Client.Core
33 Servant.Client.Core
33− Servant.Client.Free
34− Servant.Client.Generic
35 Servant.Client.Core.Reexport
34 Servant.Client.Core.Reexport
36− Servant.Client.Core.Auth
35+ Servant.Client.Core.Internal.Auth
37− Servant.Client.Core.BaseUrl
36+ Servant.Client.Core.Internal.BaseUrl
38− Servant.Client.Core.BasicAuth
37+ Servant.Client.Core.Internal.BasicAuth
39− Servant.Client.Core.ClientError
38+ Servant.Client.Core.Internal.Generic
40− Servant.Client.Core.HasClient
39+ Servant.Client.Core.Internal.HasClient
41− Servant.Client.Core.Request
40+ Servant.Client.Core.Internal.Request
42− Servant.Client.Core.Response
41+ Servant.Client.Core.Internal.RunClient
43− Servant.Client.Core.RunClient
44−
45− other-modules:
46− Servant.Client.Core.Internal
47
42
48 -- Bundled with GHC: Lower bound to not force re-installs
43 -- Bundled with GHC: Lower bound to not force re-installs
49 -- text and mtl are bundled starting with GHC-8.4
44 -- text and mtl are bundled starting with GHC-8.4
50 --
45 --
51 -- note: mtl lower bound is so low because of GHC-7.8
46 -- note: mtl lower bound is so low because of GHC-7.8
52 build-depends:
47 build-depends:
53− base >= 4.9 && < 4.18
48+ base >= 4.7 && < 4.11
54− , bytestring >= 0.10.8.1 && < 0.12
49+ , bytestring >= 0.10.4.0 && < 0.11
55− , constraints >= 0.2 && < 0.14
56− , containers >= 0.5.7.1 && < 0.7
50+ , containers >= 0.5.5.1 && < 0.6
57− , deepseq >= 1.4.2.0 && < 1.5
51+ , mtl >= 2.1 && < 2.3
58− , text >= 1.2.3.0 && < 2.1
52+ , text >= 1.2.3.0 && < 1.3
59− , transformers >= 0.5.2.0 && < 0.7
60− , template-haskell >= 2.11.1.0 && < 2.20
61
53
62− if !impl(ghc >= 8.2)
54+ if !impl(ghc >= 8.0)
63 build-depends:
55 build-depends:
64− bifunctors >= 5.5.3 && < 5.6
56+ semigroups >=0.18.3 && <0.19
65
57
66 -- Servant dependencies
58 -- Servant dependencies
67 build-depends:
59 build-depends:
68− servant >= 0.19
60+ servant == 0.13.*
69
61
70 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.
62 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.
71 -- Here can be exceptions if we really need features from the newer versions.
63 -- Here can be exceptions if we really need features from the newer versions.
72 build-depends:
64 build-depends:
73− aeson >= 1.4.1.0 && < 3
74− , base-compat >= 0.10.5 && < 0.13
65+ base-compat >= 0.9.3 && < 0.10
75− , base64-bytestring >= 1.0.0.1 && < 1.3
66+ , base64-bytestring >= 1.0.0.1 && < 1.1
76− , exceptions >= 0.10.0 && < 0.11
67+ , exceptions >= 0.8.3 && < 0.9
77− , free >= 5.1 && < 5.2
68+ , generics-sop >= 0.3.1.0 && < 0.4
69+ , http-api-data >= 0.3.7.1 && < 0.4
78− , http-media >= 0.7.1.3 && < 0.9
70+ , http-media >= 0.7.1.1 && < 0.8
79− , http-types >= 0.12.2 && < 0.13
71+ , http-types >= 0.12 && < 0.13
80 , network-uri >= 2.6.1.0 && < 2.7
72 , network-uri >= 2.6.1.0 && < 2.7
81− , safe >= 0.3.17 && < 0.4
73+ , safe >= 0.3.15 && < 0.4
82− , sop-core >= 0.4.0.0 && < 0.6
83
74
84 hs-source-dirs: src
75 hs-source-dirs: src
85 default-language: Haskell2010
76 default-language: Haskell2010
86 ghc-options: -Wall
77 ghc-options: -Wall
78+ include-dirs: include
87
79
88test-suite spec
80test-suite spec
89 type: exitcode-stdio-1.0
81 type: exitcode-stdio-1.0
@@ -93,7 +85,6 @@ test-suite spec
93 main-is: Spec.hs
85 main-is: Spec.hs
94 other-modules:
86 other-modules:
95 Servant.Client.Core.Internal.BaseUrlSpec
87 Servant.Client.Core.Internal.BaseUrlSpec
96− Servant.Client.Core.RequestSpec
97
88
98 -- Dependencies inherited from the library. No need to specify bounds.
89 -- Dependencies inherited from the library. No need to specify bounds.
99 build-depends:
90 build-depends:
@@ -101,11 +92,11 @@ test-suite spec
101 , base-compat
92 , base-compat
102 , servant-client-core
93 , servant-client-core
103
94
104− -- Additional dependencies
95+ -- Additonal dependencies
105 build-depends:
96 build-depends:
106− deepseq >= 1.4.2.0 && < 1.5
97+ deepseq >= 1.3.0.2 && <1.5
107− , hspec >= 2.6.0 && < 2.10
98+ , hspec >= 2.4.4 && <2.5
108− , QuickCheck >= 2.12.6.1 && < 2.15
99+ , QuickCheck >= 2.10.1 && < 2.12
109
100
110 build-tool-depends:
101 build-tool-depends:
111− hspec-discover:hspec-discover >= 2.6.0 && <2.10
102+ hspec-discover:hspec-discover >= 2.4.4 && <2.5
servant-client-core/src/Servant/Client/Core.hs+19−25
@@ -18,8 +18,6 @@ module Servant.Client.Core
18 -- * Client generation
18 -- * Client generation
19 clientIn
19 clientIn
20 , HasClient(..)
20 , HasClient(..)
21− , foldMapUnion
22− , matchUnion
23
21
24 -- * Request
22 -- * Request
25 , Request
23 , Request
@@ -34,23 +32,19 @@ module Servant.Client.Core
34 , AuthClientData
32 , AuthClientData
35
33
36 -- * Generic Client
34 -- * Generic Client
37− , ClientError(..)
35+ , ClientLike(..)
36+ , genericMkClientL
37+ , genericMkClientP
38+ , ServantError(..)
38 , EmptyClient(..)
39 , EmptyClient(..)
39
40
41+
40 -- * Response
42 -- * Response
41 , Response
43 , Response
42− , ResponseF (..)
44+ , GenResponse (..)
43 , RunClient(..)
45 , RunClient(..)
44− -- * BaseUrl
46+ , module Servant.Client.Core.Internal.BaseUrl
45− , BaseUrl (..)
46− , Scheme (..)
47− , showBaseUrl
48− , parseBaseUrl
49− , InvalidBaseUrlException (..)
50−
51− -- ** Streaming
52− , RunStreamingClient(..)
53− , StreamingResponse
47+ , StreamingResponse(..)
54
48
55 -- * Writing HasClient instances
49 -- * Writing HasClient instances
56 -- | These functions need not be re-exported by backend libraries.
50 -- | These functions need not be re-exported by backend libraries.
@@ -59,15 +53,15 @@ module Servant.Client.Core
59 , appendToPath
53 , appendToPath
60 , setRequestBodyLBS
54 , setRequestBodyLBS
61 , setRequestBody
55 , setRequestBody
62− , encodeQueryParamValue
63 ) where
56 ) where
64−import Servant.Client.Core.Auth
57+import Servant.Client.Core.Internal.Auth
65−import Servant.Client.Core.BaseUrl
58+import Servant.Client.Core.Internal.BaseUrl (BaseUrl (..),
66− (BaseUrl (..), InvalidBaseUrlException (..), Scheme (..),
59+ InvalidBaseUrlException,
60+ Scheme (..),
67− parseBaseUrl, showBaseUrl)
61+ parseBaseUrl,
62+ showBaseUrl)
68−import Servant.Client.Core.BasicAuth
63+import Servant.Client.Core.Internal.BasicAuth
69−import Servant.Client.Core.ClientError
64+import Servant.Client.Core.Internal.HasClient
70−import Servant.Client.Core.HasClient
71−import Servant.Client.Core.Request
65+import Servant.Client.Core.Internal.Generic
66+import Servant.Client.Core.Internal.Request
72−import Servant.Client.Core.Response
67+import Servant.Client.Core.Internal.RunClient
73−import Servant.Client.Core.RunClient
servant-client-core/src/Servant/Client/Core/BaseUrl.hsdeleted−144
@@ -1,144 +0,0 @@
1−{-# LANGUAGE DeriveDataTypeable #-}
2−{-# LANGUAGE DeriveGeneric #-}
3−{-# LANGUAGE DeriveLift #-}
4−{-# LANGUAGE ViewPatterns #-}
5−module Servant.Client.Core.BaseUrl (
6− BaseUrl (..),
7− Scheme (..),
8− showBaseUrl,
9− parseBaseUrl,
10− InvalidBaseUrlException (..),
11− ) where
12−
13−import Control.DeepSeq
14− (NFData (..))
15−import Control.Monad.Catch
16− (Exception, MonadThrow, throwM)
17−import Data.Aeson
18− (FromJSON (..), FromJSONKey (..), ToJSON (..), ToJSONKey (..))
19−import Data.Aeson.Types
20− (FromJSONKeyFunction (..), contramapToJSONKeyFunction,
21− withText)
22−import Data.Data
23− (Data)
24−import Data.List
25−import qualified Data.Text as T
26−import GHC.Generics
27−import Language.Haskell.TH.Syntax
28− (Lift)
29−import Network.URI hiding
30− (path)
31−import Safe
32−import Text.Read
33−
34−-- | URI scheme to use
35−data Scheme =
36− Http -- ^ http://
37− | Https -- ^ https://
38− deriving (Show, Eq, Ord, Generic, Lift, Data)
39−
40−-- | Simple data type to represent the target of HTTP requests
41−-- for servant's automatically-generated clients.
42−data BaseUrl = BaseUrl
43− { baseUrlScheme :: Scheme -- ^ URI scheme to use
44− , baseUrlHost :: String -- ^ host (eg "haskell.org")
45− , baseUrlPort :: Int -- ^ port (eg 80)
46− , baseUrlPath :: String -- ^ path (eg "/a/b/c")
47− } deriving (Show, Ord, Generic, Lift, Data)
48−-- TODO: Ord is more precise than Eq
49−-- 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
53−
54−instance Eq BaseUrl where
55− BaseUrl a b c path == BaseUrl a' b' c' path'
56− = a == a' && b == b' && c == c' && s path == s path'
57− where s ('/':x) = x
58− s x = x
59−
60−-- | >>> traverse_ (LBS8.putStrLn . encode) $ parseBaseUrl "api.example.com"
61−-- "http://api.example.com"
62−instance ToJSON BaseUrl where
63− toJSON = toJSON . showBaseUrl
64− toEncoding = toEncoding . showBaseUrl
65−
66−-- | >>> parseBaseUrl "api.example.com" >>= decode . encode :: Maybe BaseUrl
67−-- Just (BaseUrl {baseUrlScheme = Http, baseUrlHost = "api.example.com", baseUrlPort = 80, baseUrlPath = ""})
68−instance FromJSON BaseUrl where
69− parseJSON = withText "BaseUrl" $ \t -> case parseBaseUrl (T.unpack t) of
70− Just u -> return u
71− Nothing -> fail $ "Invalid base url: " ++ T.unpack t
72−
73−-- | >>> :{
74−-- traverse_ (LBS8.putStrLn . encode) $ do
75−-- u1 <- parseBaseUrl "api.example.com"
76−-- u2 <- parseBaseUrl "example.com"
77−-- return $ Map.fromList [(u1, 'x'), (u2, 'y')]
78−-- :}
79−-- {"http://api.example.com":"x","http://example.com":"y"}
80−instance ToJSONKey BaseUrl where
81− toJSONKey = contramapToJSONKeyFunction showBaseUrl toJSONKey
82−
83−instance FromJSONKey BaseUrl where
84− fromJSONKey = FromJSONKeyTextParser $ \t -> case parseBaseUrl (T.unpack t) of
85− Just u -> return u
86− Nothing -> fail $ "Invalid base url: " ++ T.unpack t
87−
88−-- | >>> showBaseUrl <$> parseBaseUrl "api.example.com"
89−-- "http://api.example.com"
90−showBaseUrl :: BaseUrl -> String
91−showBaseUrl (BaseUrl urlscheme host port path) =
92− schemeString ++ "//" ++ host ++ (portString </> path)
93− where
94− a </> b = if "/" `isPrefixOf` b || null b then a ++ b else a ++ '/':b
95− schemeString = case urlscheme of
96− Http -> "http:"
97− Https -> "https:"
98− portString = case (urlscheme, port) of
99− (Http, 80) -> ""
100− (Https, 443) -> ""
101− _ -> ":" ++ show port
102−
103−newtype InvalidBaseUrlException = InvalidBaseUrlException String deriving (Show)
104−instance Exception InvalidBaseUrlException
105−
106−-- |
107−--
108−-- >>> parseBaseUrl "api.example.com"
109−-- BaseUrl {baseUrlScheme = Http, baseUrlHost = "api.example.com", baseUrlPort = 80, baseUrlPath = ""}
110−--
111−-- /Note:/ trailing slash is removed
112−--
113−-- >>> parseBaseUrl "api.example.com/"
114−-- BaseUrl {baseUrlScheme = Http, baseUrlHost = "api.example.com", baseUrlPort = 80, baseUrlPath = ""}
115−--
116−-- >>> parseBaseUrl "api.example.com/dir/"
117−-- BaseUrl {baseUrlScheme = Http, baseUrlHost = "api.example.com", baseUrlPort = 80, baseUrlPath = "/dir"}
118−--
119−parseBaseUrl :: MonadThrow m => String -> m BaseUrl
120−parseBaseUrl s = case parseURI (removeTrailingSlash s) of
121− -- This is a rather hacky implementation and should be replaced with something
122− -- implemented in attoparsec (which is already a dependency anyhow (via aeson)).
123− Just (URI "http:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) path "" "") ->
124− return (BaseUrl Http host port path)
125− Just (URI "http:" (Just (URIAuth "" host "")) path "" "") ->
126− return (BaseUrl Http host 80 path)
127− Just (URI "https:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) path "" "") ->
128− return (BaseUrl Https host port path)
129− Just (URI "https:" (Just (URIAuth "" host "")) path "" "") ->
130− return (BaseUrl Https host 443 path)
131− _ -> if "://" `isInfixOf` s
132− then throwM (InvalidBaseUrlException $ "Invalid base URL: " ++ s)
133− else parseBaseUrl ("http://" ++ s)
134− where
135− removeTrailingSlash str = case lastMay str of
136− Just '/' -> init str
137− _ -> str
138−
139−-- $setup
140−--
141−-- >>> import Data.Aeson
142−-- >>> import Data.Foldable (traverse_)
143−-- >>> import qualified Data.ByteString.Lazy.Char8 as LBS8
144−-- >>> import qualified Data.Map.Strict as Map
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/HasClient.hsdeleted−1011
@@ -1,1011 +0,0 @@
1−{-# LANGUAGE ConstraintKinds #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE FlexibleContexts #-}
4−{-# LANGUAGE FlexibleInstances #-}
5−{-# LANGUAGE InstanceSigs #-}
6−{-# LANGUAGE MultiParamTypeClasses #-}
7−{-# LANGUAGE OverloadedStrings #-}
8−{-# LANGUAGE PolyKinds #-}
9−{-# LANGUAGE QuantifiedConstraints #-}
10−{-# LANGUAGE RankNTypes #-}
11−{-# LANGUAGE ScopedTypeVariables #-}
12−{-# LANGUAGE TypeApplications #-}
13−{-# LANGUAGE TypeFamilies #-}
14−{-# LANGUAGE TypeOperators #-}
15−{-# LANGUAGE UndecidableInstances #-}
16−
17−module Servant.Client.Core.HasClient (
18− clientIn,
19− HasClient (..),
20− EmptyClient (..),
21− AsClientT,
22− (//),
23− (/:),
24− foldMapUnion,
25− matchUnion,
26− ) where
27−
28−import Prelude ()
29−import Prelude.Compat
30−
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(..))
40−import Data.Foldable
41− (toList)
42−import Data.List
43− (foldl')
44−import Data.Sequence
45− (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))
59−import Data.String
60− (fromString)
61−import Data.Text
62− (Text, pack)
63−import Data.Proxy
64− (Proxy (Proxy))
65−import GHC.TypeLits
66− (KnownNat, KnownSymbol, TypeError, symbolVal)
67−import Network.HTTP.Types
68− (Status)
69−import qualified Network.HTTP.Types as H
70−import Servant.API
71− ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, BasicAuthData,
72− BuildHeadersTo (..), Capture', CaptureAll, Description,
73− EmptyAPI, Fragment, FramingRender (..), FramingUnrender (..),
74− FromSourceIO (..), Header', Headers (..), HttpVersion,
75− 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)
85−import Servant.API.ContentTypes
86− (contentTypes, AllMime (allMime), AllMimeUnrender (allMimeUnrender))
87−import Servant.API.Status
88− (statusFromNat)
89−import Servant.API.TypeLevel (FragmentUnique, AtLeastOneFragment)
90−import Servant.API.Modifiers
91− (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)
95−
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
102−
103−-- * Accessing APIs as a Client
104−
105−-- | 'clientIn' allows you to produce operations to query an API from a client
106−-- within a 'RunClient' monad.
107−--
108−-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books
109−-- > :<|> "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book -- POST /books
110−-- >
111−-- > myApi :: Proxy MyApi
112−-- > myApi = Proxy
113−-- >
114−-- > clientM :: Proxy ClientM
115−-- > clientM = Proxy
116−-- >
117−-- > getAllBooks :: ClientM [Book]
118−-- > postNewBook :: Book -> ClientM Book
119−-- > (getAllBooks :<|> postNewBook) = myApi `clientIn` clientM
120−clientIn :: HasClient m api => Proxy api -> Proxy m -> Client m api
121−clientIn p pm = clientWithRoute pm p defaultRequest
122−
123−
124−-- | This class lets us define how each API combinator influences the creation
125−-- of an HTTP request.
126−--
127−-- Unless you are writing a new backend for @servant-client-core@ or new
128−-- combinators that you want to support client-generation, you can ignore this
129−-- class.
130−class RunClient m => HasClient m api where
131− type Client (m :: * -> *) (api :: *) :: *
132− clientWithRoute :: Proxy m -> Proxy api -> Request -> Client m api
133− hoistClientMonad
134− :: Proxy m
135− -> Proxy api
136− -> (forall x. mon x -> mon' x)
137− -> Client mon api
138− -> Client mon' api
139−
140−
141−-- | A client querying function for @a ':<|>' b@ will actually hand you
142−-- one function for querying @a@ and another one for querying @b@,
143−-- stitching them together with ':<|>', which really is just like a pair.
144−--
145−-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books
146−-- > :<|> "books" :> ReqBody '[JSON] Book :> Post Book -- POST /books
147−-- >
148−-- > myApi :: Proxy MyApi
149−-- > myApi = Proxy
150−-- >
151−-- > getAllBooks :: ClientM [Book]
152−-- > postNewBook :: Book -> ClientM Book
153−-- > (getAllBooks :<|> postNewBook) = client myApi
154−instance (HasClient m a, HasClient m b) => HasClient m (a :<|> b) where
155− type Client m (a :<|> b) = Client m a :<|> Client m b
156− clientWithRoute pm Proxy req =
157− clientWithRoute pm (Proxy :: Proxy a) req :<|>
158− clientWithRoute pm (Proxy :: Proxy b) req
159−
160− hoistClientMonad pm _ f (ca :<|> cb) =
161− hoistClientMonad pm (Proxy :: Proxy a) f ca :<|>
162− hoistClientMonad pm (Proxy :: Proxy b) f cb
163−
164−-- | Singleton type representing a client for an empty API.
165−data EmptyClient = EmptyClient deriving (Eq, Show, Bounded, Enum)
166−
167−-- | The client for 'EmptyAPI' is simply 'EmptyClient'.
168−--
169−-- > type MyAPI = "books" :> Get '[JSON] [Book] -- GET /books
170−-- > :<|> "nothing" :> EmptyAPI
171−-- >
172−-- > myApi :: Proxy MyApi
173−-- > myApi = Proxy
174−-- >
175−-- > getAllBooks :: ClientM [Book]
176−-- > (getAllBooks :<|> EmptyClient) = client myApi
177−instance RunClient m => HasClient m EmptyAPI where
178− type Client m EmptyAPI = EmptyClient
179− clientWithRoute _pm Proxy _ = EmptyClient
180− hoistClientMonad _ _ _ EmptyClient = EmptyClient
181−
182−-- | If you use a 'Capture' in one of your endpoints in your API,
183−-- the corresponding querying function will automatically take
184−-- an additional argument of the type specified by your 'Capture'.
185−-- That function will take care of inserting a textual representation
186−-- of this value at the right place in the request path.
187−--
188−-- You can control how values for this type are turned into
189−-- text by specifying a 'ToHttpApiData' instance for your type.
190−--
191−-- Example:
192−--
193−-- > type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book
194−-- >
195−-- > myApi :: Proxy MyApi
196−-- > myApi = Proxy
197−-- >
198−-- > getBook :: Text -> ClientM Book
199−-- > getBook = client myApi
200−-- > -- then you can just use "getBook" to query that endpoint
201−instance (KnownSymbol capture, ToHttpApiData a, HasClient m api)
202− => HasClient m (Capture' mods capture a :> api) where
203−
204− type Client m (Capture' mods capture a :> api) =
205− a -> Client m api
206−
207− clientWithRoute pm Proxy req val =
208− clientWithRoute pm (Proxy :: Proxy api)
209− (appendToPath p req)
210−
211− where p = toEncodedUrlPiece val
212−
213− hoistClientMonad pm _ f cl = \a ->
214− hoistClientMonad pm (Proxy :: Proxy api) f (cl a)
215−
216−-- | If you use a 'CaptureAll' in one of your endpoints in your API,
217−-- the corresponding querying function will automatically take an
218−-- additional argument of a list of the type specified by your
219−-- 'CaptureAll'. That function will take care of inserting a textual
220−-- representation of this value at the right place in the request
221−-- path.
222−--
223−-- You can control how these values are turned into text by specifying
224−-- a 'ToHttpApiData' instance of your type.
225−--
226−-- Example:
227−--
228−-- > type MyAPI = "src" :> CaptureAll Text -> Get '[JSON] SourceFile
229−-- >
230−-- > myApi :: Proxy
231−-- > myApi = Proxy
232−--
233−-- > getSourceFile :: [Text] -> ClientM SourceFile
234−-- > getSourceFile = client myApi
235−-- > -- then you can use "getSourceFile" to query that endpoint
236−instance (KnownSymbol capture, ToHttpApiData a, HasClient m sublayout)
237− => HasClient m (CaptureAll capture a :> sublayout) where
238−
239− type Client m (CaptureAll capture a :> sublayout) =
240− [a] -> Client m sublayout
241−
242− clientWithRoute pm Proxy req vals =
243− clientWithRoute pm (Proxy :: Proxy sublayout)
244− (foldl' (flip appendToPath) req ps)
245−
246− where ps = map toEncodedUrlPiece vals
247−
248− hoistClientMonad pm _ f cl = \as ->
249− hoistClientMonad pm (Proxy :: Proxy sublayout) f (cl as)
250−
251−instance {-# OVERLAPPABLE #-}
252− -- Note [Non-Empty Content Types]
253− ( RunClient m, MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)
254− , KnownNat status
255− ) => HasClient m (Verb method status cts' a) where
256− type Client m (Verb method status cts' a) = m a
257− clientWithRoute _pm Proxy req = do
258− response <- runRequestAcceptStatus (Just [status]) req
259− { requestAccept = fromList $ toList accept
260− , requestMethod = method
261− }
262− response `decodedAs` (Proxy :: Proxy ct)
263− where
264− accept = contentTypes (Proxy :: Proxy ct)
265− method = reflectMethod (Proxy :: Proxy method)
266− status = statusFromNat (Proxy :: Proxy status)
267−
268− hoistClientMonad _ _ f ma = f ma
269−
270−instance {-# OVERLAPPING #-}
271− ( RunClient m, ReflectMethod method, KnownNat status
272− ) => HasClient m (Verb method status cts NoContent) where
273− type Client m (Verb method status cts NoContent)
274− = 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
287− clientWithRoute _pm Proxy req = do
288− _response <- runRequest req { requestMethod = method }
289− return NoContent
290− where method = reflectMethod (Proxy :: Proxy method)
291−
292− hoistClientMonad _ _ f ma = f ma
293−
294−instance {-# OVERLAPPING #-}
295− -- Note [Non-Empty Content Types]
296− ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls, KnownNat status
297− , ReflectMethod method, cts' ~ (ct ': cts)
298− ) => HasClient m (Verb method status cts' (Headers ls a)) where
299− type Client m (Verb method status cts' (Headers ls a))
300− = m (Headers ls a)
301− clientWithRoute _pm Proxy req = do
302− response <- runRequestAcceptStatus (Just [status]) req
303− { requestMethod = method
304− , requestAccept = fromList $ toList accept
305− }
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)
314−
315− hoistClientMonad _ _ f ma = f ma
316−
317−instance {-# OVERLAPPING #-}
318− ( RunClient m, BuildHeadersTo ls, ReflectMethod method, KnownNat status
319− ) => HasClient m (Verb method status cts (Headers ls NoContent)) where
320− type Client m (Verb method status cts (Headers ls NoContent))
321− = m (Headers ls NoContent)
322− clientWithRoute _pm Proxy req = do
323− response <- runRequestAcceptStatus (Just [status]) req { requestMethod = method }
324− return $ Headers { getResponse = NoContent
325− , getHeadersHList = buildHeadersTo . toList $ responseHeaders response
326− }
327− where
328− method = reflectMethod (Proxy :: Proxy method)
329− status = statusFromNat (Proxy :: Proxy status)
330−
331− hoistClientMonad _ _ f ma = f ma
332−
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−
419−instance {-# 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
423−
424− type Client m (Stream method status framing ct a) = m a
425−
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)
445−
446− hoistClientMonad _ _ f ma = f ma
447−
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−
463−-- | If you use a 'Header' in one of your endpoints in your API,
464−-- the corresponding querying function will automatically take
465−-- an additional argument of the type specified by your 'Header',
466−-- wrapped in Maybe.
467−--
468−-- That function will take care of encoding this argument as Text
469−-- in the request headers.
470−--
471−-- All you need is for your type to have a 'ToHttpApiData' instance.
472−--
473−-- Example:
474−--
475−-- > newtype Referer = Referer { referrer :: Text }
476−-- > deriving (Eq, Show, Generic, ToHttpApiData)
477−-- >
478−-- > -- GET /view-my-referer
479−-- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get '[JSON] Referer
480−-- >
481−-- > myApi :: Proxy MyApi
482−-- > myApi = Proxy
483−-- >
484−-- > viewReferer :: Maybe Referer -> ClientM Book
485−-- > viewReferer = client myApi
486−-- > -- then you can just use "viewRefer" to query that endpoint
487−-- > -- specifying Nothing or e.g Just "http://haskell.org/" as arguments
488−instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequired mods))
489− => HasClient m (Header' mods sym a :> api) where
490−
491− type Client m (Header' mods sym a :> api) =
492− RequiredArgument mods a -> Client m api
493−
494− clientWithRoute pm Proxy req mval =
495− clientWithRoute pm (Proxy :: Proxy api) $ foldRequiredArgument
496− (Proxy :: Proxy mods) add (maybe req add) mval
497− where
498− hname = fromString $ symbolVal (Proxy :: Proxy sym)
499−
500− add :: a -> Request
501− add value = addHeader hname value req
502−
503− hoistClientMonad pm _ f cl = \arg ->
504− hoistClientMonad pm (Proxy :: Proxy api) f (cl arg)
505−
506−-- | Using a 'HttpVersion' combinator in your API doesn't affect the client
507−-- functions.
508−instance HasClient m api
509− => HasClient m (HttpVersion :> api) where
510−
511− type Client m (HttpVersion :> api) =
512− Client m api
513−
514− clientWithRoute pm Proxy =
515− clientWithRoute pm (Proxy :: Proxy api)
516−
517− hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
518−
519−-- | Ignore @'Summary'@ in client functions.
520−instance HasClient m api => HasClient m (Summary desc :> api) where
521− type Client m (Summary desc :> api) = Client m api
522−
523− clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api)
524−
525− hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
526−
527−-- | Ignore @'Description'@ in client functions.
528−instance HasClient m api => HasClient m (Description desc :> api) where
529− type Client m (Description desc :> api) = Client m api
530−
531− clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api)
532−
533− hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
534−
535−-- | If you use a 'QueryParam' in one of your endpoints in your API,
536−-- the corresponding querying function will automatically take
537−-- an additional argument of the type specified by your 'QueryParam',
538−-- enclosed in Maybe.
539−--
540−-- If you give Nothing, nothing will be added to the query string.
541−--
542−-- If you give a non-'Nothing' value, this function will take care
543−-- of inserting a textual representation of this value in the query string.
544−--
545−-- You can control how values for your type are turned into
546−-- text by specifying a 'ToHttpApiData' instance for your type.
547−--
548−-- Example:
549−--
550−-- > type MyApi = "books" :> QueryParam "author" Text :> Get '[JSON] [Book]
551−-- >
552−-- > myApi :: Proxy MyApi
553−-- > myApi = Proxy
554−-- >
555−-- > getBooksBy :: Maybe Text -> ClientM [Book]
556−-- > getBooksBy = client myApi
557−-- > -- then you can just use "getBooksBy" to query that endpoint.
558−-- > -- 'getBooksBy Nothing' for all books
559−-- > -- 'getBooksBy (Just "Isaac Asimov")' to get all books by Isaac Asimov
560−instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequired mods))
561− => HasClient m (QueryParam' mods sym a :> api) where
562−
563− type Client m (QueryParam' mods sym a :> api) =
564− RequiredArgument mods a -> Client m api
565−
566− -- if mparam = Nothing, we don't add it to the query string
567− clientWithRoute pm Proxy req mparam =
568− clientWithRoute pm (Proxy :: Proxy api) $ foldRequiredArgument
569− (Proxy :: Proxy mods) add (maybe req add) mparam
570− where
571− add :: a -> Request
572− add param = appendToQueryString pname (Just $ encodeQueryParamValue param) req
573−
574− pname :: Text
575− pname = pack $ symbolVal (Proxy :: Proxy sym)
576−
577− hoistClientMonad pm _ f cl = \arg ->
578− hoistClientMonad pm (Proxy :: Proxy api) f (cl arg)
579−
580−-- | If you use a 'QueryParams' in one of your endpoints in your API,
581−-- the corresponding querying function will automatically take
582−-- an additional argument, a list of values of the type specified
583−-- by your 'QueryParams'.
584−--
585−-- If you give an empty list, nothing will be added to the query string.
586−--
587−-- Otherwise, this function will take care
588−-- of inserting a textual representation of your values in the query string,
589−-- under the same query string parameter name.
590−--
591−-- You can control how values for your type are turned into
592−-- text by specifying a 'ToHttpApiData' instance for your type.
593−--
594−-- Example:
595−--
596−-- > type MyApi = "books" :> QueryParams "authors" Text :> Get '[JSON] [Book]
597−-- >
598−-- > myApi :: Proxy MyApi
599−-- > myApi = Proxy
600−-- >
601−-- > getBooksBy :: [Text] -> ClientM [Book]
602−-- > getBooksBy = client myApi
603−-- > -- then you can just use "getBooksBy" to query that endpoint.
604−-- > -- 'getBooksBy []' for all books
605−-- > -- 'getBooksBy ["Isaac Asimov", "Robert A. Heinlein"]'
606−-- > -- to get all books by Asimov and Heinlein
607−instance (KnownSymbol sym, ToHttpApiData a, HasClient m api)
608− => HasClient m (QueryParams sym a :> api) where
609−
610− type Client m (QueryParams sym a :> api) =
611− [a] -> Client m api
612−
613− clientWithRoute pm Proxy req paramlist =
614− clientWithRoute pm (Proxy :: Proxy api)
615− (foldl' (\ req' -> maybe req' (flip (appendToQueryString pname) req' . Just))
616− req
617− paramlist'
618− )
619−
620− where pname = pack $ symbolVal (Proxy :: Proxy sym)
621− paramlist' = map (Just . encodeQueryParamValue) paramlist
622−
623− hoistClientMonad pm _ f cl = \as ->
624− hoistClientMonad pm (Proxy :: Proxy api) f (cl as)
625−
626−-- | If you use a 'QueryFlag' in one of your endpoints in your API,
627−-- the corresponding querying function will automatically take
628−-- an additional 'Bool' argument.
629−--
630−-- If you give 'False', nothing will be added to the query string.
631−--
632−-- Otherwise, this function will insert a value-less query string
633−-- parameter under the name associated to your 'QueryFlag'.
634−--
635−-- Example:
636−--
637−-- > type MyApi = "books" :> QueryFlag "published" :> Get '[JSON] [Book]
638−-- >
639−-- > myApi :: Proxy MyApi
640−-- > myApi = Proxy
641−-- >
642−-- > getBooks :: Bool -> ClientM [Book]
643−-- > getBooks = client myApi
644−-- > -- then you can just use "getBooks" to query that endpoint.
645−-- > -- 'getBooksBy False' for all books
646−-- > -- 'getBooksBy True' to only get _already published_ books
647−instance (KnownSymbol sym, HasClient m api)
648− => HasClient m (QueryFlag sym :> api) where
649−
650− type Client m (QueryFlag sym :> api) =
651− Bool -> Client m api
652−
653− clientWithRoute pm Proxy req flag =
654− clientWithRoute pm (Proxy :: Proxy api)
655− (if flag
656− then appendToQueryString paramname Nothing req
657− else req
658− )
659−
660− where paramname = pack $ symbolVal (Proxy :: Proxy sym)
661−
662− hoistClientMonad pm _ f cl = \b ->
663− hoistClientMonad pm (Proxy :: Proxy api) f (cl b)
664−
665−-- | Pick a 'Method' and specify where the server you want to query is. You get
666−-- back the full `Response`.
667−instance RunClient m => HasClient m Raw where
668− type Client m Raw
669− = H.Method -> m Response
670−
671− clientWithRoute :: Proxy m -> Proxy Raw -> Request -> Client m Raw
672− clientWithRoute _pm Proxy req httpMethod = do
673− runRequest req { requestMethod = httpMethod }
674−
675− hoistClientMonad _ _ f cl = \meth -> f (cl meth)
676−
677−instance RunClient m => HasClient m RawM where
678− type Client m RawM
679− = H.Method -> m Response
680−
681− clientWithRoute :: Proxy m -> Proxy RawM -> Request -> Client m RawM
682− clientWithRoute _pm Proxy req httpMethod = do
683− runRequest req { requestMethod = httpMethod }
684−
685− hoistClientMonad _ _ f cl = \meth -> f (cl meth)
686−
687−-- | If you use a 'ReqBody' in one of your endpoints in your API,
688−-- the corresponding querying function will automatically take
689−-- an additional argument of the type specified by your 'ReqBody'.
690−-- That function will take care of encoding this argument as JSON and
691−-- of using it as the request body.
692−--
693−-- All you need is for your type to have a 'ToJSON' instance.
694−--
695−-- Example:
696−--
697−-- > type MyApi = "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book
698−-- >
699−-- > myApi :: Proxy MyApi
700−-- > myApi = Proxy
701−-- >
702−-- > addBook :: Book -> ClientM Book
703−-- > addBook = client myApi
704−-- > -- then you can just use "addBook" to query that endpoint
705−instance (MimeRender ct a, HasClient m api)
706− => HasClient m (ReqBody' mods (ct ': cts) a :> api) where
707−
708− type Client m (ReqBody' mods (ct ': cts) a :> api) =
709− a -> Client m api
710−
711− clientWithRoute pm Proxy req body =
712− clientWithRoute pm (Proxy :: Proxy api)
713− (let ctProxy = Proxy :: Proxy ct
714− in setRequestBodyLBS (mimeRender ctProxy body)
715− -- We use first contentType from the Accept list
716− (contentType ctProxy)
717− req
718− )
719−
720− hoistClientMonad pm _ f cl = \a ->
721− hoistClientMonad pm (Proxy :: Proxy api) f (cl a)
722−
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−
745−-- | Make the querying function append @path@ to the request path.
746−instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where
747− type Client m (path :> api) = Client m api
748−
749− clientWithRoute pm Proxy req =
750− clientWithRoute pm (Proxy :: Proxy api)
751− (appendToPath p req)
752−
753− where p = toEncodedUrlPiece $ pack $ symbolVal (Proxy :: Proxy path)
754−
755− hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
756−
757−instance HasClient m api => HasClient m (Vault :> api) where
758− type Client m (Vault :> api) = Client m api
759−
760− clientWithRoute pm Proxy req =
761− clientWithRoute pm (Proxy :: Proxy api) req
762−
763− hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
764−
765−instance HasClient m api => HasClient m (RemoteHost :> api) where
766− type Client m (RemoteHost :> api) = Client m api
767−
768− clientWithRoute pm Proxy req =
769− clientWithRoute pm (Proxy :: Proxy api) req
770−
771− hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
772−
773−instance HasClient m api => HasClient m (IsSecure :> api) where
774− type Client m (IsSecure :> api) = Client m api
775−
776− clientWithRoute pm Proxy req =
777− clientWithRoute pm (Proxy :: Proxy api) req
778−
779− hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
780−
781−instance HasClient m subapi =>
782− HasClient m (WithNamedContext name context subapi) where
783−
784− type Client m (WithNamedContext name context subapi) = Client m subapi
785− clientWithRoute pm Proxy = clientWithRoute pm (Proxy :: Proxy subapi)
786−
787− hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy subapi) f cl
788−
789−instance HasClient m subapi =>
790− HasClient m (WithResource res :> subapi) where
791−
792− type Client m (WithResource res :> subapi) = Client m subapi
793− clientWithRoute pm Proxy = clientWithRoute pm (Proxy :: Proxy subapi)
794−
795− hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy subapi) f cl
796−
797−instance ( HasClient m api
798− ) => HasClient m (AuthProtect tag :> api) where
799− type Client m (AuthProtect tag :> api)
800− = AuthenticatedRequest (AuthProtect tag) -> Client m api
801−
802− clientWithRoute pm Proxy req (AuthenticatedRequest (val,func)) =
803− clientWithRoute pm (Proxy :: Proxy api) (func val req)
804−
805− hoistClientMonad pm _ f cl = \authreq ->
806− hoistClientMonad pm (Proxy :: Proxy api) f (cl authreq)
807−
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−
831−-- * Basic Authentication
832−
833−instance HasClient m api => HasClient m (BasicAuth realm usr :> api) where
834− type Client m (BasicAuth realm usr :> api) = BasicAuthData -> Client m api
835−
836− clientWithRoute pm Proxy req val =
837− clientWithRoute pm (Proxy :: Proxy api) (basicAuthReq val req)
838−
839− hoistClientMonad pm _ f cl = \bauth ->
840− hoistClientMonad pm (Proxy :: Proxy api) f (cl bauth)
841−
842−-- | A type that specifies that an API record contains a client implementation.
843−data AsClientT (m :: * -> *)
844−instance GenericMode (AsClientT m) where
845− type AsClientT m :- api = Client m api
846−
847−
848−type GClientConstraints api m =
849− ( GenericServant api (AsClientT m)
850− , Client m (ToServantApi api) ~ ToServant api (AsClientT m)
851− )
852−
853−class GClient (api :: * -> *) m where
854− gClientProof :: Dict (GClientConstraints api m)
855−
856−instance GClientConstraints api m => GClient api m where
857− gClientProof = Dict
858−
859−instance
860− ( forall n. GClient api n
861− , HasClient m (ToServantApi api)
862− , RunClient m
863− )
864− => HasClient m (NamedRoutes api) where
865− type Client m (NamedRoutes api) = api (AsClientT m)
866−
867− clientWithRoute :: Proxy m -> Proxy (NamedRoutes api) -> Request -> Client m (NamedRoutes api)
868− clientWithRoute pm _ request =
869− case gClientProof @api @m of
870− Dict -> fromServant $ clientWithRoute pm (Proxy @(ToServantApi api)) request
871−
872− hoistClientMonad
873− :: forall ma mb.
874− Proxy m
875− -> Proxy (NamedRoutes api)
876− -> (forall x. ma x -> mb x)
877− -> Client ma (NamedRoutes api)
878− -> Client mb (NamedRoutes api)
879− hoistClientMonad _ _ nat clientA =
880− case (gClientProof @api @ma, gClientProof @api @mb) of
881− (Dict, Dict) ->
882− fromServant @api @(AsClientT mb) $
883− hoistClientMonad @m @(ToServantApi api) @ma @mb Proxy Proxy nat $
884− toServant @api @(AsClientT ma) clientA
885−
886−infixl 1 //
887−infixl 2 /:
888−
889−-- | Helper to make code using records of clients more readable.
890−--
891−-- Can be mixed with (/:) for supplying arguments.
892−--
893−-- Example:
894−--
895−-- @
896−-- type Api = NamedRoutes RootApi
897−--
898−-- data RootApi mode = RootApi
899−-- { subApi :: mode :- NamedRoutes SubApi
900−-- , …
901−-- } deriving Generic
902−--
903−-- data SubApi mode = SubApi
904−-- { endpoint :: mode :- Get '[JSON] Person
905−-- , …
906−-- } deriving Generic
907−--
908−-- api :: Proxy API
909−-- api = Proxy
910−--
911−-- rootClient :: RootApi (AsClientT ClientM)
912−-- rootClient = client api
913−--
914−-- endpointClient :: ClientM Person
915−-- endpointClient = client \/\/ subApi \/\/ endpoint
916−-- @
917−(//) :: a -> (a -> b) -> b
918−x // f = f x
919−
920−-- | Convenience function for supplying arguments to client functions when
921−-- working with records of clients.
922−--
923−-- Intended to be used in conjunction with '(//)'.
924−--
925−-- Example:
926−--
927−-- @
928−-- type Api = NamedRoutes RootApi
929−--
930−-- data RootApi mode = RootApi
931−-- { subApi :: mode :- Capture "token" String :> NamedRoutes SubApi
932−-- , hello :: mode :- Capture "name" String :> Get '[JSON] String
933−-- , …
934−-- } deriving Generic
935−--
936−-- data SubApi mode = SubApi
937−-- { endpoint :: mode :- Get '[JSON] Person
938−-- , …
939−-- } deriving Generic
940−--
941−-- api :: Proxy API
942−-- api = Proxy
943−--
944−-- rootClient :: RootApi (AsClientT ClientM)
945−-- rootClient = client api
946−--
947−-- hello :: String -> ClientM String
948−-- hello name = rootClient \/\/ hello \/: name
949−--
950−-- endpointClient :: ClientM Person
951−-- endpointClient = client \/\/ subApi \/: "foobar123" \/\/ endpoint
952−-- @
953−(/:) :: (a -> b -> c) -> b -> a -> c
954−(/:) = flip
955−
956−
957−{- Note [Non-Empty Content Types]
958−~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
959−Rather than have
960−
961− instance (..., cts' ~ (ct ': cts)) => ... cts' ...
962−
963−It may seem to make more sense to have:
964−
965− instance (...) => ... (ct ': cts) ...
966−
967−But this means that if another instance exists that does *not* require
968−non-empty lists, but is otherwise more specific, no instance will be overall
969−more specific. This in turn generally means adding yet another instance (one
970−for empty and one for non-empty lists).
971−-}
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.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−7
@@ -4,14 +4,9 @@
4
4
5-- | Authentication for clients
5-- | Authentication for clients
6
6
7−module Servant.Client.Core.Auth (
7+module Servant.Client.Core.Internal.Auth where
8− AuthClientData,
9− AuthenticatedRequest (..),
10− mkAuthenticatedRequest,
11− ) where
12
8
13−import Servant.Client.Core.Request
9+import Servant.Client.Core.Internal.Request (Request)
14− (Request)
15
10
16-- | For a resource protected by authentication (e.g. AuthProtect), we need
11-- | For a resource protected by authentication (e.g. AuthProtect), we need
17-- to provide the client with some data used to add authentication data
12-- to provide the client with some data used to add authentication data
servant-client-core/src/Servant/Client/Core/Internal/BaseUrl.hsnew file+69
@@ -0,0 +1,69 @@
1+{-# LANGUAGE DeriveDataTypeable #-}
2+{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE ViewPatterns #-}
4+module Servant.Client.Core.Internal.BaseUrl where
5+
6+import Control.Monad.Catch (Exception, MonadThrow, throwM)
7+import Data.List
8+import Data.Typeable
9+import GHC.Generics
10+import Network.URI hiding (path)
11+import Safe
12+import Text.Read
13+
14+-- | URI scheme to use
15+data Scheme =
16+ Http -- ^ http://
17+ | Https -- ^ https://
18+ deriving (Show, Eq, Ord, Generic)
19+
20+-- | Simple data type to represent the target of HTTP requests
21+-- for servant's automatically-generated clients.
22+data BaseUrl = BaseUrl
23+ { baseUrlScheme :: Scheme -- ^ URI scheme to use
24+ , baseUrlHost :: String -- ^ host (eg "haskell.org")
25+ , baseUrlPort :: Int -- ^ port (eg 80)
26+ , baseUrlPath :: String -- ^ path (eg "/a/b/c")
27+ } deriving (Show, Ord, Generic)
28+
29+instance Eq BaseUrl where
30+ BaseUrl a b c path == BaseUrl a' b' c' path'
31+ = a == a' && b == b' && c == c' && s path == s path'
32+ where s ('/':x) = x
33+ s x = x
34+
35+showBaseUrl :: BaseUrl -> String
36+showBaseUrl (BaseUrl urlscheme host port path) =
37+ schemeString ++ "//" ++ host ++ (portString </> path)
38+ where
39+ a </> b = if "/" `isPrefixOf` b || null b then a ++ b else a ++ '/':b
40+ schemeString = case urlscheme of
41+ Http -> "http:"
42+ Https -> "https:"
43+ portString = case (urlscheme, port) of
44+ (Http, 80) -> ""
45+ (Https, 443) -> ""
46+ _ -> ":" ++ show port
47+
48+data InvalidBaseUrlException = InvalidBaseUrlException String deriving (Show, Typeable)
49+instance Exception InvalidBaseUrlException
50+
51+parseBaseUrl :: MonadThrow m => String -> m BaseUrl
52+parseBaseUrl s = case parseURI (removeTrailingSlash s) of
53+ -- This is a rather hacky implementation and should be replaced with something
54+ -- implemented in attoparsec (which is already a dependency anyhow (via aeson)).
55+ Just (URI "http:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) path "" "") ->
56+ return (BaseUrl Http host port path)
57+ Just (URI "http:" (Just (URIAuth "" host "")) path "" "") ->
58+ return (BaseUrl Http host 80 path)
59+ Just (URI "https:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) path "" "") ->
60+ return (BaseUrl Https host port path)
61+ Just (URI "https:" (Just (URIAuth "" host "")) path "" "") ->
62+ return (BaseUrl Https host 443 path)
63+ _ -> if "://" `isInfixOf` s
64+ then throwM (InvalidBaseUrlException $ "Invalid base URL: " ++ s)
65+ else parseBaseUrl ("http://" ++ s)
66+ where
67+ removeTrailingSlash str = case lastMay str of
68+ Just '/' -> init str
69+ _ -> str
servant-client-core/src/Servant/Client/Core/BasicAuth.hs → servant-client-core/src/Servant/Client/Core/Internal/BasicAuth.hsrenamed+7−11
@@ -3,18 +3,14 @@
3{-# LANGUAGE TypeSynonymInstances #-}
3{-# LANGUAGE TypeSynonymInstances #-}
4
4
5-- | Basic Authentication for clients
5-- | Basic Authentication for clients
6−module Servant.Client.Core.BasicAuth (
7− basicAuthReq,
8− ) where
9
6
7+module Servant.Client.Core.Internal.BasicAuth where
8+
10−import Data.ByteString.Base64
9+import Data.ByteString.Base64 (encode)
11− (encode)
12−import Data.Text.Encoding
10+import Data.Monoid ((<>))
13− (decodeUtf8)
11+import Data.Text.Encoding (decodeUtf8)
14−import Servant.API.BasicAuth
15− (BasicAuthData (BasicAuthData))
12+import Servant.API.BasicAuth (BasicAuthData (BasicAuthData))
16−import Servant.Client.Core.Request
13+import Servant.Client.Core.Internal.Request (Request, addHeader)
17− (Request, addHeader)
18
14
19-- | Authenticate a request using Basic Authentication
15-- | Authenticate a request using Basic Authentication
20basicAuthReq :: BasicAuthData -> Request -> Request
16basicAuthReq :: BasicAuthData -> Request -> Request
servant-client-core/src/Servant/Client/Core/Internal/Generic.hsnew file+156
@@ -0,0 +1,156 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE DefaultSignatures #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE TypeFamilies #-}
8+{-# LANGUAGE TypeOperators #-}
9+{-# LANGUAGE UndecidableInstances #-}
10+
11+#include "overlapping-compat.h"
12+
13+module Servant.Client.Core.Internal.Generic where
14+
15+import Generics.SOP (Code, Generic, I(..), NP(..), NS(Z), SOP(..), to)
16+import Servant.API ((:<|>)(..))
17+
18+-- | This class allows us to match client structure with client functions
19+-- produced with 'client' without explicit pattern-matching.
20+--
21+-- The client structure needs a 'Generics.SOP.Generic' instance.
22+--
23+-- Example:
24+--
25+-- > type API
26+-- > = "foo" :> Capture "x" Int :> Get '[JSON] Int
27+-- > :<|> "bar" :> QueryParam "a" Char :> QueryParam "b" String :> Post '[JSON] [Int]
28+-- > :<|> Capture "nested" Int :> NestedAPI
29+-- >
30+-- > type NestedAPI
31+-- > = Get '[JSON] String
32+-- > :<|> "baz" :> QueryParam "c" Char :> Post '[JSON] ()
33+-- >
34+-- > data APIClient = APIClient
35+-- > { getFoo :: Int -> ClientM Int
36+-- > , postBar :: Maybe Char -> Maybe String -> ClientM [Int]
37+-- > , mkNestedClient :: Int -> NestedClient
38+-- > } deriving GHC.Generic
39+-- >
40+-- > instance Generics.SOP.Generic APIClient
41+-- > instance (Client API ~ client) => ClientLike client APIClient
42+-- >
43+-- > data NestedClient = NestedClient
44+-- > { getString :: ClientM String
45+-- > , postBaz :: Maybe Char -> ClientM ()
46+-- > } deriving GHC.Generic
47+-- >
48+-- > instance Generics.SOP.Generic NestedClient
49+-- > instance (Client NestedAPI ~ client) => ClientLike client NestedClient
50+-- >
51+-- > mkAPIClient :: APIClient
52+-- > mkAPIClient = mkClient (client (Proxy :: Proxy API))
53+--
54+-- By default, left-nested alternatives are expanded:
55+--
56+-- > type API1
57+-- > = "foo" :> Capture "x" Int :> Get '[JSON] Int
58+-- > :<|> "bar" :> QueryParam "a" Char :> Post '[JSON] String
59+-- >
60+-- > type API2
61+-- > = "baz" :> QueryParam "c" Char :> Post '[JSON] ()
62+-- >
63+-- > type API = API1 :<|> API2
64+-- >
65+-- > data APIClient = APIClient
66+-- > { getFoo :: Int -> ClientM Int
67+-- > , postBar :: Maybe Char -> ClientM String
68+-- > , postBaz :: Maybe Char -> ClientM ()
69+-- > } deriving GHC.Generic
70+-- >
71+-- > instance Generics.SOP.Generic APIClient
72+-- > instance (Client API ~ client) => ClientLike client APIClient
73+-- >
74+-- > mkAPIClient :: APIClient
75+-- > mkAPIClient = mkClient (client (Proxy :: Proxy API))
76+--
77+-- If you want to define client for @API1@ as a separate data structure,
78+-- you can use 'genericMkClientP':
79+--
80+-- > data APIClient1 = APIClient1
81+-- > { getFoo :: Int -> ClientM Int
82+-- > , postBar :: Maybe Char -> ClientM String
83+-- > } deriving GHC.Generic
84+-- >
85+-- > instance Generics.SOP.Generic APIClient1
86+-- > instance (Client API1 ~ client) => ClientLike client APIClient1
87+-- >
88+-- > data APIClient = APIClient
89+-- > { mkAPIClient1 :: APIClient1
90+-- > , postBaz :: Maybe Char -> ClientM ()
91+-- > } deriving GHC.Generic
92+-- >
93+-- > instance Generics.SOP.Generic APIClient
94+-- > instance (Client API ~ client) => ClientLike client APIClient where
95+-- > mkClient = genericMkClientP
96+-- >
97+-- > mkAPIClient :: APIClient
98+-- > mkAPIClient = mkClient (client (Proxy :: Proxy API))
99+class ClientLike client custom where
100+ mkClient :: client -> custom
101+ default mkClient :: (Generic custom, Code custom ~ '[xs], GClientList client '[], GClientLikeL (ClientList client '[]) xs)
102+ => client -> custom
103+ mkClient = genericMkClientL
104+
105+instance ClientLike client custom
106+ => ClientLike (a -> client) (a -> custom) where
107+ mkClient c = mkClient . c
108+
109+-- | Match client structure with client functions, regarding left-nested API clients
110+-- as separate data structures.
111+class GClientLikeP client xs where
112+ gMkClientP :: client -> NP I xs
113+
114+instance (GClientLikeP b (y ': xs), ClientLike a x)
115+ => GClientLikeP (a :<|> b) (x ': y ': xs) where
116+ gMkClientP (a :<|> b) = I (mkClient a) :* gMkClientP b
117+
118+instance ClientLike a x => GClientLikeP a '[x] where
119+ gMkClientP a = I (mkClient a) :* Nil
120+
121+-- | Match client structure with client functions, expanding left-nested API clients
122+-- in the same structure.
123+class GClientLikeL (xs :: [*]) (ys :: [*]) where
124+ gMkClientL :: NP I xs -> NP I ys
125+
126+instance GClientLikeL '[] '[] where
127+ gMkClientL Nil = Nil
128+
129+instance (ClientLike x y, GClientLikeL xs ys) => GClientLikeL (x ': xs) (y ': ys) where
130+ gMkClientL (I x :* xs) = I (mkClient x) :* gMkClientL xs
131+
132+type family ClientList (client :: *) (acc :: [*]) :: [*] where
133+ ClientList (a :<|> b) acc = ClientList a (ClientList b acc)
134+ ClientList a acc = a ': acc
135+
136+class GClientList client (acc :: [*]) where
137+ gClientList :: client -> NP I acc -> NP I (ClientList client acc)
138+
139+instance (GClientList b acc, GClientList a (ClientList b acc))
140+ => GClientList (a :<|> b) acc where
141+ gClientList (a :<|> b) acc = gClientList a (gClientList b acc)
142+
143+instance OVERLAPPABLE_ (ClientList client acc ~ (client ': acc))
144+ => GClientList client acc where
145+ gClientList c acc = I c :* acc
146+
147+-- | Generate client structure from client type, expanding left-nested API (done by default).
148+genericMkClientL :: (Generic custom, Code custom ~ '[xs], GClientList client '[], GClientLikeL (ClientList client '[]) xs)
149+ => client -> custom
150+genericMkClientL = to . SOP . Z . gMkClientL . flip gClientList Nil
151+
152+-- | Generate client structure from client type, regarding left-nested API clients as separate data structures.
153+genericMkClientP :: (Generic custom, Code custom ~ '[xs], GClientLikeP client xs)
154+ => client -> custom
155+genericMkClientP = to . SOP . Z . gMkClientP
156+
servant-client-core/src/Servant/Client/Core/Internal/HasClient.hsnew file+601
@@ -0,0 +1,601 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE InstanceSigs #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE OverloadedStrings #-}
8+{-# LANGUAGE PolyKinds #-}
9+{-# LANGUAGE ScopedTypeVariables #-}
10+{-# LANGUAGE TypeFamilies #-}
11+{-# LANGUAGE TypeOperators #-}
12+{-# LANGUAGE UndecidableInstances #-}
13+
14+#include "overlapping-compat.h"
15+module Servant.Client.Core.Internal.HasClient where
16+
17+import Prelude ()
18+import Prelude.Compat
19+
20+import Control.Concurrent (newMVar, modifyMVar)
21+import Data.Foldable (toList)
22+import qualified Data.ByteString.Lazy as BL
23+import Data.List (foldl')
24+import Data.Monoid ((<>))
25+import Data.Proxy (Proxy (Proxy))
26+import Data.Sequence (fromList)
27+import Data.String (fromString)
28+import Data.Text (Text, pack)
29+import GHC.TypeLits (KnownSymbol, symbolVal)
30+import qualified Network.HTTP.Types as H
31+import Servant.API ((:<|>) ((:<|>)), (:>),
32+ AuthProtect, BasicAuth,
33+ BasicAuthData,
34+ BuildHeadersTo (..),
35+ BuildFromStream (..),
36+ ByteStringParser (..),
37+ Capture', CaptureAll,
38+ Description, EmptyAPI,
39+ FramingUnrender (..),
40+ Header', Headers (..),
41+ HttpVersion, IsSecure,
42+ MimeRender (mimeRender),
43+ MimeUnrender (mimeUnrender),
44+ NoContent (NoContent),
45+ QueryFlag, QueryParam',
46+ QueryParams, Raw,
47+ ReflectMethod (..),
48+ RemoteHost, ReqBody',
49+ ResultStream(..),
50+ SBoolI,
51+ Stream,
52+ Summary, ToHttpApiData,
53+ Vault, Verb,
54+ WithNamedContext,
55+ contentType,
56+ getHeadersHList,
57+ getResponse,
58+ toQueryParam,
59+ toUrlPiece)
60+import Servant.API.ContentTypes (contentTypes)
61+import Servant.API.Modifiers (FoldRequired,
62+ RequiredArgument,
63+ foldRequiredArgument)
64+
65+import Servant.Client.Core.Internal.Auth
66+import Servant.Client.Core.Internal.BasicAuth
67+import Servant.Client.Core.Internal.Request
68+import Servant.Client.Core.Internal.RunClient
69+
70+-- * Accessing APIs as a Client
71+
72+-- | 'clientIn' allows you to produce operations to query an API from a client
73+-- within a 'RunClient' monad.
74+--
75+-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books
76+-- > :<|> "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book -- POST /books
77+-- >
78+-- > myApi :: Proxy MyApi
79+-- > myApi = Proxy
80+-- >
81+-- > clientM :: Proxy ClientM
82+-- > clientM = Proxy
83+-- >
84+-- > getAllBooks :: ClientM [Book]
85+-- > postNewBook :: Book -> ClientM Book
86+-- > (getAllBooks :<|> postNewBook) = myApi `clientIn` clientM
87+clientIn :: HasClient m api => Proxy api -> Proxy m -> Client m api
88+clientIn p pm = clientWithRoute pm p defaultRequest
89+
90+
91+-- | This class lets us define how each API combinator influences the creation
92+-- of an HTTP request.
93+--
94+-- Unless you are writing a new backend for @servant-client-core@ or new
95+-- combinators that you want to support client-generation, you can ignore this
96+-- class.
97+class RunClient m => HasClient m api where
98+ type Client (m :: * -> *) (api :: *) :: *
99+ clientWithRoute :: Proxy m -> Proxy api -> Request -> Client m api
100+
101+
102+-- | A client querying function for @a ':<|>' b@ will actually hand you
103+-- one function for querying @a@ and another one for querying @b@,
104+-- stitching them together with ':<|>', which really is just like a pair.
105+--
106+-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books
107+-- > :<|> "books" :> ReqBody '[JSON] Book :> Post Book -- POST /books
108+-- >
109+-- > myApi :: Proxy MyApi
110+-- > myApi = Proxy
111+-- >
112+-- > getAllBooks :: ClientM [Book]
113+-- > postNewBook :: Book -> ClientM Book
114+-- > (getAllBooks :<|> postNewBook) = client myApi
115+instance (HasClient m a, HasClient m b) => HasClient m (a :<|> b) where
116+ type Client m (a :<|> b) = Client m a :<|> Client m b
117+ clientWithRoute pm Proxy req =
118+ clientWithRoute pm (Proxy :: Proxy a) req :<|>
119+ clientWithRoute pm (Proxy :: Proxy b) req
120+
121+-- | Singleton type representing a client for an empty API.
122+data EmptyClient = EmptyClient deriving (Eq, Show, Bounded, Enum)
123+
124+-- | The client for 'EmptyAPI' is simply 'EmptyClient'.
125+--
126+-- > type MyAPI = "books" :> Get '[JSON] [Book] -- GET /books
127+-- > :<|> "nothing" :> EmptyAPI
128+-- >
129+-- > myApi :: Proxy MyApi
130+-- > myApi = Proxy
131+-- >
132+-- > getAllBooks :: ClientM [Book]
133+-- > (getAllBooks :<|> EmptyClient) = client myApi
134+instance RunClient m => HasClient m EmptyAPI where
135+ type Client m EmptyAPI = EmptyClient
136+ clientWithRoute _pm Proxy _ = EmptyClient
137+
138+-- | If you use a 'Capture' in one of your endpoints in your API,
139+-- the corresponding querying function will automatically take
140+-- an additional argument of the type specified by your 'Capture'.
141+-- That function will take care of inserting a textual representation
142+-- of this value at the right place in the request path.
143+--
144+-- You can control how values for this type are turned into
145+-- text by specifying a 'ToHttpApiData' instance for your type.
146+--
147+-- Example:
148+--
149+-- > type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book
150+-- >
151+-- > myApi :: Proxy MyApi
152+-- > myApi = Proxy
153+-- >
154+-- > getBook :: Text -> ClientM Book
155+-- > getBook = client myApi
156+-- > -- then you can just use "getBook" to query that endpoint
157+instance (KnownSymbol capture, ToHttpApiData a, HasClient m api)
158+ => HasClient m (Capture' mods capture a :> api) where
159+
160+ type Client m (Capture' mods capture a :> api) =
161+ a -> Client m api
162+
163+ clientWithRoute pm Proxy req val =
164+ clientWithRoute pm (Proxy :: Proxy api)
165+ (appendToPath p req)
166+
167+ where p = (toUrlPiece val)
168+
169+-- | If you use a 'CaptureAll' in one of your endpoints in your API,
170+-- the corresponding querying function will automatically take an
171+-- additional argument of a list of the type specified by your
172+-- 'CaptureAll'. That function will take care of inserting a textual
173+-- representation of this value at the right place in the request
174+-- path.
175+--
176+-- You can control how these values are turned into text by specifying
177+-- a 'ToHttpApiData' instance of your type.
178+--
179+-- Example:
180+--
181+-- > type MyAPI = "src" :> CaptureAll Text -> Get '[JSON] SourceFile
182+-- >
183+-- > myApi :: Proxy
184+-- > myApi = Proxy
185+--
186+-- > getSourceFile :: [Text] -> ClientM SourceFile
187+-- > getSourceFile = client myApi
188+-- > -- then you can use "getSourceFile" to query that endpoint
189+instance (KnownSymbol capture, ToHttpApiData a, HasClient m sublayout)
190+ => HasClient m (CaptureAll capture a :> sublayout) where
191+
192+ type Client m (CaptureAll capture a :> sublayout) =
193+ [a] -> Client m sublayout
194+
195+ clientWithRoute pm Proxy req vals =
196+ clientWithRoute pm (Proxy :: Proxy sublayout)
197+ (foldl' (flip appendToPath) req ps)
198+
199+ where ps = map (toUrlPiece) vals
200+
201+instance OVERLAPPABLE_
202+ -- Note [Non-Empty Content Types]
203+ ( RunClient m, MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)
204+ ) => HasClient m (Verb method status cts' a) where
205+ type Client m (Verb method status cts' a) = m a
206+ clientWithRoute _pm Proxy req = do
207+ response <- runRequest req
208+ { requestAccept = fromList $ toList accept
209+ , requestMethod = method
210+ }
211+ response `decodedAs` (Proxy :: Proxy ct)
212+ where
213+ accept = contentTypes (Proxy :: Proxy ct)
214+ method = reflectMethod (Proxy :: Proxy method)
215+
216+instance OVERLAPPING_
217+ ( RunClient m, ReflectMethod method
218+ ) => HasClient m (Verb method status cts NoContent) where
219+ type Client m (Verb method status cts NoContent)
220+ = m NoContent
221+ clientWithRoute _pm Proxy req = do
222+ _response <- runRequest req { requestMethod = method }
223+ return NoContent
224+ where method = reflectMethod (Proxy :: Proxy method)
225+
226+instance OVERLAPPING_
227+ -- Note [Non-Empty Content Types]
228+ ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls
229+ , ReflectMethod method, cts' ~ (ct ': cts)
230+ ) => HasClient m (Verb method status cts' (Headers ls a)) where
231+ type Client m (Verb method status cts' (Headers ls a))
232+ = m (Headers ls a)
233+ clientWithRoute _pm Proxy req = do
234+ response <- runRequest req
235+ { requestMethod = method
236+ , requestAccept = fromList $ toList accept
237+ }
238+ case mimeUnrender (Proxy :: Proxy ct) $ responseBody response of
239+ Left err -> throwServantError $ DecodeFailure (pack err) response
240+ Right val -> return $ Headers
241+ { getResponse = val
242+ , getHeadersHList = buildHeadersTo . toList $ responseHeaders response
243+ }
244+ where method = reflectMethod (Proxy :: Proxy method)
245+ accept = contentTypes (Proxy :: Proxy ct)
246+
247+instance OVERLAPPING_
248+ ( RunClient m, BuildHeadersTo ls, ReflectMethod method
249+ ) => HasClient m (Verb method status cts (Headers ls NoContent)) where
250+ type Client m (Verb method status cts (Headers ls NoContent))
251+ = m (Headers ls NoContent)
252+ clientWithRoute _pm Proxy req = do
253+ let method = reflectMethod (Proxy :: Proxy method)
254+ response <- runRequest req { requestMethod = method }
255+ return $ Headers { getResponse = NoContent
256+ , getHeadersHList = buildHeadersTo . toList $ responseHeaders response
257+ }
258+
259+instance OVERLAPPABLE_
260+ ( RunClient m, MimeUnrender ct a, ReflectMethod method,
261+ FramingUnrender framing a, BuildFromStream a (f a)
262+ ) => HasClient m (Stream method framing ct (f a)) where
263+
264+ type Client m (Stream method framing ct (f a)) = m (f a)
265+
266+ clientWithRoute _pm Proxy req = do
267+ sresp <- streamingRequest req
268+ { requestAccept = fromList [contentType (Proxy :: Proxy ct)]
269+ , requestMethod = reflectMethod (Proxy :: Proxy method)
270+ }
271+ return . buildFromStream $ ResultStream $ \k ->
272+ runStreamingResponse sresp $ \gres -> do
273+ let reader = responseBody gres
274+ let unrender = unrenderFrames (Proxy :: Proxy framing) (Proxy :: Proxy a)
275+ loop bs = do
276+ res <- BL.fromStrict <$> reader
277+ if BL.null res
278+ then return $ parseEOF unrender res
279+ else let sofar = (bs <> res)
280+ in case parseIncremental unrender sofar of
281+ Just x -> return x
282+ Nothing -> loop sofar
283+ (frameParser, remainder) <- loop BL.empty
284+ state <- newMVar remainder
285+ let frameLoop bs = do
286+ res <- BL.fromStrict <$> reader
287+ let addIsEmptyInfo (a, r) = (r, (a, BL.null r && BL.null res))
288+ if BL.null res
289+ then if BL.null bs
290+ then return ("", (Right "", True))
291+ else return . addIsEmptyInfo $ parseEOF frameParser bs
292+ else let sofar = (bs <> res)
293+ in case parseIncremental frameParser sofar of
294+ Just x -> return $ addIsEmptyInfo x
295+ Nothing -> frameLoop sofar
296+
297+ go = processResult <$> modifyMVar state frameLoop
298+ processResult (Right bs,isDone) =
299+ if BL.null bs && isDone
300+ then Nothing
301+ else Just $ case mimeUnrender (Proxy :: Proxy ct) bs :: Either String a of
302+ Left err -> Left err
303+ Right x -> Right x
304+ processResult (Left err, _) = Just (Left err)
305+ k go
306+
307+
308+-- | If you use a 'Header' in one of your endpoints in your API,
309+-- the corresponding querying function will automatically take
310+-- an additional argument of the type specified by your 'Header',
311+-- wrapped in Maybe.
312+--
313+-- That function will take care of encoding this argument as Text
314+-- in the request headers.
315+--
316+-- All you need is for your type to have a 'ToHttpApiData' instance.
317+--
318+-- Example:
319+--
320+-- > newtype Referer = Referer { referrer :: Text }
321+-- > deriving (Eq, Show, Generic, ToHttpApiData)
322+-- >
323+-- > -- GET /view-my-referer
324+-- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get '[JSON] Referer
325+-- >
326+-- > myApi :: Proxy MyApi
327+-- > myApi = Proxy
328+-- >
329+-- > viewReferer :: Maybe Referer -> ClientM Book
330+-- > viewReferer = client myApi
331+-- > -- then you can just use "viewRefer" to query that endpoint
332+-- > -- specifying Nothing or e.g Just "http://haskell.org/" as arguments
333+instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequired mods))
334+ => HasClient m (Header' mods sym a :> api) where
335+
336+ type Client m (Header' mods sym a :> api) =
337+ RequiredArgument mods a -> Client m api
338+
339+ clientWithRoute pm Proxy req mval =
340+ clientWithRoute pm (Proxy :: Proxy api) $ foldRequiredArgument
341+ (Proxy :: Proxy mods) add (maybe req add) mval
342+ where
343+ hname = fromString $ symbolVal (Proxy :: Proxy sym)
344+
345+ add :: a -> Request
346+ add value = addHeader hname value req
347+
348+-- | Using a 'HttpVersion' combinator in your API doesn't affect the client
349+-- functions.
350+instance HasClient m api
351+ => HasClient m (HttpVersion :> api) where
352+
353+ type Client m (HttpVersion :> api) =
354+ Client m api
355+
356+ clientWithRoute pm Proxy =
357+ clientWithRoute pm (Proxy :: Proxy api)
358+
359+-- | Ignore @'Summary'@ in client functions.
360+instance HasClient m api => HasClient m (Summary desc :> api) where
361+ type Client m (Summary desc :> api) = Client m api
362+
363+ clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api)
364+
365+-- | Ignore @'Description'@ in client functions.
366+instance HasClient m api => HasClient m (Description desc :> api) where
367+ type Client m (Description desc :> api) = Client m api
368+
369+ clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api)
370+
371+-- | If you use a 'QueryParam' in one of your endpoints in your API,
372+-- the corresponding querying function will automatically take
373+-- an additional argument of the type specified by your 'QueryParam',
374+-- enclosed in Maybe.
375+--
376+-- If you give Nothing, nothing will be added to the query string.
377+--
378+-- If you give a non-'Nothing' value, this function will take care
379+-- of inserting a textual representation of this value in the query string.
380+--
381+-- You can control how values for your type are turned into
382+-- text by specifying a 'ToHttpApiData' instance for your type.
383+--
384+-- Example:
385+--
386+-- > type MyApi = "books" :> QueryParam "author" Text :> Get '[JSON] [Book]
387+-- >
388+-- > myApi :: Proxy MyApi
389+-- > myApi = Proxy
390+-- >
391+-- > getBooksBy :: Maybe Text -> ClientM [Book]
392+-- > getBooksBy = client myApi
393+-- > -- then you can just use "getBooksBy" to query that endpoint.
394+-- > -- 'getBooksBy Nothing' for all books
395+-- > -- 'getBooksBy (Just "Isaac Asimov")' to get all books by Isaac Asimov
396+instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequired mods))
397+ => HasClient m (QueryParam' mods sym a :> api) where
398+
399+ type Client m (QueryParam' mods sym a :> api) =
400+ RequiredArgument mods a -> Client m api
401+
402+ -- if mparam = Nothing, we don't add it to the query string
403+ clientWithRoute pm Proxy req mparam =
404+ clientWithRoute pm (Proxy :: Proxy api) $ foldRequiredArgument
405+ (Proxy :: Proxy mods) add (maybe req add) mparam
406+ where
407+ add :: a -> Request
408+ add param = appendToQueryString pname (Just $ toQueryParam param) req
409+
410+ pname :: Text
411+ pname = pack $ symbolVal (Proxy :: Proxy sym)
412+
413+-- | If you use a 'QueryParams' in one of your endpoints in your API,
414+-- the corresponding querying function will automatically take
415+-- an additional argument, a list of values of the type specified
416+-- by your 'QueryParams'.
417+--
418+-- If you give an empty list, nothing will be added to the query string.
419+--
420+-- Otherwise, this function will take care
421+-- of inserting a textual representation of your values in the query string,
422+-- under the same query string parameter name.
423+--
424+-- You can control how values for your type are turned into
425+-- text by specifying a 'ToHttpApiData' instance for your type.
426+--
427+-- Example:
428+--
429+-- > type MyApi = "books" :> QueryParams "authors" Text :> Get '[JSON] [Book]
430+-- >
431+-- > myApi :: Proxy MyApi
432+-- > myApi = Proxy
433+-- >
434+-- > getBooksBy :: [Text] -> ClientM [Book]
435+-- > getBooksBy = client myApi
436+-- > -- then you can just use "getBooksBy" to query that endpoint.
437+-- > -- 'getBooksBy []' for all books
438+-- > -- 'getBooksBy ["Isaac Asimov", "Robert A. Heinlein"]'
439+-- > -- to get all books by Asimov and Heinlein
440+instance (KnownSymbol sym, ToHttpApiData a, HasClient m api)
441+ => HasClient m (QueryParams sym a :> api) where
442+
443+ type Client m (QueryParams sym a :> api) =
444+ [a] -> Client m api
445+
446+ clientWithRoute pm Proxy req paramlist =
447+ clientWithRoute pm (Proxy :: Proxy api)
448+ (foldl' (\ req' -> maybe req' (flip (appendToQueryString pname) req' . Just))
449+ req
450+ paramlist'
451+ )
452+
453+ where pname = pack $ symbolVal (Proxy :: Proxy sym)
454+ paramlist' = map (Just . toQueryParam) paramlist
455+
456+-- | If you use a 'QueryFlag' in one of your endpoints in your API,
457+-- the corresponding querying function will automatically take
458+-- an additional 'Bool' argument.
459+--
460+-- If you give 'False', nothing will be added to the query string.
461+--
462+-- Otherwise, this function will insert a value-less query string
463+-- parameter under the name associated to your 'QueryFlag'.
464+--
465+-- Example:
466+--
467+-- > type MyApi = "books" :> QueryFlag "published" :> Get '[JSON] [Book]
468+-- >
469+-- > myApi :: Proxy MyApi
470+-- > myApi = Proxy
471+-- >
472+-- > getBooks :: Bool -> ClientM [Book]
473+-- > getBooks = client myApi
474+-- > -- then you can just use "getBooks" to query that endpoint.
475+-- > -- 'getBooksBy False' for all books
476+-- > -- 'getBooksBy True' to only get _already published_ books
477+instance (KnownSymbol sym, HasClient m api)
478+ => HasClient m (QueryFlag sym :> api) where
479+
480+ type Client m (QueryFlag sym :> api) =
481+ Bool -> Client m api
482+
483+ clientWithRoute pm Proxy req flag =
484+ clientWithRoute pm (Proxy :: Proxy api)
485+ (if flag
486+ then appendToQueryString paramname Nothing req
487+ else req
488+ )
489+
490+ where paramname = pack $ symbolVal (Proxy :: Proxy sym)
491+
492+
493+-- | Pick a 'Method' and specify where the server you want to query is. You get
494+-- back the full `Response`.
495+instance RunClient m => HasClient m Raw where
496+ type Client m Raw
497+ = H.Method -> m Response
498+
499+ clientWithRoute :: Proxy m -> Proxy Raw -> Request -> Client m Raw
500+ clientWithRoute _pm Proxy req httpMethod = do
501+ runRequest req { requestMethod = httpMethod }
502+
503+-- | If you use a 'ReqBody' in one of your endpoints in your API,
504+-- the corresponding querying function will automatically take
505+-- an additional argument of the type specified by your 'ReqBody'.
506+-- That function will take care of encoding this argument as JSON and
507+-- of using it as the request body.
508+--
509+-- All you need is for your type to have a 'ToJSON' instance.
510+--
511+-- Example:
512+--
513+-- > type MyApi = "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book
514+-- >
515+-- > myApi :: Proxy MyApi
516+-- > myApi = Proxy
517+-- >
518+-- > addBook :: Book -> ClientM Book
519+-- > addBook = client myApi
520+-- > -- then you can just use "addBook" to query that endpoint
521+instance (MimeRender ct a, HasClient m api)
522+ => HasClient m (ReqBody' mods (ct ': cts) a :> api) where
523+
524+ type Client m (ReqBody' mods (ct ': cts) a :> api) =
525+ a -> Client m api
526+
527+ clientWithRoute pm Proxy req body =
528+ clientWithRoute pm (Proxy :: Proxy api)
529+ (let ctProxy = Proxy :: Proxy ct
530+ in setRequestBodyLBS (mimeRender ctProxy body)
531+ -- We use first contentType from the Accept list
532+ (contentType ctProxy)
533+ req
534+ )
535+
536+-- | Make the querying function append @path@ to the request path.
537+instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where
538+ type Client m (path :> api) = Client m api
539+
540+ clientWithRoute pm Proxy req =
541+ clientWithRoute pm (Proxy :: Proxy api)
542+ (appendToPath p req)
543+
544+ where p = pack $ symbolVal (Proxy :: Proxy path)
545+
546+instance HasClient m api => HasClient m (Vault :> api) where
547+ type Client m (Vault :> api) = Client m api
548+
549+ clientWithRoute pm Proxy req =
550+ clientWithRoute pm (Proxy :: Proxy api) req
551+
552+instance HasClient m api => HasClient m (RemoteHost :> api) where
553+ type Client m (RemoteHost :> api) = Client m api
554+
555+ clientWithRoute pm Proxy req =
556+ clientWithRoute pm (Proxy :: Proxy api) req
557+
558+instance HasClient m api => HasClient m (IsSecure :> api) where
559+ type Client m (IsSecure :> api) = Client m api
560+
561+ clientWithRoute pm Proxy req =
562+ clientWithRoute pm (Proxy :: Proxy api) req
563+
564+instance HasClient m subapi =>
565+ HasClient m (WithNamedContext name context subapi) where
566+
567+ type Client m (WithNamedContext name context subapi) = Client m subapi
568+ clientWithRoute pm Proxy = clientWithRoute pm (Proxy :: Proxy subapi)
569+
570+instance ( HasClient m api
571+ ) => HasClient m (AuthProtect tag :> api) where
572+ type Client m (AuthProtect tag :> api)
573+ = AuthenticatedRequest (AuthProtect tag) -> Client m api
574+
575+ clientWithRoute pm Proxy req (AuthenticatedRequest (val,func)) =
576+ clientWithRoute pm (Proxy :: Proxy api) (func val req)
577+
578+-- * Basic Authentication
579+
580+instance HasClient m api => HasClient m (BasicAuth realm usr :> api) where
581+ type Client m (BasicAuth realm usr :> api) = BasicAuthData -> Client m api
582+
583+ clientWithRoute pm Proxy req val =
584+ clientWithRoute pm (Proxy :: Proxy api) (basicAuthReq val req)
585+
586+
587+{- Note [Non-Empty Content Types]
588+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
589+Rather than have
590+
591+ instance (..., cts' ~ (ct ': cts)) => ... cts' ...
592+
593+It may seem to make more sense to have:
594+
595+ instance (...) => ... (ct ': cts) ...
596+
597+But this means that if another instance exists that does *not* require
598+non-empty lists, but is otherwise more specific, no instance will be overall
599+more specific. This in turn generally means adding yet another instance (one
600+for empty and one for non-empty lists).
601+-}
servant-client-core/src/Servant/Client/Core/Internal/Request.hsnew file+123
@@ -0,0 +1,123 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DeriveDataTypeable #-}
3+{-# LANGUAGE DeriveFunctor #-}
4+{-# LANGUAGE DeriveFoldable #-}
5+{-# LANGUAGE DeriveTraversable #-}
6+{-# LANGUAGE DeriveGeneric #-}
7+{-# LANGUAGE MultiParamTypeClasses #-}
8+{-# LANGUAGE RankNTypes #-}
9+{-# LANGUAGE OverloadedStrings #-}
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 (Exception)
19+import qualified Data.ByteString.Builder as Builder
20+import qualified Data.ByteString as BS
21+import qualified Data.ByteString.Lazy as LBS
22+import Data.Semigroup ((<>))
23+import qualified Data.Sequence as Seq
24+import Data.Text (Text)
25+import Data.Text.Encoding (encodeUtf8)
26+import Data.Typeable (Typeable)
27+import GHC.Generics (Generic)
28+import Network.HTTP.Media (MediaType)
29+import Network.HTTP.Types (Header, HeaderName, HttpVersion,
30+ Method, QueryItem, Status, http11,
31+ methodGet)
32+import Web.HttpApiData (ToHttpApiData, toEncodedUrlPiece,
33+ toHeader)
34+
35+-- | A type representing possible errors in a request
36+--
37+-- Note that this type substantially changed in 0.12.
38+data ServantError =
39+ -- | The server returned an error response
40+ FailureResponse Response
41+ -- | The body could not be decoded at the expected type
42+ | DecodeFailure Text Response
43+ -- | The content-type of the response is not supported
44+ | UnsupportedContentType MediaType Response
45+ -- | The content-type header is invalid
46+ | InvalidContentTypeHeader Response
47+ -- | There was a connection error, and no response was received
48+ | ConnectionError Text
49+ deriving (Eq, Show, Generic, Typeable)
50+
51+instance Exception ServantError
52+
53+data RequestF a = Request
54+ { requestPath :: a
55+ , requestQueryString :: Seq.Seq QueryItem
56+ , requestBody :: Maybe (RequestBody, MediaType)
57+ , requestAccept :: Seq.Seq MediaType
58+ , requestHeaders :: Seq.Seq Header
59+ , requestHttpVersion :: HttpVersion
60+ , requestMethod :: Method
61+ } deriving (Eq, Show, Functor, Generic, Typeable)
62+
63+type Request = RequestF Builder.Builder
64+
65+-- | The request body. Currently only lazy ByteStrings are supported.
66+newtype RequestBody = RequestBodyLBS LBS.ByteString
67+ deriving (Eq, Ord, Read, Show, Typeable)
68+
69+data GenResponse a = Response
70+ { responseStatusCode :: Status
71+ , responseHeaders :: Seq.Seq Header
72+ , responseHttpVersion :: HttpVersion
73+ , responseBody :: a
74+ } deriving (Eq, Show, Generic, Typeable, Functor, Foldable, Traversable)
75+
76+type Response = GenResponse LBS.ByteString
77+newtype StreamingResponse = StreamingResponse { runStreamingResponse :: forall a. (GenResponse (IO BS.ByteString) -> IO a) -> IO a }
78+
79+-- A GET request to the top-level path
80+defaultRequest :: Request
81+defaultRequest = Request
82+ { requestPath = ""
83+ , requestQueryString = Seq.empty
84+ , requestBody = Nothing
85+ , requestAccept = Seq.empty
86+ , requestHeaders = Seq.empty
87+ , requestHttpVersion = http11
88+ , requestMethod = methodGet
89+ }
90+
91+appendToPath :: Text -> Request -> Request
92+appendToPath p req
93+ = req { requestPath = requestPath req <> "/" <> toEncodedUrlPiece p }
94+
95+appendToQueryString :: Text -- ^ param name
96+ -> Maybe Text -- ^ param value
97+ -> Request
98+ -> Request
99+appendToQueryString pname pvalue req
100+ = req { requestQueryString = requestQueryString req
101+ Seq.|> (encodeUtf8 pname, encodeUtf8 <$> pvalue)}
102+
103+addHeader :: ToHttpApiData a => HeaderName -> a -> Request -> Request
104+addHeader name val req
105+ = req { requestHeaders = requestHeaders req Seq.|> (name, toHeader val)}
106+
107+-- | Set body and media type of the request being constructed.
108+--
109+-- The body is set to the given bytestring using the 'RequestBodyLBS'
110+-- constructor.
111+--
112+-- @since 0.12
113+--
114+setRequestBodyLBS :: LBS.ByteString -> MediaType -> Request -> Request
115+setRequestBodyLBS b t req
116+ = req { requestBody = Just (RequestBodyLBS b, t) }
117+
118+-- | Set body and media type of the request being constructed.
119+--
120+-- @since 0.12
121+--
122+setRequestBody :: RequestBody -> MediaType -> Request -> Request
123+setRequestBody b t req = req { requestBody = Just (b, t) }
servant-client-core/src/Servant/Client/Core/Internal/RunClient.hsnew file+50
@@ -0,0 +1,50 @@
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 (unless)
13+import Data.Foldable (toList)
14+import Data.Proxy (Proxy)
15+import qualified Data.Text as T
16+import Network.HTTP.Media (MediaType, matches,
17+ parseAccept, (//))
18+import Servant.API (MimeUnrender,
19+ contentTypes,
20+ mimeUnrender)
21+import Servant.Client.Core.Internal.Request (Request, Response, GenResponse (..),
22+ StreamingResponse (..),
23+ ServantError (..))
24+
25+class (Monad m) => RunClient m where
26+ -- | How to make a request.
27+ runRequest :: Request -> m Response
28+ streamingRequest :: Request -> m StreamingResponse
29+ throwServantError :: ServantError -> m a
30+ catchServantError :: m a -> (ServantError -> m a) -> m a
31+
32+checkContentTypeHeader :: RunClient m => Response -> m MediaType
33+checkContentTypeHeader response =
34+ case lookup "Content-Type" $ toList $ responseHeaders response of
35+ Nothing -> return $ "application"//"octet-stream"
36+ Just t -> case parseAccept t of
37+ Nothing -> throwServantError $ InvalidContentTypeHeader response
38+ Just t' -> return t'
39+
40+decodedAs :: forall ct a m. (MimeUnrender ct a, RunClient m)
41+ => Response -> Proxy ct -> m a
42+decodedAs response contentType = do
43+ responseContentType <- checkContentTypeHeader response
44+ unless (any (matches responseContentType) accept) $
45+ throwServantError $ UnsupportedContentType responseContentType response
46+ case mimeUnrender contentType $ responseBody response of
47+ Left err -> throwServantError $ DecodeFailure (T.pack err) response
48+ Right val -> return val
49+ where
50+ accept = toList $ contentTypes contentType
servant-client-core/src/Servant/Client/Core/Reexport.hs+10−13
@@ -5,19 +5,17 @@ module Servant.Client.Core.Reexport
5 (
5 (
6 -- * HasClient
6 -- * HasClient
7 HasClient(..)
7 HasClient(..)
8− , foldMapUnion
9− , matchUnion
10− , AsClientT
11− , (//)
12− , (/:)
13
8
14 -- * Response (for @Raw@)
9 -- * Response (for @Raw@)
15 , Response
10 , Response
16 , StreamingResponse
11 , StreamingResponse
17− , ResponseF(..)
12+ , GenResponse(..)
18
13
19− -- * Data types
14+ -- * Generic Client
20− , ClientError(..)
15+ , ClientLike(..)
16+ , genericMkClientL
17+ , genericMkClientP
18+ , ServantError(..)
21 , EmptyClient(..)
19 , EmptyClient(..)
22
20
23 -- * BaseUrl
21 -- * BaseUrl
@@ -26,11 +24,10 @@ module Servant.Client.Core.Reexport
26 , showBaseUrl
24 , showBaseUrl
27 , parseBaseUrl
25 , parseBaseUrl
28 , InvalidBaseUrlException
26 , InvalidBaseUrlException
29−
30 ) where
27 ) where
31
28
32
29
33−import Servant.Client.Core.BaseUrl
30+import Servant.Client.Core.Internal.BaseUrl
34−import Servant.Client.Core.HasClient
31+import Servant.Client.Core.Internal.HasClient
35−import Servant.Client.Core.Response
32+import Servant.Client.Core.Internal.Generic
36−import Servant.Client.Core.ClientError
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.hsdeleted−18
@@ -1,18 +0,0 @@
1−{-# LANGUAGE FlexibleContexts #-}
2−{-# LANGUAGE GADTs #-}
3−{-# LANGUAGE ScopedTypeVariables #-}
4−module Servant.Client.Free (
5− client,
6− ClientF (..),
7− module Servant.Client.Core.Reexport,
8− ) where
9−
10−import Control.Monad.Free
11−import Data.Proxy
12− (Proxy (..))
13−import Servant.Client.Core
14−import Servant.Client.Core.Reexport
15−import Servant.Client.Core.RunClient
16−
17−client :: HasClient (Free ClientF) api => Proxy api -> Client (Free ClientF) api
18−client api = api `clientIn` (Proxy :: Proxy (Free ClientF))
servant-client-core/src/Servant/Client/Generic.hsdeleted−48
@@ -1,48 +0,0 @@
1−{-# OPTIONS_GHC -fno-warn-orphans #-}
2−{-# LANGUAGE FlexibleContexts #-}
3−{-# LANGUAGE KindSignatures #-}
4−{-# LANGUAGE RankNTypes #-}
5−{-# LANGUAGE ScopedTypeVariables #-}
6−{-# LANGUAGE TypeFamilies #-}
7−
8−module Servant.Client.Generic (
9− AsClientT,
10− genericClient,
11− genericClientHoist,
12− ) where
13−
14−import Data.Proxy
15− (Proxy (..))
16−
17−import Servant.API.Generic
18−import Servant.Client.Core
19−import Servant.Client.Core.HasClient (AsClientT)
20−
21−-- | Generate a record of client functions.
22−genericClient
23− :: forall routes m.
24− ( HasClient m (ToServantApi routes)
25− , GenericServant routes (AsClientT m)
26− , Client m (ToServantApi routes) ~ ToServant routes (AsClientT m)
27− )
28− => routes (AsClientT m)
29−genericClient
30− = fromServant
31− $ clientIn (Proxy :: Proxy (ToServantApi routes)) (Proxy :: Proxy m)
32−
33−-- | 'genericClient' but with 'hoistClientMonad' in between.
34−genericClientHoist
35− :: forall routes m n.
36− ( HasClient m (ToServantApi routes)
37− , GenericServant routes (AsClientT n)
38− , Client n (ToServantApi routes) ~ ToServant routes (AsClientT n)
39− )
40− => (forall x. m x -> n x) -- ^ natural transformation
41− -> routes (AsClientT n)
42−genericClientHoist nt
43− = fromServant
44− $ hoistClientMonad m api nt
45− $ clientIn api m
46− where
47− m = Proxy :: Proxy m
48− api = Proxy :: Proxy (ToServantApi routes)
servant-client-core/test/Servant/Client/Core/Internal/BaseUrlSpec.hs+1−1
@@ -8,7 +8,7 @@ import Prelude.Compat
8import Test.Hspec
8import Test.Hspec
9import Test.QuickCheck
9import Test.QuickCheck
10
10
11−import Servant.Client.Core.BaseUrl
11+import Servant.Client.Core.Internal.BaseUrl
12
12
13spec :: Spec
13spec :: Spec
14spec = do
14spec = 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
2
2
3All rights reserved.
3All rights reserved.
4
4
servant-client-ghcjs/README.md+2−2
@@ -4,12 +4,12 @@ Type safe querying of servant APIs from the browser.
4
4
5`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.
5`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.
6
6
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.
8
8
9## Using servant-client-ghcjs
9## Using servant-client-ghcjs
10`servant-client-ghcjs` should feel familiar if you've worked with `servant-client`.
10`servant-client-ghcjs` should feel familiar if you've worked with `servant-client`.
11
11
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)
13
13
14```haskell
14```haskell
15{-# LANGUAGE DataKinds #-}
15{-# 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
1+name: servant-client-ghcjs
3−version: 0.16
2+version: 0.13
4−synopsis:
5− Automatic derivation of querying functions for servant webservices for GHCJS
3+synopsis: automatical derivation of querying functions for servant webservices for ghcjs
6−
7−category: Servant, Web
8description:
4description:
9 This library lets you automatically derive Haskell functions that
5 This library lets you automatically derive Haskell functions that
10 let you query each endpoint of a <http://hackage.haskell.org/package/servant servant> webservice.
6 let you query each endpoint of a <http://hackage.haskell.org/package/servant servant> webservice.
11 .
7 .
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>.
13 .
9 .
14 <https://github.com/haskell-servant/servant/blob/master/servant-client/CHANGELOG.md CHANGELOG>
10 <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
11+license: BSD3
19−license-file: LICENSE
12+license-file: LICENSE
20−author: Servant Contributors
13+author: Servant Contributors
21−maintainer: haskell-servant-maintainers@googlegroups.com
14+maintainer: haskell-servant-maintainers@googlegroups.com
22−copyright:
23− 2014-2016 Zalora South East Asia Pte Ltd, 2016-2018 Servant Contributors
15+copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2017 Servant Contributors
24−
16+category: Servant, Web
25−build-type: Simple
17+build-type: Simple
18+cabal-version: >=1.10
26−tested-with: ghc >=7.8
19+tested-with: GHC >= 7.8
20+homepage: http://haskell-servant.readthedocs.org/
21+Bug-reports: http://github.com/haskell-servant/servant/issues
27extra-source-files:
22extra-source-files:
28 CHANGELOG.md
23 CHANGELOG.md
29 README.md
24 README.md
30−
31source-repository head
25source-repository head
32− type: git
26+ type: git
33 location: http://github.com/haskell-servant/servant.git
27 location: http://github.com/haskell-servant/servant.git
34
28
35library
29library
36 exposed-modules:
30 exposed-modules:
37 Servant.Client.Ghcjs
31 Servant.Client.Ghcjs
38 Servant.Client.Internal.XhrClient
32 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
58 build-depends:
33 build-depends:
59− servant >=0.16 && <0.20
34+ base >= 4.7 && < 4.11
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.9
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
60− , servant-client-core >=0.16 && <0.20
46+ , servant-client-core == 0.13.*
61−
47+ , string-conversions >= 0.3 && < 0.5
48+ , transformers >= 0.3 && < 0.6
49+ , transformers-base >= 0.4.4 && < 0.5
62− hs-source-dirs: src
50+ hs-source-dirs: src
63 default-language: Haskell2010
51 default-language: Haskell2010
52+ ghc-options: -Wall
53+ if impl(ghc >= 8.0)
64− ghc-options: -Wall -Wno-redundant-constraints
54+ ghc-options: -Wno-redundant-constraints
servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs+44−114
@@ -15,95 +15,57 @@
15module Servant.Client.Internal.XhrClient where
15module Servant.Client.Internal.XhrClient where
16
16
17import Control.Arrow
17import Control.Arrow
18+import Data.ByteString.Builder (toLazyByteString)
18import Control.Concurrent
19import Control.Concurrent
19import Control.Exception
20import Control.Exception
20import Control.Monad
21import Control.Monad
21−import Control.Monad.Base
22+import Control.Monad.Base (MonadBase (..))
22− (MonadBase (..))
23−import Control.Monad.Catch
23+import Control.Monad.Catch (MonadCatch, MonadThrow)
24− (MonadCatch, MonadThrow)
25−import Control.Monad.Error.Class
24+import Control.Monad.Error.Class (MonadError (..))
26− (MonadError (..))
27import Control.Monad.Reader
25import Control.Monad.Reader
28−import Control.Monad.Trans.Control
26+import Control.Monad.Trans.Control (MonadBaseControl (..))
29− (MonadBaseControl (..))
30import Control.Monad.Trans.Except
27import 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
28+import qualified Data.ByteString.Char8 as BS
36−import qualified Data.ByteString.Lazy as BL
37import Data.CaseInsensitive
29import Data.CaseInsensitive
38import Data.Char
30import Data.Char
39−import Data.Foldable
31+import Data.Foldable (toList)
40− (toList)
41−import Data.Functor.Alt
32+import Data.Functor.Alt (Alt (..))
42− (Alt (..))
43−import Data.Proxy
33+import Data.Proxy (Proxy (..))
44− (Proxy (..))
45−import qualified Data.Sequence as Seq
34+import qualified Data.Sequence as Seq
46import Data.String.Conversions
35import Data.String.Conversions
47−import Data.Typeable
48− (Typeable)
49import Foreign.StablePtr
36import Foreign.StablePtr
50import GHC.Generics
37import GHC.Generics
51−import qualified GHCJS.Buffer as Buffer
52import GHCJS.Foreign.Callback
38import GHCJS.Foreign.Callback
53import GHCJS.Prim
39import GHCJS.Prim
54import GHCJS.Types
40import GHCJS.Types
55−import JavaScript.TypedArray.ArrayBuffer
56− (ArrayBuffer)
57import JavaScript.Web.Location
41import JavaScript.Web.Location
58−import Network.HTTP.Media
59− (renderHeader)
60import Network.HTTP.Types
42import Network.HTTP.Types
43+import Network.HTTP.Media (renderHeader)
61import Servant.Client.Core
44import Servant.Client.Core
62−import qualified Servant.Types.SourceT as S
63
45
64newtype JSXMLHttpRequest = JSXMLHttpRequest JSVal
46newtype JSXMLHttpRequest = JSXMLHttpRequest JSVal
65
47
66newtype JSXMLHttpRequestClass = JSXMLHttpRequestClass JSVal
48newtype JSXMLHttpRequestClass = JSXMLHttpRequestClass JSVal
67
49
68−-- | The environment in which a request is run.
69newtype ClientEnv
50newtype ClientEnv
70 = ClientEnv
51 = ClientEnv
71 { baseUrl :: BaseUrl }
52 { baseUrl :: BaseUrl }
72 deriving (Eq, Show)
53 deriving (Eq, Show)
73
54
74−-- | Generates a set of client functions for an API.
75−--
76−-- Example:
77−--
78−-- > type API = Capture "no" Int :> Get '[JSON] Int
79−-- > :<|> Get '[JSON] [Bool]
80−-- >
81−-- > api :: Proxy API
82−-- > api = Proxy
83−-- >
84−-- > getInt :: Int -> ClientM Int
85−-- > getBools :: ClientM [Bool]
86−-- > getInt :<|> getBools = client api
87−--
88−-- NOTE: Does not support constant space streaming of the request body!
89client :: HasClient ClientM api => Proxy api -> Client ClientM api
55client :: HasClient ClientM api => Proxy api -> Client ClientM api
90client api = api `clientIn` (Proxy :: Proxy ClientM)
56client api = api `clientIn` (Proxy :: Proxy ClientM)
91
57
92−-- | @ClientM@ is the monad in which client functions run. Contains the
93−-- 'BaseUrl' used for requests in the reader environment.
94−--
95−-- NOTE: Does not support constant space streaming of the request body!
96newtype ClientM a = ClientM
58newtype ClientM a = ClientM
97− { runClientM' :: ReaderT ClientEnv (ExceptT ClientError IO) a }
59+ { runClientM' :: ReaderT ClientEnv (ExceptT ServantError IO) a }
98 deriving ( Functor, Applicative, Monad, MonadIO, Generic
60 deriving ( Functor, Applicative, Monad, MonadIO, Generic
99− , MonadReader ClientEnv, MonadError ClientError, MonadThrow
61+ , MonadReader ClientEnv, MonadError ServantError, MonadThrow
100 , MonadCatch)
62 , MonadCatch)
101
63
102instance MonadBase IO ClientM where
64instance MonadBase IO ClientM where
103 liftBase = ClientM . liftBase
65 liftBase = ClientM . liftBase
104
66
105instance MonadBaseControl IO ClientM where
67instance MonadBaseControl IO ClientM where
106− type StM ClientM a = Either ClientError a
68+ type StM ClientM a = Either ServantError a
107
69
108 liftBaseWith f = ClientM (liftBaseWith (\g -> f (g . runClientM')))
70 liftBaseWith f = ClientM (liftBaseWith (\g -> f (g . runClientM')))
109
71
@@ -113,20 +75,18 @@ instance MonadBaseControl IO ClientM where
113instance Alt ClientM where
75instance Alt ClientM where
114 a <!> b = a `catchError` const b
76 a <!> b = a `catchError` const b
115
77
116−data StreamingNotSupportedException = StreamingNotSupportedException
117− deriving ( Typeable, Show )
118−
119−instance Exception StreamingNotSupportedException where
120− displayException _ = "streamingRequest: streaming is not supported!"
121−
122instance RunClient ClientM where
78instance RunClient ClientM where
123− runRequestAcceptStatus = performRequest
79+ runRequest = performRequest
124− throwClientError = throwError
80+ throwServantError = throwError
81+ catchServantError = catchError
125
82
83+instance ClientLike (ClientM a) (ClientM a) where
84+ mkClient = id
85+
126−runClientMOrigin :: ClientM a -> ClientEnv -> IO (Either ClientError a)
86+runClientMOrigin :: ClientM a -> ClientEnv -> IO (Either ServantError a)
127runClientMOrigin cm env = runExceptT $ flip runReaderT env $ runClientM' cm
87runClientMOrigin cm env = runExceptT $ flip runReaderT env $ runClientM' cm
128
88
129−runClientM :: ClientM a -> IO (Either ClientError a)
89+runClientM :: ClientM a -> IO (Either ServantError a)
130runClientM m = do
90runClientM m = do
131 curLoc <- getWindowLocation
91 curLoc <- getWindowLocation
132
92
@@ -152,20 +112,16 @@ runClientM m = do
152
112
153 runClientMOrigin m (ClientEnv (BaseUrl protocol hostname port ""))
113 runClientMOrigin m (ClientEnv (BaseUrl protocol hostname port ""))
154
114
155−performRequest :: Maybe [Status] -> Request -> ClientM Response
115+performRequest :: Request -> ClientM Response
156−performRequest acceptStatus req = do
116+performRequest req = do
157 xhr <- liftIO initXhr
117 xhr <- liftIO initXhr
158 burl <- asks baseUrl
118 burl <- asks baseUrl
159 liftIO $ performXhr xhr burl req
119 liftIO $ performXhr xhr burl req
160 resp <- toResponse xhr
120 resp <- toResponse xhr
161
121
162− let status = responseStatusCode resp
122+ let status = statusCode (responseStatusCode resp)
163− goodStatus = case acceptStatus of
123+ unless (status >= 200 && status < 300) $
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
124+ throwError $ FailureResponse resp
169
125
170 pure resp
126 pure resp
171
127
@@ -197,9 +153,7 @@ performXhr xhr burl request = do
197
153
198 openXhr xhr (cs $ requestMethod request) (toUrl burl request) True
154 openXhr xhr (cs $ requestMethod request) (toUrl burl request) True
199 setHeaders xhr request
155 setHeaders xhr request
200− js_setResponseType xhr "arraybuffer"
201− body <- toBody request
156+ sendXhr xhr (toBody request)
202− sendXhr xhr body
203 takeMVar waiter
157 takeMVar waiter
204
158
205 freeStablePtr s
159 freeStablePtr s
@@ -232,9 +186,6 @@ openXhr xhr method url =
232foreign import javascript unsafe "$1.open($2, $3, $4)"
186foreign import javascript unsafe "$1.open($2, $3, $4)"
233 js_openXhr :: JSXMLHttpRequest -> JSVal -> JSVal -> Bool -> IO ()
187 js_openXhr :: JSXMLHttpRequest -> JSVal -> JSVal -> Bool -> IO ()
234
188
235−foreign import javascript unsafe "$1.responseType = $2;"
236− js_setResponseType :: JSXMLHttpRequest -> JSString -> IO ()
237−
238toUrl :: BaseUrl -> Request -> String
189toUrl :: BaseUrl -> Request -> String
239toUrl burl request =
190toUrl burl request =
240 let pathS = cs $ toLazyByteString $ requestPath request
191 let pathS = cs $ toLazyByteString $ requestPath request
@@ -265,55 +216,39 @@ setHeaders xhr request = do
265foreign import javascript unsafe "$1.setRequestHeader($2, $3)"
216foreign import javascript unsafe "$1.setRequestHeader($2, $3)"
266 js_setRequestHeader :: JSXMLHttpRequest -> JSVal -> JSVal -> IO ()
217 js_setRequestHeader :: JSXMLHttpRequest -> JSVal -> JSVal -> IO ()
267
218
268−sendXhr :: JSXMLHttpRequest -> Maybe ArrayBuffer -> IO ()
219+sendXhr :: JSXMLHttpRequest -> Maybe String -> IO ()
269sendXhr xhr Nothing = js_sendXhr xhr
220sendXhr xhr Nothing = js_sendXhr xhr
270sendXhr xhr (Just body) =
221sendXhr xhr (Just body) =
271− js_sendXhrWithBody xhr body
222+ js_sendXhrWithBody xhr (toJSString body)
272
223
273foreign import javascript unsafe "$1.send()"
224foreign import javascript unsafe "$1.send()"
274 js_sendXhr :: JSXMLHttpRequest -> IO ()
225 js_sendXhr :: JSXMLHttpRequest -> IO ()
275
226
276foreign import javascript unsafe "$1.send($2)"
227foreign import javascript unsafe "$1.send($2)"
277− js_sendXhrWithBody :: JSXMLHttpRequest -> ArrayBuffer -> IO ()
228+ js_sendXhrWithBody :: JSXMLHttpRequest -> JSVal -> IO ()
278
229
279−toBody :: Request -> IO (Maybe ArrayBuffer)
230+toBody :: Request -> Maybe String
280toBody request = case requestBody request of
231toBody request = case requestBody request of
281− Nothing -> return Nothing
232+ Nothing -> Nothing
282− Just (a, _) -> Just <$> go a
233+ Just (RequestBodyLBS "", _) -> Nothing
283−
284− where
285− go :: RequestBody -> IO ArrayBuffer
286− go x = case x of
287− RequestBodyLBS x -> return $ mBody $ BL.toStrict x
234+ Just (RequestBodyLBS x, _) -> Just $ cs 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
292−
293− mBody :: BS.ByteString -> ArrayBuffer
294− mBody bs = js_bufferSlice offset len $ Buffer.getArrayBuffer buffer
295− where
296− (buffer, offset, len) = Buffer.fromByteString bs
297−
298−foreign import javascript unsafe "$3.slice($1, $1 + $2)"
299− js_bufferSlice :: Int -> Int -> ArrayBuffer -> ArrayBuffer
300
235
301-- * inspecting the xhr response
236-- * inspecting the xhr response
302
237
303-- This function is only supposed to handle 'ConnectionError's. Other
238-- This function is only supposed to handle 'ConnectionError's. Other
304−-- 'ClientError's are created in Servant.Client.Req.
239+-- 'ServantError's are created in Servant.Client.Req.
305toResponse :: JSXMLHttpRequest -> ClientM Response
240toResponse :: JSXMLHttpRequest -> ClientM Response
306toResponse xhr = do
241toResponse xhr = do
307 status <- liftIO $ getStatus xhr
242 status <- liftIO $ getStatus xhr
308 case status of
243 case status of
309− 0 -> throwError $ ConnectionError (SomeException (userError "connection error"))
244+ 0 -> throwError $ ConnectionError "connection error"
310 _ -> liftIO $ do
245 _ -> liftIO $ do
311 statusText <- cs <$> getStatusText xhr
246 statusText <- cs <$> getStatusText xhr
312 headers <- parseHeaders <$> getAllResponseHeaders xhr
247 headers <- parseHeaders <$> getAllResponseHeaders xhr
313− response <- getResponse xhr
248+ responseText <- cs <$> getResponseText xhr
314 pure Response
249 pure Response
315 { responseStatusCode = mkStatus status statusText
250 { responseStatusCode = mkStatus status statusText
316− , responseBody = response
251+ , responseBody = responseText
317 , responseHeaders = Seq.fromList headers
252 , responseHeaders = Seq.fromList headers
318 , responseHttpVersion = http11 -- this is made up
253 , responseHttpVersion = http11 -- this is made up
319 }
254 }
@@ -332,19 +267,14 @@ getAllResponseHeaders xhr =
332foreign import javascript unsafe "$1.getAllResponseHeaders()"
267foreign import javascript unsafe "$1.getAllResponseHeaders()"
333 js_getAllResponseHeaders :: JSXMLHttpRequest -> IO JSVal
268 js_getAllResponseHeaders :: JSXMLHttpRequest -> IO JSVal
334
269
335−getResponse :: JSXMLHttpRequest -> IO BL.ByteString
270+getResponseText :: JSXMLHttpRequest -> IO String
336−getResponse xhr =
271+getResponseText xhr = fromJSString <$> js_responseText xhr
337− BL.fromStrict
338− . Buffer.toByteString 0 Nothing
339− . Buffer.createFromArrayBuffer
340− <$> js_response xhr
341−
342−foreign import javascript unsafe "$1.response"
272+foreign import javascript unsafe "$1.responseText"
343− js_response :: JSXMLHttpRequest -> IO ArrayBuffer
273+ js_responseText :: JSXMLHttpRequest -> IO JSVal
344
274
345parseHeaders :: String -> ResponseHeaders
275parseHeaders :: String -> ResponseHeaders
346parseHeaders s =
276parseHeaders s =
347− first mk . first strip . second strip . parseHeader <$>
277+ (first mk . first strip . second strip . parseHeader) <$>
348 splitOn "\r\n" (cs s)
278 splitOn "\r\n" (cs s)
349 where
279 where
350 parseHeader :: BS.ByteString -> (BS.ByteString, BS.ByteString)
280 parseHeader :: BS.ByteString -> (BS.ByteString, BS.ByteString)
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−283
@@ -1,289 +1,6 @@
1[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-client/CHANGELOG.md)
1[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-client/CHANGELOG.md)
2[Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)
2[Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)
3
3
4−Package versions follow the [Package Versioning Policy](https://pvp.haskell.org/): in A.B.C, bumps to either A or B represent major versions.
5−
6−0.19
7−----
8−
9−### Significant changes
10−
11−- Drop support for GHC < 8.6.
12−- Support GHC 9.0 (GHC 9.2 should work as well, but isn't fully tested yet).
13−- Support Aeson 2 ([#1475](https://github.com/haskell-servant/servant/pull/1475)),
14− which fixes a [DOS vulnerability](https://github.com/haskell/aeson/issues/864)
15− related to hash collisions.
16−- Add `NamedRoutes` combinator, making support for records first-class in Servant
17− ([#1388](https://github.com/haskell-servant/servant/pull/1388)).
18−- Add custom type errors for partially applied combinators
19− ([#1289](https://github.com/haskell-servant/servant/pull/1289),
20− [#1486](https://github.com/haskell-servant/servant/pull/1486)).
21−- *servant-client* / *servant-client-core* / *servant-http-streams*: Fix
22− erroneous behavior, where only 2XX status codes would be considered
23− successful, irrelevant of the status parameter specified by the verb
24− combinator. ([#1469](https://github.com/haskell-servant/servant/pull/1469))
25−- *servant-client* / *servant-client-core*: Fix `Show` instance for
26− `Servant.Client.Core.Request`.
27−- *servant-client* / *servant-client-core*: Allow passing arbitrary binary data
28− in Query parameters.
29− ([#1432](https://github.com/haskell-servant/servant/pull/1432)).
30−
31−### Other changes
32−
33−- Various version bumps.
34−
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−
240−0.14
241−----
242−
243−- `Stream` takes a status code argument
244−
245− ```diff
246− -Stream method framing ctype a
247− +Stream method status framing ctype a
248− ```
249−
250− ([#966](https://github.com/haskell-servant/servant/pull/966)
251− [#972](https://github.com/haskell-servant/servant/pull/972))
252−
253−- `ToStreamGenerator` definition changed, so it's possible to write an instance
254− for conduits.
255−
256− ```diff
257− -class ToStreamGenerator f a where
258− - toStreamGenerator :: f a -> StreamGenerator a
259− +class ToStreamGenerator a b | a -> b where
260− + toStreamGenerator :: a -> StreamGenerator b
261− ```
262−
263− ([#959](https://github.com/haskell-servant/servant/pull/959))
264−
265−- Added `NoFraming` streaming strategy
266− ([#959](https://github.com/haskell-servant/servant/pull/959))
267−
268−- *servant-client-core* Add `hoistClient` to `HasClient`.
269− 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
271− 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).
273− ([#936](https://github.com/haskell-servant/servant/pull/936))
274−
275−- *servant-client* Add more constructors to `RequestBody`, including
276− `RequestBodyStream`.
277− *Note:* we are looking for http-library agnostic API,
278− so the might change again soon.
279− Tell us which constructors are useful for you!
280− ([#913](https://github.com/haskell-servant/servant/pull/913))
281−
282−0.13.0.1
283−--------
284−
285−- Support `base-compat-0.10`
286−
2870.13
40.13
288----
5----
289
6
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
2
2
3All rights reserved.
3All rights reserved.
4
4
servant-client/README.lhsdeleted−1
@@ -1 +0,0 @@
1−README.md
servant-client/README.md+3−24
@@ -7,35 +7,14 @@ This library lets you automatically derive Haskell functions that let you query
7## Example
7## Example
8
8
9``` haskell
9``` haskell
10−{-# LANGUAGE DataKinds #-}
11−{-# LANGUAGE TypeOperators #-}
12−
13−import Data.Proxy
14−import Data.Text
15−import Network.HTTP.Client (newManager, defaultManagerSettings)
16−import Servant.API
17−import Servant.Client
18−
19−
20−type Book = Text
21−
22type MyApi = "books" :> Get '[JSON] [Book] -- GET /books
10type MyApi = "books" :> Get '[JSON] [Book] -- GET /books
23− :<|> "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book -- POST /books
11+ :<|> "books" :> ReqBody Book :> Post '[JSON] Book -- POST /books
24
12
25myApi :: Proxy MyApi
13myApi :: Proxy MyApi
26myApi = Proxy
14myApi = Proxy
27
15
16+getAllBooks :: Manager -> BaseUrl -> ExceptT String IO [Book]
17+postNewBook :: Book -> Manager -> BaseUrl -> ExceptT String IO Book
28-- 'client' allows you to produce operations to query an API from a client.
18-- 'client' allows you to produce operations to query an API from a client.
29−postNewBook :: Book -> ClientM Book
30−getAllBooks :: ClientM [Book]
31(getAllBooks :<|> postNewBook) = client myApi
19(getAllBooks :<|> postNewBook) = client myApi
32−
33−
34−main :: IO ()
35−main = do
36− manager' <- newManager defaultManagerSettings
37− res <- runClientM getAllBooks (mkClientEnv manager' (BaseUrl Http "localhost" 8081 ""))
38− case res of
39− Left err -> putStrLn $ "Error: " ++ show err
40− Right books -> print books
41```
20```
servant-client/include/overlapping-compat.hnew file+8
@@ -0,0 +1,8 @@
1+#if __GLASGOW_HASKELL__ >= 710
2+#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}
3+#define OVERLAPPING_ {-# OVERLAPPING #-}
4+#else
5+{-# LANGUAGE OverlappingInstances #-}
6+#define OVERLAPPABLE_
7+#define OVERLAPPING_
8+#endif
servant-client/servant-client.cabal+59−80
@@ -1,32 +1,32 @@
1−cabal-version: 2.2
2name: servant-client
1name: servant-client
3−version: 0.19
2+version: 0.13
4−
5−synopsis: Automatic derivation of querying functions for servant
3+synopsis: automatical derivation of querying functions for servant webservices
6−category: Servant, Web
7description:
4description:
8 This library lets you derive automatically Haskell functions that
5 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.
6 let you query each endpoint of a <http://hackage.haskell.org/package/servant servant> webservice.
10 .
7 .
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>.
12 .
9 .
13 <https://github.com/haskell-servant/servant/blob/master/servant-client/CHANGELOG.md CHANGELOG>
10 <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
18license-file: LICENSE
12license-file: LICENSE
19author: Servant Contributors
13author: Servant Contributors
20maintainer: haskell-servant-maintainers@googlegroups.com
14maintainer: 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
22build-type: Simple
17build-type: Simple
18+cabal-version: >=1.10
23−tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1
19+tested-with:
24− , GHCJS ==8.6.0.1
20+ GHC==7.8.4
25−
21+ GHC==7.10.3
22+ GHC==8.0.2
23+ GHC==8.2.2
24+homepage: http://haskell-servant.readthedocs.org/
25+Bug-reports: http://github.com/haskell-servant/servant/issues
26extra-source-files:
26extra-source-files:
27+ include/*.h
27 CHANGELOG.md
28 CHANGELOG.md
28 README.md
29 README.md
29−
30source-repository head
30source-repository head
31 type: git
31 type: git
32 location: http://github.com/haskell-servant/servant.git
32 location: http://github.com/haskell-servant/servant.git
@@ -34,71 +34,61 @@ source-repository head
34library
34library
35 exposed-modules:
35 exposed-modules:
36 Servant.Client
36 Servant.Client
37− Servant.Client.Streaming
38 Servant.Client.Internal.HttpClient
37 Servant.Client.Internal.HttpClient
39− Servant.Client.Internal.HttpClient.Streaming
40
38
41 -- Bundled with GHC: Lower bound to not force re-installs
39 -- Bundled with GHC: Lower bound to not force re-installs
42 -- text and mtl are bundled starting with GHC-8.4
40 -- text and mtl are bundled starting with GHC-8.4
41+ --
42+ -- note: mtl lower bound is so low because of GHC-7.8
43 build-depends:
43 build-depends:
44− base >= 4.9 && < 4.18
44+ base >= 4.7 && < 4.11
45− , bytestring >= 0.10.8.1 && < 0.12
45+ , bytestring >= 0.10.4.0 && < 0.11
46− , containers >= 0.5.7.1 && < 0.7
46+ , containers >= 0.5.5.1 && < 0.6
47− , deepseq >= 1.4.2.0 && < 1.5
47+ , mtl >= 2.1 && < 2.3
48− , mtl ^>= 2.2.2 || ^>= 2.3.1
49− , stm >= 2.4.5.1 && < 2.6
50− , text >= 1.2.3.0 && < 2.1
48+ , text >= 1.2.3.0 && < 1.3
51− , time >= 1.6.0.1 && < 1.13
49+ , time >= 1.4.2 && < 1.9
52− , transformers >= 0.5.2.0 && < 0.7
50+ , transformers >= 0.3.0.0 && < 0.6
53
51
54− if !impl(ghc >= 8.2)
52+ if !impl(ghc >= 8.0)
55− build-depends:
53+ build-depends: semigroups >=0.18.3 && <0.19
56− bifunctors >= 5.5.3 && < 5.6
57
54
58− -- Servant dependencies.
55+ -- Servant dependencies
59− -- Strict dependency on `servant-client-core` as we re-export things.
60 build-depends:
56 build-depends:
61− servant >= 0.18 && < 0.20
62− , servant-client-core >= 0.19 && < 0.19.1
57+ servant-client-core == 0.13.*
63
58
64 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.
59 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.
65 -- Here can be exceptions if we really need features from the newer versions.
60 -- Here can be exceptions if we really need features from the newer versions.
66 build-depends:
61 build-depends:
62+ aeson >= 1.2.3.0 && < 1.3
67− base-compat >= 0.10.5 && < 0.13
63+ , base-compat >= 0.9.3 && < 0.10
64+ , attoparsec >= 0.13.2.0 && < 0.14
68− , http-client >= 0.5.13.1 && < 0.8
65+ , http-client >= 0.5.7.1 && < 0.6
66+ , http-client-tls >= 0.3.5.1 && < 0.4
69− , http-media >= 0.7.1.3 && < 0.9
67+ , http-media >= 0.7.1.1 && < 0.8
70− , http-types >= 0.12.2 && < 0.13
68+ , http-types >= 0.12 && < 0.13
71− , exceptions >= 0.10.0 && < 0.11
69+ , exceptions >= 0.8.3 && < 0.9
72− , kan-extensions >= 5.2 && < 5.3
73− , monad-control >= 1.0.2.3 && < 1.1
70+ , monad-control >= 1.0.0.4 && < 1.1
74− , semigroupoids >= 5.3.1 && < 5.4
71+ , semigroupoids >= 5.2.1 && < 5.3
72+ , stm >= 2.4.4.1 && < 2.5
75− , transformers-base >= 0.4.5.2 && < 0.5
73+ , transformers-base >= 0.4.4 && < 0.5
76− , transformers-compat >= 0.6.2 && < 0.8
74+ , transformers-compat >= 0.5.1 && < 0.6
77
75
78 hs-source-dirs: src
76 hs-source-dirs: src
79 default-language: Haskell2010
77 default-language: Haskell2010
78+ ghc-options: -Wall
79+ if impl(ghc >= 8.0)
80− ghc-options: -Wall -Wno-redundant-constraints
80+ ghc-options: -Wno-redundant-constraints
81+ include-dirs: include
81
82
82test-suite spec
83test-suite spec
83 type: exitcode-stdio-1.0
84 type: exitcode-stdio-1.0
84− ghc-options: -Wall -rtsopts -threaded "-with-rtsopts=-T -N2"
85+ ghc-options: -Wall
85 default-language: Haskell2010
86 default-language: Haskell2010
86− if impl(ghcjs)
87− buildable: False
88 hs-source-dirs: test
87 hs-source-dirs: test
89 main-is: Spec.hs
88 main-is: Spec.hs
90 other-modules:
89 other-modules:
91− Servant.BasicAuthSpec
90+ Servant.ClientSpec
92− Servant.BrokenSpec
93− Servant.ClientTestUtils
94− Servant.ConnectionErrorSpec
95− Servant.FailSpec
96− Servant.GenAuthSpec
97− Servant.GenericSpec
98− Servant.HoistClientSpec
99 Servant.StreamSpec
91 Servant.StreamSpec
100− Servant.SuccessSpec
101− Servant.WrappedApiSpec
102
92
103 -- Dependencies inherited from the library. No need to specify bounds.
93 -- Dependencies inherited from the library. No need to specify bounds.
104 build-depends:
94 build-depends:
@@ -106,41 +96,30 @@ test-suite spec
106 , aeson
96 , aeson
107 , base-compat
97 , base-compat
108 , bytestring
98 , bytestring
99+ , containers
109 , http-api-data
100 , http-api-data
110 , http-client
101 , http-client
102+ , http-media
111 , http-types
103 , http-types
112 , mtl
104 , mtl
113− , kan-extensions
114 , servant-client
105 , servant-client
115 , servant-client-core
106 , servant-client-core
116− , sop-core
117− , stm
118 , text
107 , text
119 , transformers
108 , transformers
120 , transformers-compat
109 , transformers-compat
121 , wai
110 , wai
122 , warp
111 , warp
123
112
124− -- Additional dependencies
113+ -- Additonal dependencies
125 build-depends:
114 build-depends:
126− entropy >= 0.4.1.3 && < 0.5
115+ deepseq >= 1.3.0.2 && < 1.5
116+ , generics-sop >= 0.3.1.0 && < 0.4
127− , hspec >= 2.6.0 && < 2.10
117+ , hspec >= 2.4.4 && < 2.5
128− , HUnit >= 1.6.0.0 && < 1.7
118+ , HUnit >= 1.6 && < 1.7
129− , network >= 2.8.0.0 && < 3.2
119+ , network >= 2.6.3.2 && < 2.7
130− , QuickCheck >= 2.12.6.1 && < 2.15
120+ , QuickCheck >= 2.10.1 && < 2.12
131− , servant == 0.19.*
121+ , servant == 0.13.*
132− , servant-server == 0.19.*
122+ , servant-server == 0.13.*
133− , tdigest >= 0.2 && < 0.3
134
123
135 build-tool-depends:
124 build-tool-depends:
136− hspec-discover:hspec-discover >= 2.6.0 && < 2.10
125+ hspec-discover:hspec-discover >= 2.4.4 && < 2.5
137−
138−test-suite readme
139− type: exitcode-stdio-1.0
140− main-is: README.lhs
141− build-depends: base, servant, http-client, text, servant-client, markdown-unlit
142− build-tool-depends: markdown-unlit:markdown-unlit
143− ghc-options: -pgmL markdown-unlit
144− default-language: Haskell2010
145− if impl(ghcjs)
146− buildable: False
servant-client/src/Servant/Client.hs+2−4
@@ -9,10 +9,8 @@ module Servant.Client
9 , runClientM
9 , runClientM
10 , ClientEnv(..)
10 , ClientEnv(..)
11 , mkClientEnv
11 , mkClientEnv
12− , defaultMakeClientRequest
13− , hoistClient
14 , module Servant.Client.Core.Reexport
12 , module Servant.Client.Core.Reexport
15 ) where
13 ) where
16
14
17−import Servant.Client.Core.Reexport
15+import Servant.Client.Core.Reexport
18−import Servant.Client.Internal.HttpClient
16+import Servant.Client.Internal.HttpClient
servant-client/src/Servant/Client/Internal/HttpClient.hs+95−198
@@ -6,91 +6,53 @@
6{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE OverloadedStrings #-}
8{-# LANGUAGE OverloadedStrings #-}
9−{-# LANGUAGE RankNTypes #-}
10{-# LANGUAGE ScopedTypeVariables #-}
9{-# LANGUAGE ScopedTypeVariables #-}
11{-# LANGUAGE TypeFamilies #-}
10{-# LANGUAGE TypeFamilies #-}
12module Servant.Client.Internal.HttpClient where
11module Servant.Client.Internal.HttpClient where
13
12
14−import Prelude ()
13+import Prelude ()
15import Prelude.Compat
14import Prelude.Compat
16
15
17−import Control.Concurrent.MVar
18− (modifyMVar, newMVar)
19import Control.Concurrent.STM.TVar
16import Control.Concurrent.STM.TVar
20import Control.Exception
17import Control.Exception
21− (SomeException (..), catch)
22import Control.Monad
18import Control.Monad
23− (unless)
24−import Control.Monad.Base
19+import Control.Monad.Base (MonadBase (..))
25− (MonadBase (..))
26−import Control.Monad.Catch
20+import Control.Monad.Catch (MonadCatch, MonadThrow)
27− (MonadCatch, MonadThrow, MonadMask)
28−import Control.Monad.Error.Class
21+import Control.Monad.Error.Class (MonadError (..))
29− (MonadError (..))
30−import Control.Monad.IO.Class
31− (MonadIO (..))
32import Control.Monad.Reader
22import Control.Monad.Reader
33− (MonadReader, ReaderT, ask, runReaderT)
34−import Control.Monad.STM
23+import Control.Monad.STM (atomically)
35− (STM, atomically)
36−import Control.Monad.Trans.Control
24+import Control.Monad.Trans.Control (MonadBaseControl (..))
37− (MonadBaseControl (..))
38import Control.Monad.Trans.Except
25import Control.Monad.Trans.Except
39− (ExceptT, runExceptT)
40−import Data.Bifunctor
41− (bimap)
42−import qualified Data.ByteString as BS
43−import Data.ByteString.Builder
26+import Data.ByteString.Builder (toLazyByteString)
44− (toLazyByteString)
45import qualified Data.ByteString.Lazy as BSL
27import qualified Data.ByteString.Lazy as BSL
46−import Data.Either
28+import Data.Foldable (toList, for_)
47− (either)
48−import Data.Foldable
49− (foldl',toList)
50−import Data.Functor.Alt
29+import Data.Functor.Alt (Alt (..))
51− (Alt (..))
52−import Data.Maybe
30+import Data.Maybe (maybeToList)
53− (maybe, maybeToList)
54−import Data.Proxy
31+import Data.Semigroup ((<>))
55− (Proxy (..))
32+import Data.Proxy (Proxy (..))
56−import Data.Sequence
33+import Data.Sequence (fromList)
57− (fromList)
58−import Data.String
34+import Data.String (fromString)
59− (fromString)
35+import qualified Data.Text as T
60−import Data.Time.Clock
61− (UTCTime, getCurrentTime)
36+import Data.Time.Clock (getCurrentTime)
62import GHC.Generics
37import GHC.Generics
63−import Network.HTTP.Media
38+import Network.HTTP.Media (renderHeader)
64− (renderHeader)
65−import Network.HTTP.Types
39+import Network.HTTP.Types (hContentType, renderQuery,
66− (hContentType, renderQuery, statusIsSuccessful, urlEncode, Status)
40+ statusCode)
67import Servant.Client.Core
41import Servant.Client.Core
68
42
69import qualified Network.HTTP.Client as Client
43import qualified Network.HTTP.Client as Client
70−import qualified Servant.Types.SourceT as S
71
44
72-- | The environment in which a request is run.
45-- | 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'
78data ClientEnv
46data ClientEnv
79 = ClientEnv
47 = ClientEnv
80 { manager :: Client.Manager
48 { manager :: Client.Manager
81 , baseUrl :: BaseUrl
49 , baseUrl :: BaseUrl
82 , cookieJar :: Maybe (TVar Client.CookieJar)
50 , 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.
89 }
51 }
90
52
91-- | 'ClientEnv' smart constructor.
53-- | 'ClientEnv' smart constructor.
92mkClientEnv :: Client.Manager -> BaseUrl -> ClientEnv
54mkClientEnv :: Client.Manager -> BaseUrl -> ClientEnv
93−mkClientEnv mgr burl = ClientEnv mgr burl Nothing defaultMakeClientRequest
55+mkClientEnv mgr burl = ClientEnv mgr burl Nothing
94
56
95-- | Generates a set of client functions for an API.
57-- | Generates a set of client functions for an API.
96--
58--
@@ -108,41 +70,19 @@ mkClientEnv mgr burl = ClientEnv mgr burl Nothing defaultMakeClientRequest
108client :: HasClient ClientM api => Proxy api -> Client ClientM api
70client :: HasClient ClientM api => Proxy api -> Client ClientM api
109client api = api `clientIn` (Proxy :: Proxy ClientM)
71client api = api `clientIn` (Proxy :: Proxy ClientM)
110
72
111−-- | Change the monad the client functions live in, by
112−-- supplying a conversion function
113−-- (a natural transformation to be precise).
114−--
115−-- For example, assuming you have some @manager :: 'Manager'@ and
116−-- @baseurl :: 'BaseUrl'@ around:
117−--
118−-- > type API = Get '[JSON] Int :<|> Capture "n" Int :> Post '[JSON] Int
119−-- > api :: Proxy API
120−-- > api = Proxy
121−-- > getInt :: IO Int
122−-- > postInt :: Int -> IO Int
123−-- > getInt :<|> postInt = hoistClient api (flip runClientM cenv) (client api)
124−-- > where cenv = mkClientEnv manager baseurl
125−hoistClient
126− :: HasClient ClientM api
127− => Proxy api
128− -> (forall a. m a -> n a)
129− -> Client m api
130− -> Client n api
131−hoistClient = hoistClientMonad (Proxy :: Proxy ClientM)
132−
133-- | @ClientM@ is the monad in which client functions run. Contains the
73-- | @ClientM@ is the monad in which client functions run. Contains the
134-- 'Client.Manager' and 'BaseUrl' used for requests in the reader environment.
74-- 'Client.Manager' and 'BaseUrl' used for requests in the reader environment.
135newtype ClientM a = ClientM
75newtype ClientM a = ClientM
136− { unClientM :: ReaderT ClientEnv (ExceptT ClientError IO) a }
76+ { unClientM :: ReaderT ClientEnv (ExceptT ServantError IO) a }
137 deriving ( Functor, Applicative, Monad, MonadIO, Generic
77 deriving ( Functor, Applicative, Monad, MonadIO, Generic
138− , MonadReader ClientEnv, MonadError ClientError, MonadThrow
78+ , MonadReader ClientEnv, MonadError ServantError, MonadThrow
139− , MonadCatch, MonadMask)
79+ , MonadCatch)
140
80
141instance MonadBase IO ClientM where
81instance MonadBase IO ClientM where
142 liftBase = ClientM . liftBase
82 liftBase = ClientM . liftBase
143
83
144instance MonadBaseControl IO ClientM where
84instance MonadBaseControl IO ClientM where
145− type StM ClientM a = Either ClientError a
85+ type StM ClientM a = Either ServantError a
146
86
147 liftBaseWith f = ClientM (liftBaseWith (\g -> f (g . unClientM)))
87 liftBaseWith f = ClientM (liftBaseWith (\g -> f (g . unClientM)))
148
88
@@ -153,16 +93,21 @@ instance Alt ClientM where
153 a <!> b = a `catchError` \_ -> b
93 a <!> b = a `catchError` \_ -> b
154
94
155instance RunClient ClientM where
95instance RunClient ClientM where
156− runRequestAcceptStatus = performRequest
96+ runRequest = performRequest
157− throwClientError = throwError
97+ streamingRequest = performStreamingRequest
98+ throwServantError = throwError
99+ catchServantError = catchError
158
100
101+instance ClientLike (ClientM a) (ClientM a) where
102+ mkClient = id
103+
159−runClientM :: ClientM a -> ClientEnv -> IO (Either ClientError a)
104+runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a)
160runClientM cm env = runExceptT $ flip runReaderT env $ unClientM cm
105runClientM cm env = runExceptT $ flip runReaderT env $ unClientM cm
161
106
162−performRequest :: Maybe [Status] -> Request -> ClientM Response
107+performRequest :: Request -> ClientM Response
163−performRequest acceptStatus req = do
108+performRequest req = do
164− ClientEnv m burl cookieJar' createClientRequest <- ask
109+ ClientEnv m burl cookieJar' <- ask
165− clientRequest <- liftIO $ createClientRequest burl req
110+ let clientRequest = requestToClientRequest burl req
166 request <- case cookieJar' of
111 request <- case cookieJar' of
167 Nothing -> pure clientRequest
112 Nothing -> pure clientRequest
168 Just cj -> liftIO $ do
113 Just cj -> liftIO $ do
@@ -171,82 +116,67 @@ performRequest acceptStatus req = do
171 oldCookieJar <- readTVar cj
116 oldCookieJar <- readTVar cj
172 let (newRequest, newCookieJar) =
117 let (newRequest, newCookieJar) =
173 Client.insertCookiesIntoRequest
118 Client.insertCookiesIntoRequest
174− clientRequest
119+ (requestToClientRequest burl req)
175 oldCookieJar
120 oldCookieJar
176 now
121 now
177 writeTVar cj newCookieJar
122 writeTVar cj newCookieJar
178 pure newRequest
123 pure newRequest
179
124
180− response <- maybe (requestWithoutCookieJar m request) (requestWithCookieJar m request) cookieJar'
125+ eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request m
181− let status = Client.responseStatus response
126+ case eResponse of
182− ourResponse = clientResponseToResponse id response
127+ Left err -> throwError err
183− goodStatus = case acceptStatus of
128+ Right response -> do
184− Nothing -> statusIsSuccessful status
129+ for_ cookieJar' $ \cj -> liftIO $ do
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
130+ 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')
131+ atomically $ modifyTVar' cj (fst . Client.updateCookieJar response request now')
211−
132+ let status = Client.responseStatus response
212− fReq = Client.hrFinalRequest responses
133+ status_code = statusCode status
213− fRes = Client.hrFinalResponse responses
134+ ourResponse = clientResponseToResponse response
214−
135+ unless (status_code >= 200 && status_code < 300) $
215−mkFailureResponse :: BaseUrl -> Request -> ResponseF BSL.ByteString -> ClientError
136+ throwError $ FailureResponse ourResponse
216−mkFailureResponse burl request =
137+ return ourResponse
217− FailureResponse (bimap (const ()) f request)
138+
218− where
139+performStreamingRequest :: Request -> ClientM StreamingResponse
219− f b = (burl, BSL.toStrict $ toLazyByteString b)
140+performStreamingRequest req = do
220−
141+ m <- asks manager
142+ burl <- asks baseUrl
143+ let request = requestToClientRequest burl req
144+ return $ StreamingResponse $
145+ \k -> Client.withResponse request m $
146+ \r -> do
147+ let status = Client.responseStatus r
148+ status_code = statusCode status
149+ unless (status_code >= 200 && status_code < 300) $ do
150+ b <- BSL.fromChunks <$> Client.brConsume (Client.responseBody r)
221−clientResponseToResponse :: (a -> b) -> Client.Response a -> ResponseF b
151+ throw $ FailureResponse $ clientResponseToResponse r { Client.responseBody = b }
152+ k (clientResponseToResponse r)
153+
154+clientResponseToResponse :: Client.Response a -> GenResponse a
222−clientResponseToResponse f r = Response
155+clientResponseToResponse r = Response
223− { responseStatusCode = Client.responseStatus r
156+ { responseStatusCode = Client.responseStatus r
224− , responseBody = f (Client.responseBody r)
157+ , responseBody = Client.responseBody r
225− , responseHeaders = fromList $ Client.responseHeaders r
158+ , responseHeaders = fromList $ Client.responseHeaders r
226− , responseHttpVersion = Client.responseVersion r
159+ , responseHttpVersion = Client.responseVersion r
227− }
160+ }
228
161
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
162+requestToClientRequest :: BaseUrl -> Request -> Client.Request
233−defaultMakeClientRequest burl r = return Client.defaultRequest
163+requestToClientRequest burl r = Client.defaultRequest
234− { Client.method = requestMethod r
164+ { Client.method = requestMethod r
235− , Client.host = fromString $ baseUrlHost burl
165+ , Client.host = fromString $ baseUrlHost burl
236− , Client.port = baseUrlPort burl
166+ , Client.port = baseUrlPort burl
237− , Client.path = BSL.toStrict
167+ , Client.path = BSL.toStrict
238− $ fromString (baseUrlPath burl)
168+ $ fromString (baseUrlPath burl)
239− <> toLazyByteString (requestPath r)
169+ <> toLazyByteString (requestPath r)
240− , Client.queryString = buildQueryString . toList $ requestQueryString r
170+ , Client.queryString = renderQuery True . toList $ requestQueryString r
241− , Client.requestHeaders =
171+ , Client.requestHeaders =
242− maybeToList acceptHdr ++ maybeToList contentTypeHdr ++ headers
172+ maybeToList acceptHdr ++ maybeToList contentTypeHdr ++ headers
243− , Client.requestBody = body
173+ , Client.requestBody = body
244− , Client.secure = isSecure
174+ , Client.secure = isSecure
245− }
175+ }
246 where
176 where
247 -- Content-Type and Accept are specified by requestBody and requestAccept
177 -- Content-Type and Accept are specified by requestBody and requestAccept
248 headers = filter (\(h, _) -> h /= "Accept" && h /= "Content-Type") $
178 headers = filter (\(h, _) -> h /= "Accept" && h /= "Content-Type") $
249− toList $ requestHeaders r
179+ toList $requestHeaders r
250
180
251 acceptHdr
181 acceptHdr
252 | null hs = Nothing
182 | null hs = Nothing
@@ -254,49 +184,16 @@ defaultMakeClientRequest burl r = return Client.defaultRequest
254 where
184 where
255 hs = toList $ requestAccept r
185 hs = toList $ requestAccept r
256
186
257− 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
282−
283 (body, contentTypeHdr) = case requestBody r of
187 (body, contentTypeHdr) = case requestBody r of
284− Nothing -> (Client.RequestBodyBS "", Nothing)
188+ Nothing -> (Client.RequestBodyLBS "", Nothing)
189+ Just (RequestBodyLBS body', typ)
285− Just (body', typ) -> (convertBody body', Just (hContentType, renderHeader typ))
190+ -> (Client.RequestBodyLBS body', Just (hContentType, renderHeader typ))
286
191
287 isSecure = case baseUrlScheme burl of
192 isSecure = case baseUrlScheme burl of
288− Http -> False
193+ Http -> False
289− Https -> True
194+ 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−
298
195
299−catchConnectionError :: IO a -> IO (Either ClientError a)
196+catchConnectionError :: IO a -> IO (Either ServantError a)
300catchConnectionError action =
197catchConnectionError action =
301 catch (Right <$> action) $ \e ->
198 catch (Right <$> action) $ \e ->
302− pure . Left . ConnectionError $ SomeException (e :: Client.HttpException)
199+ 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+130−115
@@ -12,76 +12,83 @@
12{-# LANGUAGE RecordWildCards #-}
12{-# LANGUAGE RecordWildCards #-}
13{-# LANGUAGE ScopedTypeVariables #-}
13{-# LANGUAGE ScopedTypeVariables #-}
14{-# LANGUAGE StandaloneDeriving #-}
14{-# LANGUAGE StandaloneDeriving #-}
15−{-# LANGUAGE TypeApplications #-}
16{-# LANGUAGE TypeFamilies #-}
15{-# LANGUAGE TypeFamilies #-}
17{-# LANGUAGE TypeOperators #-}
16{-# LANGUAGE TypeOperators #-}
18{-# LANGUAGE UndecidableInstances #-}
17{-# LANGUAGE UndecidableInstances #-}
18+#if __GLASGOW_HASKELL__ >= 800
19{-# OPTIONS_GHC -freduction-depth=100 #-}
19{-# OPTIONS_GHC -freduction-depth=100 #-}
20+#else
21+{-# OPTIONS_GHC -fcontext-stack=100 #-}
22+#endif
20{-# OPTIONS_GHC -fno-warn-orphans #-}
23{-# OPTIONS_GHC -fno-warn-orphans #-}
21{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
24{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
22
25
26+#include "overlapping-compat.h"
23module Servant.ClientSpec (spec, Person(..), startWaiApp, endWaiApp) where
27module Servant.ClientSpec (spec, Person(..), startWaiApp, endWaiApp) where
24
28
25−import Prelude ()
29+import Prelude ()
26import Prelude.Compat
30import Prelude.Compat
27
31
28−import Control.Arrow
32+import Control.Arrow (left)
29− (left)
30−import Control.Concurrent
33+import Control.Concurrent (ThreadId, forkIO,
31− (ThreadId, forkIO, killThread)
34+ killThread)
32−import Control.DeepSeq
35+import Control.Exception (bracket)
33− (NFData (..))
34−import Control.Exception
35− (bracket, fromException, IOException)
36−import Control.Monad.Error.Class
36+import Control.Monad.Error.Class (throwError)
37− (throwError)
38import Data.Aeson
37import Data.Aeson
39−import Data.Char
38+import Data.Char (chr, isPrint)
40− (chr, isPrint)
41−import Data.Foldable
39+import Data.Foldable (forM_)
42− (forM_, toList)
43−import Data.Maybe
44− (isJust)
45−import Data.Monoid ()
40+import Data.Monoid hiding (getLast)
46import Data.Proxy
41import Data.Proxy
42+import qualified Generics.SOP as SOP
47−import GHC.Generics
43+import GHC.Generics (Generic)
48− (Generic)
49−import qualified Network.HTTP.Types as HTTP
44+import qualified Network.HTTP.Client as C
45+import qualified Network.HTTP.Types as HTTP
50import Network.Socket
46import Network.Socket
51−import qualified Network.Wai as Wai
47+import qualified Network.Wai as Wai
52import Network.Wai.Handler.Warp
48import Network.Wai.Handler.Warp
49+import System.IO.Unsafe (unsafePerformIO)
53import Test.Hspec
50import Test.Hspec
54import Test.Hspec.QuickCheck
51import Test.Hspec.QuickCheck
55import Test.HUnit
52import Test.HUnit
56import Test.QuickCheck
53import Test.QuickCheck
57−import Web.FormUrlEncoded
54+import Web.FormUrlEncoded (FromForm, ToForm)
58− (FromForm, ToForm)
55+
59−
60−import Servant.API
56+import Servant.API ((:<|>) ((:<|>)),
61− ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth,
57+ (:>), AuthProtect,
58+ BasicAuth,
59+ BasicAuthData (..),
60+ Capture,
62− BasicAuthData (..), Capture, CaptureAll, Delete,
61+ CaptureAll, Delete,
63− DeleteNoContent, EmptyAPI, FormUrlEncoded, Get, Header,
62+ DeleteNoContent,
63+ EmptyAPI, addHeader,
64+ FormUrlEncoded,
65+ Get, Header,
66+ Headers, JSON,
64− Headers, JSON, NoContent (NoContent), Post, Put, QueryFlag,
67+ NoContent (NoContent),
65− QueryParam, QueryParams, Raw, ReqBody, addHeader, getHeaders)
68+ Post, Put, Raw,
66−import qualified Servant.Client.Core.Auth as Auth
69+ QueryFlag,
70+ QueryParam,
71+ QueryParams,
72+ ReqBody,
73+ getHeaders)
74+import Servant.API.Internal.Test.ComprehensiveAPI
75+import Servant.Client
67−import qualified Servant.Client.Core.Request as Req
76+import qualified Servant.Client.Core.Internal.Request as Req
68−import Servant.HttpStreams
77+import qualified Servant.Client.Core.Internal.Auth as Auth
69import Servant.Server
78import Servant.Server
70import Servant.Server.Experimental.Auth
79import Servant.Server.Experimental.Auth
71−import Servant.Test.ComprehensiveAPI
72
80
73-- This declaration simply checks that all instances are in place.
81-- This declaration simply checks that all instances are in place.
74−_ = client comprehensiveAPIWithoutStreaming
82+_ = client comprehensiveAPI
75
83
76spec :: Spec
84spec :: Spec
77−spec = describe "Servant.HttpStreams" $ do
85+spec = describe "Servant.Client" $ do
78− successSpec
86+ sucessSpec
79 failSpec
87 failSpec
80 wrappedApiSpec
88 wrappedApiSpec
81 basicAuthSpec
89 basicAuthSpec
82 genAuthSpec
90 genAuthSpec
83− hoistClientSpec
91+ genericClientSpec
84− connectionErrorSpec
85
92
86-- * test data types
93-- * test data types
87
94
@@ -90,18 +97,12 @@ data Person = Person
90 , _age :: Integer
97 , _age :: Integer
91 } deriving (Eq, Show, Generic)
98 } deriving (Eq, Show, Generic)
92
99
93−instance NFData Person where
94− rnf (Person n a) = rnf n `seq` rnf a
95−
96instance ToJSON Person
100instance ToJSON Person
97instance FromJSON Person
101instance FromJSON Person
98
102
99instance ToForm Person
103instance ToForm Person
100instance FromForm Person
104instance FromForm Person
101
105
102−instance Arbitrary Person where
103− arbitrary = Person <$> arbitrary <*> arbitrary
104−
105alice :: Person
106alice :: Person
106alice = Person "Alice" 42
107alice = Person "Alice" 42
107
108
@@ -113,7 +114,7 @@ type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]
113type Api =
114type Api =
114 Get '[JSON] Person
115 Get '[JSON] Person
115 :<|> "get" :> Get '[JSON] Person
116 :<|> "get" :> Get '[JSON] Person
116− :<|> "deleteEmpty" :> DeleteNoContent
117+ :<|> "deleteEmpty" :> DeleteNoContent '[JSON] NoContent
117 :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person
118 :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person
118 :<|> "captureAll" :> CaptureAll "names" String :> Get '[JSON] [Person]
119 :<|> "captureAll" :> CaptureAll "names" String :> Get '[JSON] [Person]
119 :<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person
120 :<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person
@@ -129,8 +130,7 @@ type Api =
129 ReqBody '[JSON] [(String, [Rational])] :>
130 ReqBody '[JSON] [(String, [Rational])] :>
130 Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])])
131 Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])])
131 :<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool)
132 :<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool)
132− :<|> "deleteContentType" :> DeleteNoContent
133+ :<|> "deleteContentType" :> DeleteNoContent '[JSON] NoContent
133− :<|> "redirectWithCookie" :> Raw
134 :<|> "empty" :> EmptyAPI
134 :<|> "empty" :> EmptyAPI
135
135
136api :: Proxy Api
136api :: Proxy Api
@@ -151,7 +151,6 @@ getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]
151 -> ClientM (String, Maybe Int, Bool, [(String, [Rational])])
151 -> ClientM (String, Maybe Int, Bool, [(String, [Rational])])
152getRespHeaders :: ClientM (Headers TestHeaders Bool)
152getRespHeaders :: ClientM (Headers TestHeaders Bool)
153getDeleteContentType :: ClientM NoContent
153getDeleteContentType :: ClientM NoContent
154−_getRedirectWithCookie :: HTTP.Method -> ClientM Response
155
154
156getRoot
155getRoot
157 :<|> getGet
156 :<|> getGet
@@ -167,7 +166,6 @@ getRoot
167 :<|> getMultiple
166 :<|> getMultiple
168 :<|> getRespHeaders
167 :<|> getRespHeaders
169 :<|> getDeleteContentType
168 :<|> getDeleteContentType
170− :<|> _getRedirectWithCookie
171 :<|> EmptyClient = client api
169 :<|> EmptyClient = client api
172
170
173server :: Application
171server :: Application
@@ -180,8 +178,8 @@ server = serve api (
180 :<|> return
178 :<|> return
181 :<|> (\ name -> case name of
179 :<|> (\ name -> case name of
182 Just "alice" -> return alice
180 Just "alice" -> return alice
183− Just n -> throwError $ ServerError 400 (n ++ " not found") "" []
181+ Just n -> throwError $ ServantErr 400 (n ++ " not found") "" []
184− Nothing -> throwError $ ServerError 400 "missing parameter" "" [])
182+ Nothing -> throwError $ ServantErr 400 "missing parameter" "" [])
185 :<|> (\ names -> return (zipWith Person names [0..]))
183 :<|> (\ names -> return (zipWith Person names [0..]))
186 :<|> return
184 :<|> return
187 :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "rawSuccess")
185 :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "rawSuccess")
@@ -189,9 +187,9 @@ server = serve api (
189 :<|> (\ a b c d -> return (a, b, c, d))
187 :<|> (\ a b c d -> return (a, b, c, d))
190 :<|> (return $ addHeader 1729 $ addHeader "eg2" True)
188 :<|> (return $ addHeader 1729 $ addHeader "eg2" True)
191 :<|> return NoContent
189 :<|> return NoContent
192− :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.found302 [("Location", "testlocation"), ("Set-Cookie", "testcookie=test")] "")
193 :<|> emptyServer)
190 :<|> emptyServer)
194
191
192+
195type FailApi =
193type FailApi =
196 "get" :> Raw
194 "get" :> Raw
197 :<|> "capture" :> Capture "name" String :> Raw
195 :<|> "capture" :> Capture "name" String :> Raw
@@ -252,16 +250,62 @@ genAuthServerContext = genAuthHandler :. EmptyContext
252genAuthServer :: Application
250genAuthServer :: Application
253genAuthServer = serveWithContext genAuthAPI genAuthServerContext (const (return alice))
251genAuthServer = serveWithContext genAuthAPI genAuthServerContext (const (return alice))
254
252
255−runClient :: NFData a => ClientM a -> BaseUrl -> IO (Either ClientError a)
253+-- * generic client stuff
256−runClient x burl = withClientEnvIO burl (runClientM x)
254+
257−
255+type GenericClientAPI
258−runClientUnsafe :: ClientM a -> BaseUrl -> IO (Either ClientError a)
256+ = QueryParam "sqr" Int :> Get '[JSON] Int
259−runClientUnsafe x burl = withClientEnvIO burl (runClientMUnsafe x)
257+ :<|> Capture "foo" String :> NestedAPI1
258+
259+data GenericClient = GenericClient
260+ { getSqr :: Maybe Int -> ClientM Int
261+ , mkNestedClient1 :: String -> NestedClient1
262+ } deriving Generic
263+instance SOP.Generic GenericClient
264+instance (Client ClientM GenericClientAPI ~ client) => ClientLike client GenericClient
265+
266+type NestedAPI1
267+ = QueryParam "int" Int :> NestedAPI2
268+ :<|> QueryParam "id" Char :> Get '[JSON] Char
269+
270+data NestedClient1 = NestedClient1
271+ { mkNestedClient2 :: Maybe Int -> NestedClient2
272+ , idChar :: Maybe Char -> ClientM Char
273+ } deriving Generic
274+instance SOP.Generic NestedClient1
275+instance (Client ClientM NestedAPI1 ~ client) => ClientLike client NestedClient1
276+
277+type NestedAPI2
278+ = "sum" :> Capture "first" Int :> Capture "second" Int :> Get '[JSON] Int
279+ :<|> "void" :> Post '[JSON] ()
280+
281+data NestedClient2 = NestedClient2
282+ { getSum :: Int -> Int -> ClientM Int
283+ , doNothing :: ClientM ()
284+ } deriving Generic
285+instance SOP.Generic NestedClient2
286+instance (Client ClientM NestedAPI2 ~ client) => ClientLike client NestedClient2
287+
288+genericClientServer :: Application
289+genericClientServer = serve (Proxy :: Proxy GenericClientAPI) (
290+ (\ mx -> case mx of
291+ Just x -> return (x*x)
292+ Nothing -> throwError $ ServantErr 400 "missing parameter" "" []
293+ )
294+ :<|> nestedServer1
295+ )
260 where
296 where
261− runClientMUnsafe x env = withClientM x env return
297+ nestedServer1 _str = nestedServer2 :<|> (maybe (throwError $ ServantErr 400 "missing parameter" "" []) return)
298+ nestedServer2 _int = (\ x y -> return (x + y)) :<|> return ()
299+
300+{-# NOINLINE manager' #-}
301+manager' :: C.Manager
302+manager' = unsafePerformIO $ C.newManager C.defaultManagerSettings
303+
304+runClient :: ClientM a -> BaseUrl -> IO (Either ServantError a)
305+runClient x baseUrl' = runClientM x (mkClientEnv manager' baseUrl')
262
306
263−successSpec :: Spec
307+sucessSpec :: Spec
264−successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
308+sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
265 it "Servant.API.Get root" $ \(_, baseUrl) -> do
309 it "Servant.API.Get root" $ \(_, baseUrl) -> do
266 left show <$> runClient getRoot baseUrl `shouldReturn` Right carol
310 left show <$> runClient getRoot baseUrl `shouldReturn` Right carol
267
311
@@ -286,16 +330,9 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
286 let p = Person "Clara" 42
330 let p = Person "Clara" 42
287 left show <$> runClient (getBody p) baseUrl `shouldReturn` Right p
331 left show <$> runClient (getBody p) baseUrl `shouldReturn` Right p
288
332
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−
296 it "Servant.API.QueryParam" $ \(_, baseUrl) -> do
333 it "Servant.API.QueryParam" $ \(_, baseUrl) -> do
297 left show <$> runClient (getQueryParam (Just "alice")) baseUrl `shouldReturn` Right alice
334 left show <$> runClient (getQueryParam (Just "alice")) baseUrl `shouldReturn` Right alice
298− Left (FailureResponse _ r) <- runClient (getQueryParam (Just "bob")) baseUrl
335+ Left (FailureResponse r) <- runClient (getQueryParam (Just "bob")) baseUrl
299 responseStatusCode r `shouldBe` HTTP.Status 400 "bob not found"
336 responseStatusCode r `shouldBe` HTTP.Status 400 "bob not found"
300
337
301 it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do
338 it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do
@@ -319,7 +356,7 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
319 res <- runClient (getRawFailure HTTP.methodGet) baseUrl
356 res <- runClient (getRawFailure HTTP.methodGet) baseUrl
320 case res of
357 case res of
321 Right _ -> assertFailure "expected Left, but got Right"
358 Right _ -> assertFailure "expected Left, but got Right"
322− Left (FailureResponse _ r) -> do
359+ Left (FailureResponse r) -> do
323 responseStatusCode r `shouldBe` HTTP.status400
360 responseStatusCode r `shouldBe` HTTP.status400
324 responseBody r `shouldBe` "rawFailure"
361 responseBody r `shouldBe` "rawFailure"
325 Left e -> assertFailure $ "expected FailureResponse, but got " ++ show e
362 Left e -> assertFailure $ "expected FailureResponse, but got " ++ show e
@@ -341,14 +378,14 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
341
378
342wrappedApiSpec :: Spec
379wrappedApiSpec :: Spec
343wrappedApiSpec = describe "error status codes" $ do
380wrappedApiSpec = describe "error status codes" $ do
344− let serveW api = serve api $ throwError $ ServerError 500 "error message" "" []
381+ let serveW api = serve api $ throwError $ ServantErr 500 "error message" "" []
345 context "are correctly handled by the client" $
382 context "are correctly handled by the client" $
346 let test :: (WrappedApi, String) -> Spec
383 let test :: (WrappedApi, String) -> Spec
347 test (WrappedApi api, desc) =
384 test (WrappedApi api, desc) =
348 it desc $ bracket (startWaiApp $ serveW api) endWaiApp $ \(_, baseUrl) -> do
385 it desc $ bracket (startWaiApp $ serveW api) endWaiApp $ \(_, baseUrl) -> do
349 let getResponse :: ClientM ()
386 let getResponse :: ClientM ()
350 getResponse = client api
387 getResponse = client api
351− Left (FailureResponse _ r) <- runClient getResponse baseUrl
388+ Left (FailureResponse r) <- runClient getResponse baseUrl
352 responseStatusCode r `shouldBe` (HTTP.Status 500 "error message")
389 responseStatusCode r `shouldBe` (HTTP.Status 500 "error message")
353 in mapM_ test $
390 in mapM_ test $
354 (WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") :
391 (WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") :
@@ -365,7 +402,7 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
365 let (_ :<|> _ :<|> getDeleteEmpty :<|> _) = client api
402 let (_ :<|> _ :<|> getDeleteEmpty :<|> _) = client api
366 Left res <- runClient getDeleteEmpty baseUrl
403 Left res <- runClient getDeleteEmpty baseUrl
367 case res of
404 case res of
368− FailureResponse _ r | responseStatusCode r == HTTP.status404 -> return ()
405+ FailureResponse r | responseStatusCode r == HTTP.status404 -> return ()
369 _ -> fail $ "expected 404 response, but got " <> show res
406 _ -> fail $ "expected 404 response, but got " <> show res
370
407
371 it "reports DecodeFailure" $ \(_, baseUrl) -> do
408 it "reports DecodeFailure" $ \(_, baseUrl) -> do
@@ -375,8 +412,7 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
375 DecodeFailure _ _ -> return ()
412 DecodeFailure _ _ -> return ()
376 _ -> fail $ "expected DecodeFailure, but got " <> show res
413 _ -> fail $ "expected DecodeFailure, but got " <> show res
377
414
378− -- we don't catch IOException's
379− xit "reports ConnectionError" $ \_ -> do
415+ it "reports ConnectionError" $ \_ -> do
380 let (getGetWrongHost :<|> _) = client api
416 let (getGetWrongHost :<|> _) = client api
381 Left res <- runClient getGetWrongHost (BaseUrl Http "127.0.0.1" 19872 "")
417 Left res <- runClient getGetWrongHost (BaseUrl Http "127.0.0.1" 19872 "")
382 case res of
418 case res of
@@ -416,7 +452,7 @@ basicAuthSpec = beforeAll (startWaiApp basicAuthServer) $ afterAll endWaiApp $ d
416 it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do
452 it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do
417 let getBasic = client basicAuthAPI
453 let getBasic = client basicAuthAPI
418 let basicAuthData = BasicAuthData "not" "password"
454 let basicAuthData = BasicAuthData "not" "password"
419− Left (FailureResponse _ r) <- runClient (getBasic basicAuthData) baseUrl
455+ Left (FailureResponse r) <- runClient (getBasic basicAuthData) baseUrl
420 responseStatusCode r `shouldBe` HTTP.Status 403 "Forbidden"
456 responseStatusCode r `shouldBe` HTTP.Status 403 "Forbidden"
421
457
422genAuthSpec :: Spec
458genAuthSpec :: Spec
@@ -433,45 +469,24 @@ genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do
433 it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do
469 it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do
434 let getProtected = client genAuthAPI
470 let getProtected = client genAuthAPI
435 let authRequest = Auth.mkAuthenticatedRequest () (\_ req -> Req.addHeader "Wrong" ("header" :: String) req)
471 let authRequest = Auth.mkAuthenticatedRequest () (\_ req -> Req.addHeader "Wrong" ("header" :: String) req)
436− Left (FailureResponse _ r) <- runClient (getProtected authRequest) baseUrl
472+ Left (FailureResponse r) <- runClient (getProtected authRequest) baseUrl
437 responseStatusCode r `shouldBe` (HTTP.Status 401 "Unauthorized")
473 responseStatusCode r `shouldBe` (HTTP.Status 401 "Unauthorized")
438
474
439−-- * hoistClient
475+genericClientSpec :: Spec
440−
441−type HoistClientAPI = Get '[JSON] Int :<|> Capture "n" Int :> Post '[JSON] Int
442−
443−hoistClientAPI :: Proxy HoistClientAPI
444−hoistClientAPI = Proxy
445−
446−hoistClientServer :: Application -- implements HoistClientAPI
447−hoistClientServer = serve hoistClientAPI $ return 5 :<|> (\n -> return n)
448−
449−hoistClientSpec :: Spec
450−hoistClientSpec = beforeAll (startWaiApp hoistClientServer) $ afterAll endWaiApp $ do
476+genericClientSpec = beforeAll (startWaiApp genericClientServer) $ afterAll endWaiApp $ do
451− describe "Servant.Client.hoistClient" $ do
477+ describe "Servant.Client.Generic" $ do
452− it "allows us to GET/POST/... requests in IO instead of ClientM" $ \(_, baseUrl) -> do
453− let (getInt :<|> postInt)
454− = hoistClient hoistClientAPI
455− (fmap (either (error . show) id) . flip runClientUnsafe baseUrl)
456− (client hoistClientAPI)
457−
458− getInt `shouldReturn` 5
459− postInt 5 `shouldReturn` 5
460
478
461−-- * ConnectionError
479+ let GenericClient{..} = mkClient (client (Proxy :: Proxy GenericClientAPI))
462−type ConnectionErrorAPI = Get '[JSON] Int
480+ NestedClient1{..} = mkNestedClient1 "example"
481+ NestedClient2{..} = mkNestedClient2 (Just 42)
463
482
464−connectionErrorAPI :: Proxy ConnectionErrorAPI
483+ it "works for top-level client inClientM function" $ \(_, baseUrl) -> do
465−connectionErrorAPI = Proxy
484+ left show <$> runClient (getSqr (Just 5)) baseUrl `shouldReturn` Right 25
466
485
467−connectionErrorSpec :: Spec
486+ it "works for nested clients" $ \(_, baseUrl) -> do
468−connectionErrorSpec = describe "Servant.Client.ClientError" $
487+ left show <$> runClient (idChar (Just 'c')) baseUrl `shouldReturn` Right 'c'
469− xit "correctly catches ConnectionErrors when the HTTP request can't go through" $ do
488+ left show <$> runClient (getSum 3 4) baseUrl `shouldReturn` Right 7
470− let getInt = client connectionErrorAPI
489+ left show <$> runClient doNothing baseUrl `shouldReturn` Right ()
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
490
476-- * utils
491-- * utils
477
492
@@ -480,7 +495,7 @@ startWaiApp app = do
480 (port, socket) <- openTestSocket
495 (port, socket) <- openTestSocket
481 let settings = setPort port $ defaultSettings
496 let settings = setPort port $ defaultSettings
482 thread <- forkIO $ runSettingsSocket settings socket app
497 thread <- forkIO $ runSettingsSocket settings socket app
483− return (thread, BaseUrl Http "127.0.0.1" port "")
498+ return (thread, BaseUrl Http "localhost" port "")
484
499
485
500
486endWaiApp :: (ThreadId, BaseUrl) -> IO ()
501endWaiApp :: (ThreadId, BaseUrl) -> IO ()
@@ -489,8 +504,8 @@ endWaiApp (thread, _) = killThread thread
489openTestSocket :: IO (Port, Socket)
504openTestSocket :: IO (Port, Socket)
490openTestSocket = do
505openTestSocket = do
491 s <- socket AF_INET Stream defaultProtocol
506 s <- socket AF_INET Stream defaultProtocol
492− let localhost = tupleToHostAddress (127, 0, 0, 1)
507+ localhost <- inet_addr "127.0.0.1"
493− bind s (SockAddrInet defaultPort localhost)
508+ bind s (SockAddrInet aNY_PORT localhost)
494 listen s 1
509 listen s 1
495 port <- socketPort s
510 port <- socketPort s
496 return (fromIntegral port, s)
511 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+64−134
@@ -15,72 +15,60 @@
15{-# LANGUAGE TypeFamilies #-}
15{-# LANGUAGE TypeFamilies #-}
16{-# LANGUAGE TypeOperators #-}
16{-# LANGUAGE TypeOperators #-}
17{-# LANGUAGE UndecidableInstances #-}
17{-# LANGUAGE UndecidableInstances #-}
18+#if __GLASGOW_HASKELL__ >= 800
18{-# OPTIONS_GHC -freduction-depth=100 #-}
19{-# OPTIONS_GHC -freduction-depth=100 #-}
20+#else
21+{-# OPTIONS_GHC -fcontext-stack=100 #-}
22+#endif
19{-# OPTIONS_GHC -fno-warn-orphans #-}
23{-# OPTIONS_GHC -fno-warn-orphans #-}
20{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
24{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
21
25
26+#include "overlapping-compat.h"
22module Servant.StreamSpec (spec) where
27module Servant.StreamSpec (spec) where
23
28
24−import 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
32−import Data.Proxy
33−import qualified Data.TDigest as TD
34−import qualified Network.HTTP.Client as C
35−import Prelude ()
29+import Prelude ()
36import Prelude.Compat
30import Prelude.Compat
37−import Servant.API
31+import Data.Proxy
38− ((:<|>) ((:<|>)), (:>), JSON, NetstringFraming, StreamBody,
32+import qualified Network.HTTP.Client as C
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)
47−import System.IO.Unsafe
33+import System.IO.Unsafe (unsafePerformIO)
48− (unsafePerformIO)
49−import System.Mem
50− (performGC)
51import Test.Hspec
34import Test.Hspec
52−import Servant.ClientTestUtils (Person(..))
53−import qualified Servant.ClientTestUtils as CT
54
35
55−#if MIN_VERSION_base(4,10,0)
36+import Servant.API ((:<|>) ((:<|>)),
56−import GHC.Stats
37+ (:>),
57− (gc, gcdetails_live_bytes, getRTSStats)
38+ EmptyAPI, JSON,
58−#else
39+ StreamGet,
59−import GHC.Stats
40+ NewlineFraming,
60− (currentBytesUsed, getGCStats)
41+ NetstringFraming,
61−#endif
42+ ResultStream(..),
43+ StreamGenerator(..))
44+import Servant.Client
45+import Servant.Server
46+import qualified Servant.ClientSpec as CS
47+import Servant.ClientSpec (Person(..))
62
48
63−-- This declaration simply checks that all instances are in place.
64−-- Note: this is streaming client
65−_ = client comprehensiveAPI
66
49
67spec :: Spec
50spec :: Spec
68−spec = describe "Servant.Client.Streaming" $ do
51+spec = describe "Servant.Stream" $ do
69 streamSpec
52 streamSpec
70
53
71−type StreamApi =
54+type StreamApi f =
72− "streamGetNewline" :> StreamGet NewlineFraming JSON (SourceIO Person)
55+ "streamGetNewline" :> StreamGet NewlineFraming JSON (f Person)
73− :<|> "streamGetNetstring" :> StreamGet NetstringFraming JSON (SourceIO Person)
56+ :<|> "streamGetNetstring" :> StreamGet NetstringFraming JSON (f Person)
74− :<|> "streamALot" :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString)
57+ :<|> EmptyAPI
75− :<|> "streamBody" :> StreamBody NoFraming OctetStream (SourceIO BS.ByteString) :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString)
58+
76
59
77−api :: Proxy StreamApi
60+capi :: Proxy (StreamApi ResultStream)
78−api = Proxy
61+capi = Proxy
79
62
80−getGetNL, getGetNS :: ClientM (SourceIO Person)
63+sapi :: Proxy (StreamApi StreamGenerator)
81−getGetALot :: ClientM (SourceIO BS.ByteString)
64+sapi = Proxy
82−getStreamBody :: SourceT IO BS.ByteString -> ClientM (SourceIO BS.ByteString)
65+
66+
83−getGetNL :<|> getGetNS :<|> getGetALot :<|> getStreamBody = client api
67+getGetNL :<|> getGetNS :<|> EmptyClient = client capi
68+
69+
70+getGetNL :: ClientM (ResultStream Person)
71+getGetNS :: ClientM (ResultStream Person)
84
72
85alice :: Person
73alice :: Person
86alice = Person "Alice" 42
74alice = Person "Alice" 42
@@ -89,95 +77,37 @@ bob :: Person
89bob = Person "Bob" 25
77bob = Person "Bob" 25
90
78
91server :: Application
79server :: Application
92−server = serve api
80+server = serve sapi (
93− $ return (source [alice, bob, alice])
81+ (return (StreamGenerator (\f r -> f alice >> r bob >> r alice))
94− :<|> return (source [alice, bob, alice])
82+ :: Handler (StreamGenerator Person))
95− -- 2 ^ (18 + 10) = 256M
96− :<|> return (SourceT ($ lots (powerOfTwo 18)))
97− :<|> return
83+ :<|>
98− where
84+ (return (StreamGenerator (\f r -> f alice >> r bob >> r alice))
99− lots n
85+ :: Handler (StreamGenerator Person))
100− | n < 0 = Stop
86+ :<|>
101− | otherwise = Effect $ do
87+ emptyServer)
102− let size = powerOfTwo 10
88+
103− mbs <- getHardwareEntropy size
104− bs <- maybe (getEntropy size) pure mbs
105− return (Yield bs (lots (n - 1)))
106−
107−powerOfTwo :: Int -> Int
108−powerOfTwo = (2 ^)
109
89
110{-# NOINLINE manager' #-}
90{-# NOINLINE manager' #-}
111manager' :: C.Manager
91manager' :: C.Manager
112manager' = unsafePerformIO $ C.newManager C.defaultManagerSettings
92manager' = unsafePerformIO $ C.newManager C.defaultManagerSettings
113
93
114−withClient :: ClientM a -> BaseUrl -> (Either ClientError a -> IO r) -> IO r
94+runClient :: ClientM a -> BaseUrl -> IO (Either ServantError a)
115−withClient x baseUrl' = withClientM x (mkClientEnv manager' baseUrl')
95+runClient x baseUrl' = runClientM x (mkClientEnv manager' baseUrl')
116
96
117−testRunSourceIO :: SourceIO a
97+runResultStream :: ResultStream a -> IO (Maybe (Either String a), Maybe (Either String a), Maybe (Either String a), Maybe (Either String a))
118− -> IO (Either String [a])
98+runResultStream (ResultStream k) = k $ \act -> (,,,) <$> act <*> act <*> act <*> act
119−testRunSourceIO = runExceptT . runSourceT
120
99
121streamSpec :: Spec
100streamSpec :: Spec
122−streamSpec = beforeAll (CT.startWaiApp server) $ afterAll CT.endWaiApp $ do
101+streamSpec = beforeAll (CS.startWaiApp server) $ afterAll CS.endWaiApp $ do
102+
123− it "works with Servant.API.StreamGet.Newline" $ \(_, baseUrl) -> do
103+ it "Servant.API.StreamGet.Newline" $ \(_, baseUrl) -> do
124− withClient getGetNL baseUrl $ \(Right res) ->
104+ Right res <- runClient getGetNL baseUrl
125− testRunSourceIO res `shouldReturn` Right [alice, bob, alice]
105+ let jra = Just (Right alice)
126−
106+ jrb = Just (Right bob)
107+ runResultStream res `shouldReturn` (jra, jrb, jra, Nothing)
108+
127− it "works with Servant.API.StreamGet.Netstring" $ \(_, baseUrl) -> do
109+ it "Servant.API.StreamGet.Netstring" $ \(_, baseUrl) -> do
128− withClient getGetNS baseUrl $ \(Right res) ->
110+ Right res <- runClient getGetNS baseUrl
129− testRunSourceIO res `shouldReturn` Right [alice, bob, alice]
111+ let jra = Just (Right alice)
130−
112+ jrb = Just (Right bob)
131− it "works with Servant.API.StreamBody" $ \(_, baseUrl) -> do
113+ runResultStream res `shouldReturn` (jra, jrb, jra, Nothing)
132− withClient (getStreamBody (source input)) baseUrl $ \(Right res) ->
133− testRunSourceIO res `shouldReturn` Right output
134− where
135− input = ["foo", "", "bar"]
136− output = ["foo", "bar"]
137−
138−{-
139− 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 .
174−#if MIN_VERSION_base(4,10,0)
175− gcdetails_live_bytes . gc <$> getRTSStats
176−#else
177− currentBytesUsed <$> getGCStats
178−#endif
179− memUsed `shouldSatisfy` (< megabytes 22)
180−
181−megabytes :: Num a => a -> a
182−megabytes 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 @@
1[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-docs/CHANGELOG.md)
1[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-docs/CHANGELOG.md)
2[Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)
2[Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)
3
3
4−0.12
5−----
6−
7−### Significant changes
8−
9−- Generate sample cURL requests
10− ([#1401](https://github.com/haskell-servant/servant/pull/1401/files)).
11− Breaking change: requires sample header values to be supplied with `headers`.
12−
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−
950.11.2
40.11.2
96------
5------
97
6
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
2
2
3All rights reserved.
3All rights reserved.
4
4
servant-docs/README.md+11−44
@@ -2,56 +2,24 @@
2
2
3![servant](https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png)
3![servant](https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png)
4
4
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**.
6
6
7## Example
7## Example
8
8
9See [here](https://github.com/haskell-servant/servant/blob/master/servant-docs/example/greet.md) for the output of the following program.
9See [here](https://github.com/haskell-servant/servant/blob/master/servant-docs/example/greet.md) for the output of the following program.
10
10
11−```haskell
11+``` haskell
12{-# LANGUAGE DataKinds #-}
12{-# LANGUAGE DataKinds #-}
13−{-# LANGUAGE DeriveGeneric #-}
14−{-# LANGUAGE FlexibleInstances #-}
15−{-# LANGUAGE MultiParamTypeClasses #-}
16−{-# LANGUAGE OverloadedStrings #-}
17{-# LANGUAGE PolyKinds #-}
13{-# LANGUAGE PolyKinds #-}
18{-# LANGUAGE TypeFamilies #-}
14{-# LANGUAGE TypeFamilies #-}
15+{-# LANGUAGE DeriveGeneric #-}
19{-# LANGUAGE TypeOperators #-}
16{-# LANGUAGE TypeOperators #-}
17+{-# LANGUAGE FlexibleInstances #-}
18+{-# LANGUAGE OverloadedStrings #-}
20
19
21−import Data.Aeson (FromJSON, ToJSON)
20+import Data.Proxy
22−import Data.Proxy (Proxy (..))
23−import Data.String.Conversions (cs)
24−import Data.Text (Text)
21+import Data.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− )
40import Servant.Docs
22import 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− )
55
23
56-- our type for a Greeting message
24-- our type for a Greeting message
57data Greet = Greet { _msg :: Text }
25data Greet = Greet { _msg :: Text }
@@ -61,7 +29,6 @@ data Greet = Greet { _msg :: Text }
61-- 'MimeRender' instance for 'JSON'.
29-- 'MimeRender' instance for 'JSON'.
62instance FromJSON Greet
30instance FromJSON Greet
63instance ToJSON Greet
31instance ToJSON Greet
64−instance ToSample ()
65
32
66-- We can also implement 'MimeRender' explicitly for additional formats.
33-- We can also implement 'MimeRender' explicitly for additional formats.
67instance MimeRender PlainText Greet where
34instance MimeRender PlainText Greet where
@@ -69,7 +36,8 @@ instance MimeRender PlainText Greet where
69
36
70-- we provide a sample value for the 'Greet' type
37-- we provide a sample value for the 'Greet' type
71instance ToSample Greet where
38instance ToSample Greet where
72− toSamples _ = singleSample g
39+ toSample = Just g
40+
73 where g = Greet "Hello, haskeller!"
41 where g = Greet "Hello, haskeller!"
74
42
75instance ToParam (QueryParam "capital" Bool) where
43instance ToParam (QueryParam "capital" Bool) where
@@ -77,7 +45,6 @@ instance ToParam (QueryParam "capital" Bool) where
77 DocQueryParam "capital"
45 DocQueryParam "capital"
78 ["true", "false"]
46 ["true", "false"]
79 "Get the greeting message in uppercase (true) or not (false). Default is false."
47 "Get the greeting message in uppercase (true) or not (false). Default is false."
80− Normal
81
48
82instance ToCapture (Capture "name" Text) where
49instance ToCapture (Capture "name" Text) where
83 toCapture _ = DocCapture "name" "name of the person to greet"
50 toCapture _ = DocCapture "name" "name of the person to greet"
@@ -88,8 +55,8 @@ instance ToCapture (Capture "greetid" Text) where
88-- API specification
55-- API specification
89type TestApi =
56type TestApi =
90 "hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get '[JSON,PlainText] Greet
57 "hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get '[JSON,PlainText] Greet
91− :<|> "greet" :> ReqBody '[JSON] Greet :> Post '[JSON] Greet
58+ :<|> "greet" :> RQBody '[JSON] Greet :> Post '[JSON] Greet
92− :<|> "delete" :> Capture "greetid" Text :> Delete '[JSON] ()
59+ :<|> "delete" :> Capture "greetid" Text :> Delete '[] ()
93
60
94testApi :: Proxy TestApi
61testApi :: Proxy TestApi
95testApi = Proxy
62testApi = Proxy
servant-docs/example/greet.hs+12−13
@@ -5,15 +5,14 @@
5{-# LANGUAGE OverloadedStrings #-}
5{-# LANGUAGE OverloadedStrings #-}
6{-# LANGUAGE TypeOperators #-}
6{-# LANGUAGE TypeOperators #-}
7{-# OPTIONS_GHC -fno-warn-orphans #-}
7{-# OPTIONS_GHC -fno-warn-orphans #-}
8−import Control.Lens
8+import Control.Lens
9−import Data.Aeson
9+import Data.Aeson
10−import Data.Proxy
10+import Data.Proxy
11−import Data.String.Conversions
11+import Data.String.Conversions
12−import Data.Text
12+import Data.Text (Text)
13− (Text)
14−import GHC.Generics
13+import GHC.Generics
15−import Servant.API
14+import Servant.API
16−import Servant.Docs
15+import Servant.Docs
17
16
18-- * Example
17-- * Example
19
18
@@ -75,7 +74,7 @@ intro2 = DocIntro "This title is below the last"
75-- API specification
74-- API specification
76type TestApi =
75type TestApi =
77 -- GET /hello/:name?capital={true, false} returns a Greet as JSON or PlainText
76 -- 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
77+ "hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get '[JSON, PlainText] Greet
79
78
80 -- POST /greet with a Greet as JSON in the request body,
79 -- POST /greet with a Greet as JSON in the request body,
81 -- returns a Greet as JSON
80 -- returns a Greet as JSON
@@ -93,9 +92,9 @@ testApi = Proxy
93extra :: ExtraInfo TestApi
92extra :: ExtraInfo TestApi
94extra =
93extra =
95 extraInfo (Proxy :: Proxy ("greet" :> Capture "greetid" Text :> Delete '[JSON] NoContent)) $
94 extraInfo (Proxy :: Proxy ("greet" :> Capture "greetid" Text :> Delete '[JSON] NoContent)) $
96− defAction & headers <>~ [("X-Num-Unicorns", "1")]
95+ defAction & headers <>~ ["unicorns"]
97 & notes <>~ [ DocNote "Title" ["This is some text"]
96 & notes <>~ [ DocNote "Title" ["This is some text"]
98− , DocNote "Second section" ["And some more"]
97+ , DocNote "Second secton" ["And some more"]
99 ]
98 ]
100
99
101-- Generate the data that lets us have API docs. This
100-- Generate the data that lets us have API docs. This
@@ -109,4 +108,4 @@ docsGreet :: API
109docsGreet = docsWith defaultDocOptions [intro1, intro2] extra testApi
108docsGreet = docsWith defaultDocOptions [intro1, intro2] extra testApi
110
109
111main :: IO ()
110main :: IO ()
112−main = putStrLn $ markdownWith (defRenderingOptions { _renderCurlBasePath = Just "http://localhost:80" }) docsGreet
111+main = putStrLn $ markdown docsGreet
servant-docs/example/greet.md+27−55
@@ -10,144 +10,116 @@ You'll also note that multiple intros are possible.
10
10
11## POST /greet
11## POST /greet
12
12
13−### Request:
13+#### Request:
14
14
15- Supported content types are:
15- Supported content types are:
16
16
17− - `application/json;charset=utf-8`
18 - `application/json`
17 - `application/json`
19
18
20−- If you use ?capital=true (`application/json;charset=utf-8`, `application/json`):
19+- Example: `application/json`
21
20
22```javascript
21```javascript
23"HELLO, HASKELLER"
22"HELLO, HASKELLER"
24```
23```
25
24
26−- If you use ?capital=false (`application/json;charset=utf-8`, `application/json`):
25+#### Response:
27
26
28−```javascript
29−"Hello, haskeller"
30−```
31−
32−### Response:
33−
34−- Status code 200
27+- Status code 201
35- Headers: [("X-Example","1729")]
28- Headers: [("X-Example","1729")]
36
29
37- Supported content types are:
30- Supported content types are:
38
31
39− - `application/json;charset=utf-8`
40 - `application/json`
32 - `application/json`
41
33
42−- If you use ?capital=true (`application/json;charset=utf-8`, `application/json`):
34+- If you use ?capital=true
43
35
44```javascript
36```javascript
45"HELLO, HASKELLER"
37"HELLO, HASKELLER"
46```
38```
47
39
48−- If you use ?capital=false (`application/json;charset=utf-8`, `application/json`):
40+- If you use ?capital=false
49
41
50```javascript
42```javascript
51"Hello, haskeller"
43"Hello, haskeller"
52```
44```
53
45
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−
63## DELETE /greet/:greetid
46## DELETE /greet/:greetid
64
47
65−### Title
48+#### Title
66
49
67This is some text
50This is some text
68
51
69−### Second section
52+#### Second secton
70
53
71And some more
54And some more
72
55
73−### Captures:
56+#### Captures:
74
57
75- *greetid*: identifier of the greet msg to remove
58- *greetid*: identifier of the greet msg to remove
76
59
77−### Headers:
78
60
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.
80
62
81−### Response:
63+#### Response:
82
64
83- Status code 200
65- Status code 200
84- Headers: []
66- Headers: []
85
67
86- Supported content types are:
68- Supported content types are:
87
69
88− - `application/json;charset=utf-8`
89 - `application/json`
70 - `application/json`
90
71
91−- Example (`application/json;charset=utf-8`, `application/json`):
72+- Response body as below.
92
73
93```javascript
74```javascript
94−
75+[]
95−```
96−
97−### Sample Request:
98−
99−```bash
100−curl -XDELETE \
101− -H "X-Num-Unicorns: 1" \
102− http://localhost:80/greet/:greetid
103```
76```
104
77
105## GET /hello/:name
78## GET /hello/:name
106
79
107−### Captures:
80+#### Captures:
108
81
109- *name*: name of the person to greet
82- *name*: name of the person to greet
110
83
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:
116
85
117- capital
86- capital
118 - **Values**: *true, false*
87 - **Values**: *true, false*
119 - **Description**: Get the greeting message in uppercase (true) or not (false).Default is false.
88 - **Description**: Get the greeting message in uppercase (true) or not (false).Default is false.
120
89
121
90
122−### Response:
91+#### Response:
123
92
124- Status code 200
93- Status code 200
125- Headers: []
94- Headers: []
126
95
127- Supported content types are:
96- Supported content types are:
128
97
129− - `application/json;charset=utf-8`
130 - `application/json`
98 - `application/json`
131 - `text/plain;charset=utf-8`
99 - `text/plain;charset=utf-8`
132
100
133−- If you use ?capital=true (`application/json;charset=utf-8`, `application/json`, `text/plain;charset=utf-8`):
101+- If you use ?capital=true
134
102
135```javascript
103```javascript
136"HELLO, HASKELLER"
104"HELLO, HASKELLER"
137```
105```
138
106
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
140
114
141```javascript
115```javascript
142"Hello, haskeller"
116"Hello, haskeller"
143```
117```
144
118
145−### Sample Request:
119+- If you use ?capital=false
146
120
147−```bash
121+```
148−curl -XGET \
122+"Hello, haskeller"
149− -H "X-Num-Fairies: 1729" \
150− http://localhost:80/hello/:name
151```
123```
152
124
153
125
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/include/overlapping-compat.hnew file+8
@@ -0,0 +1,8 @@
1+#if __GLASGOW_HASKELL__ >= 710
2+#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}
3+#define OVERLAPPING_ {-# OVERLAPPING #-}
4+#else
5+{-# LANGUAGE OverlappingInstances #-}
6+#define OVERLAPPABLE_
7+#define OVERLAPPING_
8+#endif
servant-docs/servant-docs.cabal+39−33
@@ -1,31 +1,31 @@
1−cabal-version: 2.2
2name: servant-docs
1name: servant-docs
3−version: 0.12
2+version: 0.11.2
4−
5synopsis: generate API docs for your servant webservice
3synopsis: generate API docs for your servant webservice
6−category: Servant, Web
7description:
4description:
8 Library for generating API docs from a servant API definition.
5 Library for generating API docs from a servant API definition.
9 .
6 .
10 Runnable example <https://github.com/haskell-servant/servant/blob/master/servant-docs/example/greet.hs here>.
7 Runnable example <https://github.com/haskell-servant/servant/blob/master/servant-docs/example/greet.hs here>.
11 .
8 .
12 <https://github.com/haskell-servant/servant/blob/master/servant-docs/CHANGELOG.md CHANGELOG>
9 <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
10+license: BSD3
17license-file: LICENSE
11license-file: LICENSE
18author: Servant Contributors
12author: Servant Contributors
19maintainer: haskell-servant-maintainers@googlegroups.com
13maintainer: haskell-servant-maintainers@googlegroups.com
20−copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors
14+copyright: 2014-2016 Zalora South East Asia Pte Ltd, Servant Contributors
15+category: Servant, Web
21build-type: Simple
16build-type: Simple
17+cabal-version: >=1.10
22−tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1
18+tested-with:
23−
19+ GHC==7.8.4
20+ GHC==7.10.3
21+ GHC==8.0.2
22+ GHC==8.2.2
23+homepage: http://haskell-servant.readthedocs.org/
24+Bug-reports: http://github.com/haskell-servant/servant/issues
24extra-source-files:
25extra-source-files:
26+ include/*.h
25 CHANGELOG.md
27 CHANGELOG.md
26 README.md
28 README.md
27− golden/comprehensive.md
28−
29source-repository head
29source-repository head
30 type: git
30 type: git
31 location: http://github.com/haskell-servant/servant.git
31 location: http://github.com/haskell-servant/servant.git
@@ -41,32 +41,39 @@ library
41 --
41 --
42 -- note: mtl lower bound is so low because of GHC-7.8
42 -- note: mtl lower bound is so low because of GHC-7.8
43 build-depends:
43 build-depends:
44− base >= 4.9 && < 4.18
44+ base >= 4.7 && < 4.11
45− , bytestring >= 0.10.8.1 && < 0.12
45+ , bytestring >= 0.10.4.0 && < 0.11
46− , text >= 1.2.3.0 && < 2.1
46+ , text >= 1.2.3.0 && < 1.3
47+
48+ if !impl(ghc >= 8.0)
49+ build-depends:
50+ semigroups >=0.18.3 && <0.19
47
51
48 -- Servant dependencies
52 -- Servant dependencies
49 build-depends:
53 build-depends:
50− servant >= 0.18 && <0.20
54+ servant == 0.13.*
51
55
52 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.
56 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.
53 -- Here can be exceptions if we really need features from the newer versions.
57 -- Here can be exceptions if we really need features from the newer versions.
54 build-depends:
58 build-depends:
55− aeson >= 1.4.1.0 && < 3
59+ aeson >= 1.2.3.0 && < 1.3
56 , aeson-pretty >= 0.8.5 && < 0.9
60 , aeson-pretty >= 0.8.5 && < 0.9
57− , base-compat >= 0.10.5 && < 0.13
61+ , base-compat >= 0.9.3 && < 0.10
58− , case-insensitive >= 1.2.0.11 && < 1.3
62+ , case-insensitive >= 1.2.0.10 && < 1.3
63+ , control-monad-omega >= 0.3.1 && < 0.4
59− , hashable >= 1.2.7.0 && < 1.5
64+ , hashable >= 1.2.6.1 && < 1.3
60− , http-media >= 0.7.1.3 && < 0.9
65+ , http-media >= 0.7.1.1 && < 0.8
61− , http-types >= 0.12.2 && < 0.13
66+ , http-types >= 0.12 && < 0.13
62− , lens >= 4.17 && < 5.3
67+ , lens >= 4.15.4 && < 4.17
63 , string-conversions >= 0.4.0.1 && < 0.5
68 , 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
69+ , unordered-containers >= 0.2.8.0 && < 0.3
66
70
67 hs-source-dirs: src
71 hs-source-dirs: src
68 default-language: Haskell2010
72 default-language: Haskell2010
73+ ghc-options: -Wall
74+ if impl(ghc >= 8.0)
69− ghc-options: -Wall -Wno-redundant-constraints
75+ ghc-options: -Wno-redundant-constraints
76+ include-dirs: include
70
77
71executable greet-docs
78executable greet-docs
72 main-is: greet.hs
79 main-is: greet.hs
@@ -93,16 +100,15 @@ test-suite spec
93 -- Dependencies inherited from the library. No need to specify bounds.
100 -- Dependencies inherited from the library. No need to specify bounds.
94 build-depends:
101 build-depends:
95 base
102 base
96− , base-compat
97 , aeson
103 , aeson
98 , lens
104 , lens
99 , servant
105 , servant
100 , servant-docs
106 , servant-docs
101 , string-conversions
107 , string-conversions
102
108
103− -- Additional dependencies
109+ -- Additonal dependencies
104 build-depends:
110 build-depends:
105− tasty >= 1.1.0.4 && < 1.5,
111+ hspec >= 2.4.4 && < 2.5
106− tasty-golden >= 2.3.2 && < 2.4,
112+
107− tasty-hunit >= 0.10.0.1 && < 0.11,
113+ build-tool-depends:
108− transformers >= 0.5.2.0 && < 0.6
114+ hspec-discover:hspec-discover >=2.4.4 && <2.5
servant-docs/src/Servant/Docs.hs+2−2
@@ -56,5 +56,5 @@ module Servant.Docs
56 , single
56 , single
57 ) where
57 ) where
58
58
59−import Servant.Docs.Internal
59+import Servant.Docs.Internal
60−import Servant.Docs.Internal.Pretty
60+import Servant.Docs.Internal.Pretty
servant-docs/src/Servant/Docs/Internal.hs+88−273
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
1{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE DefaultSignatures #-}
4{-# LANGUAGE DefaultSignatures #-}
@@ -16,55 +17,41 @@
16{-# LANGUAGE TypeOperators #-}
17{-# LANGUAGE TypeOperators #-}
17{-# LANGUAGE UndecidableInstances #-}
18{-# LANGUAGE UndecidableInstances #-}
18
19
20+#include "overlapping-compat.h"
19module Servant.Docs.Internal where
21module Servant.Docs.Internal where
20
22
21−import Prelude ()
23+import Prelude ()
22import Prelude.Compat
24import Prelude.Compat
23
25
24import Control.Applicative
26import Control.Applicative
25−import Control.Arrow
27+import Control.Arrow (second)
26− (second)
27−import Control.Lens
28+import Control.Lens (makeLenses, mapped, over,
28− (makeLenses, mapped, each, over, set, to, toListOf, traversed, view,
29+ traversed, view, (%~), (&), (.~),
29− _1, (%~), (&), (.~), (<>~), (^.), (|>))
30+ (<>~), (^.), (|>))
31+import qualified Control.Monad.Omega as Omega
30import qualified Data.ByteString.Char8 as BSC
32import qualified Data.ByteString.Char8 as BSC
31−import Data.ByteString.Lazy.Char8
33+import Data.ByteString.Lazy.Char8 (ByteString)
32− (ByteString)
33import qualified Data.CaseInsensitive as CI
34import qualified Data.CaseInsensitive as CI
34−import Data.Foldable
35+import Data.Foldable (fold)
35− (fold, toList)
36−import Data.Hashable
36+import Data.Hashable (Hashable)
37− (Hashable)
38−import Data.HashMap.Strict
37+import Data.HashMap.Strict (HashMap)
39− (HashMap)
40−import Data.List.Compat
41− (intercalate, intersperse, sort)
38+import Data.List.Compat (intercalate, intersperse, sort)
42−import Data.List.NonEmpty
39+import Data.List.NonEmpty (NonEmpty ((:|)), groupWith)
43− (NonEmpty ((:|)), groupWith)
44import qualified Data.List.NonEmpty as NE
40import qualified Data.List.NonEmpty as NE
45import Data.Maybe
41import Data.Maybe
46−import Data.Monoid
42+import Data.Monoid (All (..), Any (..), Dual (..),
47− (All (..), Any (..), Dual (..), First (..), Last (..),
43+ First (..), Last (..),
48− Product (..), Sum (..))
44+ Product (..), Sum (..))
49−import Data.Ord
45+import Data.Ord (comparing)
50− (comparing)
51−import Data.Proxy
46+import Data.Proxy (Proxy (Proxy))
52− (Proxy (Proxy))
47+import Data.Semigroup (Semigroup (..))
53−import Data.String.Conversions
48+import Data.String.Conversions (cs)
54− (cs)
55−import Data.Text
49+import Data.Text (Text, unpack)
56− (Text, unpack)
57import GHC.Generics
50import GHC.Generics
58− (Generic, Rep, K1(K1), M1(M1), U1(U1), V1,
59− (:*:)((:*:)), (:+:)(L1, R1))
60−import qualified GHC.Generics as G
61import GHC.TypeLits
51import GHC.TypeLits
62import Servant.API
52import Servant.API
63import Servant.API.ContentTypes
53import Servant.API.ContentTypes
64import Servant.API.TypeLevel
54import Servant.API.TypeLevel
65−import Servant.API.Generic
66−
67−import qualified Data.Universe.Helpers as U
68
55
69import qualified Data.HashMap.Strict as HM
56import qualified Data.HashMap.Strict as HM
70import qualified Data.Text as T
57import qualified Data.Text as T
@@ -77,15 +64,14 @@ import qualified Network.HTTP.Types as HTTP
77-- or any 'Endpoint' value you want using the 'path' and 'method'
64-- or any 'Endpoint' value you want using the 'path' and 'method'
78-- lenses to tweak.
65-- lenses to tweak.
79--
66--
67+-- @
80−-- >>> defEndpoint
68+-- λ> 'defEndpoint'
81−-- "GET" /
69+-- GET /
82−--
83−-- >>> defEndpoint & path <>~ ["foo"]
70+-- λ> 'defEndpoint' & 'path' '<>~' ["foo"]
84−-- "GET" /foo
71+-- GET /foo
85−--
86−-- >>> defEndpoint & path <>~ ["foo"] & method .~ HTTP.methodPost
72+-- λ> 'defEndpoint' & 'path' '<>~' ["foo"] & 'method' '.~' 'HTTP.methodPost'
87−-- "POST" /foo
73+-- POST /foo
88−--
74+-- @
89data Endpoint = Endpoint
75data Endpoint = Endpoint
90 { _path :: [String] -- type collected
76 { _path :: [String] -- type collected
91 , _method :: HTTP.Method -- type collected
77 , _method :: HTTP.Method -- type collected
@@ -106,15 +92,14 @@ showPath ps = concatMap ('/' :) ps
106--
92--
107-- Here's how you can modify it:
93-- Here's how you can modify it:
108--
94--
95+-- @
109−-- >>> defEndpoint
96+-- λ> 'defEndpoint'
110−-- "GET" /
97+-- GET /
111−--
112−-- >>> defEndpoint & path <>~ ["foo"]
98+-- λ> 'defEndpoint' & 'path' '<>~' ["foo"]
113−-- "GET" /foo
99+-- GET /foo
114−--
115−-- >>> defEndpoint & path <>~ ["foo"] & method .~ HTTP.methodPost
100+-- λ> 'defEndpoint' & 'path' '<>~' ["foo"] & 'method' '.~' 'HTTP.methodPost'
116−-- "POST" /foo
101+-- POST /foo
117−--
102+-- @
118defEndpoint :: Endpoint
103defEndpoint :: Endpoint
119defEndpoint = Endpoint [] HTTP.methodGet
104defEndpoint = Endpoint [] HTTP.methodGet
120
105
@@ -131,8 +116,7 @@ instance Semigroup API where
131 (<>) = mappend
116 (<>) = mappend
132
117
133instance Monoid API where
118instance Monoid API where
134− API a1 b1 `mappend` API a2 b2 = API (a1 `mappend` a2)
119+ API a1 b1 `mappend` API a2 b2 = API (a1 `mappend` a2) (b1 `mappend` b2)
135− (HM.unionWith combineAction b1 b2)
136 mempty = API mempty mempty
120 mempty = API mempty mempty
137
121
138-- | An empty 'API'
122-- | An empty 'API'
@@ -161,20 +145,6 @@ data DocQueryParam = DocQueryParam
161 , _paramKind :: ParamKind
145 , _paramKind :: ParamKind
162 } deriving (Eq, Ord, Show)
146 } deriving (Eq, Ord, Show)
163
147
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−
178-- | An introductory paragraph for your documentation. You can pass these to
148-- | An introductory paragraph for your documentation. You can pass these to
179-- 'docsWithIntros'.
149-- 'docsWithIntros'.
180data DocIntro = DocIntro
150data DocIntro = DocIntro
@@ -240,14 +210,12 @@ data ParamKind = Normal | List | Flag
240-- want to write a 'ToSample' instance for the type that'll be represented
210-- want to write a 'ToSample' instance for the type that'll be represented
241-- as encoded data in the response.
211-- as encoded data in the response.
242--
212--
243−-- Can be tweaked with four lenses.
213+-- Can be tweaked with three 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 = []}
250--
214--
215+-- > λ> defResponse
216+-- > Response {_respStatus = 200, _respTypes = [], _respBody = []}
217+-- > λ> defResponse & respStatus .~ 204 & respBody .~ [("If everything goes well", "{ \"status\": \"ok\" }")]
218+-- > Response {_respStatus = 204, _respTypes = [], _respBody = [("If everything goes well", "{ \"status\": \"ok\" }")]}
251data Response = Response
219data Response = Response
252 { _respStatus :: Int
220 { _respStatus :: Int
253 , _respTypes :: [M.MediaType]
221 , _respTypes :: [M.MediaType]
@@ -255,25 +223,14 @@ data Response = Response
255 , _respHeaders :: [HTTP.Header]
223 , _respHeaders :: [HTTP.Header]
256 } deriving (Eq, Ord, Show)
224 } deriving (Eq, Ord, Show)
257
225
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−
267-- | Default response: status code 200, no response body.
226-- | Default response: status code 200, no response body.
268--
227--
269−-- Can be tweaked with four lenses.
228+-- Can be tweaked with two lenses.
270−--
271−-- >>> defResponse
272−-- Response {_respStatus = 200, _respTypes = [], _respBody = [], _respHeaders = []}
273−--
274−-- >>> defResponse & respStatus .~ 204
275−-- Response {_respStatus = 204, _respTypes = [], _respBody = [], _respHeaders = []}
276--
229--
230+-- > λ> defResponse
231+-- > Response {_respStatus = 200, _respBody = Nothing}
232+-- > λ> defResponse & respStatus .~ 204 & respBody .~ Just "[]"
233+-- > Response {_respStatus = 204, _respBody = Just "[]"}
277defResponse :: Response
234defResponse :: Response
278defResponse = Response
235defResponse = Response
279 { _respStatus = 200
236 { _respStatus = 200
@@ -295,9 +252,8 @@ defResponse = Response
295data Action = Action
252data Action = Action
296 { _authInfo :: [DocAuthentication] -- user supplied info
253 { _authInfo :: [DocAuthentication] -- user supplied info
297 , _captures :: [DocCapture] -- type collected + user supplied info
254 , _captures :: [DocCapture] -- type collected + user supplied info
298− , _headers :: [HTTP.Header] -- type collected
255+ , _headers :: [Text] -- type collected
299 , _params :: [DocQueryParam] -- type collected + user supplied info
256 , _params :: [DocQueryParam] -- type collected + user supplied info
300− , _fragment :: Maybe DocFragment -- type collected + user supplied info
301 , _notes :: [DocNote] -- user supplied
257 , _notes :: [DocNote] -- user supplied
302 , _mxParams :: [(String, [DocQueryParam])] -- type collected + user supplied info
258 , _mxParams :: [(String, [DocQueryParam])] -- type collected + user supplied info
303 , _rqtypes :: [M.MediaType] -- type collected
259 , _rqtypes :: [M.MediaType] -- type collected
@@ -309,30 +265,27 @@ data Action = Action
309-- laws.
265-- laws.
310--
266--
311-- As such, we invent a non-commutative, left associative operation
267-- As such, we invent a non-commutative, left associative operation
312−-- 'combineAction' to mush two together taking the response from the very left.
268+-- 'combineAction' to mush two together taking the response, body and content
269+-- types from the very left.
313combineAction :: Action -> Action -> Action
270combineAction :: Action -> Action -> Action
314−Action a c h p f n m ts body resp
271+Action a c h p n m ts body resp `combineAction` Action a' c' h' p' n' m' _ _ _ =
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')
272+ Action (a <> a') (c <> c') (h <> h') (p <> p') (n <> n') (m <> m') ts body resp
317
273
318-- | Default 'Action'. Has no 'captures', no query 'params', expects
274-- | Default 'Action'. Has no 'captures', no query 'params', expects
319-- no request body ('rqbody') and the typical response is 'defResponse'.
275-- no request body ('rqbody') and the typical response is 'defResponse'.
320--
276--
321-- Tweakable with lenses.
277-- Tweakable with lenses.
322--
278--
323−-- >>> defAction
279+-- > λ> defAction
324−-- Action {_authInfo = [], _captures = [], _headers = [], _params = [], _fragment = Nothing, _notes = [], _mxParams = [], _rqtypes = [], _rqbody = [], _response = Response {_respStatus = 200, _respTypes = [], _respBody = [], _respHeaders = []}}
280+-- > Action {_captures = [], _headers = [], _params = [], _mxParams = [], _rqbody = Nothing, _response = Response {_respStatus = 200, _respBody = Nothing}}
325−--
326−-- >>> defAction & response.respStatus .~ 201
281+-- > λ> defAction & response.respStatus .~ 201
327−-- Action {_authInfo = [], _captures = [], _headers = [], _params = [], _fragment = Nothing, _notes = [], _mxParams = [], _rqtypes = [], _rqbody = [], _response = Response {_respStatus = 201, _respTypes = [], _respBody = [], _respHeaders = []}}
282+-- > Action {_captures = [], _headers = [], _params = [], _mxParams = [], _rqbody = Nothing, _response = Response {_respStatus = 201, _respBody = Nothing}}
328−--
329defAction :: Action
283defAction :: Action
330defAction =
284defAction =
331 Action []
285 Action []
332 []
286 []
333 []
287 []
334 []
288 []
335− Nothing
336 []
289 []
337 []
290 []
338 []
291 []
@@ -356,14 +309,12 @@ data ShowContentTypes = AllContentTypes -- ^ For each example, show each conten
356--
309--
357-- @since 0.11.1
310-- @since 0.11.1
358data RenderingOptions = RenderingOptions
311data RenderingOptions = RenderingOptions
359− { _requestExamples :: !ShowContentTypes
312+ { _requestExamples :: !ShowContentTypes
360 -- ^ How many content types to display for request body examples?
313 -- ^ How many content types to display for request body examples?
361− , _responseExamples :: !ShowContentTypes
314+ , _responseExamples :: !ShowContentTypes
362 -- ^ How many content types to display for response body examples?
315 -- ^ How many content types to display for response body examples?
363− , _notesHeading :: !(Maybe String)
316+ , _notesHeading :: !(Maybe String)
364 -- ^ Optionally group all 'notes' together under a common heading.
317 -- ^ 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`).
367 } deriving (Show)
318 } deriving (Show)
368
319
369-- | Default API generation options.
320-- | Default API generation options.
@@ -375,10 +326,9 @@ data RenderingOptions = RenderingOptions
375-- @since 0.11.1
326-- @since 0.11.1
376defRenderingOptions :: RenderingOptions
327defRenderingOptions :: RenderingOptions
377defRenderingOptions = RenderingOptions
328defRenderingOptions = RenderingOptions
378− { _requestExamples = AllContentTypes
329+ { _requestExamples = AllContentTypes
379− , _responseExamples = AllContentTypes
330+ , _responseExamples = AllContentTypes
380− , _notesHeading = Nothing
331+ , _notesHeading = Nothing
381− , _renderCurlBasePath = Nothing
382 }
332 }
383
333
384-- gimme some lenses
334-- gimme some lenses
@@ -388,7 +338,6 @@ makeLenses ''API
388makeLenses ''Endpoint
338makeLenses ''Endpoint
389makeLenses ''DocCapture
339makeLenses ''DocCapture
390makeLenses ''DocQueryParam
340makeLenses ''DocQueryParam
391−makeLenses ''DocFragment
392makeLenses ''DocIntro
341makeLenses ''DocIntro
393makeLenses ''DocNote
342makeLenses ''DocNote
394makeLenses ''Response
343makeLenses ''Response
@@ -398,8 +347,7 @@ makeLenses ''RenderingOptions
398-- | Generate the docs for a given API that implements 'HasDocs'. This is the
347-- | Generate the docs for a given API that implements 'HasDocs'. This is the
399-- default way to create documentation.
348-- default way to create documentation.
400--
349--
401−-- > docs == docsWithOptions defaultDocOptions
350+-- prop> docs == docsWithOptions defaultDocOptions
402−--
403docs :: HasDocs api => Proxy api -> API
351docs :: HasDocs api => Proxy api -> API
404docs p = docsWithOptions p defaultDocOptions
352docs p = docsWithOptions p defaultDocOptions
405
353
@@ -415,9 +363,9 @@ docsWithOptions p = docsFor p (defEndpoint, defAction)
415-- > extra :: ExtraInfo TestApi
363-- > extra :: ExtraInfo TestApi
416-- > extra =
364-- > extra =
417-- > extraInfo (Proxy :: Proxy ("greet" :> Capture "greetid" Text :> Delete)) $
365-- > extraInfo (Proxy :: Proxy ("greet" :> Capture "greetid" Text :> Delete)) $
418−-- > defAction & headers <>~ [("X-Num-Unicorns", 1)]
366+-- > defAction & headers <>~ ["unicorns"]
419-- > & notes <>~ [ DocNote "Title" ["This is some text"]
367-- > & notes <>~ [ DocNote "Title" ["This is some text"]
420−-- > , DocNote "Second section" ["And some more"]
368+-- > , DocNote "Second secton" ["And some more"]
421-- > ]
369-- > ]
422
370
423extraInfo :: (IsIn endpoint api, HasLink endpoint, HasDocs endpoint)
371extraInfo :: (IsIn endpoint api, HasLink endpoint, HasDocs endpoint)
@@ -447,7 +395,7 @@ docsWith opts intros (ExtraInfo endpoints) p =
447 & apiEndpoints %~ HM.unionWith (flip combineAction) endpoints
395 & apiEndpoints %~ HM.unionWith (flip combineAction) endpoints
448
396
449
397
450−-- | Generate the docs for a given API that implements 'HasDocs' with any
398+-- | Generate the docs for a given API that implements 'HasDocs' with with any
451-- number of introduction(s)
399-- number of introduction(s)
452docsWithIntros :: HasDocs api => [DocIntro] -> Proxy api -> API
400docsWithIntros :: HasDocs api => [DocIntro] -> Proxy api -> API
453docsWithIntros intros = docsWith defaultDocOptions intros mempty
401docsWithIntros intros = docsWith defaultDocOptions intros mempty
@@ -510,22 +458,22 @@ samples = map ("",)
510
458
511-- | Default sample Generic-based inputs/outputs.
459-- | Default sample Generic-based inputs/outputs.
512defaultSamples :: forall a. (Generic a, GToSample (Rep a)) => Proxy a -> [(Text, a)]
460defaultSamples :: forall a. (Generic a, GToSample (Rep a)) => Proxy a -> [(Text, a)]
513−defaultSamples _ = second G.to <$> gtoSamples (Proxy :: Proxy (Rep a))
461+defaultSamples _ = Omega.runOmega $ second to <$> gtoSamples (Proxy :: Proxy (Rep a))
514
462
515-- | @'ToSample'@ for Generics.
463-- | @'ToSample'@ for Generics.
516--
464--
517−-- Note: we use combinators from "Universe.Data.Helpers" for more productive sample generation.
465+-- The use of @'Omega'@ allows for more productive sample generation.
518class GToSample t where
466class GToSample t where
519− gtoSamples :: proxy t -> [(Text, t x)]
467+ gtoSamples :: proxy t -> Omega.Omega (Text, t x)
520
468
521instance GToSample U1 where
469instance GToSample U1 where
522− gtoSamples _ = singleSample U1
470+ gtoSamples _ = Omega.each (singleSample U1)
523
471
524instance GToSample V1 where
472instance GToSample V1 where
525 gtoSamples _ = empty
473 gtoSamples _ = empty
526
474
527instance (GToSample p, GToSample q) => GToSample (p :*: q) where
475instance (GToSample p, GToSample q) => GToSample (p :*: q) where
528− gtoSamples _ = U.cartesianProduct render ps qs
476+ gtoSamples _ = render <$> ps <*> qs
529 where
477 where
530 ps = gtoSamples (Proxy :: Proxy p)
478 ps = gtoSamples (Proxy :: Proxy p)
531 qs = gtoSamples (Proxy :: Proxy q)
479 qs = gtoSamples (Proxy :: Proxy q)
@@ -534,13 +482,13 @@ instance (GToSample p, GToSample q) => GToSample (p :*: q) where
534 | otherwise = (ta <> ", " <> tb, a :*: b)
482 | otherwise = (ta <> ", " <> tb, a :*: b)
535
483
536instance (GToSample p, GToSample q) => GToSample (p :+: q) where
484instance (GToSample p, GToSample q) => GToSample (p :+: q) where
537− gtoSamples _ = lefts U.+++ rights
485+ gtoSamples _ = lefts <|> rights
538 where
486 where
539 lefts = second L1 <$> gtoSamples (Proxy :: Proxy p)
487 lefts = second L1 <$> gtoSamples (Proxy :: Proxy p)
540 rights = second R1 <$> gtoSamples (Proxy :: Proxy q)
488 rights = second R1 <$> gtoSamples (Proxy :: Proxy q)
541
489
542instance ToSample a => GToSample (K1 i a) where
490instance ToSample a => GToSample (K1 i a) where
543− gtoSamples _ = second K1 <$> toSamples (Proxy :: Proxy a)
491+ gtoSamples _ = second K1 <$> Omega.each (toSamples (Proxy :: Proxy a))
544
492
545instance (GToSample f) => GToSample (M1 i a f) where
493instance (GToSample f) => GToSample (M1 i a f) where
546 gtoSamples _ = second M1 <$> gtoSamples (Proxy :: Proxy f)
494 gtoSamples _ = second M1 <$> gtoSamples (Proxy :: Proxy f)
@@ -608,15 +556,6 @@ class ToCapture c where
608class ToAuthInfo a where
556class ToAuthInfo a where
609 toAuthInfo :: Proxy a -> DocAuthentication
557 toAuthInfo :: Proxy a -> DocAuthentication
610
558
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−
620-- | Generate documentation in Markdown format for
559-- | Generate documentation in Markdown format for
621-- the given 'API'.
560-- the given 'API'.
622--
561--
@@ -646,7 +585,7 @@ markdown = markdownWith defRenderingOptions
646--
585--
647-- @since 0.11.1
586-- @since 0.11.1
648markdownWith :: RenderingOptions -> API -> String
587markdownWith :: RenderingOptions -> API -> String
649−markdownWith RenderingOptions{..} api = unlines $
588+markdownWith RenderingOptions{..} api = unlines $
650 introsStr (api ^. apiIntros)
589 introsStr (api ^. apiIntros)
651 ++ (concatMap (uncurry printEndpoint) . sort . HM.toList $ api ^. apiEndpoints)
590 ++ (concatMap (uncurry printEndpoint) . sort . HM.toList $ api ^. apiEndpoints)
652
591
@@ -657,12 +596,10 @@ markdownWith RenderingOptions{..} api = unlines $
657 notesStr (action ^. notes) ++
596 notesStr (action ^. notes) ++
658 authStr (action ^. authInfo) ++
597 authStr (action ^. authInfo) ++
659 capturesStr (action ^. captures) ++
598 capturesStr (action ^. captures) ++
660− headersStr (toListOf (headers . each . _1 . to (T.pack . BSC.unpack . CI.original)) action) ++
599+ headersStr (action ^. headers) ++
661 paramsStr meth (action ^. params) ++
600 paramsStr meth (action ^. params) ++
662− fragmentStr (action ^. fragment) ++
663 rqbodyStr (action ^. rqtypes) (action ^. rqbody) ++
601 rqbodyStr (action ^. rqtypes) (action ^. rqbody) ++
664 responseStr (action ^. response) ++
602 responseStr (action ^. response) ++
665− maybe [] (curlStr endpoint (action ^. headers) (action ^. rqbody)) _renderCurlBasePath ++
666 []
603 []
667
604
668 where str = "## " ++ BSC.unpack meth
605 where str = "## " ++ BSC.unpack meth
@@ -762,14 +699,6 @@ markdownWith RenderingOptions{..} api = unlines $
762
699
763 where values = param ^. paramValues
700 where values = param ^. paramValues
764
701
765− fragmentStr :: Maybe DocFragment -> [String]
766− fragmentStr Nothing = []
767− fragmentStr (Just frag) =
768− [ "### Fragment:", ""
769− , "- *" ++ (frag ^. fragSymbol) ++ "*: " ++ (frag ^. fragDesc)
770− , ""
771− ]
772−
773 rqbodyStr :: [M.MediaType] -> [(Text, M.MediaType, ByteString)]-> [String]
702 rqbodyStr :: [M.MediaType] -> [(Text, M.MediaType, ByteString)]-> [String]
774 rqbodyStr [] [] = []
703 rqbodyStr [] [] = []
775 rqbodyStr types s =
704 rqbodyStr types s =
@@ -818,11 +747,12 @@ markdownWith RenderingOptions{..} api = unlines $
818 ("text", "css") -> "css"
747 ("text", "css") -> "css"
819 (_, _) -> ""
748 (_, _) -> ""
820
749
750+
821 contentStr mime_type body =
751 contentStr mime_type body =
822 "" :
752 "" :
823− "```" <> markdownForType mime_type :
753+ " ```" <> markdownForType mime_type :
824 cs body :
754 cs body :
825− "```" :
755+ " ```" :
826 "" :
756 "" :
827 []
757 []
828
758
@@ -842,41 +772,11 @@ markdownWith RenderingOptions{..} api = unlines $
842 xs ->
772 xs ->
843 formatBodies _responseExamples xs
773 formatBodies _responseExamples xs
844
774
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−
875-- * Instances
775-- * Instances
876
776
877-- | The generated docs for @a ':<|>' b@ just appends the docs
777-- | The generated docs for @a ':<|>' b@ just appends the docs
878-- for @a@ with the docs for @b@.
778-- for @a@ with the docs for @b@.
879−instance {-# OVERLAPPABLE #-}
779+instance OVERLAPPABLE_
880 (HasDocs a, HasDocs b)
780 (HasDocs a, HasDocs b)
881 => HasDocs (a :<|> b) where
781 => HasDocs (a :<|> b) where
882
782
@@ -895,7 +795,7 @@ instance HasDocs EmptyAPI where
895-- | @"books" :> 'Capture' "isbn" Text@ will appear as
795-- | @"books" :> 'Capture' "isbn" Text@ will appear as
896-- @/books/:isbn@ in the docs.
796-- @/books/:isbn@ in the docs.
897instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs api)
797instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs api)
898− => HasDocs (Capture' '[] sym a :> api) where
798+ => HasDocs (Capture' mods sym a :> api) where
899
799
900 docsFor Proxy (endpoint, action) =
800 docsFor Proxy (endpoint, action) =
901 docsFor subApiP (endpoint', action')
801 docsFor subApiP (endpoint', action')
@@ -907,28 +807,6 @@ instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs api)
907 endpoint' = over path (\p -> p ++ [":" ++ symbolVal symP]) endpoint
807 endpoint' = over path (\p -> p ++ [":" ++ symbolVal symP]) endpoint
908 symP = Proxy :: Proxy sym
808 symP = Proxy :: Proxy sym
909
809
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−
932
810
933-- | @"books" :> 'CaptureAll' "isbn" Text@ will appear as
811-- | @"books" :> 'CaptureAll' "isbn" Text@ will appear as
934-- @/books/:isbn@ in the docs.
812-- @/books/:isbn@ in the docs.
@@ -946,7 +824,7 @@ instance (KnownSymbol sym, ToCapture (CaptureAll sym a), HasDocs sublayout)
946 symP = Proxy :: Proxy sym
824 symP = Proxy :: Proxy sym
947
825
948
826
949−instance {-# OVERLAPPABLE #-}
827+instance OVERLAPPABLE_
950 (ToSample a, AllMimeRender (ct ': cts) a, KnownNat status
828 (ToSample a, AllMimeRender (ct ': cts) a, KnownNat status
951 , ReflectMethod method)
829 , ReflectMethod method)
952 => HasDocs (Verb method status (ct ': cts) a) where
830 => HasDocs (Verb method status (ct ': cts) a) where
@@ -962,37 +840,7 @@ instance {-# OVERLAPPABLE #-}
962 status = fromInteger $ natVal (Proxy :: Proxy status)
840 status = fromInteger $ natVal (Proxy :: Proxy status)
963 p = Proxy :: Proxy a
841 p = Proxy :: Proxy a
964
842
965−instance (ReflectMethod method) =>
843+instance OVERLAPPING_
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−
977−-- | TODO: mention the endpoint is streaming, its framing strategy
978−--
979−-- Also there are no samples.
980−--
981−-- TODO: AcceptFraming for content-type
982−instance {-# OVERLAPPABLE #-}
983− (Accept ct, KnownNat status, ReflectMethod method)
984− => HasDocs (Stream method status framing ct a) where
985− docsFor Proxy (endpoint, action) DocOptions{..} =
986− single endpoint' action'
987−
988− where endpoint' = endpoint & method .~ method'
989− action' = action & response.respTypes .~ allMime t
990− & response.respStatus .~ status
991− t = Proxy :: Proxy '[ct]
992− method' = reflectMethod (Proxy :: Proxy method)
993− status = fromInteger $ natVal (Proxy :: Proxy status)
994−
995−instance {-# OVERLAPPING #-}
996 (ToSample a, AllMimeRender (ct ': cts) a, KnownNat status
844 (ToSample a, AllMimeRender (ct ': cts) a, KnownNat status
997 , ReflectMethod method, AllHeaderSamples ls, GetHeaders (HList ls))
845 , ReflectMethod method, AllHeaderSamples ls, GetHeaders (HList ls))
998 => HasDocs (Verb method status (ct ': cts) (Headers ls a)) where
846 => HasDocs (Verb method status (ct ': cts) (Headers ls a)) where
@@ -1010,17 +858,14 @@ instance {-# OVERLAPPING #-}
1010 status = fromInteger $ natVal (Proxy :: Proxy status)
858 status = fromInteger $ natVal (Proxy :: Proxy status)
1011 p = Proxy :: Proxy a
859 p = Proxy :: Proxy a
1012
860
1013−instance (ToHttpApiData a, ToSample a, KnownSymbol sym, HasDocs api)
861+instance (KnownSymbol sym, HasDocs api)
1014 => HasDocs (Header' mods sym a :> api) where
862 => HasDocs (Header' mods sym a :> api) where
1015 docsFor Proxy (endpoint, action) =
863 docsFor Proxy (endpoint, action) =
1016 docsFor subApiP (endpoint, action')
864 docsFor subApiP (endpoint, action')
1017
865
1018 where subApiP = Proxy :: Proxy api
866 where subApiP = Proxy :: Proxy api
1019− action' = over headers (|> (headerName, headerVal)) action
867+ action' = over headers (|> headername) action
1020− headerName = CI.mk . cs $ symbolVal (Proxy :: Proxy sym)
868+ headername = T.pack $ symbolVal (Proxy :: Proxy sym)
1021− headerVal = case toSample (Proxy :: Proxy a) of
1022− Just x -> cs $ toHeader x
1023− Nothing -> "<no header sample provided>"
1024
869
1025instance (KnownSymbol sym, ToParam (QueryParam' mods sym a), HasDocs api)
870instance (KnownSymbol sym, ToParam (QueryParam' mods sym a), HasDocs api)
1026 => HasDocs (QueryParam' mods sym a :> api) where
871 => HasDocs (QueryParam' mods sym a :> api) where
@@ -1053,15 +898,6 @@ instance (KnownSymbol sym, ToParam (QueryFlag sym), HasDocs api)
1053 paramP = Proxy :: Proxy (QueryFlag sym)
898 paramP = Proxy :: Proxy (QueryFlag sym)
1054 action' = over params (|> toParam paramP) action
899 action' = over params (|> toParam paramP) action
1055
900
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
1065
901
1066instance HasDocs Raw where
902instance HasDocs Raw where
1067 docsFor _proxy (endpoint, action) _ =
903 docsFor _proxy (endpoint, action) _ =
@@ -1094,6 +930,7 @@ instance (KnownSymbol desc, HasDocs api)
1094-- both are even defined) for any particular type.
930-- both are even defined) for any particular type.
1095instance (ToSample a, AllMimeRender (ct ': cts) a, HasDocs api)
931instance (ToSample a, AllMimeRender (ct ': cts) a, HasDocs api)
1096 => HasDocs (ReqBody' mods (ct ': cts) a :> api) where
932 => HasDocs (ReqBody' mods (ct ': cts) a :> api) where
933+
1097 docsFor Proxy (endpoint, action) opts@DocOptions{..} =
934 docsFor Proxy (endpoint, action) opts@DocOptions{..} =
1098 docsFor subApiP (endpoint, action') opts
935 docsFor subApiP (endpoint, action') opts
1099
936
@@ -1104,18 +941,6 @@ instance (ToSample a, AllMimeRender (ct ': cts) a, HasDocs api)
1104 t = Proxy :: Proxy (ct ': cts)
941 t = Proxy :: Proxy (ct ': cts)
1105 p = Proxy :: Proxy a
942 p = Proxy :: Proxy a
1106
943
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−
1119instance (KnownSymbol path, HasDocs api) => HasDocs (path :> api) where
944instance (KnownSymbol path, HasDocs api) => HasDocs (path :> api) where
1120
945
1121 docsFor Proxy (endpoint, action) =
946 docsFor Proxy (endpoint, action) =
@@ -1144,9 +969,6 @@ instance HasDocs api => HasDocs (Vault :> api) where
1144instance HasDocs api => HasDocs (WithNamedContext name context api) where
969instance HasDocs api => HasDocs (WithNamedContext name context api) where
1145 docsFor Proxy = docsFor (Proxy :: Proxy api)
970 docsFor Proxy = docsFor (Proxy :: Proxy api)
1146
971
1147−instance HasDocs api => HasDocs (WithResource res :> api) where
1148− docsFor Proxy = docsFor (Proxy :: Proxy api)
1149−
1150instance (ToAuthInfo (BasicAuth realm usr), HasDocs api) => HasDocs (BasicAuth realm usr :> api) where
972instance (ToAuthInfo (BasicAuth realm usr), HasDocs api) => HasDocs (BasicAuth realm usr :> api) where
1151 docsFor Proxy (endpoint, action) =
973 docsFor Proxy (endpoint, action) =
1152 docsFor (Proxy :: Proxy api) (endpoint, action')
974 docsFor (Proxy :: Proxy api) (endpoint, action')
@@ -1154,9 +976,6 @@ instance (ToAuthInfo (BasicAuth realm usr), HasDocs api) => HasDocs (BasicAuth r
1154 authProxy = Proxy :: Proxy (BasicAuth realm usr)
976 authProxy = Proxy :: Proxy (BasicAuth realm usr)
1155 action' = over authInfo (|> toAuthInfo authProxy) action
977 action' = over authInfo (|> toAuthInfo authProxy) action
1156
978
1157−instance HasDocs (ToServantApi api) => HasDocs (NamedRoutes api) where
1158− docsFor Proxy = docsFor (Proxy :: Proxy (ToServantApi api))
1159−
1160-- ToSample instances for simple types
979-- ToSample instances for simple types
1161instance ToSample NoContent
980instance ToSample NoContent
1162instance ToSample Bool
981instance ToSample Bool
@@ -1173,7 +992,6 @@ instance (ToSample a, ToSample b, ToSample c, ToSample d, ToSample e, ToSample f
1173instance ToSample a => ToSample (Maybe a)
992instance ToSample a => ToSample (Maybe a)
1174instance (ToSample a, ToSample b) => ToSample (Either a b)
993instance (ToSample a, ToSample b) => ToSample (Either a b)
1175instance ToSample a => ToSample [a]
994instance ToSample a => ToSample [a]
1176−instance ToSample a => ToSample (NonEmpty a)
1177
995
1178-- ToSample instances for Control.Applicative types
996-- ToSample instances for Control.Applicative types
1179instance ToSample a => ToSample (Const a b)
997instance ToSample a => ToSample (Const a b)
@@ -1187,6 +1005,3 @@ instance ToSample a => ToSample (Product a)
1187instance ToSample a => ToSample (First a)
1005instance ToSample a => ToSample (First a)
1188instance ToSample a => ToSample (Last a)
1006instance ToSample a => ToSample (Last a)
1189instance ToSample a => ToSample (Dual a)
1007instance ToSample a => ToSample (Dual a)
1190−
1191−-- $setup
1192−-- >>> :set -XOverloadedStrings
servant-docs/src/Servant/Docs/Internal/Pretty.hs+6−29
@@ -4,21 +4,16 @@
4{-# LANGUAGE MultiParamTypeClasses #-}
4{-# LANGUAGE MultiParamTypeClasses #-}
5{-# LANGUAGE OverloadedStrings #-}
5{-# LANGUAGE OverloadedStrings #-}
6{-# LANGUAGE PolyKinds #-}
6{-# LANGUAGE PolyKinds #-}
7−{-# LANGUAGE TypeFamilies #-}
8{-# LANGUAGE TypeOperators #-}
7{-# LANGUAGE TypeOperators #-}
8+{-# LANGUAGE TypeFamilies #-}
9
9
10module Servant.Docs.Internal.Pretty where
10module Servant.Docs.Internal.Pretty where
11
11
12−import Data.Aeson
12+import Data.Aeson (ToJSON(..))
13− (ToJSON (..))
14−import Data.Aeson.Encode.Pretty
13+import Data.Aeson.Encode.Pretty (encodePretty)
15− (encodePretty)
16−import Data.Proxy
14+import Data.Proxy (Proxy(Proxy))
17− (Proxy (Proxy))
18−import Network.HTTP.Media
15+import Network.HTTP.Media ((//))
19− ((//))
20−import Servant.API
21−import Servant.API.Verbs
16+import Servant.API
22
17
23-- | PrettyJSON content type.
18-- | PrettyJSON content type.
24data PrettyJSON
19data PrettyJSON
@@ -47,24 +42,6 @@ type family Pretty (api :: k) :: k where
47 Pretty (Put cs r) = Put (Pretty cs) r
42 Pretty (Put cs r) = Put (Pretty cs) r
48 Pretty (Delete cs r) = Delete (Pretty cs) r
43 Pretty (Delete cs r) = Delete (Pretty cs) r
49 Pretty (Patch cs r) = Patch (Pretty cs) r
44 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
68 Pretty (ReqBody cs r) = ReqBody (Pretty cs) r
45 Pretty (ReqBody cs r) = ReqBody (Pretty cs) r
69 Pretty (JSON ': xs) = PrettyJSON ': xs
46 Pretty (JSON ': xs) = PrettyJSON ': xs
70 Pretty (x ': xs) = x ': Pretty xs
47 Pretty (x ': xs) = x ': Pretty xs
servant-docs/test/Servant/DocsSpec.hs+31−99
@@ -1,77 +1,59 @@
1−{-# LANGUAGE DataKinds #-}
1+{-# LANGUAGE CPP #-}
2−{-# LANGUAGE DeriveFunctor #-}
2+{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE DeriveGeneric #-}
4−{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleContexts #-}
5−{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE FlexibleInstances #-}
6−{-# LANGUAGE GADTs #-}
7−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
8−{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
9−{-# LANGUAGE OverloadedStrings #-}
7+{-# LANGUAGE OverloadedStrings #-}
10−{-# LANGUAGE TypeOperators #-}
8+{-# LANGUAGE TypeOperators #-}
11−{-# LANGUAGE TypeSynonymInstances #-}
9+{-# LANGUAGE TypeSynonymInstances #-}
12{-# OPTIONS_GHC -fno-warn-orphans #-}
10{-# OPTIONS_GHC -fno-warn-orphans #-}
11+#if __GLASGOW_HASKELL__ >= 800
13{-# OPTIONS_GHC -freduction-depth=100 #-}
12{-# OPTIONS_GHC -freduction-depth=100 #-}
13+#else
14+{-# OPTIONS_GHC -fcontext-stack=100 #-}
15+#endif
14
16
15module Servant.DocsSpec where
17module Servant.DocsSpec where
16
18
17import Control.Lens
19import Control.Lens
18− ((&), (<>~))
19−import Control.Monad
20− (unless)
21−import Control.Monad.Trans.Writer
22− (Writer, runWriter, tell)
23import Data.Aeson
20import Data.Aeson
24−import Data.List
21+import Data.Monoid
25− (isInfixOf)
26import Data.Proxy
22import Data.Proxy
27−import Data.String.Conversions
23+import Data.String.Conversions (cs)
28− (cs)
29import GHC.Generics
24import GHC.Generics
30−import Prelude ()
25+import Test.Hspec
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, (@?=))
38
26
39import Servant.API
27import Servant.API
28+import Servant.API.Internal.Test.ComprehensiveAPI
40import Servant.Docs.Internal
29import Servant.Docs.Internal
41−import Servant.Test.ComprehensiveAPI
42
30
43-- * comprehensive api
31-- * comprehensive api
44
32
45-- This declaration simply checks that all instances are in place.
33-- This declaration simply checks that all instances are in place.
46−comprehensiveDocs :: API
47−comprehensiveDocs = docs comprehensiveAPI
34+_ = docs comprehensiveAPI
48
35
49instance ToParam (QueryParam' mods "foo" Int) where
36instance ToParam (QueryParam' mods "foo" Int) where
50− toParam _ = DocQueryParam "foo" ["1","2","3"] "QueryParams Int" Normal
37+ toParam = error "unused"
51instance ToParam (QueryParam' mods "bar" Int) where
38instance ToParam (QueryParam' mods "bar" Int) where
52− toParam _ = DocQueryParam "bar" ["1","2","3"] "QueryParams Int" Normal
39+ toParam = error "unused"
53instance ToParam (QueryParams "foo" Int) where
40instance ToParam (QueryParams "foo" Int) where
54− toParam _ = DocQueryParam "foo" ["1","2","3"] "QueryParams Int" List
41+ toParam = error "unused"
55instance ToParam (QueryFlag "foo") where
42instance ToParam (QueryFlag "foo") where
56− toParam _ = DocQueryParam "foo" [] "QueryFlag" Flag
43+ toParam = error "unused"
57instance ToCapture (Capture "foo" Int) where
44instance ToCapture (Capture "foo" Int) where
58− toCapture _ = DocCapture "foo" "Capture foo Int"
45+ toCapture = error "unused"
59instance ToCapture (CaptureAll "foo" Int) where
46instance ToCapture (CaptureAll "foo" Int) where
60− toCapture _ = DocCapture "foo" "Capture all foo Int"
47+ toCapture = error "unused"
61−instance ToFragment (Fragment Int) where
62− toFragment _ = DocFragment "foo" "Fragment Int"
63
48
64-- * specs
49-- * specs
65
50
66−spec :: TestTree
51+spec :: Spec
67spec = describe "Servant.Docs" $ do
52spec = describe "Servant.Docs" $ do
68− golden "comprehensive API" "golden/comprehensive.md" (markdown comprehensiveDocs)
69
53
70 describe "markdown" $ do
54 describe "markdown" $ do
71− let md1 = markdown (docs (Proxy :: Proxy TestApi1))
55+ let md = markdown (docs (Proxy :: Proxy TestApi1))
72− tests1 md1
56+ tests md
73− let md2 = markdown (docs (Proxy :: Proxy TestApi2))
74− tests2 md2
75
57
76 describe "markdown with extra info" $ do
58 describe "markdown with extra info" $ do
77 let
59 let
@@ -83,7 +65,7 @@ spec = describe "Servant.Docs" $ do
83 (Proxy :: Proxy (ReqBody '[JSON] String :> Post '[JSON] Datatype1))
65 (Proxy :: Proxy (ReqBody '[JSON] String :> Post '[JSON] Datatype1))
84 (defAction & notes <>~ [DocNote "Post data" ["Posts some Json data"]])
66 (defAction & notes <>~ [DocNote "Post data" ["Posts some Json data"]])
85 md = markdown (docsWith defaultDocOptions [] extra (Proxy :: Proxy TestApi1))
67 md = markdown (docsWith defaultDocOptions [] extra (Proxy :: Proxy TestApi1))
86− tests1 md
68+ tests md
87 it "contains the extra info provided" $ do
69 it "contains the extra info provided" $ do
88 md `shouldContain` "Get an Integer"
70 md `shouldContain` "Get an Integer"
89 md `shouldContain` "Post data"
71 md `shouldContain` "Post data"
@@ -111,7 +93,7 @@ spec = describe "Servant.Docs" $ do
111
93
112
94
113 where
95 where
114− tests1 md = do
96+ tests md = do
115 it "mentions supported content-types" $ do
97 it "mentions supported content-types" $ do
116 md `shouldContain` "application/json"
98 md `shouldContain` "application/json"
117 md `shouldContain` "text/plain;charset=utf-8"
99 md `shouldContain` "text/plain;charset=utf-8"
@@ -126,21 +108,14 @@ spec = describe "Servant.Docs" $ do
126 it "mentions headers" $ do
108 it "mentions headers" $ do
127 md `shouldContain` "- This endpoint is sensitive to the value of the **X-Test** HTTP header."
109 md `shouldContain` "- This endpoint is sensitive to the value of the **X-Test** HTTP header."
128
110
129− it "contains response samples - dt1field1" $
111+ it "contains response samples" $
130− md `shouldContain` "\"dt1field1\":\"field 1\""
112+ md `shouldContain` "{\"dt1field1\":\"field 1\",\"dt1field2\":13}"
131− it "contains response samples - dt1field2" $
132− md `shouldContain` "\"dt1field2\":13"
133 it "contains request body samples" $
113 it "contains request body samples" $
134 md `shouldContain` "17"
114 md `shouldContain` "17"
135
115
136 it "does not generate any docs mentioning the 'empty-api' path" $
116 it "does not generate any docs mentioning the 'empty-api' path" $
137 md `shouldNotContain` "empty-api"
117 md `shouldNotContain` "empty-api"
138
118
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−
144
119
145-- * APIs
120-- * APIs
146
121
@@ -167,10 +142,6 @@ type TestApi1 = Get '[JSON, PlainText] (Headers '[Header "Location" String] Int)
167 :<|> Header "X-Test" Int :> Put '[JSON] Int
142 :<|> Header "X-Test" Int :> Put '[JSON] Int
168 :<|> "empty-api" :> EmptyAPI
143 :<|> "empty-api" :> EmptyAPI
169
144
170−type TestApi2 = "duplicate-endpoint" :> Get '[JSON] Datatype1
171− :<|> "duplicate-endpoint" :> Get '[PlainText] Int
172−
173−
174data TT = TT1 | TT2 deriving (Show, Eq)
145data TT = TT1 | TT2 deriving (Show, Eq)
175data UT = UT1 | UT2 deriving (Show, Eq)
146data UT = UT1 | UT2 deriving (Show, Eq)
176
147
@@ -179,42 +150,3 @@ instance ToSample TT where
179
150
180instance ToSample UT where
151instance ToSample UT where
181 toSamples _ = [("yks", UT1), ("kaks", UT2)]
152 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
1+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
2−
3−import Test.Tasty
4− (defaultMain)
5−import qualified Servant.DocsSpec
6−
7−main :: IO ()
8−main = defaultMain Servant.DocsSpec.spec
servant-docs/tinc.yamlnew file+3
@@ -0,0 +1,3 @@
1+dependencies:
2+ - name: servant
3+ path: ../servant
servant-foreign/CHANGELOG.md−104
@@ -1,110 +1,6 @@
1[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-foreign/CHANGELOG.md)
1[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-foreign/CHANGELOG.md)
2[Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)
2[Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)
3
3
4−0.15.4
5−------
6−
7−### Significant changes
8−
9−- Documentation improvements.
10−
11−### Other changes
12−
13−- Support GHC-9.0.1.
14−- Bump `lens` and `hspec` dependencies.
15−
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−
103−0.11.1
104−------
105−
106−- Add missing `Semigroup` instances
107−
1080.11
40.11
109----
5----
110
6
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
2
2
3All rights reserved.
3All rights reserved.
4
4
servant-foreign/Setup.hs+1−1
@@ -1,2 +1,2 @@
1−import Distribution.Simple
1+import Distribution.Simple
2main = defaultMain
2main = defaultMain
servant-foreign/include/overlapping-compat.hnew file+8
@@ -0,0 +1,8 @@
1+#if __GLASGOW_HASKELL__ >= 710
2+#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}
3+#define OVERLAPPING_ {-# OVERLAPPING #-}
4+#else
5+{-# LANGUAGE OverlappingInstances #-}
6+#define OVERLAPPABLE_
7+#define OVERLAPPING_
8+#endif
servant-foreign/servant-foreign.cabal+27−21
@@ -1,9 +1,6 @@
1−cabal-version: 2.2
2name: servant-foreign
1name: servant-foreign
3−version: 0.15.4
2+version: 0.11
4−
5synopsis: Helpers for generating clients for servant APIs in any programming language
3synopsis: Helpers for generating clients for servant APIs in any programming language
6−category: Servant, Web
7description:
4description:
8 Helper types and functions for generating client functions for servant APIs in any programming language
5 Helper types and functions for generating client functions for servant APIs in any programming language
9 .
6 .
@@ -12,20 +9,24 @@ description:
12 See the servant-js package for an example
9 See the servant-js package for an example
13 .
10 .
14 <https://github.com/haskell-servant/servant/blob/master/servant-foreign/CHANGELOG.md CHANGELOG>
11 <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
12+license: BSD3
19license-file: LICENSE
13license-file: LICENSE
20author: Servant Contributors
14author: Servant Contributors
21maintainer: haskell-servant-maintainers@googlegroups.com
15maintainer: haskell-servant-maintainers@googlegroups.com
22−copyright: 2015-2019 Servant Contributors
16+copyright: 2015-2016 Servant Contributors
17+category: Servant, Web
23build-type: Simple
18build-type: Simple
24−tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1
19+cabal-version: >=1.10
25−
26extra-source-files:
20extra-source-files:
21+ include/*.h
27 CHANGELOG.md
22 CHANGELOG.md
28 README.md
23 README.md
24+bug-reports: http://github.com/haskell-servant/servant/issues
25+tested-with:
26+ GHC==7.8.4
27+ GHC==7.10.3
28+ GHC==8.0.2
29+ GHC==8.2.2
29
30
30source-repository head
31source-repository head
31 type: git
32 type: git
@@ -41,28 +42,32 @@ library
41 --
42 --
42 -- note: mtl lower bound is so low because of GHC-7.8
43 -- note: mtl lower bound is so low because of GHC-7.8
43 build-depends:
44 build-depends:
44− base >= 4.9 && < 4.18
45+ base >= 4.7 && <4.11
45− , text >= 1.2.3.0 && < 2.1
46+ , text >= 1.2.3.0 && < 1.3
46
47
47 -- Servant dependencies
48 -- Servant dependencies
48 build-depends:
49 build-depends:
49− servant >=0.18 && <0.20
50+ servant == 0.13.*
50
51
51 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.
52 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.
52 -- Here can be exceptions if we really need features from the newer versions.
53 -- Here can be exceptions if we really need features from the newer versions.
53 build-depends:
54 build-depends:
54− base-compat >= 0.10.5 && < 0.13
55+ base-compat >= 0.9.3 && <0.10
55− , lens >= 4.17 && < 5.3
56+ , lens >= 4.15.4 && <4.17
56− , http-types >= 0.12.2 && < 0.13
57+ , http-types >= 0.12 && < 0.13
57
58
58 hs-source-dirs: src
59 hs-source-dirs: src
59 default-language: Haskell2010
60 default-language: Haskell2010
61+ ghc-options: -Wall
62+ if impl(ghc >= 8.0)
60− ghc-options: -Wall -Wno-redundant-constraints
63+ ghc-options: -Wno-redundant-constraints
64+ include-dirs: include
61
65
62test-suite spec
66test-suite spec
63 type: exitcode-stdio-1.0
67 type: exitcode-stdio-1.0
64 hs-source-dirs: test
68 hs-source-dirs: test
65 ghc-options: -Wall
69 ghc-options: -Wall
70+ include-dirs: include
66 main-is: Spec.hs
71 main-is: Spec.hs
67 other-modules: Servant.ForeignSpec
72 other-modules: Servant.ForeignSpec
68
73
@@ -72,9 +77,10 @@ test-suite spec
72 , servant
77 , servant
73 , servant-foreign
78 , servant-foreign
74
79
75− -- Additional dependencies
80+ -- Additonal dependencies
76 build-depends:
81 build-depends:
77− hspec >= 2.6.0 && <2.10
82+ hspec >= 2.4.4 && <2.5
83+
78 build-tool-depends:
84 build-tool-depends:
79− hspec-discover:hspec-discover >=2.6.0 && <2.10
85+ hspec-discover:hspec-discover >=2.4.4 && <2.5
80 default-language: Haskell2010
86 default-language: Haskell2010
servant-foreign/src/Servant/Foreign.hs+21−26
@@ -1,32 +1,19 @@
1-- | Generalizes all the data needed to make code generation work with
1-- | Generalizes all the data needed to make code generation work with
2-- arbitrary programming languages.
2-- 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).
5module Servant.Foreign
3module Servant.Foreign
6− (
4+ ( ArgType(..)
7− -- * Main API
5+ , HeaderArg(..)
8− listFromAPI
6+ , QueryArg(..)
9 , Req(..)
7 , Req(..)
10− , defReq
11− , HasForeignType(..)
12− , GenerateList(..)
13− , HasForeign(..)
14− , NoTypes
15− -- * Subtypes of 'Req'
16− , Url(..)
17− , Path
18 , Segment(..)
8 , Segment(..)
19 , SegmentType(..)
9 , SegmentType(..)
20− , isCapture
10+ , Url(..)
21− , captureArg
11+ -- aliases
22− , QueryArg(..)
12+ , Path
23− , ArgType(..)
24− , HeaderArg(..)
25 , Arg(..)
13 , Arg(..)
26 , FunctionName(..)
14 , FunctionName(..)
27− , ReqBodyContentType(..)
28 , PathSegment(..)
15 , PathSegment(..)
29− -- * Lenses
16+ -- lenses
30 , argName
17 , argName
31 , argType
18 , argType
32 , argPath
19 , argPath
@@ -34,7 +21,6 @@ module Servant.Foreign
34 , reqMethod
21 , reqMethod
35 , reqHeaders
22 , reqHeaders
36 , reqBody
23 , reqBody
37− , reqBodyContentType
38 , reqReturnType
24 , reqReturnType
39 , reqFuncName
25 , reqFuncName
40 , path
26 , path
@@ -42,7 +28,7 @@ module Servant.Foreign
42 , queryArgName
28 , queryArgName
43 , queryArgType
29 , queryArgType
44 , headerArg
30 , headerArg
45− -- * Prisms
31+ -- prisms
46 , _PathSegment
32 , _PathSegment
47 , _HeaderArg
33 , _HeaderArg
48 , _ReplaceHeaderArg
34 , _ReplaceHeaderArg
@@ -51,11 +37,20 @@ module Servant.Foreign
51 , _Normal
37 , _Normal
52 , _Flag
38 , _Flag
53 , _List
39 , _List
40+ -- rest of it
41+ , HasForeign(..)
42+ , HasForeignType(..)
43+ , GenerateList(..)
44+ , NoTypes
45+ , captureArg
46+ , isCapture
47+ , defReq
48+ , listFromAPI
54− -- * Re-exports
49+ -- re-exports
55 , module Servant.API
50 , module Servant.API
56 , module Servant.Foreign.Inflections
51 , module Servant.Foreign.Inflections
57 ) where
52 ) where
58
53
59−import Servant.API
54+import Servant.API
55+import Servant.Foreign.Internal
60−import Servant.Foreign.Inflections
56+import Servant.Foreign.Inflections
61−import Servant.Foreign.Internal
servant-foreign/src/Servant/Foreign/Inflections.hs+17−25
@@ -10,40 +10,27 @@ module Servant.Foreign.Inflections
10 ) where
10 ) where
11
11
12
12
13−import Control.Lens hiding
13+import Control.Lens hiding (cons)
14− (cons)
15−import qualified Data.Char as C
14+import qualified Data.Char as C
16−import Data.Text hiding
15+import Data.Monoid
17− (map)
16+import Data.Text hiding (map)
18−import Prelude hiding
17+import Prelude hiding (head, tail)
19− (head, tail)
20import Servant.Foreign.Internal
18import Servant.Foreign.Internal
21
19
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−
28concatCaseL :: Getter FunctionName Text
20concatCaseL :: Getter FunctionName Text
29concatCaseL = _FunctionName . to mconcat
21concatCaseL = _FunctionName . to mconcat
30
22
31−-- | Use the snake_case convention.
23+-- | Function name builder that simply concat each part together
32−-- Each part is separated by a single underscore character.
33−--
34−-- @[ "get", "documents", "by", "id" ] → "get_documents_by_id"@
35−snakeCase :: FunctionName -> Text
24+concatCase :: FunctionName -> Text
36−snakeCase = view snakeCaseL
25+concatCase = view concatCaseL
37
26
38snakeCaseL :: Getter FunctionName Text
27snakeCaseL :: Getter FunctionName Text
39snakeCaseL = _FunctionName . to (intercalate "_")
28snakeCaseL = _FunctionName . to (intercalate "_")
40
29
41−-- | Use the camelCase convention.
30+-- | Function name builder using the snake_case convention.
42−-- The first part is lower case, every other part starts with an upper case character.
31+-- each part is separated by a single underscore character.
43−--
44−-- @[ "get", "documents", "by", "id" ] → "getDocumentsById"@
45−camelCase :: FunctionName -> Text
32+snakeCase :: FunctionName -> Text
46−camelCase = view camelCaseL
33+snakeCase = view snakeCaseL
47
34
48camelCaseL :: Getter FunctionName Text
35camelCaseL :: Getter FunctionName Text
49camelCaseL = _FunctionName . to convert
36camelCaseL = _FunctionName . to convert
@@ -52,3 +39,8 @@ camelCaseL = _FunctionName . to convert
52 convert (p:ps) = mconcat $ p : map capitalize ps
39 convert (p:ps) = mconcat $ p : map capitalize ps
53 capitalize "" = ""
40 capitalize "" = ""
54 capitalize name = C.toUpper (head name) `cons` tail name
41 capitalize name = C.toUpper (head name) `cons` tail name
42+
43+-- | Function name builder using the CamelCase convention.
44+-- each part begins with an upper case character.
45+camelCase :: FunctionName -> Text
46+camelCase = view camelCaseL
servant-foreign/src/Servant/Foreign/Internal.hs+61−212
@@ -1,110 +1,86 @@
1−{-# LANGUAGE CPP #-}
1+{-# LANGUAGE CPP #-}
2−{-# LANGUAGE ConstraintKinds #-}
2+{-# LANGUAGE ConstraintKinds #-}
3−{-# LANGUAGE DeriveDataTypeable #-}
3+{-# LANGUAGE DeriveDataTypeable #-}
4−{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleContexts #-}
5−{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7−{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE MultiParamTypeClasses #-}
8−{-# LANGUAGE OverloadedStrings #-}
8+{-# LANGUAGE OverloadedStrings #-}
9−{-# LANGUAGE PolyKinds #-}
9+{-# LANGUAGE PolyKinds #-}
10−{-# LANGUAGE ScopedTypeVariables #-}
10+{-# LANGUAGE ScopedTypeVariables #-}
11−{-# LANGUAGE TemplateHaskell #-}
11+{-# LANGUAGE TemplateHaskell #-}
12−{-# LANGUAGE TypeFamilies #-}
12+{-# LANGUAGE TypeFamilies #-}
13−{-# LANGUAGE TypeOperators #-}
13+{-# LANGUAGE TypeOperators #-}
14−{-# LANGUAGE UndecidableInstances #-}
14+{-# LANGUAGE UndecidableInstances #-}
15−
15+#if !MIN_VERSION_base(4,8,0)
16+{-# LANGUAGE NullaryTypeClasses #-}
17+#endif
18+
19+-- | Generalizes all the data needed to make code generation work with
20+-- arbitrary programming languages.
16module Servant.Foreign.Internal where
21module Servant.Foreign.Internal where
17
22
18−import Prelude ()
23+import Prelude ()
19−import Prelude.Compat
24+import Prelude.Compat
20
25
21−import Control.Lens
26+import Control.Lens (makePrisms, makeLenses, Getter, (&), (<>~), (%~),
22− (Getter, makeLenses, makePrisms, (%~), (&), (.~), (<>~))
27+ (.~))
23−import Data.Data
28+import Data.Data (Data)
24− (Data)
25import Data.Proxy
29import Data.Proxy
26import Data.String
30import Data.String
27import Data.Text
31import Data.Text
28−import Data.Text.Encoding
32+import Data.Typeable (Typeable)
29− (decodeUtf8)
33+import Data.Text.Encoding (decodeUtf8)
30−import Data.Typeable
31− (Typeable)
32import GHC.TypeLits
34import GHC.TypeLits
33−import qualified Network.HTTP.Types as HTTP
35+import qualified Network.HTTP.Types as HTTP
34import Servant.API
36import Servant.API
35−import Servant.API.Modifiers
36− (RequiredArgument)
37import Servant.API.TypeLevel
37import Servant.API.TypeLevel
38+import Servant.API.Modifiers (RequiredArgument)
38
39
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`.
42newtype FunctionName = FunctionName { unFunctionName :: [Text] }
40newtype FunctionName = FunctionName { unFunctionName :: [Text] }
43− deriving (Data, Show, Eq, Semigroup, Monoid, Typeable)
41+ deriving (Data, Show, Eq, Monoid, Typeable)
44
42
45makePrisms ''FunctionName
43makePrisms ''FunctionName
46
44
47−-- | See documentation of 'Arg'
48newtype PathSegment = PathSegment { unPathSegment :: Text }
45newtype PathSegment = PathSegment { unPathSegment :: Text }
49− deriving (Data, Show, Eq, IsString, Semigroup, Monoid, Typeable)
46+ deriving (Data, Show, Eq, IsString, Monoid, Typeable)
50
47
51makePrisms ''PathSegment
48makePrisms ''PathSegment
52
49
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
50+data Arg f = Arg
57 { _argName :: PathSegment
51 { _argName :: PathSegment
58− -- ^ The name to be captured.
59− --
60− -- Only for capture args it really denotes a path segment.
61− , _argType :: ftype
52+ , _argType :: f }
62− -- ^ Foreign type the associated value will have
63− }
64 deriving (Data, Eq, Show, Typeable)
53 deriving (Data, Eq, Show, Typeable)
65
54
66makeLenses ''Arg
55makeLenses ''Arg
67
56
68−argPath :: Getter (Arg ftype) Text
57+argPath :: Getter (Arg f) Text
69argPath = argName . _PathSegment
58argPath = argName . _PathSegment
70
59
71−data SegmentType ftype
60+data SegmentType f
72 = Static PathSegment
61 = Static PathSegment
73− -- ^ Static path segment.
62+ -- ^ a static path segment. like "/foo"
74− --
75− -- @"foo\/bar\/baz"@
76− --
77− -- contains the static segments @"foo"@, @"bar"@ and @"baz"@.
78− | Cap (Arg ftype)
63+ | Cap (Arg f)
79− -- ^ A capture.
64+ -- ^ a capture. like "/:userid"
80− --
81− -- @"user\/{userid}\/name"@
82− --
83− -- would capture the arg @userid@ with type @ftype@.
84 deriving (Data, Eq, Show, Typeable)
65 deriving (Data, Eq, Show, Typeable)
85
66
86makePrisms ''SegmentType
67makePrisms ''SegmentType
87
68
88−-- | A part of the Url’s path.
89−newtype Segment ftype = Segment { unSegment :: SegmentType ftype }
69+newtype Segment f = Segment { unSegment :: SegmentType f }
90 deriving (Data, Eq, Show, Typeable)
70 deriving (Data, Eq, Show, Typeable)
91
71
92makePrisms ''Segment
72makePrisms ''Segment
93
73
94−-- | Whether a segment is a 'Cap'.
95−isCapture :: Segment ftype -> Bool
74+isCapture :: Segment f -> Bool
96isCapture (Segment (Cap _)) = True
75isCapture (Segment (Cap _)) = True
97isCapture _ = False
76isCapture _ = False
98
77
99−-- | Crashing Arg extraction from segment, TODO: remove
100−captureArg :: Segment ftype -> Arg ftype
78+captureArg :: Segment f -> Arg f
101captureArg (Segment (Cap s)) = s
79captureArg (Segment (Cap s)) = s
102captureArg _ = error "captureArg called on non capture"
80captureArg _ = error "captureArg called on non capture"
103
81
104−-- TODO: remove, unnecessary indirection
105−type Path ftype = [Segment ftype]
82+type Path f = [Segment f]
106
83
107−-- | Type of a 'QueryArg'.
108data ArgType
84data ArgType
109 = Normal
85 = Normal
110 | Flag
86 | Flag
@@ -113,41 +89,18 @@ data ArgType
113
89
114makePrisms ''ArgType
90makePrisms ''ArgType
115
91
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
92+data QueryArg f = QueryArg
133− { _queryArgName :: Arg ftype
93+ { _queryArgName :: Arg f
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
135 , _queryArgType :: ArgType
94 , _queryArgType :: ArgType
136− -- ^ one of normal/plain, list or flag
137 }
95 }
138 deriving (Data, Eq, Show, Typeable)
96 deriving (Data, Eq, Show, Typeable)
139
97
140makeLenses ''QueryArg
98makeLenses ''QueryArg
141
99
142−data HeaderArg ftype =
100+data HeaderArg f = HeaderArg
143− -- | The name of the header and the foreign type of its value.
144− HeaderArg
145− { _headerArg :: Arg ftype }
101+ { _headerArg :: Arg f }
146− -- | Unused, will never be set.
147− --
148− -- TODO: remove
149 | ReplaceHeaderArg
102 | ReplaceHeaderArg
150− { _headerArg :: Arg ftype
103+ { _headerArg :: Arg f
151 , _headerPattern :: Text
104 , _headerPattern :: Text
152 }
105 }
153 deriving (Data, Eq, Show, Typeable)
106 deriving (Data, Eq, Show, Typeable)
@@ -156,78 +109,31 @@ makeLenses ''HeaderArg
156
109
157makePrisms ''HeaderArg
110makePrisms ''HeaderArg
158
111
159−-- | Full endpoint url, with all captures and parameters
160−data Url ftype = Url
112+data Url f = Url
161− { _path :: Path ftype
113+ { _path :: Path f
162− -- ^ Url path, list of either static segments or captures
163− --
164− -- @"foo\/{id}\/bar"@
165− , _queryStr :: [QueryArg ftype]
114+ , _queryStr :: [QueryArg f]
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@
175 }
115 }
176 deriving (Data, Eq, Show, Typeable)
116 deriving (Data, Eq, Show, Typeable)
177
117
178−defUrl :: Url ftype
118+defUrl :: Url f
179−defUrl = Url [] [] Nothing
119+defUrl = Url [] []
180
120
181makeLenses ''Url
121makeLenses ''Url
182
122
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
123+data Req f = Req
193− { _reqUrl :: Url ftype
124+ { _reqUrl :: Url f
194− -- ^ Full list of URL segments, including captures
195− , _reqMethod :: HTTP.Method
125+ , _reqMethod :: HTTP.Method
196− -- ^ @\"GET\"@\/@\"POST\"@\/@\"PUT\"@\/…
197− , _reqHeaders :: [HeaderArg ftype]
126+ , _reqHeaders :: [HeaderArg f]
198− -- ^ Headers required by this endpoint, with their type
199− , _reqBody :: Maybe ftype
127+ , _reqBody :: Maybe f
200− -- ^ Foreign type of the expected request body ('ReqBody'), if any
201− , _reqReturnType :: Maybe ftype
128+ , _reqReturnType :: Maybe f
202− -- ^ The foreign type of the response, if any
203− , _reqFuncName :: FunctionName
129+ , _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]@
224 }
130 }
225 deriving (Data, Eq, Show, Typeable)
131 deriving (Data, Eq, Show, Typeable)
226
132
227makeLenses ''Req
133makeLenses ''Req
228
134
229defReq :: Req ftype
135defReq :: Req ftype
230−defReq = Req defUrl "GET" [] Nothing Nothing (FunctionName []) ReqBodyJSON
136+defReq = Req defUrl "GET" [] Nothing Nothing (FunctionName [])
231
137
232-- | 'HasForeignType' maps Haskell types with types in the target
138-- | 'HasForeignType' maps Haskell types with types in the target
233-- language of your backend. For example, let's say you're
139-- language of your backend. For example, let's say you're
@@ -244,7 +150,7 @@ defReq = Req defUrl "GET" [] Nothing Nothing (FunctionName []) ReqBodyJSON
244-- >
150-- >
245-- > -- Or for example in case of lists
151-- > -- Or for example in case of lists
246-- > instance HasForeignType LangX Text a => HasForeignType LangX Text [a] where
152-- > instance HasForeignType LangX Text a => HasForeignType LangX Text [a] where
247−-- > typeFor lang ftype _ = "listX of " <> typeFor lang ftype (Proxy :: Proxy a)
153+-- > typeFor lang type _ = "listX of " <> typeFor lang ftype (Proxy :: Proxy a)
248--
154--
249-- Finally to generate list of information about all the endpoints for
155-- Finally to generate list of information about all the endpoints for
250-- an API you create a function of a form:
156-- an API you create a function of a form:
@@ -264,16 +170,11 @@ defReq = Req defUrl "GET" [] Nothing Nothing (FunctionName []) ReqBodyJSON
264class HasForeignType lang ftype a where
170class HasForeignType lang ftype a where
265 typeFor :: Proxy lang -> Proxy ftype -> Proxy a -> ftype
171 typeFor :: Proxy lang -> Proxy ftype -> Proxy a -> ftype
266
172
267−-- | The language definition without any foreign types. It can be used for dynamic languages which do not /do/ type annotations.
268data NoTypes
173data NoTypes
269
174
270−-- | Use if the foreign language does not have any types.
271−instance HasForeignType NoTypes NoContent a where
175+instance HasForeignType NoTypes NoContent ftype where
272 typeFor _ _ _ = NoContent
176 typeFor _ _ _ = NoContent
273
177
274−-- | Implementation of the Servant framework types.
275−--
276−-- Relevant instances: Everything containing 'HasForeignType'.
277class HasForeign lang ftype (api :: *) where
178class HasForeign lang ftype (api :: *) where
278 type Foreign ftype api :: *
179 type Foreign ftype api :: *
279 foreignFor :: Proxy lang -> Proxy ftype -> Proxy api -> Req ftype -> Foreign ftype api
180 foreignFor :: Proxy lang -> Proxy ftype -> Proxy api -> Req ftype -> Foreign ftype api
@@ -336,33 +237,6 @@ instance (Elem JSON list, HasForeignType lang ftype a, ReflectMethod method)
336 method = reflectMethod (Proxy :: Proxy method)
237 method = reflectMethod (Proxy :: Proxy method)
337 methodLC = toLower $ decodeUtf8 method
238 methodLC = toLower $ decodeUtf8 method
338
239
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−
352−-- | TODO: doesn't taking framing into account.
353−instance (ct ~ JSON, HasForeignType lang ftype a, ReflectMethod method)
354− => HasForeign lang ftype (Stream method status framing ct a) where
355− type Foreign ftype (Stream method status framing ct a) = Req ftype
356−
357− foreignFor lang Proxy Proxy req =
358− req & reqFuncName . _FunctionName %~ (methodLC :)
359− & reqMethod .~ method
360− & reqReturnType .~ Just retType
361− where
362− retType = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy a)
363− method = reflectMethod (Proxy :: Proxy method)
364− methodLC = toLower $ decodeUtf8 method
365−
366instance (KnownSymbol sym, HasForeignType lang ftype (RequiredArgument mods a), HasForeign lang ftype api)
240instance (KnownSymbol sym, HasForeignType lang ftype (RequiredArgument mods a), HasForeign lang ftype api)
367 => HasForeign lang ftype (Header' mods sym a :> api) where
241 => HasForeign lang ftype (Header' mods sym a :> api) where
368 type Foreign ftype (Header' mods sym a :> api) = Foreign ftype api
242 type Foreign ftype (Header' mods sym a :> api) = Foreign ftype api
@@ -416,16 +290,6 @@ instance
416 { _argName = PathSegment str
290 { _argName = PathSegment str
417 , _argType = typeFor lang ftype (Proxy :: Proxy Bool) }
291 , _argType = typeFor lang ftype (Proxy :: Proxy Bool) }
418
292
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−
429instance HasForeign lang ftype Raw where
293instance HasForeign lang ftype Raw where
430 type Foreign ftype Raw = HTTP.Method -> Req ftype
294 type Foreign ftype Raw = HTTP.Method -> Req ftype
431
295
@@ -441,14 +305,6 @@ instance (Elem JSON list, HasForeignType lang ftype a, HasForeign lang ftype api
441 foreignFor lang ftype (Proxy :: Proxy api) $
305 foreignFor lang ftype (Proxy :: Proxy api) $
442 req & reqBody .~ (Just $ typeFor lang ftype (Proxy :: Proxy a))
306 req & reqBody .~ (Just $ typeFor lang ftype (Proxy :: Proxy a))
443
307
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−
452instance (KnownSymbol path, HasForeign lang ftype api)
308instance (KnownSymbol path, HasForeign lang ftype api)
453 => HasForeign lang ftype (path :> api) where
309 => HasForeign lang ftype (path :> api) where
454 type Foreign ftype (path :> api) = Foreign ftype api
310 type Foreign ftype (path :> api) = Foreign ftype api
@@ -487,13 +343,6 @@ instance HasForeign lang ftype api =>
487
343
488 foreignFor lang ftype Proxy = foreignFor lang ftype (Proxy :: Proxy api)
344 foreignFor lang ftype Proxy = foreignFor lang ftype (Proxy :: Proxy api)
489
345
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−
497instance HasForeign lang ftype api
346instance HasForeign lang ftype api
498 => HasForeign lang ftype (HttpVersion :> api) where
347 => HasForeign lang ftype (HttpVersion :> api) where
499 type Foreign ftype (HttpVersion :> api) = Foreign ftype api
348 type Foreign ftype (HttpVersion :> api) = Foreign ftype api
servant-foreign/test/Servant/ForeignSpec.hs+23−27
@@ -1,23 +1,27 @@
1+{-# LANGUAGE CPP #-}
1−{-# LANGUAGE ConstraintKinds #-}
2+{-# LANGUAGE ConstraintKinds #-}
2−{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleContexts #-}
4−{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE FlexibleInstances #-}
5−{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
6−{-# LANGUAGE OverloadedStrings #-}
7+{-# LANGUAGE OverloadedStrings #-}
7−{-# LANGUAGE PolyKinds #-}
8+{-# LANGUAGE PolyKinds #-}
8−{-# LANGUAGE ScopedTypeVariables #-}
9+{-# LANGUAGE ScopedTypeVariables #-}
9−{-# LANGUAGE TypeFamilies #-}
10+{-# LANGUAGE TypeFamilies #-}
10−{-# LANGUAGE TypeOperators #-}
11+{-# LANGUAGE TypeOperators #-}
12+#if __GLASGOW_HASKELL__ < 709
13+{-# OPTIONS_GHC -fcontext-stack=41 #-}
14+#endif
15+#include "overlapping-compat.h"
11
16
12module Servant.ForeignSpec where
17module Servant.ForeignSpec where
13
18
19+import Data.Monoid ((<>))
14−import Data.Proxy
20+import Data.Proxy
15−import Servant.Foreign
21+import Servant.Foreign
16−import Servant.Test.ComprehensiveAPI
22+import Servant.API.Internal.Test.ComprehensiveAPI
17−import Servant.Types.SourceT
18− (SourceT)
19
23
20−import Test.Hspec
24+import Test.Hspec
21
25
22
26
23spec :: Spec
27spec :: Spec
@@ -51,16 +55,13 @@ instance HasForeignType LangX String (Headers ctyps NoContent) where
51instance HasForeignType LangX String Int where
55instance HasForeignType LangX String Int where
52 typeFor _ _ _ = "intX"
56 typeFor _ _ _ = "intX"
53
57
54−instance HasForeignType LangX String (SourceT m a) where
55− typeFor _ _ _ = "streamTX"
56−
57instance HasForeignType LangX String Bool where
58instance HasForeignType LangX String Bool where
58 typeFor _ _ _ = "boolX"
59 typeFor _ _ _ = "boolX"
59
60
60−instance {-# OVERLAPPING #-} HasForeignType LangX String String where
61+instance OVERLAPPING_ HasForeignType LangX String String where
61 typeFor _ _ _ = "stringX"
62 typeFor _ _ _ = "stringX"
62
63
63−instance {-# OVERLAPPABLE #-} HasForeignType LangX String a => HasForeignType LangX String [a] where
64+instance OVERLAPPABLE_ HasForeignType LangX String a => HasForeignType LangX String [a] where
64 typeFor lang ftype _ = "listX of " <> typeFor lang ftype (Proxy :: Proxy a)
65 typeFor lang ftype _ = "listX of " <> typeFor lang ftype (Proxy :: Proxy a)
65
66
66instance (HasForeignType LangX String a) => HasForeignType LangX String (Maybe a) where
67instance (HasForeignType LangX String a) => HasForeignType LangX String (Maybe a) where
@@ -89,7 +90,6 @@ listFromAPISpec = describe "listFromAPI" $ do
89 { _reqUrl = Url
90 { _reqUrl = Url
90 [ Segment $ Static "test" ]
91 [ Segment $ Static "test" ]
91 [ QueryArg (Arg "flag" "boolX") Flag ]
92 [ QueryArg (Arg "flag" "boolX") Flag ]
92− Nothing
93 , _reqMethod = "GET"
93 , _reqMethod = "GET"
94 , _reqHeaders = [HeaderArg $ Arg "header" "maybe listX of stringX"]
94 , _reqHeaders = [HeaderArg $ Arg "header" "maybe listX of stringX"]
95 , _reqBody = Nothing
95 , _reqBody = Nothing
@@ -102,7 +102,6 @@ listFromAPISpec = describe "listFromAPI" $ do
102 { _reqUrl = Url
102 { _reqUrl = Url
103 [ Segment $ Static "test" ]
103 [ Segment $ Static "test" ]
104 [ QueryArg (Arg "param" "maybe intX") Normal ]
104 [ QueryArg (Arg "param" "maybe intX") Normal ]
105− Nothing
106 , _reqMethod = "POST"
105 , _reqMethod = "POST"
107 , _reqHeaders = []
106 , _reqHeaders = []
108 , _reqBody = Just "listX of stringX"
107 , _reqBody = Just "listX of stringX"
@@ -114,9 +113,8 @@ listFromAPISpec = describe "listFromAPI" $ do
114 shouldBe putReq $ defReq
113 shouldBe putReq $ defReq
115 { _reqUrl = Url
114 { _reqUrl = Url
116 [ Segment $ Static "test" ]
115 [ Segment $ Static "test" ]
117− -- Should this be |intX| or |listX of intX| ?
116+ -- Shoud this be |intX| or |listX of intX| ?
118 [ QueryArg (Arg "params" "listX of intX") List ]
117 [ QueryArg (Arg "params" "listX of intX") List ]
119− Nothing
120 , _reqMethod = "PUT"
118 , _reqMethod = "PUT"
121 , _reqHeaders = []
119 , _reqHeaders = []
122 , _reqBody = Just "stringX"
120 , _reqBody = Just "stringX"
@@ -130,7 +128,6 @@ listFromAPISpec = describe "listFromAPI" $ do
130 [ Segment $ Static "test"
128 [ Segment $ Static "test"
131 , Segment $ Cap (Arg "id" "intX") ]
129 , Segment $ Cap (Arg "id" "intX") ]
132 []
130 []
133− Nothing
134 , _reqMethod = "DELETE"
131 , _reqMethod = "DELETE"
135 , _reqHeaders = []
132 , _reqHeaders = []
136 , _reqBody = Nothing
133 , _reqBody = Nothing
@@ -144,7 +141,6 @@ listFromAPISpec = describe "listFromAPI" $ do
144 [ Segment $ Static "test"
141 [ Segment $ Static "test"
145 , Segment $ Cap (Arg "ids" "listX of intX") ]
142 , Segment $ Cap (Arg "ids" "listX of intX") ]
146 []
143 []
147− Nothing
148 , _reqMethod = "GET"
144 , _reqMethod = "GET"
149 , _reqHeaders = []
145 , _reqHeaders = []
150 , _reqBody = Nothing
146 , _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

This diff is too big to show here.

servant-http-streams/README.lhsdeleted−1

This diff is too big to show here.

servant-http-streams/README.mddeleted−44

This diff is too big to show here.

servant-http-streams/Setup.hsdeleted−2

This diff is too big to show here.

servant-http-streams/servant-http-streams.cabaldeleted−132

This diff is too big to show here.

servant-http-streams/src/Servant/HttpStreams.hsdeleted−19

This diff is too big to show here.

servant-http-streams/src/Servant/HttpStreams/Internal.hsdeleted−258

This diff is too big to show here.

servant-http-streams/test/Servant/StreamSpec.hsdeleted−110

This diff is too big to show here.

servant-http-streams/test/Spec.hsdeleted−1

This diff is too big to show here.

servant-machines/CHANGELOG.mddeleted−4

This diff is too big to show here.

servant-machines/LICENSEdeleted−30

This diff is too big to show here.

servant-machines/README.mddeleted−3

This diff is too big to show here.

servant-machines/Setup.hsdeleted−2

This diff is too big to show here.

servant-machines/example/Main.hsdeleted−98

This diff is too big to show here.

servant-machines/servant-machines.cabaldeleted−59

This diff is too big to show here.

servant-machines/src/Servant/Machines.hsdeleted−46

This diff is too big to show here.

servant-pipes/CHANGELOG.mddeleted−22

This diff is too big to show here.

servant-pipes/LICENSEdeleted−30

This diff is too big to show here.

servant-pipes/README.mddeleted−3

This diff is too big to show here.

servant-pipes/Setup.hsdeleted−2

This diff is too big to show here.

servant-pipes/example/Main.hsdeleted−107

This diff is too big to show here.

servant-pipes/servant-pipes.cabaldeleted−63

This diff is too big to show here.

servant-pipes/src/Servant/Pipes.hsdeleted−75

This diff is too big to show here.

servant-server/CHANGELOG.md−254

This diff is too big to show here.

servant-server/LICENSE+1−1

This diff is too big to show here.

servant-server/README.md+1−1

This diff is too big to show here.

servant-server/Setup.hsdeleted−2

This diff is too big to show here.

servant-swagger/Setup.hs → servant-server/Setup.lhsrenamed+3−5

This diff is too big to show here.

servant-server/example/README.md+1−1

This diff is too big to show here.

servant-server/example/greet.hs+3−19

This diff is too big to show here.

servant-server/include/overlapping-compat.hnew file+8

This diff is too big to show here.

servant-server/servant-server.cabal+87−67

This diff is too big to show here.

servant-server/src/Servant.hs+5−6

This diff is too big to show here.

servant-server/src/Servant/Server.hs+16−73

This diff is too big to show here.

servant-server/src/Servant/Server/Experimental/Auth.hs+25−28

This diff is too big to show here.

servant-server/src/Servant/Server/Generic.hsdeleted−92

This diff is too big to show here.

servant-server/src/Servant/Server/Internal.hs+206−439

This diff is too big to show here.

servant-server/src/Servant/Server/Internal/BasicAuth.hs+16−23

This diff is too big to show here.

servant-server/src/Servant/Server/Internal/Context.hs+15−27

This diff is too big to show here.

servant-server/src/Servant/Server/Internal/Delayed.hsdeleted−272

This diff is too big to show here.

servant-server/src/Servant/Server/Internal/DelayedIO.hsdeleted−71

This diff is too big to show here.

servant-server/src/Servant/Server/Internal/ErrorFormatter.hsdeleted−87

This diff is too big to show here.

servant-server/src/Servant/Server/Internal/Handler.hs+17−30

This diff is too big to show here.

servant-server/src/Servant/Server/Internal/RouteResult.hsdeleted−76

This diff is too big to show here.

servant-server/src/Servant/Server/Internal/Router.hs+43−94

This diff is too big to show here.

servant-server/src/Servant/Server/Internal/RoutingApplication.hs+377−7

This diff is too big to show here.

servant-server/src/Servant/Server/Internal/ServerError.hs → servant-server/src/Servant/Server/Internal/ServantErr.hsrenamed+79−84

This diff is too big to show here.

servant-server/src/Servant/Server/StaticFiles.hsdeleted−83

This diff is too big to show here.

servant-server/src/Servant/Server/UVerb.hsdeleted−116

This diff is too big to show here.

servant-server/src/Servant/Utils/StaticFiles.hs+84−4

This diff is too big to show here.

servant-server/test/Servant/ArbitraryMonadServerSpec.hs+3−4

This diff is too big to show here.

servant-server/test/Servant/HoistSpec.hs+3−4

This diff is too big to show here.

servant-server/test/Servant/Server/ErrorSpec.hs+9−78

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

servant-server/test/Servant/Server/RouterSpec.hs+26−179

This diff is too big to show here.

servant-server/test/Servant/Server/StreamingSpec.hs+7−8

This diff is too big to show here.

servant-server/test/Servant/Server/UsingContextSpec.hs+3−4

This diff is too big to show here.

servant-server/test/Servant/Server/UsingContextSpec/TestCombinators.hs+9−9

This diff is too big to show here.

servant-server/test/Servant/ServerSpec.hs+174−399

This diff is too big to show here.

servant-server/test/Servant/Server/StaticFilesSpec.hs → servant-server/test/Servant/Utils/StaticFilesSpec.hsrenamed+16−25

This diff is too big to show here.

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

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/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+5−673

This diff is too big to show here.

servant/LICENSE+1−1

This diff is too big to show here.

servant/Setup.hsdeleted−2

This diff is too big to show here.

servant-auth/servant-auth-docs/Setup.hs → servant/Setup.lhsrenamed+3−5

This diff is too big to show here.

servant/include/overlapping-compat.hnew file+8

This diff is too big to show here.

servant/servant.cabal+89−82

This diff is too big to show here.

servant/src/Servant/API.hs+65−89

This diff is too big to show here.

servant/src/Servant/API/Alternative.hs+3−25

This diff is too big to show here.

servant/src/Servant/API/BasicAuth.hs+6−9

This diff is too big to show here.

servant/src/Servant/API/Capture.hs+2−4

This diff is too big to show here.

servant/src/Servant/API/ContentTypes.hs+34−36

This diff is too big to show here.

servant/src/Servant/API/Description.hs+6−9

This diff is too big to show here.

servant/src/Servant/API/Empty.hs+1−2

This diff is too big to show here.

servant/src/Servant/API/Experimental/Auth.hs+4−5

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/Generic.hsdeleted−146

This diff is too big to show here.

servant/src/Servant/API/Header.hs+3−5

This diff is too big to show here.

servant/src/Servant/API/HttpVersion.hs+1−2

This diff is too big to show here.

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

This diff is too big to show here.

servant/src/Servant/API/IsSecure.hs+2−4

This diff is too big to show here.

servant/src/Servant/API/Modifiers.hs+7−9

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/QueryParam.hs+3−5

This diff is too big to show here.

servant/src/Servant/API/Raw.hs+3−9

This diff is too big to show here.

servant/src/Servant/API/RemoteHost.hs−1

This diff is too big to show here.

servant/src/Servant/API/ReqBody.hs+3−4

This diff is too big to show here.

servant/src/Servant/API/ResponseHeaders.hs+37−135

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+108−225

This diff is too big to show here.

servant/src/Servant/API/Sub.hs+1−2

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+37−81

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/Vault.hs+1−2

This diff is too big to show here.

servant/src/Servant/API/Verbs.hs+17−30

This diff is too big to show here.

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

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.hsdeleted−679

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/Enter.hsnew file+121

This diff is too big to show here.

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

This diff is too big to show here.

servant/test/Servant/API/ContentTypesSpec.hs+21−50

This diff is too big to show here.

servant/test/Servant/API/ResponseHeadersSpec.hs+4−15

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/Utils/EnterSpec.hsnew file+33

This diff is too big to show here.

servant/test/Servant/LinksSpec.hs → servant/test/Servant/Utils/LinksSpec.hsrenamed+18−34

This diff is too big to show here.

servant/test/doctests.hsnew file+25

This diff is too big to show here.

setup.pydeleted−11

This diff is too big to show here.

stack-ghcjs.yamldeleted−34

This diff is too big to show here.

stack.yaml+8−10

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.