git.iko.soy/servant

on 2e5f8e7 help sign in

fromaaeee88

swap

to0 ahead, 595 behind

compare

.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

.travis.ymlnew file+172

@@ -0,0 +1,172 @@

1+# This Travis job script has been generated by a script via

2+#

3+# runghc make_travis_yml_2.hs '--config=cabal.make-travis-yml' '--output=.travis.yml' 'cabal.project'

4+#

5+# For more information, see https://github.com/haskell-CI/haskell-ci

6+#

7+language: c

8+sudo: false

9+

10+git:

11+ submodules: false # whether to recursively clone submodules

12+

13+branches:

14+ only:

15+ - master

16+

17+cache:

18+ directories:

19+ - $HOME/.cabal/packages

20+ - $HOME/.cabal/store

21+

22+before_cache:

23+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log

24+ # remove files that are regenerated by 'cabal update'

25+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.*

26+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json

27+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache

28+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar

29+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx

30+

31+ - rm -rfv $HOME/.cabal/packages/head.hackage

32+

33+matrix:

34+ include:

35+ - compiler: "ghc-8.6.1"

36+ # env: TEST=--disable-tests BENCH=--disable-benchmarks

37+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.6.1], sources: [hvr-ghc]}}

38+ - compiler: "ghc-8.4.4"

39+ # env: TEST=--disable-tests BENCH=--disable-benchmarks

40+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.4.4], sources: [hvr-ghc]}}

41+ - compiler: "ghc-8.2.2"

42+ # env: TEST=--disable-tests BENCH=--disable-benchmarks

43+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.2.2], sources: [hvr-ghc]}}

44+ - compiler: "ghc-8.0.2"

45+ # env: TEST=--disable-tests BENCH=--disable-benchmarks

46+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.0.2], sources: [hvr-ghc]}}

47+

48+before_install:

49+ - HC=${CC}

50+ - HCPKG=${HC/ghc/ghc-pkg}

51+ - unset CC

52+ - ROOTDIR=$(pwd)

53+ - mkdir -p $HOME/.local/bin

54+ - "PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$HOME/local/bin:$PATH"

55+ - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') ))

56+ - echo $HCNUMVER

57+

58+install:

59+ - cabal --version

60+ - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"

61+ - BENCH=${BENCH---enable-benchmarks}

62+ - TEST=${TEST---enable-tests}

63+ - HADDOCK=${HADDOCK-true}

64+ - UNCONSTRAINED=${UNCONSTRAINED-true}

65+ - NOINSTALLEDCONSTRAINTS=${NOINSTALLEDCONSTRAINTS-false}

66+ - GHCHEAD=${GHCHEAD-false}

67+ - travis_retry cabal update -v

68+ - "sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config"

69+ - rm -fv cabal.project cabal.project.local

70+ - "if [ $HCNUMVER -ge 70800 ]; then sed -i.bak 's/-- ghc-options:.*/ghc-options: -j2/' ${HOME}/.cabal/config; fi"

71+ - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$'

72+ - "printf 'packages: \"servant\" \"servant-client\" \"servant-client-core\" \"servant-docs\" \"servant-foreign\" \"servant-server\" \"doc/tutorial\" \"doc/cookbook/basic-auth\" \"doc/cookbook/curl-mock\" \"doc/cookbook/db-postgres-pool\" \"doc/cookbook/db-sqlite-simple\" \"doc/cookbook/file-upload\" \"doc/cookbook/generic\" \"doc/cookbook/https\" \"doc/cookbook/sentry\" \"doc/cookbook/testing\" \"doc/cookbook/structuring-apis\" \"doc/cookbook/using-custom-monad\" \"doc/cookbook/using-free-client\"\\n' > cabal.project"

73+ - "echo 'constraints: foundation >=0.0.14,memory <0.14.12 || >0.14.12' >> cabal.project"

74+ - "echo 'allow-newer: servant-auth-server:http-types,servant-auth-server:servant-server,servant-js:base, servant-pagination:servant,servant-pagination:servant-server' >> cabal.project"

75+ - touch cabal.project.local

76+ - "if ! $NOINSTALLEDCONSTRAINTS; then for pkg in $($HCPKG list --simple-output); do echo $pkg | grep -vw -- servant | grep -vw -- servant-client | grep -vw -- servant-client-core | grep -vw -- servant-docs | grep -vw -- servant-foreign | grep -vw -- servant-server | grep -vw -- tutorial | grep -vw -- cookbook-basic-auth | grep -vw -- cookbook-curl-mock | grep -vw -- cookbook-db-postgres-pool | grep -vw -- cookbook-db-sqlite-simple | grep -vw -- cookbook-file-upload | grep -vw -- cookbook-generic | grep -vw -- cookbook-https | grep -vw -- cookbook-sentry | grep -vw -- cookbook-testing | grep -vw -- cookbook-structuring-apis | grep -vw -- cookbook-using-custom-monad | grep -vw -- cookbook-using-free-client | sed 's/^/constraints: /' | sed 's/-[^-]*$/ installed/' >> cabal.project.local; done; fi"

77+ - cat cabal.project || true

78+ - cat cabal.project.local || true

79+ - if [ -f "servant/configure.ac" ]; then

80+ (cd "servant" && autoreconf -i);

81+ fi

82+ - if [ -f "servant-client/configure.ac" ]; then

83+ (cd "servant-client" && autoreconf -i);

84+ fi

85+ - if [ -f "servant-client-core/configure.ac" ]; then

86+ (cd "servant-client-core" && autoreconf -i);

87+ fi

88+ - if [ -f "servant-docs/configure.ac" ]; then

89+ (cd "servant-docs" && autoreconf -i);

90+ fi

91+ - if [ -f "servant-foreign/configure.ac" ]; then

92+ (cd "servant-foreign" && autoreconf -i);

93+ fi

94+ - if [ -f "servant-server/configure.ac" ]; then

95+ (cd "servant-server" && autoreconf -i);

96+ fi

97+ - if [ -f "doc/tutorial/configure.ac" ]; then

98+ (cd "doc/tutorial" && autoreconf -i);

99+ fi

100+ - if [ -f "doc/cookbook/basic-auth/configure.ac" ]; then

101+ (cd "doc/cookbook/basic-auth" && autoreconf -i);

102+ fi

103+ - if [ -f "doc/cookbook/curl-mock/configure.ac" ]; then

104+ (cd "doc/cookbook/curl-mock" && autoreconf -i);

105+ fi

106+ - if [ -f "doc/cookbook/db-postgres-pool/configure.ac" ]; then

107+ (cd "doc/cookbook/db-postgres-pool" && autoreconf -i);

108+ fi

109+ - if [ -f "doc/cookbook/db-sqlite-simple/configure.ac" ]; then

110+ (cd "doc/cookbook/db-sqlite-simple" && autoreconf -i);

111+ fi

112+ - if [ -f "doc/cookbook/file-upload/configure.ac" ]; then

113+ (cd "doc/cookbook/file-upload" && autoreconf -i);

114+ fi

115+ - if [ -f "doc/cookbook/generic/configure.ac" ]; then

116+ (cd "doc/cookbook/generic" && autoreconf -i);

117+ fi

118+ - if [ -f "doc/cookbook/https/configure.ac" ]; then

119+ (cd "doc/cookbook/https" && autoreconf -i);

120+ fi

121+ - if [ -f "doc/cookbook/sentry/configure.ac" ]; then

122+ (cd "doc/cookbook/sentry" && autoreconf -i);

123+ fi

124+ - if [ -f "doc/cookbook/testing/configure.ac" ]; then

125+ (cd "doc/cookbook/testing" && autoreconf -i);

126+ fi

127+ - if [ -f "doc/cookbook/structuring-apis/configure.ac" ]; then

128+ (cd "doc/cookbook/structuring-apis" && autoreconf -i);

129+ fi

130+ - if [ -f "doc/cookbook/using-custom-monad/configure.ac" ]; then

131+ (cd "doc/cookbook/using-custom-monad" && autoreconf -i);

132+ fi

133+ - if [ -f "doc/cookbook/using-free-client/configure.ac" ]; then

134+ (cd "doc/cookbook/using-free-client" && autoreconf -i);

135+ fi

136+ - rm -f cabal.project.freeze

137+ - rm -rf .ghc.environment.* "servant"/dist "servant-client"/dist "servant-client-core"/dist "servant-docs"/dist "servant-foreign"/dist "servant-server"/dist "doc/tutorial"/dist "doc/cookbook/basic-auth"/dist "doc/cookbook/curl-mock"/dist "doc/cookbook/db-postgres-pool"/dist "doc/cookbook/db-sqlite-simple"/dist "doc/cookbook/file-upload"/dist "doc/cookbook/generic"/dist "doc/cookbook/https"/dist "doc/cookbook/sentry"/dist "doc/cookbook/testing"/dist "doc/cookbook/structuring-apis"/dist "doc/cookbook/using-custom-monad"/dist "doc/cookbook/using-free-client"/dist

138+ - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)

139+

140+# Here starts the actual work to be performed for the package under test;

141+# any command which exits with a non-zero exit code causes the build to fail.

142+script:

143+ # test that source-distributions can be generated

144+ - echo Packaging... && echo -en 'travis_fold:start:sdist\\r'

145+ - cabal new-sdist all

146+ - echo -en 'travis_fold:end:sdist\\r'

147+ - echo Unpacking... && echo -en 'travis_fold:start:unpack\\r'

148+ - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/

149+ - cd ${DISTDIR} || false

150+ - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \;

151+ - "printf 'packages: servant-*/*.cabal servant-client-*/*.cabal servant-client-core-*/*.cabal servant-docs-*/*.cabal servant-foreign-*/*.cabal servant-server-*/*.cabal tutorial-*/*.cabal cookbook-basic-auth-*/*.cabal cookbook-curl-mock-*/*.cabal cookbook-db-postgres-pool-*/*.cabal cookbook-db-sqlite-simple-*/*.cabal cookbook-file-upload-*/*.cabal cookbook-generic-*/*.cabal cookbook-https-*/*.cabal cookbook-sentry-*/*.cabal cookbook-testing-*/*.cabal cookbook-structuring-apis-*/*.cabal cookbook-using-custom-monad-*/*.cabal cookbook-using-free-client-*/*.cabal\\n' > cabal.project"

152+ - "echo 'constraints: foundation >=0.0.14,memory <0.14.12 || >0.14.12' >> cabal.project"

153+ - "echo 'allow-newer: servant-auth-server:http-types,servant-auth-server:servant-server,servant-js:base, servant-pagination:servant,servant-pagination:servant-server' >> cabal.project"

154+ - touch cabal.project.local

155+ - "if ! $NOINSTALLEDCONSTRAINTS; then for pkg in $($HCPKG list --simple-output); do echo $pkg | grep -vw -- servant | grep -vw -- servant-client | grep -vw -- servant-client-core | grep -vw -- servant-docs | grep -vw -- servant-foreign | grep -vw -- servant-server | grep -vw -- tutorial | grep -vw -- cookbook-basic-auth | grep -vw -- cookbook-curl-mock | grep -vw -- cookbook-db-postgres-pool | grep -vw -- cookbook-db-sqlite-simple | grep -vw -- cookbook-file-upload | grep -vw -- cookbook-generic | grep -vw -- cookbook-https | grep -vw -- cookbook-sentry | grep -vw -- cookbook-testing | grep -vw -- cookbook-structuring-apis | grep -vw -- cookbook-using-custom-monad | grep -vw -- cookbook-using-free-client | sed 's/^/constraints: /' | sed 's/-[^-]*$/ installed/' >> cabal.project.local; done; fi"

156+ - cat cabal.project || true

157+ - cat cabal.project.local || true

158+ - echo -en 'travis_fold:end:unpack\\r'

159+

160+ - echo Building with tests and benchmarks... && echo -en 'travis_fold:start:build-everything\\r'

161+ # build & run tests, build benchmarks

162+ - cabal new-build -w ${HC} ${TEST} ${BENCH} all

163+ - echo -en 'travis_fold:end:build-everything\\r'

164+ - if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} ${BENCH} all; fi

165+

166+ - echo Haddock... && echo -en 'travis_fold:start:haddock\\r'

167+ # haddock

168+ - if $HADDOCK; then cabal new-haddock -w ${HC} ${TEST} ${BENCH} all; else echo "Skipping haddock generation";fi

169+

170+ - echo -en 'travis_fold:end:haddock\\r'

171+# REGENDATA ["--config=cabal.make-travis-yml","--output=.travis.yml","cabal.project"]

172+# EOF

CONTRIBUTING.md+4−34

@@ -21,7 +21,6 @@ Or `nix`:

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,7 @@ 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+**Important**: please do not modify the changelog files nor the versions of the servant packages you are sending patches for. We take care of this before every release and do it uniformly for all the servant packages, so there's no need to worry about this for your pull requests.

39−

40−## Changelog entries

41−

42−We experiment with using [changelog-d tool](https://github.com/phadej/changelog-d) to assemble changelogs.

43−You are not required to install it.

44−

45−In each PR please add a file to `changelog.d` directory named after issue you are solving or the pull request itself (in a separate commit after you know the pull request number). For example

46−

47−```cabal

48−synopsis: One sentence summary of the change.

49−prs: #1219

50−issues: #1028

51−

52−description: {

53−

54−A longer description. Small changes don't need this.

55−Bigger ones definitely do, for example we try to include migration hints

56−for breaking changes.

57−

58−However if you don't know what to write, that's ok too.

59−

60−By the way, the braces around are omitted when the file is parsed.

61−They can be used so the field doesn't need to be indented, which is handy

62−for prose.

63−

64−}

65−```

66

38

67## PR process

39## PR process

68

40

@@ -79,10 +51,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

51We 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

52one 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

53getting to know it better. If you do write a new combinator, we would love to

82−know about it! Either hop on

54+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

55+issue with the `news` tag (which we will close when we read it).

85−read it).

86

56

87As for adding them to the main repo: maintaining combinators can be expensive,

57As for adding them to the main repo: maintaining combinators can be expensive,

88since official combinators must have instances for all classes (and new classes

58since official combinators must have instances for all classes (and new classes

@@ -105,7 +75,7 @@ the `news` label if you make a new package so we can know about it!

105

75

106## Release policy

76## Release policy

107

77

108−We are currently moving to a more aggressive release policy, so that you can get

78+We are currently moving to a more aggresive release policy, so that you can get

109what you contribute from Hackage fairly soon. However, note that prior to major

79what you contribute from Hackage fairly soon. However, note that prior to major

110releases it may take some time in between releases.

80releases it may take some time in between releases.

111

81

README.md+17−27

@@ -4,16 +4,16 @@

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## Contributing

19## Contributing

@@ -24,7 +24,7 @@ See `CONTRIBUTING.md`

24

24

25- Update changelog and bump versions in `master`

25- 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)

26 - `git log --oneline v0.12.. | grep 'Merge pull request'` is a good starting point (use correct previous release tag)

27−- Create a release branch, e.g. `release-0.13`

27+- Create a release branch, e.g. `release-0.13`, and *protect it* from accidental force pushes.

28 - Release branch is useful for backporting fixes from `master`

28 - Release branch is useful for backporting fixes from `master`

29- Smoke test in [`servant-universe`](https://github.com/phadej/servant-universe)

29- 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.

30 - `git submodule foreach git checkout master` and `git submodule foreach git pull` to get newest of everything.

@@ -32,7 +32,7 @@ See `CONTRIBUTING.md`

32 - It's a good idea to separate these steps, as tests often pass, if they compile :)

32 - It's a good idea to separate these steps, as tests often pass, if they compile :)

33 - See `cabal.project` to selectively `allow-newer`

33 - See `cabal.project` to selectively `allow-newer`

34 - If some packages are broken, on your discretisation there are two options:

34 - If some packages are broken, on your discretisation there are two options:

35− - Fix them and make PRs: it's a good idea to test against older `servant` version too.

35+ - Fix them and make PRs: it's good idea to test against older `servant` version too.

36 - Temporarily comment out broken package

36 - 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

37 - 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:

38- When ripples are cleared out:

@@ -40,32 +40,22 @@ See `CONTRIBUTING.md`

40 - `git push --tags`

40 - `git push --tags`

41 - `cabal sdist` and `cabal upload`

41 - `cabal sdist` and `cabal upload`

42

42

43−## TechEmpower framework benchmarks

43+## travis

44

44

45−We develop and maintain the servant TFB entry in https://github.com/haskell-servant/FrameworkBenchmarks/

45+`.travis.yml` is generated using `make-travis-yml` tool, in

46+[multi-ghc-travis](https://github.com/haskell-hvr/multi-ghc-travis) repository.

46

47

47−To verify (i.e. compile and test that it works)

48+To regenerate the script use (*note:* atm you need to comment `doc/cookbook/` packages).

48

49

49−```sh

50−./tfb --mode verify --test servant servant-beam servant-psql-simple --type json plaintext db fortune

51```

50```

52−

51+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```

52```

58

53

59−To compare with `reitit` (Clojure framework)

54+In case Travis jobs fail due failing build of dependency, you can temporarily

55+add `constraints` to the `cabal.project`, and regenerate the `.travis.yml`.

56+For example, the following will disallow single `troublemaker-13.37` package version:

60

57

61−```sh

62−./tfb --mode benchmark --test reitit reitit-async reitit-jdbc servant servant-beam servant-psql-simple --type json plaintext db fortune

63```

58```

64−

59+constraints:

65−You can see the visualised results at https://www.techempower.com/benchmarks/#section=test

60+ troublemaker <13.37 && > 13.37

66−

61+```

67−## Nix

68−

69−A developer shell.nix file is provided in the `nix` directory

70−

71−See [nix/README.md](nix/README.md)

cabal.ghcjs.project+15−5

@@ -1,14 +1,24 @@

1-- Using https://launchpad.net/~hvr/+archive/ubuntu/ghcjs

1-- Using https://launchpad.net/~hvr/+archive/ubuntu/ghcjs

2+--

3+-- $ cabal new-build --project-file cabal.ghcjs.project all -w /opt/ghcjs/8.4/bin/ghcjs

2

4

3packages:

5packages:

4 servant/

6 servant/

5− servant-client/

6 servant-client-core/

7 servant-client-core/

8+ servant-client-ghcjs/

7

9

8-- we need to tell cabal we are using GHCJS

10-- we need to tell cabal we are using GHCJS

9compiler: ghcjs

11compiler: ghcjs

10−tests: True

11

12

12−-- Constraints so that reflex-platform provided packages are selected.

13+-- https://github.com/ghcjs/ghcjs/issues/665

13−constraints: attoparsec == 0.13.2.2

14+constraints: primitive <0.6.4

14−constraints: hashable == 1.3.0.0

15+

16+-- ghcjs-base wants old aeson

17+allow-newer: ghcjs-base:aeson

18+

19+-- https://github.com/nomeata/hackage-ghcjs-overlay

20+repository ghcjs-overlay

21+ url: http://hackage-ghcjs-overlay.nomeata.de/

22+ secure: True

23+ root-keys:

24+ key-threshold: 0

cabal.make-travis-ymlnew file+15

@@ -0,0 +1,15 @@

1+folds: all-but-test

2+branches: master

3+

4+-- We have inplace packages (servant-js) so we skip installing dependencies in a separate step

5+install-dependencies-step: False

6+

7+-- this speed-ups the build a little, but we have to check these for release

8+no-tests-no-benchmarks: False

9+unconstrained-step: False

10+

11+-- Don't run cabal check, as cookbook examples won't pass it

12+cabal-check: False

13+

14+-- ghc-options: -j2

15+jobs: :2

cabal.project+20−35

@@ -1,54 +1,39 @@

1−packages:

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/

17

8

18−-- servant streaming

9+ -- doc/cookbook/*/*.cabal

19−packages:

20− servant-machines/

21− servant-conduit/

22− servant-pipes/

23−

24−-- servant GHCJS

25−-- packages:

26−-- servant-jsaddle/

27

10

28−-- Cookbooks

29−packages:

30 doc/cookbook/basic-auth

11 doc/cookbook/basic-auth

31 doc/cookbook/curl-mock

12 doc/cookbook/curl-mock

32− doc/cookbook/custom-errors

33− doc/cookbook/basic-streaming

34 doc/cookbook/db-postgres-pool

13 doc/cookbook/db-postgres-pool

35 doc/cookbook/db-sqlite-simple

14 doc/cookbook/db-sqlite-simple

36 doc/cookbook/file-upload

15 doc/cookbook/file-upload

37 doc/cookbook/generic

16 doc/cookbook/generic

38− doc/cookbook/hoist-server-with-context

17+ -- doc/cookbook/hoist-server-with-context

39 doc/cookbook/https

18 doc/cookbook/https

40− doc/cookbook/jwt-and-basic-auth

19+ -- doc/cookbook/jwt-and-basic-auth/

41− doc/cookbook/pagination

20+ -- doc/cookbook/pagination

42− -- doc/cookbook/sentry

21+ doc/cookbook/sentry

43− -- Commented out because servant-quickcheck currently doesn't build.

44− -- doc/cookbook/testing

22+ doc/cookbook/testing

45− doc/cookbook/uverb

46 doc/cookbook/structuring-apis

23 doc/cookbook/structuring-apis

47 doc/cookbook/using-custom-monad

24 doc/cookbook/using-custom-monad

48 doc/cookbook/using-free-client

25 doc/cookbook/using-free-client

49− -- doc/cookbook/open-id-connect

50− doc/cookbook/managed-resource

51

26

52−tests: True

27+allow-newer:

53−optimization: False

28+ servant-auth-server:http-types,

54−-- reorder-goals: True

29+ servant-auth-server:servant-server,

30+ servant-js:base

31+

32+constraints:

33+ -- see https://github.com/haskell-infra/hackage-trustees/issues/119

34+ foundation >=0.0.14,

35+ memory <0.14.12 || >0.14.12

36+

37+allow-newer:

38+ servant-pagination:servant,

39+ servant-pagination:servant-server

changelog.d/1432deleted−9

@@ -1,9 +0,0 @@

1−synopsis: Fixes encoding of URL parameters in servant-client

2−prs: #1432

3−issues: #1418

4−description: {

5−Some applications use query parameters to pass arbitrary (non-unicode) binary

6−data. This change modifies how servant-client handles query parameters, so

7−that application developers can use `ToHttpApiData` to marshal binary data into

8−query parameters.

9−}

changelog.d/1469deleted−11

@@ -1,11 +0,0 @@

1−synopsis: Derive HasClient good response status from Verb status

2−prs: #1469

3−description: {

4−`HasClient` instances for the `Verb` datatype use `runRequest` in

5−`clientWithRoute` definitions.

6−This means that a request performed with `runClientM` will be successful if and

7−only if the endpoint specify a response status code >=200 and <300.

8−This change replaces `runRequest` with `runRequestAcceptStatus` in `Verb`

9−instances for the `HasClient` class, deriving the good response status from

10−the `Verb` status.

11−}

changelog.d/1477deleted−9

@@ -1,9 +0,0 @@

1−synopsis: Enable FlexibleContexts in Servant.API.ContentTypes

2−prs: #1477

3−

4−description: {

5−

6−Starting with GHC 9.2, UndecidableInstances no longer implies FlexibleContexts.

7−Add this extension where it's needed to make compilation succeed.

8−

9−}

changelog.d/1529deleted−10

@@ -1,10 +0,0 @@

1−synopsis: Fix performRequest in servant-client-ghcjs

2−prs: #1529

3−

4−description: {

5−

6−performRequest function in servant-client-ghcjs was not compatible with the

7−latest RunClient typeclass. Added the acceptStatus parameter and fixed the

8−functionality to match what servant-client provides.

9−

10−}

changelog.d/1556deleted−81

@@ -1,81 +0,0 @@

1−synopsis: Display capture hints in router layout

2−prs: #1556

3−

4−description: {

5−

6−This PR enhances the `Servant.Server.layout` function, which produces a textual description of the routing layout of an API. More precisely, it changes `<capture>` blocks, so that they display the name and type of the variable being captured instead.

7−

8−Example:

9−

10−For the following API

11−```haskell

12−type API =

13− "a" :> "d" :> Get '[JSON] NoContent

14− :<|> "b" :> Capture "x" Int :> Get '[JSON] Bool

15− :<|> "a" :> "e" :> Get '[JSON] Int

16−```

17−

18−we previously got the following output:

19−

20−```

21−/

22−├─ a/

23−│ ├─ d/

24−│ │ └─•

25−│ └─ e/

26−│ └─•

27−└─ b/

28− └─ <capture>/

29− ├─•

30− ┆

31− └─•

32−```

33−

34−now we get:

35−

36−```

37−/

38−├─ a/

39−│ ├─ d/

40−│ │ └─•

41−│ └─ e/

42−│ └─•

43−└─ b/

44− └─ <x::Int>/

45− ├─•

46− ┆

47− └─•

48−```

49−

50−This change is achieved by the introduction of a CaptureHint type, which is passed as an extra argument to the CaptureRouter and CaptureAllRouter constructors for the Router' type.

51−CaptureHint values are then used in routerLayout, to display the name and type of captured values, instead of just `<capture>` previously.

52−

53−N.B.:

54−Because the choice smart constructor for routers can aggregate Capture combinators with different capture hints, the Capture*Router constructors actually take a list of CaptureHint, instead of a single one.

55−

56−This PR also introduces Spec tests for the routerLayout function.

57−

58−Warning:

59−This change is potentially breaking, because it adds the constraint `Typeable a` to all types that are to be captured. Because all types are typeable since GHC 7.10, this is not as bad as it sounds ; it only break expressions where `a` is quantified in an expression with `Capture a`.

60−In those cases, the fix is easy: it suffices to add `Typeable a` to the left-hand side of the quantification constraint.

61−

62−For instance, the following code will no longer compile:

63−```haskell

64−type MyAPI a = Capture "foo" a :> Get '[JSON] ()

65−

66−myServer :: forall a. Server (MyAPI a)

67−myServer = const $ return ()

68−

69−myApi :: forall a. Proxy (MyAPI a)

70−myApi = Proxy

71−

72−app :: forall a. (FromHttpApiData a) => Application

73−app = serve (myApi @a) (myServer @a)

74−```

75−

76−Indeed, `app` should be replaced with:

77−```haskell

78−app :: forall a. (FromHttpApiData a, Typeable a) => Application

79−app = serve (myApi @a) (myServer @a)

80−```

81−}

changelog.d/1569deleted−13

@@ -1,13 +0,0 @@

1−synopsis: Encode captures using toEncodedUrlPiece

2−prs: #1569

3−issues: #1511

4−

5−description: {

6−The `servant-client` library now makes direct use of `toEncodedUrlPiece` from `ToHttpApiData`

7−to encode captured values when building the request path. It gives user freedom to implement

8−URL-encoding however they need.

9−

10−Previous behavior was to use `toUrlPiece` and URL-encode its output using `toEncodedUrlPiece`

11−from the `Text` instance of `ToHttpApiData`. The issue with this approach is that

12−`ToHttpApiData Text` is overly zealous and also encodes characters, such as `*`, which are perfectly valid in a URL.

13−}

changelog.d/1571deleted−10

@@ -1,10 +0,0 @@

1−synopsis: Support UVerb in servant-auth-server

2−prs: #1571

3−issues: #1570

4−description: {

5−UVerb endpoints are now supported by servant-auth-server and can be used under the

6−Auth combinator when writing servers. It is still unsupported by

7−servant-auth-client.

8−

9−This PR also brings Headers support in UVerb responses

10−}

changelog.d/1573deleted−2

@@ -1,2 +0,0 @@

1−synopsis: Add API docs for ServerT

2−prs: #1573

changelog.d/1580deleted−12

@@ -1,12 +0,0 @@

1−synopsis: Allow IO in validationKeys

2−prs: #1580

3−issues: #1579

4−

5−description: {

6−

7−Currently validationKeys are a fixed JWKSet. This does not work with OIDC

8−providers such as AWS Cognito or Okta, which regularly fetching jwks_uri to

9−discover new and expired keys.

10−

11−This change alters the type of validationKeys from JWKSet to IO JWKSet.

12−}

changelog.d/1589deleted−2

@@ -1,2 +0,0 @@

1−synopsis: Only include question mark for nonempty query strings

2−prs: 1589

changelog.d/1595deleted−2

@@ -1,2 +0,0 @@

1−synopsis: Run ClientEnv's makeClientRequest in IO.

2−prs: #1595

changelog.d/1606deleted−10

@@ -1,10 +0,0 @@

1−synopsis: Handle Cookies correctly for RunStreamingClient

2−prs: #1606

3−issues: #1605

4−

5−description: {

6−

7−Makes performWithStreamingRequest take into consideration the

8−CookieJar, which it previously didn't.

9−

10−}

changelog.d/1638deleted−2

@@ -1,2 +0,0 @@

1−synopsis: Add Functor instance to AuthHandler.

2−prs: #1638

changelog.d/1649deleted−8

@@ -1,8 +0,0 @@

1−synopsis: Add HasStatus instance for Headers (that defers StatusOf to underlying value)

2−prs: #1649

3−

4−description: {

5−

6−Adds a new HasStatus (Headers hs a) instance (StatusOf (Headers hs a) = StatusOf a)

7−

8−}

changelog.d/configdeleted−2

@@ -1,2 +0,0 @@

1−organization: haskell-servant

2−repository: servant

changelog.d/servant-docs-curldeleted−16

@@ -1,16 +0,0 @@

1−synopsis: Add sample cURL requests to generated documentation

2−prs: #1401

3−

4−description: {

5−

6−Add sample cURL requests to generated documentation.

7−

8−Those supplying changes to the Request `header` field manually using

9−lenses will need to add a sample bytestring value.

10−

11−`headers <>~ ["unicorn"]`

12−

13−becomes

14−

15−`headers <>~ [("unicorn", "sample value")]`

16−}

default.nixdeleted−38

@@ -1,38 +0,0 @@

1−with (builtins.fromJSON (builtins.readFile ./nix/nixpkgs.json));

2−{

3− pkgs ? import (builtins.fetchTarball {

4− url = "https://github.com/NixOS/nixpkgs/archive/${rev}.tar.gz";

5− inherit sha256;

6− }) {}

7−, compiler ? "ghc883"

8−}:

9−let

10− overrides = self: super: {

11− servant = self.callCabal2nix "servant" ./servant {};

12− servant-docs = self.callCabal2nix "servant-docs" ./servant-docs {};

13− servant-pipes = self.callCabal2nix "servant-pipes" ./servant-pipes {};

14− servant-server = self.callCabal2nix "servant-server" ./servant-server {};

15− servant-client = self.callCabal2nix "servant-client" ./servant-client {};

16− servant-foreign = self.callCabal2nix "servant-foreign" ./servant-foreign {};

17− servant-conduit = self.callCabal2nix "servant-conduit" ./servant-conduit {};

18− servant-machines = self.callCabal2nix "servant-machines" ./servant-machines {};

19− servant-client-core = self.callCabal2nix "servant-client-core" ./servant-client-core {};

20− servant-http-streams = self.callCabal2nix "servant-http-streams" ./servant-http-streams {};

21− };

22− hPkgs = pkgs.haskell.packages.${compiler}.override { inherit overrides; };

23−in

24− with hPkgs;

25− {

26− inherit

27− servant

28− servant-client

29− servant-client-core

30− servant-conduit

31− servant-docs

32− servant-foreign

33− servant-http-streams

34− servant-machines

35− servant-pipes

36− servant-server;

37− }

38−

doc/Makefile+1−3

@@ -10,8 +10,6 @@ BUILDDIR = _build

10

10

11# Put it first so that "make" without argument is like "make help".

11# Put it first so that "make" without argument is like "make help".

12help:

12help:

13− @if [ ! -d venv ]; then echo "WARNING: There is no venv directory, did you forget to 'virtualenv venv'. Check README.md."; fi

14− @if [ ! "z$$(which $(SPHINXBUILD))" = "z$$(pwd)/venv/bin/sphinx-build" ]; then echo "WARNING: Did you forgot to 'source venv/bin/activate'"; fi

15 @$(SPHINXBUILD) -M help "$(SOURCEDIR)" "$(BUILDDIR)" $(SPHINXOPTS) $(O)

13 @$(SPHINXBUILD) -M help "$(SOURCEDIR)" "$(BUILDDIR)" $(SPHINXOPTS) $(O)

16

14

17.PHONY: help Makefile

15.PHONY: help Makefile

@@ -19,4 +17,4 @@ help:

19# Catch-all target: route all unknown targets to Sphinx using the new

17# Catch-all target: route all unknown targets to Sphinx using the new

20# "make mode" option. $(O) is meant as a shortcut for $(SPHINXOPTS).

18# "make mode" option. $(O) is meant as a shortcut for $(SPHINXOPTS).

21%: Makefile

19%: Makefile

22− @$(SPHINXBUILD) -M $@ "$(SOURCEDIR)" "$(BUILDDIR)" $(SPHINXOPTS) $(O)

20+ @$(SPHINXBUILD) -M $@ "$(SOURCEDIR)" "$(BUILDDIR)" $(SPHINXOPTS) $(O)

doc/README.mddeleted−8

@@ -1,8 +0,0 @@

1−To build the docs locally:

2−

3− $ virtualenv venv

4− $ . ./venv/bin/activate

5− $ pip install -r requirements.txt

6− $ make html

7−

8−Docs will be built in _build/html/index.html .

doc/building-the-docsnew file+8

@@ -0,0 +1,8 @@

1+To build the docs locally:

2+

3+$ virtualenv venv

4+$ . ./venv/bin/activate

5+$ pip install -r requirements.txt

6+$ make html

7+

8+Docs will be built in _build/html/index.html .

doc/conf.py+3−1

@@ -46,7 +46,7 @@ master_doc = 'index'

46

46

47# General information about the project.

47# General information about the project.

48project = u'Servant'

48project = u'Servant'

49−copyright = u'2022, Servant Contributors'

49+copyright = u'2018, Servant Contributors'

50author = u'Servant Contributors'

50author = u'Servant Contributors'

51

51

52# The version info for the project you're documenting, acts as replacement for

52# The version info for the project you're documenting, acts as replacement for

@@ -167,5 +167,7 @@ texinfo_documents = [

167# -- Markdown -------------------------------------------------------------

167# -- Markdown -------------------------------------------------------------

168

168

169source_parsers = {

169source_parsers = {

170+ '.md': CommonMarkParser,

170 '.lhs': CommonMarkParser,

171 '.lhs': CommonMarkParser,

171}

172}

173+

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==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.1

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−2

@@ -1,7 +1,6 @@

1packages:

1packages:

2 basic-auth/

2 basic-auth/

3 curl-mock/

3 curl-mock/

4− db-mysql-basics/

5 db-sqlite-simple/

4 db-sqlite-simple/

6 db-postgres-pool/

5 db-postgres-pool/

7 using-custom-monad/

6 using-custom-monad/

@@ -13,7 +12,6 @@ packages:

13 pagination/

12 pagination/

14 sentry/

13 sentry/

15 testing/

14 testing/

16− open-id-connect/

17 ../../servant

15 ../../servant

18 ../../servant-server

16 ../../servant-server

19 ../../servant-client-core

17 ../../servant-client-core

doc/cookbook/cabal.project.localdeleted

No changes to the content.

doc/cookbook/curl-mock/CurlMock.lhs+23−10

@@ -1,7 +1,7 @@

1# Generating mock curl calls

1# Generating mock curl calls

2

2

3In this example we will generate curl requests with mock post data from a servant API.

3In this example we will generate curl requests with mock post data from a servant API.

4−This may be useful for testing and development purposes.

4+This may be usefull for testing and development purposes.

5Especially post requests with a request body are tedious to send manually.

5Especially post requests with a request body are tedious to send manually.

6

6

7Also, we will learn how to use the servant-foreign library to generate stuff from servant APIs.

7Also, we will learn how to use the servant-foreign library to generate stuff from servant APIs.

@@ -22,8 +22,9 @@ Language extensions and imports:

22{-# LANGUAGE TypeOperators #-}

22{-# LANGUAGE TypeOperators #-}

23

23

24import Control.Lens ((^.))

24import Control.Lens ((^.))

25−import Data.Aeson

25+import Data.Aeson.Compat

26import Data.Aeson.Text

26import Data.Aeson.Text

27+import Data.Monoid ((<>))

27import Data.Proxy (Proxy (Proxy))

28import Data.Proxy (Proxy (Proxy))

28import Data.Text (Text)

29import Data.Text (Text)

29import Data.Text.Encoding (decodeUtf8)

30import Data.Text.Encoding (decodeUtf8)

@@ -75,7 +76,7 @@ api = Proxy

75```

76```

76

77

77

78

78−## servant-foreign and the HasForeignType Class

79+## servant-forgein and the HasForeignType Class

79

80

80Servant-foreign allows us to look into the API we designed.

81Servant-foreign allows us to look into the API we designed.

81The entry point is `listFromAPI` which takes three types and returns a list of endpoints:

82The entry point is `listFromAPI` which takes three types and returns a list of endpoints:

@@ -85,7 +86,7 @@ listFromAPI :: (HasForeign lang ftype api, GenerateList ftype (Foreign ftype api

85```

86```

86

87

87This looks a bit confusing...

88This looks a bit confusing...

88−[Here](https://hackage.haskell.org/package/servant-foreign/docs/Servant-Foreign.html#t:HasForeign) is the documentation for the `HasForeign` typeclass.

89+[Here](https://hackage.haskell.org/package/servant-foreign-0.11.1/docs/Servant-Foreign.html#t:HasForeignType) is the documentation for the `HasForeign` typeclass.

89We will not go into details here, but this allows us to create a value of type `ftype` for any type `a` in our API.

90We 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

91In our case we want to create a mock of every type `a`.

92In our case we want to create a mock of every type `a`.

@@ -129,12 +130,24 @@ generateCurl :: (GenerateList Mocked (Foreign Mocked api), HasForeign NoLang Moc

129generateCurl p host =

130generateCurl p host =

130 fmap T.unlines body

131 fmap T.unlines body

131 where

132 where

132− body = mapM (generateEndpoint host)

133+ body = foldr (\endp curlCalls -> mCons (generateEndpoint host endp) curlCalls) (return [])

133 $ listFromAPI (Proxy :: Proxy NoLang) (Proxy :: Proxy Mocked) p

134 $ listFromAPI (Proxy :: Proxy NoLang) (Proxy :: Proxy Mocked) p

134```

135```

135

136

136−First, `listFromAPI` gives us a list of `Req Mocked`. Each `Req` describes one endpoint from the API type.

137+To understand this function, better start at the end:

137−We generate a curl call for each of them using the following helper.

138+

139+`listFromAPI` gives us a list of endpoints. We iterate over them (`foldr`) and call `generateEndpoint` for every endpoint.

140+

141+As generate endpoint will not return `Text` but `IO Text` (remember we need some random bits to mock), we cannot just use the cons operator but need to build `IO [Text]` from `IO Text`s.

142+

143+``` haskell

144+mCons :: IO a -> IO [a] -> IO [a]

145+mCons ele list =

146+ ele >>= \e -> list >>= \l -> return ( e : l )

147+```

148+

149+

150+Now comes the juicy part; accessing the endpoints data:

138

151

139``` haskell

152``` haskell

140generateEndpoint :: Text -> Req Mocked -> IO Text

153generateEndpoint :: Text -> Req Mocked -> IO Text

@@ -156,7 +169,7 @@ generateEndpoint host req =

156`servant-foreign` offers a multitude of lenses to be used with `Req`-values.

169`servant-foreign` offers a multitude of lenses to be used with `Req`-values.

157

170

158`reqMethod` gives us a straigthforward `Network.HTTP.Types.Method`, `reqUrl` the url part and so on.

171`reqMethod` gives us a straigthforward `Network.HTTP.Types.Method`, `reqUrl` the url part and so on.

159−Just take a look at [the docs](https://hackage.haskell.org/package/servant-foreign/docs/Servant-Foreign.html).

172+Just take a look at [the docs](https://hackage.haskell.org/package/servant-foreign-0.11.1/docs/Servant-Foreign.html).

160

173

161But how do we get our mocked json string? This seems to be a bit to short to be true:

174But how do we get our mocked json string? This seems to be a bit to short to be true:

162

175

@@ -188,7 +201,7 @@ And now, lets hook it all up in our main function:

188``` haskell

201``` haskell

189main :: IO ()

202main :: IO ()

190main =

203main =

191− generateCurl api "localhost:8081" >>= T.IO.putStrLn

204+ generateCurl api "localhost:8081" >>= (\v -> T.IO.putStrLn v)

192```

205```

193

206

194Done:

207Done:

@@ -200,6 +213,6 @@ curl -X POST -d '{"email":"wV򝣀_b򆎘:z񁊞򲙲!(3DM V","age":10,"name":"=|W"}

200```

213```

201

214

202This is of course no complete curl call mock generator, many things including path arguments are missing.

215This is of course no complete curl call mock generator, many things including path arguments are missing.

203−But it correctly generates mock calls for simple POST requests.

216+But it correctly generate mock calls for simple POST requests.

204

217

205Also, we now know how to use `HasForeignType` and `listFromAPI` to generate anything we want.

218Also, we now know how to use `HasForeignType` and `listFromAPI` to generate anything we want.

doc/cookbook/curl-mock/curl-mock.cabal+5−7

@@ -1,22 +1,20 @@

1−cabal-version: 2.2

2name: cookbook-curl-mock

1name: cookbook-curl-mock

3version: 0.1

2version: 0.1

4synopsis: Generate curl mock requests cookbook example

3synopsis: Generate curl mock requests 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==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.1

12

12

13executable cookbock-curl-mock

13executable cookbock-curl-mock

14− if impl(ghc >= 9.2)

15− -- generic-arbitrary is incompatible

16− buildable: False

17 main-is: CurlMock.lhs

14 main-is: CurlMock.lhs

18 build-depends: base == 4.*

15 build-depends: base == 4.*

19 , aeson

16 , aeson

17+ , aeson-compat

20 , lens

18 , lens

21 , text

19 , text

22 , servant

20 , servant

doc/cookbook/custom-errors/CustomErrors.lhsdeleted−189

@@ -1,189 +0,0 @@

1−# Customizing errors from Servant

2−

3−Servant handles a lot of parsing and validation of the input request. When it can't parse something: query

4−parameters, URL parts or request body, it will return appropriate HTTP codes like 400 Bad Request.

5−

6−These responses will contain the error message in their body without any formatting. However, it is often

7−desirable to be able to provide custom formatting for these error messages, for example, to wrap them in JSON.

8−

9−Recently Servant got a way to add such formatting. This Cookbook chapter demonstrates how to use it.

10−

11−Extensions and imports:

12−```haskell

13−{-# LANGUAGE DataKinds #-}

14−{-# LANGUAGE DeriveGeneric #-}

15−{-# LANGUAGE OverloadedStrings #-}

16−{-# LANGUAGE PolyKinds #-}

17−{-# LANGUAGE TypeFamilies #-}

18−{-# LANGUAGE TypeOperators #-}

19−

20−import Data.Aeson

21−import Data.Proxy

22−import Data.Text

23−import GHC.Generics

24−import Network.Wai

25−import Network.Wai.Handler.Warp

26−

27−import Servant

28−

29−import Data.String.Conversions

30− (cs)

31−import Servant.API.ContentTypes

32−```

33−

34−The API (from `greet.hs` example in Servant sources):

35−

36−```haskell

37−-- | A greet message data type

38−newtype Greet = Greet { _msg :: Text }

39− deriving (Generic, Show)

40−

41−instance FromJSON Greet

42−instance ToJSON Greet

43−

44−-- API specification

45−type TestApi =

46− -- GET /hello/:name?capital={true, false} returns a Greet as JSON

47− "hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get '[JSON] Greet

48−

49− -- POST /greet with a Greet as JSON in the request body,

50− -- returns a Greet as JSON

51− :<|> "greet" :> ReqBody '[JSON] Greet :> Post '[JSON] Greet

52−

53− -- DELETE /greet/:greetid

54− :<|> "greet" :> Capture "greetid" Text :> Delete '[JSON] NoContent

55−

56−testApi :: Proxy TestApi

57−testApi = Proxy

58−

59−-- Server-side handlers.

60−--

61−-- There's one handler per endpoint, which, just like in the type

62−-- that represents the API, are glued together using :<|>.

63−--

64−-- Each handler runs in the 'Handler' monad.

65−server :: Server TestApi

66−server = helloH :<|> postGreetH :<|> deleteGreetH

67−

68− where helloH name Nothing = helloH name (Just False)

69− helloH name (Just False) = return . Greet $ "Hello, " <> name

70− helloH name (Just True) = return . Greet . toUpper $ "Hello, " <> name

71−

72− postGreetH greet = return greet

73−

74− deleteGreetH _ = return NoContent

75−```

76−

77−## Error formatters

78−

79−`servant-server` provides an `ErrorFormatter` type to specify how the error message will be

80−formatted. A formatter is just a function accepting three parameters:

81−

82−- `TypeRep` from `Data.Typeable`: this is a runtime representation of the type of the combinator

83− (like `Capture` or `ReqBody`) that generated the error. It can be used to display its name (with

84− `show`) or even dynamically dispatch on the combinator type. See the docs for `Data.Typeable` and

85− `Type.Reflection` modules.

86−- `Request`: full information for the request that led to the error.

87−- `String`: specific error message from the combinator.

88−

89−The formatter is expected to produce a `ServerError` which will be returned from the handler.

90−

91−Additionally, there is `NotFoundErrorFormatter`, which accepts only `Request` and can customize the

92−error in case when no route can be matched (HTTP 404).

93−

94−Let's make two formatters. First one will wrap our error in a JSON:

95−

96−```json

97−{

98− "error": "ERROR MESSAGE",

99− "combinator": "NAME OF THE COMBINATOR"

100−}

101−```

102−

103−Additionally, this formatter will examine the `Accept` header of the request and generate JSON

104−message only if client can accept it.

105−

106−```haskell

107−customFormatter :: ErrorFormatter

108−customFormatter tr req err =

109− let

110− -- aeson Value which will be sent to the client

111− value = object ["combinator" .= show tr, "error" .= err]

112− -- Accept header of the request

113− accH = getAcceptHeader req

114− in

115− -- handleAcceptH is Servant's function that checks whether the client can accept a

116− -- certain message type.

117− -- In this case we call it with "Proxy '[JSON]" argument, meaning that we want to return a JSON.

118− case handleAcceptH (Proxy :: Proxy '[JSON]) accH value of

119− -- If client can't handle JSON, we just return the body the old way

120− Nothing -> err400 { errBody = cs err }

121− -- Otherwise, we return the JSON formatted body and set the "Content-Type" header.

122− Just (ctypeH, body) -> err400

123− { errBody = body

124− , errHeaders = [("Content-Type", cs ctypeH)]

125− }

126−

127−notFoundFormatter :: NotFoundErrorFormatter

128−notFoundFormatter req =

129− err404 { errBody = cs $ "Not found path: " <> rawPathInfo req }

130−```

131−

132−If you don't need to react to the `Accept` header, you can just unconditionally return the JSON like

133−this (with `encode` from `Data.Aeson`):

134−

135−```

136−err400

137− { errBody = encode body

138− , errHeaders = [("Content-Type", "application/json")]

139− }

140−```

141−

142−## Passing formatters to Servant

143−

144−Servant uses the Context to configure formatters. You only need to add a value of type

145−`ErrorFormatters` to your context. This is a record with the following fields:

146−

147−- `bodyParserErrorFormatter :: ErrorFormatter`

148−- `urlParseErrorFormatter :: ErrorFormatter`

149−- `headerParseErrorFormatter :: ErrorFormatter`

150−- `notFoundErrorFormatter :: NotFoundErrorFormatter`

151−

152−Default formatters are exported as `defaultErrorFormatters`, so you can use record update syntax to

153−set the only ones you need:

154−

155−```haskell

156−customFormatters :: ErrorFormatters

157−customFormatters = defaultErrorFormatters

158− { bodyParserErrorFormatter = customFormatter

159− , notFoundErrorFormatter = notFoundFormatter

160− }

161−```

162−

163−And at last, use `serveWithContext` to run your server as usual:

164−

165−```haskell

166−app :: Application

167−app = serveWithContext testApi (customFormatters :. EmptyContext) server

168−

169−main :: IO ()

170−main = run 8000 app

171−```

172−

173−Now if we try to request something with a wrong body, we will get a nice error:

174−

175−```

176−$ http -j POST localhost:8000/greet 'foo=bar'

177−HTTP/1.1 400 Bad Request

178−Content-Type: application/json;charset=utf-8

179−Date: Fri, 17 Jul 2020 13:34:18 GMT

180−Server: Warp/3.3.12

181−Transfer-Encoding: chunked

182−

183−{

184− "combinator": "ReqBody'",

185− "error": "Error in $: parsing Main.Greet(Greet) failed, key \"_msg\" not found"

186−}

187−```

188−

189−Notice the `Content-Type` header set by our combinator.

doc/cookbook/custom-errors/custom-errors.cabaldeleted−25

@@ -1,25 +0,0 @@

1−cabal-version: 2.2

2−name: cookbook-custom-errors

3−version: 0.1

4−synopsis: Return custom error messages from combinators

5−homepage: http://docs.servant.dev

6−license: BSD-3-Clause

7−license-file: ../../../servant/LICENSE

8−author: Servant Contributors

9−maintainer: haskell-servant-maintainers@googlegroups.com

10−build-type: Simple

11−tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7

12−

13−executable cookbook-custom-errors

14− main-is: CustomErrors.lhs

15− build-depends: base == 4.*

16− , aeson

17− , servant

18− , servant-server

19− , string-conversions

20− , text

21− , wai

22− , warp

23− default-language: Haskell2010

24− ghc-options: -Wall -pgmL markdown-unlit

25− build-tool-depends: markdown-unlit:markdown-unlit

doc/cookbook/db-mysql-basics/MysqlBasics.lhsdeleted−236

@@ -1,236 +0,0 @@

1−# Overview

2−

3−This doc will walk through a single-module implementation of a servant API connecting to a MySQL database. It will also include some basic CRUD operations.

4−

5−Once you can wrap your head around this implementation, understanding more complex features like resource pools would be beneficial next steps.

6−

7−The only *prerequisite* is that you have a MySQL database open on port 3306 of your machine. Docker is an easy way to manage this.

8−

9−## Setup

10−

11−- The mysql database should be up and running on 127.0.0.1:3306

12−

13−- Our API will be exposed on localhost:8080

14−

15−## REST actions available

16−

17−*Get all people*

18−

19−```

20−/people GET

21−```

22−

23−*Get person by ID*

24−

25−```

26−/people/:id GET

27−```

28−

29−*Insert a new person*

30−

31−```

32−/people POST

33−

34−{

35− "name": "NewName",

36− "age": 24

37−}

38−```

39−

40−*Delete a person*

41−

42−```

43−/people/:id DELETE

44−```

45−

46−## Other notes

47−

48−At the time of writing this issue may occur when building your project:

49−

50−```

51−setup: Missing dependencies on foreign libraries:

52−* Missing (or bad) C libraries: ssl, crypto

53−```

54−

55−If using stack, this can be fixed by adding the following lines to your `stack.yaml`:

56−

57−```

58−extra-include-dirs:

59−- /usr/local/opt/openssl/include

60−extra-lib-dirs:

61−- /usr/local/opt/openssl/lib

62−```

63−

64−Or for cabal, running your builds with these configurations passed as options.

65−

66−## Implementation: Main.hs

67−

68−Let's jump in:

69−

70−```haskell

71−{-# LANGUAGE DataKinds #-}

72−{-# LANGUAGE DeriveGeneric #-}

73−{-# LANGUAGE FlexibleInstances #-}

74−{-# LANGUAGE GADTs #-}

75−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

76−{-# LANGUAGE MultiParamTypeClasses #-}

77−{-# LANGUAGE QuasiQuotes #-}

78−{-# LANGUAGE TemplateHaskell #-}

79−{-# LANGUAGE TypeFamilies #-}

80−{-# LANGUAGE TypeOperators #-}

81−module Lib where

82−

83−import Control.Monad.IO.Class (liftIO)

84−import Control.Monad.Logger (NoLoggingT (..))

85−import Control.Monad.Trans.Reader (runReaderT)

86−import Control.Monad.Trans.Resource (ResourceT, runResourceT)

87−import Data.Aeson as JSON

88−import Data.Int (Int64 (..))

89−import Data.Text (Text)

90−import qualified Data.Text as T

91−import qualified Data.Text.IO as T

92−import Database.Persist

93−import Database.Persist.MySQL (ConnectInfo (..),

94− SqlBackend (..),

95− defaultConnectInfo, fromSqlKey, runMigration,

96− runSqlPool, toSqlKey, withMySQLConn)

97−import Database.Persist.Sql (SqlPersistT, runSqlConn)

98−import Database.Persist.TH (mkMigrate, mkPersist,

99− persistLowerCase, share,

100− sqlSettings)

101−import Database.Persist.Types (PersistValue(PersistInt64))

102−import Servant (Handler, throwError)

103−

104−import GHC.Generics

105−import Network.Wai

106−import Network.Wai.Handler.Warp

107−import Servant

108−import Servant.API

109−import System.Environment (getArgs)

110−

111−share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|

112−Person json

113− Id Int Primary Unique

114− name Text

115− age Text

116− deriving Eq Show Generic

117−|]

118−

119−type Api =

120− "person" :> Get '[JSON] [Person]

121− :<|> "person" :> Capture "id" Int :> Get '[JSON] Person

122− :<|> "person" :> Capture "id" Int :> Delete '[JSON] ()

123− :<|> "person" :> ReqBody '[JSON] Person :> Post '[JSON] Person

124−

125−apiProxy :: Proxy Api

126−apiProxy = Proxy

127−

128−app :: Application

129−app = serve apiProxy server

130−

131−-- Run a database operation, and lift the result into a Handler.

132−-- This minimises usage of IO operations in other functions

133−runDB :: SqlPersistT (ResourceT (NoLoggingT IO)) a -> Handler a

134−runDB a = liftIO $ runNoLoggingT $ runResourceT $ withMySQLConn connInfo $ runSqlConn a

135−

136−-- Change these out to suit your local setup

137−connInfo :: ConnectInfo

138−connInfo = defaultConnectInfo { connectHost = "127.0.0.1", connectUser = "root", connectPassword = "abcd", connectDatabase = "test-database" }

139−

140−doMigration :: IO ()

141−doMigration = runNoLoggingT $ runResourceT $ withMySQLConn connInfo $ runReaderT $ runMigration migrateAll

142−

143−server :: Server Api

144−server =

145− personGET :<|>

146− personGETById :<|>

147− personDELETE :<|>

148− personPOST

149− where

150− personGET = selectPersons

151− personGETById id = selectPersonById id

152− personDELETE id = deletePerson id

153− personPOST personJson = createPerson personJson

154−

155−selectPersons :: Handler [Person]

156−selectPersons = do

157− personList <- runDB $ selectList [] []

158− return $ map (\(Entity _ u) -> u) personList

159−

160−selectPersonById :: Int -> Handler Person

161−selectPersonById id = do

162− sqlResult <- runDB $ get $ PersonKey id

163− case sqlResult of

164− Just person -> return person

165− Nothing -> throwError err404 { errBody = JSON.encode "Person with ID not found." }

166−

167−createPerson :: Person -> Handler Person

168−createPerson person = do

169− attemptCreate <- runDB $ insert person

170− case attemptCreate of

171− PersonKey k -> return person

172− _ -> throwError err503 { errBody = JSON.encode "Could not create Person." }

173−

174−deletePerson :: Int -> Handler ()

175−deletePerson id = do runDB $ delete $ PersonKey id

176−

177−startApp :: IO ()

178−startApp = do

179− args <- getArgs

180− let arg1 = if not (null args) then Just (head args) else Nothing

181− case arg1 of

182− Just "migrate" -> doMigration

183− _ -> run 8080 app

184−```

185−

186−## Sample requests

187−

188−Assuming that you have the db running and have first run `stack exec run migrate`, the following sample requests will test your API:

189−

190−*Create a person*

191−

192−```bash

193−curl -X POST \

194− http://localhost:8080/person \

195− -H 'Accept: */*' \

196− -H 'Accept-Encoding: gzip, deflate' \

197− -H 'Cache-Control: no-cache' \

198− -H 'Connection: keep-alive' \

199− -H 'Content-Length: 62' \

200− -H 'Content-Type: application/json' \

201− -H 'Host: localhost:8080' \

202− -H 'cache-control: no-cache' \

203− -d '{

204− "name": "Jake",

205− "age": "25"

206−}'

207−```

208−

209−*Get all persons*

210−

211−```bash

212−curl -X GET \

213− http://localhost:8080/person \

214− -H 'Accept: */*' \

215− -H 'Accept-Encoding: gzip, deflate' \

216− -H 'Cache-Control: no-cache' \

217− -H 'Connection: keep-alive' \

218− -H 'Content-Length: 33' \

219− -H 'Content-Type: application/json' \

220− -H 'Host: localhost:8080' \

221− -H 'cache-control: no-cache'

222−```

223−

224−*Get person by ID*

225−

226−```bash

227−curl -X GET \

228− http://localhost:8080/person/1 \

229− -H 'Accept: */*' \

230− -H 'Accept-Encoding: gzip, deflate' \

231− -H 'Cache-Control: no-cache' \

232− -H 'Connection: keep-alive' \

233− -H 'Content-Type: application/json' \

234− -H 'Host: localhost:8080' \

235− -H 'cache-control: no-cache'

236−```

doc/cookbook/db-mysql-basics/mysql-basics.cabaldeleted−40

@@ -1,40 +0,0 @@

1−cabal-version: 2.2

2−name: mysql-basics

3−version: 0.1.0.0

4−synopsis: Simple MySQL API cookbook example

5−homepage: http://docs.servant.dev/

6−license: BSD-3-Clause

7−license-file: ../../../servant/LICENSE

8−author: Servant Contributors

9−maintainer: haskell-servant-maintainers@googlegroups.com

10−build-type: Simple

11−

12−executable run

13− hs-source-dirs: .

14− main-is: MysqlBasics.hs

15− ghc-options: -threaded -rtsopts -with-rtsopts=-N

16− build-depends: aeson

17− , base

18− , bytestring

19− , http-client

20− , monad-logger

21− , mysql-simple

22− , persistent

23− , persistent-mysql

24− , persistent-template

25− , resource-pool

26− , resourcet

27− , servant

28− , servant-client

29− , servant-server

30− , text

31− , transformers

32− , wai

33− , warp

34− default-language: Haskell2010

35− ghc-options: -Wall -pgmL markdown-unlit

36− build-tool-depends: markdown-unlit:markdown-unlit

37−

38−source-repository head

39− type: git

40− location: https://github.com/githubuser/mysql-basics

doc/cookbook/db-postgres-pool/db-postgres-pool.cabal+4−4

@@ -1,14 +1,14 @@

1−cabal-version: 2.2

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==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.1

12

12

13executable cookbook-db-postgres-pool

13executable cookbook-db-postgres-pool

14 main-is: PostgresPool.lhs

14 main-is: PostgresPool.lhs

doc/cookbook/db-sqlite-simple/db-sqlite-simple.cabal+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==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.1

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+4−4

@@ -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

@@ -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==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.1

12

12

13executable cookbook-file-upload

13executable cookbook-file-upload

14 main-is: FileUpload.lhs

14 main-is: FileUpload.lhs

doc/cookbook/generic/Generic.lhs+7−42

@@ -7,11 +7,10 @@

7{-# LANGUAGE TypeOperators #-}

7{-# LANGUAGE TypeOperators #-}

8module Main (main, api, getLink, routesLinks, cliGet) where

8module Main (main, api, getLink, routesLinks, cliGet) where

9

9

10−import Control.Exception (throwIO)

10+import Control.Exception (throwIO)

11−import Control.Monad.Trans.Reader (ReaderT, runReaderT)

12−import Data.Proxy (Proxy (..))

11+import Data.Proxy (Proxy (..))

13−import Network.Wai.Handler.Warp (run)

12+import Network.Wai.Handler.Warp (run)

14−import System.Environment (getArgs)

13+import System.Environment (getArgs)

15

14

16import Servant

15import Servant

17import Servant.Client

16import Servant.Client

@@ -43,13 +42,13 @@ api :: Proxy (ToServantApi Routes)

43api = genericApi (Proxy :: Proxy Routes)

42api = genericApi (Proxy :: Proxy Routes)

44```

43```

45

44

46−It's recommended to use `genericApi` function, as then you'll get

45+It's recommented to use `genericApi` function, as then you'll get

47better error message, for example if you forget to `derive Generic`.

46better error message, for example if you forget to `derive Generic`.

48

47

49## Links

48## Links

50

49

51The clear advantage of record-based generics approach, is that

50The clear advantage of record-based generics approach, is that

52−we can get safe links very conveniently. We don't need to define endpoint types,

51+we can get safe links very conviently. We don't need to define endpoint types,

53as field accessors work as proxies:

52as field accessors work as proxies:

54

53

55```haskell

54```haskell

@@ -67,7 +66,7 @@ routesLinks = allFieldLinks

67## Client

66## Client

68

67

69Even more power starts to show when we generate a record of client functions.

68Even more power starts to show when we generate a record of client functions.

70−Here we use `genericClientHoist` function, which lets us simultaneously

69+Here we use `genericClientHoist` function, which let us simultaneously

71hoist the monad, in this case from `ClientM` to `IO`.

70hoist the monad, in this case from `ClientM` to `IO`.

72

71

73```haskell

72```haskell

@@ -103,39 +102,5 @@ main = do

103 ("run":_) -> do

102 ("run":_) -> do

104 putStrLn "Starting cookbook-generic at http://localhost:8000"

103 putStrLn "Starting cookbook-generic at http://localhost:8000"

105 run 8000 app

104 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"

105 _ -> putStrLn "To run, pass 'run' argument: cabal new-run cookbook-generic run"

111```

106```

112−

113−## Using generics together with a custom monad

114−

115−If your app uses a custom monad, here's how you can combine it with

116−generics.

117−

118−```haskell

119−data AppCustomState =

120− AppCustomState

121−

122−type AppM = ReaderT AppCustomState Handler

123−

124−apiMyMonad :: Proxy (ToServantApi Routes)

125−apiMyMonad = genericApi (Proxy :: Proxy Routes)

126−

127−getRouteMyMonad :: Int -> AppM String

128−getRouteMyMonad = return . show

129−

130−putRouteMyMonad :: Int -> AppM Bool

131−putRouteMyMonad = return . odd

132−

133−recordMyMonad :: Routes (AsServerT AppM)

134−recordMyMonad = Routes {_get = getRouteMyMonad, _put = putRouteMyMonad}

135−

136−-- natural transformation

137−nt :: AppCustomState -> AppM a -> Handler a

138−nt s x = runReaderT x s

139−

140−appMyMonad :: AppCustomState -> Application

141−appMyMonad state = genericServeT (nt state) recordMyMonad

doc/cookbook/generic/generic.cabal+4−4

@@ -1,14 +1,14 @@

1−cabal-version: 2.2

2name: cookbook-generic

1name: cookbook-generic

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==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.1

12

12

13executable cookbook-using-custom-monad

13executable cookbook-using-custom-monad

14 main-is: Generic.lhs

14 main-is: Generic.lhs

doc/cookbook/hoist-server-with-context/HoistServerWithContext.lhs+4−11

@@ -25,15 +25,8 @@ for our logging example below.

25This recipe uses the following ingredients:

25This recipe uses the following ingredients:

26

26

27```haskell

27```haskell

28−{-# LANGUAGE DataKinds #-}

29−{-# LANGUAGE DeriveGeneric #-}

30−{-# LANGUAGE OverloadedStrings #-}

28+{-# LANGUAGE OverloadedStrings, TypeFamilies, DataKinds,

31−{-# LANGUAGE TypeFamilies #-}

32−{-# LANGUAGE TypeOperators #-}

29+ DeriveGeneric, TypeOperators #-}

33−

34−import Prelude ()

35−import Prelude.Compat

36−

37import Control.Monad.IO.Class (liftIO)

30import Control.Monad.IO.Class (liftIO)

38import Control.Monad.Reader

31import Control.Monad.Reader

39import Data.Aeson

32import Data.Aeson

@@ -254,7 +247,7 @@ loginHandler cookieSettings jwtSettings form = do

254 liftIO $ pushLogStrLn logset $ toLogStr logMsg

247 liftIO $ pushLogStrLn logset $ toLogStr logMsg

255 throwError err401

248 throwError err401

256 Just applyCookies -> do

249 Just applyCookies -> do

257− let successMsg = logMsg{message = "AdminUser successfully authenticated!"}

250+ let successMsg = logMsg{message = "AdminUser succesfully authenticated!"}

258 liftIO $ pushLogStrLn logset $ toLogStr successMsg

251 liftIO $ pushLogStrLn logset $ toLogStr successMsg

259 pure $ applyCookies successMsg

252 pure $ applyCookies successMsg

260loginHandler _ _ _ = throwError err401

253loginHandler _ _ _ = throwError err401

@@ -287,7 +280,7 @@ mkApp cfg cs jwts ctx =

287 (flip runReaderT ctx) (adminServer cs jwts)

280 (flip runReaderT ctx) (adminServer cs jwts)

288```

281```

289

282

290−One footnote: because we'd like our logs to be in JSON form, we'll also create a `Middleware` object

283+One footenote: because we'd like our logs to be in JSON form, we'll also create a `Middleware` object

291so that `Warp` *also* will emit logs as JSON. This will ensure *all* logs are emitted as JSON:

284so that `Warp` *also* will emit logs as JSON. This will ensure *all* logs are emitted as JSON:

292

285

293```haskell

286```haskell

doc/cookbook/hoist-server-with-context/hoist-server-with-context.cabal+5−6

@@ -1,22 +1,21 @@

1−cabal-version: 2.2

2name: cookbook-hoist-server-with-context

1name: cookbook-hoist-server-with-context

3version: 0.0.1

2version: 0.0.1

4synopsis: JWT and basic access authentication with a Custom Monad cookbook example

3synopsis: JWT and basic access authentication with a Custom Monad 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==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.1

15

15

16executable cookbook-hoist-server-with-context

16executable cookbook-hoist-server-with-context

17 main-is: HoistServerWithContext.lhs

17 main-is: HoistServerWithContext.lhs

18 build-depends: base == 4.*

18 build-depends: base == 4.*

19− , base-compat

20 , text >= 1.2

19 , text >= 1.2

21 , aeson >= 1.2

20 , aeson >= 1.2

22 , data-default

21 , data-default

@@ -24,7 +23,7 @@ executable cookbook-hoist-server-with-context

24 , servant

23 , servant

25 , servant-server

24 , servant-server

26 , servant-auth >= 0.3.2

25 , servant-auth >= 0.3.2

27− , servant-auth-server >= 0.4.4.0

26+ , servant-auth-server

28 , time

27 , time

29 , warp >= 3.2

28 , warp >= 3.2

30 , wai >= 3.2

29 , wai >= 3.2

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==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.1

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−8

@@ -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,

@@ -20,15 +20,11 @@ you name it!

20 structuring-apis/StructuringApis.lhs

20 structuring-apis/StructuringApis.lhs

21 generic/Generic.lhs

21 generic/Generic.lhs

22 https/Https.lhs

22 https/Https.lhs

23− db-mysql-basics/MysqlBasics.lhs

24 db-sqlite-simple/DBConnection.lhs

23 db-sqlite-simple/DBConnection.lhs

25 db-postgres-pool/PostgresPool.lhs

24 db-postgres-pool/PostgresPool.lhs

26 using-custom-monad/UsingCustomMonad.lhs

25 using-custom-monad/UsingCustomMonad.lhs

27 using-free-client/UsingFreeClient.lhs

26 using-free-client/UsingFreeClient.lhs

28− custom-errors/CustomErrors.lhs

29− uverb/UVerb.lhs

30 basic-auth/BasicAuth.lhs

27 basic-auth/BasicAuth.lhs

31− basic-streaming/Streaming.lhs

32 jwt-and-basic-auth/JWTAndBasicAuth.lhs

28 jwt-and-basic-auth/JWTAndBasicAuth.lhs

33 hoist-server-with-context/HoistServerWithContext.lhs

29 hoist-server-with-context/HoistServerWithContext.lhs

34 file-upload/FileUpload.lhs

30 file-upload/FileUpload.lhs

@@ -36,5 +32,3 @@ you name it!

36 curl-mock/CurlMock.lhs

32 curl-mock/CurlMock.lhs

37 sentry/Sentry.lhs

33 sentry/Sentry.lhs

38 testing/Testing.lhs

34 testing/Testing.lhs

39− open-id-connect/OpenIdConnect.lhs

40− managed-resource/ManagedResource.lhs

doc/cookbook/jwt-and-basic-auth/jwt-and-basic-auth.cabal+5−5

@@ -1,17 +1,17 @@

1−cabal-version: 2.2

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==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.1

15

15

16executable cookbook-jwt-and-basic-auth

16executable cookbook-jwt-and-basic-auth

17 main-is: JWTAndBasicAuth.lhs

17 main-is: JWTAndBasicAuth.lhs

@@ -22,7 +22,7 @@ executable cookbook-jwt-and-basic-auth

22 , servant

22 , servant

23 , servant-client

23 , servant-client

24 , servant-server

24 , servant-server

25− , servant-auth == 0.4.*

25+ , servant-auth ==0.3.*

26 , servant-auth-server >= 0.3.1.0

26 , servant-auth-server >= 0.3.1.0

27 , warp >= 3.2

27 , warp >= 3.2

28 , wai >= 3.2

28 , wai >= 3.2

doc/cookbook/managed-resource/ManagedResource.lhsdeleted−114

@@ -1,114 +0,0 @@

1−# Request-lifetime Managed Resources

2−

3−Let's see how we can write a handle that uses a resource managed by Servant. The resource is created automatically by Servant when the server recieves a request, and the resource is automatically destroyed when the server is finished handling a request.

4−

5−As usual, we start with a little bit of throat clearing.

6−

7−

8−``` haskell

9−{-# LANGUAGE DataKinds #-}

10−{-# LANGUAGE TypeOperators #-}

11−import Control.Concurrent

12−import Control.Exception (bracket, throwIO)

13−import Control.Monad.IO.Class

14−import Control.Monad.Trans.Resource

15−import Data.Acquire

16−import Network.HTTP.Client (newManager, defaultManagerSettings)

17−import Network.Wai.Handler.Warp

18−import Servant

19−import Servant.Client

20−import System.IO

21−```

22−

23−Here we define an API type that uses the `WithResource` combinator. The server handler for an endpoint with a `WithResource res` component will receive a value of that type as an argument.

24−

25−``` haskell

26−type API = WithResource Handle :> ReqBody '[PlainText] String :> Post '[JSON] NoContent

27−

28−api :: Proxy API

29−api = Proxy

30−```

31−

32−But this resource value has to come from somewhere. Servant obtains the value using an Acquire provided in the context. The Acquire knows how to both create and destroy resources of a particular type.

33−

34−``` haskell

35−appContext :: Context '[Acquire Handle]

36−appContext = acquireHandle :. EmptyContext

37−

38−acquireHandle :: Acquire Handle

39−acquireHandle = mkAcquire newHandle closeHandle

40−

41−newHandle :: IO Handle

42−newHandle = do

43− putStrLn "opening file"

44− h <- openFile "test.txt" AppendMode

45− putStrLn "opened file"

46− return h

47−

48−closeHandle :: Handle -> IO ()

49−closeHandle h = do

50− putStrLn "closing file"

51− hClose h

52− putStrLn "closed file"

53−```

54−

55−Now we create the handler which will use this resource. This handler will write the request message to the System.IO.Handle which was provided to us. In some situations the handler will succeed, but in some in will fail. In either case, Servant will clean up the resource for us.

56−

57−``` haskell

58−server :: Server API

59−server = writeToFile

60−

61− where writeToFile :: (ReleaseKey, Handle) -> String -> Handler NoContent

62− writeToFile (_, h) msg = case msg of

63− "illegal" -> error "wait, that's illegal!"

64− legalMsg -> liftIO $ do

65− putStrLn "writing file"

66− hPutStrLn h legalMsg

67− putStrLn "wrote file"

68− return NoContent

69−```

70−

71−Finally we run the server in the background while we post messages to it.

72−

73−``` haskell

74−runApp :: IO ()

75−runApp = run 8080 (serveWithContext api appContext $ server)

76−

77−postMsg :: String -> ClientM NoContent

78−postMsg = client api

79−

80−main :: IO ()

81−main = do

82− mgr <- newManager defaultManagerSettings

83− bracket (forkIO $ runApp) killThread $ \_ -> do

84− ms <- flip runClientM (mkClientEnv mgr (BaseUrl Http "localhost" 8080 "")) $ do

85− liftIO $ putStrLn "sending hello message"

86− _ <- postMsg "hello"

87− liftIO $ putStrLn "sending illegal message"

88− _ <- postMsg "illegal"

89− liftIO $ putStrLn "done"

90− print ms

91−```

92−

93−This program prints

94−

95−```

96−sending hello message

97−opening file

98−opened file

99−writing file

100−wrote file

101−closing file

102−closed file

103−sending illegal message

104−opening file

105−opened file

106−closing file

107−closed file

108−wait, that's illegal!

109−CallStack (from HasCallStack):

110− error, called at ManagedResource.lhs:63:24 in main:Main

111−Left (FailureResponse (Request {requestPath = (BaseUrl {baseUrlScheme = Http, baseUrlHost = "localhost", baseUrlPort = 8080, baseUrlPath = ""},""), requestQueryString = fromList [], requestBody = Just ((),text/plain;charset=utf-8), requestAccept = fromList [], requestHeaders = fromList [], requestHttpVersion = HTTP/1.1, requestMethod = "POST"}) (Response {responseStatusCode = Status {statusCode = 500, statusMessage = "Internal Server Error"}, responseHeaders = fromList [("Transfer-Encoding","chunked"),("Date","Thu, 24 Nov 2022 21:04:47 GMT"),("Server","Warp/3.3.23"),("Content-Type","text/plain; charset=utf-8")], responseHttpVersion = HTTP/1.1, responseBody = "Something went wrong"}))

112−```

113−

114−and appends to a file called `test.txt`. We can see from the output that when a legal message is sent, the file is opened, written to, and closed. We can also see that when an illegal message is sent, the file is opened but not written to. Crucially, it is still closed even though the handler threw an exception.

doc/cookbook/managed-resource/managed-resource.cabaldeleted−30

@@ -1,30 +0,0 @@

1−cabal-version: 2.2

2−name: cookbook-managed-resource

3−version: 0.1

4−synopsis: Simple managed resource cookbook example

5−homepage: http://docs.servant.dev/

6−license: BSD-3-Clause

7−license-file: ../../../servant/LICENSE

8−author: Servant Contributors

9−maintainer: haskell-servant-maintainers@googlegroups.com

10−build-type: Simple

11−tested-with: GHC==9.4.2

12−

13−executable cookbook-managed-resource

14− main-is: ManagedResource.lhs

15− build-depends: base == 4.*

16− , text >= 1.2

17− , aeson >= 1.2

18− , servant

19− , servant-client

20− , servant-server

21− , warp >= 3.2

22− , wai >= 3.2

23− , http-types >= 0.12

24− , markdown-unlit >= 0.4

25− , http-client >= 0.5

26− , transformers

27− , resourcet

28− default-language: Haskell2010

29− ghc-options: -Wall -pgmL markdown-unlit

30− build-tool-depends: markdown-unlit:markdown-unlit

doc/cookbook/open-id-connect/OpenIdConnect.cabaldeleted−45

@@ -1,45 +0,0 @@

1−cabal-version: 2.2

2−name: open-id-connect

3−version: 0.1

4−synopsis: OpenId Connect with Servant example

5−homepage: http://haskell-servant.readthedocs.org/

6−license: BSD-3-Clause

7−license-file: ../../../servant/LICENSE

8−author: Servant Contributors

9−maintainer: haskell-servant-maintainers@googlegroups.com

10−build-type: Simple

11−tested-with: GHC==8.6.5

12−

13−executable cookbook-openidconnect

14− main-is: OpenIdConnect.lhs

15− build-depends: base ==4.*

16− , aeson

17− , aeson-pretty

18− , binary

19− , blaze-html

20− , blaze-markup

21− , bytestring

22− , case-insensitive

23− , cereal

24− , containers

25− , generic-lens

26− , http-client

27− , http-client-tls

28− , http-types

29− , jose-jwt

30− , lens

31− , lens-aeson

32− , oidc-client

33− , protolude

34− , random

35− , servant

36− , servant-blaze

37− , servant-server

38− , text

39− , time

40− , vector

41− , wai

42− , warp >= 3.2

43− default-language: Haskell2010

44− ghc-options: -Wall -Wcompat -Wincomplete-uni-patterns -Wredundant-constraints -Wnoncanonical-monad-instances -pgmL markdown-unlit

45− build-tool-depends: markdown-unlit:markdown-unlit >= 0.4

doc/cookbook/open-id-connect/OpenIdConnect.lhsdeleted−472

@@ -1,472 +0,0 @@

1−[OpenID Connect](https://openid.net/connect/)

2−=============================================

3−

4−Use OpenID Connect to authenticate your users.

5−This example use google OIDC provider.

6−It was made for a working with single page application where

7−some login token would be saved in the user agent local storage.

8−

9−Workflow:

10−

11−1. user is presented with a login button,

12−2. when the user clicks on the button it is redirected to the OIDC

13− provider,

14−3. the user login in the OIDC provider,

15−4. the OIDC provider will redirect the user and provide a `code`,

16−5. the server will use this code to make a POST to the OIDC provider

17− and will get back authentication infos,

18−6. The user will get display an HTML page that will save a secret

19− identifying him in the local storage, then it will be redirected to

20− /.

21−

22−Let's put the imports behind us:

23−

24−``` haskell

25−{-# LANGUAGE DataKinds #-}

26−{-# LANGUAGE DeriveGeneric #-}

27−{-# LANGUAGE DuplicateRecordFields #-}

28−{-# LANGUAGE FlexibleContexts #-}

29−{-# LANGUAGE FlexibleInstances #-}

30−{-# LANGUAGE MultiParamTypeClasses #-}

31−{-# LANGUAGE NoImplicitPrelude #-}

32−{-# LANGUAGE OverloadedLists #-}

33−{-# LANGUAGE OverloadedStrings #-}

34−{-# LANGUAGE PartialTypeSignatures #-}

35−{-# LANGUAGE PolyKinds #-}

36−{-# LANGUAGE RankNTypes #-}

37−{-# LANGUAGE RecordWildCards #-}

38−{-# LANGUAGE ScopedTypeVariables #-}

39−{-# LANGUAGE TypeFamilies #-}

40−{-# LANGUAGE TypeOperators #-}

41−{-# LANGUAGE TypeSynonymInstances #-}

42−

43−module Main where

44−

45−import Protolude

46−

47−import Data.Aeson

48− (FromJSON (..), (.:))

49−import qualified Data.Aeson as JSON

50−import qualified Data.Aeson.Types as AeT

51−import qualified Data.ByteString.Lazy as LBS

52−import qualified Data.List as List

53−import qualified Data.Text as Text

54−import Jose.Jwt

55− (Jwt (..), decodeClaims)

56−import Network.HTTP.Client

57− (Manager, newManager)

58−import Network.HTTP.Client.TLS

59− (tlsManagerSettings)

60−import Network.Wai.Handler.Warp

61− (run)

62−import Servant

63−import Servant.HTML.Blaze

64− (HTML)

65−import qualified System.Random as Random

66−import Text.Blaze

67− (ToMarkup (..))

68−import qualified Text.Blaze.Html as H

69−import Text.Blaze.Html5

70− ((!))

71−import qualified Text.Blaze.Html5 as H

72−import qualified Text.Blaze.Html5.Attributes as HA

73−import Text.Blaze.Renderer.Utf8

74− (renderMarkup)

75−import qualified Web.OIDC.Client as O

76−```

77−

78−You'll need to create a new OpenID Connect client in an OpenID Provider.

79−This example was tested with Google.

80−

81−You can find a list of public OIDC provider here:

82−https://connect2id.com/products/nimbus-oauth-openid-connect-sdk/openid-connect-providers

83−

84−I copied some here:

85−

86−- Google: https://developers.google.com/identity/protocols/OpenIDConnect

87− more precisely: https://console.developers.google.com/apis/credentials

88−- Microsoft: https://docs.microsoft.com/en-us/previous-versions/azure/dn645541(v=azure.100)

89−- Yahoo: https://developer.yahoo.com/oauth2/guide/openid_connect/

90−- PayPal: https://developer.paypal.com/docs/integration/direct/identity/log-in-with-paypal/

91−

92−During the configuration you'll need to provide a redirect uri.

93−The redirect_uri should correspond to the uri user will be redirected to

94−after a successful login into the OpenID provider.

95−

96−So during your test, you should certainly just use `http://localhost:3000/login/cb`.

97−In general you should use your own domain name.

98−

99−You'll then be given a `client_id` and a `client_password`.

100−Fill those values in here:

101−

102−``` haskell

103−oidcConf :: OIDCConf

104−oidcConf = OIDCConf { redirectUri = "http://localhost:3000/login/cb"

105− , clientId = "xxxxxxxxxxxx-xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx.apps.googleusercontent.com"

106− , clientPassword = "************************" }

107−```

108−

109−Then we declare our main server:

110−

111−``` haskell

112−main :: IO ()

113−main = do

114− oidcEnv <- initOIDC oidcConf

115− run 3000 (app oidcEnv)

116−

117−type API = IdentityRoutes Customer

118− :<|> Get '[HTML] Homepage

119−

120−api :: Proxy API

121−api = Proxy

122−

123−server :: OIDCEnv -> Server API

124−server oidcEnv = serveOIDC oidcEnv handleOIDCLogin

125− :<|> return Homepage

126−

127−-- | Then main app

128−app :: OIDCEnv -> Application

129−app oidcEnv = serve api (server oidcEnv)

130−```

131−

132−OIDC

133−----

134−

135−That part try to separate concern, and certainly in a real world

136−application that should be in its distinct module.

137−

138−``` haskell

139−-- * OIDC

140−

141−data OIDCConf =

142− OIDCConf { redirectUri :: ByteString

143− , clientId :: ByteString

144− , clientPassword :: ByteString

145− } deriving (Show, Eq)

146−```

147−

148−First we need to initialize OIDC.

149−A short explanation about it:

150−

151−- to complete the workflow we need to make a POST request to the OIDC provider.

152− So we need to create an http manager to make those call properly.

153−- Then in order to prevent replay attack, each time an user wants to login we

154− should provide a random string called the `state`. When the user is

155− redirected to the `redirect_uri`, the OIDC provider should provide the same

156− `state` along a `code` parameter.

157−

158−``` haskell

159−initOIDC :: OIDCConf -> IO OIDCEnv

160−initOIDC OIDCConf{..} = do

161− mgr <- newManager tlsManagerSettings

162− prov <- O.discover "https://accounts.google.com" mgr

163− let oidc = O.setCredentials clientId clientPassword redirectUri (O.newOIDC prov)

164− return OIDCEnv { oidc = oidc

165− , mgr = mgr

166− , genState = genRandomBS

167− , prov = prov

168− , redirectUri = redirectUri

169− , clientId = clientId

170− , clientPassword = clientPassword

171− }

172−

173−data OIDCEnv = OIDCEnv { oidc :: O.OIDC

174− , mgr :: Manager

175− , genState :: IO ByteString

176− , prov :: O.Provider

177− , redirectUri :: ByteString

178− , clientId :: ByteString

179− , clientPassword :: ByteString

180− }

181−```

182−

183−The `IdentityRoutes` are two endpoints:

184−

185−- an endpoint to redirect the users to the OIDC Provider,

186−- another one the user will be redirected to from the OIDC Provider.

187−

188−``` haskell

189−type IdentityRoutes a =

190− "login" :> ( -- redirect User to the OpenID Provider

191− Get '[JSON] NoContent

192− -- render the page that will save the user creds in the user-agent

193− :<|> "cb" :> QueryParam "error" Text

194− :> QueryParam "code" Text

195− :> Get '[HTML] User)

196−

197−-- | gen a 302 redirect helper

198−redirects :: (StringConv s ByteString) => s -> Handler ()

199−redirects url = throwError err302 { errHeaders = [("Location",toS url)]}

200−```

201−

202−That function will generate the URL to redirect the users to when

203−they'll click on the login link: `https://yourdomain/login`.

204−

205−``` haskell

206−genOIDCURL :: OIDCEnv -> IO ByteString

207−genOIDCURL OIDCEnv{..} = do

208− st <- genState -- generate a random string

209− let oidcCreds = O.setCredentials clientId clientPassword redirectUri (O.newOIDC prov)

210− loc <- O.getAuthenticationRequestUrl oidcCreds [O.openId, O.email, O.profile] (Just st) []

211− return (show loc)

212−

213−handleLogin :: OIDCEnv -> Handler NoContent

214−handleLogin oidcenv = do

215− loc <- liftIO (genOIDCURL oidcenv)

216− redirects loc

217− return NoContent

218−```

219−

220−The `AuthInfo` is about the infos we can grab from OIDC provider.

221−

222−To be more precise, the user should come with a `code` (a token) and

223−POSTing that code to the correct OIDC provider endpoint should return a JSON

224−object. One of the fields should be named `id_token` which should be a

225−JWT containing all the information we need. Depending on the scopes we

226−asked we might get more information.

227−

228−``` haskell

229−-- | @AuthInfo@

230−data AuthInfo = AuthInfo { email :: Text

231− , emailVerified :: Bool

232− , name :: Text } deriving (Eq, Show, Generic)

233−

234−instance FromJSON AuthInfo where

235− parseJSON (JSON.Object v) = do

236− email :: Text <- v .: "email"

237− email_verified :: Bool <- v .: "email_verified"

238− name :: Text <- v .: "name"

239− return $ AuthInfo (toS email) email_verified (toS name)

240− parseJSON invalid = AeT.typeMismatch "Coord" invalid

241−instance JSON.ToJSON AuthInfo where

242− toJSON (AuthInfo e ev n) =

243− JSON.object [ "email" JSON..= (toS e :: Text)

244− , "email_verified" JSON..= ev

245− , "name" JSON..= (toS n :: Text)

246− ]

247−

248−type LoginHandler = AuthInfo -> IO (Either Text User)

249−```

250−

251−The `handleLoggedIn` is that part that will retrieve the information from

252−the user once he is redirected from the OIDC Provider after login.

253−

254−If the user is redirected to the `redirect_uri` but with an `error` query

255−parameter then it means something went wrong.

256−If there is no error query param but a `code` query param it means the user

257−successfully logged in. From there we need to make a request to the token

258−endpoint of the OIDC provider. It's a POST that should contain the code

259−as well as the client id and secret.

260−Making this HTTP POST is the responsibility of `requestTokens`.

261−

262−From there we extract the `claims` of the JWT contained in one of the value

263−of the JSON returned by the POST HTTP Request.

264−

265−``` haskell

266−data User = User { userId :: Text

267− , userSecret :: Text

268− , localStorageKey :: Text

269− , redirectUrl :: Maybe Text

270− } deriving (Show,Eq,Ord)

271−

272−handleLoggedIn :: OIDCEnv

273− -> LoginHandler -- ^ handle successful id

274− -> Maybe Text -- ^ error

275− -> Maybe Text -- ^ code

276− -> Handler User

277−handleLoggedIn oidcenv handleSuccessfulId err mcode =

278− case err of

279− Just errorMsg -> forbidden errorMsg

280− Nothing -> case mcode of

281− Just oauthCode -> do

282− tokens <- liftIO $ O.requestTokens (oidc oidcenv) (toS oauthCode) (mgr oidcenv)

283− putText . show . O.claims . O.idToken $ tokens

284− let jwt = toS . unJwt . O.jwt . O.idToken $ tokens

285− eAuthInfo = decodeClaims jwt :: Either O.JwtError (O.JwtHeader,AuthInfo)

286− case eAuthInfo of

287− Left jwtErr -> forbidden $ "JWT decode/check problem: " <> show jwtErr

288− Right (_,authInfo) ->

289− if emailVerified authInfo

290− then do

291− user <- liftIO $ handleSuccessfulId authInfo

292− either forbidden return user

293− else forbidden "Please verify your email"

294− Nothing -> do

295− liftIO $ putText "No code param"

296− forbidden "no code parameter given"

297−```

298−

299−When you render a User with blaze-html, it will generate a page with a js

300−that will put a secret for that user in the local storage. And it will

301−redirect the user to /.

302−

303−``` haskell

304−instance ToMarkup User where

305− toMarkup User{..} = H.docTypeHtml $ do

306− H.head $

307− H.title "Logged In"

308− H.body $ do

309− H.h1 "Logged In"

310− H.p (H.toHtml ("Successful login with id " <> userId))

311− H.script (H.toHtml ("localStorage.setItem('" <> localStorageKey <> "','" <> userSecret <> "');"

312− <> "localStorage.setItem('user-id','" <> userId <> "');"

313− <> "window.location='" <> fromMaybe "/" redirectUrl <> "';" -- redirect the user to /

314− ));

315−

316−serveOIDC :: OIDCEnv -> LoginHandler -> Server (IdentityRoutes a)

317−serveOIDC oidcenv loginHandler =

318− handleLogin oidcenv :<|> handleLoggedIn oidcenv loginHandler

319−

320−-- * Auth

321−type APIKey = ByteString

322−type Account = Text.Text

323−type Conf = [(APIKey,Account)]

324−data Customer = Customer {

325− account :: Account

326− , apiKey :: APIKey

327− , mail :: Maybe Text

328− , fullname :: Maybe Text

329− }

330−```

331−

332−Here is the code that displays the homepage.

333−It should contain a link to the `/login` URL.

334−When the user clicks on this link it will be redirected to Google login page

335−with some generated information.

336−

337−The page also displays the content of the local storage.

338−And in particular the items `api-key` and `user-id`.

339−Those items should be set after a successful login when the user is redirected to

340−`/login/cb`.

341−

342−The logic used generally is to use that api-key to uniquely identify an user.

343−Another option would have been to set a cookie.

344−

345−``` haskell

346−data Homepage = Homepage

347−

348−instance ToMarkup Homepage where

349− toMarkup Homepage = H.docTypeHtml $ do

350− H.head $ do

351− H.title "OpenID Connect Servant Example"

352− H.style (H.toHtml ("body { font-family: monospace; font-size: 18px; }" :: Text.Text))

353− H.body $ do

354− H.h1 "OpenID Connect Servant Example"

355− H.div $

356− H.a ! HA.href "/login" $ "Click here to login"

357− H.ul $ do

358− H.li $ do

359− H.span "API Key in Local storage: "

360− H.script (H.toHtml ("document.write(localStorage.getItem('api-key'));" :: Text.Text))

361− H.li $ do

362− H.span "User ID in Local storage: "

363− H.script (H.toHtml ("document.write(localStorage.getItem('user-id'));" :: Text.Text))

364−```

365−

366−We need some helpers to generate random string for generating state and API Keys.

367−

368−``` haskell

369−-- | generate a random ByteString, not necessarily extremely good randomness

370−-- still the password will be long enough to be very difficult to crack

371−genRandomBS :: IO ByteString

372−genRandomBS = do

373− g <- Random.newStdGen

374− Random.randomRs (0, n) g & take 42 & fmap toChar & readable 0 & toS & return

375− where

376− n = length letters - 1

377− toChar i = letters List.!! i

378− letters = ['A'..'Z'] <> ['0'..'9'] <> ['a'..'z']

379− readable :: Int -> [Char] -> [Char]

380− readable _ [] = []

381− readable i str =

382− let blocksize = case n of

383− 0 -> 8

384− 1 -> 4

385− 2 -> 4

386− 3 -> 4

387− _ -> 12

388− block = take blocksize str

389− rest = drop blocksize str

390− in if List.null rest

391− then str

392− else block <> "-" <> readable (i+1) rest

393−

394−customerFromAuthInfo :: AuthInfo -> IO Customer

395−customerFromAuthInfo authinfo = do

396− apikey <- genRandomBS

397− return Customer { account = toS (email authinfo)

398− , apiKey = apikey

399− , mail = Just (toS (email authinfo))

400− , fullname = Just (toS (name authinfo))

401− }

402−

403−handleOIDCLogin :: LoginHandler

404−handleOIDCLogin authInfo = do

405− custInfo <- customerFromAuthInfo authInfo

406− if emailVerified authInfo

407− then return . Right . customerToUser $ custInfo

408− else return (Left "You emails is not verified by your provider. Please verify your email.")

409− where

410− customerToUser :: Customer -> User

411− customerToUser c =

412− User { userId = toS (account c)

413− , userSecret = toS (apiKey c)

414− , redirectUrl = Nothing

415− , localStorageKey = "api-key"

416− }

417−```

418−

419−`Error` helpers

420−---------------

421−

422−``` haskell

423−data Err = Err { errTitle :: Text

424− , errMsg :: Text }

425−

426−instance ToMarkup Err where

427− toMarkup Err{..} = H.docTypeHtml $ do

428− H.head $ do

429− H.title "Error"

430− H.body $ do

431− H.h1 (H.a ! HA.href "/" $ "Home")

432− H.h2 (H.toHtml errTitle)

433− H.p (H.toHtml errMsg)

434−

435−format :: ToMarkup a => a -> LBS.ByteString

436−format err = toMarkup err & renderMarkup

437−

438−appToErr :: ServerError -> Text -> ServerError

439−appToErr x msg = x

440− { errBody = toS $ format (Err (toS (errReasonPhrase x)) msg)

441− , errHeaders = [("Content-Type","text/html")]}

442−

443−unauthorized :: (MonadError ServerError m) => Text -> m a

444−unauthorized = throwError . unauthorizedErr

445−

446−unauthorizedErr :: Text -> ServerError

447−unauthorizedErr = appToErr err401

448−

449−forbidden :: (MonadError ServerError m) => Text -> m a

450−forbidden = throwError . forbiddenErr

451−

452−forbiddenErr :: Text -> ServerError

453−forbiddenErr = appToErr err403

454−

455−notFound :: ( MonadError ServerError m) => Text -> m a

456−notFound = throwError . notFoundErr

457−

458−notFoundErr :: Text -> ServerError

459−notFoundErr = appToErr err404

460−

461−preconditionFailed :: ( MonadError ServerError m) => Text -> m a

462−preconditionFailed = throwError . preconditionFailedErr

463−

464−preconditionFailedErr :: Text -> ServerError

465−preconditionFailedErr = appToErr err412

466−

467−serverError :: ( MonadError ServerError m) => Text -> m a

468−serverError = throwError . serverErrorErr

469−

470−serverErrorErr :: Text -> ServerError

471−serverErrorErr = appToErr err500

472−```

doc/cookbook/pagination/Pagination.lhs+8−8

@@ -18,7 +18,7 @@ For example: `Range: createdAt 2017-01-15T23:14:67.000Z; offset 5; order desc` i

18the client is willing to retrieve the next batch of document in descending order that were

18the client is willing to retrieve the next batch of document in descending order that were

19created after the fifteenth of January, skipping the first 5.

19created after the fifteenth of January, skipping the first 5.

20

20

21−As a response, the server may return the list of corresponding documents, and augment the

21+As a response, the server may return the list of corresponding document, and augment the

22response with 3 headers:

22response with 3 headers:

23

23

24- `Accept-Ranges`: A comma-separated list of fields upon which a range can be defined

24- `Accept-Ranges`: A comma-separated list of fields upon which a range can be defined

@@ -127,7 +127,7 @@ defaultRange =

127 getDefaultRange (Proxy @Color)

127 getDefaultRange (Proxy @Color)

128```

128```

129

129

130−Note that `getFieldValue :: Proxy "name" -> Color -> String` is the minimal complete definition

130+Note that `getFieldValue :: Proxy "name" -> Color -> String` is the minimal complete definintion

131of the class. Yet, you can define `getRangeOptions` to provide different parsing options (see

131of the class. Yet, you can define `getRangeOptions` to provide different parsing options (see

132the last section of this guide). In the meantime, we've also defined a `defaultRange` as it will

132the last section of this guide). In the meantime, we've also defined a `defaultRange` as it will

133come in handy when defining our handler.

133come in handy when defining our handler.

@@ -148,7 +148,7 @@ type MyHeaders =

148```

148```

149

149

150`PageHeaders` is a type alias provided by the library to declare the necessary response headers

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:

151+we mentionned in introduction. Expanding the alias boils down to the following:

152

152

153``` haskell

153``` haskell

154-- type MyHeaders =

154-- type MyHeaders =

@@ -165,7 +165,7 @@ not, _servant-pagination_ provides an easy way to lift a collection of resources

165#### Server

165#### Server

166

166

167Time to connect the last bits by defining the server implementation of our colorful API. The `Ranges`

167Time to connect the last bits by defining the server implementation of our colorful API. The `Ranges`

168−type we've defined above (tied to the `Range` HTTP header) indicates the server to parse any `Range`

168+type we've defined above (tight to the `Range` HTTP header) indicates the server to parse any `Range`

169header, looking for the format defined in introduction with fields and target types we have just declared.

169header, looking for the format defined in introduction with fields and target types we have just declared.

170If no such header is provided, we will end up receiving `Nothing`. Otherwise, it will be possible

170If no such header is provided, we will end up receiving `Nothing`. Otherwise, it will be possible

171to _extract_ a `Range` from our `Ranges`.

171to _extract_ a `Range` from our `Ranges`.

@@ -192,7 +192,7 @@ the format we defined, where `<field>` here can only be `name` and `<value>` mus

192- `Range: <field> [<value>][; offset <o>][; limit <l>][; order <asc|desc>]`

192- `Range: <field> [<value>][; offset <o>][; limit <l>][; order <asc|desc>]`

193

193

194Beside the target field, everything is pretty much optional in the `Range` HTTP header. Missing parts

194Beside the target field, everything is pretty much optional in the `Range` HTTP header. Missing parts

195−are deduced from the `RangeOptions` that are part of the `HasPagination` instance. Therefore, all

195+are deducted from the `RangeOptions` that are part of the `HasPagination` instance. Therefore, all

196following examples are valid requests to send to our server:

196following examples are valid requests to send to our server:

197

197

198- 1 - `curl http://localhost:1442/colors -vH 'Range: name'`

198- 1 - `curl http://localhost:1442/colors -vH 'Range: name'`

@@ -219,7 +219,7 @@ The previous ranges reads as follows:

219Note that in the simple above scenario, there's no ambiguity with `extractRange` and `returnRange`

219Note that in the simple above scenario, there's no ambiguity with `extractRange` and `returnRange`

220because there's only one possible `Range` defined on our resource. Yet, as you've most probably

220because there's only one possible `Range` defined on our resource. Yet, as you've most probably

221noticed, the `Ranges` combinator accepts a list of fields, each of which must declare a `HasPagination`

221noticed, the `Ranges` combinator accepts a list of fields, each of which must declare a `HasPagination`

222−instance. Doing so will make the other helper functions more ambiguous and type annotations are

222+instance. Doing so will make the other helper functions more ambiguous and type annotation are

223highly likely to be needed.

223highly likely to be needed.

224

224

225

225

@@ -235,8 +235,8 @@ instance HasPagination Color "hex" where

235#### Parsing Options

235#### Parsing Options

236

236

237By default, `servant-pagination` provides an implementation of `getRangeOptions` for each

237By default, `servant-pagination` provides an implementation of `getRangeOptions` for each

238−`HasPagination` instance. However, this can be overridden when defining the instance to provide

238+`HasPagination` instance. However, this can be overwritten 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

239+your own options. This options come into play when a `Range` header is received and isn't fully

240specified (`limit`, `offset`, `order` are all optional) to provide default fallback values for those.

240specified (`limit`, `offset`, `order` are all optional) to provide default fallback values for those.

241

241

242For instance, let's say we wanted to change the default limit to `5` in a new range on

242For instance, let's say we wanted to change the default limit to `5` in a new range on

doc/cookbook/pagination/pagination.cabal+5−5

@@ -1,21 +1,21 @@

1−cabal-version: 2.2

2name: cookbook-pagination

1name: cookbook-pagination

3version: 2.1

2version: 2.1

4synopsis: Pagination with Servant example

3synopsis: Pagination with Servant 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==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.1

12

12

13executable cookbook-pagination

13executable cookbook-pagination

14 main-is: Pagination.lhs

14 main-is: Pagination.lhs

15 build-tool-depends: markdown-unlit:markdown-unlit

15 build-tool-depends: markdown-unlit:markdown-unlit

16 default-language: Haskell2010

16 default-language: Haskell2010

17 ghc-options: -Wall -pgmL markdown-unlit

17 ghc-options: -Wall -pgmL markdown-unlit

18− build-depends: base >= 4.9 && <5

18+ build-depends: base >= 4.8 && <4.13

19 , aeson

19 , aeson

20 , servant

20 , servant

21 , servant-server

21 , servant-server

doc/cookbook/sentry/Sentry.lhs+2−2

@@ -79,14 +79,14 @@ It does three things. First it initializes the service which will communicate wi

79

79

80- the Sentry `DSN`, which is obtained when creating a new project on Sentry

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

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

82+- an event trasport, which generally would be `sendRecord`, an HTTPS capable trasport which uses http-conduit

83- a fallback handler, which we choose to be `silentFallback` since later we are logging to the console anyway.

83- a fallback handler, which we choose to be `silentFallback` since later we are logging to the console anyway.

84

84

85In the second step it actually sends our message to Sentry with the `register` function. Its arguments are:

85In the second step it actually sends our message to Sentry with the `register` function. Its arguments are:

86

86

87- the configured Sentry service which we just created

87- the configured Sentry service which we just created

88- the name of the logger

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)

89+- the error level (see [SentryLevel](https://hackage.haskell.org/package/raven-haskell-0.1.2.0/docs/System-Log-Raven-Types.html#t:SentryLevel) for the possible options)

90- the message we want to send

90- the message we want to send

91- an update function to handle the specific `SentryRecord`

91- an update function to handle the specific `SentryRecord`

92

92

doc/cookbook/sentry/sentry.cabal+4−4

@@ -1,14 +1,14 @@

1−cabal-version: 2.2

2name: cookbook-sentry

1name: cookbook-sentry

3version: 0.1

2version: 0.1

4synopsis: Collecting runtime exceptions using Sentry

3synopsis: Collecting runtime exceptions using Sentry

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==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.1

12

12

13executable cookbook-sentry

13executable cookbook-sentry

14 main-is: Sentry.lhs

14 main-is: Sentry.lhs

doc/cookbook/structuring-apis/StructuringApis.lhs+1−1

@@ -144,7 +144,7 @@ simpleAPIServer

144 :: m [a]

144 :: m [a]

145 -> (i -> m a)

145 -> (i -> m a)

146 -> (a -> m NoContent)

146 -> (a -> m NoContent)

147− -> ServerT (SimpleAPI name a i) m

147+ -> Server (SimpleAPI name a i) m

148simpleAPIServer listAs getA postA =

148simpleAPIServer listAs getA postA =

149 listAs :<|> getA :<|> postA

149 listAs :<|> getA :<|> postA

150

150

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==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.1

12

12

13executable cookbook-structuring-apis

13executable cookbook-structuring-apis

14 main-is: StructuringApis.lhs

14 main-is: StructuringApis.lhs

doc/cookbook/testing/Testing.lhs+19−20

@@ -41,9 +41,6 @@ This recipe starts with the following ingredients:

41```haskell

41```haskell

42{-# LANGUAGE OverloadedStrings, TypeFamilies, DataKinds,

42{-# LANGUAGE OverloadedStrings, TypeFamilies, DataKinds,

43 DeriveGeneric, TypeOperators #-}

43 DeriveGeneric, TypeOperators #-}

44−import Prelude ()

45−import Prelude.Compat

46−

47import qualified Control.Concurrent as C

44import qualified Control.Concurrent as C

48import Control.Concurrent.MVar

45import Control.Concurrent.MVar

49import Control.Exception (bracket)

46import Control.Exception (bracket)

@@ -51,9 +48,9 @@ import Control.Lens hiding (Context)

51import Data.Aeson

48import Data.Aeson

52import Data.Aeson.Lens

49import Data.Aeson.Lens

53import qualified Data.HashMap.Strict as HM

50import qualified Data.HashMap.Strict as HM

54−import Data.Text (Text, unpack)

51+import Data.Text

55import GHC.Generics

52import GHC.Generics

56−import Network.HTTP.Client hiding (Proxy)

53+import Network.HTTP.Client hiding (Proxy)

57import Network.HTTP.Types

54import Network.HTTP.Types

58import Network.Wai

55import Network.Wai

59import qualified Network.Wai.Handler.Warp as Warp

56import qualified Network.Wai.Handler.Warp as Warp

@@ -142,31 +139,33 @@ of it and see how it responds.

142Let's write some tests:

139Let's write some tests:

143

140

144```haskell

141```haskell

145−withUserApp :: (Warp.Port -> IO ()) -> IO ()

142+withUserApp :: IO () -> IO ()

146withUserApp action =

143withUserApp action =

147− -- testWithApplication makes sure the action is executed after the server has

144+ -- we can spin up a server in another thread and kill that thread when done

148− -- started and is being properly shutdown.

145+ -- in an exception-safe way

149− Warp.testWithApplication (pure userApp) action

146+ bracket (liftIO $ C.forkIO $ Warp.run 8888 userApp)

147+ C.killThread

148+ (const action)

150

149

151

150

152businessLogicSpec :: Spec

151businessLogicSpec :: Spec

153businessLogicSpec =

152businessLogicSpec =

154 -- `around` will start our Server before the tests and turn it off after

153 -- `around` will start our Server before the tests and turn it off after

155− around withUserApp $ do

154+ around_ withUserApp $ do

156 -- create a test client function

155 -- create a test client function

157 let createUser = client (Proxy :: Proxy UserApi)

156 let createUser = client (Proxy :: Proxy UserApi)

158 -- create a servant-client ClientEnv

157 -- create a servant-client ClientEnv

159− baseUrl <- runIO $ parseBaseUrl "http://localhost"

158+ baseUrl <- runIO $ parseBaseUrl "http://localhost:8888"

160 manager <- runIO $ newManager defaultManagerSettings

159 manager <- runIO $ newManager defaultManagerSettings

161− let clientEnv port = mkClientEnv manager (baseUrl { baseUrlPort = port })

160+ let clientEnv = mkClientEnv manager baseUrl

162

161

163 -- testing scenarios start here

162 -- testing scenarios start here

164 describe "POST /user" $ do

163 describe "POST /user" $ do

165− it "should create a user with a high enough ID" $ \port -> do

164+ it "should create a user with a high enough ID" $ do

166− result <- runClientM (createUser 50001) (clientEnv port)

165+ result <- runClientM (createUser 50001) clientEnv

167 result `shouldBe` (Right $ User { name = "some user", user_id = 50001})

166 result `shouldBe` (Right $ User { name = "some user", user_id = 50001})

168− it "will it fail with a too-small ID?" $ \port -> do

167+ it "will it fail with a too-small ID?" $ do

169− result <- runClientM (createUser 4999) (clientEnv port)

168+ result <- runClientM (createUser 4999) clientEnv

170 result `shouldBe` (Right $ User { name = "some user", user_id = 50001})

169 result `shouldBe` (Right $ User { name = "some user", user_id = 50001})

171```

170```

172

171

@@ -232,7 +231,7 @@ clientEnv esHost esPort = do

232 manager <- newManager defaultManagerSettings

231 manager <- newManager defaultManagerSettings

233 pure $ mkClientEnv manager baseUrl

232 pure $ mkClientEnv manager baseUrl

234

233

235−runSearchClient :: Text -> Text -> ClientM a -> IO (Either ClientError a)

234+runSearchClient :: Text -> Text -> ClientM a -> IO (Either ServantError a)

236runSearchClient esHost esPort = (clientEnv esHost esPort >>=) . runClientM

235runSearchClient esHost esPort = (clientEnv esHost esPort >>=) . runClientM

237```

236```

238

237

@@ -265,7 +264,7 @@ docServer esHost esPort = getDocById esHost esPort

265-- actions

264-- actions

266getDocById :: Text -> Text -> Integer -> Handler Value

265getDocById :: Text -> Text -> Integer -> Handler Value

267getDocById esHost esPort docId = do

266getDocById esHost esPort docId = do

268− -- Our Servant Client function returns Either ClientError Value here:

267+ -- Our Servant Client function returns Either ServantError Value here:

269 docRes <- liftIO $ runSearchClient esHost esPort (getDocument docId)

268 docRes <- liftIO $ runSearchClient esHost esPort (getDocument docId)

270 case docRes of

269 case docRes of

271 Left err -> throwError $ err404 { errBody = "Failed looking up content" }

270 Left err -> throwError $ err404 { errBody = "Failed looking up content" }

@@ -408,7 +407,7 @@ server :: IO (Server API)

408server = do

407server = do

409 mvar <- newMVar ""

408 mvar <- newMVar ""

410 return $ (\x -> liftIO $ swapMVar mvar x)

409 return $ (\x -> liftIO $ swapMVar mvar x)

411− :<|> (liftIO $ readMVar mvar >>= return . length)

410+ :<|> (liftIO $ readMVar mvar >>= return . Prelude.length)

412 :<|> (const $ return ())

411 :<|> (const $ return ())

413```

412```

414

413

@@ -503,4 +502,4 @@ Lastly, if you want a broad overview of where your application fits in with

503regard to best practices, consider using `servant-quickcheck`.

502regard to best practices, consider using `servant-quickcheck`.

504

503

505This program is available as a cabal project

504This program is available as a cabal project

506−[here](https://github.com/haskell-servant/servant/tree/master/doc/cookbook/testing).

505+[here](https://github.com/haskell-servant/servant/tree/master/doc/cookbook/testing).

doc/cookbook/testing/testing.cabal+5−6

@@ -1,21 +1,20 @@

1−cabal-version: 2.2

2name: cookbook-testing

1name: cookbook-testing

3version: 0.0.1

2version: 0.0.1

4synopsis: Common testing patterns in Servant apps

3synopsis: Common testing patterns in Servant apps

5description: This recipe includes various strategies for writing tests for Servant.

4description: This recipe includes various strategies for writing tests for Servant.

6−homepage: http://docs.servant.dev/

5+homepage: http://haskell-servant.readthedocs.org/

7−license: BSD-3-Clause

6+license: BSD3

8license-file: ../../../servant/LICENSE

7license-file: ../../../servant/LICENSE

9author: Servant Contributors

8author: Servant Contributors

10maintainer: haskell-servant-maintainers@googlegroups.com

9maintainer: haskell-servant-maintainers@googlegroups.com

11category: Servant

10category: Servant

12build-type: Simple

11build-type: Simple

12+cabal-version: >=1.10

13−tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7

13+tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.1

14

14

15executable cookbook-testing

15executable cookbook-testing

16 main-is: Testing.lhs

16 main-is: Testing.lhs

17 build-depends: base == 4.*

17 build-depends: base == 4.*

18− , base-compat

19 , text >= 1.2

18 , text >= 1.2

20 , aeson >= 1.2

19 , aeson >= 1.2

21 , lens-aeson

20 , lens-aeson

@@ -23,7 +22,7 @@ executable cookbook-testing

23 , servant

22 , servant

24 , servant-client

23 , servant-client

25 , servant-server

24 , servant-server

26− , servant-quickcheck >= 0.0.10

25+ , servant-quickcheck

27 , http-client

26 , http-client

28 , http-types >= 0.12

27 , http-types >= 0.12

29 , hspec

28 , hspec

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==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.1

12

12

13executable cookbook-using-custom-monad

13executable cookbook-using-custom-monad

14 main-is: UsingCustomMonad.lhs

14 main-is: UsingCustomMonad.lhs

doc/cookbook/using-free-client/UsingFreeClient.lhs+9−7

@@ -2,7 +2,7 @@

2

2

3or simply put: _a practical introduction to `Servant.Client.Free`_.

3or simply put: _a practical introduction to `Servant.Client.Free`_.

4

4

5−Someone asked on IRC how one could access the intermediate Requests (resp. Responses)

5+Someone asked on IRC how one could access the intermediate Requests (resp. Responses)

6produced (resp. received) by client functions derived using servant-client.

6produced (resp. received) by client functions derived using servant-client.

7My response to such inquiries is: to extend `servant-client` in an ad-hoc way (e.g for testing or debugging

7My response to such inquiries is: to extend `servant-client` in an ad-hoc way (e.g for testing or debugging

8purposes), use `Servant.Client.Free`. This recipe shows how.

8purposes), use `Servant.Client.Free`. This recipe shows how.

@@ -99,6 +99,8 @@ test = case getSquare 42 of

99 putStrLn $ "ERROR: got pure result: " ++ show n

99 putStrLn $ "ERROR: got pure result: " ++ show n

100 Free (Throw err) ->

100 Free (Throw err) ->

101 putStrLn $ "ERROR: got error right away: " ++ show err

101 putStrLn $ "ERROR: got error right away: " ++ show err

102+ Free (StreamingRequest _req _k) ->

103+ putStrLn $ "ERROR: need to do streaming request" -- TODO: no Show Req :(

102```

104```

103

105

104We are interested in `RunRequest`, that's what client should block on:

106We are interested in `RunRequest`, that's what client should block on:

@@ -119,7 +121,7 @@ Now we can use `servant-client`'s internals to convert servant's `Request`

119to http-client's `Request`, and we can inspect it:

121to http-client's `Request`, and we can inspect it:

120

122

121```haskell

123```haskell

122− req' <- I.defaultMakeClientRequest burl req

124+ let req' = I.requestToClientRequest burl req

123 putStrLn $ "Making request: " ++ show req'

125 putStrLn $ "Making request: " ++ show req'

124```

126```

125

127

@@ -135,13 +137,13 @@ And we continue by turning http-client's `Response` into servant's `Response`,

135and calling the continuation. We should get a `Pure` value.

137and calling the continuation. We should get a `Pure` value.

136

138

137```haskell

139```haskell

138− let res = I.clientResponseToResponse id res'

140+ let res = I.clientResponseToResponse res'

139−

141+

140 case k res of

142 case k res of

141 Pure n ->

143 Pure n ->

142 putStrLn $ "Expected 1764, got " ++ show n

144 putStrLn $ "Expected 1764, got " ++ show n

143− _ ->

145+ _ ->

144− putStrLn "ERROR: didn't get a response"

146+ putStrLn "ERROR: didn't got a response"

145```

147```

146

148

147So that's it. Using `Free` we can evaluate servant clients step-by-step, and

149So that's it. Using `Free` we can evaluate servant clients step-by-step, and

@@ -153,7 +155,7 @@ and responses available for us to inspect, since `RunClient` only gives us

153access to one `Request` or `Response` at a time.

155access to one `Request` or `Response` at a time.

154

156

155On the other hand, a "batch collection" of requests and/or responses can be achieved

157On the other hand, a "batch collection" of requests and/or responses can be achieved

156−with both free clients and a custom `RunClient` instance rather easily, for example

158+with both free clients and a custom `RunClient` instance rather easily, for example

157by using a `Writer [(Request, Response)]` monad.

159by using a `Writer [(Request, Response)]` monad.

158

160

159Here is an example of running our small `test` against a running server:

161Here is an example of running our small `test` against a running server:

doc/cookbook/using-free-client/using-free-client.cabal+4−4

@@ -1,14 +1,14 @@

1−cabal-version: 2.2

2name: cookbook-using-free-client

1name: cookbook-using-free-client

3version: 0.1

2version: 0.1

4synopsis: Using Free client

3synopsis: Using Free client

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==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.1

12

12

13executable cookbook-using-free-client

13executable cookbook-using-free-client

14 main-is: UsingFreeClient.lhs

14 main-is: UsingFreeClient.lhs

doc/cookbook/uverb/UVerb.lhsdeleted−223

@@ -1,223 +0,0 @@

1−# Listing alternative responses and exceptions in your API types

2−

3−Servant allows you to talk about the exceptions you throw in your API

4−types. This is not limited to actual exceptions, you can write

5−handlers that respond with arbitrary open unions of types.

6−

7−## Compatibility

8−

9−:warning: This cookbook is compatible with GHC 8.6.1 or higher :warning:

10−

11−## Preliminaries

12−

13−```haskell

14−{-# LANGUAGE ConstraintKinds #-}

15−{-# LANGUAGE DataKinds #-}

16−{-# LANGUAGE DeriveGeneric #-}

17−{-# LANGUAGE DerivingStrategies #-}

18−{-# LANGUAGE DeriveAnyClass #-}

19−{-# LANGUAGE DerivingVia #-}

20−{-# LANGUAGE FlexibleContexts #-}

21−{-# LANGUAGE FlexibleInstances #-}

22−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

23−{-# LANGUAGE InstanceSigs #-}

24−{-# LANGUAGE MultiParamTypeClasses #-}

25−{-# LANGUAGE OverloadedStrings #-}

26−{-# LANGUAGE ScopedTypeVariables #-}

27−{-# LANGUAGE StandaloneDeriving #-}

28−{-# LANGUAGE TypeApplications #-}

29−{-# LANGUAGE TypeFamilies #-}

30−{-# LANGUAGE TypeOperators #-}

31−{-# LANGUAGE UndecidableInstances #-}

32−{-# OPTIONS_GHC -Wall -Wno-orphans #-}

33−

34−import Control.Concurrent (threadDelay)

35−import Control.Concurrent.Async (async)

36−import Control.Monad (when)

37−import Control.Monad.Except (ExceptT (..), MonadError (..), MonadTrans (..), runExceptT)

38−import Data.Aeson (FromJSON (..), ToJSON (..))

39−import Data.Aeson.Encode.Pretty (encodePretty)

40−import Data.String.Conversions (cs)

41−import Data.Swagger (ToSchema)

42−import Data.Typeable (Proxy (Proxy))

43−import qualified GHC.Generics as GHC

44−import qualified Network.HTTP.Client as Client

45−import qualified Network.Wai.Handler.Warp as Warp

46−import Servant.API

47−import Servant.Client

48−import Servant.Server

49−import Servant.Swagger

50−```

51−

52−## The API

53−

54−This looks like a `Verb`-based routing table, except that `UVerb` has

55−no status, and carries a list of response types rather than a single

56−one. Each entry in the list carries its own response code.

57−

58−```haskell

59−type API =

60− "fisx" :> Capture "bool" Bool

61− :> UVerb 'GET '[JSON] '[FisxUser, WithStatus 303 String]

62− :<|> "arian"

63− :> UVerb 'GET '[JSON] '[WithStatus 201 ArianUser]

64−```

65−

66−Here are the details:

67−

68−```haskell

69−data FisxUser = FisxUser {name :: String}

70− deriving (Eq, Show, GHC.Generic)

71−

72−instance ToJSON FisxUser

73−instance FromJSON FisxUser

74−instance ToSchema FisxUser

75−

76−-- | 'HasStatus' allows us to can get around 'WithStatus' if we want

77−-- to, and associate the status code with our resource types directly.

78−--

79−-- (To avoid orphan instances and make it more explicit what's in the

80−-- API and what isn't, we could even introduce a newtype 'Resource'

81−-- that wraps all the types we're using in our routing table, and then

82−-- define lots of 'HasStatus' instances for @Resource This@ and

83−-- @Resource That@.)

84−instance HasStatus FisxUser where

85− type StatusOf FisxUser = 203

86−

87−data ArianUser = ArianUser

88− deriving (Eq, Show, GHC.Generic)

89−

90−instance ToJSON ArianUser

91−instance FromJSON ArianUser

92−instance ToSchema ArianUser

93−```

94−

95−## Server, Client, Swagger

96−

97−You can just respond with any of the elements of the union in handlers.

98−

99−```haskell

100−fisx :: Bool -> Handler (Union '[FisxUser, WithStatus 303 String])

101−fisx True = respond (FisxUser "fisx")

102−fisx False = respond (WithStatus @303 ("still fisx" :: String))

103−

104−arian :: Handler (Union '[WithStatus 201 ArianUser])

105−arian = respond (WithStatus @201 ArianUser)

106−```

107−

108−You can create client functions like you're used to:

109−

110−```

111−fisxClient :: Bool -> ClientM (Union '[FisxUser, WithStatus 303 String])

112−arianClient :: ClientM (Union '[WithStatus 201 ArianUser])

113−(fisxClient :<|> arianClient) = client (Proxy @API)

114−```

115−

116−... and that's basically it! Here are a few sample commands that

117−show you how the swagger docs look like and how you can handle the

118−result unions in clients:

119−

120−```

121−main :: IO ()

122−main = do

123− putStrLn . cs . encodePretty $ toSwagger (Proxy @API)

124− _ <- async . Warp.run 8080 $ serve (Proxy @API) (fisx :<|> arian)

125− threadDelay 50000

126− mgr <- Client.newManager Client.defaultManagerSettings

127− let cenv = mkClientEnv mgr (BaseUrl Http "localhost" 8080 "")

128− result <- runClientM (fisxClient True) cenv

129− print $ foldMapUnion (Proxy @Show) show <$> result

130− print $ matchUnion @FisxUser <$> result

131− print $ matchUnion @(WithStatus 303 String) <$> result

132− pure ()

133−```

134−

135−## Idiomatic exceptions

136−

137−Since `UVerb` (probably) will mostly be used for error-like responses, it may be desirable to be able to early abort handler, like with current servant one would use `throwError` with `ServerError`.

138−

139−```haskell

140−newtype UVerbT xs m a = UVerbT { unUVerbT :: ExceptT (Union xs) m a }

141− deriving (Functor, Applicative, Monad, MonadTrans)

142−

143−-- | Deliberately hide 'ExceptT's 'MonadError' instance to be able to use

144−-- underlying monad's instance.

145−instance MonadError e m => MonadError e (UVerbT xs m) where

146− throwError = lift . throwError

147− catchError (UVerbT act) h = UVerbT $ ExceptT $

148− runExceptT act `catchError` (runExceptT . unUVerbT . h)

149−

150−-- | This combinator runs 'UVerbT'. It applies 'respond' internally, so the handler

151−-- may use the usual 'return'.

152−runUVerbT :: (Monad m, HasStatus x, IsMember x xs) => UVerbT xs m x -> m (Union xs)

153−runUVerbT (UVerbT act) = either id id <$> runExceptT (act >>= respond)

154−

155−-- | Short-circuit 'UVerbT' computation returning one of the response types.

156−throwUVerb :: (Monad m, HasStatus x, IsMember x xs) => x -> UVerbT xs m a

157−throwUVerb = UVerbT . ExceptT . fmap Left . respond

158−```

159−

160−Example usage:

161−

162−```haskell

163−data Foo = Foo Int Int Int

164− deriving (Show, Eq, GHC.Generic, ToJSON)

165− deriving HasStatus via WithStatus 200 Foo

166−

167−data Bar = Bar

168− deriving (Show, Eq, GHC.Generic)

169−

170−instance ToJSON Bar

171−

172−h :: Handler (Union '[Foo, WithStatus 400 Bar])

173−h = runUVerbT $ do

174− when ({- something bad -} True) $

175− throwUVerb $ WithStatus @400 Bar

176−

177− when ({- really bad -} False) $

178− throwError $ err500

179−

180− -- a lot of code here...

181−

182− return $ Foo 1 2 3

183−```

184−

185−## Related Work

186−

187−There is the [issue from

188−2017](https://github.com/haskell-servant/servant/issues/841) that was

189−resolved by the introduction of `UVerb`, with a long discussion on

190−alternative designs.

191−

192−[servant-checked-exceptions](https://hackage.haskell.org/package/servant-checked-exceptions)

193−is a good solution to the problem, but it restricts the user to JSON

194−and a very specific envelop encoding for the union type, which is

195−often not acceptable. (One good reason for this design choice is that

196−it makes writing clients easier, where you need to get to the union

197−type from one representative, and you don't want to run several

198−parsers in the hope that the ones that should will always error out so

199−you can try until the right one returns a value.)

200−

201−[servant-exceptions](https://github.com/ch1bo/servant-exceptions) is

202−another shot at the problem. It is inspired by

203−servant-checked-exceptions, so it may be worth taking a closer look.

204−The README claims that

205−[cardano-sl](https://github.com/input-output-hk/cardano-sl) also has

206−some code for generalized error handling.

207−

208−In an earier version of the `UVerb` implementation, we have used some

209−code from

210−[world-peace](https://hackage.haskell.org/package/world-peace), but

211−that package itself wasn't flexible enough, and we had to use

212−[sop-core](https://hackage.haskell.org/package/sop-core) to implement

213−the `HasServer` instance.

214−

215−Here is a blog post we found on the subject:

216−https://lukwagoallan.com/posts/unifying-servant-server-error-responses

217−

218−(If you have anything else, please add it here or let us know.)

219−

220−```haskell

221−main :: IO ()

222−main = return ()

223−```

doc/cookbook/uverb/uverb.cabaldeleted−35

@@ -1,35 +0,0 @@

1−cabal-version: 2.2

2−name: cookbook-uverb

3−version: 0.0.1

4−synopsis: How to use the 'UVerb' type.

5−description: Listing alternative responses and exceptions in your API types.

6−homepage: http://docs.servant.dev/

7−license: BSD-3-Clause

8−license-file: ../../../servant/LICENSE

9−author: Servant Contributors

10−maintainer: haskell-servant-maintainers@googlegroups.com

11−category: Servant

12−build-type: Simple

13−tested-with: GHC==8.6.5, GHC==8.8.4, GHC==8.10.7

14−

15−executable cookbook-uverb

16− main-is: UVerb.lhs

17− build-depends: base == 4.*

18− , aeson >= 1.2

19− , aeson-pretty >= 0.8.8

20− , async

21− , http-client

22− , mtl

23− , servant

24− , servant-client

25− , servant-server

26− , servant-swagger

27− , string-conversions

28− , swagger2

29− , wai

30− , warp

31− if impl(ghc >= 9)

32− buildable: False

33− default-language: Haskell2010

34− ghc-options: -Wall -pgmL markdown-unlit

35− build-tool-depends: markdown-unlit:markdown-unlit

doc/examples.md+1−1

@@ -8,7 +8,7 @@

8

8

9- **[servant-examples](https://github.com/sras/servant-examples)**:

9- **[servant-examples](https://github.com/sras/servant-examples)**:

10

10

11− Similar to [the cookbook](https://docs.servant.dev/en/latest/cookbook/index.html) but

11+ Similar to [the cookbook](https://haskell-servant.readthedocs.io/en/latest/cookbook/index.html) but

12 with no explanations, for developers who just want to look at code examples to find out how to do X or Y

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.

13 with servant.

14

14

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+3−4

@@ -1,4 +1,3 @@

1−recommonmark==0.5.0

1+recommonmark==0.4.0

2−Sphinx==1.8.4

2+Sphinx==1.7.5

3−sphinx_rtd_theme>=0.4.2

3+sphinx_rtd_theme>=0.4.0

4−jinja2<3.1.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 delineated from one another in the stream. The three standard strategies given with Servant are `NewlineFraming`, `NetstringFraming` and `NoFraming`, but others can be written to match other protocols.

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−10

@@ -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`).

doc/tutorial/Client.lhs+26−26

@@ -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:

@@ -161,7 +158,7 @@ The types of the arguments for the functions are the same as for (server-side) r

161## Changing the monad the client functions live in

158## Changing the monad the client functions live in

162

159

163Just like `hoistServer` allows us to change the monad in which request handlers

160Just like `hoistServer` allows us to change the monad in which request handlers

164−of a web application live, we also have `hoistClient` for changing the monad

161+of a web application live in, we also have `hoistClient` for changing the monad

165in which _client functions_ live. Consider the following trivial API:

162in which _client functions_ live. Consider the following trivial API:

166

163

167``` haskell

164``` haskell

@@ -173,7 +170,7 @@ hoistClientAPI = Proxy

173

170

174We already know how to derive client functions for this API, and as we have

171We already know how to derive client functions for this API, and as we have

175seen above they all return results in the `ClientM` monad when using `servant-client`.

172seen above they all return results in the `ClientM` monad when using `servant-client`.

176−However, `ClientM` is rarely (or never) the actual monad we need to use the client

173+However, `ClientM` rarely (or never) is the actual monad we need to use the client

177functions in. Sometimes we need to run them in IO, sometimes in a custom monad

174functions in. Sometimes we need to run them in IO, sometimes in a custom monad

178stack. `hoistClient` is a very simple solution to the problem of "changing" the monad

175stack. `hoistClient` is a very simple solution to the problem of "changing" the monad

179the clients run in.

176the clients run in.

@@ -220,38 +217,41 @@ getClients clientEnv

220Consider the following streaming API type:

217Consider the following streaming API type:

221

218

222``` haskell

219``` haskell

223−type StreamAPI = "positionStream" :> StreamGet NewlineFraming JSON (SourceIO Position)

220+type StreamAPI = "positionStream" :> StreamGet NewlineFraming JSON (ResultStream Position)

224```

221```

225

222

226−Note that we use the same `SourceIO` type as on the server-side

223+Note that when we declared an API to serve, we specified a `StreamGenerator` as a producer of streams. Now we specify our result type as a `ResultStream`. With types that can be used both ways, if appropriate adaptors are written (in the form of `ToStreamGenerator` and `BuildFromStream` instances), then this asymmetry isn't necessary. Otherwise, if you want to share the same API across clients and servers, you can parameterize it like so:

227−(this is different from `servant-0.14`).

224+

228−However, we have to use different client, `Servant.Client.Streaming`,

225+``` haskell ignore

229−which can stream (but has different API).

226+type StreamAPI f = "positionStream" :> StreamGet NewlineFraming JSON (f Position)

227+type ServerStreamAPI = StreamAPI StreamGenerator

228+type ClientStreamAPI = StreamAPI ResultStream

229+```

230

230

231In any case, here's how we write a function to query our API:

231In any case, here's how we write a function to query our API:

232

232

233−```haskell

233+``` haskell

234streamAPI :: Proxy StreamAPI

234streamAPI :: Proxy StreamAPI

235streamAPI = Proxy

235streamAPI = Proxy

236

236

237−posStream :: S.ClientM (SourceIO Position)

237+posStream :: ClientM (ResultStream Position)

238+

238−posStream = S.client streamAPI

239+posStream = client streamAPI

239```

240```

240

241

241−We'll get back a `SourceIO Position`. Instead of `runClientM`, the streaming

242−client provides `withClientM`: the underlying HTTP connection is open only

243−until the inner functions exits. Inside the block we can e.g just print out

244−all elements from a `SourceIO`, to give some idea of how to work with them.

242+And here's how to just print out all elements from a `ResultStream`, to give some idea of how to work with them.

245

243

246``` haskell

244``` haskell

247−printSourceIO :: Show a => ClientEnv -> S.ClientM (SourceIO a) -> IO ()

245+printResultStream :: Show a => ResultStream a -> IO ()

248−printSourceIO env c = S.withClientM c env $ \e -> case e of

246+printResultStream (ResultStream k) = k $ \getResult ->

249− Left err -> putStrLn $ "Error: " ++ show err

247+ let loop = do

250− Right rs -> foreach fail print rs

248+ r <- getResult

249+ case r of

250+ Nothing -> return ()

251+ Just x -> print x >> loop

252+ in loop

251```

253```

252

254

253−The stream is parsed and provided incrementally. So the above loop prints out

255+The stream is parsed and provided incrementally. So the above loop prints out each result as soon as it is received on the stream, rather than waiting until they are all available to print them at once.

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

256

257You now know how to use **servant-client**!

257You 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+2−2

@@ -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

doc/tutorial/Server.lhs+41−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```

@@ -183,7 +182,7 @@ users2 = [isaac, albert]

183

182

184Now, just like we separate the various endpoints in `UserAPI` with `:<|>`, we

183Now, just like we separate the various endpoints in `UserAPI` with `:<|>`, we

185are going to separate the handlers with `:<|>` too! They must be provided in

184are going to separate the handlers with `:<|>` too! They must be provided in

186−the same order as in the API type.

185+the same order as in in the API type.

187

186

188``` haskell

187``` haskell

189server2 :: Server UserAPI2

188server2 :: Server UserAPI2

@@ -313,8 +312,8 @@ For reference, here's a list of some combinators from **servant**:

313## The `FromHttpApiData`/`ToHttpApiData` classes

312## The `FromHttpApiData`/`ToHttpApiData` classes

314

313

315Wait... How does **servant** know how to decode the `Int`s from the URL? Or how

314Wait... 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

315+to decode a `ClientInfo` value from the request body? This is what this and the

317−help us answer these questions.

316+following two sections address.

318

317

319`Capture`s and `QueryParam`s are represented by some textual value in URLs.

318`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

319`Header`s are similarly represented by a pair of a header name and a

@@ -599,7 +598,7 @@ $ curl -H 'Accept: text/html' http://localhost:8081/persons

599

598

600## The `Handler` monad

599## The `Handler` monad

601

600

602−At the heart of the handlers is the monad they run in, namely a newtype `Handler` around `ExceptT ServerError IO`

601+At the heart of the handlers is the monad they run in, namely a newtype `Handler` around `ExceptT ServantErr IO`

603([haddock documentation for `ExceptT`](http://hackage.haskell.org/package/mtl-2.2.1/docs/Control-Monad-Except.html#t:ExceptT)).

602([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

603One might wonder: why this monad? The answer is that it is the

605simplest monad with the following properties:

604simplest monad with the following properties:

@@ -617,12 +616,12 @@ newtype ExceptT e m a = ExceptT (m (Either e a))

617```

616```

618

617

619In short, this means that a handler of type `Handler a` is simply

618In short, this means that a handler of type `Handler a` is simply

620−equivalent to a computation of type `IO (Either ServerError a)`, that is, an IO

619+equivalent to a computation of type `IO (Either ServantErr a)`, that is, an IO

621action that either returns an error or a result.

620action that either returns an error or a result.

622

621

623−The module [`Control.Monad.Except`](https://hackage.haskell.org/package/mtl/docs/Control-Monad-Except.html#t:ExceptT)

622+The module [`Control.Monad.Except`](https://hackage.haskell.org/package/mtl-2.2.1/docs/Control-Monad-Except.html#t:ExceptT)

624from which `ExceptT` comes is worth looking at.

623from which `ExceptT` comes is worth looking at.

625−Perhaps most importantly, `ExceptT` and `Handler` are instances of `MonadError`, so

624+Perhaps most importantly, `ExceptT` and `Handler` are an instances of `MonadError`, so

626`throwError` can be used to return an error from your handler (whereas `return`

625`throwError` can be used to return an error from your handler (whereas `return`

627 is enough to return a success).

626 is enough to return a success).

628

627

@@ -632,9 +631,9 @@ kind and abort early. The next two sections cover how to do just that.

632

631

633### Performing IO

632### Performing IO

634

633

635−Other important instances from the list above are `MonadIO m => MonadIO

634+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.

635+(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)

636+[`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:

637is a class from the **transformers** package defined as:

639

638

640``` haskell ignore

639``` haskell ignore

@@ -660,16 +659,16 @@ server5 = do

660 return (FileContent filecontent)

659 return (FileContent filecontent)

661```

660```

662

661

663−### Failing, through `ServerError`

662+### Failing, through `ServantErr`

664

663

665If you want to explicitly fail at providing the result promised by an endpoint

664If 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

665using 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

666error message, all you have to do is use the `throwError` function mentioned above

668−and provide it with the appropriate value of type `ServerError`, which is

667+and provide it with the appropriate value of type `ServantErr`, which is

669defined as:

668defined as:

670

669

671``` haskell ignore

670``` haskell ignore

672−data ServerError = ServerError

671+data ServantErr = ServantErr

673 { errHTTPCode :: Int

672 { errHTTPCode :: Int

674 , errReasonPhrase :: String

673 , errReasonPhrase :: String

675 , errBody :: ByteString -- lazy bytestring

674 , errBody :: ByteString -- lazy bytestring

@@ -685,7 +684,7 @@ use record update syntax:

685failingHandler :: Handler ()

684failingHandler :: Handler ()

686failingHandler = throwError myerr

685failingHandler = throwError myerr

687

686

688− where myerr :: ServerError

687+ where myerr :: ServantErr

689 myerr = err503 { errBody = "Sorry dear user." }

688 myerr = err503 { errBody = "Sorry dear user." }

690```

689```

691

690

@@ -716,7 +715,7 @@ $ curl --verbose http://localhost:8081/myfile.txt

716>

715>

717< HTTP/1.1 404 Not Found

716< HTTP/1.1 404 Not Found

718[snip]

717[snip]

719−myfile.txt just isn't there, please leave this server alone.

718+myfile.txt just isnt there, please leave this server alone.

720

719

721$ echo Hello > myfile.txt

720$ echo Hello > myfile.txt

722

721

@@ -818,7 +817,7 @@ If it doesn't exist, the handler will fail with a `404` status code.

818

817

819`serveDirectoryWebApp` uses some standard settings that fit the use case of

818`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

819serving static files for most web apps. You can find out about the other

821−options in the documentation of the `Servant.Server.StaticFiles` module.

820+options in the documentation of the `Servant.Utils.StaticFiles` module.

822

821

823## Nested APIs

822## Nested APIs

824

823

@@ -830,7 +829,7 @@ type UserAPI3 = -- view the user with given userid, in JSON

830 Capture "userid" Int :> Get '[JSON] User

829 Capture "userid" Int :> Get '[JSON] User

831

830

832 :<|> -- delete the user with given userid. empty response

831 :<|> -- delete the user with given userid. empty response

833− Capture "userid" Int :> DeleteNoContent

832+ Capture "userid" Int :> DeleteNoContent '[JSON] NoContent

834```

833```

835

834

836We can instead factor out the `userid`:

835We can instead factor out the `userid`:

@@ -838,7 +837,7 @@ We can instead factor out the `userid`:

838``` haskell

837``` haskell

839type UserAPI4 = Capture "userid" Int :>

838type UserAPI4 = Capture "userid" Int :>

840 ( Get '[JSON] User

839 ( Get '[JSON] User

841− :<|> DeleteNoContent

840+ :<|> DeleteNoContent '[JSON] NoContent

842 )

841 )

843```

842```

844

843

@@ -896,13 +895,13 @@ type API1 = "users" :>

896-- we factor out the Request Body

895-- we factor out the Request Body

897type API2 = ReqBody '[JSON] User :>

896type API2 = ReqBody '[JSON] User :>

898 ( Get '[JSON] User -- just display the same user back, don't register it

897 ( Get '[JSON] User -- just display the same user back, don't register it

899− :<|> PostNoContent -- register the user. empty response

898+ :<|> PostNoContent '[JSON] NoContent -- register the user. empty response

900 )

899 )

901

900

902-- we factor out a Header

901-- we factor out a Header

903type API3 = Header "Authorization" Token :>

902type API3 = Header "Authorization" Token :>

904 ( Get '[JSON] SecretData -- get some secret data, if authorized

903 ( Get '[JSON] SecretData -- get some secret data, if authorized

905− :<|> ReqBody '[JSON] SecretData :> PostNoContent -- add some secret data, if authorized

904+ :<|> ReqBody '[JSON] SecretData :> PostNoContent '[JSON] NoContent -- add some secret data, if authorized

906 )

905 )

907

906

908newtype Token = Token ByteString

907newtype Token = Token ByteString

@@ -915,11 +914,11 @@ API type only at the end.

915``` haskell

914``` haskell

916type UsersAPI =

915type UsersAPI =

917 Get '[JSON] [User] -- list users

916 Get '[JSON] [User] -- list users

918− :<|> ReqBody '[JSON] User :> PostNoContent -- add a user

917+ :<|> ReqBody '[JSON] User :> PostNoContent '[JSON] NoContent -- add a user

919 :<|> Capture "userid" Int :>

918 :<|> Capture "userid" Int :>

920 ( Get '[JSON] User -- view a user

919 ( Get '[JSON] User -- view a user

921− :<|> ReqBody '[JSON] User :> PutNoContent -- update a user

920+ :<|> ReqBody '[JSON] User :> PutNoContent '[JSON] NoContent -- update a user

922− :<|> DeleteNoContent -- delete a user

921+ :<|> DeleteNoContent '[JSON] NoContent -- delete a user

923 )

922 )

924

923

925usersServer :: Server UsersAPI

924usersServer :: Server UsersAPI

@@ -948,11 +947,11 @@ usersServer = getUsers :<|> newUser :<|> userOperations

948``` haskell

947``` haskell

949type ProductsAPI =

948type ProductsAPI =

950 Get '[JSON] [Product] -- list products

949 Get '[JSON] [Product] -- list products

951− :<|> ReqBody '[JSON] Product :> PostNoContent -- add a product

950+ :<|> ReqBody '[JSON] Product :> PostNoContent '[JSON] NoContent -- add a product

952 :<|> Capture "productid" Int :>

951 :<|> Capture "productid" Int :>

953 ( Get '[JSON] Product -- view a product

952 ( Get '[JSON] Product -- view a product

954− :<|> ReqBody '[JSON] Product :> PutNoContent -- update a product

953+ :<|> ReqBody '[JSON] Product :> PutNoContent '[JSON] NoContent -- update a product

955− :<|> DeleteNoContent -- delete a product

954+ :<|> DeleteNoContent '[JSON] NoContent -- delete a product

956 )

955 )

957

956

958data Product = Product { productId :: Int }

957data Product = Product { productId :: Int }

@@ -996,11 +995,11 @@ abstract that away:

996-- indexed by values of type 'i'

995-- indexed by values of type 'i'

997type APIFor a i =

996type APIFor a i =

998 Get '[JSON] [a] -- list 'a's

997 Get '[JSON] [a] -- list 'a's

999− :<|> ReqBody '[JSON] a :> PostNoContent -- add an 'a'

998+ :<|> ReqBody '[JSON] a :> PostNoContent '[JSON] NoContent -- add an 'a'

1000 :<|> Capture "id" i :>

999 :<|> Capture "id" i :>

1001 ( Get '[JSON] a -- view an 'a' given its "identifier" of type 'i'

1000 ( Get '[JSON] a -- view an 'a' given its "identifier" of type 'i'

1002− :<|> ReqBody '[JSON] a :> PutNoContent -- update an 'a'

1001+ :<|> ReqBody '[JSON] a :> PutNoContent '[JSON] NoContent -- update an 'a'

1003− :<|> DeleteNoContent -- delete an 'a'

1002+ :<|> DeleteNoContent '[JSON] NoContent -- delete an 'a'

1004 )

1003 )

1005

1004

1006-- Build the appropriate 'Server'

1005-- Build the appropriate 'Server'

@@ -1128,14 +1127,14 @@ This is the webservice in action:

1128``` bash

1127``` bash

1129$ curl http://localhost:8081/a

1128$ curl http://localhost:8081/a

11301797

11291797

1131−$ curl http://localhost:8081/b -X GET -d '42.0' -H 'Content-Type: application/json'

1130+$ curl http://localhost:8081/b

1132−true

1131+"hi"

1133```

1132```

1134

1133

1135### An arrow is a reader too.

1134### An arrow is a reader too.

1136

1135

1137In previous versions of `servant` we had an `enter` to do what `hoistServer`

1136In previous versions of `servant` we had an `enter` to do what `hoistServer`

1138−does now. `enter` had an ambitious design goals, but was problematic in practice.

1137+does now. `enter` had a ambitious design goals, but was problematic in practice.

1139

1138

1140One problematic situation was when the source monad was `(->) r`, yet it's

1139One problematic situation was when the source monad was `(->) r`, yet it's

1141handy in practice, because `(->) r` is isomorphic to `Reader r`.

1140handy in practice, because `(->) r` is isomorphic to `Reader r`.

@@ -1161,37 +1160,24 @@ app5 = serve readerAPI (hoistServer readerAPI funToHandler funServerT)

1161

1160

1162## Streaming endpoints

1161## Streaming endpoints

1163

1162

1164−We can create endpoints that don't just give back a single result, but give

1163+We can create endpoints that don't just give back a single result, but give back a *stream* of results, served one at a time. Stream endpoints only provide a single content type, and also specify what framing strategy is used to delineate the results. To serve these results, we need to give back a stream producer. Adapters can be written to `Pipes`, `Conduit` and the like, or written directly as `StreamGenerator`s. StreamGenerators are IO-based continuations that are handed two functions -- the first to write the first result back, and the second to write all subsequent results back. (This is to allow handling of situations where the entire stream is prefixed by a header, or where a boundary is written between elements, but not prior to the first element). The API of a streaming endpoint needs to explicitly specify which sort of generator it produces. Note that the generator itself is returned by a `Handler` action, so that additional IO may be done in the creation of one.

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

1164

1175``` haskell

1165``` haskell

1176−type StreamAPI = "userStream" :> StreamGet NewlineFraming JSON (SourceIO User)

1166+type StreamAPI = "userStream" :> StreamGet NewlineFraming JSON (StreamGenerator User)

1177streamAPI :: Proxy StreamAPI

1167streamAPI :: Proxy StreamAPI

1178streamAPI = Proxy

1168streamAPI = Proxy

1179

1169

1180−streamUsers :: SourceIO User

1170+streamUsers :: StreamGenerator User

1181−streamUsers = source [isaac, albert, albert]

1171+streamUsers = StreamGenerator $ \sendFirst sendRest -> do

1172+ sendFirst isaac

1173+ sendRest albert

1174+ sendRest albert

1182

1175

1183app6 :: Application

1176app6 :: Application

1184app6 = serve streamAPI (return streamUsers)

1177app6 = serve streamAPI (return streamUsers)

1185```

1178```

1186

1179

1187−This simple application returns a stream of `User` values encoded in JSON

1180+This simple application returns a stream of `User` values encoded in JSON format, with each value separated by a newline. In this case, the stream will consist of the value of `isaac`, followed by the value of `albert`, then the value of `albert` a third time. Importantly, the stream is written back as results are produced, rather than all at once. This means first that results are delivered when they are available, and second, that if an exception interrupts production of the full stream, nonetheless partial results have already been written back.

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

1181

1196## Conclusion

1182## Conclusion

1197

1183

doc/tutorial/index.rst+20−1

@@ -6,10 +6,29 @@ This is an introductory tutorial to **servant**. Whilst browsing is fine, it mak

6Any comments, issues or feedback about the tutorial can be submitted

6Any comments, issues or feedback about the tutorial can be submitted

7to `servant's issue tracker <http://github.com/haskell-servant/servant/issues>`_.

7to `servant's issue tracker <http://github.com/haskell-servant/servant/issues>`_.

8

8

9+In fact, the whole tutorial is a `cabal <https://cabal.readthedocs.io/en/latest/>`_

10+project and can be built and played with locally as follows:

11+

12+.. code-block:: bash

13+

14+ $ git clone https://github.com/haskell-servant/servant.git

15+ $ cd servant

16+ # build

17+ $ cabal new-build tutorial

18+ # load in ghci to play with it

19+ $ cabal new-repl tutorial

20+

21+The code can be found in the `*.lhs` files under `doc/tutorial/` in the

22+repository. Feel free to edit it while you're reading this documentation and

23+see the effect of your changes.

24+

25+`Nix <https://nixos.org/nix/>`_ users should feel free to take a look at

26+the `nix/shell.nix` file in the repository and use it to provision a suitable

27+environment to build and run the examples.

28+

9.. toctree::

29.. toctree::

10 :maxdepth: 1

30 :maxdepth: 1

11

31

12− install.rst

13 ApiType.lhs

32 ApiType.lhs

14 Server.lhs

33 Server.lhs

15 Client.lhs

34 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+17−11

@@ -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==8.0.2

17− GHC==8.8.3, GHC ==8.10.7

17+ GHC==8.2.2

18+ GHC==8.4.4

19+ GHC==8.6.1

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.13

36 , aeson

38 , aeson

39+ , aeson-compat

37 , attoparsec

40 , attoparsec

38 , base-compat

41 , base-compat

39 , bytestring

42 , bytestring

@@ -63,11 +66,12 @@ 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.5.0 && <0.6

@@ -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 ? "ghc822"

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+}

servant-auth/README.mddeleted−1

@@ -1 +0,0 @@

1−servant-auth-server/README.lhs

servant-auth/servant-auth-client/.ghcideleted−1

@@ -1 +0,0 @@

1−:set -isrc -itest -idoctest/ghci-wrapper/src

servant-auth/servant-auth-client/CHANGELOG.mddeleted−26

@@ -1,26 +0,0 @@

1−# Changelog

2−

3−All notable changes to this project will be documented in this file.

4−

5−The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/)

6−and this project adheres to [PVP Versioning](https://pvp.haskell.org/).

7−

8−## [Unreleased]

9−

10−## [0.4.1.0] - 2020-10-06

11−

12−- Support generic Bearer token auth

13−

14−## [0.4.0.0] - 2019-03-08

15−

16−## Changed

17−

18−- #145 Support servant-0.16 in tests @domenkozar

19−- #145 Drop GHC 7.10 support @domenkozar

20−

21−## [0.3.3.0] - 2018-06-18

22−

23−### Added

24−- Support for GHC 8.4 by @phadej

25−- Support for servant-0.14 by @phadej

26−- Changelog by @domenkozar

servant-auth/servant-auth-client/LICENSEdeleted−31

@@ -1,31 +0,0 @@

1−Copyright Julian K. Arni (c) 2015

2−

3−All rights reserved.

4−

5−Redistribution and use in source and binary forms, with or without

6−modification, are permitted provided that the following conditions are met:

7−

8− * Redistributions of source code must retain the above copyright

9− notice, this list of conditions and the following disclaimer.

10−

11− * Redistributions in binary form must reproduce the above

12− copyright notice, this list of conditions and the following

13− disclaimer in the documentation and/or other materials provided

14− with the distribution.

15−

16− * Neither the name of Julian K. Arni nor the names of other

17− contributors may be used to endorse or promote products derived

18− from this software without specific prior written permission.

19−

20−THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS

21−"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT

22−LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR

23−A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT

24−OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,

25−SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT

26−LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,

27−DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY

28−THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT

29−(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE

30−OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

31−

servant-auth/servant-auth-client/Setup.hsdeleted−2

@@ -1,2 +0,0 @@

1−import Distribution.Simple

2−main = defaultMain

servant-auth/servant-auth-client/servant-auth-client.cabaldeleted−80

@@ -1,80 +0,0 @@

1−cabal-version: 2.2

2−name: servant-auth-client

3−version: 0.4.1.0

4−synopsis: servant-client/servant-auth compatibility

5−description: This package provides instances that allow generating clients from

6− <https://hackage.haskell.org/package/servant servant>

7− APIs that use

8− <https://hackage.haskell.org/package/servant-auth servant-auth's> @Auth@ combinator.

9− .

10− For a quick overview of the usage, see the <https://github.com/haskell-servant/servant/tree/master/servant-auth#readme README>.

11−category: Web, Servant, Authentication

12−homepage: https://github.com/haskell-servant/servant/tree/master/servant-auth#readme

13−bug-reports: https://github.com/haskell-servant/servant/issues

14−author: Julian K. Arni

15−maintainer: jkarni@gmail.com

16−copyright: (c) Julian K. Arni

17−license: BSD-3-Clause

18−license-file: LICENSE

19−tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1

20−build-type: Simple

21−extra-source-files:

22− CHANGELOG.md

23−

24−source-repository head

25− type: git

26− location: https://github.com/haskell-servant/servant

27−

28−library

29− hs-source-dirs:

30− src

31− default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators

32− ghc-options: -Wall

33− build-depends:

34− base >= 4.10 && < 4.18

35− , bytestring >= 0.10.6.0 && < 0.12

36− , containers >= 0.5.6.2 && < 0.7

37− , servant-auth == 0.4.*

38− , servant >= 0.13 && < 0.20

39− , servant-client-core >= 0.13 && < 0.20

40−

41− exposed-modules:

42− Servant.Auth.Client

43− Servant.Auth.Client.Internal

44− default-language: Haskell2010

45−

46−test-suite spec

47− type: exitcode-stdio-1.0

48− main-is: Spec.hs

49− hs-source-dirs:

50− test

51− default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators

52− ghc-options: -Wall

53− build-tool-depends: hspec-discover:hspec-discover >=2.5.5 && <2.10

54−

55− -- dependencies with bounds inherited from the library stanza

56− build-depends:

57− base

58− , servant-client

59− , servant-auth

60− , servant

61− , servant-auth-client

62−

63− -- test dependencies

64− build-depends:

65− hspec >= 2.5.5 && < 2.10

66− , QuickCheck >= 2.11.3 && < 2.15

67− , aeson >= 1.3.1.1 && < 3

68− , bytestring >= 0.10.6.0 && < 0.12

69− , http-client >= 0.5.13.1 && < 0.8

70− , http-types >= 0.12.2 && < 0.13

71− , servant-auth-server >= 0.4.2.0 && < 0.5

72− , servant-server >= 0.13 && < 0.20

73− , time >= 1.5.0.1 && < 1.13

74− , transformers >= 0.4.2.0 && < 0.6

75− , wai >= 3.2.1.2 && < 3.3

76− , warp >= 3.2.25 && < 3.4

77− , jose >= 0.10 && < 0.11

78− other-modules:

79− Servant.Auth.ClientSpec

80− default-language: Haskell2010

servant-auth/servant-auth-client/src/Servant/Auth/Client.hsdeleted−3

@@ -1,3 +0,0 @@

1−module Servant.Auth.Client (Token(..), Bearer) where

2−

3−import Servant.Auth.Client.Internal (Bearer, Token(..))

servant-auth/servant-auth-client/src/Servant/Auth/Client/Internal.hsdeleted−64

@@ -1,64 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

3−{-# LANGUAGE UndecidableInstances #-}

4−{-# OPTIONS_GHC -fno-warn-orphans #-}

5−#if __GLASGOW_HASKELL__ == 800

6−{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}

7−#endif

8−module Servant.Auth.Client.Internal where

9−

10−import qualified Data.ByteString as BS

11−import Data.Monoid

12−import Data.Proxy (Proxy (..))

13−import Data.String (IsString)

14−import GHC.Exts (Constraint)

15−import GHC.Generics (Generic)

16−import Servant.API ((:>))

17−import Servant.Auth

18−

19−import Servant.Client.Core

20−import Data.Sequence ((<|))

21−

22−-- | A simple bearer token.

23−newtype Token = Token { getToken :: BS.ByteString }

24− deriving (Eq, Show, Read, Generic, IsString)

25−

26−type family HasBearer xs :: Constraint where

27− HasBearer (Bearer ': xs) = ()

28− HasBearer (JWT ': xs) = ()

29− HasBearer (x ': xs) = HasBearer xs

30− HasBearer '[] = BearerAuthNotEnabled

31−

32−class BearerAuthNotEnabled

33−

34−-- | @'HasBearer' auths@ is nominally a redundant constraint, but ensures we're not

35−-- trying to send a token to an API that doesn't accept them.

36−instance (HasBearer auths, HasClient m api) => HasClient m (Auth auths a :> api) where

37− type Client m (Auth auths a :> api) = Token -> Client m api

38−

39− clientWithRoute m _ req (Token token)

40− = clientWithRoute m (Proxy :: Proxy api)

41− $ req { requestHeaders = ("Authorization", headerVal) <| requestHeaders req }

42− where

43− headerVal = "Bearer " <> token

44−

45−#if MIN_VERSION_servant_client_core(0,14,0)

46− hoistClientMonad pm _ nt cl = hoistClientMonad pm (Proxy :: Proxy api) nt . cl

47−#endif

48−

49−

50−-- * Authentication combinators

51−

52−-- | A Bearer token in the Authorization header:

53−--

54−-- @Authorization: Bearer <token>@

55−--

56−-- This can be any token recognized by the server, for example,

57−-- a JSON Web Token (JWT).

58−--

59−-- Note that, since the exact way the token is validated is not specified,

60−-- this combinator can only be used in the client. The server would not know

61−-- how to validate it, while the client does not care.

62−-- If you want to implement Bearer authentication in your server, you have to

63−-- choose a specific combinator, such as 'JWT'.

64−data Bearer

servant-auth/servant-auth-client/test/Servant/Auth/ClientSpec.hsdeleted−161

@@ -1,161 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE DeriveAnyClass #-}

3−module Servant.Auth.ClientSpec (spec) where

4−

5−import Crypto.JOSE (JWK,

6− KeyMaterialGenParam (OctGenParam),

7− genJWK)

8−import Data.Aeson (FromJSON (..), ToJSON (..))

9−import qualified Data.ByteString.Lazy as BSL

10−import Data.Time (UTCTime, defaultTimeLocale,

11− parseTimeOrError)

12−import GHC.Generics (Generic)

13−import Network.HTTP.Client (Manager, defaultManagerSettings,

14− newManager)

15−import Network.HTTP.Types (status401)

16−import Network.Wai.Handler.Warp (testWithApplication)

17−import Servant

18−import Servant.Client (BaseUrl (..), Scheme (Http),

19− ClientError (FailureResponse),

20−#if MIN_VERSION_servant_client(0,16,0)

21− ResponseF(..),

22−#elif MIN_VERSION_servant_client(0,13,0)

23− GenResponse(..),

24−#elif MIN_VERSION_servant_client(0,12,0)

25− Response(..),

26−#endif

27− client)

28−import System.IO.Unsafe (unsafePerformIO)

29−import Test.Hspec

30−import Test.QuickCheck

31−

32−#if MIN_VERSION_servant_client(0,13,0)

33−import Servant.Client (mkClientEnv, runClientM)

34−#elif MIN_VERSION_servant_client(0,9,0)

35−import Servant.Client (ClientEnv (..), runClientM)

36−#else

37−import Control.Monad.Trans.Except (runExceptT)

38−#endif

39−#if !MIN_VERSION_servant_server(0,16,0)

40−#define ClientError ServantError

41−#endif

42−

43−import Servant.Auth.Client

44−import Servant.Auth.Server

45−import Servant.Auth.Server.SetCookieOrphan ()

46−

47−spec :: Spec

48−spec = describe "The JWT combinator" $ do

49− hasClientSpec

50−

51−

52−------------------------------------------------------------------------------

53−-- * HasClient {{{

54−

55−hasClientSpec :: Spec

56−hasClientSpec = describe "HasClient" $ around (testWithApplication $ return app) $ do

57−

58− let mkTok :: User -> Maybe UTCTime -> IO Token

59− mkTok user mexp = do

60− Right tok <- makeJWT user jwtCfg mexp

61− return $ Token $ BSL.toStrict tok

62−

63− it "succeeds when the token does not have expiry" $ \port -> property $ \user -> do

64− tok <- mkTok user Nothing

65− v <- getIntClient tok mgr (BaseUrl Http "localhost" port "")

66− v `shouldBe` Right (length $ name user)

67−

68− it "succeeds when the token is not expired" $ \port -> property $ \user -> do

69− tok <- mkTok user (Just future)

70− v <- getIntClient tok mgr (BaseUrl Http "localhost" port "")

71− v `shouldBe` Right (length $ name user)

72−

73− it "fails when token is expired" $ \port -> property $ \user -> do

74− tok <- mkTok user (Just past)

75−#if MIN_VERSION_servant_client(0,16,0)

76− Left (FailureResponse _ (Response stat _ _ _))

77−#elif MIN_VERSION_servant_client(0,12,0)

78− Left (FailureResponse (Response stat _ _ _))

79−#elif MIN_VERSION_servant_client(0,11,0)

80− Left (FailureResponse _ stat _ _)

81−#else

82− Left (FailureResponse stat _ _)

83−#endif

84− <- getIntClient tok mgr (BaseUrl Http "localhost" port "")

85− stat `shouldBe` status401

86−

87−

88−getIntClient :: Token -> Manager -> BaseUrl -> IO (Either ClientError Int)

89−#if MIN_VERSION_servant(0,13,0)

90−getIntClient tok m burl = runClientM (client api tok) (mkClientEnv m burl)

91−#elif MIN_VERSION_servant(0,9,0)

92−getIntClient tok m burl = runClientM (client api tok) (ClientEnv m burl)

93−#else

94−getIntClient tok m burl = runExceptT $ client api tok m burl

95−#endif

96−-- }}}

97−------------------------------------------------------------------------------

98−-- * API and Server {{{

99−

100−type API = Auth '[JWT] User :> Get '[JSON] Int

101−

102−api :: Proxy API

103−api = Proxy

104−

105−theKey :: JWK

106−theKey = unsafePerformIO . genJWK $ OctGenParam 256

107−{-# NOINLINE theKey #-}

108−

109−mgr :: Manager

110−mgr = unsafePerformIO $ newManager defaultManagerSettings

111−{-# NOINLINE mgr #-}

112−

113−app :: Application

114−app = serveWithContext api ctx server

115− where

116− ctx = cookieCfg :. jwtCfg :. EmptyContext

117−

118−jwtCfg :: JWTSettings

119−jwtCfg = defaultJWTSettings theKey

120−

121−cookieCfg :: CookieSettings

122−cookieCfg = defaultCookieSettings

123−

124−

125−server :: Server API

126−server = getInt

127− where

128− getInt :: AuthResult User -> Handler Int

129− getInt (Authenticated u) = return . length $ name u

130− getInt _ = throwAll err401

131−

132−

133−-- }}}

134−------------------------------------------------------------------------------

135−-- * Utils {{{

136−

137−past :: UTCTime

138−past = parseTimeOrError True defaultTimeLocale "%Y-%m-%d" "1970-01-01"

139−

140−future :: UTCTime

141−future = parseTimeOrError True defaultTimeLocale "%Y-%m-%d" "2070-01-01"

142−

143−

144−-- }}}

145−------------------------------------------------------------------------------

146−-- * Types {{{

147−

148−data User = User

149− { name :: String

150− , _id :: String

151− } deriving (Eq, Show, Read, Generic)

152−

153−instance FromJWT User

154−instance ToJWT User

155−instance FromJSON User

156−instance ToJSON User

157−

158−instance Arbitrary User where

159− arbitrary = User <$> arbitrary <*> arbitrary

160−

161−-- }}}

servant-auth/servant-auth-client/test/Spec.hsdeleted−1

@@ -1 +0,0 @@

1−{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

servant-auth/servant-auth-docs/.ghcideleted−1

@@ -1 +0,0 @@

1−:set -isrc -itest -idoctest/ghci-wrapper/src

servant-auth/servant-auth-docs/CHANGELOG.mddeleted−14

@@ -1,14 +0,0 @@

1−# Changelog

2−

3−All notable changes to this project will be documented in this file.

4−

5−The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/)

6−and this project adheres to [PVP Versioning](https://pvp.haskell.org/).

7−

8−## [Unreleased]

9−

10−## [0.2.10.0] - 2018-06-18

11−

12−### Added

13−- Support for GHC 8.4 by @phadej

14−- Changelog by @domenkozar

servant-auth/servant-auth-docs/LICENSEdeleted−31

@@ -1,31 +0,0 @@

1−Copyright Julian K. Arni (c) 2015

2−

3−All rights reserved.

4−

5−Redistribution and use in source and binary forms, with or without

6−modification, are permitted provided that the following conditions are met:

7−

8− * Redistributions of source code must retain the above copyright

9− notice, this list of conditions and the following disclaimer.

10−

11− * Redistributions in binary form must reproduce the above

12− copyright notice, this list of conditions and the following

13− disclaimer in the documentation and/or other materials provided

14− with the distribution.

15−

16− * Neither the name of Julian K. Arni nor the names of other

17− contributors may be used to endorse or promote products derived

18− from this software without specific prior written permission.

19−

20−THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS

21−"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT

22−LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR

23−A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT

24−OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,

25−SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT

26−LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,

27−DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY

28−THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT

29−(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE

30−OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

31−

servant-auth/servant-auth-docs/Setup.hsdeleted−33

@@ -1,33 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# OPTIONS_GHC -Wall #-}

3−module Main (main) where

4−

5−#ifndef MIN_VERSION_cabal_doctest

6−#define MIN_VERSION_cabal_doctest(x,y,z) 0

7−#endif

8−

9−#if MIN_VERSION_cabal_doctest(1,0,0)

10−

11−import Distribution.Extra.Doctest ( defaultMainWithDoctests )

12−main :: IO ()

13−main = defaultMainWithDoctests "doctests"

14−

15−#else

16−

17−#ifdef MIN_VERSION_Cabal

18−-- If the macro is defined, we have new cabal-install,

19−-- but for some reason we don't have cabal-doctest in package-db

20−--

21−-- Probably we are running cabal sdist, when otherwise using new-build

22−-- workflow

23−#warning You are configuring this package without cabal-doctest installed. \

24− The doctests test-suite will not work as a result. \

25− To fix this, install cabal-doctest before configuring.

26−#endif

27−

28−import Distribution.Simple

29−

30−main :: IO ()

31−main = defaultMain

32−

33−#endif

servant-auth/servant-auth-docs/servant-auth-docs.cabaldeleted−84

@@ -1,84 +0,0 @@

1−cabal-version: 2.2

2−name: servant-auth-docs

3−version: 0.2.10.0

4−synopsis: servant-docs/servant-auth compatibility

5−description: This package provides instances that allow generating docs from

6− <https://hackage.haskell.org/package/servant servant>

7− APIs that use

8− <https://hackage.haskell.org/package/servant-auth servant-auth's> @Auth@ combinator.

9− .

10− For a quick overview of the usage, see the <https://github.com/haskell-servant/servant/tree/master/servant-auth#readme README>.

11−category: Web, Servant, Authentication

12−homepage: https://github.com/haskell-servant/servant/tree/master/servant-auth#readme

13−bug-reports: https://github.com/haskell-servant/servant/issues

14−author: Julian K. Arni

15−maintainer: jkarni@gmail.com

16−copyright: (c) Julian K. Arni

17−license: BSD-3-Clause

18−license-file: LICENSE

19−tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1

20−build-type: Custom

21−extra-source-files:

22− CHANGELOG.md

23−

24−custom-setup

25− setup-depends:

26− base, Cabal, cabal-doctest >=1.0.6 && <1.1

27−

28−source-repository head

29− type: git

30− location: https://github.com/haskell-servant/servant

31−

32−library

33− hs-source-dirs:

34− src

35− default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators

36− ghc-options: -Wall

37− build-depends:

38− base >= 4.10 && < 4.18

39− , servant-docs >= 0.11.2 && < 0.13

40− , servant >= 0.13 && < 0.20

41− , servant-auth == 0.4.*

42− , lens >= 4.16.1 && <5.3

43− exposed-modules:

44− Servant.Auth.Docs

45− default-language: Haskell2010

46−

47−test-suite doctests

48− type: exitcode-stdio-1.0

49− main-is: doctests.hs

50− build-depends:

51− base,

52− servant-auth-docs,

53− doctest >= 0.16 && < 0.21,

54− QuickCheck >= 2.11.3 && < 2.15,

55− template-haskell

56− ghc-options: -Wall -threaded

57− hs-source-dirs: test

58− default-language: Haskell2010

59−

60−test-suite spec

61− type: exitcode-stdio-1.0

62− main-is: Spec.hs

63− hs-source-dirs:

64− test

65− default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators

66− ghc-options: -Wall

67− build-tool-depends: hspec-discover:hspec-discover >=2.5.5 && <2.10

68−

69− -- dependencies with bounds inherited from the library stanza

70− build-depends:

71− base

72− , text

73− , servant-docs

74− , servant

75− , servant-auth

76− , lens

77−

78− -- test dependencies

79− build-depends:

80− servant-auth-docs

81− , hspec >= 2.5.5 && < 2.10

82− , QuickCheck >= 2.11.3 && < 2.15

83−

84− default-language: Haskell2010

servant-auth/servant-auth-docs/src/Servant/Auth/Docs.hsdeleted−96

@@ -1,96 +0,0 @@

1−{-# OPTIONS_GHC -fno-warn-orphans #-}

2−module Servant.Auth.Docs

3− (

4− -- | The purpose of this package is provide the instance for 'servant-auth'

5− -- combinators needed for 'servant-docs' documentation generation.

6− --

7− -- >>> type API = Auth '[JWT, Cookie, BasicAuth] Int :> Get '[JSON] Int

8− -- >>> putStr $ markdown $ docs (Proxy :: Proxy API)

9− -- ## GET /

10− -- ...

11− -- ... Authentication

12− -- ...

13− -- This part of the API is protected by the following authentication mechanisms:

14− -- ...

15− -- * JSON Web Tokens ([JWTs](https://en.wikipedia.org/wiki/JSON_Web_Token))

16− -- * [Cookies](https://en.wikipedia.org/wiki/HTTP_cookie)

17− -- * [Basic Authentication](https://en.wikipedia.org/wiki/Basic_access_authentication)

18− -- ...

19− -- Clients must supply the following data

20− -- ...

21− -- One of the following:

22− -- ...

23− -- * A JWT Token signed with this server's key

24− -- * Cookies automatically set by browsers, plus a header

25− -- * Cookies automatically set by browsers, plus a header

26− -- ...

27−

28− -- * Re-export

29− JWT

30− , BasicAuth

31− , Cookie

32− , Auth

33− ) where

34−

35−import Control.Lens ((%~), (&), (|>))

36−import Data.List (intercalate)

37−import Data.Monoid

38−import Data.Proxy (Proxy (Proxy))

39−import Servant.API hiding (BasicAuth)

40−import Servant.Auth

41−import Servant.Docs hiding (pretty)

42−import Servant.Docs.Internal (DocAuthentication (..), authInfo)

43−

44−instance (AllDocs auths, HasDocs api) => HasDocs (Auth auths r :> api) where

45− docsFor _ (endpoint, action) =

46− docsFor (Proxy :: Proxy api) (endpoint, action & authInfo %~ (|> info))

47− where

48− (intro, reqData) = pretty $ allDocs (Proxy :: Proxy auths)

49− info = DocAuthentication intro reqData

50−

51−

52−pretty :: [(String, String)] -> (String, String)

53−pretty [] = error "shouldn't happen"

54−pretty [(i, d)] =

55− ( "This part of the API is protected by " <> i

56− , d

57− )

58−pretty rs =

59− ( "This part of the API is protected by the following authentication mechanisms:\n\n"

60− ++ " * " <> intercalate "\n * " (fst <$> rs)

61− , "\nOne of the following:\n\n"

62− ++ " * " <> intercalate "\n * " (snd <$> rs)

63− )

64−

65−

66−class AllDocs (x :: [*]) where

67− allDocs :: proxy x

68− -- intro, req

69− -> [(String, String)]

70−

71−instance (OneDoc a, AllDocs as) => AllDocs (a ': as) where

72− allDocs _ = oneDoc (Proxy :: Proxy a) : allDocs (Proxy :: Proxy as)

73−

74−instance AllDocs '[] where

75− allDocs _ = []

76−

77−class OneDoc a where

78− oneDoc :: proxy a -> (String, String)

79−

80−instance OneDoc JWT where

81− oneDoc _ =

82− ("JSON Web Tokens ([JWTs](https://en.wikipedia.org/wiki/JSON_Web_Token))"

83− , "A JWT Token signed with this server's key")

84−

85−instance OneDoc Cookie where

86− oneDoc _ =

87− ("[Cookies](https://en.wikipedia.org/wiki/HTTP_cookie)"

88− , "Cookies automatically set by browsers, plus a header")

89−

90−instance OneDoc BasicAuth where

91− oneDoc _ =

92− ( "[Basic Authentication](https://en.wikipedia.org/wiki/Basic_access_authentication)"

93− , "Cookies automatically set by browsers, plus a header")

94−

95−-- $setup

96−-- >>> instance ToSample Int where toSamples _ = singleSample 1729

servant-auth/servant-auth-docs/test/Spec.hsdeleted−1

@@ -1 +0,0 @@

1−{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

servant-auth/servant-auth-docs/test/doctests.hsdeleted−12

@@ -1,12 +0,0 @@

1−module Main where

2−

3−import Build_doctests (flags, pkgs, module_sources)

4−import Data.Foldable (traverse_)

5−import Test.DocTest

6−

7−main :: IO ()

8−main = do

9− traverse_ putStrLn args

10− doctest args

11− where

12− args = flags ++ pkgs ++ module_sources

servant-auth/servant-auth-server/.ghcideleted−1

@@ -1 +0,0 @@

1−:set -isrc -itest -idoctest/ghci-wrapper/src

servant-auth/servant-auth-server/CHANGELOG.mddeleted−130

@@ -1,130 +0,0 @@

1−# Changelog

2−

3−All notable changes to this project will be documented in this file.

4−

5−The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/)

6−and this project adheres to [PVP Versioning](https://pvp.haskell.org/).

7−

8−## [Unreleased]

9−

10−## [0.4.6.0] - 2020-10-06

11−

12−## Changed

13−

14−- expose verifyJWT and use it in two places [@domenkozar]

15−- support GHC 8.10 [@domenkozar]

16−- move ToJWT/FromJWT to servant-auth [@erewok]

17−- #165 fix AnySite with Cookie 3.5.0 [@odr]

18−

19−## [0.4.5.1] - 2020-02-06

20−

21−## Changed

22−

23−- #158 servant 0.17 support [@phadej]

24−

25−## [0.4.5.0] - 2019-12-28

26−

27−## Changed

28−- #144 servant 0.16 support and drop GHC 7.10 support [@domenkozar]

29−- #148 removed unused constaint in HasServer instance for Auth

30−- #154 GHC 8.8 support [@phadej]

31−

32−### Added

33−- #141 Support Stream combinator [@domenkozar]

34−- #143 Allow servant-0.16 [@phadej]

35−

36−## [0.4.4.0] - 2019-03-02

37−

38−### Added

39−- #141 Support Stream combinator [@domenkozar]

40−- #143 Allow servant-0.16 [@phadej]

41−

42−## [0.4.3.0] - 2019-01-17

43−

44−## Changed

45−- #117 Avoid running auth checks unnecessarily [@sopvop]

46−- #110 Get rid of crypto-api dependency [@domenkozar]

47−- #130 clearSession: improve cross-browser compatibility [@domenkozar]

48−- #136 weed out bytestring-conversion [@stephenirl]

49−

50−## [0.4.2.0] - 2018-11-05

51−

52−### Added

53−- `Headers hs a` instance for AddSetCookieApi [@domenkozar]

54−- GHC 8.6.x support [@domenkozar]

55−

56−## [0.4.1.0] - 2018-10-05

57−

58−### Added

59−- #125 Allow setting domain name for a cookie [@domenkozar]

60−

61−## Changed

62−- bump http-api-data to 0.3.10 that includes Cookie orphan instances previously located in servant-auth-server [@phadej]

63−- #114 Export `HasSecurity` typeclass [@rockbmb]

64−

65−## [0.4.0.1] - 2018-09-23

66−

67−### Security

68−- #123 Session cookie did not apply SameSite attribute [@domenkozar]

69−

70−### Added

71−- #112 HasLink instance for Auth combinator [@adetokunbo]

72−- #111 Documentation for using hoistServer [@mschristiansen]

73−- #107 Add utility functions for reading and writing a key to a file [@mschristiansen]

74−

75−## [0.4.0.0] - 2018-06-17

76−

77−### Added

78−- Support GHC 8.4 by @phadej and @domenkozar

79−- Support for servant-0.14 by @phadej

80−- #96 Support for jose-0.7 by @xaviershay

81−- #92 add `clearSession` for logout by @plredmond and @3noch

82−- #95 makeJWT: allow setting Alg via defaultJWTSettings by @domenkozar

83−- #89 Validate JWT against a JWKSet instead of JWK by @sopvop

84−

85−### Changed

86−- #92 Rename CSRF to XSRF by @plredmond and @3noch

87−- #92 extract 'XsrfCookieSettings' from 'CookieSettings' and make XSRF checking optional

88− by @plredmond and @3noch

89−- #69 export SameSite by @domenkozar

90−- #102 Reuse Servant.Api.IsSecure instead of duplicating ADT by @domenkozar

91−

92−### Deprecated

93−- #92 Renamed 'makeCsrfCookie' to 'makeXsrfCookie' and marked the former as deprecated

94− by @plredmond and @3noc

95−- #92 Made several changes to the structure of 'CookieSettings' which will require

96− attention by users who have modified the XSRF settings by @plredmond and @3noch

97−

98−### Security

99−- #94 Force cookie expiration on serverside by @karshan

100−

101−## [0.3.2.0] - 2018-02-21

102−

103−### Added

104−- #76 Export wwwAuthenticatedErr and elaborate its annotation by @defanor

105−- Support for servant-0.14 by @phadej

106−

107−### Changed

108−- Disable the readme executable for ghcjs builds by @hamishmack

109−- #84 Make AddSetCookieApi type family open by @qnikst

110−- #79 Make CSRF checks optional for GET requests by @harendra-kumar

111−

112−## [0.3.1.0] - 2017-11-08

113−

114−### Added

115−- Support for servant-0.12 by @phadej

116−

117−## [0.3.0.0] - 2017-11-07

118−

119−### Changed

120−- #47 'cookiePath' and 'xsrfCookiePath' added to 'CookieSettings' by @mchaver

121−

122−## [0.2.8.0] - 2017-05-26

123−

124−### Added

125−- #45 Support for servant-0.11 by @phadej

126−

127−## [0.2.7.0] - 2017-02-11

128−

129−### Changed

130−- #27 #41 'acceptLogin' and 'makeCsrfCookie' functions by @bts

servant-auth/servant-auth-server/LICENSEdeleted−31

@@ -1,31 +0,0 @@

1−Copyright Julian K. Arni (c) 2015

2−

3−All rights reserved.

4−

5−Redistribution and use in source and binary forms, with or without

6−modification, are permitted provided that the following conditions are met:

7−

8− * Redistributions of source code must retain the above copyright

9− notice, this list of conditions and the following disclaimer.

10−

11− * Redistributions in binary form must reproduce the above

12− copyright notice, this list of conditions and the following

13− disclaimer in the documentation and/or other materials provided

14− with the distribution.

15−

16− * Neither the name of Julian K. Arni nor the names of other

17− contributors may be used to endorse or promote products derived

18− from this software without specific prior written permission.

19−

20−THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS

21−"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT

22−LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR

23−A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT

24−OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,

25−SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT

26−LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,

27−DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY

28−THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT

29−(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE

30−OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

31−

servant-auth/servant-auth-server/README.lhsdeleted−291

@@ -1,291 +0,0 @@

1−# servant-auth

2−

3−These packages provides safe and easy-to-use authentication options for

4−`servant`. The same API can be protected via:

5−- basicauth

6−- cookies

7−- JWT tokens

8−

9−

10−| Package | Hackage |

11−| -------------------- | ----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- |

12−| servant-auth | [](https://hackage.haskell.org/package/servant-auth) |

13−| servant-auth-server | [](https://hackage.haskell.org/package/servant-auth-server) |

14−| servant-auth-client | [](https://hackage.haskell.org/package/servant-auth-client) |

15−| servant-auth-swagger | [](https://hackage.haskell.org/package/servant-auth-swagger) |

16−| servant-auth-docs | [](https://hackage.haskell.org/package/servant-auth-docs) |

17−

18−## How it works

19−

20−First some imports:

21−

22−~~~ haskell

23−{-# OPTIONS_GHC -fno-warn-unused-binds #-}

24−{-# OPTIONS_GHC -fno-warn-deprecations #-}

25−import Control.Concurrent (forkIO)

26−import Control.Monad (forever)

27−import Control.Monad.Trans (liftIO)

28−import Data.Aeson (FromJSON, ToJSON)

29−import GHC.Generics (Generic)

30−import Network.Wai.Handler.Warp (run)

31−import System.Environment (getArgs)

32−import Servant

33−import Servant.Auth.Server

34−import Servant.Auth.Server.SetCookieOrphan ()

35−~~~

36−

37−`servant-auth` library introduces a combinator `Auth`:

38−

39−~~~ haskell

40−data Auth (auths :: [*]) val

41−~~~

42−

43−What `Auth [Auth1, Auth2] Something :> API` means is that `API` is protected by

44−*either* `Auth1` *or* `Auth2`, and the result of authentication will be of type

45−`AuthResult Something`, where :

46−

47−~~~ haskell

48−data AuthResult val

49− = BadPassword

50− | NoSuchUser

51− | Authenticated val

52− | Indefinite

53−~~~

54−

55−Your handlers will get a value of type `AuthResult Something`, and can decide

56−what to do with it.

57−

58−~~~ haskell

59−

60−data User = User { name :: String, email :: String }

61− deriving (Eq, Show, Read, Generic)

62−

63−instance ToJSON User

64−instance ToJWT User

65−instance FromJSON User

66−instance FromJWT User

67−

68−data Login = Login { username :: String, password :: String }

69− deriving (Eq, Show, Read, Generic)

70−

71−instance ToJSON Login

72−instance FromJSON Login

73−

74−type Protected

75− = "name" :> Get '[JSON] String

76− :<|> "email" :> Get '[JSON] String

77−

78−

79−-- | 'Protected' will be protected by 'auths', which we still have to specify.

80−protected :: Servant.Auth.Server.AuthResult User -> Server Protected

81−-- If we get an "Authenticated v", we can trust the information in v, since

82−-- it was signed by a key we trust.

83−protected (Servant.Auth.Server.Authenticated user) = return (name user) :<|> return (email user)

84−-- Otherwise, we return a 401.

85−protected _ = throwAll err401

86−

87−type Unprotected =

88− "login"

89− :> ReqBody '[JSON] Login

90− :> Verb 'POST 204 '[JSON] (Headers '[ Header "Set-Cookie" SetCookie

91− , Header "Set-Cookie" SetCookie]

92− NoContent)

93− :<|> Raw

94−

95−unprotected :: CookieSettings -> JWTSettings -> Server Unprotected

96−unprotected cs jwts = checkCreds cs jwts :<|> serveDirectory "example/static"

97−

98−type API auths = (Servant.Auth.Server.Auth auths User :> Protected) :<|> Unprotected

99−

100−server :: CookieSettings -> JWTSettings -> Server (API auths)

101−server cs jwts = protected :<|> unprotected cs jwts

102−

103−~~~

104−

105−The code is common to all authentications. In order to pick one or more specific

106−authentication methods, all we need to do is provide the expect configuration

107−parameters.

108−

109−## API tokens

110−

111−The following example illustrates how to protect an API with tokens.

112−

113−

114−~~~ haskell

115−-- In main, we fork the server, and allow new tokens to be created in the

116−-- command line for the specified user name and email.

117−mainWithJWT :: IO ()

118−mainWithJWT = do

119− -- We generate the key for signing tokens. This would generally be persisted,

120− -- and kept safely

121− myKey <- generateKey

122− -- Adding some configurations. All authentications require CookieSettings to

123− -- be in the context.

124− let jwtCfg = defaultJWTSettings myKey

125− cfg = defaultCookieSettings :. jwtCfg :. EmptyContext

126− --- Here we actually make concrete

127− api = Proxy :: Proxy (API '[JWT])

128− _ <- forkIO $ run 7249 $ serveWithContext api cfg (server defaultCookieSettings jwtCfg)

129−

130− putStrLn "Started server on localhost:7249"

131− putStrLn "Enter name and email separated by a space for a new token"

132−

133− forever $ do

134− xs <- words <$> getLine

135− case xs of

136− [name', email'] -> do

137− etoken <- makeJWT (User name' email') jwtCfg Nothing

138− case etoken of

139− Left e -> putStrLn $ "Error generating token:t" ++ show e

140− Right v -> putStrLn $ "New token:\t" ++ show v

141− _ -> putStrLn "Expecting a name and email separated by spaces"

142−

143−~~~

144−

145−And indeed:

146−

147−~~~ bash

148−

149−./readme JWT

150−

151− Started server on localhost:7249

152− Enter name and email separated by a space for a new token

153− alice alice@gmail.com

154− New token: "eyJhbGciOiJIUzI1NiJ9.eyJkYXQiOnsiZW1haWwiOiJhbGljZUBnbWFpbC5jb20iLCJuYW1lIjoiYWxpY2UifX0.xzOIrx_A9VOKzVO-R1c1JYKBqK9risF625HOxpBzpzE"

155−

156−curl localhost:7249/name -v

157−

158− * Hostname was NOT found in DNS cache

159− * Trying 127.0.0.1...

160− * Connected to localhost (127.0.0.1) port 7249 (#0)

161− > GET /name HTTP/1.1

162− > User-Agent: curl/7.35.0

163− > Host: localhost:7249

164− > Accept: */*

165− >

166− < HTTP/1.1 401 Unauthorized

167− < Transfer-Encoding: chunked

168− < Date: Wed, 07 Sep 2016 20:17:17 GMT

169− * Server Warp/3.2.7 is not blacklisted

170− < Server: Warp/3.2.7

171− <

172− * Connection #0 to host localhost left intact

173−

174−curl -H "Authorization: Bearer eyJhbGciOiJIUzI1NiJ9.eyJkYXQiOnsiZW1haWwiOiJhbGljZUBnbWFpbC5jb20iLCJuYW1lIjoiYWxpY2UifX0.xzOIrx_A9VOKzVO-R1c1JYKBqK9risF625HOxpBzpzE" \

175− localhost:7249/name -v

176−

177− * Hostname was NOT found in DNS cache

178− * Trying 127.0.0.1...

179− * Connected to localhost (127.0.0.1) port 7249 (#0)

180− > GET /name HTTP/1.1

181− > User-Agent: curl/7.35.0

182− > Host: localhost:7249

183− > Accept: */*

184− > Authorization: Bearer eyJhbGciOiJIUzI1NiJ9.eyJkYXQiOnsiZW1haWwiOiJhbGljZUBnbWFpbC5jb20iLCJuYW1lIjoiYWxpY2UifX0.xzOIrx_A9VOKzVO-R1c1JYKBqK9risF625HOxpBzpzE

185− >

186− < HTTP/1.1 200 OK

187− < Transfer-Encoding: chunked

188− < Date: Wed, 07 Sep 2016 20:16:11 GMT

189− * Server Warp/3.2.7 is not blacklisted

190− < Server: Warp/3.2.7

191− < Content-Type: application/json

192− < Set-Cookie: JWT-Cookie=eyJhbGciOiJIUzI1NiJ9.eyJkYXQiOnsiZW1haWwiOiJhbGljZUBnbWFpbC5jb20iLCJuYW1lIjoiYWxpY2UifX0.xzOIrx_A9VOKzVO-R1c1JYKBqK9risF625HOxpBzpzE; HttpOnly; Secure

193− < Set-Cookie: XSRF-TOKEN=TWcdPnHr2QHcVyTw/TTBLQ==; Secure

194− <

195− * Connection #0 to host localhost left intact

196− "alice"%

197−

198−

199−~~~

200−

201−## Cookies

202−

203−What if, in addition to API tokens, we want to expose our API to browsers? All

204−we need to do is say so!

205−

206−~~~ haskell

207−mainWithCookies :: IO ()

208−mainWithCookies = do

209− -- We *also* need a key to sign the cookies

210− myKey <- generateKey

211− -- Adding some configurations. 'Cookie' requires, in addition to

212− -- CookieSettings, JWTSettings (for signing), so everything is just as before

213− let jwtCfg = defaultJWTSettings myKey

214− cfg = defaultCookieSettings :. jwtCfg :. EmptyContext

215− --- Here is the actual change

216− api = Proxy :: Proxy (API '[Cookie])

217− run 7249 $ serveWithContext api cfg (server defaultCookieSettings jwtCfg)

218−

219−-- Here is the login handler

220−checkCreds :: CookieSettings

221− -> JWTSettings

222− -> Login

223− -> Handler (Headers '[ Header "Set-Cookie" SetCookie

224− , Header "Set-Cookie" SetCookie]

225− NoContent)

226−checkCreds cookieSettings jwtSettings (Login "Ali Baba" "Open Sesame") = do

227− -- Usually you would ask a database for the user info. This is just a

228− -- regular servant handler, so you can follow your normal database access

229− -- patterns (including using 'enter').

230− let usr = User "Ali Baba" "ali@email.com"

231− mApplyCookies <- liftIO $ acceptLogin cookieSettings jwtSettings usr

232− case mApplyCookies of

233− Nothing -> throwError err401

234− Just applyCookies -> return $ applyCookies NoContent

235−checkCreds _ _ _ = throwError err401

236−~~~

237−

238−### XSRF and the frontend

239−

240−XSRF protection works by requiring that there be a header of the same value as

241−a distinguished cookie that is set by the server on each request. What the

242−cookie and header name are can be configured (see `xsrfCookieName` and

243−`xsrfHeaderName` in `CookieSettings`), but by default they are "XSRF-TOKEN" and

244−"X-XSRF-TOKEN". This means that, if your client is a browser and you're using

245−cookies, Javascript on the client must set the header of each request by

246−reading the cookie. For jQuery, and with the default values, that might be:

247−

248−~~~ javascript

249−

250−var token = (function() {

251− r = document.cookie.match(new RegExp('XSRF-TOKEN=([^;]+)'))

252− if (r) return r[1];

253−})();

254−

255−

256−$.ajaxPrefilter(function(opts, origOpts, xhr) {

257− xhr.setRequestHeader('X-XSRF-TOKEN', token);

258− }

259−

260−~~~

261−

262−I *believe* nothing at all needs to be done if you're using Angular's `$http`

263−directive, but I haven't tested this.

264−

265−XSRF protection can be disabled just for `GET` requests by setting

266−`xsrfExcludeGet = False`. You might want this if you're relying on the browser

267−to navigate between pages that require cookie authentication.

268−

269−XSRF protection can be completely disabled by setting `cookieXsrfSetting =

270−Nothing` in `CookieSettings`. This is not recommended! If your cookie

271−authenticated web application runs any javascript, it's recommended to send the

272−XSRF header. However, if your web application runs no javascript, disabling

273−XSRF entirely may be required.

274−

275−# Note on this README

276−

277−This README is a literate haskell file. Here is 'main', allowing you to pick

278−between the examples above.

279−

280−~~~ haskell

281−

282−main :: IO ()

283−main = do

284− args <- getArgs

285− let usage = "Usage: readme (JWT|Cookie)"

286− case args of

287− ["JWT"] -> mainWithJWT

288− ["Cookie"] -> mainWithCookies

289− e -> putStrLn $ "Arguments: \"" ++ unwords e ++ "\" not understood\n" ++ usage

290−

291−~~~

servant-auth/servant-auth-server/README.mddeleted−1

@@ -1 +0,0 @@

1−README.lhs

servant-auth/servant-auth-server/Setup.hsdeleted−2

@@ -1,2 +0,0 @@

1−import Distribution.Simple

2−main = defaultMain

servant-auth/servant-auth-server/servant-auth-server.cabaldeleted−135

@@ -1,135 +0,0 @@

1−cabal-version: 2.2

2−name: servant-auth-server

3−version: 0.4.7.0

4−synopsis: servant-server/servant-auth compatibility

5−description: This package provides the required instances for using the @Auth@ combinator

6− in your 'servant' server.

7− .

8− Both cookie- and token- (REST API) based authentication is provided.

9− .

10− For a quick overview of the usage, see the <https://github.com/haskell-servant/servant/tree/master/servant-auth#readme README>.

11−category: Web, Servant, Authentication

12−homepage: https://github.com/haskell-servant/servant/tree/master/servant-auth#readme

13−bug-reports: https://github.com/haskell-servant/servant/issues

14−author: Julian K. Arni

15−maintainer: jkarni@gmail.com

16−copyright: (c) Julian K. Arni

17−license: BSD-3-Clause

18−license-file: LICENSE

19−tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1

20−build-type: Simple

21−extra-source-files:

22− CHANGELOG.md

23−

24−source-repository head

25− type: git

26− location: https://github.com/haskell-servant/servant

27−

28−library

29− hs-source-dirs:

30− src

31− default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators

32− ghc-options: -Wall

33− build-depends:

34− base >= 4.10 && < 4.18

35− , aeson >= 1.0.0.1 && < 3

36− , base64-bytestring >= 1.0.0.1 && < 2

37− , blaze-builder >= 0.4.1.0 && < 0.5

38− , bytestring >= 0.10.6.0 && < 0.12

39− , case-insensitive >= 1.2.0.11 && < 1.3

40− , cookie >= 0.4.4 && < 0.5

41− , data-default-class >= 0.1.2.0 && < 0.2

42− , entropy >= 0.4.1.3 && < 0.5

43− , http-types >= 0.12.2 && < 0.13

44− , jose >= 0.10 && < 0.11

45− , lens >= 4.16.1 && < 5.3

46− , memory >= 0.14.16 && < 0.19

47− , monad-time >= 0.3.1.0 && < 0.4

48− , mtl ^>= 2.2.2 || ^>= 2.3.1

49− , servant >= 0.13 && < 0.20

50− , servant-auth == 0.4.*

51− , servant-server >= 0.13 && < 0.20

52− , tagged >= 0.8.4 && < 0.9

53− , text >= 1.2.3.0 && < 2.1

54− , time >= 1.5.0.1 && < 1.13

55− , unordered-containers >= 0.2.9.0 && < 0.3

56− , wai >= 3.2.1.2 && < 3.3

57−

58− if impl(ghc >= 9)

59− build-depends:

60− -- base64-bytestring 1.2.1.0 contains important fix for GHC-9, lower versions

61− -- produce wrong results, thus corrupring JWT via jose package.

62− -- See: https://github.com/haskell/base64-bytestring/pull/46

63− base64-bytestring >= 1.2.1.0

64−

65− exposed-modules:

66− Servant.Auth.Server

67− Servant.Auth.Server.Internal

68− Servant.Auth.Server.Internal.AddSetCookie

69− Servant.Auth.Server.Internal.BasicAuth

70− Servant.Auth.Server.Internal.Class

71− Servant.Auth.Server.Internal.ConfigTypes

72− Servant.Auth.Server.Internal.Cookie

73− Servant.Auth.Server.Internal.FormLogin

74− Servant.Auth.Server.Internal.JWT

75− Servant.Auth.Server.Internal.ThrowAll

76− Servant.Auth.Server.Internal.Types

77− Servant.Auth.Server.SetCookieOrphan

78− default-language: Haskell2010

79−

80−test-suite readme

81− type: exitcode-stdio-1.0

82− main-is: README.lhs

83− default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators

84− ghc-options: -Wall -pgmL markdown-unlit

85− build-tool-depends: markdown-unlit:markdown-unlit

86− build-depends:

87− base

88− , servant-auth

89− , servant-auth-server

90− , servant-server

91− , aeson

92− , mtl

93− , warp

94− default-language: Haskell2010

95− if impl(ghcjs)

96− buildable: False

97−

98−test-suite spec

99− type: exitcode-stdio-1.0

100− main-is: Spec.hs

101− hs-source-dirs:

102− test

103− default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators

104− ghc-options: -Wall

105− build-tool-depends: hspec-discover:hspec-discover >=2.5.5 && <2.10

106−

107− -- dependencies with bounds inherited from the library stanza

108− build-depends:

109− base

110− , aeson

111− , bytestring

112− , case-insensitive

113− , jose

114− , lens

115− , mtl

116− , time

117− , http-types

118− , wai

119− , servant

120− , servant-server

121− , transformers

122−

123− -- test dependencies

124− build-depends:

125− servant-auth-server

126− , hspec >= 2.5.5 && < 2.10

127− , QuickCheck >= 2.11.3 && < 2.15

128− , http-client >= 0.5.13.1 && < 0.8

129− , lens-aeson >= 1.0.2 && < 1.3

130− , warp >= 3.2.25 && < 3.4

131− , wreq >= 0.5.2.1 && < 0.6

132− , text >= 1.2.3.0 && < 2.1

133− other-modules:

134− Servant.Auth.ServerSpec

135− default-language: Haskell2010

servant-auth/servant-auth-server/src/Servant/Auth/Server.hsdeleted−180

@@ -1,180 +0,0 @@

1−module Servant.Auth.Server

2− (

3− -- | This package provides implementations for some common authentication

4− -- methods. Authentication yields a trustworthy (because generated by the

5− -- server) value of an some arbitrary type:

6− --

7− -- > type MyApi = Protected

8− -- >

9− -- > type Protected = Auth '[JWT, Cookie] User :> Get '[JSON] UserAccountDetails

10− -- >

11− -- > server :: Server Protected

12− -- > server (Authenticated usr) = ... -- here we know the client really is

13− -- > -- who she claims to be

14− -- > server _ = throwAll err401

15− --

16− -- Additional configuration happens via 'Context'.

17− --

18− -- == Example for Custom Handler

19− -- To use a custom 'Servant.Server.Handler' it is necessary to use

20− -- 'Servant.Server.hoistServerWithContext' instead of

21− -- 'Servant.Server.hoistServer' and specify the 'Context'.

22− --

23− -- Below is an example of passing 'CookieSettings' and 'JWTSettings' in the

24− -- 'Context' to create a specialized function equivalent to

25− -- 'Servant.Server.hoistServer' for an API that includes cookie

26− -- authentication.

27− --

28− -- > hoistServerWithAuth

29− -- > :: HasServer api '[CookieSettings, JWTSettings]

30− -- > => Proxy api

31− -- > -> (forall x. m x -> n x)

32− -- > -> ServerT api m

33− -- > -> ServerT api n

34− -- > hoistServerWithAuth api =

35− -- > hoistServerWithContext api (Proxy :: Proxy '[CookieSettings, JWTSettings])

36−

37− ----------------------------------------------------------------------------

38− -- * Auth

39− -- | Basic types

40− Auth

41− , AuthResult(..)

42− , AuthCheck(..)

43−

44− ----------------------------------------------------------------------------

45− -- * JWT

46− -- | JSON Web Tokens (JWT) are a compact and secure way of transferring

47− -- information between parties. In this library, they are signed by the

48− -- server (or by some other party posessing the relevant key), and used to

49− -- indicate the bearer's identity or authorization.

50− --

51− -- Arbitrary information can be encoded - just declare instances for the

52− -- 'FromJWT' and 'ToJWT' classes. Don't go overboard though - be aware that

53− -- usually you'll be trasmitting this information on each request (and

54− -- response!).

55− --

56− -- Note that, while the tokens are signed, they are not encrypted. Do not put

57− -- any information you do not wish the client to know in them!

58−

59− -- ** Combinator

60− -- | Re-exported from 'servant-auth'

61− , JWT

62−

63− -- ** Classes

64− , FromJWT(..)

65− , ToJWT(..)

66−

67− -- ** Related types

68− , IsMatch(..)

69−

70− -- ** Settings

71− , JWTSettings(..)

72− , defaultJWTSettings

73−

74− -- ** Create check

75− , jwtAuthCheck

76−

77−

78− ----------------------------------------------------------------------------

79− -- * Cookie

80− -- | Cookies are also a method of identifying and authenticating a user. They

81− -- are particular common when the client is a browser

82−

83− -- ** Combinator

84− -- | Re-exported from 'servant-auth'

85− , Cookie

86−

87− -- ** Settings

88− , CookieSettings(..)

89− , XsrfCookieSettings(..)

90− , defaultCookieSettings

91− , defaultXsrfCookieSettings

92− , makeSessionCookie

93− , makeSessionCookieBS

94− , makeXsrfCookie

95− , makeCsrfCookie

96− , makeCookie

97− , makeCookieBS

98− , acceptLogin

99− , clearSession

100−

101−

102− -- ** Related types

103− , IsSecure(..)

104− , SameSite(..)

105− , AreAuths

106−

107− ----------------------------------------------------------------------------

108− -- * BasicAuth

109− -- ** Combinator

110− -- | Re-exported from 'servant-auth'

111− , BasicAuth

112−

113− -- ** Classes

114− , FromBasicAuthData(..)

115−

116− -- ** Settings

117− , BasicAuthCfg

118−

119− -- ** Related types

120− , BasicAuthData(..)

121− , IsPasswordCorrect(..)

122−

123− -- ** Authentication request

124− , wwwAuthenticatedErr

125−

126− ----------------------------------------------------------------------------

127− -- * Utilies

128− , ThrowAll(throwAll)

129− , generateKey

130− , generateSecret

131− , fromSecret

132− , writeKey

133− , readKey

134− , makeJWT

135− , verifyJWT

136−

137− -- ** Re-exports

138− , Default(def)

139− , SetCookie

140− ) where

141−

142−import Prelude hiding (readFile, writeFile)

143−import Data.ByteString (ByteString, writeFile, readFile)

144−import Data.Default.Class (Default (def))

145−import Servant.Auth

146−import Servant.Auth.JWT

147−import Servant.Auth.Server.Internal ()

148−import Servant.Auth.Server.Internal.BasicAuth

149−import Servant.Auth.Server.Internal.Class

150−import Servant.Auth.Server.Internal.ConfigTypes

151−import Servant.Auth.Server.Internal.Cookie

152−import Servant.Auth.Server.Internal.JWT

153−import Servant.Auth.Server.Internal.ThrowAll

154−import Servant.Auth.Server.Internal.Types

155−

156−import Crypto.JOSE as Jose

157−import Servant (BasicAuthData (..))

158−import Web.Cookie (SetCookie)

159−

160−-- | Generate a key suitable for use with 'defaultConfig'.

161−generateKey :: IO Jose.JWK

162−generateKey = Jose.genJWK $ Jose.OctGenParam 256

163−

164−-- | Generate a bytestring suitable for use with 'fromSecret'.

165−generateSecret :: MonadRandom m => m ByteString

166−generateSecret = Jose.getRandomBytes 256

167−

168−-- | Restores a key from a bytestring.

169−fromSecret :: ByteString -> Jose.JWK

170−fromSecret = Jose.fromOctets

171−

172−-- | Writes a secret to a file. Can for instance be used from the REPL

173−-- to persist a key to a file, which can then be included with the

174−-- application. Restore the key using 'readKey'.

175−writeKey :: FilePath -> IO ()

176−writeKey fp = writeFile fp =<< generateSecret

177−

178−-- | Reads a key from a file.

179−readKey :: FilePath -> IO Jose.JWK

180−readKey fp = fromSecret <$> readFile fp

servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal.hsdeleted−67

@@ -1,67 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE UndecidableInstances #-}

3−{-# OPTIONS_GHC -fno-warn-orphans #-}

4−

5−module Servant.Auth.Server.Internal where

6−

7−import Control.Monad.Trans (liftIO)

8−import Servant ((:>), Handler, HasServer (..),

9− Proxy (..),

10− HasContextEntry(getContextEntry))

11−import Servant.Auth

12−import Servant.Auth.JWT (ToJWT)

13−

14−import Servant.Auth.Server.Internal.AddSetCookie

15−import Servant.Auth.Server.Internal.Class

16−import Servant.Auth.Server.Internal.Cookie

17−import Servant.Auth.Server.Internal.ConfigTypes

18−import Servant.Auth.Server.Internal.JWT

19−import Servant.Auth.Server.Internal.Types

20−

21−import Servant.Server.Internal (DelayedIO, addAuthCheck, withRequest)

22−

23−instance ( n ~ 'S ('S 'Z)

24− , HasServer (AddSetCookiesApi n api) ctxs, AreAuths auths ctxs v

25− , HasServer api ctxs -- this constraint is needed to implement hoistServer

26− , AddSetCookies n (ServerT api Handler) (ServerT (AddSetCookiesApi n api) Handler)

27− , ToJWT v

28− , HasContextEntry ctxs CookieSettings

29− , HasContextEntry ctxs JWTSettings

30− ) => HasServer (Auth auths v :> api) ctxs where

31− type ServerT (Auth auths v :> api) m = AuthResult v -> ServerT api m

32−

33−#if MIN_VERSION_servant_server(0,12,0)

34− hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s

35−#endif

36−

37− route _ context subserver =

38− route (Proxy :: Proxy (AddSetCookiesApi n api))

39− context

40− (fmap go subserver `addAuthCheck` authCheck)

41−

42− where

43− authCheck :: DelayedIO (AuthResult v, SetCookieList ('S ('S 'Z)))

44− authCheck = withRequest $ \req -> liftIO $ do

45− authResult <- runAuthCheck (runAuths (Proxy :: Proxy auths) context) req

46− cookies <- makeCookies authResult

47− return (authResult, cookies)

48−

49− jwtSettings :: JWTSettings

50− jwtSettings = getContextEntry context

51−

52− cookieSettings :: CookieSettings

53− cookieSettings = getContextEntry context

54−

55− makeCookies :: AuthResult v -> IO (SetCookieList ('S ('S 'Z)))

56− makeCookies authResult = do

57− case authResult of

58− (Authenticated v) -> do

59− ejwt <- makeSessionCookie cookieSettings jwtSettings v

60− xsrf <- makeXsrfCookie cookieSettings

61− return $ Just xsrf `SetCookieCons` (ejwt `SetCookieCons` SetCookieNil)

62− _ -> return $ Nothing `SetCookieCons` (Nothing `SetCookieCons` SetCookieNil)

63−

64− go :: (AuthResult v -> ServerT api Handler)

65− -> (AuthResult v, SetCookieList n)

66− -> ServerT (AddSetCookiesApi n api) Handler

67− go fn (authResult, cookies) = addSetCookies cookies $ fn authResult

servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/AddSetCookie.hsdeleted−119

@@ -1,119 +0,0 @@

1−{-# LANGUAGE PolyKinds #-}

2−{-# LANGUAGE TupleSections #-}

3−{-# LANGUAGE UndecidableInstances #-}

4−{-# LANGUAGE CPP #-}

5−

6−module Servant.Auth.Server.Internal.AddSetCookie where

7−

8−import Blaze.ByteString.Builder (toByteString)

9−import qualified Data.ByteString as BS

10−import Data.Tagged (Tagged (..))

11−import qualified Network.HTTP.Types as HTTP

12−import Network.Wai (mapResponseHeaders)

13−import Servant

14−import Servant.API.UVerb.Union

15−import Servant.API.Generic

16−import Servant.Server.Generic

17−import Web.Cookie

18−

19−-- What are we doing here? Well, the idea is to add headers to the response,

20−-- but the headers come from the authentication check. In order to do that, we

21−-- tweak a little the general theme of recursing down the API tree; this time,

22−-- we recurse down a variation of it that adds headers to all the endpoints.

23−-- This involves the usual type-level checks.

24−--

25−-- TODO: If the endpoints already have headers, this will not work as is.

26−

27−data Nat = Z | S Nat

28−

29−type family AddSetCookiesApi (n :: Nat) a where

30− AddSetCookiesApi ('S 'Z) a = AddSetCookieApi a

31− AddSetCookiesApi ('S n) a = AddSetCookiesApi n (AddSetCookieApi a)

32−

33−type family AddSetCookieApiVerb a where

34− AddSetCookieApiVerb (Headers ls a) = Headers (Header "Set-Cookie" SetCookie ': ls) a

35− AddSetCookieApiVerb a = Headers '[Header "Set-Cookie" SetCookie] a

36−

37−#if MIN_VERSION_servant_server(0,18,1)

38−type family MapAddSetCookieApiVerb (as :: [*]) where

39− MapAddSetCookieApiVerb '[] = '[]

40− MapAddSetCookieApiVerb (a ': as) = (AddSetCookieApiVerb a ': MapAddSetCookieApiVerb as)

41−#endif

42−

43−type family AddSetCookieApi a :: *

44−type instance AddSetCookieApi (a :> b) = a :> AddSetCookieApi b

45−type instance AddSetCookieApi (a :<|> b) = AddSetCookieApi a :<|> AddSetCookieApi b

46−#if MIN_VERSION_servant_server(0,19,0)

47−type instance AddSetCookieApi (NamedRoutes api) = AddSetCookieApi (ToServantApi api)

48−#endif

49−type instance AddSetCookieApi (Verb method stat ctyps a)

50− = Verb method stat ctyps (AddSetCookieApiVerb a)

51−#if MIN_VERSION_servant_server(0,18,1)

52−type instance AddSetCookieApi (UVerb method ctyps as)

53− = UVerb method ctyps (MapAddSetCookieApiVerb as)

54−#endif

55−type instance AddSetCookieApi Raw = Raw

56−#if MIN_VERSION_servant_server(0,15,0)

57−type instance AddSetCookieApi (Stream method stat framing ctyps a)

58− = Stream method stat framing ctyps (AddSetCookieApiVerb a)

59−#endif

60−type instance AddSetCookieApi (Headers hs a) = AddSetCookieApiVerb (Headers hs a)

61−

62−data SetCookieList (n :: Nat) :: * where

63− SetCookieNil :: SetCookieList 'Z

64− SetCookieCons :: Maybe SetCookie -> SetCookieList n -> SetCookieList ('S n)

65−

66−class AddSetCookies (n :: Nat) orig new where

67− addSetCookies :: SetCookieList n -> orig -> new

68−

69−instance {-# OVERLAPS #-} AddSetCookies ('S n) oldb newb

70− => AddSetCookies ('S n) (a -> oldb) (a -> newb) where

71− addSetCookies cookies oldfn = addSetCookies cookies . oldfn

72−

73−instance (orig1 ~ orig2) => AddSetCookies 'Z orig1 orig2 where

74− addSetCookies _ = id

75−

76−instance {-# OVERLAPPABLE #-}

77− ( Functor m

78− , AddSetCookies n (m old) (m cookied)

79− , AddHeader "Set-Cookie" SetCookie cookied new

80− ) => AddSetCookies ('S n) (m old) (m new) where

81− addSetCookies (mCookie `SetCookieCons` rest) oldVal =

82− case mCookie of

83− Nothing -> noHeader <$> addSetCookies rest oldVal

84− Just cookie -> addHeader cookie <$> addSetCookies rest oldVal

85−

86−instance {-# OVERLAPS #-}

87− (AddSetCookies ('S n) a a', AddSetCookies ('S n) b b')

88− => AddSetCookies ('S n) (a :<|> b) (a' :<|> b') where

89− addSetCookies cookies (a :<|> b) = addSetCookies cookies a :<|> addSetCookies cookies b

90−

91−instance {-# OVERLAPS #-}

92− ( AddSetCookies ('S n) (ServerT (ToServantApi api) m) cookiedApi

93− , Generic (api (AsServerT m))

94− , GServantProduct (Rep (api (AsServerT m)))

95− , ToServant api (AsServerT m) ~ ServerT (ToServantApi api) m

96− )

97− => AddSetCookies ('S n) (api (AsServerT m)) cookiedApi where

98− addSetCookies cookies = addSetCookies cookies . toServant

99−

100−-- | for @servant <0.11@

101−instance

102− AddSetCookies ('S n) Application Application where

103− addSetCookies cookies r request respond

104− = r request $ respond . mapResponseHeaders (++ mkHeaders cookies)

105−

106−-- | for @servant >=0.11@

107−instance

108− AddSetCookies ('S n) (Tagged m Application) (Tagged m Application) where

109− addSetCookies cookies r = Tagged $ \request respond ->

110− unTagged r request $ respond . mapResponseHeaders (++ mkHeaders cookies)

111−

112−mkHeaders :: SetCookieList x -> [HTTP.Header]

113−mkHeaders x = ("Set-Cookie",) <$> mkCookies x

114− where

115− mkCookies :: forall y. SetCookieList y -> [BS.ByteString]

116− mkCookies SetCookieNil = []

117− mkCookies (SetCookieCons Nothing rest) = mkCookies rest

118− mkCookies (SetCookieCons (Just y) rest)

119− = toByteString (renderSetCookie y) : mkCookies rest

servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/BasicAuth.hsdeleted−59

@@ -1,59 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−module Servant.Auth.Server.Internal.BasicAuth where

3−

4−#if !MIN_VERSION_servant_server(0,16,0)

5−#define ServerError ServantErr

6−#endif

7−

8−import qualified Data.ByteString as BS

9−import Servant (BasicAuthData (..),

10− ServerError (..), err401)

11−import Servant.Server.Internal.BasicAuth (decodeBAHdr,

12− mkBAChallengerHdr)

13−

14−import Servant.Auth.Server.Internal.Types

15−

16−-- | A 'ServerError' that asks the client to authenticate via Basic

17−-- Authentication, should be invoked by an application whenever

18−-- appropriate. The argument is the realm.

19−wwwAuthenticatedErr :: BS.ByteString -> ServerError

20−wwwAuthenticatedErr realm = err401 { errHeaders = [mkBAChallengerHdr realm] }

21−

22−-- | A type holding the configuration for Basic Authentication.

23−-- It is defined as a type family with no arguments, so that

24−-- it can be instantiated to whatever type you need to

25−-- authenticate your users (use @type instance BasicAuthCfg = ...@).

26−--

27−-- Note that the instantiation is application-wide,

28−-- i.e. there can be only one instance.

29−-- As a consequence, it should not be instantiated in a library.

30−--

31−-- Basic Authentication expects an element of type 'BasicAuthCfg'

32−-- to be in the 'Context'; that element is then passed automatically

33−-- to the instance of 'FromBasicAuthData' together with the

34−-- authentication data obtained from the client.

35−--

36−-- If you do not need a configuration for Basic Authentication,

37−-- you can use just @BasicAuthCfg = ()@, and recall to also

38−-- add @()@ to the 'Context'.

39−-- A basic but more interesting example is to take as 'BasicAuthCfg'

40−-- a list of authorised username/password pairs:

41−--

42−-- > deriving instance Eq BasicAuthData

43−-- > type instance BasicAuthCfg = [BasicAuthData]

44−-- > instance FromBasicAuthData User where

45−-- > fromBasicAuthData authData authCfg =

46−-- > if elem authData authCfg then ...

47−type family BasicAuthCfg

48−

49−class FromBasicAuthData a where

50− -- | Whether the username exists and the password is correct.

51− -- Note that, rather than passing a 'Pass' to the function, we pass a

52− -- function that checks an 'EncryptedPass'. This is to make sure you don't

53− -- accidentally do something untoward with the password, like store it.

54− fromBasicAuthData :: BasicAuthData -> BasicAuthCfg -> IO (AuthResult a)

55−

56−basicAuthCheck :: FromBasicAuthData usr => BasicAuthCfg -> AuthCheck usr

57−basicAuthCheck cfg = AuthCheck $ \req -> case decodeBAHdr req of

58− Nothing -> return Indefinite

59− Just baData -> fromBasicAuthData baData cfg

servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/Class.hsdeleted−72

@@ -1,72 +0,0 @@

1−{-# LANGUAGE UndecidableInstances #-}

2−module Servant.Auth.Server.Internal.Class where

3−

4−import Servant.Auth

5−import Data.Monoid

6−import Servant hiding (BasicAuth)

7−

8−import Servant.Auth.JWT

9−import Servant.Auth.Server.Internal.Types

10−import Servant.Auth.Server.Internal.ConfigTypes

11−import Servant.Auth.Server.Internal.BasicAuth

12−import Servant.Auth.Server.Internal.Cookie

13−import Servant.Auth.Server.Internal.JWT (jwtAuthCheck)

14−

15−-- | @IsAuth a ctx v@ indicates that @a@ is an auth type that expects all

16−-- elements of @ctx@ to be the in the Context and whose authentication check

17−-- returns an @AuthCheck v@.

18−class IsAuth a v where

19− type family AuthArgs a :: [*]

20− runAuth :: proxy a -> proxy v -> Unapp (AuthArgs a) (AuthCheck v)

21−

22−instance FromJWT usr => IsAuth Cookie usr where

23− type AuthArgs Cookie = '[CookieSettings, JWTSettings]

24− runAuth _ _ = cookieAuthCheck

25−

26−instance FromJWT usr => IsAuth JWT usr where

27− type AuthArgs JWT = '[JWTSettings]

28− runAuth _ _ = jwtAuthCheck

29−

30−instance FromBasicAuthData usr => IsAuth BasicAuth usr where

31− type AuthArgs BasicAuth = '[BasicAuthCfg]

32− runAuth _ _ = basicAuthCheck

33−

34−-- * Helper

35−

36−class AreAuths (as :: [*]) (ctxs :: [*]) v where

37− runAuths :: proxy as -> Context ctxs -> AuthCheck v

38−

39−instance AreAuths '[] ctxs v where

40− runAuths _ _ = mempty

41−

42−instance ( AuthCheck v ~ App (AuthArgs a) (Unapp (AuthArgs a) (AuthCheck v))

43− , IsAuth a v

44− , AreAuths as ctxs v

45− , AppCtx ctxs (AuthArgs a) (Unapp (AuthArgs a) (AuthCheck v))

46− ) => AreAuths (a ': as) ctxs v where

47− runAuths _ ctxs = go <> runAuths (Proxy :: Proxy as) ctxs

48− where

49− go = appCtx (Proxy :: Proxy (AuthArgs a))

50− ctxs

51− (runAuth (Proxy :: Proxy a) (Proxy :: Proxy v))

52−

53−type family Unapp ls res where

54− Unapp '[] res = res

55− Unapp (arg1 ': rest) res = arg1 -> Unapp rest res

56−

57−type family App ls res where

58− App '[] res = res

59− App (arg1 ': rest) (arg1 -> res) = App rest res

60−

61−-- | @AppCtx@ applies the function @res@ to the arguments in @ls@ by taking the

62−-- values from the Context provided.

63−class AppCtx ctx ls res where

64− appCtx :: proxy ls -> Context ctx -> res -> App ls res

65−

66−instance ( HasContextEntry ctxs ctx

67− , AppCtx ctxs rest res

68− ) => AppCtx ctxs (ctx ': rest) (ctx -> res) where

69− appCtx _ ctx fn = appCtx (Proxy :: Proxy rest) ctx $ fn $ getContextEntry ctx

70−

71−instance AppCtx ctx '[] res where

72− appCtx _ _ r = r

servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/ConfigTypes.hsdeleted−127

@@ -1,127 +0,0 @@

1−module Servant.Auth.Server.Internal.ConfigTypes

2− ( module Servant.Auth.Server.Internal.ConfigTypes

3− , Servant.API.IsSecure(..)

4− ) where

5−

6−import Crypto.JOSE as Jose

7−import Crypto.JWT as Jose

8−import qualified Data.ByteString as BS

9−import Data.Default.Class

10−import Data.Time

11−import GHC.Generics (Generic)

12−import Servant.API (IsSecure(..))

13−

14−data IsMatch = Matches | DoesNotMatch

15− deriving (Eq, Show, Read, Generic, Ord)

16−

17−data IsPasswordCorrect = PasswordCorrect | PasswordIncorrect

18− deriving (Eq, Show, Read, Generic, Ord)

19−

20−-- The @SameSite@ attribute of cookies determines whether cookies will be sent

21−-- on cross-origin requests.

22−--

23−-- See <https://tools.ietf.org/html/draft-west-first-party-cookies-07 this document>

24−-- for more information.

25−data SameSite = AnySite | SameSiteStrict | SameSiteLax

26− deriving (Eq, Show, Read, Generic, Ord)

27−

28−-- | @JWTSettings@ are used to generate cookies, and to verify JWTs.

29−data JWTSettings = JWTSettings

30− {

31− -- | Key used to sign JWT.

32− signingKey :: Jose.JWK

33− -- | Algorithm used to sign JWT.

34− , jwtAlg :: Maybe Jose.Alg

35− -- | Keys used to validate JWT.

36− , validationKeys :: IO Jose.JWKSet

37− -- | An @aud@ predicate. The @aud@ is a string or URI that identifies the

38− -- intended recipient of the JWT.

39− , audienceMatches :: Jose.StringOrURI -> IsMatch

40− } deriving (Generic)

41−

42−-- | A @JWTSettings@ where the audience always matches.

43−defaultJWTSettings :: Jose.JWK -> JWTSettings

44−defaultJWTSettings k = JWTSettings

45− { signingKey = k

46− , jwtAlg = Nothing

47− , validationKeys = pure $ Jose.JWKSet [k]

48− , audienceMatches = const Matches }

49−

50−-- | The policies to use when generating cookies.

51−--

52−-- If *both* 'cookieMaxAge' and 'cookieExpires' are @Nothing@, browsers will

53−-- treat the cookie as a *session cookie*. These will be deleted when the

54−-- browser is closed.

55−--

56−-- Note that having the setting @Secure@ may cause testing failures if you are

57−-- not testing over HTTPS.

58−data CookieSettings = CookieSettings

59− {

60− -- | 'Secure' means browsers will only send cookies over HTTPS. Default:

61− -- @Secure@.

62− cookieIsSecure :: !IsSecure

63− -- | How long from now until the cookie expires. Default: @Nothing@.

64− , cookieMaxAge :: !(Maybe DiffTime)

65− -- | At what time the cookie expires. Default: @Nothing@.

66− , cookieExpires :: !(Maybe UTCTime)

67− -- | The URL path and sub-paths for which this cookie is used. Default: @Just "/"@.

68− , cookiePath :: !(Maybe BS.ByteString)

69− -- | Domain name, if set cookie also allows subdomains. Default: @Nothing@.

70− , cookieDomain :: !(Maybe BS.ByteString)

71− -- | 'SameSite' settings. Default: @SameSiteLax@.

72− , cookieSameSite :: !SameSite

73− -- | What name to use for the cookie used for the session.

74− , sessionCookieName :: !BS.ByteString

75− -- | The optional settings to use for XSRF protection. Default: @Just def@.

76− , cookieXsrfSetting :: !(Maybe XsrfCookieSettings)

77− } deriving (Eq, Show, Generic)

78−

79−instance Default CookieSettings where

80− def = defaultCookieSettings

81−

82−defaultCookieSettings :: CookieSettings

83−defaultCookieSettings = CookieSettings

84− { cookieIsSecure = Secure

85− , cookieMaxAge = Nothing

86− , cookieExpires = Nothing

87− , cookiePath = Just "/"

88− , cookieDomain = Nothing

89− , cookieSameSite = SameSiteLax

90− , sessionCookieName = "JWT-Cookie"

91− , cookieXsrfSetting = Just def

92− }

93−

94−-- | The policies to use when generating and verifying XSRF cookies

95−data XsrfCookieSettings = XsrfCookieSettings

96− {

97− -- | What name to use for the cookie used for XSRF protection.

98− xsrfCookieName :: !BS.ByteString

99− -- | What path to use for the cookie used for XSRF protection. Default @Just "/"@.

100− , xsrfCookiePath :: !(Maybe BS.ByteString)

101− -- | What name to use for the header used for XSRF protection.

102− , xsrfHeaderName :: !BS.ByteString

103− -- | Exclude GET request method from XSRF protection.

104− , xsrfExcludeGet :: !Bool

105− } deriving (Eq, Show, Generic)

106−

107−instance Default XsrfCookieSettings where

108− def = defaultXsrfCookieSettings

109−

110−defaultXsrfCookieSettings :: XsrfCookieSettings

111−defaultXsrfCookieSettings = XsrfCookieSettings

112− { xsrfCookieName = "XSRF-TOKEN"

113− , xsrfCookiePath = Just "/"

114− , xsrfHeaderName = "X-XSRF-TOKEN"

115− , xsrfExcludeGet = False

116− }

117−

118−------------------------------------------------------------------------------

119−-- Internal {{{

120−

121−jwtSettingsToJwtValidationSettings :: JWTSettings -> Jose.JWTValidationSettings

122−jwtSettingsToJwtValidationSettings s

123− = defaultJWTValidationSettings (toBool <$> audienceMatches s)

124− where

125− toBool Matches = True

126− toBool DoesNotMatch = False

127−-- }}}

servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/Cookie.hsdeleted−183

@@ -1,183 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−module Servant.Auth.Server.Internal.Cookie where

3−

4−import Blaze.ByteString.Builder (toByteString)

5−import Control.Monad (MonadPlus(..), guard)

6−import Control.Monad.Except

7−import Control.Monad.Reader

8−import qualified Crypto.JOSE as Jose

9−import qualified Crypto.JWT as Jose

10−import Data.ByteArray (constEq)

11−import qualified Data.ByteString as BS

12−import qualified Data.ByteString.Base64 as BS64

13−import qualified Data.ByteString.Lazy as BSL

14−import Data.CaseInsensitive (mk)

15−import Data.Maybe (fromMaybe)

16−import Data.Time.Calendar (Day(..))

17−import Data.Time.Clock (UTCTime(..), secondsToDiffTime)

18−import Network.HTTP.Types (methodGet)

19−import Network.HTTP.Types.Header(hCookie)

20−import Network.Wai (Request, requestHeaders, requestMethod)

21−import Servant (AddHeader, addHeader)

22−import System.Entropy (getEntropy)

23−import Web.Cookie

24−

25−import Servant.Auth.JWT (FromJWT (decodeJWT), ToJWT)

26−import Servant.Auth.Server.Internal.ConfigTypes

27−import Servant.Auth.Server.Internal.JWT (makeJWT, verifyJWT)

28−import Servant.Auth.Server.Internal.Types

29−

30−

31−cookieAuthCheck :: FromJWT usr => CookieSettings -> JWTSettings -> AuthCheck usr

32−cookieAuthCheck ccfg jwtSettings = do

33− req <- ask

34− jwtCookie <- maybe mempty return $ do

35− cookies' <- lookup hCookie $ requestHeaders req

36− let cookies = parseCookies cookies'

37− -- Apply the XSRF check if enabled.

38− guard $ fromMaybe True $ do

39− xsrfCookieCfg <- xsrfCheckRequired ccfg req

40− return $ xsrfCookieAuthCheck xsrfCookieCfg req cookies

41− -- session cookie *must* be HttpOnly and Secure

42− lookup (sessionCookieName ccfg) cookies

43− verifiedJWT <- liftIO $ verifyJWT jwtSettings jwtCookie

44− case verifiedJWT of

45− Nothing -> mzero

46− Just v -> return v

47−

48−xsrfCheckRequired :: CookieSettings -> Request -> Maybe XsrfCookieSettings

49−xsrfCheckRequired cookieSettings req = do

50− xsrfCookieCfg <- cookieXsrfSetting cookieSettings

51− let disableForGetReq = xsrfExcludeGet xsrfCookieCfg && requestMethod req == methodGet

52− guard $ not disableForGetReq

53− return xsrfCookieCfg

54−

55−xsrfCookieAuthCheck :: XsrfCookieSettings -> Request -> [(BS.ByteString, BS.ByteString)] -> Bool

56−xsrfCookieAuthCheck xsrfCookieCfg req cookies = fromMaybe False $ do

57− xsrfCookie <- lookup (xsrfCookieName xsrfCookieCfg) cookies

58− xsrfHeader <- lookup (mk $ xsrfHeaderName xsrfCookieCfg) $ requestHeaders req

59− return $ xsrfCookie `constEq` xsrfHeader

60−

61−-- | Makes a cookie to be used for XSRF.

62−makeXsrfCookie :: CookieSettings -> IO SetCookie

63−makeXsrfCookie cookieSettings = case cookieXsrfSetting cookieSettings of

64− Just xsrfCookieSettings -> makeRealCookie xsrfCookieSettings

65− Nothing -> return $ noXsrfTokenCookie cookieSettings

66− where

67− makeRealCookie xsrfCookieSettings = do

68− xsrfValue <- BS64.encode <$> getEntropy 32

69− return

70− $ applyXsrfCookieSettings xsrfCookieSettings

71− $ applyCookieSettings cookieSettings

72− $ def{ setCookieValue = xsrfValue }

73−

74−

75−-- | Alias for 'makeXsrfCookie'.

76−makeCsrfCookie :: CookieSettings -> IO SetCookie

77−makeCsrfCookie = makeXsrfCookie

78−{-# DEPRECATED makeCsrfCookie "Use makeXsrfCookie instead" #-}

79−

80−

81−-- | Makes a cookie with session information.

82−makeSessionCookie :: ToJWT v => CookieSettings -> JWTSettings -> v -> IO (Maybe SetCookie)

83−makeSessionCookie cookieSettings jwtSettings v = do

84− ejwt <- makeJWT v jwtSettings (cookieExpires cookieSettings)

85− case ejwt of

86− Left _ -> return Nothing

87− Right jwt -> return

88− $ Just

89− $ applySessionCookieSettings cookieSettings

90− $ applyCookieSettings cookieSettings

91− $ def{ setCookieValue = BSL.toStrict jwt }

92−

93−noXsrfTokenCookie :: CookieSettings -> SetCookie

94−noXsrfTokenCookie cookieSettings =

95− applyCookieSettings cookieSettings $ def{ setCookieName = "NO-XSRF-TOKEN", setCookieValue = "" }

96−

97−applyCookieSettings :: CookieSettings -> SetCookie -> SetCookie

98−applyCookieSettings cookieSettings setCookie = setCookie

99− { setCookieMaxAge = cookieMaxAge cookieSettings

100− , setCookieExpires = cookieExpires cookieSettings

101− , setCookiePath = cookiePath cookieSettings

102− , setCookieDomain = cookieDomain cookieSettings

103− , setCookieSecure = case cookieIsSecure cookieSettings of

104− Secure -> True

105− NotSecure -> False

106− }

107−

108−applyXsrfCookieSettings :: XsrfCookieSettings -> SetCookie -> SetCookie

109−applyXsrfCookieSettings xsrfCookieSettings setCookie = setCookie

110− { setCookieName = xsrfCookieName xsrfCookieSettings

111− , setCookiePath = xsrfCookiePath xsrfCookieSettings

112− , setCookieHttpOnly = False

113− }

114−

115−applySessionCookieSettings :: CookieSettings -> SetCookie -> SetCookie

116−applySessionCookieSettings cookieSettings setCookie = setCookie

117− { setCookieName = sessionCookieName cookieSettings

118− , setCookieSameSite = case cookieSameSite cookieSettings of

119− AnySite -> anySite

120− SameSiteStrict -> Just sameSiteStrict

121− SameSiteLax -> Just sameSiteLax

122− , setCookieHttpOnly = True

123− }

124− where

125−#if MIN_VERSION_cookie(0,4,5)

126− anySite = Just sameSiteNone

127−#else

128− anySite = Nothing

129−#endif

130−

131−-- | For a JWT-serializable session, returns a function that decorates a

132−-- provided response object with XSRF and session cookies. This should be used

133−-- when a user successfully authenticates with credentials.

134−acceptLogin :: ( ToJWT session

135− , AddHeader "Set-Cookie" SetCookie response withOneCookie

136− , AddHeader "Set-Cookie" SetCookie withOneCookie withTwoCookies )

137− => CookieSettings

138− -> JWTSettings

139− -> session

140− -> IO (Maybe (response -> withTwoCookies))

141−acceptLogin cookieSettings jwtSettings session = do

142− mSessionCookie <- makeSessionCookie cookieSettings jwtSettings session

143− case mSessionCookie of

144− Nothing -> pure Nothing

145− Just sessionCookie -> do

146− xsrfCookie <- makeXsrfCookie cookieSettings

147− return $ Just $ addHeader sessionCookie . addHeader xsrfCookie

148−

149−-- | Arbitrary cookie expiry time set back in history after unix time 0

150−expireTime :: UTCTime

151−expireTime = UTCTime (ModifiedJulianDay 50000) 0

152−

153−-- | Adds headers to a response that clears all session cookies

154−-- | using max-age and expires cookie attributes.

155−clearSession :: ( AddHeader "Set-Cookie" SetCookie response withOneCookie

156− , AddHeader "Set-Cookie" SetCookie withOneCookie withTwoCookies )

157− => CookieSettings

158− -> response

159− -> withTwoCookies

160−clearSession cookieSettings = addHeader clearedSessionCookie . addHeader clearedXsrfCookie

161− where

162− -- According to RFC6265 max-age takes precedence, but IE/Edge ignore it completely so we set both

163− cookieSettingsExpires = cookieSettings

164− { cookieExpires = Just expireTime

165− , cookieMaxAge = Just (secondsToDiffTime 0)

166− }

167− clearedSessionCookie = applySessionCookieSettings cookieSettingsExpires $ applyCookieSettings cookieSettingsExpires def

168− clearedXsrfCookie = case cookieXsrfSetting cookieSettings of

169− Just xsrfCookieSettings -> applyXsrfCookieSettings xsrfCookieSettings $ applyCookieSettings cookieSettingsExpires def

170− Nothing -> noXsrfTokenCookie cookieSettingsExpires

171−

172−makeSessionCookieBS :: ToJWT v => CookieSettings -> JWTSettings -> v -> IO (Maybe BS.ByteString)

173−makeSessionCookieBS a b c = fmap (toByteString . renderSetCookie) <$> makeSessionCookie a b c

174−

175−-- | Alias for 'makeSessionCookie'.

176−makeCookie :: ToJWT v => CookieSettings -> JWTSettings -> v -> IO (Maybe SetCookie)

177−makeCookie = makeSessionCookie

178−{-# DEPRECATED makeCookie "Use makeSessionCookie instead" #-}

179−

180−-- | Alias for 'makeSessionCookieBS'.

181−makeCookieBS :: ToJWT v => CookieSettings -> JWTSettings -> v -> IO (Maybe BS.ByteString)

182−makeCookieBS = makeSessionCookieBS

183−{-# DEPRECATED makeCookieBS "Use makeSessionCookieBS instead" #-}

servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/FormLogin.hsdeleted−3

@@ -1,3 +0,0 @@

1−module Servant.Auth.Server.Internal.FormLogin where

2−

3−

servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/JWT.hsdeleted−68

@@ -1,68 +0,0 @@

1−module Servant.Auth.Server.Internal.JWT where

2−

3−import Control.Lens

4−import Control.Monad (MonadPlus(..), guard)

5−import Control.Monad.Reader

6−import qualified Crypto.JOSE as Jose

7−import qualified Crypto.JWT as Jose

8−import Data.ByteArray (constEq)

9−import qualified Data.ByteString as BS

10−import qualified Data.ByteString.Lazy as BSL

11−import Data.Maybe (fromMaybe)

12−import Data.Time (UTCTime)

13−import Network.Wai (requestHeaders)

14−

15−import Servant.Auth.JWT (FromJWT(..), ToJWT(..))

16−import Servant.Auth.Server.Internal.ConfigTypes

17−import Servant.Auth.Server.Internal.Types

18−

19−

20−-- | A JWT @AuthCheck@. You likely won't need to use this directly unless you

21−-- are protecting a @Raw@ endpoint.

22−jwtAuthCheck :: FromJWT usr => JWTSettings -> AuthCheck usr

23−jwtAuthCheck jwtSettings = do

24− req <- ask

25− token <- maybe mempty return $ do

26− authHdr <- lookup "Authorization" $ requestHeaders req

27− let bearer = "Bearer "

28− (mbearer, rest) = BS.splitAt (BS.length bearer) authHdr

29− guard (mbearer `constEq` bearer)

30− return rest

31− verifiedJWT <- liftIO $ verifyJWT jwtSettings token

32− case verifiedJWT of

33− Nothing -> mzero

34− Just v -> return v

35−

36−-- | Creates a JWT containing the specified data. The data is stored in the

37−-- @dat@ claim. The 'Maybe UTCTime' argument indicates the time at which the

38−-- token expires.

39−makeJWT :: ToJWT a

40− => a -> JWTSettings -> Maybe UTCTime -> IO (Either Jose.Error BSL.ByteString)

41−makeJWT v cfg expiry = Jose.runJOSE $ do

42− bestAlg <- Jose.bestJWSAlg $ signingKey cfg

43− let alg = fromMaybe bestAlg $ jwtAlg cfg

44− ejwt <- Jose.signClaims (signingKey cfg)

45− (Jose.newJWSHeader ((), alg))

46− (addExp $ encodeJWT v)

47−

48− return $ Jose.encodeCompact ejwt

49− where

50− addExp claims = case expiry of

51− Nothing -> claims

52− Just e -> claims & Jose.claimExp ?~ Jose.NumericDate e

53−

54−

55−verifyJWT :: FromJWT a => JWTSettings -> BS.ByteString -> IO (Maybe a)

56−verifyJWT jwtCfg input = do

57− keys <- validationKeys jwtCfg

58− verifiedJWT <- Jose.runJOSE $ do

59− unverifiedJWT <- Jose.decodeCompact (BSL.fromStrict input)

60− Jose.verifyClaims

61− (jwtSettingsToJwtValidationSettings jwtCfg)

62− keys

63− unverifiedJWT

64− return $ case verifiedJWT of

65− Left (_ :: Jose.JWTError) -> Nothing

66− Right v -> case decodeJWT v of

67− Left _ -> Nothing

68− Right v' -> Just v'

servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/ThrowAll.hsdeleted−58

@@ -1,58 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE UndecidableInstances #-}

3−module Servant.Auth.Server.Internal.ThrowAll where

4−

5−#if !MIN_VERSION_servant_server(0,16,0)

6−#define ServerError ServantErr

7−#endif

8−

9−import Control.Monad.Error.Class

10−import Data.Tagged (Tagged (..))

11−import Servant ((:<|>) (..), ServerError(..), NamedRoutes(..))

12−import Servant.API.Generic

13−import Servant.Server.Generic

14−import Servant.Server

15−import Network.HTTP.Types

16−import Network.Wai

17−

18−import qualified Data.ByteString.Char8 as BS

19−

20−class ThrowAll a where

21− -- | 'throwAll' is a convenience function to throw errors across an entire

22− -- sub-API

23− --

24− --

25− -- > throwAll err400 :: Handler a :<|> Handler b :<|> Handler c

26− -- > == throwError err400 :<|> throwError err400 :<|> err400

27− throwAll :: ServerError -> a

28−

29−instance (ThrowAll a, ThrowAll b) => ThrowAll (a :<|> b) where

30− throwAll e = throwAll e :<|> throwAll e

31−

32−instance

33− ( ThrowAll (ToServant api (AsServerT m)) , GenericServant api (AsServerT m)) =>

34− ThrowAll (api (AsServerT m)) where

35−

36− throwAll = fromServant . throwAll

37−

38−-- Really this shouldn't be necessary - ((->) a) should be an instance of

39−-- MonadError, no?

40−instance {-# OVERLAPPING #-} ThrowAll b => ThrowAll (a -> b) where

41− throwAll e = const $ throwAll e

42−

43−instance {-# OVERLAPPABLE #-} (MonadError ServerError m) => ThrowAll (m a) where

44− throwAll = throwError

45−

46−-- | for @servant <0.11@

47−instance {-# OVERLAPPING #-} ThrowAll Application where

48− throwAll e _req respond

49− = respond $ responseLBS (mkStatus (errHTTPCode e) (BS.pack $ errReasonPhrase e))

50− (errHeaders e)

51− (errBody e)

52−

53−-- | for @servant >=0.11@

54−instance {-# OVERLAPPING #-} MonadError ServerError m => ThrowAll (Tagged m Application) where

55− throwAll e = Tagged $ \_req respond ->

56− respond $ responseLBS (mkStatus (errHTTPCode e) (BS.pack $ errReasonPhrase e))

57− (errHeaders e)

58− (errBody e)

servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/Types.hsdeleted−113

@@ -1,113 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−module Servant.Auth.Server.Internal.Types where

3−

4−import Control.Applicative

5−import Control.Monad (MonadPlus(..), ap)

6−import Control.Monad.Reader

7−import Control.Monad.Time

8−import Data.Monoid (Monoid (..))

9−import Data.Semigroup (Semigroup (..))

10−import Data.Time (getCurrentTime)

11−import GHC.Generics (Generic)

12−import Network.Wai (Request)

13−

14−import qualified Control.Monad.Fail as Fail

15−

16−-- | The result of an authentication attempt.

17−data AuthResult val

18− = BadPassword

19− | NoSuchUser

20− -- | Authentication succeeded.

21− | Authenticated val

22− -- | If an authentication procedure cannot be carried out - if for example it

23− -- expects a password and username in a header that is not present -

24− -- @Indefinite@ is returned. This indicates that other authentication

25− -- methods should be tried.

26− | Indefinite

27− deriving (Eq, Show, Read, Generic, Ord, Functor, Traversable, Foldable)

28−

29−instance Semigroup (AuthResult val) where

30− Indefinite <> y = y

31− x <> _ = x

32−

33−instance Monoid (AuthResult val) where

34− mempty = Indefinite

35− mappend = (<>)

36−

37−instance Applicative AuthResult where

38− pure = return

39− (<*>) = ap

40−

41−instance Monad AuthResult where

42− return = Authenticated

43− Authenticated v >>= f = f v

44− BadPassword >>= _ = BadPassword

45− NoSuchUser >>= _ = NoSuchUser

46− Indefinite >>= _ = Indefinite

47−

48−instance Alternative AuthResult where

49− empty = mzero

50− (<|>) = mplus

51−

52−instance MonadPlus AuthResult where

53− mzero = mempty

54− mplus = (<>)

55−

56−

57−-- | An @AuthCheck@ is the function used to decide the authentication status

58−-- (the 'AuthResult') of a request. Different @AuthCheck@s may be combined as a

59−-- Monoid or Alternative; the semantics of this is that the *first*

60−-- non-'Indefinite' result from left to right is used and the rest are ignored.

61−newtype AuthCheck val = AuthCheck

62− { runAuthCheck :: Request -> IO (AuthResult val) }

63− deriving (Generic, Functor)

64−

65−instance Semigroup (AuthCheck val) where

66− AuthCheck f <> AuthCheck g = AuthCheck $ \x -> do

67− fx <- f x

68− case fx of

69− Indefinite -> g x

70− r -> pure r

71−

72−instance Monoid (AuthCheck val) where

73− mempty = AuthCheck $ const $ return mempty

74− mappend = (<>)

75−

76−instance Applicative AuthCheck where

77− pure = return

78− (<*>) = ap

79−

80−instance Monad AuthCheck where

81− return = AuthCheck . return . return . return

82− AuthCheck ac >>= f = AuthCheck $ \req -> do

83− aresult <- ac req

84− case aresult of

85− Authenticated usr -> runAuthCheck (f usr) req

86− BadPassword -> return BadPassword

87− NoSuchUser -> return NoSuchUser

88− Indefinite -> return Indefinite

89−

90−#if !MIN_VERSION_base(4,13,0)

91− fail = Fail.fail

92−#endif

93−

94−instance Fail.MonadFail AuthCheck where

95− fail _ = AuthCheck . const $ return Indefinite

96−

97−instance MonadReader Request AuthCheck where

98− ask = AuthCheck $ \x -> return (Authenticated x)

99− local f (AuthCheck check) = AuthCheck $ \req -> check (f req)

100−

101−instance MonadIO AuthCheck where

102− liftIO action = AuthCheck $ const $ Authenticated <$> action

103−

104−instance MonadTime AuthCheck where

105− currentTime = liftIO getCurrentTime

106−

107−instance Alternative AuthCheck where

108− empty = mzero

109− (<|>) = mplus

110−

111−instance MonadPlus AuthCheck where

112− mzero = mempty

113− mplus = (<>)

servant-auth/servant-auth-server/src/Servant/Auth/Server/SetCookieOrphan.hsdeleted−3

@@ -1,3 +0,0 @@

1−module Servant.Auth.Server.SetCookieOrphan

2− {-# DEPRECATED "instance exists in http-api-data-0.3.9. This module will be removed in next major release." #-}

3− () where

servant-auth/servant-auth-server/test/Servant/Auth/ServerSpec.hsdeleted−634

@@ -1,634 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE TypeApplications #-}

3−module Servant.Auth.ServerSpec (spec) where

4−

5−#if !MIN_VERSION_servant_server(0,16,0)

6−#define ServerError ServantErr

7−#endif

8−

9−import Control.Lens

10−import Control.Monad.IO.Class (liftIO)

11−import Crypto.JOSE (Alg (HS256, None), Error,

12− JWK, JWSHeader,

13− KeyMaterialGenParam (OctGenParam),

14− ToCompact, encodeCompact,

15− genJWK, newJWSHeader, runJOSE)

16−import Crypto.JWT (Audience (..), ClaimsSet,

17− NumericDate (NumericDate),

18− SignedJWT,

19− claimAud, claimNbf,

20− signClaims,

21− emptyClaimsSet,

22− unregisteredClaims)

23−import Data.Aeson (FromJSON, ToJSON, Value,

24− toJSON, encode)

25−import Data.Aeson.Lens (_JSON)

26−import qualified Data.ByteString as BS

27−import qualified Data.ByteString.Lazy as BSL

28−import Data.Text (Text, pack)

29−import Data.CaseInsensitive (mk)

30−import Data.Foldable (find)

31−import Data.Monoid

32−import Data.Time

33−import Data.Time.Clock (getCurrentTime)

34−import GHC.Generics (Generic)

35−import Network.HTTP.Client (cookie_http_only,

36− cookie_name, cookie_value,

37− cookie_expiry_time,

38− destroyCookieJar)

39−import Network.HTTP.Types (Status, status200,

40− status401)

41−import Network.Wai (responseLBS)

42−import Network.Wai.Handler.Warp (testWithApplication)

43−import Network.Wreq (Options, auth, basicAuth,

44− checkResponse,

45− cookieExpiryTime, cookies,

46− defaults, get, getWith, postWith,

47− header, oauth2Bearer,

48− responseBody,

49− responseCookieJar,

50− responseHeader,

51− responseStatus)

52−import Network.Wreq.Types (Postable(..))

53−import Servant hiding (BasicAuth,

54− IsSecure (..), header)

55−import Servant.API.Generic ((:-))

56−import Servant.Auth.Server

57−import Servant.Auth.Server.Internal.Cookie (expireTime)

58−import Servant.Auth.Server.SetCookieOrphan ()

59−#if MIN_VERSION_servant_server(0,15,0)

60−import qualified Servant.Types.SourceT as S

61−#endif

62−import System.IO.Unsafe (unsafePerformIO)

63−import Test.Hspec

64−import Test.QuickCheck

65−import qualified Network.HTTP.Client as HCli

66−

67−

68−

69−spec :: Spec

70−spec = do

71− authSpec

72− cookieAuthSpec

73− jwtAuthSpec

74− throwAllSpec

75− basicAuthSpec

76−

77−------------------------------------------------------------------------------

78−-- * Auth {{{

79−

80−authSpec :: Spec

81−authSpec

82− = describe "The Auth combinator"

83− $ around (testWithApplication . return $ app jwtAndCookieApi) $ do

84−

85− it "returns a 401 if all authentications are Indefinite" $ \port -> do

86− get (url port) `shouldHTTPErrorWith` status401

87−

88− it "succeeds if one authentication suceeds" $ \port -> property $

89− \(user :: User) -> do

90− jwt <- makeJWT user jwtCfg Nothing

91− opts <- addJwtToHeader jwt

92− resp <- getWith opts (url port)

93− resp ^? responseBody . _JSON `shouldBe` Just (length $ name user)

94−

95− it "fails (403) if one authentication fails" $ const $

96− pendingWith "Authentications don't yet fail, only are Indefinite"

97−

98− it "doesn't clobber pre-existing response headers" $ \port -> property $

99− \(user :: User) -> do

100− jwt <- makeJWT user jwtCfg Nothing

101− opts <- addJwtToHeader jwt

102− resp <- getWith opts (url port ++ "/header")

103− resp ^. responseHeader "Blah" `shouldBe` "1797"

104− resp ^. responseHeader "Set-Cookie" `shouldSatisfy` (/= "")

105−

106− context "Raw" $ do

107−

108− it "gets the response body" $ \port -> property $ \(user :: User) -> do

109− jwt <- makeJWT user jwtCfg Nothing

110− opts <- addJwtToHeader jwt

111− resp <- getWith opts (url port ++ "/raw")

112− resp ^. responseBody `shouldBe` "how are you?"

113−

114− it "doesn't clobber pre-existing reponse headers" $ \port -> property $

115− \(user :: User) -> do

116− jwt <- makeJWT user jwtCfg Nothing

117− opts <- addJwtToHeader jwt

118− resp <- getWith opts (url port ++ "/raw")

119− resp ^. responseHeader "hi" `shouldBe` "there"

120− resp ^. responseHeader "Set-Cookie" `shouldSatisfy` (/= "")

121−

122−

123− context "Setting cookies" $ do

124−

125− it "sets cookies that it itself accepts" $ \port -> property $ \user -> do

126− jwt <- createJWT theKey (newJWSHeader ((), HS256))

127− (claims $ toJSON user)

128− opts' <- addJwtToCookie cookieCfg jwt

129− let opts = addCookie (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"])

130− (xsrfField xsrfCookieName cookieCfg <> "=blah")

131− resp <- getWith opts (url port)

132− let (cookieJar:_) = resp ^.. responseCookieJar

133− Just xxsrf = find (\x -> cookie_name x == xsrfField xsrfCookieName cookieCfg)

134− $ destroyCookieJar cookieJar

135− opts2 = defaults

136− & cookies .~ Just cookieJar

137− & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ [cookie_value xxsrf]

138− resp2 <- getWith opts2 (url port)

139− resp2 ^? responseBody . _JSON `shouldBe` Just (length $ name user)

140−

141− it "uses the Expiry from the configuration" $ \port -> property $ \(user :: User) -> do

142− jwt <- createJWT theKey (newJWSHeader ((), HS256))

143− (claims $ toJSON user)

144− opts' <- addJwtToCookie cookieCfg jwt

145− let opts = addCookie (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"])

146− (xsrfField xsrfCookieName cookieCfg <> "=blah")

147− resp <- getWith opts (url port)

148− let (cookieJar:_) = resp ^.. responseCookieJar

149− Just xxsrf = find (\x -> cookie_name x == xsrfField xsrfCookieName cookieCfg)

150− $ destroyCookieJar cookieJar

151− xxsrf ^. cookieExpiryTime `shouldBe` future

152−

153− it "sets the token cookie as HttpOnly" $ \port -> property $ \(user :: User) -> do

154− jwt <- createJWT theKey (newJWSHeader ((), HS256))

155− (claims $ toJSON user)

156− opts' <- addJwtToCookie cookieCfg jwt

157− let opts = addCookie (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"])

158− (xsrfField xsrfCookieName cookieCfg <> "=blah")

159− resp <- getWith opts (url port)

160− let (cookieJar:_) = resp ^.. responseCookieJar

161− Just token = find (\x -> cookie_name x == sessionCookieName cookieCfg)

162− $ destroyCookieJar cookieJar

163− cookie_http_only token `shouldBe` True

164−

165−

166−

167−-- }}}

168−------------------------------------------------------------------------------

169−-- * Cookie Auth {{{

170−

171−cookieAuthSpec :: Spec

172−cookieAuthSpec

173− = describe "The Auth combinator" $ do

174− describe "With XSRF check" $

175− around (testWithApplication . return $ app cookieOnlyApi) $ do

176−

177− it "fails if XSRF header and cookie don't match" $ \port -> property

178− $ \(user :: User) -> do

179− jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)

180− opts' <- addJwtToCookie cookieCfg jwt

181− let opts = addCookie (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"])

182− (xsrfField xsrfCookieName cookieCfg <> "=blerg")

183− getWith opts (url port) `shouldHTTPErrorWith` status401

184−

185− it "fails with no XSRF header or cookie" $ \port -> property

186− $ \(user :: User) -> do

187− jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)

188− opts' <- addJwtToCookie cookieCfg jwt

189− let opts = opts' & checkResponse .~ Just mempty

190− resp <- getWith opts (url port)

191− resp ^. responseStatus `shouldBe` status401

192− (resp ^. responseCookieJar) `shouldNotHaveCookies` ["XSRF-TOKEN"]

193−

194− -- Validating that the XSRF cookie isn't added for UVerb routes either.

195− -- These routes can return a 401 response directly without using throwError / throwAll,

196− -- which revealed a bug:

197− --

198− -- https://github.com/haskell-servant/servant/issues/1570#issuecomment-1076374449

199− resp <- getWith opts (url port ++ "/uverb")

200− resp ^. responseStatus `shouldBe` status401

201− (resp ^. responseCookieJar) `shouldNotHaveCookies` ["XSRF-TOKEN"]

202−

203−

204− it "succeeds if XSRF header and cookie match, and JWT is valid" $ \port -> property

205− $ \(user :: User) -> do

206− jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)

207− opts' <- addJwtToCookie cookieCfg jwt

208− let opts = addCookie (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"])

209− (xsrfField xsrfCookieName cookieCfg <> "=blah")

210− resp <- getWith opts (url port)

211− resp ^? responseBody . _JSON `shouldBe` Just (length $ name user)

212−

213− it "sets and clears the right cookies" $ \port -> property

214− $ \(user :: User) -> do

215− let optsFromResp resp =

216− let jar = resp ^. responseCookieJar

217− Just xsrfCookieValue = cookie_value <$> find (\c -> cookie_name c == xsrfField xsrfCookieName cookieCfg) (destroyCookieJar jar)

218− in defaults

219− & cookies .~ Just jar -- real cookie jars aren't updated by being replaced

220− & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ [xsrfCookieValue]

221−

222− resp <- postWith defaults (url port ++ "/login") user

223− (resp ^. responseCookieJar) `shouldMatchCookieNames`

224− [ sessionCookieName cookieCfg

225− , xsrfField xsrfCookieName cookieCfg

226− ]

227− let loggedInOpts = optsFromResp resp

228−

229− resp <- getWith loggedInOpts (url port)

230− resp ^? responseBody . _JSON `shouldBe` Just (length $ name user)

231−

232− -- logout

233− resp <- getWith loggedInOpts (url port ++ "/logout")

234−

235− -- assert cookies were expired

236− now <- getCurrentTime

237− let assertCookie c = now >= cookie_expiry_time c

238− all assertCookie (destroyCookieJar (resp ^. responseCookieJar)) `shouldBe` True

239−

240− let loggedOutOpts = optsFromResp resp

241− getWith loggedOutOpts (url port) `shouldHTTPErrorWith` status401

242−

243− describe "With no XSRF check for GET requests" $ let

244− noXsrfGet xsrfCfg = xsrfCfg { xsrfExcludeGet = True }

245− cookieCfgNoXsrfGet = cookieCfg { cookieXsrfSetting = fmap noXsrfGet $ cookieXsrfSetting cookieCfg }

246− in around (testWithApplication . return $ appWithCookie cookieOnlyApi cookieCfgNoXsrfGet) $ do

247−

248− it "succeeds with no XSRF header or cookie for GET" $ \port -> property

249− $ \(user :: User) -> do

250− jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)

251− opts <- addJwtToCookie cookieCfgNoXsrfGet jwt

252− resp <- getWith opts (url port)

253− resp ^? responseBody . _JSON `shouldBe` Just (length $ name user)

254−

255− it "fails with no XSRF header or cookie for POST" $ \port -> property

256− $ \(user :: User) number -> do

257− jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)

258− opts <- addJwtToCookie cookieCfgNoXsrfGet jwt

259− postWith opts (url port) (toJSON (number :: Int)) `shouldHTTPErrorWith` status401

260−

261− describe "With no XSRF check at all" $ let

262− cookieCfgNoXsrf = cookieCfg { cookieXsrfSetting = Nothing }

263− in around (testWithApplication . return $ appWithCookie cookieOnlyApi cookieCfgNoXsrf) $ do

264−

265− it "succeeds with no XSRF header or cookie for GET" $ \port -> property

266− $ \(user :: User) -> do

267− jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)

268− opts <- addJwtToCookie cookieCfgNoXsrf jwt

269− resp <- getWith opts (url port)

270− resp ^? responseBody . _JSON `shouldBe` Just (length $ name user)

271−

272− it "succeeds with no XSRF header or cookie for POST" $ \port -> property

273− $ \(user :: User) number -> do

274− jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)

275− opts <- addJwtToCookie cookieCfgNoXsrf jwt

276− resp <- postWith opts (url port) $ toJSON (number :: Int)

277− resp ^? responseBody . _JSON `shouldBe` Just number

278−

279− it "sets and clears the right cookies" $ \port -> property

280− $ \(user :: User) -> do

281− let optsFromResp resp = defaults

282− & cookies .~ Just (resp ^. responseCookieJar) -- real cookie jars aren't updated by being replaced

283−

284− resp <- postWith defaults (url port ++ "/login") user

285− (resp ^. responseCookieJar) `shouldMatchCookieNames`

286− [ sessionCookieName cookieCfg

287− , "NO-XSRF-TOKEN"

288− ]

289− let loggedInOpts = optsFromResp resp

290−

291− resp <- getWith (loggedInOpts) (url port)

292− resp ^? responseBody . _JSON `shouldBe` Just (length $ name user)

293−

294− resp <- getWith loggedInOpts (url port ++ "/logout")

295− (resp ^. responseCookieJar) `shouldMatchCookieNameValues`

296− [ (sessionCookieName cookieCfg, "value")

297− , ("NO-XSRF-TOKEN", "")

298− ]

299−

300− -- assert cookies were expired

301− now <- getCurrentTime

302− let assertCookie c = now >= cookie_expiry_time c

303− all assertCookie (destroyCookieJar (resp ^. responseCookieJar)) `shouldBe` True

304−

305− let loggedOutOpts = optsFromResp resp

306−

307− getWith loggedOutOpts (url port) `shouldHTTPErrorWith` status401

308−

309−-- }}}

310−------------------------------------------------------------------------------

311−-- * JWT Auth {{{

312−

313−jwtAuthSpec :: Spec

314−jwtAuthSpec

315− = describe "The JWT combinator"

316− $ around (testWithApplication . return $ app jwtOnlyApi) $ do

317−

318− it "fails if 'aud' does not match predicate" $ \port -> property $

319− \(user :: User) -> do

320− jwt <- createJWT theKey (newJWSHeader ((), HS256))

321− (claims (toJSON user) & claimAud .~ Just (Audience ["boo"]))

322− opts <- addJwtToHeader (jwt >>= (return . encodeCompact))

323− getWith opts (url port) `shouldHTTPErrorWith` status401

324−

325− it "succeeds if 'aud' does match predicate" $ \port -> property $

326− \(user :: User) -> do

327− jwt <- createJWT theKey (newJWSHeader ((), HS256))

328− (claims (toJSON user) & claimAud .~ Just (Audience ["anythingElse"]))

329− opts <- addJwtToHeader (jwt >>= (return . encodeCompact))

330− resp <- getWith opts (url port)

331− resp ^. responseStatus `shouldBe` status200

332−

333− it "fails if 'nbf' is set to a future date" $ \port -> property $

334− \(user :: User) -> do

335− jwt <- createJWT theKey (newJWSHeader ((), HS256))

336− (claims (toJSON user) & claimNbf .~ Just (NumericDate future))

337− opts <- addJwtToHeader (jwt >>= (return . encodeCompact))

338− getWith opts (url port) `shouldHTTPErrorWith` status401

339−

340− it "fails if 'exp' is set to a past date" $ \port -> property $

341− \(user :: User) -> do

342− jwt <- makeJWT user jwtCfg (Just past)

343− opts <- addJwtToHeader jwt

344− getWith opts (url port) `shouldHTTPErrorWith` status401

345−

346− it "succeeds if 'exp' is set to a future date" $ \port -> property $

347− \(user :: User) -> do

348− jwt <- makeJWT user jwtCfg (Just future)

349− opts <- addJwtToHeader jwt

350− resp <- getWith opts (url port)

351− resp ^. responseStatus `shouldBe` status200

352−

353− it "fails if JWT is not signed" $ \port -> property $ \(user :: User) -> do

354− jwt <- createJWT theKey (newJWSHeader ((), None))

355− (claims $ toJSON user)

356− opts <- addJwtToHeader (jwt >>= (return . encodeCompact))

357− getWith opts (url port) `shouldHTTPErrorWith` status401

358−

359− it "fails if JWT does not use expected algorithm" $ const $

360− pendingWith "Need https://github.com/frasertweedale/hs-jose/issues/19"

361−

362− it "fails if data is not valid JSON" $ \port -> do

363− jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims "{{")

364− opts <- addJwtToHeader (jwt >>= (return .encodeCompact))

365− getWith opts (url port) `shouldHTTPErrorWith` status401

366−

367− it "suceeds as wreq's oauth2Bearer" $ \port -> property $ \(user :: User) -> do

368− jwt <- createJWT theKey (newJWSHeader ((), HS256))

369− (claims $ toJSON user)

370− resp <- case jwt >>= (return . encodeCompact) of

371− Left (e :: Error) -> fail $ show e

372− Right v -> getWith (defaults & auth ?~ oauth2Bearer (BSL.toStrict v)) (url port)

373− resp ^. responseStatus `shouldBe` status200

374−

375−-- }}}

376−------------------------------------------------------------------------------

377−-- * Basic Auth {{{

378−

379−basicAuthSpec :: Spec

380−basicAuthSpec = describe "The BasicAuth combinator"

381− $ around (testWithApplication . return $ app basicAuthApi) $ do

382−

383− it "succeeds with the correct password and username" $ \port -> do

384− resp <- getWith (defaults & auth ?~ basicAuth "ali" "Open sesame") (url port)

385− resp ^. responseStatus `shouldBe` status200

386−

387− it "fails with non-existent user" $ \port -> do

388− getWith (defaults & auth ?~ basicAuth "thief" "Open sesame") (url port)

389− `shouldHTTPErrorWith` status401

390−

391− it "fails with incorrect password" $ \port -> do

392− getWith (defaults & auth ?~ basicAuth "ali" "phatic") (url port)

393− `shouldHTTPErrorWith` status401

394−

395− it "fails with no auth header" $ \port -> do

396− get (url port) `shouldHTTPErrorWith` status401

397−

398−-- }}}

399−------------------------------------------------------------------------------

400−-- * ThrowAll {{{

401−

402−throwAllSpec :: Spec

403−throwAllSpec = describe "throwAll" $ do

404−

405− it "works for plain values" $ do

406− let t :: Either ServerError Int :<|> Either ServerError Bool :<|> Either ServerError String

407− t = throwAll err401

408− t `shouldBe` throwError err401 :<|> throwError err401 :<|> throwError err401

409−

410− it "works for function types" $ property $ \i -> do

411− let t :: Int -> (Either ServerError Bool :<|> Either ServerError String)

412− t = throwAll err401

413− expected _ = throwError err401 :<|> throwError err401

414− t i `shouldBe` expected i

415−

416−-- }}}

417−------------------------------------------------------------------------------

418−-- * API and Server {{{

419−

420−type API auths

421− = Auth auths User :>

422− ( Get '[JSON] Int

423− :<|> ReqBody '[JSON] Int :> Post '[JSON] Int

424− :<|> "named" :> NamedRoutes DummyRoutes

425− :<|> "header" :> Get '[JSON] (Headers '[Header "Blah" Int] Int)

426−#if MIN_VERSION_servant_server(0,15,0)

427− :<|> "stream" :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString)

428−#endif

429− :<|> "raw" :> Raw

430− )

431− :<|> "uverb" :> Auth auths User :> UVerb 'GET '[JSON] '[WithStatus 200 Int, WithStatus 401 Text, WithStatus 403 Text]

432− :<|> "login" :> ReqBody '[JSON] User :> Post '[JSON] (Headers '[ Header "Set-Cookie" SetCookie

433− , Header "Set-Cookie" SetCookie ] NoContent)

434− :<|> "logout" :> Get '[JSON] (Headers '[ Header "Set-Cookie" SetCookie

435− , Header "Set-Cookie" SetCookie ] NoContent)

436−

437−data DummyRoutes mode = DummyRoutes

438− { dummyInt :: mode :- "dummy" :> Get '[JSON] Int

439− } deriving Generic

440−

441−jwtOnlyApi :: Proxy (API '[Servant.Auth.Server.JWT])

442−jwtOnlyApi = Proxy

443−

444−cookieOnlyApi :: Proxy (API '[Cookie])

445−cookieOnlyApi = Proxy

446−

447−basicAuthApi :: Proxy (API '[BasicAuth])

448−basicAuthApi = Proxy

449−

450−jwtAndCookieApi :: Proxy (API '[Servant.Auth.Server.JWT, Cookie])

451−jwtAndCookieApi = Proxy

452−

453−theKey :: JWK

454−theKey = unsafePerformIO . genJWK $ OctGenParam 256

455−{-# NOINLINE theKey #-}

456−

457−

458−cookieCfg :: CookieSettings

459−cookieCfg = def

460− { cookieExpires = Just future

461− , cookieIsSecure = NotSecure

462− , sessionCookieName = "RuncibleSpoon"

463− , cookieXsrfSetting = pure $ def

464− { xsrfCookieName = "TheyDinedOnMince"

465− , xsrfHeaderName = "AndSlicesOfQuince"

466− }

467− }

468−xsrfField :: (XsrfCookieSettings -> a) -> CookieSettings -> a

469−xsrfField f = maybe (error "expected XsrfCookieSettings for test") f . cookieXsrfSetting

470−

471−jwtCfg :: JWTSettings

472−jwtCfg = (defaultJWTSettings theKey) { audienceMatches = \x ->

473− if x == "boo" then DoesNotMatch else Matches }

474−

475−instance FromBasicAuthData User where

476− fromBasicAuthData (BasicAuthData usr pwd) _

477− = return $ if usr == "ali" && pwd == "Open sesame"

478− then Authenticated $ User "ali" "ali@the-thieves-den.com"

479− else Indefinite

480−

481−-- Could be anything, really, but since this is already in the cfg we don't

482−-- have to add it

483−type instance BasicAuthCfg = JWK

484−

485−appWithCookie :: AreAuths auths '[CookieSettings, JWTSettings, JWK] User

486− => Proxy (API auths) -> CookieSettings -> Application

487−appWithCookie api ccfg = serveWithContext api ctx $ server ccfg

488− where

489− ctx = ccfg :. jwtCfg :. theKey :. EmptyContext

490−

491−-- | Takes a proxy parameter indicating which authentication systems to enable.

492−app :: AreAuths auths '[CookieSettings, JWTSettings, JWK] User

493− => Proxy (API auths) -> Application

494−app api = appWithCookie api cookieCfg

495−

496−server :: CookieSettings -> Server (API auths)

497−server ccfg =

498− (\authResult -> case authResult of

499− Authenticated usr -> getInt usr

500− :<|> postInt usr

501− :<|> DummyRoutes { dummyInt = getInt usr }

502− :<|> getHeaderInt

503−#if MIN_VERSION_servant_server(0,15,0)

504− :<|> return (S.source ["bytestring"])

505−#endif

506− :<|> raw

507− Indefinite -> throwAll err401

508− _ -> throwAll err403

509− ) :<|>

510− (\authResult -> case authResult of

511− Authenticated usr -> respond (WithStatus @200 (42 :: Int))

512− Indefinite -> respond (WithStatus @401 $ pack "Authentication required")

513− _ -> respond (WithStatus @403 $ pack "Forbidden")

514− )

515− :<|> getLogin

516− :<|> getLogout

517− where

518− getInt :: User -> Handler Int

519− getInt usr = return . length $ name usr

520−

521− postInt :: User -> Int -> Handler Int

522− postInt _ = return

523−

524− getHeaderInt :: Handler (Headers '[Header "Blah" Int] Int)

525− getHeaderInt = return $ addHeader 1797 17

526−

527− getLogin :: User -> Handler (Headers '[ Header "Set-Cookie" SetCookie

528− , Header "Set-Cookie" SetCookie ] NoContent)

529− getLogin user = do

530− maybeApplyCookies <- liftIO $ acceptLogin ccfg jwtCfg user

531− case maybeApplyCookies of

532− Just applyCookies -> return $ applyCookies NoContent

533− Nothing -> error "cookies failed to apply"

534−

535− getLogout :: Handler (Headers '[ Header "Set-Cookie" SetCookie

536− , Header "Set-Cookie" SetCookie ] NoContent)

537− getLogout = return $ clearSession ccfg NoContent

538−

539− raw :: Server Raw

540− raw =

541−#if MIN_VERSION_servant_server(0,11,0)

542− Tagged $

543−#endif

544− \_req respond ->

545− respond $ responseLBS status200 [("hi", "there")] "how are you?"

546−

547−-- }}}

548−------------------------------------------------------------------------------

549−-- * Utils {{{

550−

551−past :: UTCTime

552−past = parseTimeOrError True defaultTimeLocale "%Y-%m-%d" "1970-01-01"

553−

554−future :: UTCTime

555−future = parseTimeOrError True defaultTimeLocale "%Y-%m-%d" "2070-01-01"

556−

557−addJwtToHeader :: Either Error BSL.ByteString -> IO Options

558−addJwtToHeader jwt = case jwt of

559− Left e -> fail $ show e

560− Right v -> return

561− $ defaults & header "Authorization" .~ ["Bearer " <> BSL.toStrict v]

562−

563−createJWT :: JWK -> JWSHeader () -> ClaimsSet -> IO (Either Error Crypto.JWT.SignedJWT)

564−createJWT k a b = runJOSE $ signClaims k a b

565−

566−addJwtToCookie :: ToCompact a => CookieSettings -> Either Error a -> IO Options

567−addJwtToCookie ccfg jwt = case jwt >>= (return . encodeCompact) of

568− Left e -> fail $ show e

569− Right v -> return

570− $ defaults & header "Cookie" .~ [sessionCookieName ccfg <> "=" <> BSL.toStrict v]

571−

572−addCookie :: Options -> BS.ByteString -> Options

573−addCookie opts cookie' = opts & header "Cookie" %~ \c -> case c of

574− [h] -> [cookie' <> "; " <> h]

575− [] -> [cookie']

576− _ -> error "expecting single cookie header"

577−

578−

579−shouldHTTPErrorWith :: IO a -> Status -> Expectation

580−shouldHTTPErrorWith act stat = act `shouldThrow` \e -> case e of

581−#if MIN_VERSION_http_client(0,5,0)

582− HCli.HttpExceptionRequest _ (HCli.StatusCodeException resp _)

583− -> HCli.responseStatus resp == stat

584−#else

585− HCli.StatusCodeException x _ _ -> x == stat

586−#endif

587− _ -> False

588−

589−shouldMatchCookieNames :: HCli.CookieJar -> [BS.ByteString] -> Expectation

590−shouldMatchCookieNames cj patterns

591− = fmap cookie_name (destroyCookieJar cj)

592− `shouldMatchList` patterns

593−

594−shouldNotHaveCookies :: HCli.CookieJar -> [BS.ByteString] -> Expectation

595−shouldNotHaveCookies cj patterns =

596− sequence_ $ (\cookieName -> cookieNames `shouldNotContain` [cookieName]) <$> patterns

597− where cookieNames :: [BS.ByteString]

598− cookieNames = cookie_name <$> destroyCookieJar cj

599−

600−shouldMatchCookieNameValues :: HCli.CookieJar -> [(BS.ByteString, BS.ByteString)] -> Expectation

601−shouldMatchCookieNameValues cj patterns

602− = fmap ((,) <$> cookie_name <*> cookie_value) (destroyCookieJar cj)

603− `shouldMatchList` patterns

604−

605−url :: Int -> String

606−url port = "http://localhost:" <> show port

607−

608−claims :: Value -> ClaimsSet

609−claims val = emptyClaimsSet & unregisteredClaims . at "dat" .~ Just val

610−-- }}}

611−------------------------------------------------------------------------------

612−-- * Types {{{

613−

614−data User = User

615− { name :: String

616− , _id :: String

617− } deriving (Eq, Show, Read, Generic)

618−

619−instance FromJWT User

620−instance ToJWT User

621−instance FromJSON User

622−instance ToJSON User

623−

624−instance Arbitrary User where

625− arbitrary = User <$> arbitrary <*> arbitrary

626−

627−instance Postable User where

628− postPayload user request = return $ request

629− { HCli.requestBody = HCli.RequestBodyLBS $ encode user

630− , HCli.requestHeaders = (mk "Content-Type", "application/json") : HCli.requestHeaders request

631− }

632−

633−

634−-- }}}

servant-auth/servant-auth-server/test/Spec.hsdeleted−1

@@ -1 +0,0 @@

1−{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

servant-auth/servant-auth-swagger/.ghcideleted−1

@@ -1 +0,0 @@

1−:set -isrc -itest -idoctest/ghci-wrapper/src

servant-auth/servant-auth-swagger/CHANGELOG.mddeleted−24

@@ -1,24 +0,0 @@

1−# Changelog

2−

3−All notable changes to this project will be documented in this file.

4−

5−The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/)

6−and this project adheres to [PVP Versioning](https://pvp.haskell.org/).

7−

8−## [Unreleased]

9−

10−## [0.2.10.1] - 2020-10-06

11−

12−### Changed

13−

14−- Support GHC 8.10 @domenkozar

15−- Fix build with swagger 2.5.x @domenkozar

16−

17−## [0.2.10.0] - 2018-06-18

18−

19−### Added

20−

21−- Support for GHC 8.4 by @phadej

22−- Changelog by @domenkozar

23−- #93: Add Cookie in SwaggerSpec API by @domenkozar

24−- #42: Add dummy AllHasSecurity Cookie instance by @sordina

servant-auth/servant-auth-swagger/LICENSEdeleted−31

@@ -1,31 +0,0 @@

1−Copyright Julian K. Arni (c) 2015

2−

3−All rights reserved.

4−

5−Redistribution and use in source and binary forms, with or without

6−modification, are permitted provided that the following conditions are met:

7−

8− * Redistributions of source code must retain the above copyright

9− notice, this list of conditions and the following disclaimer.

10−

11− * Redistributions in binary form must reproduce the above

12− copyright notice, this list of conditions and the following

13− disclaimer in the documentation and/or other materials provided

14− with the distribution.

15−

16− * Neither the name of Julian K. Arni nor the names of other

17− contributors may be used to endorse or promote products derived

18− from this software without specific prior written permission.

19−

20−THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS

21−"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT

22−LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR

23−A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT

24−OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,

25−SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT

26−LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,

27−DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY

28−THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT

29−(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE

30−OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

31−

servant-auth/servant-auth-swagger/Setup.hsdeleted−2

@@ -1,2 +0,0 @@

1−import Distribution.Simple

2−main = defaultMain

servant-auth/servant-auth-swagger/servant-auth-swagger.cabaldeleted−70

@@ -1,70 +0,0 @@

1−cabal-version: 2.2

2−name: servant-auth-swagger

3−version: 0.2.10.1

4−synopsis: servant-swagger/servant-auth compatibility

5−description: This package provides instances that allow generating swagger2 schemas from

6− <https://hackage.haskell.org/package/servant servant>

7− APIs that use

8− <https://hackage.haskell.org/package/servant-auth servant-auth's> @Auth@ combinator.

9− .

10− For a quick overview of the usage, see the <https://github.com/haskell-servant/servant/tree/master/servant-auth#readme README>.

11−category: Web, Servant, Authentication

12−homepage: https://github.com/haskell-servant/servant/tree/master/servant-auth#readme

13−bug-reports: https://github.com/haskell-servant/servant/issues

14−author: Julian K. Arni

15−maintainer: jkarni@gmail.com

16−copyright: (c) Julian K. Arni

17−license: BSD-3-Clause

18−license-file: LICENSE

19−tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4

20−build-type: Simple

21−extra-source-files:

22− CHANGELOG.md

23−

24−source-repository head

25− type: git

26− location: https://github.com/haskell-servant/servant

27−

28−library

29− hs-source-dirs:

30− src

31− default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators

32− ghc-options: -Wall

33− build-depends:

34− base >= 4.10 && < 4.18

35− , text >= 1.2.3.0 && < 2.1

36− , servant-swagger >= 1.1.5 && < 2

37− , swagger2 >= 2.2.2 && < 3

38− , servant >= 0.13 && < 0.20

39− , servant-auth == 0.4.*

40− , lens >= 4.16.1 && < 5.3

41− exposed-modules:

42− Servant.Auth.Swagger

43− default-language: Haskell2010

44−

45−test-suite spec

46− type: exitcode-stdio-1.0

47− main-is: Spec.hs

48− hs-source-dirs:

49− test

50− default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators

51− ghc-options: -Wall

52− build-tool-depends: hspec-discover:hspec-discover >= 2.5.5 && <2.10

53− -- dependencies with bounds inherited from the library stanza

54− build-depends:

55− base

56− , text

57− , servant-swagger

58− , swagger2

59− , servant

60− , servant-auth

61− , lens

62−

63− -- test dependencies

64− build-depends:

65− servant-auth-swagger

66− , hspec >= 2.5.5 && < 2.10

67− , QuickCheck >= 2.11.3 && < 2.15

68− other-modules:

69− Servant.Auth.SwaggerSpec

70− default-language: Haskell2010

servant-auth/servant-auth-swagger/src/Servant/Auth/Swagger.hsdeleted−87

@@ -1,87 +0,0 @@

1−{-# OPTIONS_GHC -fno-warn-orphans #-}

2−{-# LANGUAGE CPP #-}

3−module Servant.Auth.Swagger

4− (

5− -- | The purpose of this package is provide the instance for 'servant-auth'

6− -- combinators needed for 'servant-swagger' documentation generation.

7− --

8− -- Currently only JWT and BasicAuth are supported.

9−

10− -- * Re-export

11− JWT

12− , BasicAuth

13− , Auth

14−

15− -- * Needed to define instances of @HasSwagger@

16− , HasSecurity (..)

17− ) where

18−

19−import Control.Lens ((&), (<>~))

20−import Data.Proxy (Proxy (Proxy))

21−import Data.Swagger (ApiKeyLocation (..), ApiKeyParams (..),

22− SecurityRequirement (..), SecurityScheme (..),

23−#if MIN_VERSION_swagger2(2,6,0)

24− SecurityDefinitions(..),

25−#endif

26− SecuritySchemeType (..), allOperations, security,

27− securityDefinitions)

28−import GHC.Exts (fromList)

29−import Servant.API hiding (BasicAuth)

30−import Servant.Auth

31−import Servant.Swagger

32−

33−import qualified Data.Text as T

34−

35−instance (AllHasSecurity xs, HasSwagger api) => HasSwagger (Auth xs r :> api) where

36− toSwagger _

37− = toSwagger (Proxy :: Proxy api)

38− & securityDefinitions <>~ mkSec (fromList secs)

39− & allOperations.security <>~ secReqs

40− where

41− secs = securities (Proxy :: Proxy xs)

42− secReqs = [ SecurityRequirement (fromList [(s,[])]) | (s,_) <- secs]

43− mkSec =

44−#if MIN_VERSION_swagger2(2,6,0)

45− SecurityDefinitions

46−#else

47− id

48−#endif

49−

50−

51−class HasSecurity x where

52− securityName :: Proxy x -> T.Text

53− securityScheme :: Proxy x -> SecurityScheme

54−

55−instance HasSecurity BasicAuth where

56− securityName _ = "BasicAuth"

57− securityScheme _ = SecurityScheme type_ (Just desc)

58− where

59− type_ = SecuritySchemeBasic

60− desc = "Basic access authentication"

61−

62−instance HasSecurity JWT where

63− securityName _ = "JwtSecurity"

64− securityScheme _ = SecurityScheme type_ (Just desc)

65− where

66− type_ = SecuritySchemeApiKey (ApiKeyParams "Authorization" ApiKeyHeader)

67− desc = "JSON Web Token-based API key"

68−

69−class AllHasSecurity (x :: [*]) where

70− securities :: Proxy x -> [(T.Text,SecurityScheme)]

71−

72−instance {-# OVERLAPPABLE #-} (HasSecurity x, AllHasSecurity xs) => AllHasSecurity (x ': xs) where

73− securities _ = (securityName px, securityScheme px) : securities pxs

74− where

75− px :: Proxy x

76− px = Proxy

77− pxs :: Proxy xs

78− pxs = Proxy

79−

80−instance {-# OVERLAPPING #-} AllHasSecurity xs => AllHasSecurity (Cookie ': xs) where

81− securities _ = securities pxs

82− where

83− pxs :: Proxy xs

84− pxs = Proxy

85−

86−instance AllHasSecurity '[] where

87− securities _ = []

servant-auth/servant-auth-swagger/test/Servant/Auth/SwaggerSpec.hsdeleted−38

@@ -1,38 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−module Servant.Auth.SwaggerSpec (spec) where

3−

4−import Control.Lens

5−import Data.Proxy

6−import Servant.API

7−import Servant.Auth

8−import Servant.Auth.Swagger

9−import Data.Swagger

10−import Servant.Swagger

11−import Test.Hspec

12−

13−spec :: Spec

14−spec = describe "HasSwagger instance" $ do

15−

16− let swag = toSwagger (Proxy :: Proxy API)

17−

18− it "adds security definitions at the top level" $ do

19−#if MIN_VERSION_swagger2(2,6,0)

20− let (SecurityDefinitions secDefs) = swag ^. securityDefinitions

21−#else

22− let secDefs = swag ^. securityDefinitions

23−#endif

24− length secDefs `shouldSatisfy` (> 0)

25−

26− it "adds security at sub-apis" $ do

27− swag ^. security `shouldBe` []

28− show (swag ^. paths . at "/secure") `shouldContain` "JwtSecurity"

29− show (swag ^. paths . at "/insecure") `shouldNotContain` "JwtSecurity"

30−

31−-- * API

32−

33−type API = "secure" :> Auth '[JWT, Cookie] Int :> SecureAPI

34− :<|> "insecure" :> InsecureAPI

35−

36−type SecureAPI = Get '[JSON] Int :<|> ReqBody '[JSON] Int :> Post '[JSON] Int

37−

38−type InsecureAPI = SecureAPI

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

@@ -1 +0,0 @@

1−{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

servant-auth/servant-auth/.ghcideleted−1

@@ -1 +0,0 @@

1−:set -isrc -itest -idoctest/ghci-wrapper/src

servant-auth/servant-auth/CHANGELOG.mddeleted−20

@@ -1,20 +0,0 @@

1−# Changelog

2−

3−All notable changes to this project will be documented in this file.

4−

5−The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/)

6−and this project adheres to [PVP Versioning](https://pvp.haskell.org/).

7−

8−## [Unreleased]

9−

10−## [0.4.0.0] - 2020-10-06

11−

12−- Support for GHC 8.10 by @domenkozar

13−- Support servant 0.18 by @domenkozar

14−- Move `ToJWT/FromJWT` from servant-auth-server

15−

16−## [0.3.2.0] - 2018-06-18

17−

18−### Added

19−- Support for GHC 8.4 by @phadej

20−- Changelog by @domenkozar

servant-auth/servant-auth/LICENSEdeleted−31

@@ -1,31 +0,0 @@

1−Copyright Julian K. Arni (c) 2015

2−

3−All rights reserved.

4−

5−Redistribution and use in source and binary forms, with or without

6−modification, are permitted provided that the following conditions are met:

7−

8− * Redistributions of source code must retain the above copyright

9− notice, this list of conditions and the following disclaimer.

10−

11− * Redistributions in binary form must reproduce the above

12− copyright notice, this list of conditions and the following

13− disclaimer in the documentation and/or other materials provided

14− with the distribution.

15−

16− * Neither the name of Julian K. Arni nor the names of other

17− contributors may be used to endorse or promote products derived

18− from this software without specific prior written permission.

19−

20−THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS

21−"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT

22−LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR

23−A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT

24−OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,

25−SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT

26−LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,

27−DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY

28−THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT

29−(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE

30−OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

31−

servant-auth/servant-auth/Setup.hsdeleted−2

@@ -1,2 +0,0 @@

1−import Distribution.Simple

2−main = defaultMain

servant-auth/servant-auth/servant-auth.cabaldeleted−47

@@ -1,47 +0,0 @@

1−cabal-version: 2.2

2−name: servant-auth

3−version: 0.4.1.0

4−synopsis: Authentication combinators for servant

5−description: This package provides an @Auth@ combinator for 'servant'. This combinator

6− allows using different authentication schemes in a straightforward way,

7− and possibly in conjunction with one another.

8− .

9− 'servant-auth' additionally provides concrete authentication schemes, such

10− as Basic Access Authentication, JSON Web Tokens, and Cookies.

11− .

12− For more details on how to use this, see the <https://github.com/haskell-servant/servant/tree/master/servant-auth#readme README>.

13−category: Web, Servant, Authentication

14−homepage: https://github.com/haskell-servant/servant/tree/master/servant-auth#readme

15−bug-reports: https://github.com/haskell-servant/servant/issues

16−author: Julian K. Arni

17−maintainer: jkarni@gmail.com

18−copyright: (c) Julian K. Arni

19−license: BSD-3-Clause

20−license-file: LICENSE

21−tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1

22−build-type: Simple

23−extra-source-files:

24− CHANGELOG.md

25−

26−source-repository head

27− type: git

28− location: https://github.com/haskell-servant/servant

29−

30−library

31− hs-source-dirs:

32− src

33− default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators

34− ghc-options: -Wall

35− build-depends:

36− base >= 4.10 && < 4.18

37− , containers >= 0.6 && < 0.7

38− , aeson >= 1.3.1.1 && < 3

39− , jose >= 0.10 && < 0.11

40− , lens >= 4.16.1 && < 5.3

41− , servant >= 0.15 && < 0.20

42− , text >= 1.2.3.0 && < 2.1

43− , unordered-containers >= 0.2.9.0 && < 0.3

44− exposed-modules:

45− Servant.Auth

46− Servant.Auth.JWT

47− default-language: Haskell2010

servant-auth/servant-auth/src/Servant/Auth.hsdeleted−54

@@ -1,54 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4−{-# LANGUAGE TypeFamilies #-}

5−{-# LANGUAGE TypeOperators #-}

6−module Servant.Auth where

7−

8−import Data.Proxy (Proxy(..))

9−import Servant.API ((:>))

10−import Servant.Links (HasLink (..))

11−

12−-- * Authentication

13−

14−-- | @Auth [auth1, auth2] val :> api@ represents an API protected *either* by

15−-- @auth1@ or @auth2@

16−data Auth (auths :: [*]) val

17−

18−-- | A @HasLink@ instance for @Auth@

19−instance HasLink sub => HasLink (Auth (tag :: [*]) value :> sub) where

20−#if MIN_VERSION_servant(0,14,0)

21− type MkLink (Auth (tag :: [*]) value :> sub) a = MkLink sub a

22− toLink toA _ = toLink toA (Proxy :: Proxy sub)

23−#else

24− type MkLink (Auth (tag :: [*]) value :> sub) = MkLink sub

25− toLink _ = toLink (Proxy :: Proxy sub)

26−#endif

27−

28−-- ** Combinators

29−

30−-- | A JSON Web Token (JWT) in the Authorization header:

31−--

32−-- @Authorization: Bearer \<token\>@

33−--

34−-- Note that while the token is signed, it is not encrypted. Therefore do not

35−-- keep in it any information you would not like the client to know.

36−--

37−-- JWTs are described in IETF's <https://tools.ietf.org/html/rfc7519 RFC 7519>

38−data JWT

39−

40−-- | A cookie. The content cookie itself is a JWT. Another cookie is also used,

41−-- the contents of which are expected to be send back to the server in a

42−-- header, for XSRF protection.

43−data Cookie

44−

45−

46−-- We could use 'servant''s BasicAuth, but then we don't get control over the

47−-- documentation, and we'd have to polykind everything. (Also, we don't

48−-- currently depend on servant!)

49−--

50−-- | Basic Auth.

51−data BasicAuth

52−

53−-- | Login via a form.

54−data FormLogin form

servant-auth/servant-auth/src/Servant/Auth/JWT.hsdeleted−40

@@ -1,40 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−

3−module Servant.Auth.JWT where

4−

5−import Control.Lens ((^.))

6−import qualified Crypto.JWT as Jose

7−import Data.Aeson (FromJSON, Result (..), ToJSON, fromJSON,

8− toJSON)

9−#if MIN_VERSION_aeson(2,0,0)

10−import qualified Data.Map as KM

11−#else

12−import qualified Data.HashMap.Strict as KM

13−#endif

14−

15−import qualified Data.Text as T

16−

17−

18−-- This should probably also be from ClaimSet

19−--

20−-- | How to decode data from a JWT.

21−--

22−-- The default implementation assumes the data is stored in the unregistered

23−-- @dat@ claim, and uses the @FromJSON@ instance to decode value from there.

24−class FromJWT a where

25− decodeJWT :: Jose.ClaimsSet -> Either T.Text a

26− default decodeJWT :: FromJSON a => Jose.ClaimsSet -> Either T.Text a

27− decodeJWT m = case KM.lookup "dat" (m ^. Jose.unregisteredClaims) of

28− Nothing -> Left "Missing 'dat' claim"

29− Just v -> case fromJSON v of

30− Error e -> Left $ T.pack e

31− Success a -> Right a

32−

33−-- | How to encode data from a JWT.

34−--

35−-- The default implementation stores data in the unregistered @dat@ claim, and

36−-- uses the type's @ToJSON@ instance to encode the data.

37−class ToJWT a where

38− encodeJWT :: a -> Jose.ClaimsSet

39− default encodeJWT :: ToJSON a => a -> Jose.ClaimsSet

40− encodeJWT a = Jose.addClaim "dat" (toJSON a) Jose.emptyClaimsSet

servant-auth/servant-auth/test/Spec.hsdeleted−1

@@ -1 +0,0 @@

1−{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

servant-client-core/CHANGELOG.md+2−234

@@ -1,238 +1,6 @@

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−

2360.14.1

40.14.1

237------

5------

238

6

@@ -275,9 +43,9 @@ Package versions follow the [Package Versioning Policy](https://pvp.haskell.org/

275

43

276- *servant-client-core* Add `hoistClient` to `HasClient`.

44- *servant-client-core* Add `hoistClient` to `HasClient`.

277 Just like `hoistServer` allows us to change the monad in which request handlers

45 Just like `hoistServer` allows us to change the monad in which request handlers

278− of a web application live, we also have `hoistClient` for changing the monad

46+ of a web application live in, we also have `hoistClient` for changing the monad

279 in which *client functions* live.

47 in which *client functions* live.

280− Read [tutorial section for more information](https://docs.servant.dev/en/release-0.14/tutorial/Client.html#changing-the-monad-the-client-functions-live-in).

48+ Read [tutorial section for more information](https://haskell-servant.readthedocs.io/en/release-0.14/tutorial/Client.html#changing-the-monad-the-client-functions-live-in).

281 ([#936](https://github.com/haskell-servant/servant/pull/936))

49 ([#936](https://github.com/haskell-servant/servant/pull/936))

282

50

283 iF you have own combinators, you'll need to define a new method of

51 iF you have own combinators, you'll need to define a new method of

servant-client-core/LICENSE+1−1

@@ -1,4 +1,4 @@

1−Copyright (c) 2017-2018, Servant Contributors

1+Copyright (c) 2017, Servant Contributors

2

2

3All rights reserved.

3All rights reserved.

4

4

servant-client-core/servant-client-core.cabal+39−48

@@ -1,27 +1,27 @@

1−cabal-version: 2.2

2name: servant-client-core

1name: servant-client-core

3−version: 0.19

2+version: 0.14.1

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:

23 CHANGELOG.md

18 CHANGELOG.md

24 README.md

19 README.md

20+tested-with:

21+ GHC==8.0.2

22+ GHC==8.2.2

23+ GHC==8.4.4

24+ GHC==8.6.1

25

25

26source-repository head

26source-repository head

27 type: git

27 type: git

@@ -33,53 +33,45 @@ library

33 Servant.Client.Free

33 Servant.Client.Free

34 Servant.Client.Generic

34 Servant.Client.Generic

35 Servant.Client.Core.Reexport

35 Servant.Client.Core.Reexport

36− Servant.Client.Core.Auth

36+ Servant.Client.Core.Internal.Auth

37− Servant.Client.Core.BaseUrl

37+ Servant.Client.Core.Internal.BaseUrl

38− Servant.Client.Core.BasicAuth

38+ Servant.Client.Core.Internal.BasicAuth

39− Servant.Client.Core.ClientError

39+ Servant.Client.Core.Internal.ClientF

40− Servant.Client.Core.HasClient

40+ Servant.Client.Core.Internal.Generic

41+ Servant.Client.Core.Internal.HasClient

41− Servant.Client.Core.Request

42+ Servant.Client.Core.Internal.Request

42− Servant.Client.Core.Response

43+ Servant.Client.Core.Internal.RunClient

43− Servant.Client.Core.RunClient

44−

45− other-modules:

46− Servant.Client.Core.Internal

47

44

48 -- Bundled with GHC: Lower bound to not force re-installs

45 -- Bundled with GHC: Lower bound to not force re-installs

49 -- text and mtl are bundled starting with GHC-8.4

46 -- text and mtl are bundled starting with GHC-8.4

50 --

47 --

51 -- note: mtl lower bound is so low because of GHC-7.8

48 -- note: mtl lower bound is so low because of GHC-7.8

52 build-depends:

49 build-depends:

53− base >= 4.9 && < 4.18

50+ base >= 4.9 && < 4.13

54− , bytestring >= 0.10.8.1 && < 0.12

51+ , bytestring >= 0.10.8.1 && < 0.11

55− , constraints >= 0.2 && < 0.14

56 , containers >= 0.5.7.1 && < 0.7

52 , containers >= 0.5.7.1 && < 0.7

57− , deepseq >= 1.4.2.0 && < 1.5

58− , text >= 1.2.3.0 && < 2.1

53+ , text >= 1.2.3.0 && < 1.3

59− , transformers >= 0.5.2.0 && < 0.7

54+ , transformers >= 0.5.2.0 && < 0.6

60− , template-haskell >= 2.11.1.0 && < 2.20

55+ , template-haskell >= 2.11.1.0 && < 2.15

61−

62− if !impl(ghc >= 8.2)

63− build-depends:

64− bifunctors >= 5.5.3 && < 5.6

65

56

66 -- Servant dependencies

57 -- Servant dependencies

67 build-depends:

58 build-depends:

68− servant >= 0.19

59+ servant >= 0.14.1 && <0.15

69

60

70 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.

61 -- 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.

62 -- Here can be exceptions if we really need features from the newer versions.

72 build-depends:

63 build-depends:

73− aeson >= 1.4.1.0 && < 3

64+ aeson >= 1.4.0.0 && < 1.5

74− , base-compat >= 0.10.5 && < 0.13

65+ , base-compat >= 0.10.1 && < 0.11

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.10.0 && < 0.11

77− , free >= 5.1 && < 5.2

68+ , free >= 5.0.2 && < 5.2

69+ , generics-sop >= 0.3.2.0 && < 0.4

70+ , http-api-data >= 0.3.8.1 && < 0.4

78− , http-media >= 0.7.1.3 && < 0.9

71+ , http-media >= 0.7.1.2 && < 0.8

79− , http-types >= 0.12.2 && < 0.13

72+ , http-types >= 0.12.1 && < 0.13

80 , network-uri >= 2.6.1.0 && < 2.7

73 , network-uri >= 2.6.1.0 && < 2.7

81 , safe >= 0.3.17 && < 0.4

74 , safe >= 0.3.17 && < 0.4

82− , sop-core >= 0.4.0.0 && < 0.6

83

75

84 hs-source-dirs: src

76 hs-source-dirs: src

85 default-language: Haskell2010

77 default-language: Haskell2010

@@ -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.1 && <2.6

108− , QuickCheck >= 2.12.6.1 && < 2.15

99+ , QuickCheck >= 2.11.3 && < 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.5.1 && <2.6

servant-client-core/src/Servant/Client/Core.hs+16−24

@@ -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,13 @@ 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

66− (BaseUrl (..), InvalidBaseUrlException (..), Scheme (..),

59+ (BaseUrl (..), InvalidBaseUrlException, Scheme (..),

67 parseBaseUrl, showBaseUrl)

60 parseBaseUrl, showBaseUrl)

68−import Servant.Client.Core.BasicAuth

61+import Servant.Client.Core.Internal.BasicAuth

69−import Servant.Client.Core.ClientError

62+import Servant.Client.Core.Internal.Generic

70−import Servant.Client.Core.HasClient

63+import Servant.Client.Core.Internal.HasClient

71−import Servant.Client.Core.Request

64+import Servant.Client.Core.Internal.Request

72−import Servant.Client.Core.Response

65+import Servant.Client.Core.Internal.RunClient

73−import Servant.Client.Core.RunClient

servant-client-core/src/Servant/Client/Core/ClientError.hsdeleted−86

@@ -1,86 +0,0 @@

1−{-# LANGUAGE DeriveDataTypeable #-}

2−{-# LANGUAGE DeriveFoldable #-}

3−{-# LANGUAGE DeriveFunctor #-}

4−{-# LANGUAGE DeriveGeneric #-}

5−{-# LANGUAGE DeriveTraversable #-}

6−{-# LANGUAGE MultiParamTypeClasses #-}

7−{-# LANGUAGE OverloadedStrings #-}

8−{-# LANGUAGE RankNTypes #-}

9−{-# LANGUAGE ScopedTypeVariables #-}

10−{-# LANGUAGE TypeFamilies #-}

11−module Servant.Client.Core.ClientError (

12− ClientError (..),

13− ) where

14−

15−import Prelude ()

16−import Prelude.Compat

17−

18−import Control.DeepSeq

19− (NFData (..))

20−import Control.Exception

21− (SomeException (..))

22−import Control.Monad.Catch

23− (Exception)

24−import qualified Data.ByteString as BS

25−import Data.Text

26− (Text)

27−import Data.Typeable

28− (Typeable, typeOf)

29−import GHC.Generics

30− (Generic)

31−import Network.HTTP.Media

32− (MediaType)

33−import Network.HTTP.Types ()

34−

35−import Servant.Client.Core.BaseUrl

36−import Servant.Client.Core.Internal

37− (mediaTypeRnf)

38−import Servant.Client.Core.Request

39−import Servant.Client.Core.Response

40−

41−

42−-- | A type representing possible errors in a request

43−--

44−-- Note that this type substantially changed in 0.12.

45−data ClientError =

46− -- | The server returned an error response including the

47− -- failing request. 'requestPath' includes the 'BaseUrl' and the

48− -- path of the request.

49− FailureResponse (RequestF () (BaseUrl, BS.ByteString)) Response

50− -- | The body could not be decoded at the expected type

51− | DecodeFailure Text Response

52− -- | The content-type of the response is not supported

53− | UnsupportedContentType MediaType Response

54− -- | The content-type header is invalid

55− | InvalidContentTypeHeader Response

56− -- | There was a connection error, and no response was received

57− | ConnectionError SomeException

58− deriving (Show, Generic, Typeable)

59−

60−instance Eq ClientError where

61− FailureResponse req res == FailureResponse req' res' = req == req' && res == res'

62− DecodeFailure t r == DecodeFailure t' r' = t == t' && r == r'

63− UnsupportedContentType mt r == UnsupportedContentType mt' r' = mt == mt' && r == r'

64− InvalidContentTypeHeader r == InvalidContentTypeHeader r' = r == r'

65− ConnectionError exc == ConnectionError exc' = eqSomeException exc exc'

66− where

67− -- returns true, if type of exception is the same

68− eqSomeException (SomeException a) (SomeException b) = typeOf a == typeOf b

69−

70− -- prevent wild card blindness

71− FailureResponse {} == _ = False

72− DecodeFailure {} == _ = False

73− UnsupportedContentType {} == _ = False

74− InvalidContentTypeHeader {} == _ = False

75− ConnectionError {} == _ = False

76−

77−instance Exception ClientError

78−

79−-- | Note: an exception in 'ConnectionError' might not be evaluated fully,

80−-- We only 'rnf' its 'show'ed value.

81−instance NFData ClientError where

82− rnf (FailureResponse req res) = rnf req `seq` rnf res

83− rnf (DecodeFailure err res) = rnf err `seq` rnf res

84− rnf (UnsupportedContentType mt' res) = mediaTypeRnf mt' `seq` rnf res

85− rnf (InvalidContentTypeHeader res) = rnf res

86− rnf (ConnectionError err) = err `seq` rnf (show err)

servant-client-core/src/Servant/Client/Core/Internal.hsdeleted−12

@@ -1,12 +0,0 @@

1−module Servant.Client.Core.Internal where

2−

3−import Control.DeepSeq

4− (rnf)

5−import Network.HTTP.Media

6− (MediaType, mainType, parameters, subType)

7−

8−mediaTypeRnf :: MediaType -> ()

9−mediaTypeRnf mt =

10− rnf (mainType mt) `seq`

11− rnf (subType mt) `seq`

12− rnf (parameters mt)

servant-client-core/src/Servant/Client/Core/Auth.hs → servant-client-core/src/Servant/Client/Core/Internal/Auth.hsrenamed+2−6

@@ -4,13 +4,9 @@

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

14 (Request)

10 (Request)

15

11

16-- | For a resource protected by authentication (e.g. AuthProtect), we need

12-- | For a resource protected by authentication (e.g. AuthProtect), we need

servant-client-core/src/Servant/Client/Core/BaseUrl.hs → servant-client-core/src/Servant/Client/Core/Internal/BaseUrl.hsrenamed+1−12

@@ -2,16 +2,8 @@

2{-# LANGUAGE DeriveGeneric #-}

2{-# LANGUAGE DeriveGeneric #-}

3{-# LANGUAGE DeriveLift #-}

3{-# LANGUAGE DeriveLift #-}

4{-# LANGUAGE ViewPatterns #-}

4{-# LANGUAGE ViewPatterns #-}

5−module Servant.Client.Core.BaseUrl (

5+module Servant.Client.Core.Internal.BaseUrl where

6− BaseUrl (..),

7− Scheme (..),

8− showBaseUrl,

9− parseBaseUrl,

10− InvalidBaseUrlException (..),

11− ) where

12

6

13−import Control.DeepSeq

14− (NFData (..))

15import Control.Monad.Catch

7import Control.Monad.Catch

16 (Exception, MonadThrow, throwM)

8 (Exception, MonadThrow, throwM)

17import Data.Aeson

9import Data.Aeson

@@ -47,9 +39,6 @@ data BaseUrl = BaseUrl

47 } deriving (Show, Ord, Generic, Lift, Data)

39 } deriving (Show, Ord, Generic, Lift, Data)

48-- TODO: Ord is more precise than Eq

40-- TODO: Ord is more precise than Eq

49-- TODO: Add Hashable instance?

41-- 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

42

54instance Eq BaseUrl where

43instance Eq BaseUrl where

55 BaseUrl a b c path == BaseUrl a' b' c' path'

44 BaseUrl a b c path == BaseUrl a' b' c' path'

servant-client-core/src/Servant/Client/Core/BasicAuth.hs → servant-client-core/src/Servant/Client/Core/Internal/BasicAuth.hsrenamed+5−4

@@ -3,17 +3,18 @@

3{-# LANGUAGE TypeSynonymInstances #-}

3{-# LANGUAGE TypeSynonymInstances #-}

4

4

5-- | Basic Authentication for clients

5-- | Basic Authentication for clients

6+

6−module Servant.Client.Core.BasicAuth (

7+module Servant.Client.Core.Internal.BasicAuth where

7− basicAuthReq,

8− ) where

9

8

10import Data.ByteString.Base64

9import Data.ByteString.Base64

11 (encode)

10 (encode)

11+import Data.Monoid

12+ ((<>))

12import Data.Text.Encoding

13import Data.Text.Encoding

13 (decodeUtf8)

14 (decodeUtf8)

14import Servant.API.BasicAuth

15import Servant.API.BasicAuth

15 (BasicAuthData (BasicAuthData))

16 (BasicAuthData (BasicAuthData))

16−import Servant.Client.Core.Request

17+import Servant.Client.Core.Internal.Request

17 (Request, addHeader)

18 (Request, addHeader)

18

19

19-- | Authenticate a request using Basic Authentication

20-- | Authenticate a request using Basic Authentication

servant-client-core/src/Servant/Client/Core/Internal/ClientF.hsnew file+10

@@ -0,0 +1,10 @@

1+{-# LANGUAGE DeriveFunctor #-}

2+module Servant.Client.Core.Internal.ClientF where

3+

4+import Servant.Client.Core.Internal.Request

5+

6+data ClientF a

7+ = RunRequest Request (Response -> a)

8+ | StreamingRequest Request (StreamingResponse -> a)

9+ | Throw ServantError

10+ deriving (Functor)

servant-client-core/src/Servant/Client/Core/Internal/Generic.hsnew file+155

@@ -0,0 +1,155 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE DefaultSignatures #-}

3+{-# LANGUAGE FlexibleContexts #-}

4+{-# LANGUAGE FlexibleInstances #-}

5+{-# LANGUAGE MultiParamTypeClasses #-}

6+{-# LANGUAGE TypeFamilies #-}

7+{-# LANGUAGE TypeOperators #-}

8+{-# LANGUAGE UndecidableInstances #-}

9+

10+module Servant.Client.Core.Internal.Generic where

11+

12+import Generics.SOP

13+ (Code, Generic, I (..), NP (..), NS (Z), SOP (..), to)

14+import Servant.API

15+ ((:<|>) (..))

16+

17+-- | This class allows us to match client structure with client functions

18+-- produced with 'client' without explicit pattern-matching.

19+--

20+-- The client structure needs a 'Generics.SOP.Generic' instance.

21+--

22+-- Example:

23+--

24+-- > type API

25+-- > = "foo" :> Capture "x" Int :> Get '[JSON] Int

26+-- > :<|> "bar" :> QueryParam "a" Char :> QueryParam "b" String :> Post '[JSON] [Int]

27+-- > :<|> Capture "nested" Int :> NestedAPI

28+-- >

29+-- > type NestedAPI

30+-- > = Get '[JSON] String

31+-- > :<|> "baz" :> QueryParam "c" Char :> Post '[JSON] ()

32+-- >

33+-- > data APIClient = APIClient

34+-- > { getFoo :: Int -> ClientM Int

35+-- > , postBar :: Maybe Char -> Maybe String -> ClientM [Int]

36+-- > , mkNestedClient :: Int -> NestedClient

37+-- > } deriving GHC.Generic

38+-- >

39+-- > instance Generics.SOP.Generic APIClient

40+-- > instance (Client API ~ client) => ClientLike client APIClient

41+-- >

42+-- > data NestedClient = NestedClient

43+-- > { getString :: ClientM String

44+-- > , postBaz :: Maybe Char -> ClientM ()

45+-- > } deriving GHC.Generic

46+-- >

47+-- > instance Generics.SOP.Generic NestedClient

48+-- > instance (Client NestedAPI ~ client) => ClientLike client NestedClient

49+-- >

50+-- > mkAPIClient :: APIClient

51+-- > mkAPIClient = mkClient (client (Proxy :: Proxy API))

52+--

53+-- By default, left-nested alternatives are expanded:

54+--

55+-- > type API1

56+-- > = "foo" :> Capture "x" Int :> Get '[JSON] Int

57+-- > :<|> "bar" :> QueryParam "a" Char :> Post '[JSON] String

58+-- >

59+-- > type API2

60+-- > = "baz" :> QueryParam "c" Char :> Post '[JSON] ()

61+-- >

62+-- > type API = API1 :<|> API2

63+-- >

64+-- > data APIClient = APIClient

65+-- > { getFoo :: Int -> ClientM Int

66+-- > , postBar :: Maybe Char -> ClientM String

67+-- > , postBaz :: Maybe Char -> ClientM ()

68+-- > } deriving GHC.Generic

69+-- >

70+-- > instance Generics.SOP.Generic APIClient

71+-- > instance (Client API ~ client) => ClientLike client APIClient

72+-- >

73+-- > mkAPIClient :: APIClient

74+-- > mkAPIClient = mkClient (client (Proxy :: Proxy API))

75+--

76+-- If you want to define client for @API1@ as a separate data structure,

77+-- you can use 'genericMkClientP':

78+--

79+-- > data APIClient1 = APIClient1

80+-- > { getFoo :: Int -> ClientM Int

81+-- > , postBar :: Maybe Char -> ClientM String

82+-- > } deriving GHC.Generic

83+-- >

84+-- > instance Generics.SOP.Generic APIClient1

85+-- > instance (Client API1 ~ client) => ClientLike client APIClient1

86+-- >

87+-- > data APIClient = APIClient

88+-- > { mkAPIClient1 :: APIClient1

89+-- > , postBaz :: Maybe Char -> ClientM ()

90+-- > } deriving GHC.Generic

91+-- >

92+-- > instance Generics.SOP.Generic APIClient

93+-- > instance (Client API ~ client) => ClientLike client APIClient where

94+-- > mkClient = genericMkClientP

95+-- >

96+-- > mkAPIClient :: APIClient

97+-- > mkAPIClient = mkClient (client (Proxy :: Proxy API))

98+class ClientLike client custom where

99+ mkClient :: client -> custom

100+ default mkClient :: (Generic custom, Code custom ~ '[xs], GClientList client '[], GClientLikeL (ClientList client '[]) xs)

101+ => client -> custom

102+ mkClient = genericMkClientL

103+

104+instance ClientLike client custom

105+ => ClientLike (a -> client) (a -> custom) where

106+ mkClient c = mkClient . c

107+

108+-- | Match client structure with client functions, regarding left-nested API clients

109+-- as separate data structures.

110+class GClientLikeP client xs where

111+ gMkClientP :: client -> NP I xs

112+

113+instance (GClientLikeP b (y ': xs), ClientLike a x)

114+ => GClientLikeP (a :<|> b) (x ': y ': xs) where

115+ gMkClientP (a :<|> b) = I (mkClient a) :* gMkClientP b

116+

117+instance ClientLike a x => GClientLikeP a '[x] where

118+ gMkClientP a = I (mkClient a) :* Nil

119+

120+-- | Match client structure with client functions, expanding left-nested API clients

121+-- in the same structure.

122+class GClientLikeL (xs :: [*]) (ys :: [*]) where

123+ gMkClientL :: NP I xs -> NP I ys

124+

125+instance GClientLikeL '[] '[] where

126+ gMkClientL Nil = Nil

127+

128+instance (ClientLike x y, GClientLikeL xs ys) => GClientLikeL (x ': xs) (y ': ys) where

129+ gMkClientL (I x :* xs) = I (mkClient x) :* gMkClientL xs

130+

131+type family ClientList (client :: *) (acc :: [*]) :: [*] where

132+ ClientList (a :<|> b) acc = ClientList a (ClientList b acc)

133+ ClientList a acc = a ': acc

134+

135+class GClientList client (acc :: [*]) where

136+ gClientList :: client -> NP I acc -> NP I (ClientList client acc)

137+

138+instance (GClientList b acc, GClientList a (ClientList b acc))

139+ => GClientList (a :<|> b) acc where

140+ gClientList (a :<|> b) acc = gClientList a (gClientList b acc)

141+

142+instance {-# OVERLAPPABLE #-} (ClientList client acc ~ (client ': acc))

143+ => GClientList client acc where

144+ gClientList c acc = I c :* acc

145+

146+-- | Generate client structure from client type, expanding left-nested API (done by default).

147+genericMkClientL :: (Generic custom, Code custom ~ '[xs], GClientList client '[], GClientLikeL (ClientList client '[]) xs)

148+ => client -> custom

149+genericMkClientL = to . SOP . Z . gMkClientL . flip gClientList Nil

150+

151+-- | Generate client structure from client type, regarding left-nested API clients as separate data structures.

152+genericMkClientP :: (Generic custom, Code custom ~ '[xs], GClientLikeP client xs)

153+ => client -> custom

154+genericMkClientP = to . SOP . Z . gMkClientP

155+

servant-client-core/src/Servant/Client/Core/HasClient.hs → servant-client-core/src/Servant/Client/Core/Internal/HasClient.hsrenamed+89−443

@@ -1,4 +1,3 @@

1−{-# LANGUAGE ConstraintKinds #-}

2{-# LANGUAGE DataKinds #-}

1{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE FlexibleContexts #-}

2{-# LANGUAGE FlexibleContexts #-}

4{-# LANGUAGE FlexibleInstances #-}

3{-# LANGUAGE FlexibleInstances #-}

@@ -6,99 +5,59 @@

6{-# LANGUAGE MultiParamTypeClasses #-}

5{-# LANGUAGE MultiParamTypeClasses #-}

7{-# LANGUAGE OverloadedStrings #-}

6{-# LANGUAGE OverloadedStrings #-}

8{-# LANGUAGE PolyKinds #-}

7{-# LANGUAGE PolyKinds #-}

9−{-# LANGUAGE QuantifiedConstraints #-}

10{-# LANGUAGE RankNTypes #-}

8{-# LANGUAGE RankNTypes #-}

11{-# LANGUAGE ScopedTypeVariables #-}

9{-# LANGUAGE ScopedTypeVariables #-}

12−{-# LANGUAGE TypeApplications #-}

13{-# LANGUAGE TypeFamilies #-}

10{-# LANGUAGE TypeFamilies #-}

14{-# LANGUAGE TypeOperators #-}

11{-# LANGUAGE TypeOperators #-}

15{-# LANGUAGE UndecidableInstances #-}

12{-# LANGUAGE UndecidableInstances #-}

16

13

17−module Servant.Client.Core.HasClient (

14+module Servant.Client.Core.Internal.HasClient where

18− clientIn,

19− HasClient (..),

20− EmptyClient (..),

21− AsClientT,

22− (//),

23− (/:),

24− foldMapUnion,

25− matchUnion,

26− ) where

27

15

28import Prelude ()

16import Prelude ()

29import Prelude.Compat

17import Prelude.Compat

30

18

31−import Control.Arrow

19+import Control.Concurrent

32− (left, (+++))

20+ (modifyMVar, newMVar)

33−import Control.Monad

21+import Control.Monad.IO.Class

34− (unless)

22+ (MonadIO (..))

35−import qualified Data.ByteString as BS

36−import qualified Data.ByteString.Lazy as BL

23+import qualified Data.ByteString.Lazy as BL

37−import Data.Either

38− (partitionEithers)

39−import Data.Constraint (Dict(..))

40import Data.Foldable

24import Data.Foldable

41 (toList)

25 (toList)

42import Data.List

26import Data.List

43 (foldl')

27 (foldl')

28+import Data.Proxy

29+ (Proxy (Proxy))

30+import Data.Semigroup

31+ ((<>))

44import Data.Sequence

32import Data.Sequence

45 (fromList)

33 (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))

59import Data.String

34import Data.String

60 (fromString)

35 (fromString)

61import Data.Text

36import Data.Text

62 (Text, pack)

37 (Text, pack)

63−import Data.Proxy

64− (Proxy (Proxy))

65import GHC.TypeLits

38import GHC.TypeLits

66− (KnownNat, KnownSymbol, TypeError, symbolVal)

39+ (KnownSymbol, symbolVal)

67−import Network.HTTP.Types

68− (Status)

69−import qualified Network.HTTP.Types as H

40+import qualified Network.HTTP.Types as H

70import Servant.API

41import Servant.API

71 ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, BasicAuthData,

42 ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, BasicAuthData,

72− BuildHeadersTo (..), Capture', CaptureAll, Description,

43+ BuildHeadersTo (..), ByteStringParser (..), Capture',

73− EmptyAPI, Fragment, FramingRender (..), FramingUnrender (..),

44+ CaptureAll, Description, EmptyAPI, FramingUnrender (..),

74− FromSourceIO (..), Header', Headers (..), HttpVersion,

45+ FromResultStream (..), Header', Headers (..), HttpVersion,

75 IsSecure, MimeRender (mimeRender),

46 IsSecure, MimeRender (mimeRender),

76− MimeUnrender (mimeUnrender), NoContent (NoContent),

47+ MimeUnrender (mimeUnrender), NoContent (NoContent), QueryFlag,

77− NoContentVerb, QueryFlag, QueryParam', QueryParams, Raw, RawM,

78− ReflectMethod (..), RemoteHost, ReqBody', SBoolI, Stream,

48+ QueryParam', QueryParams, Raw, ReflectMethod (..), RemoteHost,

79− StreamBody', Summary, ToHttpApiData, ToSourceIO (..), Vault,

49+ ReqBody', ResultStream (..), SBoolI, Stream, Summary,

80− Verb, WithNamedContext, WithResource, WithStatus (..), contentType, getHeadersHList,

50+ ToHttpApiData, Vault, Verb, WithNamedContext, contentType,

81− getResponse, toEncodedUrlPiece, toUrlPiece, NamedRoutes)

51+ getHeadersHList, getResponse, toQueryParam, toUrlPiece)

82−import Servant.API.Generic

83− (GenericMode(..), ToServant, ToServantApi

84− , GenericServant, toServant, fromServant)

85import Servant.API.ContentTypes

52import Servant.API.ContentTypes

86− (contentTypes, AllMime (allMime), AllMimeUnrender (allMimeUnrender))

53+ (contentTypes)

87−import Servant.API.Status

88− (statusFromNat)

89−import Servant.API.TypeLevel (FragmentUnique, AtLeastOneFragment)

90import Servant.API.Modifiers

54import Servant.API.Modifiers

91 (FoldRequired, RequiredArgument, foldRequiredArgument)

55 (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

56

96−import Servant.Client.Core.Auth

57+import Servant.Client.Core.Internal.Auth

97−import Servant.Client.Core.BasicAuth

58+import Servant.Client.Core.Internal.BasicAuth

98−import Servant.Client.Core.ClientError

59+import Servant.Client.Core.Internal.Request

99−import Servant.Client.Core.Request

100−import Servant.Client.Core.Response

60+import Servant.Client.Core.Internal.RunClient

101−import Servant.Client.Core.RunClient

102

61

103-- * Accessing APIs as a Client

62-- * Accessing APIs as a Client

104

63

@@ -208,7 +167,7 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m api)

208 clientWithRoute pm (Proxy :: Proxy api)

167 clientWithRoute pm (Proxy :: Proxy api)

209 (appendToPath p req)

168 (appendToPath p req)

210

169

211− where p = toEncodedUrlPiece val

170+ where p = (toUrlPiece val)

212

171

213 hoistClientMonad pm _ f cl = \a ->

172 hoistClientMonad pm _ f cl = \a ->

214 hoistClientMonad pm (Proxy :: Proxy api) f (cl a)

173 hoistClientMonad pm (Proxy :: Proxy api) f (cl a)

@@ -243,7 +202,7 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m sublayout)

243 clientWithRoute pm (Proxy :: Proxy sublayout)

202 clientWithRoute pm (Proxy :: Proxy sublayout)

244 (foldl' (flip appendToPath) req ps)

203 (foldl' (flip appendToPath) req ps)

245

204

246− where ps = map toEncodedUrlPiece vals

205+ where ps = map (toUrlPiece) vals

247

206

248 hoistClientMonad pm _ f cl = \as ->

207 hoistClientMonad pm _ f cl = \as ->

249 hoistClientMonad pm (Proxy :: Proxy sublayout) f (cl as)

208 hoistClientMonad pm (Proxy :: Proxy sublayout) f (cl as)

@@ -251,11 +210,10 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m sublayout)

251instance {-# OVERLAPPABLE #-}

210instance {-# OVERLAPPABLE #-}

252 -- Note [Non-Empty Content Types]

211 -- Note [Non-Empty Content Types]

253 ( RunClient m, MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)

212 ( RunClient m, MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)

254− , KnownNat status

255 ) => HasClient m (Verb method status cts' a) where

213 ) => HasClient m (Verb method status cts' a) where

256 type Client m (Verb method status cts' a) = m a

214 type Client m (Verb method status cts' a) = m a

257 clientWithRoute _pm Proxy req = do

215 clientWithRoute _pm Proxy req = do

258− response <- runRequestAcceptStatus (Just [status]) req

216+ response <- runRequest req

259 { requestAccept = fromList $ toList accept

217 { requestAccept = fromList $ toList accept

260 , requestMethod = method

218 , requestMethod = method

261 }

219 }

@@ -263,27 +221,14 @@ instance {-# OVERLAPPABLE #-}

263 where

221 where

264 accept = contentTypes (Proxy :: Proxy ct)

222 accept = contentTypes (Proxy :: Proxy ct)

265 method = reflectMethod (Proxy :: Proxy method)

223 method = reflectMethod (Proxy :: Proxy method)

266− status = statusFromNat (Proxy :: Proxy status)

267

224

268 hoistClientMonad _ _ f ma = f ma

225 hoistClientMonad _ _ f ma = f ma

269

226

270instance {-# OVERLAPPING #-}

227instance {-# OVERLAPPING #-}

271− ( RunClient m, ReflectMethod method, KnownNat status

228+ ( RunClient m, ReflectMethod method

272 ) => HasClient m (Verb method status cts NoContent) where

229 ) => HasClient m (Verb method status cts NoContent) where

273 type Client m (Verb method status cts NoContent)

230 type Client m (Verb method status cts NoContent)

274 = m NoContent

231 = 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

232 clientWithRoute _pm Proxy req = do

288 _response <- runRequest req { requestMethod = method }

233 _response <- runRequest req { requestMethod = method }

289 return NoContent

234 return NoContent

@@ -293,173 +238,91 @@ instance (RunClient m, ReflectMethod method) =>

293

238

294instance {-# OVERLAPPING #-}

239instance {-# OVERLAPPING #-}

295 -- Note [Non-Empty Content Types]

240 -- Note [Non-Empty Content Types]

296− ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls, KnownNat status

241+ ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls

297 , ReflectMethod method, cts' ~ (ct ': cts)

242 , ReflectMethod method, cts' ~ (ct ': cts)

298 ) => HasClient m (Verb method status cts' (Headers ls a)) where

243 ) => HasClient m (Verb method status cts' (Headers ls a)) where

299 type Client m (Verb method status cts' (Headers ls a))

244 type Client m (Verb method status cts' (Headers ls a))

300 = m (Headers ls a)

245 = m (Headers ls a)

301 clientWithRoute _pm Proxy req = do

246 clientWithRoute _pm Proxy req = do

302− response <- runRequestAcceptStatus (Just [status]) req

247+ response <- runRequest req

303 { requestMethod = method

248 { requestMethod = method

304 , requestAccept = fromList $ toList accept

249 , requestAccept = fromList $ toList accept

305 }

250 }

306− val <- response `decodedAs` (Proxy :: Proxy ct)

251+ case mimeUnrender (Proxy :: Proxy ct) $ responseBody response of

252+ Left err -> throwServantError $ DecodeFailure (pack err) response

253+ Right val -> return $ Headers

307− return $ Headers { getResponse = val

254+ { getResponse = val

308− , getHeadersHList = buildHeadersTo . toList $ responseHeaders response

255+ , getHeadersHList = buildHeadersTo . toList $ responseHeaders response

309− }

256+ }

310− where

311− method = reflectMethod (Proxy :: Proxy method)

257+ where method = reflectMethod (Proxy :: Proxy method)

312− accept = contentTypes (Proxy :: Proxy ct)

258+ accept = contentTypes (Proxy :: Proxy ct)

313− status = statusFromNat (Proxy :: Proxy status)

314

259

315 hoistClientMonad _ _ f ma = f ma

260 hoistClientMonad _ _ f ma = f ma

316

261

317instance {-# OVERLAPPING #-}

262instance {-# OVERLAPPING #-}

318− ( RunClient m, BuildHeadersTo ls, ReflectMethod method, KnownNat status

263+ ( RunClient m, BuildHeadersTo ls, ReflectMethod method

319 ) => HasClient m (Verb method status cts (Headers ls NoContent)) where

264 ) => HasClient m (Verb method status cts (Headers ls NoContent)) where

320 type Client m (Verb method status cts (Headers ls NoContent))

265 type Client m (Verb method status cts (Headers ls NoContent))

321 = m (Headers ls NoContent)

266 = m (Headers ls NoContent)

322 clientWithRoute _pm Proxy req = do

267 clientWithRoute _pm Proxy req = do

268+ let method = reflectMethod (Proxy :: Proxy method)

323− response <- runRequestAcceptStatus (Just [status]) req { requestMethod = method }

269+ response <- runRequest req { requestMethod = method }

324 return $ Headers { getResponse = NoContent

270 return $ Headers { getResponse = NoContent

325 , getHeadersHList = buildHeadersTo . toList $ responseHeaders response

271 , getHeadersHList = buildHeadersTo . toList $ responseHeaders response

326 }

272 }

327− where

328− method = reflectMethod (Proxy :: Proxy method)

329− status = statusFromNat (Proxy :: Proxy status)

330

273

331 hoistClientMonad _ _ f ma = f ma

274 hoistClientMonad _ _ f ma = f ma

332

275

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−

419instance {-# OVERLAPPABLE #-}

276instance {-# OVERLAPPABLE #-}

420− ( RunStreamingClient m, MimeUnrender ct chunk, ReflectMethod method,

277+ ( RunClient m, MonadIO m, MimeUnrender ct a, ReflectMethod method,

421− FramingUnrender framing, FromSourceIO chunk a

278+ FramingUnrender framing a, FromResultStream a b

422− ) => HasClient m (Stream method status framing ct a) where

279+ ) => HasClient m (Stream method status framing ct b) where

423

280

424− type Client m (Stream method status framing ct a) = m a

281+ type Client m (Stream method status framing ct b) = m b

425

282

426− hoistClientMonad _ _ f ma = f ma

427−

428− clientWithRoute _pm Proxy req = withStreamingRequest req' $ \gres -> do

283+ clientWithRoute _pm Proxy req = do

429− let mimeUnrender' = mimeUnrender (Proxy :: Proxy ct) :: BL.ByteString -> Either String chunk

284+ sresp <- streamingRequest req

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)]

285+ { requestAccept = fromList [contentType (Proxy :: Proxy ct)]

435− , requestMethod = reflectMethod (Proxy :: Proxy method)

286+ , requestMethod = reflectMethod (Proxy :: Proxy method)

436− }

287+ }

437−

288+ liftIO $ fromResultStream $ ResultStream $ \k ->

438−instance {-# OVERLAPPING #-}

289+ runStreamingResponse sresp $ \gres -> do

439− ( RunStreamingClient m, MimeUnrender ct chunk, ReflectMethod method,

290+ let reader = responseBody gres

440− FramingUnrender framing, FromSourceIO chunk a,

291+ let unrender = unrenderFrames (Proxy :: Proxy framing) (Proxy :: Proxy a)

441− BuildHeadersTo hs

292+ loop bs = do

442− ) => HasClient m (Stream method status framing ct (Headers hs a)) where

293+ res <- BL.fromStrict <$> reader

443−

294+ if BL.null res

444− type Client m (Stream method status framing ct (Headers hs a)) = m (Headers hs a)

295+ then return $ parseEOF unrender res

296+ else let sofar = (bs <> res)

297+ in case parseIncremental unrender sofar of

298+ Just x -> return x

299+ Nothing -> loop sofar

300+ (frameParser, remainder) <- loop BL.empty

301+ state <- newMVar remainder

302+ let frameLoop bs = do

303+ res <- BL.fromStrict <$> reader

304+ let addIsEmptyInfo (a, r) = (r, (a, BL.null r && BL.null res))

305+ if BL.null res

306+ then if BL.null bs

307+ then return ("", (Right "", True))

308+ else return . addIsEmptyInfo $ parseEOF frameParser bs

309+ else let sofar = (bs <> res)

310+ in case parseIncremental frameParser sofar of

311+ Just x -> return $ addIsEmptyInfo x

312+ Nothing -> frameLoop sofar

313+

314+ go = processResult <$> modifyMVar state frameLoop

315+ processResult (Right bs,isDone) =

316+ if BL.null bs && isDone

317+ then Nothing

318+ else Just $ case mimeUnrender (Proxy :: Proxy ct) bs :: Either String a of

319+ Left err -> Left err

320+ Right x -> Right x

321+ processResult (Left err, _) = Just (Left err)

322+ k go

445

323

446 hoistClientMonad _ _ f ma = f ma

324 hoistClientMonad _ _ f ma = f ma

447

325

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,

326-- | If you use a 'Header' in one of your endpoints in your API,

464-- the corresponding querying function will automatically take

327-- the corresponding querying function will automatically take

465-- an additional argument of the type specified by your 'Header',

328-- an additional argument of the type specified by your 'Header',

@@ -569,7 +432,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequire

569 (Proxy :: Proxy mods) add (maybe req add) mparam

432 (Proxy :: Proxy mods) add (maybe req add) mparam

570 where

433 where

571 add :: a -> Request

434 add :: a -> Request

572− add param = appendToQueryString pname (Just $ encodeQueryParamValue param) req

435+ add param = appendToQueryString pname (Just $ toQueryParam param) req

573

436

574 pname :: Text

437 pname :: Text

575 pname = pack $ symbolVal (Proxy :: Proxy sym)

438 pname = pack $ symbolVal (Proxy :: Proxy sym)

@@ -618,7 +481,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api)

618 )

481 )

619

482

620 where pname = pack $ symbolVal (Proxy :: Proxy sym)

483 where pname = pack $ symbolVal (Proxy :: Proxy sym)

621− paramlist' = map (Just . encodeQueryParamValue) paramlist

484+ paramlist' = map (Just . toQueryParam) paramlist

622

485

623 hoistClientMonad pm _ f cl = \as ->

486 hoistClientMonad pm _ f cl = \as ->

624 hoistClientMonad pm (Proxy :: Proxy api) f (cl as)

487 hoistClientMonad pm (Proxy :: Proxy api) f (cl as)

@@ -674,16 +537,6 @@ instance RunClient m => HasClient m Raw where

674

537

675 hoistClientMonad _ _ f cl = \meth -> f (cl meth)

538 hoistClientMonad _ _ f cl = \meth -> f (cl meth)

676

539

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,

540-- | If you use a 'ReqBody' in one of your endpoints in your API,

688-- the corresponding querying function will automatically take

541-- the corresponding querying function will automatically take

689-- an additional argument of the type specified by your 'ReqBody'.

542-- an additional argument of the type specified by your 'ReqBody'.

@@ -720,28 +573,6 @@ instance (MimeRender ct a, HasClient m api)

720 hoistClientMonad pm _ f cl = \a ->

573 hoistClientMonad pm _ f cl = \a ->

721 hoistClientMonad pm (Proxy :: Proxy api) f (cl a)

574 hoistClientMonad pm (Proxy :: Proxy api) f (cl a)

722

575

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.

576-- | Make the querying function append @path@ to the request path.

746instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where

577instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where

747 type Client m (path :> api) = Client m api

578 type Client m (path :> api) = Client m api

@@ -750,7 +581,7 @@ instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where

750 clientWithRoute pm (Proxy :: Proxy api)

581 clientWithRoute pm (Proxy :: Proxy api)

751 (appendToPath p req)

582 (appendToPath p req)

752

583

753− where p = toEncodedUrlPiece $ pack $ symbolVal (Proxy :: Proxy path)

584+ where p = pack $ symbolVal (Proxy :: Proxy path)

754

585

755 hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl

586 hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl

756

587

@@ -786,14 +617,6 @@ instance HasClient m subapi =>

786

617

787 hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy subapi) f cl

618 hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy subapi) f cl

788

619

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−

797instance ( HasClient m api

620instance ( HasClient m api

798 ) => HasClient m (AuthProtect tag :> api) where

621 ) => HasClient m (AuthProtect tag :> api) where

799 type Client m (AuthProtect tag :> api)

622 type Client m (AuthProtect tag :> api)

@@ -805,29 +628,6 @@ instance ( HasClient m api

805 hoistClientMonad pm _ f cl = \authreq ->

628 hoistClientMonad pm _ f cl = \authreq ->

806 hoistClientMonad pm (Proxy :: Proxy api) f (cl authreq)

629 hoistClientMonad pm (Proxy :: Proxy api) f (cl authreq)

807

630

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

631-- * Basic Authentication

832

632

833instance HasClient m api => HasClient m (BasicAuth realm usr :> api) where

633instance HasClient m api => HasClient m (BasicAuth realm usr :> api) where

@@ -839,120 +639,6 @@ instance HasClient m api => HasClient m (BasicAuth realm usr :> api) where

839 hoistClientMonad pm _ f cl = \bauth ->

639 hoistClientMonad pm _ f cl = \bauth ->

840 hoistClientMonad pm (Proxy :: Proxy api) f (cl bauth)

640 hoistClientMonad pm (Proxy :: Proxy api) f (cl bauth)

841

641

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

642

957{- Note [Non-Empty Content Types]

643{- Note [Non-Empty Content Types]

958~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

644~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

@@ -969,43 +655,3 @@ non-empty lists, but is otherwise more specific, no instance will be overall

969more specific. This in turn generally means adding yet another instance (one

655more specific. This in turn generally means adding yet another instance (one

970for empty and one for non-empty lists).

656for empty and one for non-empty lists).

971-}

657-}

972−

973−-------------------------------------------------------------------------------

974−-- helpers

975−-------------------------------------------------------------------------------

976−

977−checkContentTypeHeader :: RunClient m => Response -> m MediaType

978−checkContentTypeHeader response =

979− case lookup "Content-Type" $ toList $ responseHeaders response of

980− Nothing -> return $ "application" Media.// "octet-stream"

981− Just t -> case parseAccept t of

982− Nothing -> throwClientError $ InvalidContentTypeHeader response

983− Just t' -> return t'

984−

985−decodedAs :: forall ct a m. (MimeUnrender ct a, RunClient m)

986− => Response -> Proxy ct -> m a

987−decodedAs response ct = do

988− responseContentType <- checkContentTypeHeader response

989− unless (any (matches responseContentType) accept) $

990− throwClientError $ UnsupportedContentType responseContentType response

991− case mimeUnrender ct $ responseBody response of

992− Left err -> throwClientError $ DecodeFailure (T.pack err) response

993− Right val -> return val

994− where

995− accept = toList $ contentTypes ct

996−

997−-------------------------------------------------------------------------------

998−-- Custom type errors

999−-------------------------------------------------------------------------------

1000−

1001−-- Erroring instance for HasClient' when a combinator is not fully applied

1002−instance (RunClient m, TypeError (PartialApplication HasClient arr)) => HasClient m ((arr :: a -> b) :> sub)

1003− where

1004− type Client m (arr :> sub) = TypeError (PartialApplication HasClient arr)

1005− clientWithRoute _ _ _ = error "unreachable"

1006− hoistClientMonad _ _ _ _ = error "unreachable"

1007−

1008−-- Erroring instances for 'HasClient' for unknown API combinators

1009−instance {-# OVERLAPPABLE #-} (RunClient m, TypeError (NoInstanceForSub (HasClient m) ty)) => HasClient m (ty :> sub)

1010−

1011−instance {-# OVERLAPPABLE #-} (RunClient m, TypeError (NoInstanceFor (HasClient m api))) => HasClient m api

servant-client-core/src/Servant/Client/Core/Internal/Request.hsnew file+138

@@ -0,0 +1,138 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE DeriveDataTypeable #-}

3+{-# LANGUAGE DeriveFoldable #-}

4+{-# LANGUAGE DeriveFunctor #-}

5+{-# LANGUAGE DeriveGeneric #-}

6+{-# LANGUAGE DeriveTraversable #-}

7+{-# LANGUAGE MultiParamTypeClasses #-}

8+{-# LANGUAGE OverloadedStrings #-}

9+{-# LANGUAGE RankNTypes #-}

10+{-# LANGUAGE ScopedTypeVariables #-}

11+{-# LANGUAGE TypeFamilies #-}

12+

13+module Servant.Client.Core.Internal.Request where

14+

15+import Prelude ()

16+import Prelude.Compat

17+

18+import Control.Monad.Catch

19+ (Exception)

20+import qualified Data.ByteString as BS

21+import qualified Data.ByteString.Builder as Builder

22+import qualified Data.ByteString.Lazy as LBS

23+import Data.Int

24+ (Int64)

25+import Data.Semigroup

26+ ((<>))

27+import qualified Data.Sequence as Seq

28+import Data.Text

29+ (Text)

30+import Data.Text.Encoding

31+ (encodeUtf8)

32+import Data.Typeable

33+ (Typeable)

34+import GHC.Generics

35+ (Generic)

36+import Network.HTTP.Media

37+ (MediaType)

38+import Network.HTTP.Types

39+ (Header, HeaderName, HttpVersion, Method, QueryItem, Status,

40+ http11, methodGet)

41+import Web.HttpApiData

42+ (ToHttpApiData, toEncodedUrlPiece, toHeader)

43+

44+-- | A type representing possible errors in a request

45+--

46+-- Note that this type substantially changed in 0.12.

47+data ServantError =

48+ -- | The server returned an error response

49+ FailureResponse Response

50+ -- | The body could not be decoded at the expected type

51+ | DecodeFailure Text Response

52+ -- | The content-type of the response is not supported

53+ | UnsupportedContentType MediaType Response

54+ -- | The content-type header is invalid

55+ | InvalidContentTypeHeader Response

56+ -- | There was a connection error, and no response was received

57+ | ConnectionError Text

58+ deriving (Eq, Show, Generic, Typeable)

59+

60+instance Exception ServantError

61+

62+data RequestF a = Request

63+ { requestPath :: a

64+ , requestQueryString :: Seq.Seq QueryItem

65+ , requestBody :: Maybe (RequestBody, MediaType)

66+ , requestAccept :: Seq.Seq MediaType

67+ , requestHeaders :: Seq.Seq Header

68+ , requestHttpVersion :: HttpVersion

69+ , requestMethod :: Method

70+ } deriving (Generic, Typeable)

71+

72+type Request = RequestF Builder.Builder

73+

74+-- | The request body. A replica of the @http-client@ @RequestBody@.

75+data RequestBody

76+ = RequestBodyLBS LBS.ByteString

77+ | RequestBodyBS BS.ByteString

78+ | RequestBodyBuilder Int64 Builder.Builder

79+ | RequestBodyStream Int64 ((IO BS.ByteString -> IO ()) -> IO ())

80+ | RequestBodyStreamChunked ((IO BS.ByteString -> IO ()) -> IO ())

81+ | RequestBodyIO (IO RequestBody)

82+ deriving (Generic, Typeable)

83+

84+data GenResponse a = Response

85+ { responseStatusCode :: Status

86+ , responseHeaders :: Seq.Seq Header

87+ , responseHttpVersion :: HttpVersion

88+ , responseBody :: a

89+ } deriving (Eq, Show, Generic, Typeable, Functor, Foldable, Traversable)

90+

91+type Response = GenResponse LBS.ByteString

92+newtype StreamingResponse = StreamingResponse { runStreamingResponse :: forall a. (GenResponse (IO BS.ByteString) -> IO a) -> IO a }

93+

94+-- A GET request to the top-level path

95+defaultRequest :: Request

96+defaultRequest = Request

97+ { requestPath = ""

98+ , requestQueryString = Seq.empty

99+ , requestBody = Nothing

100+ , requestAccept = Seq.empty

101+ , requestHeaders = Seq.empty

102+ , requestHttpVersion = http11

103+ , requestMethod = methodGet

104+ }

105+

106+appendToPath :: Text -> Request -> Request

107+appendToPath p req

108+ = req { requestPath = requestPath req <> "/" <> toEncodedUrlPiece p }

109+

110+appendToQueryString :: Text -- ^ param name

111+ -> Maybe Text -- ^ param value

112+ -> Request

113+ -> Request

114+appendToQueryString pname pvalue req

115+ = req { requestQueryString = requestQueryString req

116+ Seq.|> (encodeUtf8 pname, encodeUtf8 <$> pvalue)}

117+

118+addHeader :: ToHttpApiData a => HeaderName -> a -> Request -> Request

119+addHeader name val req

120+ = req { requestHeaders = requestHeaders req Seq.|> (name, toHeader val)}

121+

122+-- | Set body and media type of the request being constructed.

123+--

124+-- The body is set to the given bytestring using the 'RequestBodyLBS'

125+-- constructor.

126+--

127+-- @since 0.12

128+--

129+setRequestBodyLBS :: LBS.ByteString -> MediaType -> Request -> Request

130+setRequestBodyLBS b t req

131+ = req { requestBody = Just (RequestBodyLBS b, t) }

132+

133+-- | Set body and media type of the request being constructed.

134+--

135+-- @since 0.12

136+--

137+setRequestBody :: RequestBody -> MediaType -> Request -> Request

138+setRequestBody b t req = req { requestBody = Just (b, t) }

servant-client-core/src/Servant/Client/Core/Internal/RunClient.hsnew file+60

@@ -0,0 +1,60 @@

1+{-# LANGUAGE FlexibleContexts #-}

2+{-# LANGUAGE MultiParamTypeClasses #-}

3+{-# LANGUAGE OverloadedStrings #-}

4+{-# LANGUAGE ScopedTypeVariables #-}

5+{-# LANGUAGE TypeFamilies #-}

6+-- | Types for possible backends to run client-side `Request` queries

7+module Servant.Client.Core.Internal.RunClient where

8+

9+import Prelude ()

10+import Prelude.Compat

11+

12+import Control.Monad

13+ (unless)

14+import Control.Monad.Free

15+ (Free (..), liftF)

16+import Data.Foldable

17+ (toList)

18+import Data.Proxy

19+ (Proxy)

20+import qualified Data.Text as T

21+import Network.HTTP.Media

22+ (MediaType, matches, parseAccept, (//))

23+import Servant.API

24+ (MimeUnrender, contentTypes, mimeUnrender)

25+

26+import Servant.Client.Core.Internal.ClientF

27+import Servant.Client.Core.Internal.Request

28+ (GenResponse (..), Request, Response, ServantError (..),

29+ StreamingResponse (..))

30+

31+class Monad m => RunClient m where

32+ -- | How to make a request.

33+ runRequest :: Request -> m Response

34+ streamingRequest :: Request -> m StreamingResponse

35+ throwServantError :: ServantError -> m a

36+

37+checkContentTypeHeader :: RunClient m => Response -> m MediaType

38+checkContentTypeHeader response =

39+ case lookup "Content-Type" $ toList $ responseHeaders response of

40+ Nothing -> return $ "application"//"octet-stream"

41+ Just t -> case parseAccept t of

42+ Nothing -> throwServantError $ InvalidContentTypeHeader response

43+ Just t' -> return t'

44+

45+decodedAs :: forall ct a m. (MimeUnrender ct a, RunClient m)

46+ => Response -> Proxy ct -> m a

47+decodedAs response contentType = do

48+ responseContentType <- checkContentTypeHeader response

49+ unless (any (matches responseContentType) accept) $

50+ throwServantError $ UnsupportedContentType responseContentType response

51+ case mimeUnrender contentType $ responseBody response of

52+ Left err -> throwServantError $ DecodeFailure (T.pack err) response

53+ Right val -> return val

54+ where

55+ accept = toList $ contentTypes contentType

56+

57+instance ClientF ~ f => RunClient (Free f) where

58+ runRequest req = liftF (RunRequest req id)

59+ streamingRequest req = liftF (StreamingRequest req id)

60+ throwServantError = liftF . Throw

servant-client-core/src/Servant/Client/Core/Reexport.hs+10−13

@@ -5,19 +5,17 @@ module Servant.Client.Core.Reexport

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.Generic

32+import Servant.Client.Core.Internal.HasClient

35−import Servant.Client.Core.Response

33+import Servant.Client.Core.Internal.Request

36−import Servant.Client.Core.ClientError

servant-client-core/src/Servant/Client/Core/Request.hsdeleted−192

@@ -1,192 +0,0 @@

1−{-# LANGUAGE DeriveDataTypeable #-}

2−{-# LANGUAGE DeriveFoldable #-}

3−{-# LANGUAGE DeriveFunctor #-}

4−{-# LANGUAGE DeriveGeneric #-}

5−{-# LANGUAGE DeriveTraversable #-}

6−{-# LANGUAGE MultiParamTypeClasses #-}

7−{-# LANGUAGE OverloadedStrings #-}

8−{-# LANGUAGE RankNTypes #-}

9−{-# LANGUAGE ScopedTypeVariables #-}

10−{-# LANGUAGE TypeFamilies #-}

11−module Servant.Client.Core.Request (

12− Request,

13− RequestF (..),

14− RequestBody (..),

15− defaultRequest,

16− -- ** Modifiers

17− addHeader,

18− appendToPath,

19− appendToQueryString,

20− encodeQueryParamValue,

21− setRequestBody,

22− setRequestBodyLBS,

23− ) where

24−

25−import Prelude ()

26−import Prelude.Compat

27−

28−import Control.DeepSeq

29− (NFData (..))

30−import Data.Bifoldable

31− (Bifoldable (..))

32−import Data.Bifunctor

33− (Bifunctor (..))

34−import Data.Bitraversable

35− (Bitraversable (..), bifoldMapDefault, bimapDefault)

36−import qualified Data.ByteString as BS

37−import Data.ByteString.Builder

38− (Builder)

39−import qualified Data.ByteString.Builder as Builder

40−import qualified Data.ByteString.Lazy as LBS

41−import qualified Data.Sequence as Seq

42−import Data.Text

43− (Text)

44−import Data.Text.Encoding

45− (encodeUtf8)

46−import Data.Typeable

47− (Typeable)

48−import GHC.Generics

49− (Generic)

50−import Network.HTTP.Media

51− (MediaType)

52−import Network.HTTP.Types

53− (Header, HeaderName, HttpVersion (..), Method, QueryItem,

54− http11, methodGet)

55−import Servant.API

56− (ToHttpApiData, toEncodedUrlPiece, toHeader, SourceIO)

57−

58−import Servant.Client.Core.Internal (mediaTypeRnf)

59−

60−data RequestF body path = Request

61− { requestPath :: path

62− , requestQueryString :: Seq.Seq QueryItem

63− , requestBody :: Maybe (body, MediaType)

64− , requestAccept :: Seq.Seq MediaType

65− , requestHeaders :: Seq.Seq Header

66− , requestHttpVersion :: HttpVersion

67− , requestMethod :: Method

68− } deriving (Generic, Typeable, Eq, Functor, Foldable, Traversable)

69−

70−instance (Show a, Show b) =>

71− Show (Servant.Client.Core.Request.RequestF a b) where

72− showsPrec p req

73− = showParen

74− (p >= 11)

75− ( showString "Request {requestPath = "

76− . showsPrec 0 (requestPath req)

77− . showString ", requestQueryString = "

78− . showsPrec 0 (requestQueryString req)

79− . showString ", requestBody = "

80− . showsPrec 0 (requestBody req)

81− . showString ", requestAccept = "

82− . showsPrec 0 (requestAccept req)

83− . showString ", requestHeaders = "

84− . showsPrec 0 (redactSensitiveHeader <$> requestHeaders req)

85− . showString ", requestHttpVersion = "

86− . showsPrec 0 (requestHttpVersion req)

87− . showString ", requestMethod = "

88− . showsPrec 0 (requestMethod req)

89− . showString "}"

90− )

91− where

92− redactSensitiveHeader :: Header -> Header

93− redactSensitiveHeader ("Authorization", _) = ("Authorization", "<REDACTED>")

94− redactSensitiveHeader h = h

95−instance Bifunctor RequestF where bimap = bimapDefault

96−instance Bifoldable RequestF where bifoldMap = bifoldMapDefault

97−instance Bitraversable RequestF where

98− bitraverse f g r = mk

99− <$> traverse (bitraverse f pure) (requestBody r)

100− <*> g (requestPath r)

101− where

102− mk b p = r { requestBody = b, requestPath = p }

103−

104−instance (NFData path, NFData body) => NFData (RequestF body path) where

105− rnf r =

106− rnf (requestPath r)

107− `seq` rnf (requestQueryString r)

108− `seq` rnfB (requestBody r)

109− `seq` rnf (fmap mediaTypeRnf (requestAccept r))

110− `seq` rnf (requestHeaders r)

111− `seq` requestHttpVersion r

112− `seq` rnf (requestMethod r)

113− where

114− rnfB Nothing = ()

115− rnfB (Just (b, mt)) = rnf b `seq` mediaTypeRnf mt

116−

117−type Request = RequestF RequestBody Builder

118−

119−-- | The request body. R replica of the @http-client@ @RequestBody@.

120−data RequestBody

121− = RequestBodyLBS LBS.ByteString

122− | RequestBodyBS BS.ByteString

123− | RequestBodySource (SourceIO LBS.ByteString)

124− deriving (Generic, Typeable)

125−

126−instance Show RequestBody where

127− showsPrec d (RequestBodyLBS lbs) = showParen (d > 10)

128− $ showString "RequestBodyLBS "

129− . showsPrec 11 lbs

130− showsPrec d (RequestBodyBS bs) = showParen (d > 10)

131− $ showString "RequestBodyBS "

132− . showsPrec 11 bs

133− showsPrec d (RequestBodySource _) = showParen (d > 10)

134− $ showString "RequestBodySource <IO>"

135−

136−-- A GET request to the top-level path

137−defaultRequest :: Request

138−defaultRequest = Request

139− { requestPath = ""

140− , requestQueryString = Seq.empty

141− , requestBody = Nothing

142− , requestAccept = Seq.empty

143− , requestHeaders = Seq.empty

144− , requestHttpVersion = http11

145− , requestMethod = methodGet

146− }

147−

148−-- | Append extra path to the request being constructed.

149−--

150−-- Warning: This function assumes that the path fragment is already URL-encoded.

151−appendToPath :: Builder -> Request -> Request

152−appendToPath p req

153− = req { requestPath = requestPath req <> "/" <> p }

154−

155−-- | Append a query parameter to the request being constructed.

156−--

157−appendToQueryString :: Text -- ^ query param name

158− -> Maybe BS.ByteString -- ^ query param value

159− -> Request

160− -> Request

161−appendToQueryString pname pvalue req

162− = req { requestQueryString = requestQueryString req

163− Seq.|> (encodeUtf8 pname, pvalue)}

164−

165−-- | Encode a query parameter value.

166−--

167−encodeQueryParamValue :: ToHttpApiData a => a -> BS.ByteString

168−encodeQueryParamValue = LBS.toStrict . Builder.toLazyByteString . toEncodedUrlPiece

169−

170−-- | Add header to the request being constructed.

171−--

172−addHeader :: ToHttpApiData a => HeaderName -> a -> Request -> Request

173−addHeader name val req

174− = req { requestHeaders = requestHeaders req Seq.|> (name, toHeader val)}

175−

176−-- | Set body and media type of the request being constructed.

177−--

178−-- The body is set to the given bytestring using the 'RequestBodyLBS'

179−-- constructor.

180−--

181−-- @since 0.12

182−--

183−setRequestBodyLBS :: LBS.ByteString -> MediaType -> Request -> Request

184−setRequestBodyLBS b t req

185− = req { requestBody = Just (RequestBodyLBS b, t) }

186−

187−-- | Set body and media type of the request being constructed.

188−--

189−-- @since 0.12

190−--

191−setRequestBody :: RequestBody -> MediaType -> Request -> Request

192−setRequestBody b t req = req { requestBody = Just (b, t) }

servant-client-core/src/Servant/Client/Core/Response.hsdeleted−53

@@ -1,53 +0,0 @@

1−{-# LANGUAGE DeriveDataTypeable #-}

2−{-# LANGUAGE DeriveFoldable #-}

3−{-# LANGUAGE DeriveFunctor #-}

4−{-# LANGUAGE DeriveGeneric #-}

5−{-# LANGUAGE DeriveTraversable #-}

6−{-# LANGUAGE MultiParamTypeClasses #-}

7−{-# LANGUAGE RankNTypes #-}

8−{-# LANGUAGE ScopedTypeVariables #-}

9−{-# LANGUAGE TypeFamilies #-}

10−

11−module Servant.Client.Core.Response (

12− Response,

13− StreamingResponse,

14− ResponseF (..),

15− ) where

16−

17−import Prelude ()

18−import Prelude.Compat

19−

20−import Control.DeepSeq

21− (NFData (..))

22−import qualified Data.ByteString as BS

23−import qualified Data.ByteString.Lazy as LBS

24−import qualified Data.Sequence as Seq

25−import Data.Typeable

26− (Typeable)

27−import GHC.Generics

28− (Generic)

29−import Network.HTTP.Types

30− (Header, HttpVersion (..), Status (..))

31−

32−import Servant.API.Stream

33− (SourceIO)

34−

35−data ResponseF a = Response

36− { responseStatusCode :: Status

37− , responseHeaders :: Seq.Seq Header

38− , responseHttpVersion :: HttpVersion

39− , responseBody :: a

40− } deriving (Eq, Show, Generic, Typeable, Functor, Foldable, Traversable)

41−

42−instance NFData a => NFData (ResponseF a) where

43− rnf (Response sc hs hv body) =

44− rnfStatus sc `seq`

45− rnf hs `seq`

46− rnfHttpVersion hv `seq`

47− rnf body

48− where

49− rnfStatus (Status code msg) = rnf code `seq` rnf msg

50− rnfHttpVersion (HttpVersion _ _) = () -- HttpVersion fields are strict

51−

52−type Response = ResponseF LBS.ByteString

53−type StreamingResponse = ResponseF (SourceIO BS.ByteString)

servant-client-core/src/Servant/Client/Core/RunClient.hsdeleted−55

@@ -1,55 +0,0 @@

1−{-# LANGUAGE DeriveFunctor #-}

2−{-# LANGUAGE FlexibleContexts #-}

3−{-# LANGUAGE MultiParamTypeClasses #-}

4−{-# LANGUAGE OverloadedStrings #-}

5−{-# LANGUAGE ScopedTypeVariables #-}

6−{-# LANGUAGE TypeFamilies #-}

7−-- | Types for possible backends to run client-side `Request` queries

8−module Servant.Client.Core.RunClient (

9− RunClient (..),

10− runRequest,

11− RunStreamingClient (..),

12− ClientF (..),

13− ) where

14−

15−import Prelude ()

16−import Prelude.Compat

17−

18−import Network.HTTP.Types.Status

19− (Status)

20−import Control.Monad.Free

21− (Free (..), liftF)

22−

23−import Servant.Client.Core.ClientError

24−import Servant.Client.Core.Request

25−import Servant.Client.Core.Response

26−

27−class Monad m => RunClient m where

28− -- | How to make a request, with an optional list of status codes to not throw exceptions

29− -- for (default: [200..299]).

30− runRequestAcceptStatus :: Maybe [Status] -> Request -> m Response

31− throwClientError :: ClientError -> m a

32−

33−-- | How to make a request.

34−runRequest :: RunClient m => Request -> m Response

35−runRequest = runRequestAcceptStatus Nothing

36−

37−class RunClient m => RunStreamingClient m where

38− withStreamingRequest :: Request -> (StreamingResponse -> IO a) -> m a

39−

40−-------------------------------------------------------------------------------

41−-- Free

42−-------------------------------------------------------------------------------

43−

44−-- | 'ClientF' cannot stream.

45−--

46−-- Compare to 'RunClient'.

47−data ClientF a

48− = RunRequest Request (Response -> a)

49− | Throw ClientError

50− deriving (Functor)

51−

52−-- TODO: honour the accept-status argument.

53−instance ClientF ~ f => RunClient (Free f) where

54− runRequestAcceptStatus _ req = liftF (RunRequest req id)

55− throwClientError = liftF . Throw

servant-client-core/src/Servant/Client/Free.hs+1−1

@@ -11,8 +11,8 @@ import Control.Monad.Free

11import Data.Proxy

11import Data.Proxy

12 (Proxy (..))

12 (Proxy (..))

13import Servant.Client.Core

13import Servant.Client.Core

14+import Servant.Client.Core.Internal.ClientF

14import Servant.Client.Core.Reexport

15import Servant.Client.Core.Reexport

15−import Servant.Client.Core.RunClient

16

16

17client :: HasClient (Free ClientF) api => Proxy api -> Client (Free ClientF) api

17client :: HasClient (Free ClientF) api => Proxy api -> Client (Free ClientF) api

18client api = api `clientIn` (Proxy :: Proxy (Free ClientF))

18client api = api `clientIn` (Proxy :: Proxy (Free ClientF))

servant-client-core/src/Servant/Client/Generic.hs+11−8

@@ -1,10 +1,9 @@

1−{-# OPTIONS_GHC -fno-warn-orphans #-}

1+{-# LANGUAGE ConstraintKinds #-}

2−{-# LANGUAGE FlexibleContexts #-}

2+{-# LANGUAGE FlexibleContexts #-}

3−{-# LANGUAGE KindSignatures #-}

3+{-# LANGUAGE KindSignatures #-}

4−{-# LANGUAGE RankNTypes #-}

4+{-# LANGUAGE RankNTypes #-}

5−{-# LANGUAGE ScopedTypeVariables #-}

5+{-# LANGUAGE ScopedTypeVariables #-}

6−{-# LANGUAGE TypeFamilies #-}

6+{-# LANGUAGE TypeFamilies #-}

7−

8module Servant.Client.Generic (

7module Servant.Client.Generic (

9 AsClientT,

8 AsClientT,

10 genericClient,

9 genericClient,

@@ -16,7 +15,11 @@ import Data.Proxy

16

15

17import Servant.API.Generic

16import Servant.API.Generic

18import Servant.Client.Core

17import Servant.Client.Core

19−import Servant.Client.Core.HasClient (AsClientT)

18+

19+-- | A type that specifies that an API reocrd contains a client implementation.

20+data AsClientT (m :: * -> *)

21+instance GenericMode (AsClientT m) where

22+ type AsClientT m :- api = Client m api

20

23

21-- | Generate a record of client functions.

24-- | Generate a record of client functions.

22genericClient

25genericClient

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.14

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.12

35+ , bytestring >= 0.10 && < 0.11

36+ , case-insensitive >= 1.2.0.0 && < 1.3.0.0

37+ , containers >= 0.5 && < 0.6

38+ , exceptions >= 0.8 && < 0.11

39+ , ghcjs-base >= 0.2.0.0 && < 0.3.0.0

40+ , ghcjs-prim >= 0.1.0.0 && < 0.2.0.0

41+ , http-media >= 0.6.2 && < 0.8

42+ , http-types >= 0.12 && < 0.13

43+ , monad-control >= 1.0.0.4 && < 1.1

44+ , mtl >= 2.1 && < 2.3

45+ , semigroupoids >= 4.3 && < 5.3

60− , servant-client-core >=0.16 && <0.20

46+ , servant-client-core == 0.14.*

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+48−52

@@ -18,48 +18,35 @@ import Control.Arrow

18import Control.Concurrent

18import Control.Concurrent

19import Control.Exception

19import Control.Exception

20import Control.Monad

20import Control.Monad

21−import Control.Monad.Base

21+import Control.Monad.Base (MonadBase (..))

22− (MonadBase (..))

23−import Control.Monad.Catch

22+import Control.Monad.Catch (MonadCatch, MonadThrow)

24− (MonadCatch, MonadThrow)

25−import Control.Monad.Error.Class

23+import Control.Monad.Error.Class (MonadError (..))

26− (MonadError (..))

27import Control.Monad.Reader

24import Control.Monad.Reader

28−import Control.Monad.Trans.Control

25+import Control.Monad.Trans.Control (MonadBaseControl (..))

29− (MonadBaseControl (..))

30import Control.Monad.Trans.Except

26import Control.Monad.Trans.Except

31−import Data.Bifunctor

32− (bimap)

33−import Data.ByteString.Builder

34− (toLazyByteString)

27+import Data.ByteString.Builder (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

29+import qualified Data.ByteString.Lazy as BL

37import Data.CaseInsensitive

30import Data.CaseInsensitive

38import Data.Char

31import Data.Char

39−import Data.Foldable

32+import Data.Foldable (toList)

40− (toList)

41−import Data.Functor.Alt

33+import Data.Functor.Alt (Alt (..))

42− (Alt (..))

34+import Data.IORef (modifyIORef, newIORef, readIORef)

43−import Data.Proxy

44− (Proxy (..))

35+import Data.Proxy (Proxy (..))

45−import qualified Data.Sequence as Seq

36+import qualified Data.Sequence as Seq

46import Data.String.Conversions

37import Data.String.Conversions

47−import Data.Typeable

38+import Data.Typeable (Typeable)

48− (Typeable)

49import Foreign.StablePtr

39import Foreign.StablePtr

50import GHC.Generics

40import GHC.Generics

51−import qualified GHCJS.Buffer as Buffer

41+import qualified GHCJS.Buffer as Buffer

52import GHCJS.Foreign.Callback

42import GHCJS.Foreign.Callback

53import GHCJS.Prim

43import GHCJS.Prim

54import GHCJS.Types

44import GHCJS.Types

55−import JavaScript.TypedArray.ArrayBuffer

45+import JavaScript.TypedArray.ArrayBuffer ( ArrayBuffer )

56− (ArrayBuffer)

57import JavaScript.Web.Location

46import JavaScript.Web.Location

58−import Network.HTTP.Media

47+import Network.HTTP.Media (renderHeader)

59− (renderHeader)

60import Network.HTTP.Types

48import Network.HTTP.Types

61import Servant.Client.Core

49import Servant.Client.Core

62−import qualified Servant.Types.SourceT as S

63

50

64newtype JSXMLHttpRequest = JSXMLHttpRequest JSVal

51newtype JSXMLHttpRequest = JSXMLHttpRequest JSVal

65

52

@@ -94,16 +81,16 @@ client api = api `clientIn` (Proxy :: Proxy ClientM)

94--

81--

95-- NOTE: Does not support constant space streaming of the request body!

82-- NOTE: Does not support constant space streaming of the request body!

96newtype ClientM a = ClientM

83newtype ClientM a = ClientM

97− { runClientM' :: ReaderT ClientEnv (ExceptT ClientError IO) a }

84+ { runClientM' :: ReaderT ClientEnv (ExceptT ServantError IO) a }

98 deriving ( Functor, Applicative, Monad, MonadIO, Generic

85 deriving ( Functor, Applicative, Monad, MonadIO, Generic

99− , MonadReader ClientEnv, MonadError ClientError, MonadThrow

86+ , MonadReader ClientEnv, MonadError ServantError, MonadThrow

100 , MonadCatch)

87 , MonadCatch)

101

88

102instance MonadBase IO ClientM where

89instance MonadBase IO ClientM where

103 liftBase = ClientM . liftBase

90 liftBase = ClientM . liftBase

104

91

105instance MonadBaseControl IO ClientM where

92instance MonadBaseControl IO ClientM where

106− type StM ClientM a = Either ClientError a

93+ type StM ClientM a = Either ServantError a

107

94

108 liftBaseWith f = ClientM (liftBaseWith (\g -> f (g . runClientM')))

95 liftBaseWith f = ClientM (liftBaseWith (\g -> f (g . runClientM')))

109

96

@@ -120,13 +107,17 @@ instance Exception StreamingNotSupportedException where

120 displayException _ = "streamingRequest: streaming is not supported!"

107 displayException _ = "streamingRequest: streaming is not supported!"

121

108

122instance RunClient ClientM where

109instance RunClient ClientM where

123− runRequestAcceptStatus = performRequest

110+ runRequest = performRequest

124− throwClientError = throwError

111+ streamingRequest _ = liftIO $ throwIO StreamingNotSupportedException

112+ throwServantError = throwError

125

113

114+instance ClientLike (ClientM a) (ClientM a) where

115+ mkClient = id

116+

126−runClientMOrigin :: ClientM a -> ClientEnv -> IO (Either ClientError a)

117+runClientMOrigin :: ClientM a -> ClientEnv -> IO (Either ServantError a)

127runClientMOrigin cm env = runExceptT $ flip runReaderT env $ runClientM' cm

118runClientMOrigin cm env = runExceptT $ flip runReaderT env $ runClientM' cm

128

119

129−runClientM :: ClientM a -> IO (Either ClientError a)

120+runClientM :: ClientM a -> IO (Either ServantError a)

130runClientM m = do

121runClientM m = do

131 curLoc <- getWindowLocation

122 curLoc <- getWindowLocation

132

123

@@ -152,20 +143,16 @@ runClientM m = do

152

143

153 runClientMOrigin m (ClientEnv (BaseUrl protocol hostname port ""))

144 runClientMOrigin m (ClientEnv (BaseUrl protocol hostname port ""))

154

145

155−performRequest :: Maybe [Status] -> Request -> ClientM Response

146+performRequest :: Request -> ClientM Response

156−performRequest acceptStatus req = do

147+performRequest req = do

157 xhr <- liftIO initXhr

148 xhr <- liftIO initXhr

158 burl <- asks baseUrl

149 burl <- asks baseUrl

159 liftIO $ performXhr xhr burl req

150 liftIO $ performXhr xhr burl req

160 resp <- toResponse xhr

151 resp <- toResponse xhr

161

152

162− let status = responseStatusCode resp

153+ let status = statusCode (responseStatusCode resp)

163− goodStatus = case acceptStatus of

154+ 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

155+ throwError $ FailureResponse resp

169

156

170 pure resp

157 pure resp

171

158

@@ -284,29 +271,38 @@ toBody request = case requestBody request of

284 where

271 where

285 go :: RequestBody -> IO ArrayBuffer

272 go :: RequestBody -> IO ArrayBuffer

286 go x = case x of

273 go x = case x of

287− RequestBodyLBS x -> return $ mBody $ BL.toStrict x

274+ RequestBodyLBS x -> return $ mBody $ BL.toStrict x

288− RequestBodyBS x -> return $ mBody x

275+ RequestBodyBS x -> return $ mBody x

289− RequestBodySource xs -> runExceptT (S.runSourceT xs) >>= \e -> case e of

276+ RequestBodyBuilder _ x -> return $ mBody $ BL.toStrict $ toLazyByteString x

290− Left err -> fail err

277+ RequestBodyStream _ x -> mBody <$> readBody x

291− Right bss -> return $ mBody $ BL.toStrict $ mconcat bss

278+ RequestBodyStreamChunked x -> mBody <$> readBody x

279+ RequestBodyIO x -> x >>= go

292

280

293 mBody :: BS.ByteString -> ArrayBuffer

281 mBody :: BS.ByteString -> ArrayBuffer

294 mBody bs = js_bufferSlice offset len $ Buffer.getArrayBuffer buffer

282 mBody bs = js_bufferSlice offset len $ Buffer.getArrayBuffer buffer

295 where

283 where

296 (buffer, offset, len) = Buffer.fromByteString bs

284 (buffer, offset, len) = Buffer.fromByteString bs

297

285

286+ readBody :: ((IO BS.ByteString -> IO ()) -> IO a) -> IO BS.ByteString

287+ readBody writer = do

288+ m <- newIORef mempty

289+ _ <- writer (\bsAct -> do

290+ bs <- bsAct

291+ modifyIORef m (<> bs))

292+ readIORef m

293+

298foreign import javascript unsafe "$3.slice($1, $1 + $2)"

294foreign import javascript unsafe "$3.slice($1, $1 + $2)"

299 js_bufferSlice :: Int -> Int -> ArrayBuffer -> ArrayBuffer

295 js_bufferSlice :: Int -> Int -> ArrayBuffer -> ArrayBuffer

300

296

301-- * inspecting the xhr response

297-- * inspecting the xhr response

302

298

303-- This function is only supposed to handle 'ConnectionError's. Other

299-- This function is only supposed to handle 'ConnectionError's. Other

304−-- 'ClientError's are created in Servant.Client.Req.

300+-- 'ServantError's are created in Servant.Client.Req.

305toResponse :: JSXMLHttpRequest -> ClientM Response

301toResponse :: JSXMLHttpRequest -> ClientM Response

306toResponse xhr = do

302toResponse xhr = do

307 status <- liftIO $ getStatus xhr

303 status <- liftIO $ getStatus xhr

308 case status of

304 case status of

309− 0 -> throwError $ ConnectionError (SomeException (userError "connection error"))

305+ 0 -> throwError $ ConnectionError "connection error"

310 _ -> liftIO $ do

306 _ -> liftIO $ do

311 statusText <- cs <$> getStatusText xhr

307 statusText <- cs <$> getStatusText xhr

312 headers <- parseHeaders <$> getAllResponseHeaders xhr

308 headers <- parseHeaders <$> getAllResponseHeaders xhr

servant-client-ghcjs/tinc.yamlnew file+5

@@ -0,0 +1,5 @@

1+dependencies:

2+ - name: servant

3+ path: ../servant

4+ - name: servant-server

5+ path: ../servant-server

servant-client/CHANGELOG.md+2−238

@@ -1,242 +1,6 @@

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−

2400.14

40.14

241----

5----

242

6

@@ -267,9 +31,9 @@ Package versions follow the [Package Versioning Policy](https://pvp.haskell.org/

267

31

268- *servant-client-core* Add `hoistClient` to `HasClient`.

32- *servant-client-core* Add `hoistClient` to `HasClient`.

269 Just like `hoistServer` allows us to change the monad in which request handlers

33 Just like `hoistServer` allows us to change the monad in which request handlers

270− of a web application live, we also have `hoistClient` for changing the monad

34+ of a web application live in, we also have `hoistClient` for changing the monad

271 in which *client functions* live.

35 in which *client functions* live.

272− Read [tutorial section for more information](https://docs.servant.dev/en/release-0.14/tutorial/Client.html#changing-the-monad-the-client-functions-live-in).

36+ Read [tutorial section for more information](https://haskell-servant.readthedocs.io/en/release-0.14/tutorial/Client.html#changing-the-monad-the-client-functions-live-in).

273 ([#936](https://github.com/haskell-servant/servant/pull/936))

37 ([#936](https://github.com/haskell-servant/servant/pull/936))

274

38

275- *servant-client* Add more constructors to `RequestBody`, including

39- *servant-client* Add more constructors to `RequestBody`, including

servant-client/LICENSE+1−1

@@ -1,4 +1,4 @@

1−Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, 2016-2018 Servant Contributors

1+Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, Servant Contributors

2

2

3All rights reserved.

3All rights reserved.

4

4

servant-client/servant-client.cabal+43−69

@@ -1,32 +1,31 @@

1−cabal-version: 2.2

2name: servant-client

1name: servant-client

3−version: 0.19

2+version: 0.14

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==8.0.2

25−

21+ GHC==8.2.2

22+ GHC==8.4.4

23+ GHC==8.6.1

24+homepage: http://haskell-servant.readthedocs.org/

25+Bug-reports: http://github.com/haskell-servant/servant/issues

26extra-source-files:

26extra-source-files:

27 CHANGELOG.md

27 CHANGELOG.md

28 README.md

28 README.md

29−

30source-repository head

29source-repository head

31 type: git

30 type: git

32 location: http://github.com/haskell-servant/servant.git

31 location: http://github.com/haskell-servant/servant.git

@@ -34,46 +33,38 @@ source-repository head

34library

33library

35 exposed-modules:

34 exposed-modules:

36 Servant.Client

35 Servant.Client

37− Servant.Client.Streaming

38 Servant.Client.Internal.HttpClient

36 Servant.Client.Internal.HttpClient

39− Servant.Client.Internal.HttpClient.Streaming

40

37

41 -- Bundled with GHC: Lower bound to not force re-installs

38 -- Bundled with GHC: Lower bound to not force re-installs

42 -- text and mtl are bundled starting with GHC-8.4

39 -- text and mtl are bundled starting with GHC-8.4

40+ --

41+ -- note: mtl lower bound is so low because of GHC-7.8

43 build-depends:

42 build-depends:

44− base >= 4.9 && < 4.18

43+ base >= 4.7 && < 4.13

45− , bytestring >= 0.10.8.1 && < 0.12

44+ , bytestring >= 0.10.4.0 && < 0.11

46− , containers >= 0.5.7.1 && < 0.7

45+ , containers >= 0.5.5.1 && < 0.7

47− , deepseq >= 1.4.2.0 && < 1.5

46+ , 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

47+ , text >= 1.2.3.0 && < 1.3

51− , time >= 1.6.0.1 && < 1.13

48+ , time >= 1.4.2 && < 1.9

52− , transformers >= 0.5.2.0 && < 0.7

49+ , transformers >= 0.3.0.0 && < 0.6

53−

54− if !impl(ghc >= 8.2)

55− build-depends:

56− bifunctors >= 5.5.3 && < 5.6

57

50

58− -- Servant dependencies.

51+ -- Servant dependencies

59− -- Strict dependency on `servant-client-core` as we re-export things.

60 build-depends:

52 build-depends:

61− servant >= 0.18 && < 0.20

62− , servant-client-core >= 0.19 && < 0.19.1

53+ servant-client-core == 0.14.*

63

54

64 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.

55 -- 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.

56 -- Here can be exceptions if we really need features from the newer versions.

66 build-depends:

57 build-depends:

67− base-compat >= 0.10.5 && < 0.13

58+ base-compat >= 0.10.1 && < 0.11

68− , http-client >= 0.5.13.1 && < 0.8

59+ , http-client >= 0.5.12 && < 0.6

69− , http-media >= 0.7.1.3 && < 0.9

60+ , http-media >= 0.7.1.2 && < 0.8

70− , http-types >= 0.12.2 && < 0.13

61+ , http-types >= 0.12.1 && < 0.13

71 , exceptions >= 0.10.0 && < 0.11

62 , exceptions >= 0.10.0 && < 0.11

72− , kan-extensions >= 5.2 && < 5.3

73 , monad-control >= 1.0.2.3 && < 1.1

63 , monad-control >= 1.0.2.3 && < 1.1

74− , semigroupoids >= 5.3.1 && < 5.4

64+ , semigroupoids >= 5.2.2 && < 5.4

65+ , stm >= 2.4.5.0 && < 2.6

75 , transformers-base >= 0.4.5.2 && < 0.5

66 , transformers-base >= 0.4.5.2 && < 0.5

76− , transformers-compat >= 0.6.2 && < 0.8

67+ , transformers-compat >= 0.6.2 && < 0.7

77

68

78 hs-source-dirs: src

69 hs-source-dirs: src

79 default-language: Haskell2010

70 default-language: Haskell2010

@@ -81,24 +72,13 @@ library

81

72

82test-suite spec

73test-suite spec

83 type: exitcode-stdio-1.0

74 type: exitcode-stdio-1.0

84− ghc-options: -Wall -rtsopts -threaded "-with-rtsopts=-T -N2"

75+ ghc-options: -Wall -rtsopts -with-rtsopts=-T

85 default-language: Haskell2010

76 default-language: Haskell2010

86− if impl(ghcjs)

87− buildable: False

88 hs-source-dirs: test

77 hs-source-dirs: test

89 main-is: Spec.hs

78 main-is: Spec.hs

90 other-modules:

79 other-modules:

91− Servant.BasicAuthSpec

80+ 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

81 Servant.StreamSpec

100− Servant.SuccessSpec

101− Servant.WrappedApiSpec

102

82

103 -- Dependencies inherited from the library. No need to specify bounds.

83 -- Dependencies inherited from the library. No need to specify bounds.

104 build-depends:

84 build-depends:

@@ -110,30 +90,26 @@ test-suite spec

110 , http-client

90 , http-client

111 , http-types

91 , http-types

112 , mtl

92 , mtl

113− , kan-extensions

114 , servant-client

93 , servant-client

115 , servant-client-core

94 , servant-client-core

116− , sop-core

117− , stm

118 , text

95 , text

119 , transformers

96 , transformers

120 , transformers-compat

97 , transformers-compat

121 , wai

98 , wai

122 , warp

99 , warp

123

100

124− -- Additional dependencies

101+ -- Additonal dependencies

125 build-depends:

102 build-depends:

126− entropy >= 0.4.1.3 && < 0.5

103+ generics-sop >= 0.3.2.0 && < 0.4

127− , hspec >= 2.6.0 && < 2.10

104+ , hspec >= 2.5.1 && < 2.6

128− , HUnit >= 1.6.0.0 && < 1.7

105+ , HUnit >= 1.6 && < 1.7

129− , network >= 2.8.0.0 && < 3.2

106+ , network >= 2.6.3.2 && < 2.8

130− , QuickCheck >= 2.12.6.1 && < 2.15

107+ , QuickCheck >= 2.10.1 && < 2.12

131− , servant == 0.19.*

108+ , servant == 0.14.*

132− , servant-server == 0.19.*

109+ , servant-server == 0.14.*

133− , tdigest >= 0.2 && < 0.3

134

110

135 build-tool-depends:

111 build-tool-depends:

136− hspec-discover:hspec-discover >= 2.6.0 && < 2.10

112+ hspec-discover:hspec-discover >= 2.5.1 && < 2.6

137

113

138test-suite readme

114test-suite readme

139 type: exitcode-stdio-1.0

115 type: exitcode-stdio-1.0

@@ -142,5 +118,3 @@ test-suite readme

142 build-tool-depends: markdown-unlit:markdown-unlit

118 build-tool-depends: markdown-unlit:markdown-unlit

143 ghc-options: -pgmL markdown-unlit

119 ghc-options: -pgmL markdown-unlit

144 default-language: Haskell2010

120 default-language: Haskell2010

145− if impl(ghcjs)

146− buildable: False

servant-client/src/Servant/Client.hs−1

@@ -9,7 +9,6 @@ module Servant.Client

9 , runClientM

9 , runClientM

10 , ClientEnv(..)

10 , ClientEnv(..)

11 , mkClientEnv

11 , mkClientEnv

12− , defaultMakeClientRequest

13 , hoistClient

12 , hoistClient

14 , module Servant.Client.Core.Reexport

13 , module Servant.Client.Core.Reexport

15 ) where

14 ) where

servant-client/src/Servant/Client/Internal/HttpClient.hs+90−148

@@ -14,83 +14,61 @@ module Servant.Client.Internal.HttpClient where

14import Prelude ()

14import Prelude ()

15import Prelude.Compat

15import Prelude.Compat

16

16

17−import Control.Concurrent.MVar

18− (modifyMVar, newMVar)

19import Control.Concurrent.STM.TVar

17import Control.Concurrent.STM.TVar

20import Control.Exception

18import Control.Exception

21− (SomeException (..), catch)

22import Control.Monad

19import Control.Monad

23− (unless)

24import Control.Monad.Base

20import Control.Monad.Base

25 (MonadBase (..))

21 (MonadBase (..))

26import Control.Monad.Catch

22import Control.Monad.Catch

27− (MonadCatch, MonadThrow, MonadMask)

23+ (MonadCatch, MonadThrow)

28import Control.Monad.Error.Class

24import Control.Monad.Error.Class

29 (MonadError (..))

25 (MonadError (..))

30−import Control.Monad.IO.Class

31− (MonadIO (..))

32import Control.Monad.Reader

26import Control.Monad.Reader

33− (MonadReader, ReaderT, ask, runReaderT)

34import Control.Monad.STM

27import Control.Monad.STM

35− (STM, atomically)

28+ (atomically)

36import Control.Monad.Trans.Control

29import Control.Monad.Trans.Control

37 (MonadBaseControl (..))

30 (MonadBaseControl (..))

38import Control.Monad.Trans.Except

31import Control.Monad.Trans.Except

39− (ExceptT, runExceptT)

40−import Data.Bifunctor

41− (bimap)

42−import qualified Data.ByteString as BS

43import Data.ByteString.Builder

32import Data.ByteString.Builder

44 (toLazyByteString)

33 (toLazyByteString)

45import qualified Data.ByteString.Lazy as BSL

34import qualified Data.ByteString.Lazy as BSL

46−import Data.Either

47− (either)

48import Data.Foldable

35import Data.Foldable

49− (foldl',toList)

36+ (for_, toList)

50import Data.Functor.Alt

37import Data.Functor.Alt

51 (Alt (..))

38 (Alt (..))

52import Data.Maybe

39import Data.Maybe

53− (maybe, maybeToList)

40+ (maybeToList)

54import Data.Proxy

41import Data.Proxy

55 (Proxy (..))

42 (Proxy (..))

43+import Data.Semigroup

44+ ((<>))

56import Data.Sequence

45import Data.Sequence

57 (fromList)

46 (fromList)

58import Data.String

47import Data.String

59 (fromString)

48 (fromString)

49+import qualified Data.Text as T

60import Data.Time.Clock

50import Data.Time.Clock

61− (UTCTime, getCurrentTime)

51+ (getCurrentTime)

62import GHC.Generics

52import GHC.Generics

63import Network.HTTP.Media

53import Network.HTTP.Media

64 (renderHeader)

54 (renderHeader)

65import Network.HTTP.Types

55import Network.HTTP.Types

66− (hContentType, renderQuery, statusIsSuccessful, urlEncode, Status)

56+ (hContentType, renderQuery, statusCode)

67import Servant.Client.Core

57import Servant.Client.Core

68

58

69import qualified Network.HTTP.Client as Client

59import qualified Network.HTTP.Client as Client

70−import qualified Servant.Types.SourceT as S

71

60

72-- | The environment in which a request is run.

61-- | 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

62data ClientEnv

79 = ClientEnv

63 = ClientEnv

80 { manager :: Client.Manager

64 { manager :: Client.Manager

81 , baseUrl :: BaseUrl

65 , baseUrl :: BaseUrl

82 , cookieJar :: Maybe (TVar Client.CookieJar)

66 , 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 }

67 }

90

68

91-- | 'ClientEnv' smart constructor.

69-- | 'ClientEnv' smart constructor.

92mkClientEnv :: Client.Manager -> BaseUrl -> ClientEnv

70mkClientEnv :: Client.Manager -> BaseUrl -> ClientEnv

93−mkClientEnv mgr burl = ClientEnv mgr burl Nothing defaultMakeClientRequest

71+mkClientEnv mgr burl = ClientEnv mgr burl Nothing

94

72

95-- | Generates a set of client functions for an API.

73-- | Generates a set of client functions for an API.

96--

74--

@@ -133,16 +111,16 @@ hoistClient = hoistClientMonad (Proxy :: Proxy ClientM)

133-- | @ClientM@ is the monad in which client functions run. Contains the

111-- | @ClientM@ is the monad in which client functions run. Contains the

134-- 'Client.Manager' and 'BaseUrl' used for requests in the reader environment.

112-- 'Client.Manager' and 'BaseUrl' used for requests in the reader environment.

135newtype ClientM a = ClientM

113newtype ClientM a = ClientM

136− { unClientM :: ReaderT ClientEnv (ExceptT ClientError IO) a }

114+ { unClientM :: ReaderT ClientEnv (ExceptT ServantError IO) a }

137 deriving ( Functor, Applicative, Monad, MonadIO, Generic

115 deriving ( Functor, Applicative, Monad, MonadIO, Generic

138− , MonadReader ClientEnv, MonadError ClientError, MonadThrow

116+ , MonadReader ClientEnv, MonadError ServantError, MonadThrow

139− , MonadCatch, MonadMask)

117+ , MonadCatch)

140

118

141instance MonadBase IO ClientM where

119instance MonadBase IO ClientM where

142 liftBase = ClientM . liftBase

120 liftBase = ClientM . liftBase

143

121

144instance MonadBaseControl IO ClientM where

122instance MonadBaseControl IO ClientM where

145− type StM ClientM a = Either ClientError a

123+ type StM ClientM a = Either ServantError a

146

124

147 liftBaseWith f = ClientM (liftBaseWith (\g -> f (g . unClientM)))

125 liftBaseWith f = ClientM (liftBaseWith (\g -> f (g . unClientM)))

148

126

@@ -153,16 +131,20 @@ instance Alt ClientM where

153 a <!> b = a `catchError` \_ -> b

131 a <!> b = a `catchError` \_ -> b

154

132

155instance RunClient ClientM where

133instance RunClient ClientM where

156− runRequestAcceptStatus = performRequest

134+ runRequest = performRequest

157− throwClientError = throwError

135+ streamingRequest = performStreamingRequest

136+ throwServantError = throwError

158

137

138+instance ClientLike (ClientM a) (ClientM a) where

139+ mkClient = id

140+

159−runClientM :: ClientM a -> ClientEnv -> IO (Either ClientError a)

141+runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a)

160runClientM cm env = runExceptT $ flip runReaderT env $ unClientM cm

142runClientM cm env = runExceptT $ flip runReaderT env $ unClientM cm

161

143

162−performRequest :: Maybe [Status] -> Request -> ClientM Response

144+performRequest :: Request -> ClientM Response

163−performRequest acceptStatus req = do

145+performRequest req = do

164− ClientEnv m burl cookieJar' createClientRequest <- ask

146+ ClientEnv m burl cookieJar' <- ask

165− clientRequest <- liftIO $ createClientRequest burl req

147+ let clientRequest = requestToClientRequest burl req

166 request <- case cookieJar' of

148 request <- case cookieJar' of

167 Nothing -> pure clientRequest

149 Nothing -> pure clientRequest

168 Just cj -> liftIO $ do

150 Just cj -> liftIO $ do

@@ -171,82 +153,67 @@ performRequest acceptStatus req = do

171 oldCookieJar <- readTVar cj

153 oldCookieJar <- readTVar cj

172 let (newRequest, newCookieJar) =

154 let (newRequest, newCookieJar) =

173 Client.insertCookiesIntoRequest

155 Client.insertCookiesIntoRequest

174− clientRequest

156+ (requestToClientRequest burl req)

175 oldCookieJar

157 oldCookieJar

176 now

158 now

177 writeTVar cj newCookieJar

159 writeTVar cj newCookieJar

178 pure newRequest

160 pure newRequest

179

161

180− response <- maybe (requestWithoutCookieJar m request) (requestWithCookieJar m request) cookieJar'

162+ eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request m

181− let status = Client.responseStatus response

163+ case eResponse of

182− ourResponse = clientResponseToResponse id response

164+ Left err -> throwError err

183− goodStatus = case acceptStatus of

165+ Right response -> do

184− Nothing -> statusIsSuccessful status

166+ 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

167+ 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')

168+ atomically $ modifyTVar' cj (fst . Client.updateCookieJar response request now')

211−

169+ let status = Client.responseStatus response

212− fReq = Client.hrFinalRequest responses

170+ status_code = statusCode status

213− fRes = Client.hrFinalResponse responses

171+ ourResponse = clientResponseToResponse response

214−

172+ unless (status_code >= 200 && status_code < 300) $

215−mkFailureResponse :: BaseUrl -> Request -> ResponseF BSL.ByteString -> ClientError

173+ throwError $ FailureResponse ourResponse

216−mkFailureResponse burl request =

174+ return ourResponse

217− FailureResponse (bimap (const ()) f request)

175+

218− where

176+performStreamingRequest :: Request -> ClientM StreamingResponse

219− f b = (burl, BSL.toStrict $ toLazyByteString b)

177+performStreamingRequest req = do

220−

178+ m <- asks manager

179+ burl <- asks baseUrl

180+ let request = requestToClientRequest burl req

181+ return $ StreamingResponse $

182+ \k -> Client.withResponse request m $

183+ \r -> do

184+ let status = Client.responseStatus r

185+ status_code = statusCode status

186+ unless (status_code >= 200 && status_code < 300) $ do

187+ b <- BSL.fromChunks <$> Client.brConsume (Client.responseBody r)

221−clientResponseToResponse :: (a -> b) -> Client.Response a -> ResponseF b

188+ throw $ FailureResponse $ clientResponseToResponse r { Client.responseBody = b }

189+ k (clientResponseToResponse r)

190+

191+clientResponseToResponse :: Client.Response a -> GenResponse a

222−clientResponseToResponse f r = Response

192+clientResponseToResponse r = Response

223− { responseStatusCode = Client.responseStatus r

193+ { responseStatusCode = Client.responseStatus r

224− , responseBody = f (Client.responseBody r)

194+ , responseBody = Client.responseBody r

225− , responseHeaders = fromList $ Client.responseHeaders r

195+ , responseHeaders = fromList $ Client.responseHeaders r

226− , responseHttpVersion = Client.responseVersion r

196+ , responseHttpVersion = Client.responseVersion r

227− }

197+ }

228

198

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

199+requestToClientRequest :: BaseUrl -> Request -> Client.Request

233−defaultMakeClientRequest burl r = return Client.defaultRequest

200+requestToClientRequest burl r = Client.defaultRequest

234− { Client.method = requestMethod r

201+ { Client.method = requestMethod r

235− , Client.host = fromString $ baseUrlHost burl

202+ , Client.host = fromString $ baseUrlHost burl

236− , Client.port = baseUrlPort burl

203+ , Client.port = baseUrlPort burl

237− , Client.path = BSL.toStrict

204+ , Client.path = BSL.toStrict

238− $ fromString (baseUrlPath burl)

205+ $ fromString (baseUrlPath burl)

239− <> toLazyByteString (requestPath r)

206+ <> toLazyByteString (requestPath r)

240− , Client.queryString = buildQueryString . toList $ requestQueryString r

207+ , Client.queryString = renderQuery True . toList $ requestQueryString r

241− , Client.requestHeaders =

208+ , Client.requestHeaders =

242− maybeToList acceptHdr ++ maybeToList contentTypeHdr ++ headers

209+ maybeToList acceptHdr ++ maybeToList contentTypeHdr ++ headers

243− , Client.requestBody = body

210+ , Client.requestBody = body

244− , Client.secure = isSecure

211+ , Client.secure = isSecure

245− }

212+ }

246 where

213 where

247 -- Content-Type and Accept are specified by requestBody and requestAccept

214 -- Content-Type and Accept are specified by requestBody and requestAccept

248 headers = filter (\(h, _) -> h /= "Accept" && h /= "Content-Type") $

215 headers = filter (\(h, _) -> h /= "Accept" && h /= "Content-Type") $

249− toList $ requestHeaders r

216+ toList $requestHeaders r

250

217

251 acceptHdr

218 acceptHdr

252 | null hs = Nothing

219 | null hs = Nothing

@@ -255,48 +222,23 @@ defaultMakeClientRequest burl r = return Client.defaultRequest

255 hs = toList $ requestAccept r

222 hs = toList $ requestAccept r

256

223

257 convertBody bd = case bd of

224 convertBody bd = case bd of

258− RequestBodyLBS body' -> Client.RequestBodyLBS body'

225+ RequestBodyLBS body' -> Client.RequestBodyLBS body'

259− RequestBodyBS body' -> Client.RequestBodyBS body'

226+ RequestBodyBS body' -> Client.RequestBodyBS body'

260− RequestBodySource sourceIO -> Client.RequestBodyStreamChunked givesPopper

227+ RequestBodyBuilder size body' -> Client.RequestBodyBuilder size body'

261− where

228+ RequestBodyStream size body' -> Client.RequestBodyStream size body'

262− givesPopper :: (IO BS.ByteString -> IO ()) -> IO ()

229+ RequestBodyStreamChunked body' -> Client.RequestBodyStreamChunked body'

263− givesPopper needsPopper = S.unSourceT sourceIO $ \step0 -> do

230+ RequestBodyIO body' -> Client.RequestBodyIO (convertBody <$> body')

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

231

283 (body, contentTypeHdr) = case requestBody r of

232 (body, contentTypeHdr) = case requestBody r of

284− Nothing -> (Client.RequestBodyBS "", Nothing)

233+ Nothing -> (Client.RequestBodyLBS "", Nothing)

234+ Just (body', typ)

285− Just (body', typ) -> (convertBody body', Just (hContentType, renderHeader typ))

235+ -> (convertBody body', Just (hContentType, renderHeader typ))

286

236

287 isSecure = case baseUrlScheme burl of

237 isSecure = case baseUrlScheme burl of

288− Http -> False

238+ Http -> False

289− Https -> True

239+ 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

240

299−catchConnectionError :: IO a -> IO (Either ClientError a)

241+catchConnectionError :: IO a -> IO (Either ServantError a)

300catchConnectionError action =

242catchConnectionError action =

301 catch (Right <$> action) $ \e ->

243 catch (Right <$> action) $ \e ->

302− pure . Left . ConnectionError $ SomeException (e :: Client.HttpException)

244+ pure . Left . ConnectionError . T.pack $ show (e :: Client.HttpException)

servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hsdeleted−203

@@ -1,203 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE DeriveGeneric #-}

3−{-# LANGUAGE FlexibleContexts #-}

4−{-# LANGUAGE FlexibleInstances #-}

5−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

6−{-# LANGUAGE MultiParamTypeClasses #-}

7−{-# LANGUAGE RankNTypes #-}

8−{-# LANGUAGE ScopedTypeVariables #-}

9−{-# LANGUAGE TypeFamilies #-}

10−module Servant.Client.Internal.HttpClient.Streaming (

11− module Servant.Client.Internal.HttpClient.Streaming,

12− ClientEnv (..),

13− mkClientEnv,

14− clientResponseToResponse,

15− defaultMakeClientRequest,

16− catchConnectionError,

17− ) where

18−

19−import Prelude ()

20−import Prelude.Compat

21−

22−import Control.Concurrent.STM.TVar

23−import Control.DeepSeq

24− (NFData, force)

25−import Control.Exception

26− (evaluate, throwIO)

27−import Control.Monad

28− (unless)

29−import Control.Monad.Base

30− (MonadBase (..))

31−import Control.Monad.Codensity

32− (Codensity (..))

33−import Control.Monad.Error.Class

34− (MonadError (..))

35−import Control.Monad.Reader

36−import Control.Monad.STM

37− (atomically)

38−import Control.Monad.Trans.Except

39−import qualified Data.ByteString as BS

40−import qualified Data.ByteString.Lazy as BSL

41−import Data.Foldable

42− (for_)

43−import Data.Functor.Alt

44− (Alt (..))

45−import Data.Proxy

46− (Proxy (..))

47−import Data.Time.Clock

48− (getCurrentTime)

49−import GHC.Generics

50−import Network.HTTP.Types

51− (Status, statusIsSuccessful)

52−

53−import qualified Network.HTTP.Client as Client

54−

55−import Servant.Client.Core

56−import Servant.Client.Internal.HttpClient

57− (ClientEnv (..), catchConnectionError,

58− clientResponseToResponse, mkClientEnv, mkFailureResponse,

59− defaultMakeClientRequest)

60−import qualified Servant.Types.SourceT as S

61−

62−

63−-- | Generates a set of client functions for an API.

64−--

65−-- Example:

66−--

67−-- > type API = Capture "no" Int :> Get '[JSON] Int

68−-- > :<|> Get '[JSON] [Bool]

69−-- >

70−-- > api :: Proxy API

71−-- > api = Proxy

72−-- >

73−-- > getInt :: Int -> ClientM Int

74−-- > getBools :: ClientM [Bool]

75−-- > getInt :<|> getBools = client api

76−client :: HasClient ClientM api => Proxy api -> Client ClientM api

77−client api = api `clientIn` (Proxy :: Proxy ClientM)

78−

79−-- | Change the monad the client functions live in, by

80−-- supplying a conversion function

81−-- (a natural transformation to be precise).

82−--

83−-- For example, assuming you have some @manager :: 'Manager'@ and

84−-- @baseurl :: 'BaseUrl'@ around:

85−--

86−-- > type API = Get '[JSON] Int :<|> Capture "n" Int :> Post '[JSON] Int

87−-- > api :: Proxy API

88−-- > api = Proxy

89−-- > getInt :: IO Int

90−-- > postInt :: Int -> IO Int

91−-- > getInt :<|> postInt = hoistClient api (flip runClientM cenv) (client api)

92−-- > where cenv = mkClientEnv manager baseurl

93−hoistClient

94− :: HasClient ClientM api

95− => Proxy api

96− -> (forall a. m a -> n a)

97− -> Client m api

98− -> Client n api

99−hoistClient = hoistClientMonad (Proxy :: Proxy ClientM)

100−

101−-- | @ClientM@ is the monad in which client functions run. Contains the

102−-- 'Client.Manager' and 'BaseUrl' used for requests in the reader environment.

103−newtype ClientM a = ClientM

104− { unClientM :: ReaderT ClientEnv (ExceptT ClientError (Codensity IO)) a }

105− deriving ( Functor, Applicative, Monad, MonadIO, Generic

106− , MonadReader ClientEnv, MonadError ClientError)

107−

108−instance MonadBase IO ClientM where

109− liftBase = ClientM . liftIO

110−

111−-- | Try clients in order, last error is preserved.

112−instance Alt ClientM where

113− a <!> b = a `catchError` \_ -> b

114−

115−instance RunClient ClientM where

116− runRequestAcceptStatus = performRequest

117− throwClientError = throwError

118−

119−instance RunStreamingClient ClientM where

120− withStreamingRequest = performWithStreamingRequest

121−

122−withClientM :: ClientM a -> ClientEnv -> (Either ClientError a -> IO b) -> IO b

123−withClientM cm env k =

124− let Codensity f = runExceptT $ flip runReaderT env $ unClientM cm

125− in f k

126−

127−-- | A 'runClientM' variant for streaming client.

128−--

129−-- It allows using this module's 'ClientM' in a direct style.

130−-- The 'NFData' constraint however prevents using this function with genuine

131−-- streaming response types ('SourceT', 'Conduit', pipes 'Proxy' or 'Machine').

132−-- For those you have to use 'withClientM'.

133−--

134−-- /Note:/ we 'force' the result, so the likelihood of accidentally leaking a

135−-- connection is smaller. Use with care.

136−--

137−runClientM :: NFData a => ClientM a -> ClientEnv -> IO (Either ClientError a)

138−runClientM cm env = withClientM cm env (evaluate . force)

139−

140−performRequest :: Maybe [Status] -> Request -> ClientM Response

141−performRequest acceptStatus req = do

142− -- TODO: should use Client.withResponse here too

143− ClientEnv m burl cookieJar' createClientRequest <- ask

144− clientRequest <- liftIO $ createClientRequest burl req

145− request <- case cookieJar' of

146− Nothing -> pure clientRequest

147− Just cj -> liftIO $ do

148− now <- getCurrentTime

149− atomically $ do

150− oldCookieJar <- readTVar cj

151− let (newRequest, newCookieJar) =

152− Client.insertCookiesIntoRequest

153− clientRequest

154− oldCookieJar

155− now

156− writeTVar cj newCookieJar

157− pure newRequest

158−

159− eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request m

160− case eResponse of

161− Left err -> throwError err

162− Right response -> do

163− for_ cookieJar' $ \cj -> liftIO $ do

164− now' <- getCurrentTime

165− atomically $ modifyTVar' cj (fst . Client.updateCookieJar response request now')

166− let status = Client.responseStatus response

167− ourResponse = clientResponseToResponse id response

168− goodStatus = case acceptStatus of

169− Nothing -> statusIsSuccessful status

170− Just good -> status `elem` good

171− unless goodStatus $ do

172− throwError $ mkFailureResponse burl req ourResponse

173− return ourResponse

174−

175−-- | TODO: support UVerb ('acceptStatus' argument, like in 'performRequest' above).

176−performWithStreamingRequest :: Request -> (StreamingResponse -> IO a) -> ClientM a

177−performWithStreamingRequest req k = do

178− ClientEnv m burl cookieJar' createClientRequest <- ask

179− clientRequest <- liftIO $ createClientRequest burl req

180− request <- case cookieJar' of

181− Nothing -> pure clientRequest

182− Just cj -> liftIO $ do

183− now <- getCurrentTime

184− atomically $ do

185− oldCookieJar <- readTVar cj

186− let (newRequest, newCookieJar) =

187− Client.insertCookiesIntoRequest

188− clientRequest

189− oldCookieJar

190− now

191− writeTVar cj newCookieJar

192− pure newRequest

193− ClientM $ lift $ lift $ Codensity $ \k1 ->

194− Client.withResponse request m $ \res -> do

195− let status = Client.responseStatus res

196−

197− -- we throw FailureResponse in IO :(

198− unless (statusIsSuccessful status) $ do

199− b <- BSL.fromChunks <$> Client.brConsume (Client.responseBody res)

200− throwIO $ mkFailureResponse burl req (clientResponseToResponse (const b) res)

201−

202− x <- k (clientResponseToResponse (S.fromAction BS.null) res)

203− k1 x

servant-client/src/Servant/Client/Streaming.hsdeleted−19

@@ -1,19 +0,0 @@

1−-- | This module provides 'client' which can automatically generate

2−-- querying functions for each endpoint just from the type representing your

3−-- API.

4−--

5−-- This client supports streaming operations.

6−module Servant.Client.Streaming

7− ( client

8− , ClientM

9− , withClientM

10− , runClientM

11− , ClientEnv(..)

12− , mkClientEnv

13− , defaultMakeClientRequest

14− , hoistClient

15− , module Servant.Client.Core.Reexport

16− ) where

17−

18−import Servant.Client.Core.Reexport

19−import Servant.Client.Internal.HttpClient.Streaming

servant-client/test/Servant/BasicAuthSpec.hsdeleted−53

@@ -1,53 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE ConstraintKinds #-}

3−{-# LANGUAGE DataKinds #-}

4−{-# LANGUAGE FlexibleContexts #-}

5−{-# LANGUAGE FlexibleInstances #-}

6−{-# LANGUAGE GADTs #-}

7−{-# LANGUAGE MultiParamTypeClasses #-}

8−{-# LANGUAGE OverloadedStrings #-}

9−{-# LANGUAGE PolyKinds #-}

10−{-# LANGUAGE ScopedTypeVariables #-}

11−{-# LANGUAGE TypeFamilies #-}

12−{-# LANGUAGE TypeOperators #-}

13−{-# LANGUAGE UndecidableInstances #-}

14−{-# OPTIONS_GHC -freduction-depth=100 #-}

15−{-# OPTIONS_GHC -fno-warn-orphans #-}

16−{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

17−

18−module Servant.BasicAuthSpec (spec) where

19−

20−import Prelude ()

21−import Prelude.Compat

22−

23−import Control.Arrow

24− (left)

25−import Data.Monoid ()

26−import qualified Network.HTTP.Types as HTTP

27−import Test.Hspec

28−

29−import Servant.API

30− (BasicAuthData (..))

31−import Servant.Client

32−import Servant.ClientTestUtils

33−

34−spec :: Spec

35−spec = describe "Servant.BasicAuthSpec" $ do

36− basicAuthSpec

37−

38−basicAuthSpec :: Spec

39−basicAuthSpec = beforeAll (startWaiApp basicAuthServer) $ afterAll endWaiApp $ do

40− context "Authentication works when requests are properly authenticated" $ do

41−

42− it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do

43− let getBasic = client basicAuthAPI

44− let basicAuthData = BasicAuthData "servant" "server"

45− left show <$> runClient (getBasic basicAuthData) baseUrl `shouldReturn` Right alice

46−

47− context "Authentication is rejected when requests are not authenticated properly" $ do

48−

49− it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do

50− let getBasic = client basicAuthAPI

51− let basicAuthData = BasicAuthData "not" "password"

52− Left (FailureResponse _ r) <- runClient (getBasic basicAuthData) baseUrl

53− responseStatusCode r `shouldBe` HTTP.Status 403 "Forbidden"

servant-client/test/Servant/BrokenSpec.hsdeleted−71

@@ -1,71 +0,0 @@

1−{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE TypeOperators #-}

3−{-# OPTIONS_GHC -freduction-depth=100 #-}

4−{-# OPTIONS_GHC -fno-warn-orphans #-}

5−{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

6−

7−module Servant.BrokenSpec (spec) where

8−

9−import Prelude ()

10−import Prelude.Compat

11−

12−import Data.Monoid ()

13−import Data.Proxy

14−import qualified Network.HTTP.Types as HTTP

15−import Test.Hspec

16−

17−import Servant.API

18− ((:<|>) ((:<|>)), (:>), JSON, Verb, Get, StdMethod (GET))

19−import Servant.Client

20−import Servant.ClientTestUtils

21−import Servant.Server

22−

23−-- * api for testing inconsistencies between client and server

24−

25−type Get201 = Verb 'GET 201

26−type Get301 = Verb 'GET 301

27−

28−type BrokenAPI =

29− -- the server should respond with 200, but returns 201

30− "get200" :> Get201 '[JSON] ()

31− -- the server should respond with 307, but returns 301

32− :<|> "get307" :> Get301 '[JSON] ()

33−

34−brokenApi :: Proxy BrokenAPI

35−brokenApi = Proxy

36−

37−brokenServer :: Application

38−brokenServer = serve brokenApi (pure () :<|> pure ())

39−

40−type PublicAPI =

41− -- the client expects 200

42− "get200" :> Get '[JSON] ()

43− -- the client expects 307

44− :<|> "get307" :> Get307 '[JSON] ()

45−

46−publicApi :: Proxy PublicAPI

47−publicApi = Proxy

48−

49−get200Client :: ClientM ()

50−get307Client :: ClientM ()

51−get200Client :<|> get307Client = client publicApi

52−

53−

54−spec :: Spec

55−spec = describe "Servant.BrokenSpec" $ do

56− brokenSpec

57−

58−brokenSpec :: Spec

59−brokenSpec = beforeAll (startWaiApp brokenServer) $ afterAll endWaiApp $ do

60− context "client returns errors for inconsistencies between client and server api" $ do

61− it "reports FailureResponse with wrong 2xx status code" $ \(_, baseUrl) -> do

62− res <- runClient get200Client baseUrl

63− case res of

64− Left (FailureResponse _ r) | responseStatusCode r == HTTP.status201 -> return ()

65− _ -> fail $ "expected 201 broken response, but got " <> show res

66−

67− it "reports FailureResponse with wrong 3xx status code" $ \(_, baseUrl) -> do

68− res <- runClient get307Client baseUrl

69− case res of

70− Left (FailureResponse _ r) | responseStatusCode r == HTTP.status301 -> return ()

71− _ -> fail $ "expected 301 broken response, but got " <> show res

servant-http-streams/test/Servant/ClientSpec.hs → servant-client/test/Servant/ClientSpec.hsrenamed+105−71

@@ -12,7 +12,6 @@

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 #-}

@@ -29,27 +28,29 @@ import Control.Arrow

29 (left)

28 (left)

30import Control.Concurrent

29import Control.Concurrent

31 (ThreadId, forkIO, killThread)

30 (ThreadId, forkIO, killThread)

32−import Control.DeepSeq

33− (NFData (..))

34import Control.Exception

31import Control.Exception

35− (bracket, fromException, IOException)

32+ (bracket)

36import Control.Monad.Error.Class

33import Control.Monad.Error.Class

37 (throwError)

34 (throwError)

38import Data.Aeson

35import Data.Aeson

39import Data.Char

36import Data.Char

40 (chr, isPrint)

37 (chr, isPrint)

41import Data.Foldable

38import Data.Foldable

42− (forM_, toList)

39+ (forM_)

43−import Data.Maybe

44− (isJust)

45import Data.Monoid ()

40import Data.Monoid ()

46import Data.Proxy

41import Data.Proxy

42+import Data.Semigroup

43+ ((<>))

44+import qualified Generics.SOP as SOP

47import GHC.Generics

45import GHC.Generics

48 (Generic)

46 (Generic)

49−import qualified Network.HTTP.Types as HTTP

47+import qualified Network.HTTP.Client as C

48+import qualified Network.HTTP.Types as HTTP

50import Network.Socket

49import Network.Socket

51−import qualified Network.Wai as Wai

50+import qualified Network.Wai as Wai

52import Network.Wai.Handler.Warp

51import Network.Wai.Handler.Warp

52+import System.IO.Unsafe

53+ (unsafePerformIO)

53import Test.Hspec

54import Test.Hspec

54import Test.Hspec.QuickCheck

55import Test.Hspec.QuickCheck

55import Test.HUnit

56import Test.HUnit

@@ -63,25 +64,25 @@ import Servant.API

63 DeleteNoContent, EmptyAPI, FormUrlEncoded, Get, Header,

64 DeleteNoContent, EmptyAPI, FormUrlEncoded, Get, Header,

64 Headers, JSON, NoContent (NoContent), Post, Put, QueryFlag,

65 Headers, JSON, NoContent (NoContent), Post, Put, QueryFlag,

65 QueryParam, QueryParams, Raw, ReqBody, addHeader, getHeaders)

66 QueryParam, QueryParams, Raw, ReqBody, addHeader, getHeaders)

67+import Servant.API.Internal.Test.ComprehensiveAPI

68+import Servant.Client

66−import qualified Servant.Client.Core.Auth as Auth

69+import qualified Servant.Client.Core.Internal.Auth as Auth

67−import qualified Servant.Client.Core.Request as Req

70+import qualified Servant.Client.Core.Internal.Request as Req

68−import Servant.HttpStreams

69import Servant.Server

71import Servant.Server

70import Servant.Server.Experimental.Auth

72import Servant.Server.Experimental.Auth

71−import Servant.Test.ComprehensiveAPI

72

73

73-- This declaration simply checks that all instances are in place.

74-- This declaration simply checks that all instances are in place.

74−_ = client comprehensiveAPIWithoutStreaming

75+_ = client comprehensiveAPI

75

76

76spec :: Spec

77spec :: Spec

77−spec = describe "Servant.HttpStreams" $ do

78+spec = describe "Servant.Client" $ do

78− successSpec

79+ sucessSpec

79 failSpec

80 failSpec

80 wrappedApiSpec

81 wrappedApiSpec

81 basicAuthSpec

82 basicAuthSpec

82 genAuthSpec

83 genAuthSpec

84+ genericClientSpec

83 hoistClientSpec

85 hoistClientSpec

84− connectionErrorSpec

85

86

86-- * test data types

87-- * test data types

87

88

@@ -90,9 +91,6 @@ data Person = Person

90 , _age :: Integer

91 , _age :: Integer

91 } deriving (Eq, Show, Generic)

92 } deriving (Eq, Show, Generic)

92

93

93−instance NFData Person where

94− rnf (Person n a) = rnf n `seq` rnf a

95−

96instance ToJSON Person

94instance ToJSON Person

97instance FromJSON Person

95instance FromJSON Person

98

96

@@ -113,7 +111,7 @@ type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]

113type Api =

111type Api =

114 Get '[JSON] Person

112 Get '[JSON] Person

115 :<|> "get" :> Get '[JSON] Person

113 :<|> "get" :> Get '[JSON] Person

116− :<|> "deleteEmpty" :> DeleteNoContent

114+ :<|> "deleteEmpty" :> DeleteNoContent '[JSON] NoContent

117 :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person

115 :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person

118 :<|> "captureAll" :> CaptureAll "names" String :> Get '[JSON] [Person]

116 :<|> "captureAll" :> CaptureAll "names" String :> Get '[JSON] [Person]

119 :<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person

117 :<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person

@@ -129,8 +127,7 @@ type Api =

129 ReqBody '[JSON] [(String, [Rational])] :>

127 ReqBody '[JSON] [(String, [Rational])] :>

130 Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])])

128 Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])])

131 :<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool)

129 :<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool)

132− :<|> "deleteContentType" :> DeleteNoContent

130+ :<|> "deleteContentType" :> DeleteNoContent '[JSON] NoContent

133− :<|> "redirectWithCookie" :> Raw

134 :<|> "empty" :> EmptyAPI

131 :<|> "empty" :> EmptyAPI

135

132

136api :: Proxy Api

133api :: Proxy Api

@@ -151,7 +148,6 @@ getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]

151 -> ClientM (String, Maybe Int, Bool, [(String, [Rational])])

148 -> ClientM (String, Maybe Int, Bool, [(String, [Rational])])

152getRespHeaders :: ClientM (Headers TestHeaders Bool)

149getRespHeaders :: ClientM (Headers TestHeaders Bool)

153getDeleteContentType :: ClientM NoContent

150getDeleteContentType :: ClientM NoContent

154−_getRedirectWithCookie :: HTTP.Method -> ClientM Response

155

151

156getRoot

152getRoot

157 :<|> getGet

153 :<|> getGet

@@ -167,7 +163,6 @@ getRoot

167 :<|> getMultiple

163 :<|> getMultiple

168 :<|> getRespHeaders

164 :<|> getRespHeaders

169 :<|> getDeleteContentType

165 :<|> getDeleteContentType

170− :<|> _getRedirectWithCookie

171 :<|> EmptyClient = client api

166 :<|> EmptyClient = client api

172

167

173server :: Application

168server :: Application

@@ -180,8 +175,8 @@ server = serve api (

180 :<|> return

175 :<|> return

181 :<|> (\ name -> case name of

176 :<|> (\ name -> case name of

182 Just "alice" -> return alice

177 Just "alice" -> return alice

183− Just n -> throwError $ ServerError 400 (n ++ " not found") "" []

178+ Just n -> throwError $ ServantErr 400 (n ++ " not found") "" []

184− Nothing -> throwError $ ServerError 400 "missing parameter" "" [])

179+ Nothing -> throwError $ ServantErr 400 "missing parameter" "" [])

185 :<|> (\ names -> return (zipWith Person names [0..]))

180 :<|> (\ names -> return (zipWith Person names [0..]))

186 :<|> return

181 :<|> return

187 :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "rawSuccess")

182 :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "rawSuccess")

@@ -189,9 +184,9 @@ server = serve api (

189 :<|> (\ a b c d -> return (a, b, c, d))

184 :<|> (\ a b c d -> return (a, b, c, d))

190 :<|> (return $ addHeader 1729 $ addHeader "eg2" True)

185 :<|> (return $ addHeader 1729 $ addHeader "eg2" True)

191 :<|> return NoContent

186 :<|> return NoContent

192− :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.found302 [("Location", "testlocation"), ("Set-Cookie", "testcookie=test")] "")

193 :<|> emptyServer)

187 :<|> emptyServer)

194

188

189+

195type FailApi =

190type FailApi =

196 "get" :> Raw

191 "get" :> Raw

197 :<|> "capture" :> Capture "name" String :> Raw

192 :<|> "capture" :> Capture "name" String :> Raw

@@ -252,16 +247,62 @@ genAuthServerContext = genAuthHandler :. EmptyContext

252genAuthServer :: Application

247genAuthServer :: Application

253genAuthServer = serveWithContext genAuthAPI genAuthServerContext (const (return alice))

248genAuthServer = serveWithContext genAuthAPI genAuthServerContext (const (return alice))

254

249

255−runClient :: NFData a => ClientM a -> BaseUrl -> IO (Either ClientError a)

250+-- * generic client stuff

256−runClient x burl = withClientEnvIO burl (runClientM x)

251+

257−

252+type GenericClientAPI

258−runClientUnsafe :: ClientM a -> BaseUrl -> IO (Either ClientError a)

253+ = QueryParam "sqr" Int :> Get '[JSON] Int

259−runClientUnsafe x burl = withClientEnvIO burl (runClientMUnsafe x)

254+ :<|> Capture "foo" String :> NestedAPI1

255+

256+data GenericClient = GenericClient

257+ { getSqr :: Maybe Int -> ClientM Int

258+ , mkNestedClient1 :: String -> NestedClient1

259+ } deriving Generic

260+instance SOP.Generic GenericClient

261+instance (Client ClientM GenericClientAPI ~ client) => ClientLike client GenericClient

262+

263+type NestedAPI1

264+ = QueryParam "int" Int :> NestedAPI2

265+ :<|> QueryParam "id" Char :> Get '[JSON] Char

266+

267+data NestedClient1 = NestedClient1

268+ { mkNestedClient2 :: Maybe Int -> NestedClient2

269+ , idChar :: Maybe Char -> ClientM Char

270+ } deriving Generic

271+instance SOP.Generic NestedClient1

272+instance (Client ClientM NestedAPI1 ~ client) => ClientLike client NestedClient1

273+

274+type NestedAPI2

275+ = "sum" :> Capture "first" Int :> Capture "second" Int :> Get '[JSON] Int

276+ :<|> "void" :> Post '[JSON] ()

277+

278+data NestedClient2 = NestedClient2

279+ { getSum :: Int -> Int -> ClientM Int

280+ , doNothing :: ClientM ()

281+ } deriving Generic

282+instance SOP.Generic NestedClient2

283+instance (Client ClientM NestedAPI2 ~ client) => ClientLike client NestedClient2

284+

285+genericClientServer :: Application

286+genericClientServer = serve (Proxy :: Proxy GenericClientAPI) (

287+ (\ mx -> case mx of

288+ Just x -> return (x*x)

289+ Nothing -> throwError $ ServantErr 400 "missing parameter" "" []

290+ )

291+ :<|> nestedServer1

292+ )

260 where

293 where

261− runClientMUnsafe x env = withClientM x env return

294+ nestedServer1 _str = nestedServer2 :<|> (maybe (throwError $ ServantErr 400 "missing parameter" "" []) return)

295+ nestedServer2 _int = (\ x y -> return (x + y)) :<|> return ()

262

296

263−successSpec :: Spec

297+{-# NOINLINE manager' #-}

298+manager' :: C.Manager

299+manager' = unsafePerformIO $ C.newManager C.defaultManagerSettings

300+

301+runClient :: ClientM a -> BaseUrl -> IO (Either ServantError a)

302+runClient x baseUrl' = runClientM x (mkClientEnv manager' baseUrl')

303+

304+sucessSpec :: Spec

264−successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do

305+sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do

265 it "Servant.API.Get root" $ \(_, baseUrl) -> do

306 it "Servant.API.Get root" $ \(_, baseUrl) -> do

266 left show <$> runClient getRoot baseUrl `shouldReturn` Right carol

307 left show <$> runClient getRoot baseUrl `shouldReturn` Right carol

267

308

@@ -286,16 +327,9 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do

286 let p = Person "Clara" 42

327 let p = Person "Clara" 42

287 left show <$> runClient (getBody p) baseUrl `shouldReturn` Right p

328 left show <$> runClient (getBody p) baseUrl `shouldReturn` Right p

288

329

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

330 it "Servant.API.QueryParam" $ \(_, baseUrl) -> do

297 left show <$> runClient (getQueryParam (Just "alice")) baseUrl `shouldReturn` Right alice

331 left show <$> runClient (getQueryParam (Just "alice")) baseUrl `shouldReturn` Right alice

298− Left (FailureResponse _ r) <- runClient (getQueryParam (Just "bob")) baseUrl

332+ Left (FailureResponse r) <- runClient (getQueryParam (Just "bob")) baseUrl

299 responseStatusCode r `shouldBe` HTTP.Status 400 "bob not found"

333 responseStatusCode r `shouldBe` HTTP.Status 400 "bob not found"

300

334

301 it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do

335 it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do

@@ -319,7 +353,7 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do

319 res <- runClient (getRawFailure HTTP.methodGet) baseUrl

353 res <- runClient (getRawFailure HTTP.methodGet) baseUrl

320 case res of

354 case res of

321 Right _ -> assertFailure "expected Left, but got Right"

355 Right _ -> assertFailure "expected Left, but got Right"

322− Left (FailureResponse _ r) -> do

356+ Left (FailureResponse r) -> do

323 responseStatusCode r `shouldBe` HTTP.status400

357 responseStatusCode r `shouldBe` HTTP.status400

324 responseBody r `shouldBe` "rawFailure"

358 responseBody r `shouldBe` "rawFailure"

325 Left e -> assertFailure $ "expected FailureResponse, but got " ++ show e

359 Left e -> assertFailure $ "expected FailureResponse, but got " ++ show e

@@ -341,14 +375,14 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do

341

375

342wrappedApiSpec :: Spec

376wrappedApiSpec :: Spec

343wrappedApiSpec = describe "error status codes" $ do

377wrappedApiSpec = describe "error status codes" $ do

344− let serveW api = serve api $ throwError $ ServerError 500 "error message" "" []

378+ let serveW api = serve api $ throwError $ ServantErr 500 "error message" "" []

345 context "are correctly handled by the client" $

379 context "are correctly handled by the client" $

346 let test :: (WrappedApi, String) -> Spec

380 let test :: (WrappedApi, String) -> Spec

347 test (WrappedApi api, desc) =

381 test (WrappedApi api, desc) =

348 it desc $ bracket (startWaiApp $ serveW api) endWaiApp $ \(_, baseUrl) -> do

382 it desc $ bracket (startWaiApp $ serveW api) endWaiApp $ \(_, baseUrl) -> do

349 let getResponse :: ClientM ()

383 let getResponse :: ClientM ()

350 getResponse = client api

384 getResponse = client api

351− Left (FailureResponse _ r) <- runClient getResponse baseUrl

385+ Left (FailureResponse r) <- runClient getResponse baseUrl

352 responseStatusCode r `shouldBe` (HTTP.Status 500 "error message")

386 responseStatusCode r `shouldBe` (HTTP.Status 500 "error message")

353 in mapM_ test $

387 in mapM_ test $

354 (WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") :

388 (WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") :

@@ -365,7 +399,7 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do

365 let (_ :<|> _ :<|> getDeleteEmpty :<|> _) = client api

399 let (_ :<|> _ :<|> getDeleteEmpty :<|> _) = client api

366 Left res <- runClient getDeleteEmpty baseUrl

400 Left res <- runClient getDeleteEmpty baseUrl

367 case res of

401 case res of

368− FailureResponse _ r | responseStatusCode r == HTTP.status404 -> return ()

402+ FailureResponse r | responseStatusCode r == HTTP.status404 -> return ()

369 _ -> fail $ "expected 404 response, but got " <> show res

403 _ -> fail $ "expected 404 response, but got " <> show res

370

404

371 it "reports DecodeFailure" $ \(_, baseUrl) -> do

405 it "reports DecodeFailure" $ \(_, baseUrl) -> do

@@ -375,8 +409,7 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do

375 DecodeFailure _ _ -> return ()

409 DecodeFailure _ _ -> return ()

376 _ -> fail $ "expected DecodeFailure, but got " <> show res

410 _ -> fail $ "expected DecodeFailure, but got " <> show res

377

411

378− -- we don't catch IOException's

379− xit "reports ConnectionError" $ \_ -> do

412+ it "reports ConnectionError" $ \_ -> do

380 let (getGetWrongHost :<|> _) = client api

413 let (getGetWrongHost :<|> _) = client api

381 Left res <- runClient getGetWrongHost (BaseUrl Http "127.0.0.1" 19872 "")

414 Left res <- runClient getGetWrongHost (BaseUrl Http "127.0.0.1" 19872 "")

382 case res of

415 case res of

@@ -416,7 +449,7 @@ basicAuthSpec = beforeAll (startWaiApp basicAuthServer) $ afterAll endWaiApp $ d

416 it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do

449 it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do

417 let getBasic = client basicAuthAPI

450 let getBasic = client basicAuthAPI

418 let basicAuthData = BasicAuthData "not" "password"

451 let basicAuthData = BasicAuthData "not" "password"

419− Left (FailureResponse _ r) <- runClient (getBasic basicAuthData) baseUrl

452+ Left (FailureResponse r) <- runClient (getBasic basicAuthData) baseUrl

420 responseStatusCode r `shouldBe` HTTP.Status 403 "Forbidden"

453 responseStatusCode r `shouldBe` HTTP.Status 403 "Forbidden"

421

454

422genAuthSpec :: Spec

455genAuthSpec :: Spec

@@ -433,9 +466,25 @@ genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do

433 it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do

466 it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do

434 let getProtected = client genAuthAPI

467 let getProtected = client genAuthAPI

435 let authRequest = Auth.mkAuthenticatedRequest () (\_ req -> Req.addHeader "Wrong" ("header" :: String) req)

468 let authRequest = Auth.mkAuthenticatedRequest () (\_ req -> Req.addHeader "Wrong" ("header" :: String) req)

436− Left (FailureResponse _ r) <- runClient (getProtected authRequest) baseUrl

469+ Left (FailureResponse r) <- runClient (getProtected authRequest) baseUrl

437 responseStatusCode r `shouldBe` (HTTP.Status 401 "Unauthorized")

470 responseStatusCode r `shouldBe` (HTTP.Status 401 "Unauthorized")

438

471

472+genericClientSpec :: Spec

473+genericClientSpec = beforeAll (startWaiApp genericClientServer) $ afterAll endWaiApp $ do

474+ describe "Servant.Client.Generic" $ do

475+

476+ let GenericClient{..} = mkClient (client (Proxy :: Proxy GenericClientAPI))

477+ NestedClient1{..} = mkNestedClient1 "example"

478+ NestedClient2{..} = mkNestedClient2 (Just 42)

479+

480+ it "works for top-level client inClientM function" $ \(_, baseUrl) -> do

481+ left show <$> runClient (getSqr (Just 5)) baseUrl `shouldReturn` Right 25

482+

483+ it "works for nested clients" $ \(_, baseUrl) -> do

484+ left show <$> runClient (idChar (Just 'c')) baseUrl `shouldReturn` Right 'c'

485+ left show <$> runClient (getSum 3 4) baseUrl `shouldReturn` Right 7

486+ left show <$> runClient doNothing baseUrl `shouldReturn` Right ()

487+

439-- * hoistClient

488-- * hoistClient

440

489

441type HoistClientAPI = Get '[JSON] Int :<|> Capture "n" Int :> Post '[JSON] Int

490type HoistClientAPI = Get '[JSON] Int :<|> Capture "n" Int :> Post '[JSON] Int

@@ -452,27 +501,12 @@ hoistClientSpec = beforeAll (startWaiApp hoistClientServer) $ afterAll endWaiApp

452 it "allows us to GET/POST/... requests in IO instead of ClientM" $ \(_, baseUrl) -> do

501 it "allows us to GET/POST/... requests in IO instead of ClientM" $ \(_, baseUrl) -> do

453 let (getInt :<|> postInt)

502 let (getInt :<|> postInt)

454 = hoistClient hoistClientAPI

503 = hoistClient hoistClientAPI

455− (fmap (either (error . show) id) . flip runClientUnsafe baseUrl)

504+ (fmap (either (error . show) id) . flip runClient baseUrl)

456 (client hoistClientAPI)

505 (client hoistClientAPI)

457

506

458 getInt `shouldReturn` 5

507 getInt `shouldReturn` 5

459 postInt 5 `shouldReturn` 5

508 postInt 5 `shouldReturn` 5

460

509

461−-- * ConnectionError

462−type ConnectionErrorAPI = Get '[JSON] Int

463−

464−connectionErrorAPI :: Proxy ConnectionErrorAPI

465−connectionErrorAPI = Proxy

466−

467−connectionErrorSpec :: Spec

468−connectionErrorSpec = describe "Servant.Client.ClientError" $

469− xit "correctly catches ConnectionErrors when the HTTP request can't go through" $ do

470− let getInt = client connectionErrorAPI

471− let baseUrl' = BaseUrl Http "example.invalid" 80 ""

472− let isHttpError (Left (ConnectionError e)) = isJust $ fromException @IOException e

473− isHttpError _ = False

474− (isHttpError <$> runClient getInt baseUrl') `shouldReturn` True

475−

476-- * utils

510-- * utils

477

511

478startWaiApp :: Application -> IO (ThreadId, BaseUrl)

512startWaiApp :: Application -> IO (ThreadId, BaseUrl)

@@ -480,7 +514,7 @@ startWaiApp app = do

480 (port, socket) <- openTestSocket

514 (port, socket) <- openTestSocket

481 let settings = setPort port $ defaultSettings

515 let settings = setPort port $ defaultSettings

482 thread <- forkIO $ runSettingsSocket settings socket app

516 thread <- forkIO $ runSettingsSocket settings socket app

483− return (thread, BaseUrl Http "127.0.0.1" port "")

517+ return (thread, BaseUrl Http "localhost" port "")

484

518

485

519

486endWaiApp :: (ThreadId, BaseUrl) -> IO ()

520endWaiApp :: (ThreadId, BaseUrl) -> IO ()

@@ -489,8 +523,8 @@ endWaiApp (thread, _) = killThread thread

489openTestSocket :: IO (Port, Socket)

523openTestSocket :: IO (Port, Socket)

490openTestSocket = do

524openTestSocket = do

491 s <- socket AF_INET Stream defaultProtocol

525 s <- socket AF_INET Stream defaultProtocol

492− let localhost = tupleToHostAddress (127, 0, 0, 1)

526+ localhost <- inet_addr "127.0.0.1"

493− bind s (SockAddrInet defaultPort localhost)

527+ bind s (SockAddrInet aNY_PORT localhost)

494 listen s 1

528 listen s 1

495 port <- socketPort s

529 port <- socketPort s

496 return (fromIntegral port, s)

530 return (fromIntegral port, s)

servant-client/test/Servant/ClientTestUtils.hsdeleted−384

@@ -1,384 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE ConstraintKinds #-}

3−{-# LANGUAGE DataKinds #-}

4−{-# LANGUAGE DeriveGeneric #-}

5−{-# LANGUAGE FlexibleContexts #-}

6−{-# LANGUAGE FlexibleInstances #-}

7−{-# LANGUAGE GADTs #-}

8−{-# LANGUAGE MultiParamTypeClasses #-}

9−{-# LANGUAGE OverloadedStrings #-}

10−{-# LANGUAGE PolyKinds #-}

11−{-# LANGUAGE ScopedTypeVariables #-}

12−{-# LANGUAGE TypeApplications #-}

13−{-# LANGUAGE TypeFamilies #-}

14−{-# LANGUAGE TypeOperators #-}

15−{-# LANGUAGE UndecidableInstances #-}

16−{-# OPTIONS_GHC -freduction-depth=100 #-}

17−{-# OPTIONS_GHC -fno-warn-orphans #-}

18−{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

19−

20−module Servant.ClientTestUtils where

21−

22−import Prelude ()

23−import Prelude.Compat

24−

25−import Control.Concurrent

26− (ThreadId, forkIO, killThread)

27−import Control.Monad

28− (join)

29−import Control.Monad.Error.Class

30− (throwError)

31−import Data.Aeson

32−import Data.ByteString

33− (ByteString)

34−import Data.ByteString.Builder

35− (byteString)

36−import qualified Data.ByteString.Lazy as LazyByteString

37−import Data.Char

38− (chr, isPrint)

39−import Data.Monoid ()

40−import Data.Proxy

41−import Data.SOP

42−import Data.Text

43− (Text)

44−import qualified Data.Text as Text

45−import Data.Text.Encoding

46− (decodeUtf8, encodeUtf8)

47−import GHC.Generics

48− (Generic)

49−import qualified Network.HTTP.Client as C

50−import qualified Network.HTTP.Types as HTTP

51−import Network.Socket

52−import qualified Network.Wai as Wai

53−import Network.Wai.Handler.Warp

54−import System.IO.Unsafe

55− (unsafePerformIO)

56−import Test.QuickCheck

57−import Web.FormUrlEncoded

58− (FromForm, ToForm)

59−

60−import Servant.API

61− ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth,

62− BasicAuthData (..), Capture, CaptureAll, DeleteNoContent,

63− EmptyAPI, FormUrlEncoded, Fragment, FromHttpApiData (..), Get, Header, Headers,

64− JSON, MimeRender (mimeRender), MimeUnrender (mimeUnrender),

65− NoContent (NoContent), PlainText, Post, QueryFlag, QueryParam,

66− QueryParams, Raw, ReqBody, StdMethod (GET), ToHttpApiData (..), UVerb, Union,

67− Verb, WithStatus (WithStatus), NamedRoutes, addHeader)

68−import Servant.API.Generic ((:-))

69−import Servant.Client

70−import qualified Servant.Client.Core.Auth as Auth

71−import Servant.Server

72−import Servant.Server.Experimental.Auth

73−import Servant.Test.ComprehensiveAPI

74−

75−-- This declaration simply checks that all instances are in place.

76−_ = client comprehensiveAPIWithoutStreaming

77−

78−-- * test data types

79−

80−data Person = Person

81− { _name :: String

82− , _age :: Integer

83− } deriving (Eq, Show, Read, Generic)

84−

85−instance ToJSON Person

86−instance FromJSON Person

87−

88−instance ToForm Person

89−instance FromForm Person

90−

91−instance Arbitrary Person where

92− arbitrary = Person <$> arbitrary <*> arbitrary

93−

94−instance MimeRender PlainText Person where

95− mimeRender _ = LazyByteString.fromStrict . encodeUtf8 . Text.pack . show

96−

97−instance MimeUnrender PlainText Person where

98− mimeUnrender _ =

99− -- This does not handle any errors, but it should be fine for tests

100− Right . read . Text.unpack . decodeUtf8 . LazyByteString.toStrict

101−

102−

103−alice :: Person

104−alice = Person "Alice" 42

105−

106−carol :: Person

107−carol = Person "Carol" 17

108−

109−type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]

110−

111−data RecordRoutes mode = RecordRoutes

112− { version :: mode :- "version" :> Get '[JSON] Int

113− , echo :: mode :- "echo" :> Capture "string" String :> Get '[JSON] String

114− , otherRoutes :: mode :- "other" :> Capture "someParam" Int :> NamedRoutes OtherRoutes

115− } deriving Generic

116−

117−data OtherRoutes mode = OtherRoutes

118− { something :: mode :- "something" :> Get '[JSON] [String]

119− } deriving Generic

120−

121−-- Get for HTTP 307 Temporary Redirect

122−type Get307 = Verb 'GET 307

123−

124−type Api =

125− Get '[JSON] Person

126− :<|> "get" :> Get '[JSON] Person

127− -- This endpoint returns a response with status code 307 Temporary Redirect,

128− -- different from the ones in the 2xx successful class, to test derivation

129− -- of clients' api.

130− :<|> "get307" :> Get307 '[PlainText] Text

131− :<|> "deleteEmpty" :> DeleteNoContent

132− :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person

133− :<|> "captureAll" :> CaptureAll "names" String :> Get '[JSON] [Person]

134− :<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person

135− :<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person

136− -- This endpoint makes use of a 'Raw' server because it is not currently

137− -- possible to handle arbitrary binary query param values with

138− -- @servant-server@

139− :<|> "param-binary" :> QueryParam "payload" UrlEncodedByteString :> Raw

140− :<|> "params" :> QueryParams "names" String :> Get '[JSON] [Person]

141− :<|> "flag" :> QueryFlag "flag" :> Get '[JSON] Bool

142− :<|> "fragment" :> Fragment String :> Get '[JSON] Person

143− :<|> "rawSuccess" :> Raw

144− :<|> "rawSuccessPassHeaders" :> Raw

145− :<|> "rawFailure" :> Raw

146− :<|> "multiple" :>

147− Capture "first" String :>

148− QueryParam "second" Int :>

149− QueryFlag "third" :>

150− ReqBody '[JSON] [(String, [Rational])] :>

151− Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])])

152− :<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool)

153− :<|> "uverb-headers" :> UVerb 'GET '[JSON] '[ WithStatus 200 (Headers TestHeaders Bool), WithStatus 204 String ]

154− :<|> "deleteContentType" :> DeleteNoContent

155− :<|> "redirectWithCookie" :> Raw

156− :<|> "empty" :> EmptyAPI

157− :<|> "uverb-success-or-redirect" :>

158− Capture "bool" Bool :>

159− UVerb 'GET '[PlainText] '[WithStatus 200 Person,

160− WithStatus 301 Text]

161− :<|> "uverb-get-created" :> UVerb 'GET '[PlainText] '[WithStatus 201 Person]

162− :<|> NamedRoutes RecordRoutes

163− :<|> "captureVerbatim" :> Capture "someString" Verbatim :> Get '[PlainText] Text

164−

165−api :: Proxy Api

166−api = Proxy

167−

168−getRoot :: ClientM Person

169−getGet :: ClientM Person

170−getGet307 :: ClientM Text

171−getDeleteEmpty :: ClientM NoContent

172−getCapture :: String -> ClientM Person

173−getCaptureAll :: [String] -> ClientM [Person]

174−getBody :: Person -> ClientM Person

175−getQueryParam :: Maybe String -> ClientM Person

176−getQueryParamBinary :: Maybe UrlEncodedByteString -> HTTP.Method -> ClientM Response

177−getQueryParams :: [String] -> ClientM [Person]

178−getQueryFlag :: Bool -> ClientM Bool

179−getFragment :: ClientM Person

180−getRawSuccess :: HTTP.Method -> ClientM Response

181−getRawSuccessPassHeaders :: HTTP.Method -> ClientM Response

182−getRawFailure :: HTTP.Method -> ClientM Response

183−getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]

184− -> ClientM (String, Maybe Int, Bool, [(String, [Rational])])

185−getRespHeaders :: ClientM (Headers TestHeaders Bool)

186−getUVerbRespHeaders :: ClientM (Union '[ WithStatus 200 (Headers TestHeaders Bool), WithStatus 204 String ])

187−getDeleteContentType :: ClientM NoContent

188−getRedirectWithCookie :: HTTP.Method -> ClientM Response

189−uverbGetSuccessOrRedirect :: Bool

190− -> ClientM (Union '[WithStatus 200 Person,

191− WithStatus 301 Text])

192−uverbGetCreated :: ClientM (Union '[WithStatus 201 Person])

193−recordRoutes :: RecordRoutes (AsClientT ClientM)

194−

195−getRoot

196− :<|> getGet

197− :<|> getGet307

198− :<|> getDeleteEmpty

199− :<|> getCapture

200− :<|> getCaptureAll

201− :<|> getBody

202− :<|> getQueryParam

203− :<|> getQueryParamBinary

204− :<|> getQueryParams

205− :<|> getQueryFlag

206− :<|> getFragment

207− :<|> getRawSuccess

208− :<|> getRawSuccessPassHeaders

209− :<|> getRawFailure

210− :<|> getMultiple

211− :<|> getRespHeaders

212− :<|> getUVerbRespHeaders

213− :<|> getDeleteContentType

214− :<|> getRedirectWithCookie

215− :<|> EmptyClient

216− :<|> uverbGetSuccessOrRedirect

217− :<|> uverbGetCreated

218− :<|> recordRoutes

219− :<|> captureVerbatim = client api

220−

221−server :: Application

222−server = serve api (

223− return carol

224− :<|> return alice

225− :<|> return "redirecting"

226− :<|> return NoContent

227− :<|> (\ name -> return $ Person name 0)

228− :<|> (\ names -> return (zipWith Person names [0..]))

229− :<|> return

230− :<|> (\ name -> case name of

231− Just "alice" -> return alice

232− Just n -> throwError $ ServerError 400 (n ++ " not found") "" []

233− Nothing -> throwError $ ServerError 400 "missing parameter" "" [])

234− :<|> const (Tagged $ \request respond ->

235− respond . maybe (Wai.responseLBS HTTP.notFound404 [] "Missing: payload")

236− (Wai.responseLBS HTTP.ok200 [] . LazyByteString.fromStrict)

237− . join

238− . lookup "payload"

239− $ Wai.queryString request

240− )

241− :<|> (\ names -> return (zipWith Person names [0..]))

242− :<|> return

243− :<|> return alice

244− :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "rawSuccess")

245− :<|> (Tagged $ \ request respond -> (respond $ Wai.responseLBS HTTP.ok200 (Wai.requestHeaders $ request) "rawSuccess"))

246− :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.badRequest400 [] "rawFailure")

247− :<|> (\ a b c d -> return (a, b, c, d))

248− :<|> (return $ addHeader 1729 $ addHeader "eg2" True)

249− :<|> (pure . Z . I . WithStatus $ addHeader 1729 $ addHeader "eg2" True)

250− :<|> return NoContent

251− :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.found302 [("Location", "testlocation"), ("Set-Cookie", "testcookie=test")] "")

252− :<|> emptyServer

253− :<|> (\shouldRedirect -> if shouldRedirect

254− then respond (WithStatus @301 ("redirecting" :: Text))

255− else respond (WithStatus @200 alice ))

256− :<|> respond (WithStatus @201 carol)

257− :<|> RecordRoutes

258− { version = pure 42

259− , echo = pure

260− , otherRoutes = \_ -> OtherRoutes

261− { something = pure ["foo", "bar", "pweet"]

262− }

263− }

264− :<|> pure . decodeUtf8 . unVerbatim

265− )

266−

267−-- * api for testing failures

268−

269−type FailApi =

270− "get" :> Raw

271− :<|> "capture" :> Capture "name" String :> Raw

272− :<|> "body" :> Raw

273− :<|> "headers" :> Raw

274−failApi :: Proxy FailApi

275−failApi = Proxy

276−

277−failServer :: Application

278−failServer = serve failApi (

279− (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "")

280− :<|> (\ _capture -> Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "application/json")] "")

281− :<|> (Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "fooooo")] "")

282− :<|> (Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "application/x-www-form-urlencoded"), ("X-Example1", "1"), ("X-Example2", "foo")] "")

283− )

284−

285−-- * basic auth stuff

286−

287−type BasicAuthAPI =

288− BasicAuth "foo-realm" () :> "private" :> "basic" :> Get '[JSON] Person

289−

290−basicAuthAPI :: Proxy BasicAuthAPI

291−basicAuthAPI = Proxy

292−

293−basicAuthHandler :: BasicAuthCheck ()

294−basicAuthHandler =

295− let check (BasicAuthData username password) =

296− if username == "servant" && password == "server"

297− then return (Authorized ())

298− else return Unauthorized

299− in BasicAuthCheck check

300−

301−basicServerContext :: Context '[ BasicAuthCheck () ]

302−basicServerContext = basicAuthHandler :. EmptyContext

303−

304−basicAuthServer :: Application

305−basicAuthServer = serveWithContext basicAuthAPI basicServerContext (const (return alice))

306−

307−-- * general auth stuff

308−

309−type GenAuthAPI =

310− AuthProtect "auth-tag" :> "private" :> "auth" :> Get '[JSON] Person

311−

312−genAuthAPI :: Proxy GenAuthAPI

313−genAuthAPI = Proxy

314−

315−type instance AuthServerData (AuthProtect "auth-tag") = ()

316−type instance Auth.AuthClientData (AuthProtect "auth-tag") = ()

317−

318−genAuthHandler :: AuthHandler Wai.Request ()

319−genAuthHandler =

320− let handler req = case lookup "AuthHeader" (Wai.requestHeaders req) of

321− Nothing -> throwError (err401 { errBody = "Missing auth header" })

322− Just _ -> return ()

323− in mkAuthHandler handler

324−

325−genAuthServerContext :: Context '[ AuthHandler Wai.Request () ]

326−genAuthServerContext = genAuthHandler :. EmptyContext

327−

328−genAuthServer :: Application

329−genAuthServer = serveWithContext genAuthAPI genAuthServerContext (const (return alice))

330−

331−{-# NOINLINE manager' #-}

332−manager' :: C.Manager

333−manager' = unsafePerformIO $ C.newManager C.defaultManagerSettings

334−

335−runClient :: ClientM a -> BaseUrl -> IO (Either ClientError a)

336−runClient x baseUrl' = runClientM x (mkClientEnv manager' baseUrl')

337−

338−-- * utils

339−

340−startWaiApp :: Application -> IO (ThreadId, BaseUrl)

341−startWaiApp app = do

342− (port, socket) <- openTestSocket

343− let settings = setPort port defaultSettings

344− thread <- forkIO $ runSettingsSocket settings socket app

345− return (thread, BaseUrl Http "localhost" port "")

346−

347−

348−endWaiApp :: (ThreadId, BaseUrl) -> IO ()

349−endWaiApp (thread, _) = killThread thread

350−

351−openTestSocket :: IO (Port, Socket)

352−openTestSocket = do

353− s <- socket AF_INET Stream defaultProtocol

354− let localhost = tupleToHostAddress (127, 0, 0, 1)

355− bind s (SockAddrInet defaultPort localhost)

356− listen s 1

357− port <- socketPort s

358− return (fromIntegral port, s)

359−

360−pathGen :: Gen (NonEmptyList Char)

361−pathGen = fmap NonEmpty path

362− where

363− path = listOf1 $ elements $

364− filter (not . (`elem` ("?%[]/#;" :: String))) $

365− filter isPrint $

366− map chr [0..127]

367−

368−newtype UrlEncodedByteString = UrlEncodedByteString { unUrlEncodedByteString :: ByteString }

369−

370−instance ToHttpApiData UrlEncodedByteString where

371− toEncodedUrlPiece = byteString . HTTP.urlEncode True . unUrlEncodedByteString

372− toUrlPiece = decodeUtf8 . HTTP.urlEncode True . unUrlEncodedByteString

373−

374−instance FromHttpApiData UrlEncodedByteString where

375− parseUrlPiece = pure . UrlEncodedByteString . HTTP.urlDecode True . encodeUtf8

376−

377−newtype Verbatim = Verbatim { unVerbatim :: ByteString }

378−

379−instance ToHttpApiData Verbatim where

380− toEncodedUrlPiece = byteString . unVerbatim

381− toUrlPiece = decodeUtf8 . unVerbatim

382−

383−instance FromHttpApiData Verbatim where

384− parseUrlPiece = pure . Verbatim . encodeUtf8

servant-client/test/Servant/ConnectionErrorSpec.hsdeleted−55

@@ -1,55 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE ConstraintKinds #-}

3−{-# LANGUAGE DataKinds #-}

4−{-# LANGUAGE FlexibleContexts #-}

5−{-# LANGUAGE FlexibleInstances #-}

6−{-# LANGUAGE GADTs #-}

7−{-# LANGUAGE MultiParamTypeClasses #-}

8−{-# LANGUAGE OverloadedStrings #-}

9−{-# LANGUAGE PolyKinds #-}

10−{-# LANGUAGE ScopedTypeVariables #-}

11−{-# LANGUAGE TypeApplications #-}

12−{-# LANGUAGE TypeFamilies #-}

13−{-# LANGUAGE TypeOperators #-}

14−{-# LANGUAGE UndecidableInstances #-}

15−{-# OPTIONS_GHC -freduction-depth=100 #-}

16−{-# OPTIONS_GHC -fno-warn-orphans #-}

17−{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

18−

19−module Servant.ConnectionErrorSpec (spec) where

20−

21−import Prelude ()

22−import Prelude.Compat

23−

24−import Control.Exception

25− (fromException)

26−import Data.Maybe

27− (isJust)

28−import Data.Monoid ()

29−import Data.Proxy

30−import qualified Network.HTTP.Client as C

31−import Test.Hspec

32−

33−import Servant.API

34− (Get, JSON)

35−import Servant.Client

36−import Servant.ClientTestUtils

37−

38−

39−spec :: Spec

40−spec = describe "Servant.ConnectionErrorSpec" $ do

41− connectionErrorSpec

42−

43−type ConnectionErrorAPI = Get '[JSON] Int

44−

45−connectionErrorAPI :: Proxy ConnectionErrorAPI

46−connectionErrorAPI = Proxy

47−

48−connectionErrorSpec :: Spec

49−connectionErrorSpec = describe "Servant.Client.ClientError" $

50− it "correctly catches ConnectionErrors when the HTTP request can't go through" $ do

51− let getInt = client connectionErrorAPI

52− let baseUrl' = BaseUrl Http "example.invalid" 80 ""

53− let isHttpError (Left (ConnectionError e)) = isJust $ fromException @C.HttpException e

54− isHttpError _ = False

55− (isHttpError <$> runClient getInt baseUrl') `shouldReturn` True

servant-client/test/Servant/FailSpec.hsdeleted−79

@@ -1,79 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE ConstraintKinds #-}

3−{-# LANGUAGE DataKinds #-}

4−{-# LANGUAGE FlexibleContexts #-}

5−{-# LANGUAGE FlexibleInstances #-}

6−{-# LANGUAGE GADTs #-}

7−{-# LANGUAGE MultiParamTypeClasses #-}

8−{-# LANGUAGE OverloadedStrings #-}

9−{-# LANGUAGE PolyKinds #-}

10−{-# LANGUAGE ScopedTypeVariables #-}

11−{-# LANGUAGE TypeFamilies #-}

12−{-# LANGUAGE TypeOperators #-}

13−{-# LANGUAGE UndecidableInstances #-}

14−{-# OPTIONS_GHC -freduction-depth=100 #-}

15−{-# OPTIONS_GHC -fno-warn-orphans #-}

16−{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

17−

18−module Servant.FailSpec (spec) where

19−

20−import Prelude ()

21−import Prelude.Compat

22−

23−import Data.Monoid ()

24−import qualified Network.HTTP.Types as HTTP

25−import Test.Hspec

26−

27−import Servant.API

28− ((:<|>) ((:<|>)))

29−import Servant.Client

30−import Servant.ClientTestUtils

31−

32−spec :: Spec

33−spec = describe "Servant.FailSpec" $ do

34− failSpec

35−

36−failSpec :: Spec

37−failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do

38−

39− context "client returns errors appropriately" $ do

40− it "reports FailureResponse" $ \(_, baseUrl) -> do

41− let (_ :<|> _ :<|> _ :<|> getDeleteEmpty :<|> _) = client api

42− Left res <- runClient getDeleteEmpty baseUrl

43− case res of

44− FailureResponse _ r | responseStatusCode r == HTTP.status404 -> return ()

45− _ -> fail $ "expected 404 response, but got " <> show res

46−

47− it "reports DecodeFailure" $ \(_, baseUrl) -> do

48− let (_ :<|> _ :<|> _ :<|> _ :<|> getCapture :<|> _) = client api

49− Left res <- runClient (getCapture "foo") baseUrl

50− case res of

51− DecodeFailure _ _ -> return ()

52− _ -> fail $ "expected DecodeFailure, but got " <> show res

53−

54− it "reports ConnectionError" $ \_ -> do

55− let (getGetWrongHost :<|> _) = client api

56− Left res <- runClient getGetWrongHost (BaseUrl Http "127.0.0.1" 19872 "")

57− case res of

58− ConnectionError _ -> return ()

59− _ -> fail $ "expected ConnectionError, but got " <> show res

60−

61− it "reports UnsupportedContentType" $ \(_, baseUrl) -> do

62− let (_ :<|> getGet :<|> _ ) = client api

63− Left res <- runClient getGet baseUrl

64− case res of

65− UnsupportedContentType "application/octet-stream" _ -> return ()

66− _ -> fail $ "expected UnsupportedContentType, but got " <> show res

67−

68− it "reports UnsupportedContentType when there are response headers" $ \(_, baseUrl) -> do

69− Left res <- runClient getRespHeaders baseUrl

70− case res of

71− UnsupportedContentType "application/x-www-form-urlencoded" _ -> return ()

72− _ -> fail $ "expected UnsupportedContentType, but got " <> show res

73−

74− it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do

75− let (_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api

76− Left res <- runClient (getBody alice) baseUrl

77− case res of

78− InvalidContentTypeHeader _ -> return ()

79− _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res

servant-client/test/Servant/GenAuthSpec.hsdeleted−54

@@ -1,54 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE ConstraintKinds #-}

3−{-# LANGUAGE DataKinds #-}

4−{-# LANGUAGE FlexibleContexts #-}

5−{-# LANGUAGE FlexibleInstances #-}

6−{-# LANGUAGE GADTs #-}

7−{-# LANGUAGE MultiParamTypeClasses #-}

8−{-# LANGUAGE OverloadedStrings #-}

9−{-# LANGUAGE PolyKinds #-}

10−{-# LANGUAGE ScopedTypeVariables #-}

11−{-# LANGUAGE TypeFamilies #-}

12−{-# LANGUAGE TypeOperators #-}

13−{-# LANGUAGE UndecidableInstances #-}

14−{-# OPTIONS_GHC -freduction-depth=100 #-}

15−{-# OPTIONS_GHC -fno-warn-orphans #-}

16−{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

17−

18−module Servant.GenAuthSpec (spec) where

19−

20−import Prelude ()

21−import Prelude.Compat

22−

23−import Control.Arrow

24− (left)

25−import Data.Monoid ()

26−import qualified Network.HTTP.Types as HTTP

27−import Test.Hspec

28−

29−import Servant.Client

30−import qualified Servant.Client.Core.Auth as Auth

31−import qualified Servant.Client.Core.Request as Req

32−import Servant.ClientTestUtils

33−

34−spec :: Spec

35−spec = describe "Servant.GenAuthSpec" $ do

36− genAuthSpec

37−

38−genAuthSpec :: Spec

39−genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do

40− context "Authentication works when requests are properly authenticated" $ do

41−

42− it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do

43− let getProtected = client genAuthAPI

44− let authRequest = Auth.mkAuthenticatedRequest () (\_ req -> Req.addHeader "AuthHeader" ("cool" :: String) req)

45− left show <$> runClient (getProtected authRequest) baseUrl `shouldReturn` Right alice

46−

47− context "Authentication is rejected when requests are not authenticated properly" $ do

48−

49− it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do

50− let getProtected = client genAuthAPI

51− let authRequest = Auth.mkAuthenticatedRequest () (\_ req -> Req.addHeader "Wrong" ("header" :: String) req)

52− Left (FailureResponse _ r) <- runClient (getProtected authRequest) baseUrl

53− responseStatusCode r `shouldBe` HTTP.Status 401 "Unauthorized"

54−

servant-client/test/Servant/GenericSpec.hsdeleted−37

@@ -1,37 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE ConstraintKinds #-}

3−{-# LANGUAGE DataKinds #-}

4−{-# LANGUAGE FlexibleContexts #-}

5−{-# LANGUAGE FlexibleInstances #-}

6−{-# LANGUAGE GADTs #-}

7−{-# LANGUAGE MultiParamTypeClasses #-}

8−{-# LANGUAGE OverloadedStrings #-}

9−{-# LANGUAGE PolyKinds #-}

10−{-# LANGUAGE ScopedTypeVariables #-}

11−{-# LANGUAGE TypeFamilies #-}

12−{-# LANGUAGE TypeOperators #-}

13−{-# LANGUAGE UndecidableInstances #-}

14−{-# OPTIONS_GHC -freduction-depth=100 #-}

15−{-# OPTIONS_GHC -fno-warn-orphans #-}

16−{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

17−

18−module Servant.GenericSpec (spec) where

19−

20−import Test.Hspec

21−

22−import Servant.Client ((//), (/:))

23−import Servant.ClientTestUtils

24−

25−spec :: Spec

26−spec = describe "Servant.GenericSpec" $ do

27− genericSpec

28−

29−genericSpec :: Spec

30−genericSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do

31− context "Record clients work as expected" $ do

32−

33− it "Client functions return expected values" $ \(_,baseUrl) -> do

34− runClient (recordRoutes // version) baseUrl `shouldReturn` Right 42

35− runClient (recordRoutes // echo /: "foo") baseUrl `shouldReturn` Right "foo"

36− it "Clients can be nested" $ \(_,baseUrl) -> do

37− runClient (recordRoutes // otherRoutes /: 42 // something) baseUrl `shouldReturn` Right ["foo", "bar", "pweet"]

servant-client/test/Servant/HoistClientSpec.hsdeleted−58

@@ -1,58 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE ConstraintKinds #-}

3−{-# LANGUAGE DataKinds #-}

4−{-# LANGUAGE FlexibleContexts #-}

5−{-# LANGUAGE FlexibleInstances #-}

6−{-# LANGUAGE GADTs #-}

7−{-# LANGUAGE MultiParamTypeClasses #-}

8−{-# LANGUAGE OverloadedStrings #-}

9−{-# LANGUAGE PolyKinds #-}

10−{-# LANGUAGE RecordWildCards #-}

11−{-# LANGUAGE ScopedTypeVariables #-}

12−{-# LANGUAGE TypeFamilies #-}

13−{-# LANGUAGE TypeOperators #-}

14−{-# LANGUAGE UndecidableInstances #-}

15−{-# OPTIONS_GHC -freduction-depth=100 #-}

16−{-# OPTIONS_GHC -fno-warn-orphans #-}

17−{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

18−

19−module Servant.HoistClientSpec (spec) where

20−

21−import Prelude ()

22−import Prelude.Compat

23−

24−import Data.Monoid ()

25−import Data.Proxy

26−import Test.Hspec

27−

28−import Servant.API

29− ((:<|>) ((:<|>)), (:>), Capture,

30− Get, JSON, Post)

31−import Servant.Client

32−import Servant.Server

33−import Servant.ClientTestUtils

34−

35−

36−spec :: Spec

37−spec = describe "Servant.HoistClientSpec" $ do

38− hoistClientSpec

39−

40−type HoistClientAPI = Get '[JSON] Int :<|> Capture "n" Int :> Post '[JSON] Int

41−

42−hoistClientAPI :: Proxy HoistClientAPI

43−hoistClientAPI = Proxy

44−

45−hoistClientServer :: Application -- implements HoistClientAPI

46−hoistClientServer = serve hoistClientAPI $ return 5 :<|> return

47−

48−hoistClientSpec :: Spec

49−hoistClientSpec = beforeAll (startWaiApp hoistClientServer) $ afterAll endWaiApp $ do

50− describe "Servant.Client.hoistClient" $ do

51− it "allows us to GET/POST/... requests in IO instead of ClientM" $ \(_, baseUrl) -> do

52− let (getInt :<|> postInt)

53− = hoistClient hoistClientAPI

54− (fmap (either (error . show) id) . flip runClient baseUrl)

55− (client hoistClientAPI)

56−

57− getInt `shouldReturn` 5

58− postInt 5 `shouldReturn` 5

servant-client/test/Servant/StreamSpec.hs+73−109

@@ -22,65 +22,56 @@

22module Servant.StreamSpec (spec) where

22module Servant.StreamSpec (spec) where

23

23

24import Control.Monad

24import Control.Monad

25− (when)

25+ (replicateM_, void)

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

26+import qualified Data.ByteString as BS

32import Data.Proxy

27import Data.Proxy

33−import qualified Data.TDigest as TD

34−import qualified Network.HTTP.Client as C

28+import qualified Network.HTTP.Client as C

35import Prelude ()

29import Prelude ()

36import Prelude.Compat

30import Prelude.Compat

37−import Servant.API

31+import System.IO

38− ((:<|>) ((:<|>)), (:>), JSON, NetstringFraming, StreamBody,

32+ (IOMode (ReadMode), withFile)

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)

47import System.IO.Unsafe

33import System.IO.Unsafe

48 (unsafePerformIO)

34 (unsafePerformIO)

49−import System.Mem

50− (performGC)

51import Test.Hspec

35import Test.Hspec

52−import Servant.ClientTestUtils (Person(..))

36+import Test.QuickCheck

37+

38+import Servant.API

39+ ((:<|>) ((:<|>)), (:>), JSON, NetstringFraming,

40+ NewlineFraming, NoFraming, OctetStream, ResultStream (..),

41+ StreamGenerator (..), StreamGet)

42+import Servant.Client

43+import Servant.ClientSpec

44+ (Person (..))

53−import qualified Servant.ClientTestUtils as CT

45+import qualified Servant.ClientSpec as CS

46+import Servant.Server

54

47

55#if MIN_VERSION_base(4,10,0)

48#if MIN_VERSION_base(4,10,0)

56import GHC.Stats

49import GHC.Stats

57− (gc, gcdetails_live_bytes, getRTSStats)

50+ (gc, gcdetails_mem_in_use_bytes, getRTSStats)

58#else

51#else

59import GHC.Stats

52import GHC.Stats

60 (currentBytesUsed, getGCStats)

53 (currentBytesUsed, getGCStats)

61#endif

54#endif

62

55

63−-- This declaration simply checks that all instances are in place.

64−-- Note: this is streaming client

65−_ = client comprehensiveAPI

66−

67spec :: Spec

56spec :: Spec

68−spec = describe "Servant.Client.Streaming" $ do

57+spec = describe "Servant.Stream" $ do

69 streamSpec

58 streamSpec

70

59

71−type StreamApi =

60+type StreamApi f =

72− "streamGetNewline" :> StreamGet NewlineFraming JSON (SourceIO Person)

61+ "streamGetNewline" :> StreamGet NewlineFraming JSON (f Person)

73− :<|> "streamGetNetstring" :> StreamGet NetstringFraming JSON (SourceIO Person)

62+ :<|> "streamGetNetstring" :> StreamGet NetstringFraming JSON (f Person)

74− :<|> "streamALot" :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString)

63+ :<|> "streamALot" :> StreamGet NoFraming OctetStream (f BS.ByteString)

75− :<|> "streamBody" :> StreamBody NoFraming OctetStream (SourceIO BS.ByteString) :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString)

64+

65+

66+capi :: Proxy (StreamApi ResultStream)

67+capi = Proxy

76

68

77−api :: Proxy StreamApi

69+sapi :: Proxy (StreamApi StreamGenerator)

78−api = Proxy

70+sapi = Proxy

79

71

80−getGetNL, getGetNS :: ClientM (SourceIO Person)

72+getGetNL, getGetNS :: ClientM (ResultStream Person)

81−getGetALot :: ClientM (SourceIO BS.ByteString)

73+getGetALot :: ClientM (ResultStream BS.ByteString)

82−getStreamBody :: SourceT IO BS.ByteString -> ClientM (SourceIO BS.ByteString)

83−getGetNL :<|> getGetNS :<|> getGetALot :<|> getStreamBody = client api

74+getGetNL :<|> getGetNS :<|> getGetALot = client capi

84

75

85alice :: Person

76alice :: Person

86alice = Person "Alice" 42

77alice = Person "Alice" 42

@@ -89,95 +80,68 @@ bob :: Person

89bob = Person "Bob" 25

80bob = Person "Bob" 25

90

81

91server :: Application

82server :: Application

92−server = serve api

83+server = serve sapi

93− $ return (source [alice, bob, alice])

84+ $ return (StreamGenerator (\f r -> f alice >> r bob >> r alice))

94− :<|> return (source [alice, bob, alice])

85+ :<|> return (StreamGenerator (\f r -> f alice >> r bob >> r alice))

95− -- 2 ^ (18 + 10) = 256M

86+ :<|> return (StreamGenerator lotsGenerator)

96− :<|> return (SourceT ($ lots (powerOfTwo 18)))

97− :<|> return

98 where

87 where

99− lots n

88+ lotsGenerator f r = do

100− | n < 0 = Stop

89+ void $ f ""

90+ void $ withFile "/dev/urandom" ReadMode $

91+ \handle -> streamFiveMBNTimes handle 1000 r

92+ return ()

93+

94+ streamFiveMBNTimes handle left sink

95+ | left <= (0 :: Int) = return ()

101− | otherwise = Effect $ do

96+ | otherwise = do

102− let size = powerOfTwo 10

97+ msg <- BS.hGet handle (megabytes 5)

103− mbs <- getHardwareEntropy size

98+ _ <- sink msg

104− bs <- maybe (getEntropy size) pure mbs

99+ streamFiveMBNTimes handle (left - 1) sink

105− return (Yield bs (lots (n - 1)))

100+

106

101

107−powerOfTwo :: Int -> Int

108−powerOfTwo = (2 ^)

109

102

110{-# NOINLINE manager' #-}

103{-# NOINLINE manager' #-}

111manager' :: C.Manager

104manager' :: C.Manager

112manager' = unsafePerformIO $ C.newManager C.defaultManagerSettings

105manager' = unsafePerformIO $ C.newManager C.defaultManagerSettings

113

106

114−withClient :: ClientM a -> BaseUrl -> (Either ClientError a -> IO r) -> IO r

107+runClient :: ClientM a -> BaseUrl -> IO (Either ServantError a)

115−withClient x baseUrl' = withClientM x (mkClientEnv manager' baseUrl')

108+runClient x baseUrl' = runClientM x (mkClientEnv manager' baseUrl')

116

109

117−testRunSourceIO :: SourceIO a

110+testRunResultStream :: ResultStream a

111+ -> IO ( Maybe (Either String a)

118− -> IO (Either String [a])

112+ , Maybe (Either String a)

119−testRunSourceIO = runExceptT . runSourceT

113+ , Maybe (Either String a)

114+ , Maybe (Either String a))

115+testRunResultStream (ResultStream k)

116+ = k $ \act -> (,,,) <$> act <*> act <*> act <*> act

120

117

121streamSpec :: Spec

118streamSpec :: Spec

122−streamSpec = beforeAll (CT.startWaiApp server) $ afterAll CT.endWaiApp $ do

119+streamSpec = beforeAll (CS.startWaiApp server) $ afterAll CS.endWaiApp $ do

120+

123 it "works with Servant.API.StreamGet.Newline" $ \(_, baseUrl) -> do

121 it "works with Servant.API.StreamGet.Newline" $ \(_, baseUrl) -> do

124− withClient getGetNL baseUrl $ \(Right res) ->

122+ Right res <- runClient getGetNL baseUrl

125− testRunSourceIO res `shouldReturn` Right [alice, bob, alice]

123+ let jra = Just (Right alice)

124+ jrb = Just (Right bob)

125+ testRunResultStream res `shouldReturn` (jra, jrb, jra, Nothing)

126

126

127 it "works with Servant.API.StreamGet.Netstring" $ \(_, baseUrl) -> do

127 it "works with Servant.API.StreamGet.Netstring" $ \(_, baseUrl) -> do

128− withClient getGetNS baseUrl $ \(Right res) ->

128+ Right res <- runClient getGetNS baseUrl

129− testRunSourceIO res `shouldReturn` Right [alice, bob, alice]

129+ let jra = Just (Right alice)

130−

130+ jrb = Just (Right bob)

131− it "works with Servant.API.StreamBody" $ \(_, baseUrl) -> do

131+ testRunResultStream 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

132

138{-

133{-

139 it "streams in constant memory" $ \(_, baseUrl) -> do

134 it "streams in constant memory" $ \(_, baseUrl) -> do

140− Right rs <- runClient getGetALot baseUrl

135+ Right (ResultStream res) <- runClient getGetALot baseUrl

141− performGC

136+ let consumeNChunks n = replicateM_ n (res void)

142− -- usage0 <- getUsage

137+ consumeNChunks 900

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)

138#if MIN_VERSION_base(4,10,0)

175− gcdetails_live_bytes . gc <$> getRTSStats

139+ memUsed <- gcdetails_mem_in_use_bytes . gc <$> getRTSStats

176#else

140#else

177− currentBytesUsed <$> getGCStats

141+ memUsed <- currentBytesUsed <$> getGCStats

178#endif

142#endif

179 memUsed `shouldSatisfy` (< megabytes 22)

143 memUsed `shouldSatisfy` (< megabytes 22)

144+-}

180

145

181megabytes :: Num a => a -> a

146megabytes :: Num a => a -> a

182megabytes n = n * (1000 ^ (2 :: Int))

147megabytes 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-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

3

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+4−4

@@ -75,7 +75,7 @@ intro2 = DocIntro "This title is below the last"

75-- API specification

75-- API specification

76type TestApi =

76type TestApi =

77 -- GET /hello/:name?capital={true, false} returns a Greet as JSON or PlainText

77 -- GET /hello/:name?capital={true, false} returns a Greet as JSON or PlainText

78− "hello" :> Capture "name" Text :> Header "X-Num-Fairies" Int :> QueryParam "capital" Bool :> Get '[JSON, PlainText] Greet

78+ "hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get '[JSON, PlainText] Greet

79

79

80 -- POST /greet with a Greet as JSON in the request body,

80 -- POST /greet with a Greet as JSON in the request body,

81 -- returns a Greet as JSON

81 -- returns a Greet as JSON

@@ -93,9 +93,9 @@ testApi = Proxy

93extra :: ExtraInfo TestApi

93extra :: ExtraInfo TestApi

94extra =

94extra =

95 extraInfo (Proxy :: Proxy ("greet" :> Capture "greetid" Text :> Delete '[JSON] NoContent)) $

95 extraInfo (Proxy :: Proxy ("greet" :> Capture "greetid" Text :> Delete '[JSON] NoContent)) $

96− defAction & headers <>~ [("X-Num-Unicorns", "1")]

96+ defAction & headers <>~ ["unicorns"]

97 & notes <>~ [ DocNote "Title" ["This is some text"]

97 & notes <>~ [ DocNote "Title" ["This is some text"]

98− , DocNote "Second section" ["And some more"]

98+ , DocNote "Second secton" ["And some more"]

99 ]

99 ]

100

100

101-- Generate the data that lets us have API docs. This

101-- Generate the data that lets us have API docs. This

@@ -109,4 +109,4 @@ docsGreet :: API

109docsGreet = docsWith defaultDocOptions [intro1, intro2] extra testApi

109docsGreet = docsWith defaultDocOptions [intro1, intro2] extra testApi

110

110

111main :: IO ()

111main :: IO ()

112−main = putStrLn $ markdownWith (defRenderingOptions { _renderCurlBasePath = Just "http://localhost:80" }) docsGreet

112+main = putStrLn $ markdown docsGreet

servant-docs/example/greet.md+27−55

@@ -10,144 +10,116 @@ You'll also note that multiple intros are possible.

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/servant-docs.cabal+31−32

@@ -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−

3+x-revision: 5

5synopsis: generate API docs for your servant webservice

4synopsis: generate API docs for your servant webservice

6−category: Servant, Web

7description:

5description:

8 Library for generating API docs from a servant API definition.

6 Library for generating API docs from a servant API definition.

9 .

7 .

10 Runnable example <https://github.com/haskell-servant/servant/blob/master/servant-docs/example/greet.hs here>.

8 Runnable example <https://github.com/haskell-servant/servant/blob/master/servant-docs/example/greet.hs here>.

11 .

9 .

12 <https://github.com/haskell-servant/servant/blob/master/servant-docs/CHANGELOG.md CHANGELOG>

10 <https://github.com/haskell-servant/servant/blob/master/servant-docs/CHANGELOG.md CHANGELOG>

13−

14−homepage: http://docs.servant.dev/

15−bug-reports: http://github.com/haskell-servant/servant/issues

16−license: BSD-3-Clause

11+license: BSD3

17license-file: LICENSE

12license-file: LICENSE

18author: Servant Contributors

13author: Servant Contributors

19maintainer: haskell-servant-maintainers@googlegroups.com

14maintainer: haskell-servant-maintainers@googlegroups.com

20−copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors

15+copyright: 2014-2016 Zalora South East Asia Pte Ltd, Servant Contributors

16+category: Servant, Web

21build-type: Simple

17build-type: Simple

18+cabal-version: >=1.10

22−tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1

19+tested-with:

23−

20+ GHC==8.0.2

21+ GHC==8.2.2

22+ GHC==8.4.4

23+ GHC==8.6.1

24+homepage: http://haskell-servant.readthedocs.org/

25+Bug-reports: http://github.com/haskell-servant/servant/issues

24extra-source-files:

26extra-source-files:

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,28 +41,28 @@ 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.13

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

47

48 -- Servant dependencies

48 -- Servant dependencies

49 build-depends:

49 build-depends:

50− servant >= 0.18 && <0.20

50+ servant == 0.13.* || ==0.14.*

51

51

52 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.

52 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.

53 -- Here can be exceptions if we really need features from the newer versions.

53 -- Here can be exceptions if we really need features from the newer versions.

54 build-depends:

54 build-depends:

55− aeson >= 1.4.1.0 && < 3

55+ aeson >= 1.2.3.0 && < 1.5

56 , aeson-pretty >= 0.8.5 && < 0.9

56 , aeson-pretty >= 0.8.5 && < 0.9

57− , base-compat >= 0.10.5 && < 0.13

57+ , base-compat >= 0.9.3 && < 0.11

58− , case-insensitive >= 1.2.0.11 && < 1.3

58+ , case-insensitive >= 1.2.0.10 && < 1.3

59+ , control-monad-omega >= 0.3.1 && < 0.4

59− , hashable >= 1.2.7.0 && < 1.5

60+ , hashable >= 1.2.6.1 && < 1.3

60− , http-media >= 0.7.1.3 && < 0.9

61+ , http-media >= 0.7.0 && < 0.8

61− , http-types >= 0.12.2 && < 0.13

62+ , http-types >= 0.12 && < 0.13

62− , lens >= 4.17 && < 5.3

63+ , lens >= 4.15.4 && < 4.18

63 , string-conversions >= 0.4.0.1 && < 0.5

64 , string-conversions >= 0.4.0.1 && < 0.5

64− , universe-base >= 1.1.1 && < 1.2

65− , unordered-containers >= 0.2.9.0 && < 0.3

65+ , unordered-containers >= 0.2.8.0 && < 0.3

66

66

67 hs-source-dirs: src

67 hs-source-dirs: src

68 default-language: Haskell2010

68 default-language: Haskell2010

@@ -93,16 +93,15 @@ test-suite spec

93 -- Dependencies inherited from the library. No need to specify bounds.

93 -- Dependencies inherited from the library. No need to specify bounds.

94 build-depends:

94 build-depends:

95 base

95 base

96− , base-compat

97 , aeson

96 , aeson

98 , lens

97 , lens

99 , servant

98 , servant

100 , servant-docs

99 , servant-docs

101 , string-conversions

100 , string-conversions

102

101

103− -- Additional dependencies

102+ -- Additonal dependencies

104 build-depends:

103 build-depends:

105− tasty >= 1.1.0.4 && < 1.5,

104+ hspec >= 2.4.4 && < 2.6

106− tasty-golden >= 2.3.2 && < 2.4,

105+

107− tasty-hunit >= 0.10.0.1 && < 0.11,

106+ build-tool-depends:

108− transformers >= 0.5.2.0 && < 0.6

107+ hspec-discover:hspec-discover >=2.4.4 && <2.6

servant-docs/src/Servant/Docs/Internal.hs+72−229

@@ -25,14 +25,15 @@ import Control.Applicative

25import Control.Arrow

25import Control.Arrow

26 (second)

26 (second)

27import Control.Lens

27import Control.Lens

28− (makeLenses, mapped, each, over, set, to, toListOf, traversed, view,

28+ (makeLenses, mapped, over, traversed, view, (%~), (&), (.~),

29− _1, (%~), (&), (.~), (<>~), (^.), (|>))

29+ (<>~), (^.), (|>))

30+import qualified Control.Monad.Omega as Omega

30import qualified Data.ByteString.Char8 as BSC

31import qualified Data.ByteString.Char8 as BSC

31import Data.ByteString.Lazy.Char8

32import Data.ByteString.Lazy.Char8

32 (ByteString)

33 (ByteString)

33import qualified Data.CaseInsensitive as CI

34import qualified Data.CaseInsensitive as CI

34import Data.Foldable

35import Data.Foldable

35− (fold, toList)

36+ (fold)

36import Data.Hashable

37import Data.Hashable

37 (Hashable)

38 (Hashable)

38import Data.HashMap.Strict

39import Data.HashMap.Strict

@@ -50,21 +51,17 @@ import Data.Ord

50 (comparing)

51 (comparing)

51import Data.Proxy

52import Data.Proxy

52 (Proxy (Proxy))

53 (Proxy (Proxy))

54+import Data.Semigroup

55+ (Semigroup (..))

53import Data.String.Conversions

56import Data.String.Conversions

54 (cs)

57 (cs)

55import Data.Text

58import Data.Text

56 (Text, unpack)

59 (Text, unpack)

57import GHC.Generics

60import 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

61import GHC.TypeLits

62import Servant.API

62import Servant.API

63import Servant.API.ContentTypes

63import Servant.API.ContentTypes

64import Servant.API.TypeLevel

64import Servant.API.TypeLevel

65−import Servant.API.Generic

66−

67−import qualified Data.Universe.Helpers as U

68

65

69import qualified Data.HashMap.Strict as HM

66import qualified Data.HashMap.Strict as HM

70import qualified Data.Text as T

67import qualified Data.Text as T

@@ -77,15 +74,14 @@ import qualified Network.HTTP.Types as HTTP

77-- or any 'Endpoint' value you want using the 'path' and 'method'

74-- or any 'Endpoint' value you want using the 'path' and 'method'

78-- lenses to tweak.

75-- lenses to tweak.

79--

76--

77+-- @

80−-- >>> defEndpoint

78+-- λ> 'defEndpoint'

81−-- "GET" /

79+-- GET /

82−--

83−-- >>> defEndpoint & path <>~ ["foo"]

80+-- λ> 'defEndpoint' & 'path' '<>~' ["foo"]

84−-- "GET" /foo

81+-- GET /foo

85−--

86−-- >>> defEndpoint & path <>~ ["foo"] & method .~ HTTP.methodPost

82+-- λ> 'defEndpoint' & 'path' '<>~' ["foo"] & 'method' '.~' 'HTTP.methodPost'

87−-- "POST" /foo

83+-- POST /foo

88−--

84+-- @

89data Endpoint = Endpoint

85data Endpoint = Endpoint

90 { _path :: [String] -- type collected

86 { _path :: [String] -- type collected

91 , _method :: HTTP.Method -- type collected

87 , _method :: HTTP.Method -- type collected

@@ -106,15 +102,14 @@ showPath ps = concatMap ('/' :) ps

106--

102--

107-- Here's how you can modify it:

103-- Here's how you can modify it:

108--

104--

105+-- @

109−-- >>> defEndpoint

106+-- λ> 'defEndpoint'

110−-- "GET" /

107+-- GET /

111−--

112−-- >>> defEndpoint & path <>~ ["foo"]

108+-- λ> 'defEndpoint' & 'path' '<>~' ["foo"]

113−-- "GET" /foo

109+-- GET /foo

114−--

115−-- >>> defEndpoint & path <>~ ["foo"] & method .~ HTTP.methodPost

110+-- λ> 'defEndpoint' & 'path' '<>~' ["foo"] & 'method' '.~' 'HTTP.methodPost'

116−-- "POST" /foo

111+-- POST /foo

117−--

112+-- @

118defEndpoint :: Endpoint

113defEndpoint :: Endpoint

119defEndpoint = Endpoint [] HTTP.methodGet

114defEndpoint = Endpoint [] HTTP.methodGet

120

115

@@ -131,8 +126,7 @@ instance Semigroup API where

131 (<>) = mappend

126 (<>) = mappend

132

127

133instance Monoid API where

128instance Monoid API where

134− API a1 b1 `mappend` API a2 b2 = API (a1 `mappend` a2)

129+ 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

130 mempty = API mempty mempty

137

131

138-- | An empty 'API'

132-- | An empty 'API'

@@ -161,20 +155,6 @@ data DocQueryParam = DocQueryParam

161 , _paramKind :: ParamKind

155 , _paramKind :: ParamKind

162 } deriving (Eq, Ord, Show)

156 } deriving (Eq, Ord, Show)

163

157

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

158-- | An introductory paragraph for your documentation. You can pass these to

179-- 'docsWithIntros'.

159-- 'docsWithIntros'.

180data DocIntro = DocIntro

160data DocIntro = DocIntro

@@ -240,14 +220,12 @@ data ParamKind = Normal | List | Flag

240-- want to write a 'ToSample' instance for the type that'll be represented

220-- want to write a 'ToSample' instance for the type that'll be represented

241-- as encoded data in the response.

221-- as encoded data in the response.

242--

222--

243−-- Can be tweaked with four lenses.

223+-- 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--

224--

225+-- > λ> defResponse

226+-- > Response {_respStatus = 200, _respTypes = [], _respBody = []}

227+-- > λ> defResponse & respStatus .~ 204 & respBody .~ [("If everything goes well", "{ \"status\": \"ok\" }")]

228+-- > Response {_respStatus = 204, _respTypes = [], _respBody = [("If everything goes well", "{ \"status\": \"ok\" }")]}

251data Response = Response

229data Response = Response

252 { _respStatus :: Int

230 { _respStatus :: Int

253 , _respTypes :: [M.MediaType]

231 , _respTypes :: [M.MediaType]

@@ -255,25 +233,14 @@ data Response = Response

255 , _respHeaders :: [HTTP.Header]

233 , _respHeaders :: [HTTP.Header]

256 } deriving (Eq, Ord, Show)

234 } deriving (Eq, Ord, Show)

257

235

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.

236-- | Default response: status code 200, no response body.

268--

237--

269−-- Can be tweaked with four lenses.

238+-- 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--

239--

240+-- > λ> defResponse

241+-- > Response {_respStatus = 200, _respBody = Nothing}

242+-- > λ> defResponse & respStatus .~ 204 & respBody .~ Just "[]"

243+-- > Response {_respStatus = 204, _respBody = Just "[]"}

277defResponse :: Response

244defResponse :: Response

278defResponse = Response

245defResponse = Response

279 { _respStatus = 200

246 { _respStatus = 200

@@ -295,9 +262,8 @@ defResponse = Response

295data Action = Action

262data Action = Action

296 { _authInfo :: [DocAuthentication] -- user supplied info

263 { _authInfo :: [DocAuthentication] -- user supplied info

297 , _captures :: [DocCapture] -- type collected + user supplied info

264 , _captures :: [DocCapture] -- type collected + user supplied info

298− , _headers :: [HTTP.Header] -- type collected

265+ , _headers :: [Text] -- type collected

299 , _params :: [DocQueryParam] -- type collected + user supplied info

266 , _params :: [DocQueryParam] -- type collected + user supplied info

300− , _fragment :: Maybe DocFragment -- type collected + user supplied info

301 , _notes :: [DocNote] -- user supplied

267 , _notes :: [DocNote] -- user supplied

302 , _mxParams :: [(String, [DocQueryParam])] -- type collected + user supplied info

268 , _mxParams :: [(String, [DocQueryParam])] -- type collected + user supplied info

303 , _rqtypes :: [M.MediaType] -- type collected

269 , _rqtypes :: [M.MediaType] -- type collected

@@ -309,30 +275,27 @@ data Action = Action

309-- laws.

275-- laws.

310--

276--

311-- As such, we invent a non-commutative, left associative operation

277-- As such, we invent a non-commutative, left associative operation

312−-- 'combineAction' to mush two together taking the response from the very left.

278+-- 'combineAction' to mush two together taking the response, body and content

279+-- types from the very left.

313combineAction :: Action -> Action -> Action

280combineAction :: Action -> Action -> Action

314−Action a c h p f n m ts body resp

281+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')

282+ Action (a <> a') (c <> c') (h <> h') (p <> p') (n <> n') (m <> m') ts body resp

317

283

318-- | Default 'Action'. Has no 'captures', no query 'params', expects

284-- | Default 'Action'. Has no 'captures', no query 'params', expects

319-- no request body ('rqbody') and the typical response is 'defResponse'.

285-- no request body ('rqbody') and the typical response is 'defResponse'.

320--

286--

321-- Tweakable with lenses.

287-- Tweakable with lenses.

322--

288--

323−-- >>> defAction

289+-- > λ> defAction

324−-- Action {_authInfo = [], _captures = [], _headers = [], _params = [], _fragment = Nothing, _notes = [], _mxParams = [], _rqtypes = [], _rqbody = [], _response = Response {_respStatus = 200, _respTypes = [], _respBody = [], _respHeaders = []}}

290+-- > Action {_captures = [], _headers = [], _params = [], _mxParams = [], _rqbody = Nothing, _response = Response {_respStatus = 200, _respBody = Nothing}}

325−--

326−-- >>> defAction & response.respStatus .~ 201

291+-- > λ> defAction & response.respStatus .~ 201

327−-- Action {_authInfo = [], _captures = [], _headers = [], _params = [], _fragment = Nothing, _notes = [], _mxParams = [], _rqtypes = [], _rqbody = [], _response = Response {_respStatus = 201, _respTypes = [], _respBody = [], _respHeaders = []}}

292+-- > Action {_captures = [], _headers = [], _params = [], _mxParams = [], _rqbody = Nothing, _response = Response {_respStatus = 201, _respBody = Nothing}}

328−--

329defAction :: Action

293defAction :: Action

330defAction =

294defAction =

331 Action []

295 Action []

332 []

296 []

333 []

297 []

334 []

298 []

335− Nothing

336 []

299 []

337 []

300 []

338 []

301 []

@@ -356,14 +319,12 @@ data ShowContentTypes = AllContentTypes -- ^ For each example, show each conten

356--

319--

357-- @since 0.11.1

320-- @since 0.11.1

358data RenderingOptions = RenderingOptions

321data RenderingOptions = RenderingOptions

359− { _requestExamples :: !ShowContentTypes

322+ { _requestExamples :: !ShowContentTypes

360 -- ^ How many content types to display for request body examples?

323 -- ^ How many content types to display for request body examples?

361− , _responseExamples :: !ShowContentTypes

324+ , _responseExamples :: !ShowContentTypes

362 -- ^ How many content types to display for response body examples?

325 -- ^ How many content types to display for response body examples?

363− , _notesHeading :: !(Maybe String)

326+ , _notesHeading :: !(Maybe String)

364 -- ^ Optionally group all 'notes' together under a common heading.

327 -- ^ 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)

328 } deriving (Show)

368

329

369-- | Default API generation options.

330-- | Default API generation options.

@@ -375,10 +336,9 @@ data RenderingOptions = RenderingOptions

375-- @since 0.11.1

336-- @since 0.11.1

376defRenderingOptions :: RenderingOptions

337defRenderingOptions :: RenderingOptions

377defRenderingOptions = RenderingOptions

338defRenderingOptions = RenderingOptions

378− { _requestExamples = AllContentTypes

339+ { _requestExamples = AllContentTypes

379− , _responseExamples = AllContentTypes

340+ , _responseExamples = AllContentTypes

380− , _notesHeading = Nothing

341+ , _notesHeading = Nothing

381− , _renderCurlBasePath = Nothing

382 }

342 }

383

343

384-- gimme some lenses

344-- gimme some lenses

@@ -388,7 +348,6 @@ makeLenses ''API

388makeLenses ''Endpoint

348makeLenses ''Endpoint

389makeLenses ''DocCapture

349makeLenses ''DocCapture

390makeLenses ''DocQueryParam

350makeLenses ''DocQueryParam

391−makeLenses ''DocFragment

392makeLenses ''DocIntro

351makeLenses ''DocIntro

393makeLenses ''DocNote

352makeLenses ''DocNote

394makeLenses ''Response

353makeLenses ''Response

@@ -398,8 +357,7 @@ makeLenses ''RenderingOptions

398-- | Generate the docs for a given API that implements 'HasDocs'. This is the

357-- | Generate the docs for a given API that implements 'HasDocs'. This is the

399-- default way to create documentation.

358-- default way to create documentation.

400--

359--

401−-- > docs == docsWithOptions defaultDocOptions

360+-- prop> docs == docsWithOptions defaultDocOptions

402−--

403docs :: HasDocs api => Proxy api -> API

361docs :: HasDocs api => Proxy api -> API

404docs p = docsWithOptions p defaultDocOptions

362docs p = docsWithOptions p defaultDocOptions

405

363

@@ -415,9 +373,9 @@ docsWithOptions p = docsFor p (defEndpoint, defAction)

415-- > extra :: ExtraInfo TestApi

373-- > extra :: ExtraInfo TestApi

416-- > extra =

374-- > extra =

417-- > extraInfo (Proxy :: Proxy ("greet" :> Capture "greetid" Text :> Delete)) $

375-- > extraInfo (Proxy :: Proxy ("greet" :> Capture "greetid" Text :> Delete)) $

418−-- > defAction & headers <>~ [("X-Num-Unicorns", 1)]

376+-- > defAction & headers <>~ ["unicorns"]

419-- > & notes <>~ [ DocNote "Title" ["This is some text"]

377-- > & notes <>~ [ DocNote "Title" ["This is some text"]

420−-- > , DocNote "Second section" ["And some more"]

378+-- > , DocNote "Second secton" ["And some more"]

421-- > ]

379-- > ]

422

380

423extraInfo :: (IsIn endpoint api, HasLink endpoint, HasDocs endpoint)

381extraInfo :: (IsIn endpoint api, HasLink endpoint, HasDocs endpoint)

@@ -447,7 +405,7 @@ docsWith opts intros (ExtraInfo endpoints) p =

447 & apiEndpoints %~ HM.unionWith (flip combineAction) endpoints

405 & apiEndpoints %~ HM.unionWith (flip combineAction) endpoints

448

406

449

407

450−-- | Generate the docs for a given API that implements 'HasDocs' with any

408+-- | Generate the docs for a given API that implements 'HasDocs' with with any

451-- number of introduction(s)

409-- number of introduction(s)

452docsWithIntros :: HasDocs api => [DocIntro] -> Proxy api -> API

410docsWithIntros :: HasDocs api => [DocIntro] -> Proxy api -> API

453docsWithIntros intros = docsWith defaultDocOptions intros mempty

411docsWithIntros intros = docsWith defaultDocOptions intros mempty

@@ -510,22 +468,22 @@ samples = map ("",)

510

468

511-- | Default sample Generic-based inputs/outputs.

469-- | Default sample Generic-based inputs/outputs.

512defaultSamples :: forall a. (Generic a, GToSample (Rep a)) => Proxy a -> [(Text, a)]

470defaultSamples :: forall a. (Generic a, GToSample (Rep a)) => Proxy a -> [(Text, a)]

513−defaultSamples _ = second G.to <$> gtoSamples (Proxy :: Proxy (Rep a))

471+defaultSamples _ = Omega.runOmega $ second to <$> gtoSamples (Proxy :: Proxy (Rep a))

514

472

515-- | @'ToSample'@ for Generics.

473-- | @'ToSample'@ for Generics.

516--

474--

517−-- Note: we use combinators from "Universe.Data.Helpers" for more productive sample generation.

475+-- The use of @'Omega'@ allows for more productive sample generation.

518class GToSample t where

476class GToSample t where

519− gtoSamples :: proxy t -> [(Text, t x)]

477+ gtoSamples :: proxy t -> Omega.Omega (Text, t x)

520

478

521instance GToSample U1 where

479instance GToSample U1 where

522− gtoSamples _ = singleSample U1

480+ gtoSamples _ = Omega.each (singleSample U1)

523

481

524instance GToSample V1 where

482instance GToSample V1 where

525 gtoSamples _ = empty

483 gtoSamples _ = empty

526

484

527instance (GToSample p, GToSample q) => GToSample (p :*: q) where

485instance (GToSample p, GToSample q) => GToSample (p :*: q) where

528− gtoSamples _ = U.cartesianProduct render ps qs

486+ gtoSamples _ = render <$> ps <*> qs

529 where

487 where

530 ps = gtoSamples (Proxy :: Proxy p)

488 ps = gtoSamples (Proxy :: Proxy p)

531 qs = gtoSamples (Proxy :: Proxy q)

489 qs = gtoSamples (Proxy :: Proxy q)

@@ -534,13 +492,13 @@ instance (GToSample p, GToSample q) => GToSample (p :*: q) where

534 | otherwise = (ta <> ", " <> tb, a :*: b)

492 | otherwise = (ta <> ", " <> tb, a :*: b)

535

493

536instance (GToSample p, GToSample q) => GToSample (p :+: q) where

494instance (GToSample p, GToSample q) => GToSample (p :+: q) where

537− gtoSamples _ = lefts U.+++ rights

495+ gtoSamples _ = lefts <|> rights

538 where

496 where

539 lefts = second L1 <$> gtoSamples (Proxy :: Proxy p)

497 lefts = second L1 <$> gtoSamples (Proxy :: Proxy p)

540 rights = second R1 <$> gtoSamples (Proxy :: Proxy q)

498 rights = second R1 <$> gtoSamples (Proxy :: Proxy q)

541

499

542instance ToSample a => GToSample (K1 i a) where

500instance ToSample a => GToSample (K1 i a) where

543− gtoSamples _ = second K1 <$> toSamples (Proxy :: Proxy a)

501+ gtoSamples _ = second K1 <$> Omega.each (toSamples (Proxy :: Proxy a))

544

502

545instance (GToSample f) => GToSample (M1 i a f) where

503instance (GToSample f) => GToSample (M1 i a f) where

546 gtoSamples _ = second M1 <$> gtoSamples (Proxy :: Proxy f)

504 gtoSamples _ = second M1 <$> gtoSamples (Proxy :: Proxy f)

@@ -608,15 +566,6 @@ class ToCapture c where

608class ToAuthInfo a where

566class ToAuthInfo a where

609 toAuthInfo :: Proxy a -> DocAuthentication

567 toAuthInfo :: Proxy a -> DocAuthentication

610

568

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

569-- | Generate documentation in Markdown format for

621-- the given 'API'.

570-- the given 'API'.

622--

571--

@@ -646,7 +595,7 @@ markdown = markdownWith defRenderingOptions

646--

595--

647-- @since 0.11.1

596-- @since 0.11.1

648markdownWith :: RenderingOptions -> API -> String

597markdownWith :: RenderingOptions -> API -> String

649−markdownWith RenderingOptions{..} api = unlines $

598+markdownWith RenderingOptions{..} api = unlines $

650 introsStr (api ^. apiIntros)

599 introsStr (api ^. apiIntros)

651 ++ (concatMap (uncurry printEndpoint) . sort . HM.toList $ api ^. apiEndpoints)

600 ++ (concatMap (uncurry printEndpoint) . sort . HM.toList $ api ^. apiEndpoints)

652

601

@@ -657,12 +606,10 @@ markdownWith RenderingOptions{..} api = unlines $

657 notesStr (action ^. notes) ++

606 notesStr (action ^. notes) ++

658 authStr (action ^. authInfo) ++

607 authStr (action ^. authInfo) ++

659 capturesStr (action ^. captures) ++

608 capturesStr (action ^. captures) ++

660− headersStr (toListOf (headers . each . _1 . to (T.pack . BSC.unpack . CI.original)) action) ++

609+ headersStr (action ^. headers) ++

661 paramsStr meth (action ^. params) ++

610 paramsStr meth (action ^. params) ++

662− fragmentStr (action ^. fragment) ++

663 rqbodyStr (action ^. rqtypes) (action ^. rqbody) ++

611 rqbodyStr (action ^. rqtypes) (action ^. rqbody) ++

664 responseStr (action ^. response) ++

612 responseStr (action ^. response) ++

665− maybe [] (curlStr endpoint (action ^. headers) (action ^. rqbody)) _renderCurlBasePath ++

666 []

613 []

667

614

668 where str = "## " ++ BSC.unpack meth

615 where str = "## " ++ BSC.unpack meth

@@ -762,14 +709,6 @@ markdownWith RenderingOptions{..} api = unlines $

762

709

763 where values = param ^. paramValues

710 where values = param ^. paramValues

764

711

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]

712 rqbodyStr :: [M.MediaType] -> [(Text, M.MediaType, ByteString)]-> [String]

774 rqbodyStr [] [] = []

713 rqbodyStr [] [] = []

775 rqbodyStr types s =

714 rqbodyStr types s =

@@ -818,11 +757,12 @@ markdownWith RenderingOptions{..} api = unlines $

818 ("text", "css") -> "css"

757 ("text", "css") -> "css"

819 (_, _) -> ""

758 (_, _) -> ""

820

759

760+

821 contentStr mime_type body =

761 contentStr mime_type body =

822 "" :

762 "" :

823− "```" <> markdownForType mime_type :

763+ " ```" <> markdownForType mime_type :

824 cs body :

764 cs body :

825− "```" :

765+ " ```" :

826 "" :

766 "" :

827 []

767 []

828

768

@@ -842,36 +782,6 @@ markdownWith RenderingOptions{..} api = unlines $

842 xs ->

782 xs ->

843 formatBodies _responseExamples xs

783 formatBodies _responseExamples xs

844

784

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

785-- * Instances

876

786

877-- | The generated docs for @a ':<|>' b@ just appends the docs

787-- | The generated docs for @a ':<|>' b@ just appends the docs

@@ -895,7 +805,7 @@ instance HasDocs EmptyAPI where

895-- | @"books" :> 'Capture' "isbn" Text@ will appear as

805-- | @"books" :> 'Capture' "isbn" Text@ will appear as

896-- @/books/:isbn@ in the docs.

806-- @/books/:isbn@ in the docs.

897instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs api)

807instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs api)

898− => HasDocs (Capture' '[] sym a :> api) where

808+ => HasDocs (Capture' mods sym a :> api) where

899

809

900 docsFor Proxy (endpoint, action) =

810 docsFor Proxy (endpoint, action) =

901 docsFor subApiP (endpoint', action')

811 docsFor subApiP (endpoint', action')

@@ -907,28 +817,6 @@ instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs api)

907 endpoint' = over path (\p -> p ++ [":" ++ symbolVal symP]) endpoint

817 endpoint' = over path (\p -> p ++ [":" ++ symbolVal symP]) endpoint

908 symP = Proxy :: Proxy sym

818 symP = Proxy :: Proxy sym

909

819

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

820

933-- | @"books" :> 'CaptureAll' "isbn" Text@ will appear as

821-- | @"books" :> 'CaptureAll' "isbn" Text@ will appear as

934-- @/books/:isbn@ in the docs.

822-- @/books/:isbn@ in the docs.

@@ -962,25 +850,12 @@ instance {-# OVERLAPPABLE #-}

962 status = fromInteger $ natVal (Proxy :: Proxy status)

850 status = fromInteger $ natVal (Proxy :: Proxy status)

963 p = Proxy :: Proxy a

851 p = Proxy :: Proxy a

964

852

965−instance (ReflectMethod method) =>

966− HasDocs (NoContentVerb method) where

967− docsFor Proxy (endpoint, action) DocOptions{..} =

968− single endpoint' action'

969−

970− where endpoint' = endpoint & method .~ method'

971− action' = action & response.respStatus .~ 204

972− & response.respTypes .~ []

973− & response.respBody .~ []

974− & response.respHeaders .~ []

975− method' = reflectMethod (Proxy :: Proxy method)

976−

977-- | TODO: mention the endpoint is streaming, its framing strategy

853-- | TODO: mention the endpoint is streaming, its framing strategy

978--

854--

979-- Also there are no samples.

855-- Also there are no samples.

980−--

981−-- TODO: AcceptFraming for content-type

982instance {-# OVERLAPPABLE #-}

856instance {-# OVERLAPPABLE #-}

857+ (MimeRender ct a, KnownNat status

983− (Accept ct, KnownNat status, ReflectMethod method)

858+ , ReflectMethod method)

984 => HasDocs (Stream method status framing ct a) where

859 => HasDocs (Stream method status framing ct a) where

985 docsFor Proxy (endpoint, action) DocOptions{..} =

860 docsFor Proxy (endpoint, action) DocOptions{..} =

986 single endpoint' action'

861 single endpoint' action'

@@ -991,6 +866,7 @@ instance {-# OVERLAPPABLE #-}

991 t = Proxy :: Proxy '[ct]

866 t = Proxy :: Proxy '[ct]

992 method' = reflectMethod (Proxy :: Proxy method)

867 method' = reflectMethod (Proxy :: Proxy method)

993 status = fromInteger $ natVal (Proxy :: Proxy status)

868 status = fromInteger $ natVal (Proxy :: Proxy status)

869+ p = Proxy :: Proxy a

994

870

995instance {-# OVERLAPPING #-}

871instance {-# OVERLAPPING #-}

996 (ToSample a, AllMimeRender (ct ': cts) a, KnownNat status

872 (ToSample a, AllMimeRender (ct ': cts) a, KnownNat status

@@ -1010,17 +886,14 @@ instance {-# OVERLAPPING #-}

1010 status = fromInteger $ natVal (Proxy :: Proxy status)

886 status = fromInteger $ natVal (Proxy :: Proxy status)

1011 p = Proxy :: Proxy a

887 p = Proxy :: Proxy a

1012

888

1013−instance (ToHttpApiData a, ToSample a, KnownSymbol sym, HasDocs api)

889+instance (KnownSymbol sym, HasDocs api)

1014 => HasDocs (Header' mods sym a :> api) where

890 => HasDocs (Header' mods sym a :> api) where

1015 docsFor Proxy (endpoint, action) =

891 docsFor Proxy (endpoint, action) =

1016 docsFor subApiP (endpoint, action')

892 docsFor subApiP (endpoint, action')

1017

893

1018 where subApiP = Proxy :: Proxy api

894 where subApiP = Proxy :: Proxy api

1019− action' = over headers (|> (headerName, headerVal)) action

895+ action' = over headers (|> headername) action

1020− headerName = CI.mk . cs $ symbolVal (Proxy :: Proxy sym)

896+ 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

897

1025instance (KnownSymbol sym, ToParam (QueryParam' mods sym a), HasDocs api)

898instance (KnownSymbol sym, ToParam (QueryParam' mods sym a), HasDocs api)

1026 => HasDocs (QueryParam' mods sym a :> api) where

899 => HasDocs (QueryParam' mods sym a :> api) where

@@ -1053,15 +926,6 @@ instance (KnownSymbol sym, ToParam (QueryFlag sym), HasDocs api)

1053 paramP = Proxy :: Proxy (QueryFlag sym)

926 paramP = Proxy :: Proxy (QueryFlag sym)

1054 action' = over params (|> toParam paramP) action

927 action' = over params (|> toParam paramP) action

1055

928

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

929

1066instance HasDocs Raw where

930instance HasDocs Raw where

1067 docsFor _proxy (endpoint, action) _ =

931 docsFor _proxy (endpoint, action) _ =

@@ -1094,6 +958,7 @@ instance (KnownSymbol desc, HasDocs api)

1094-- both are even defined) for any particular type.

958-- both are even defined) for any particular type.

1095instance (ToSample a, AllMimeRender (ct ': cts) a, HasDocs api)

959instance (ToSample a, AllMimeRender (ct ': cts) a, HasDocs api)

1096 => HasDocs (ReqBody' mods (ct ': cts) a :> api) where

960 => HasDocs (ReqBody' mods (ct ': cts) a :> api) where

961+

1097 docsFor Proxy (endpoint, action) opts@DocOptions{..} =

962 docsFor Proxy (endpoint, action) opts@DocOptions{..} =

1098 docsFor subApiP (endpoint, action') opts

963 docsFor subApiP (endpoint, action') opts

1099

964

@@ -1104,18 +969,6 @@ instance (ToSample a, AllMimeRender (ct ': cts) a, HasDocs api)

1104 t = Proxy :: Proxy (ct ': cts)

969 t = Proxy :: Proxy (ct ': cts)

1105 p = Proxy :: Proxy a

970 p = Proxy :: Proxy a

1106

971

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

972instance (KnownSymbol path, HasDocs api) => HasDocs (path :> api) where

1120

973

1121 docsFor Proxy (endpoint, action) =

974 docsFor Proxy (endpoint, action) =

@@ -1144,9 +997,6 @@ instance HasDocs api => HasDocs (Vault :> api) where

1144instance HasDocs api => HasDocs (WithNamedContext name context api) where

997instance HasDocs api => HasDocs (WithNamedContext name context api) where

1145 docsFor Proxy = docsFor (Proxy :: Proxy api)

998 docsFor Proxy = docsFor (Proxy :: Proxy api)

1146

999

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

1000instance (ToAuthInfo (BasicAuth realm usr), HasDocs api) => HasDocs (BasicAuth realm usr :> api) where

1151 docsFor Proxy (endpoint, action) =

1001 docsFor Proxy (endpoint, action) =

1152 docsFor (Proxy :: Proxy api) (endpoint, action')

1002 docsFor (Proxy :: Proxy api) (endpoint, action')

@@ -1154,9 +1004,6 @@ instance (ToAuthInfo (BasicAuth realm usr), HasDocs api) => HasDocs (BasicAuth r

1154 authProxy = Proxy :: Proxy (BasicAuth realm usr)

1004 authProxy = Proxy :: Proxy (BasicAuth realm usr)

1155 action' = over authInfo (|> toAuthInfo authProxy) action

1005 action' = over authInfo (|> toAuthInfo authProxy) action

1156

1006

1157−instance HasDocs (ToServantApi api) => HasDocs (NamedRoutes api) where

1158− docsFor Proxy = docsFor (Proxy :: Proxy (ToServantApi api))

1159−

1160-- ToSample instances for simple types

1007-- ToSample instances for simple types

1161instance ToSample NoContent

1008instance ToSample NoContent

1162instance ToSample Bool

1009instance ToSample Bool

@@ -1173,7 +1020,6 @@ instance (ToSample a, ToSample b, ToSample c, ToSample d, ToSample e, ToSample f

1173instance ToSample a => ToSample (Maybe a)

1020instance ToSample a => ToSample (Maybe a)

1174instance (ToSample a, ToSample b) => ToSample (Either a b)

1021instance (ToSample a, ToSample b) => ToSample (Either a b)

1175instance ToSample a => ToSample [a]

1022instance ToSample a => ToSample [a]

1176−instance ToSample a => ToSample (NonEmpty a)

1177

1023

1178-- ToSample instances for Control.Applicative types

1024-- ToSample instances for Control.Applicative types

1179instance ToSample a => ToSample (Const a b)

1025instance ToSample a => ToSample (Const a b)

@@ -1187,6 +1033,3 @@ instance ToSample a => ToSample (Product a)

1187instance ToSample a => ToSample (First a)

1033instance ToSample a => ToSample (First a)

1188instance ToSample a => ToSample (Last a)

1034instance ToSample a => ToSample (Last a)

1189instance ToSample a => ToSample (Dual a)

1035instance ToSample a => ToSample (Dual a)

1190−

1191−-- $setup

1192−-- >>> :set -XOverloadedStrings

servant-docs/src/Servant/Docs/Internal/Pretty.hs−19

@@ -18,7 +18,6 @@ import Data.Proxy

18import Network.HTTP.Media

18import Network.HTTP.Media

19 ((//))

19 ((//))

20import Servant.API

20import Servant.API

21−import Servant.API.Verbs

22

21

23-- | PrettyJSON content type.

22-- | PrettyJSON content type.

24data PrettyJSON

23data PrettyJSON

@@ -47,24 +46,6 @@ type family Pretty (api :: k) :: k where

47 Pretty (Put cs r) = Put (Pretty cs) r

46 Pretty (Put cs r) = Put (Pretty cs) r

48 Pretty (Delete cs r) = Delete (Pretty cs) r

47 Pretty (Delete cs r) = Delete (Pretty cs) r

49 Pretty (Patch cs r) = Patch (Pretty cs) r

48 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

49 Pretty (ReqBody cs r) = ReqBody (Pretty cs) r

69 Pretty (JSON ': xs) = PrettyJSON ': xs

50 Pretty (JSON ': xs) = PrettyJSON ': xs

70 Pretty (x ': xs) = x ': Pretty xs

51 Pretty (x ': xs) = x ': Pretty xs

servant-docs/test/Servant/DocsSpec.hs+25−97

@@ -1,77 +1,55 @@

1−{-# LANGUAGE DataKinds #-}

1+{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE DeriveFunctor #-}

3−{-# LANGUAGE DeriveGeneric #-}

2+{-# LANGUAGE DeriveGeneric #-}

4−{-# LANGUAGE FlexibleContexts #-}

3+{-# LANGUAGE FlexibleContexts #-}

5−{-# LANGUAGE FlexibleInstances #-}

4+{-# LANGUAGE FlexibleInstances #-}

6−{-# LANGUAGE GADTs #-}

7−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

8−{-# LANGUAGE MultiParamTypeClasses #-}

5+{-# LANGUAGE MultiParamTypeClasses #-}

9−{-# LANGUAGE OverloadedStrings #-}

6+{-# LANGUAGE OverloadedStrings #-}

10−{-# LANGUAGE TypeOperators #-}

7+{-# LANGUAGE TypeOperators #-}

11−{-# LANGUAGE TypeSynonymInstances #-}

8+{-# LANGUAGE TypeSynonymInstances #-}

12{-# OPTIONS_GHC -fno-warn-orphans #-}

9{-# OPTIONS_GHC -fno-warn-orphans #-}

13{-# OPTIONS_GHC -freduction-depth=100 #-}

10{-# OPTIONS_GHC -freduction-depth=100 #-}

14

11

15module Servant.DocsSpec where

12module Servant.DocsSpec where

16

13

17import Control.Lens

14import Control.Lens

18− ((&), (<>~))

19−import Control.Monad

20− (unless)

21−import Control.Monad.Trans.Writer

22− (Writer, runWriter, tell)

23import Data.Aeson

15import Data.Aeson

24−import Data.List

16+import Data.Monoid

25− (isInfixOf)

26import Data.Proxy

17import Data.Proxy

27import Data.String.Conversions

18import Data.String.Conversions

28 (cs)

19 (cs)

29import GHC.Generics

20import GHC.Generics

30−import Prelude ()

21+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

22

39import Servant.API

23import Servant.API

24+import Servant.API.Internal.Test.ComprehensiveAPI

40import Servant.Docs.Internal

25import Servant.Docs.Internal

41−import Servant.Test.ComprehensiveAPI

42

26

43-- * comprehensive api

27-- * comprehensive api

44

28

45-- This declaration simply checks that all instances are in place.

29-- This declaration simply checks that all instances are in place.

46−comprehensiveDocs :: API

47−comprehensiveDocs = docs comprehensiveAPI

30+_ = docs comprehensiveAPI

48

31

49instance ToParam (QueryParam' mods "foo" Int) where

32instance ToParam (QueryParam' mods "foo" Int) where

50− toParam _ = DocQueryParam "foo" ["1","2","3"] "QueryParams Int" Normal

33+ toParam = error "unused"

51instance ToParam (QueryParam' mods "bar" Int) where

34instance ToParam (QueryParam' mods "bar" Int) where

52− toParam _ = DocQueryParam "bar" ["1","2","3"] "QueryParams Int" Normal

35+ toParam = error "unused"

53instance ToParam (QueryParams "foo" Int) where

36instance ToParam (QueryParams "foo" Int) where

54− toParam _ = DocQueryParam "foo" ["1","2","3"] "QueryParams Int" List

37+ toParam = error "unused"

55instance ToParam (QueryFlag "foo") where

38instance ToParam (QueryFlag "foo") where

56− toParam _ = DocQueryParam "foo" [] "QueryFlag" Flag

39+ toParam = error "unused"

57instance ToCapture (Capture "foo" Int) where

40instance ToCapture (Capture "foo" Int) where

58− toCapture _ = DocCapture "foo" "Capture foo Int"

41+ toCapture = error "unused"

59instance ToCapture (CaptureAll "foo" Int) where

42instance ToCapture (CaptureAll "foo" Int) where

60− toCapture _ = DocCapture "foo" "Capture all foo Int"

43+ toCapture = error "unused"

61−instance ToFragment (Fragment Int) where

62− toFragment _ = DocFragment "foo" "Fragment Int"

63

44

64-- * specs

45-- * specs

65

46

66−spec :: TestTree

47+spec :: Spec

67spec = describe "Servant.Docs" $ do

48spec = describe "Servant.Docs" $ do

68− golden "comprehensive API" "golden/comprehensive.md" (markdown comprehensiveDocs)

69

49

70 describe "markdown" $ do

50 describe "markdown" $ do

71− let md1 = markdown (docs (Proxy :: Proxy TestApi1))

51+ let md = markdown (docs (Proxy :: Proxy TestApi1))

72− tests1 md1

52+ tests md

73− let md2 = markdown (docs (Proxy :: Proxy TestApi2))

74− tests2 md2

75

53

76 describe "markdown with extra info" $ do

54 describe "markdown with extra info" $ do

77 let

55 let

@@ -83,7 +61,7 @@ spec = describe "Servant.Docs" $ do

83 (Proxy :: Proxy (ReqBody '[JSON] String :> Post '[JSON] Datatype1))

61 (Proxy :: Proxy (ReqBody '[JSON] String :> Post '[JSON] Datatype1))

84 (defAction & notes <>~ [DocNote "Post data" ["Posts some Json data"]])

62 (defAction & notes <>~ [DocNote "Post data" ["Posts some Json data"]])

85 md = markdown (docsWith defaultDocOptions [] extra (Proxy :: Proxy TestApi1))

63 md = markdown (docsWith defaultDocOptions [] extra (Proxy :: Proxy TestApi1))

86− tests1 md

64+ tests md

87 it "contains the extra info provided" $ do

65 it "contains the extra info provided" $ do

88 md `shouldContain` "Get an Integer"

66 md `shouldContain` "Get an Integer"

89 md `shouldContain` "Post data"

67 md `shouldContain` "Post data"

@@ -111,7 +89,7 @@ spec = describe "Servant.Docs" $ do

111

89

112

90

113 where

91 where

114− tests1 md = do

92+ tests md = do

115 it "mentions supported content-types" $ do

93 it "mentions supported content-types" $ do

116 md `shouldContain` "application/json"

94 md `shouldContain` "application/json"

117 md `shouldContain` "text/plain;charset=utf-8"

95 md `shouldContain` "text/plain;charset=utf-8"

@@ -126,21 +104,14 @@ spec = describe "Servant.Docs" $ do

126 it "mentions headers" $ do

104 it "mentions headers" $ do

127 md `shouldContain` "- This endpoint is sensitive to the value of the **X-Test** HTTP header."

105 md `shouldContain` "- This endpoint is sensitive to the value of the **X-Test** HTTP header."

128

106

129− it "contains response samples - dt1field1" $

107+ it "contains response samples" $

130− md `shouldContain` "\"dt1field1\":\"field 1\""

108+ md `shouldContain` "{\"dt1field1\":\"field 1\",\"dt1field2\":13}"

131− it "contains response samples - dt1field2" $

132− md `shouldContain` "\"dt1field2\":13"

133 it "contains request body samples" $

109 it "contains request body samples" $

134 md `shouldContain` "17"

110 md `shouldContain` "17"

135

111

136 it "does not generate any docs mentioning the 'empty-api' path" $

112 it "does not generate any docs mentioning the 'empty-api' path" $

137 md `shouldNotContain` "empty-api"

113 md `shouldNotContain` "empty-api"

138

114

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

115

145-- * APIs

116-- * APIs

146

117

@@ -167,10 +138,6 @@ type TestApi1 = Get '[JSON, PlainText] (Headers '[Header "Location" String] Int)

167 :<|> Header "X-Test" Int :> Put '[JSON] Int

138 :<|> Header "X-Test" Int :> Put '[JSON] Int

168 :<|> "empty-api" :> EmptyAPI

139 :<|> "empty-api" :> EmptyAPI

169

140

170−type TestApi2 = "duplicate-endpoint" :> Get '[JSON] Datatype1

171− :<|> "duplicate-endpoint" :> Get '[PlainText] Int

172−

173−

174data TT = TT1 | TT2 deriving (Show, Eq)

141data TT = TT1 | TT2 deriving (Show, Eq)

175data UT = UT1 | UT2 deriving (Show, Eq)

142data UT = UT1 | UT2 deriving (Show, Eq)

176

143

@@ -179,42 +146,3 @@ instance ToSample TT where

179

146

180instance ToSample UT where

147instance ToSample UT where

181 toSamples _ = [("yks", UT1), ("kaks", UT2)]

148 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−99

@@ -1,105 +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−

1030.11.1

40.11.1

104------

5------

105

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/servant-foreign.cabal+22−20

@@ -1,9 +1,7 @@

1−cabal-version: 2.2

2name: servant-foreign

1name: servant-foreign

3−version: 0.15.4

2+version: 0.11.1

4−

3+x-revision: 3

5synopsis: Helpers for generating clients for servant APIs in any programming language

4synopsis: Helpers for generating clients for servant APIs in any programming language

6−category: Servant, Web

7description:

5description:

8 Helper types and functions for generating client functions for servant APIs in any programming language

6 Helper types and functions for generating client functions for servant APIs in any programming language

9 .

7 .

@@ -12,20 +10,23 @@ description:

12 See the servant-js package for an example

10 See the servant-js package for an example

13 .

11 .

14 <https://github.com/haskell-servant/servant/blob/master/servant-foreign/CHANGELOG.md CHANGELOG>

12 <https://github.com/haskell-servant/servant/blob/master/servant-foreign/CHANGELOG.md CHANGELOG>

15−

16−homepage: http://docs.servant.dev/

17−bug-reports: http://github.com/haskell-servant/servant/issues

18−license: BSD-3-Clause

13+license: BSD3

19license-file: LICENSE

14license-file: LICENSE

20author: Servant Contributors

15author: Servant Contributors

21maintainer: haskell-servant-maintainers@googlegroups.com

16maintainer: haskell-servant-maintainers@googlegroups.com

22−copyright: 2015-2019 Servant Contributors

17+copyright: 2015-2016 Servant Contributors

18+category: Servant, Web

23build-type: Simple

19build-type: Simple

24−tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1

20+cabal-version: >=1.10

25−

26extra-source-files:

21extra-source-files:

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==8.0.2

27+ GHC==8.2.2

28+ GHC==8.4.4

29+ GHC==8.6.1

29

30

30source-repository head

31source-repository head

31 type: git

32 type: git

@@ -41,19 +42,19 @@ 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.13

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.* || ==0.14.*

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.11

55− , lens >= 4.17 && < 5.3

56+ , lens >= 4.15.4 && <4.18

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

@@ -72,9 +73,10 @@ test-suite spec

72 , servant

73 , servant

73 , servant-foreign

74 , servant-foreign

74

75

75− -- Additional dependencies

76+ -- Additonal dependencies

76 build-depends:

77 build-depends:

77− hspec >= 2.6.0 && <2.10

78+ hspec >= 2.4.4 && <2.6

79+

78 build-tool-depends:

80 build-tool-depends:

79− hspec-discover:hspec-discover >=2.6.0 && <2.10

81+ hspec-discover:hspec-discover >=2.4.4 && <2.6

80 default-language: Haskell2010

82 default-language: Haskell2010

servant-foreign/src/Servant/Foreign.hs+18−23

@@ -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,7 +37,16 @@ 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

servant-foreign/src/Servant/Foreign/Inflections.hs+13−18

@@ -13,37 +13,27 @@ module Servant.Foreign.Inflections

13import Control.Lens hiding

13import Control.Lens hiding

14 (cons)

14 (cons)

15import qualified Data.Char as C

15import qualified Data.Char as C

16+import Data.Monoid

16import Data.Text hiding

17import Data.Text hiding

17 (map)

18 (map)

18import Prelude hiding

19import Prelude hiding

19 (head, tail)

20 (head, tail)

20import Servant.Foreign.Internal

21import Servant.Foreign.Internal

21

22

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

23concatCaseL :: Getter FunctionName Text

29concatCaseL = _FunctionName . to mconcat

24concatCaseL = _FunctionName . to mconcat

30

25

31−-- | Use the snake_case convention.

26+-- | 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

27+concatCase :: FunctionName -> Text

36−snakeCase = view snakeCaseL

28+concatCase = view concatCaseL

37

29

38snakeCaseL :: Getter FunctionName Text

30snakeCaseL :: Getter FunctionName Text

39snakeCaseL = _FunctionName . to (intercalate "_")

31snakeCaseL = _FunctionName . to (intercalate "_")

40

32

41−-- | Use the camelCase convention.

33+-- | Function name builder using the snake_case convention.

42−-- The first part is lower case, every other part starts with an upper case character.

34+-- each part is separated by a single underscore character.

43−--

44−-- @[ "get", "documents", "by", "id" ] → "getDocumentsById"@

45−camelCase :: FunctionName -> Text

35+snakeCase :: FunctionName -> Text

46−camelCase = view camelCaseL

36+snakeCase = view snakeCaseL

47

37

48camelCaseL :: Getter FunctionName Text

38camelCaseL :: Getter FunctionName Text

49camelCaseL = _FunctionName . to convert

39camelCaseL = _FunctionName . to convert

@@ -52,3 +42,8 @@ camelCaseL = _FunctionName . to convert

52 convert (p:ps) = mconcat $ p : map capitalize ps

42 convert (p:ps) = mconcat $ p : map capitalize ps

53 capitalize "" = ""

43 capitalize "" = ""

54 capitalize name = C.toUpper (head name) `cons` tail name

44 capitalize name = C.toUpper (head name) `cons` tail name

45+

46+-- | Function name builder using the CamelCase convention.

47+-- each part begins with an upper case character.

48+camelCase :: FunctionName -> Text

49+camelCase = view camelCaseL

servant-foreign/src/Servant/Foreign/Internal.hs+35−169

@@ -13,6 +13,8 @@

13{-# LANGUAGE TypeOperators #-}

13{-# LANGUAGE TypeOperators #-}

14{-# LANGUAGE UndecidableInstances #-}

14{-# LANGUAGE UndecidableInstances #-}

15

15

16+-- | Generalizes all the data needed to make code generation work with

17+-- arbitrary programming languages.

16module Servant.Foreign.Internal where

18module Servant.Foreign.Internal where

17

19

18import Prelude ()

20import Prelude ()

@@ -23,6 +25,8 @@ import Control.Lens

23import Data.Data

25import Data.Data

24 (Data)

26 (Data)

25import Data.Proxy

27import Data.Proxy

28+import Data.Semigroup

29+ (Semigroup)

26import Data.String

30import Data.String

27import Data.Text

31import Data.Text

28import Data.Text.Encoding

32import Data.Text.Encoding

@@ -36,75 +40,50 @@ import Servant.API.Modifiers

36 (RequiredArgument)

40 (RequiredArgument)

37import Servant.API.TypeLevel

41import Servant.API.TypeLevel

38

42

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] }

43newtype FunctionName = FunctionName { unFunctionName :: [Text] }

43 deriving (Data, Show, Eq, Semigroup, Monoid, Typeable)

44 deriving (Data, Show, Eq, Semigroup, Monoid, Typeable)

44

45

45makePrisms ''FunctionName

46makePrisms ''FunctionName

46

47

47−-- | See documentation of 'Arg'

48newtype PathSegment = PathSegment { unPathSegment :: Text }

48newtype PathSegment = PathSegment { unPathSegment :: Text }

49 deriving (Data, Show, Eq, IsString, Semigroup, Monoid, Typeable)

49 deriving (Data, Show, Eq, IsString, Semigroup, Monoid, Typeable)

50

50

51makePrisms ''PathSegment

51makePrisms ''PathSegment

52

52

53−-- | Maps a name to the foreign type that belongs to the annotated value.

54−--

55−-- Used for header args, query args, and capture args.

56−data Arg ftype = Arg

53+data Arg f = Arg

57 { _argName :: PathSegment

54 { _argName :: PathSegment

58− -- ^ The name to be captured.

59− --

60− -- Only for capture args it really denotes a path segment.

61− , _argType :: ftype

55+ , _argType :: f }

62− -- ^ Foreign type the associated value will have

63− }

64 deriving (Data, Eq, Show, Typeable)

56 deriving (Data, Eq, Show, Typeable)

65

57

66makeLenses ''Arg

58makeLenses ''Arg

67

59

68−argPath :: Getter (Arg ftype) Text

60+argPath :: Getter (Arg f) Text

69argPath = argName . _PathSegment

61argPath = argName . _PathSegment

70

62

71−data SegmentType ftype

63+data SegmentType f

72 = Static PathSegment

64 = Static PathSegment

73− -- ^ Static path segment.

65+ -- ^ 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)

66+ | Cap (Arg f)

79− -- ^ A capture.

67+ -- ^ 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)

68 deriving (Data, Eq, Show, Typeable)

85

69

86makePrisms ''SegmentType

70makePrisms ''SegmentType

87

71

88−-- | A part of the Url’s path.

89−newtype Segment ftype = Segment { unSegment :: SegmentType ftype }

72+newtype Segment f = Segment { unSegment :: SegmentType f }

90 deriving (Data, Eq, Show, Typeable)

73 deriving (Data, Eq, Show, Typeable)

91

74

92makePrisms ''Segment

75makePrisms ''Segment

93

76

94−-- | Whether a segment is a 'Cap'.

95−isCapture :: Segment ftype -> Bool

77+isCapture :: Segment f -> Bool

96isCapture (Segment (Cap _)) = True

78isCapture (Segment (Cap _)) = True

97isCapture _ = False

79isCapture _ = False

98

80

99−-- | Crashing Arg extraction from segment, TODO: remove

100−captureArg :: Segment ftype -> Arg ftype

81+captureArg :: Segment f -> Arg f

101captureArg (Segment (Cap s)) = s

82captureArg (Segment (Cap s)) = s

102captureArg _ = error "captureArg called on non capture"

83captureArg _ = error "captureArg called on non capture"

103

84

104−-- TODO: remove, unnecessary indirection

105−type Path ftype = [Segment ftype]

85+type Path f = [Segment f]

106

86

107−-- | Type of a 'QueryArg'.

108data ArgType

87data ArgType

109 = Normal

88 = Normal

110 | Flag

89 | Flag

@@ -113,41 +92,18 @@ data ArgType

113

92

114makePrisms ''ArgType

93makePrisms ''ArgType

115

94

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

95+data QueryArg f = QueryArg

133− { _queryArgName :: Arg ftype

96+ { _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

97 , _queryArgType :: ArgType

136− -- ^ one of normal/plain, list or flag

137 }

98 }

138 deriving (Data, Eq, Show, Typeable)

99 deriving (Data, Eq, Show, Typeable)

139

100

140makeLenses ''QueryArg

101makeLenses ''QueryArg

141

102

142−data HeaderArg ftype =

103+data HeaderArg f = HeaderArg

143− -- | The name of the header and the foreign type of its value.

144− HeaderArg

145− { _headerArg :: Arg ftype }

104+ { _headerArg :: Arg f }

146− -- | Unused, will never be set.

147− --

148− -- TODO: remove

149 | ReplaceHeaderArg

105 | ReplaceHeaderArg

150− { _headerArg :: Arg ftype

106+ { _headerArg :: Arg f

151 , _headerPattern :: Text

107 , _headerPattern :: Text

152 }

108 }

153 deriving (Data, Eq, Show, Typeable)

109 deriving (Data, Eq, Show, Typeable)

@@ -156,78 +112,31 @@ makeLenses ''HeaderArg

156

112

157makePrisms ''HeaderArg

113makePrisms ''HeaderArg

158

114

159−-- | Full endpoint url, with all captures and parameters

160−data Url ftype = Url

115+data Url f = Url

161− { _path :: Path ftype

116+ { _path :: Path f

162− -- ^ Url path, list of either static segments or captures

163− --

164− -- @"foo\/{id}\/bar"@

165− , _queryStr :: [QueryArg ftype]

117+ , _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 }

118 }

176 deriving (Data, Eq, Show, Typeable)

119 deriving (Data, Eq, Show, Typeable)

177

120

178−defUrl :: Url ftype

121+defUrl :: Url f

179−defUrl = Url [] [] Nothing

122+defUrl = Url [] []

180

123

181makeLenses ''Url

124makeLenses ''Url

182

125

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

126+data Req f = Req

193− { _reqUrl :: Url ftype

127+ { _reqUrl :: Url f

194− -- ^ Full list of URL segments, including captures

195− , _reqMethod :: HTTP.Method

128+ , _reqMethod :: HTTP.Method

196− -- ^ @\"GET\"@\/@\"POST\"@\/@\"PUT\"@\/…

197− , _reqHeaders :: [HeaderArg ftype]

129+ , _reqHeaders :: [HeaderArg f]

198− -- ^ Headers required by this endpoint, with their type

199− , _reqBody :: Maybe ftype

130+ , _reqBody :: Maybe f

200− -- ^ Foreign type of the expected request body ('ReqBody'), if any

201− , _reqReturnType :: Maybe ftype

131+ , _reqReturnType :: Maybe f

202− -- ^ The foreign type of the response, if any

203− , _reqFuncName :: FunctionName

132+ , _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 }

133 }

225 deriving (Data, Eq, Show, Typeable)

134 deriving (Data, Eq, Show, Typeable)

226

135

227makeLenses ''Req

136makeLenses ''Req

228

137

229defReq :: Req ftype

138defReq :: Req ftype

230−defReq = Req defUrl "GET" [] Nothing Nothing (FunctionName []) ReqBodyJSON

139+defReq = Req defUrl "GET" [] Nothing Nothing (FunctionName [])

231

140

232-- | 'HasForeignType' maps Haskell types with types in the target

141-- | 'HasForeignType' maps Haskell types with types in the target

233-- language of your backend. For example, let's say you're

142-- language of your backend. For example, let's say you're

@@ -244,7 +153,7 @@ defReq = Req defUrl "GET" [] Nothing Nothing (FunctionName []) ReqBodyJSON

244-- >

153-- >

245-- > -- Or for example in case of lists

154-- > -- Or for example in case of lists

246-- > instance HasForeignType LangX Text a => HasForeignType LangX Text [a] where

155-- > instance HasForeignType LangX Text a => HasForeignType LangX Text [a] where

247−-- > typeFor lang ftype _ = "listX of " <> typeFor lang ftype (Proxy :: Proxy a)

156+-- > typeFor lang type _ = "listX of " <> typeFor lang ftype (Proxy :: Proxy a)

248--

157--

249-- Finally to generate list of information about all the endpoints for

158-- Finally to generate list of information about all the endpoints for

250-- an API you create a function of a form:

159-- an API you create a function of a form:

@@ -264,16 +173,11 @@ defReq = Req defUrl "GET" [] Nothing Nothing (FunctionName []) ReqBodyJSON

264class HasForeignType lang ftype a where

173class HasForeignType lang ftype a where

265 typeFor :: Proxy lang -> Proxy ftype -> Proxy a -> ftype

174 typeFor :: Proxy lang -> Proxy ftype -> Proxy a -> ftype

266

175

267−-- | The language definition without any foreign types. It can be used for dynamic languages which do not /do/ type annotations.

268data NoTypes

176data NoTypes

269

177

270−-- | Use if the foreign language does not have any types.

271−instance HasForeignType NoTypes NoContent a where

178+instance HasForeignType NoTypes NoContent ftype where

272 typeFor _ _ _ = NoContent

179 typeFor _ _ _ = NoContent

273

180

274−-- | Implementation of the Servant framework types.

275−--

276−-- Relevant instances: Everything containing 'HasForeignType'.

277class HasForeign lang ftype (api :: *) where

181class HasForeign lang ftype (api :: *) where

278 type Foreign ftype api :: *

182 type Foreign ftype api :: *

279 foreignFor :: Proxy lang -> Proxy ftype -> Proxy api -> Req ftype -> Foreign ftype api

183 foreignFor :: Proxy lang -> Proxy ftype -> Proxy api -> Req ftype -> Foreign ftype api

@@ -336,19 +240,6 @@ instance (Elem JSON list, HasForeignType lang ftype a, ReflectMethod method)

336 method = reflectMethod (Proxy :: Proxy method)

240 method = reflectMethod (Proxy :: Proxy method)

337 methodLC = toLower $ decodeUtf8 method

241 methodLC = toLower $ decodeUtf8 method

338

242

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.

243-- | TODO: doesn't taking framing into account.

353instance (ct ~ JSON, HasForeignType lang ftype a, ReflectMethod method)

244instance (ct ~ JSON, HasForeignType lang ftype a, ReflectMethod method)

354 => HasForeign lang ftype (Stream method status framing ct a) where

245 => HasForeign lang ftype (Stream method status framing ct a) where

@@ -416,16 +307,6 @@ instance

416 { _argName = PathSegment str

307 { _argName = PathSegment str

417 , _argType = typeFor lang ftype (Proxy :: Proxy Bool) }

308 , _argType = typeFor lang ftype (Proxy :: Proxy Bool) }

418

309

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

310instance HasForeign lang ftype Raw where

430 type Foreign ftype Raw = HTTP.Method -> Req ftype

311 type Foreign ftype Raw = HTTP.Method -> Req ftype

431

312

@@ -441,14 +322,6 @@ instance (Elem JSON list, HasForeignType lang ftype a, HasForeign lang ftype api

441 foreignFor lang ftype (Proxy :: Proxy api) $

322 foreignFor lang ftype (Proxy :: Proxy api) $

442 req & reqBody .~ (Just $ typeFor lang ftype (Proxy :: Proxy a))

323 req & reqBody .~ (Just $ typeFor lang ftype (Proxy :: Proxy a))

443

324

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)

325instance (KnownSymbol path, HasForeign lang ftype api)

453 => HasForeign lang ftype (path :> api) where

326 => HasForeign lang ftype (path :> api) where

454 type Foreign ftype (path :> api) = Foreign ftype api

327 type Foreign ftype (path :> api) = Foreign ftype api

@@ -487,13 +360,6 @@ instance HasForeign lang ftype api =>

487

360

488 foreignFor lang ftype Proxy = foreignFor lang ftype (Proxy :: Proxy api)

361 foreignFor lang ftype Proxy = foreignFor lang ftype (Proxy :: Proxy api)

489

362

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

363instance HasForeign lang ftype api

498 => HasForeign lang ftype (HttpVersion :> api) where

364 => HasForeign lang ftype (HttpVersion :> api) where

499 type Foreign ftype (HttpVersion :> api) = Foreign ftype api

365 type Foreign ftype (HttpVersion :> api) = Foreign ftype api

servant-foreign/test/Servant/ForeignSpec.hs+4−12

@@ -11,11 +11,11 @@

11

11

12module Servant.ForeignSpec where

12module Servant.ForeignSpec where

13

13

14+import Data.Monoid

15+ ((<>))

14import Data.Proxy

16import Data.Proxy

17+import Servant.API.Internal.Test.ComprehensiveAPI

15import Servant.Foreign

18import Servant.Foreign

16−import Servant.Test.ComprehensiveAPI

17−import Servant.Types.SourceT

18− (SourceT)

19

19

20import Test.Hspec

20import Test.Hspec

21

21

@@ -51,9 +51,6 @@ instance HasForeignType LangX String (Headers ctyps NoContent) where

51instance HasForeignType LangX String Int where

51instance HasForeignType LangX String Int where

52 typeFor _ _ _ = "intX"

52 typeFor _ _ _ = "intX"

53

53

54−instance HasForeignType LangX String (SourceT m a) where

55− typeFor _ _ _ = "streamTX"

56−

57instance HasForeignType LangX String Bool where

54instance HasForeignType LangX String Bool where

58 typeFor _ _ _ = "boolX"

55 typeFor _ _ _ = "boolX"

59

56

@@ -89,7 +86,6 @@ listFromAPISpec = describe "listFromAPI" $ do

89 { _reqUrl = Url

86 { _reqUrl = Url

90 [ Segment $ Static "test" ]

87 [ Segment $ Static "test" ]

91 [ QueryArg (Arg "flag" "boolX") Flag ]

88 [ QueryArg (Arg "flag" "boolX") Flag ]

92− Nothing

93 , _reqMethod = "GET"

89 , _reqMethod = "GET"

94 , _reqHeaders = [HeaderArg $ Arg "header" "maybe listX of stringX"]

90 , _reqHeaders = [HeaderArg $ Arg "header" "maybe listX of stringX"]

95 , _reqBody = Nothing

91 , _reqBody = Nothing

@@ -102,7 +98,6 @@ listFromAPISpec = describe "listFromAPI" $ do

102 { _reqUrl = Url

98 { _reqUrl = Url

103 [ Segment $ Static "test" ]

99 [ Segment $ Static "test" ]

104 [ QueryArg (Arg "param" "maybe intX") Normal ]

100 [ QueryArg (Arg "param" "maybe intX") Normal ]

105− Nothing

106 , _reqMethod = "POST"

101 , _reqMethod = "POST"

107 , _reqHeaders = []

102 , _reqHeaders = []

108 , _reqBody = Just "listX of stringX"

103 , _reqBody = Just "listX of stringX"

@@ -114,9 +109,8 @@ listFromAPISpec = describe "listFromAPI" $ do

114 shouldBe putReq $ defReq

109 shouldBe putReq $ defReq

115 { _reqUrl = Url

110 { _reqUrl = Url

116 [ Segment $ Static "test" ]

111 [ Segment $ Static "test" ]

117− -- Should this be |intX| or |listX of intX| ?

112+ -- Shoud this be |intX| or |listX of intX| ?

118 [ QueryArg (Arg "params" "listX of intX") List ]

113 [ QueryArg (Arg "params" "listX of intX") List ]

119− Nothing

120 , _reqMethod = "PUT"

114 , _reqMethod = "PUT"

121 , _reqHeaders = []

115 , _reqHeaders = []

122 , _reqBody = Just "stringX"

116 , _reqBody = Just "stringX"

@@ -130,7 +124,6 @@ listFromAPISpec = describe "listFromAPI" $ do

130 [ Segment $ Static "test"

124 [ Segment $ Static "test"

131 , Segment $ Cap (Arg "id" "intX") ]

125 , Segment $ Cap (Arg "id" "intX") ]

132 []

126 []

133− Nothing

134 , _reqMethod = "DELETE"

127 , _reqMethod = "DELETE"

135 , _reqHeaders = []

128 , _reqHeaders = []

136 , _reqBody = Nothing

129 , _reqBody = Nothing

@@ -144,7 +137,6 @@ listFromAPISpec = describe "listFromAPI" $ do

144 [ Segment $ Static "test"

137 [ Segment $ Static "test"

145 , Segment $ Cap (Arg "ids" "listX of intX") ]

138 , Segment $ Cap (Arg "ids" "listX of intX") ]

146 []

139 []

147− Nothing

148 , _reqMethod = "GET"

140 , _reqMethod = "GET"

149 , _reqHeaders = []

141 , _reqHeaders = []

150 , _reqBody = Nothing

142 , _reqBody = Nothing

servant-foreign/tinc.yamlnew file+3

@@ -0,0 +1,3 @@

1+dependencies:

2+ - name: servant

3+ path: ../servant

servant-http-streams/CHANGELOG.mddeleted−98

@@ -1,98 +0,0 @@

1− [The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-http-streams/CHANGELOG.md)

2−[Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)

3−

4−0.18.4

5−------

6−

7−### Significant changes

8−

9−- *servant-client* / *servant-client-core* / *servant-http-streams*:

10− Fix erroneous behavior, where only 2XX status codes would be considered

11− successful, irrelevant of the status parameter specified by the verb

12− combinator. ([#1469](https://github.com/haskell-servant/servant/pull/1469))

13−

14−0.18.3

15−------

16−

17−### Other changes

18−

19−- Support GHC-9.0.1.

20−- Fix test suite running in CI.

21−- Bump `bytestring` and `hspec` dependencies.

22−

23−0.18.2

24−------

25−

26−### Significant changes

27−

28−- Support `servant-client-core` 0.18.2.

29−

30−0.18.1

31−------

32−

33−### Significant changes

34−

35−- Union verbs

36−

37−### Other changes

38−

39−- Bump "tested-with" ghc versions

40−

41−0.18

42−----

43−

44−### Significant changes

45−

46−- Support for ghc8.8 (#1318, #1326, #1327)

47−

48−

49−0.17

50−----

51−

52−### Significant changes

53−

54−- Add NoContentVerb [#1028](https://github.com/haskell-servant/servant/issues/1028) [#1219](https://github.com/haskell-servant/servant/pull/1219) [#1228](https://github.com/haskell-servant/servant/pull/1228)

55−

56− The `NoContent` API endpoints should now use `NoContentVerb` combinator.

57− The API type changes are usually of the kind

58−

59− ```diff

60− - :<|> PostNoContent '[JSON] NoContent

61− + :<|> PostNoContent

62− ```

63−

64− i.e. one doesn't need to specify the content-type anymore. There is no content.

65−

66−- `Capture` can be `Lenient` [#1155](https://github.com/haskell-servant/servant/issues/1155) [#1156](https://github.com/haskell-servant/servant/pull/1156)

67−

68− You can specify a lenient capture as

69−

70− ```haskell

71− :<|> "capture-lenient" :> Capture' '[Lenient] "foo" Int :> GET

72− ```

73−

74− which will make the capture always succeed. Handlers will be of the

75− type `Either String CapturedType`, where `Left err` represents

76− the possible parse failure.

77−

78−### Other changes

79−

80−- *servant-client* *servant-client-core* *servant-http-streams* Fix Verb with headers checking content type differently [#1200](https://github.com/haskell-servant/servant/issues/1200) [#1204](https://github.com/haskell-servant/servant/pull/1204)

81−

82− For `Verb`s with response `Headers`, the implementation didn't check

83− for the content-type of the response. Now it does.

84−

85−- *servant-client* *servant-http-streams* `HasClient` instance for `Stream` with `Headers` [#1170](https://github.com/haskell-servant/servant/issues/1170) [#1197](https://github.com/haskell-servant/servant/pull/1197)

86−- *servant-client* Redact the authorization header in Show and exceptions [#1238](https://github.com/haskell-servant/servant/pull/1238)

87−

88−

89−

90−0.16.0.1

91−--------

92−

93−- Allow `base-compat-0.11`

94−

95−0.16

96−----

97−

98−- Initial release

servant-http-streams/LICENSEdeleted−30

@@ -1,30 +0,0 @@

1−Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, 2016-2018 Servant Contributors

2−

3−All rights reserved.

4−

5−Redistribution and use in source and binary forms, with or without

6−modification, are permitted provided that the following conditions are met:

7−

8− * Redistributions of source code must retain the above copyright

9− notice, this list of conditions and the following disclaimer.

10−

11− * Redistributions in binary form must reproduce the above

12− copyright notice, this list of conditions and the following

13− disclaimer in the documentation and/or other materials provided

14− with the distribution.

15−

16− * Neither the name of Zalora South East Asia Pte Ltd nor the names of other

17− contributors may be used to endorse or promote products derived

18− from this software without specific prior written permission.

19−

20−THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS

21−"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT

22−LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR

23−A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT

24−OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,

25−SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT

26−LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,

27−DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY

28−THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT

29−(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE

30−OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

servant-http-streams/README.lhsdeleted−1

@@ -1 +0,0 @@

1−README.md

servant-http-streams/README.mddeleted−44

@@ -1,44 +0,0 @@

1−# servant-client

2−

3−

4−

5−This library lets you automatically derive Haskell functions that let you query each endpoint of a *servant* webservice.

6−

7−## Example

8−

9−``` haskell

10−{-# LANGUAGE DataKinds #-}

11−{-# LANGUAGE TypeOperators #-}

12−

13−import Data.Proxy

14−import Data.Text

15−import Servant.API

16−import Servant.HttpStreams

17−

18−

19−type Book = Text

20−

21−type MyApi = "books" :> Get '[JSON] [Book] -- GET /books

22− :<|> "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book -- POST /books

23−

24−myApi :: Proxy MyApi

25−myApi = Proxy

26−

27−-- 'client' allows you to produce operations to query an API from a client.

28−postNewBook :: Book -> ClientM Book

29−getAllBooks :: ClientM [Book]

30−(getAllBooks :<|> postNewBook) = client myApi

31−

32−-- the IOException happens already in withClientEnvIO

33−main' :: IO ()

34−main' = do

35− let burl = BaseUrl Http "localhost" 8081 ""

36− withClientEnvIO burl $ \env -> do

37− res <- runClientM getAllBooks env

38− case res of

39− Left err -> putStrLn $ "Error: " ++ show err

40− Right books -> print books

41−

42−main :: IO ()

43−main = return ()

44−```

servant-http-streams/Setup.hsdeleted−2

@@ -1,2 +0,0 @@

1−import Distribution.Simple

2−main = defaultMain

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

@@ -1,132 +0,0 @@

1−cabal-version: 2.2

2−name: servant-http-streams

3−version: 0.18.4

4−

5−synopsis: Automatic derivation of querying functions for servant

6−category: Servant, Web

7−description:

8− This library lets you derive automatically Haskell functions that

9− let you query each endpoint of a <http://hackage.haskell.org/package/servant servant> webservice.

10− .

11− See <http://docs.servant.dev/en/stable/tutorial/Client.html the client section of the tutorial>.

12− .

13− <https://github.com/haskell-servant/servant/blob/master/servant-client/CHANGELOG.md CHANGELOG>

14−

15−homepage: http://docs.servant.dev/

16−bug-reports: http://github.com/haskell-servant/servant/issues

17−license: BSD-3-Clause

18−license-file: LICENSE

19−author: Servant Contributors

20−maintainer: haskell-servant-maintainers@googlegroups.com

21−copyright: 2019 Servant Contributors

22−build-type: Simple

23−tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1

24−

25−extra-source-files:

26− CHANGELOG.md

27− README.md

28−

29−source-repository head

30− type: git

31− location: http://github.com/haskell-servant/servant.git

32−

33−library

34− exposed-modules:

35− Servant.HttpStreams

36− Servant.HttpStreams.Internal

37−

38− -- Bundled with GHC: Lower bound to not force re-installs

39− -- text and mtl are bundled starting with GHC-8.4

40− build-depends:

41− base >= 4.9 && < 4.18

42− , bytestring >= 0.10.8.1 && < 0.12

43− , containers >= 0.5.7.1 && < 0.7

44− , deepseq >= 1.4.2.0 && < 1.5

45− , mtl ^>= 2.2.2 || ^>= 2.3.1

46− , text >= 1.2.3.0 && < 2.1

47− , time >= 1.6.0.1 && < 1.13

48− , transformers >= 0.5.2.0 && < 0.7

49−

50− if !impl(ghc >= 8.2)

51− build-depends:

52− bifunctors >= 5.5.3 && < 5.6

53−

54− -- Servant dependencies.

55− -- Strict dependency on `servant-client-core` as we re-export things.

56− build-depends:

57− servant >= 0.18 && < 0.20

58− , servant-client-core >= 0.18.3 && <0.20

59−

60− -- Other dependencies: Lower bound around what is in the latest Stackage LTS.

61− -- Here can be exceptions if we really need features from the newer versions.

62− build-depends:

63− base-compat >= 0.10.5 && < 0.13

64− , case-insensitive

65− , http-streams >= 0.8.6.1 && < 0.9

66− , http-media >= 0.7.1.3 && < 0.9

67− , io-streams >= 1.5.0.1 && < 1.6

68− , http-types >= 0.12.2 && < 0.13

69− , http-common >= 0.8.2.0 && < 0.9

70− , exceptions >= 0.10.0 && < 0.11

71− , kan-extensions >= 5.2 && < 5.3

72− , monad-control >= 1.0.2.3 && < 1.1

73− , semigroupoids >= 5.3.1 && < 5.4

74− , transformers-base >= 0.4.5.2 && < 0.5

75− , transformers-compat >= 0.6.2 && < 0.8

76−

77− hs-source-dirs: src

78− default-language: Haskell2010

79− ghc-options: -Wall -Wno-redundant-constraints

80−

81−test-suite spec

82− type: exitcode-stdio-1.0

83− ghc-options: -Wall -rtsopts -threaded "-with-rtsopts=-T -N2"

84− default-language: Haskell2010

85− hs-source-dirs: test

86− main-is: Spec.hs

87− other-modules:

88− Servant.ClientSpec

89− Servant.StreamSpec

90−

91− -- Dependencies inherited from the library. No need to specify bounds.

92− build-depends:

93− base

94− , aeson

95− , base-compat

96− , bytestring

97− , http-api-data

98− , http-streams

99− , deepseq

100− , http-types

101− , mtl

102− , kan-extensions

103− , servant-http-streams

104− , servant-client-core

105− , stm

106− , text

107− , transformers

108− , transformers-compat

109− , wai

110− , warp

111−

112− -- Additional dependencies

113− build-depends:

114− entropy >= 0.4.1.3 && < 0.5

115− , hspec >= 2.6.0 && < 2.10

116− , HUnit >= 1.6.0.0 && < 1.7

117− , network >= 2.8.0.0 && < 3.2

118− , QuickCheck >= 2.12.6.1 && < 2.15

119− , servant == 0.19.*

120− , servant-server == 0.19.*

121− , tdigest >= 0.2 && < 0.3

122−

123− build-tool-depends:

124− hspec-discover:hspec-discover >= 2.6.0 && < 2.10

125−

126−test-suite readme

127− type: exitcode-stdio-1.0

128− main-is: README.lhs

129− build-depends: base, servant, http-streams, text, servant-http-streams, markdown-unlit

130− build-tool-depends: markdown-unlit:markdown-unlit

131− ghc-options: -pgmL markdown-unlit

132− default-language: Haskell2010

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

@@ -1,19 +0,0 @@

1−

2−

3−-- | This module provides 'client' which can automatically generate

4−-- querying functions for each endpoint just from the type representing your

5−-- API.

6−module Servant.HttpStreams

7− ( client

8− , ClientM

9− , withClientM

10− , runClientM

11− , ClientEnv(..)

12− , mkClientEnv

13− , withClientEnvIO

14− , hoistClient

15− , module Servant.Client.Core.Reexport

16− ) where

17−

18−import Servant.Client.Core.Reexport

19−import Servant.HttpStreams.Internal

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

@@ -1,258 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE DeriveDataTypeable #-}

3−{-# LANGUAGE DeriveGeneric #-}

4−{-# LANGUAGE FlexibleContexts #-}

5−{-# LANGUAGE FlexibleInstances #-}

6−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

7−{-# LANGUAGE MultiParamTypeClasses #-}

8−{-# LANGUAGE OverloadedStrings #-}

9−{-# LANGUAGE RankNTypes #-}

10−{-# LANGUAGE ScopedTypeVariables #-}

11−{-# LANGUAGE TypeFamilies #-}

12−module Servant.HttpStreams.Internal where

13−

14−import Prelude ()

15−import Prelude.Compat

16−

17−import Control.DeepSeq

18− (NFData, force)

19−import Control.Exception

20− (IOException, SomeException (..), catch, evaluate, throwIO)

21−import Control.Monad

22− (unless)

23−import Control.Monad.Base

24− (MonadBase (..))

25−import Control.Monad.Codensity

26− (Codensity (..))

27−import Control.Monad.Error.Class

28− (MonadError (..))

29−import Control.Monad.IO.Class

30− (MonadIO (..))

31−import Control.Monad.Reader

32− (MonadReader, ReaderT, ask, runReaderT)

33−import Control.Monad.Trans.Class

34− (lift)

35−import Control.Monad.Trans.Except

36− (ExceptT, runExceptT)

37−import Data.Bifunctor

38− (bimap, first)

39−import Data.ByteString.Builder

40− (toLazyByteString)

41−import qualified Data.ByteString.Builder as B

42−import qualified Data.ByteString.Lazy as BSL

43−import qualified Data.CaseInsensitive as CI

44−import Data.Foldable

45− (for_, toList)

46−import Data.Functor.Alt

47− (Alt (..))

48−import Data.Maybe

49− (maybeToList)

50−import Data.Proxy

51− (Proxy (..))

52−import Data.Sequence

53− (fromList)

54−import Data.String

55− (fromString)

56−import GHC.Generics

57−import Network.HTTP.Media

58− (renderHeader)

59−import Network.HTTP.Types

60− (Status (..), hContentType, http11, renderQuery, statusIsSuccessful)

61−import Servant.Client.Core

62−

63−import qualified Network.Http.Client as Client

64−import qualified Network.Http.Types as Client

65−import qualified Servant.Types.SourceT as S

66−import qualified System.IO.Streams as Streams

67−

68−-- | The environment in which a request is run.

69−--

70−-- 'ClientEnv' carries an open connection. See 'withClientEnvIO'.

71−--

72−data ClientEnv

73− = ClientEnv

74− { baseUrl :: BaseUrl

75− , connection :: Client.Connection

76− }

77−

78−-- | 'ClientEnv' smart constructor.

79−mkClientEnv :: BaseUrl -> Client.Connection -> ClientEnv

80−mkClientEnv = ClientEnv

81−

82−-- | Open a connection to 'BaseUrl'.

83−withClientEnvIO :: BaseUrl -> (ClientEnv -> IO r) -> IO r

84−withClientEnvIO burl k = Client.withConnection open $ \conn ->

85− k (mkClientEnv burl conn)

86− where

87− open = Client.openConnection (fromString $ baseUrlHost burl) (fromIntegral $ baseUrlPort burl)

88−

89−-- | Generates a set of client functions for an API.

90−--

91−-- Example:

92−--

93−-- > type API = Capture "no" Int :> Get '[JSON] Int

94−-- > :<|> Get '[JSON] [Bool]

95−-- >

96−-- > api :: Proxy API

97−-- > api = Proxy

98−-- >

99−-- > getInt :: Int -> ClientM Int

100−-- > getBools :: ClientM [Bool]

101−-- > getInt :<|> getBools = client api

102−client :: HasClient ClientM api => Proxy api -> Client ClientM api

103−client api = api `clientIn` (Proxy :: Proxy ClientM)

104−

105−-- | Change the monad the client functions live in, by

106−-- supplying a conversion function

107−-- (a natural transformation to be precise).

108−--

109−-- For example, assuming you have some @manager :: 'Manager'@ and

110−-- @baseurl :: 'BaseUrl'@ around:

111−--

112−-- > type API = Get '[JSON] Int :<|> Capture "n" Int :> Post '[JSON] Int

113−-- > api :: Proxy API

114−-- > api = Proxy

115−-- > getInt :: IO Int

116−-- > postInt :: Int -> IO Int

117−-- > getInt :<|> postInt = hoistClient api (flip runClientM cenv) (client api)

118−-- > where cenv = mkClientEnv manager baseurl

119−hoistClient

120− :: HasClient ClientM api

121− => Proxy api

122− -> (forall a. m a -> n a)

123− -> Client m api

124− -> Client n api

125−hoistClient = hoistClientMonad (Proxy :: Proxy ClientM)

126−

127−-- | @ClientM@ is the monad in which client functions run. Contains the

128−-- 'Client.Manager' and 'BaseUrl' used for requests in the reader environment.

129−newtype ClientM a = ClientM

130− { unClientM :: ReaderT ClientEnv (ExceptT ClientError (Codensity IO)) a }

131− deriving ( Functor, Applicative, Monad, MonadIO, Generic

132− , MonadReader ClientEnv, MonadError ClientError)

133−

134−instance MonadBase IO ClientM where

135− liftBase = ClientM . liftIO

136−

137−-- | Try clients in order, last error is preserved.

138−instance Alt ClientM where

139− a <!> b = a `catchError` \_ -> b

140−

141−instance RunClient ClientM where

142− runRequestAcceptStatus = performRequest

143− throwClientError = throwError

144−

145−instance RunStreamingClient ClientM where

146− withStreamingRequest = performWithStreamingRequest

147−

148−runClientM :: NFData a => ClientM a -> ClientEnv -> IO (Either ClientError a)

149−runClientM cm env = withClientM cm env (evaluate . force)

150−

151−withClientM :: ClientM a -> ClientEnv -> (Either ClientError a -> IO b) -> IO b

152−withClientM cm env k =

153− let Codensity f = runExceptT $ flip runReaderT env $ unClientM cm

154− in f k

155−

156−performRequest :: Maybe [Status] -> Request -> ClientM Response

157−performRequest acceptStatus req = do

158− ClientEnv burl conn <- ask

159− let (req', body) = requestToClientRequest burl req

160− x <- ClientM $ lift $ lift $ Codensity $ \k -> do

161− Client.sendRequest conn req' body

162− Client.receiveResponse conn $ \res' body' -> do

163− let status = toEnum $ Client.getStatusCode res'

164− lbs <- BSL.fromChunks <$> Streams.toList body'

165− let res'' = clientResponseToResponse res' lbs

166− goodStatus = case acceptStatus of

167− Nothing -> statusIsSuccessful status

168− Just good -> status `elem` good

169− if goodStatus

170− then k (Right res'')

171− else k (Left (mkFailureResponse burl req res''))

172−

173− either throwError pure x

174−

175−performWithStreamingRequest :: Request -> (StreamingResponse -> IO a) -> ClientM a

176−performWithStreamingRequest req k = do

177− ClientEnv burl conn <- ask

178− let (req', body) = requestToClientRequest burl req

179− ClientM $ lift $ lift $ Codensity $ \k1 -> do

180− Client.sendRequest conn req' body

181− Client.receiveResponseRaw conn $ \res' body' -> do

182− -- check status code

183− let status = toEnum $ Client.getStatusCode res'

184− unless (statusIsSuccessful status) $ do

185− lbs <- BSL.fromChunks <$> Streams.toList body'

186− throwIO $ mkFailureResponse burl req (clientResponseToResponse res' lbs)

187−

188− x <- k (clientResponseToResponse res' (fromInputStream body'))

189− k1 x

190−

191−mkFailureResponse :: BaseUrl -> Request -> ResponseF BSL.ByteString -> ClientError

192−mkFailureResponse burl request =

193− FailureResponse (bimap (const ()) f request)

194− where

195− f b = (burl, BSL.toStrict $ toLazyByteString b)

196−

197−clientResponseToResponse :: Client.Response -> body -> ResponseF body

198−clientResponseToResponse r body = Response

199− { responseStatusCode = Status (Client.getStatusCode r) (Client.getStatusMessage r)

200− , responseBody = body

201− , responseHeaders = fromList $ map (first CI.mk) $ Client.retrieveHeaders $ Client.getHeaders r

202− , responseHttpVersion = http11 -- guess

203− }

204−

205−requestToClientRequest :: BaseUrl -> Request -> (Client.Request, Streams.OutputStream B.Builder -> IO ())

206−requestToClientRequest burl r = (request, body)

207− where

208− request = Client.buildRequest1 $ do

209− Client.http (Client.Method $ requestMethod r)

210− $ fromString (baseUrlPath burl)

211− <> BSL.toStrict (toLazyByteString (requestPath r))

212− <> renderQuery True (toList (requestQueryString r))

213− -- We are connected, but we still need to know what we try to query

214− Client.setHostname (fromString $ baseUrlHost burl) (fromIntegral $ baseUrlPort burl)

215− for_ (maybeToList acceptHdr ++ maybeToList contentTypeHdr ++ headers) $ \(hn, hv) ->

216− Client.setHeader (CI.original hn) hv

217−

218− -- body is always chunked

219− Client.setTransferEncoding

220−

221− -- Content-Type and Accept are specified by requestBody and requestAccept

222− headers = filter (\(h, _) -> h /= "Accept" && h /= "Content-Type") $

223− toList $ requestHeaders r

224−

225− acceptHdr

226− | null hs = Nothing

227− | otherwise = Just ("Accept", renderHeader hs)

228− where

229− hs = toList $ requestAccept r

230−

231− convertBody bd os = case bd of

232− RequestBodyLBS body' ->

233− Streams.writeTo os (Just (B.lazyByteString body'))

234− RequestBodyBS body' ->

235− Streams.writeTo os (Just (B.byteString body'))

236− RequestBodySource sourceIO ->

237− toOutputStream sourceIO os

238−

239− (body, contentTypeHdr) = case requestBody r of

240− Nothing -> (Client.emptyBody, Nothing)

241− Just (body', typ) -> (convertBody body', Just (hContentType, renderHeader typ))

242−

243−catchConnectionError :: IO a -> IO (Either ClientError a)

244−catchConnectionError action =

245− catch (Right <$> action) $ \e ->

246− pure . Left . ConnectionError $ SomeException (e :: IOException)

247−

248−fromInputStream :: Streams.InputStream b -> S.SourceT IO b

249−fromInputStream is = S.SourceT $ \k -> k loop where

250− loop = S.Effect $ maybe S.Stop (flip S.Yield loop) <$> Streams.read is

251−

252−toOutputStream :: S.SourceT IO BSL.ByteString -> Streams.OutputStream B.Builder -> IO ()

253−toOutputStream (S.SourceT k) os = k loop where

254− loop S.Stop = return ()

255− loop (S.Error err) = fail err

256− loop (S.Skip s) = loop s

257− loop (S.Effect mx) = mx >>= loop

258− loop (S.Yield x s) = Streams.write (Just (B.lazyByteString x)) os >> loop s

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

@@ -1,110 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE ConstraintKinds #-}

3−{-# LANGUAGE DataKinds #-}

4−{-# LANGUAGE DeriveGeneric #-}

5−{-# LANGUAGE FlexibleContexts #-}

6−{-# LANGUAGE FlexibleInstances #-}

7−{-# LANGUAGE FunctionalDependencies #-}

8−{-# LANGUAGE GADTs #-}

9−{-# LANGUAGE MultiParamTypeClasses #-}

10−{-# LANGUAGE OverloadedStrings #-}

11−{-# LANGUAGE PolyKinds #-}

12−{-# LANGUAGE RecordWildCards #-}

13−{-# LANGUAGE ScopedTypeVariables #-}

14−{-# LANGUAGE StandaloneDeriving #-}

15−{-# LANGUAGE TypeFamilies #-}

16−{-# LANGUAGE TypeOperators #-}

17−{-# LANGUAGE UndecidableInstances #-}

18−{-# OPTIONS_GHC -freduction-depth=100 #-}

19−{-# OPTIONS_GHC -fno-warn-orphans #-}

20−{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

21−

22−module Servant.StreamSpec (spec) where

23−

24−import Control.Monad.Trans.Except

25−import qualified Data.ByteString as BS

26−import Data.Proxy

27−import Prelude ()

28−import Prelude.Compat

29−import Servant.API

30− ((:<|>) ((:<|>)), (:>), JSON, NetstringFraming,

31− NewlineFraming, NoFraming, OctetStream, SourceIO, StreamBody,

32− StreamGet)

33−import Servant.ClientSpec

34− (Person (..))

35−import qualified Servant.ClientSpec as CS

36−import Servant.HttpStreams

37−import Servant.Server

38−import Servant.Types.SourceT

39−import System.Entropy

40− (getEntropy, getHardwareEntropy)

41−import Test.Hspec

42−

43−

44−spec :: Spec

45−spec = describe "Servant.HttpStreams streaming" $ do

46− streamSpec

47−

48−type StreamApi =

49− "streamGetNewline" :> StreamGet NewlineFraming JSON (SourceIO Person)

50− :<|> "streamGetNetstring" :> StreamGet NetstringFraming JSON (SourceIO Person)

51− :<|> "streamALot" :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString)

52− :<|> "streamBody" :> StreamBody NoFraming OctetStream (SourceIO BS.ByteString) :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString)

53−

54−api :: Proxy StreamApi

55−api = Proxy

56−

57−getGetNL, getGetNS :: ClientM (SourceIO Person)

58−_getGetALot :: ClientM (SourceIO BS.ByteString)

59−getStreamBody :: SourceT IO BS.ByteString -> ClientM (SourceIO BS.ByteString)

60−getGetNL :<|> getGetNS :<|> _getGetALot :<|> getStreamBody = client api

61−

62−alice :: Person

63−alice = Person "Alice" 42

64−

65−bob :: Person

66−bob = Person "Bob" 25

67−

68−server :: Application

69−server = serve api

70− $ return (source [alice, bob, alice])

71− :<|> return (source [alice, bob, alice])

72− -- 2 ^ (18 + 10) = 256M

73− :<|> return (SourceT ($ lots (powerOfTwo 18)))

74− :<|> return

75− where

76− lots n

77− | n < 0 = Stop

78− | otherwise = Effect $ do

79− let size = powerOfTwo 10

80− mbs <- getHardwareEntropy size

81− bs <- maybe (getEntropy size) pure mbs

82− return (Yield bs (lots (n - 1)))

83−

84−powerOfTwo :: Int -> Int

85−powerOfTwo = (2 ^)

86−

87−withClient :: ClientM a -> BaseUrl -> (Either ClientError a -> IO r) -> IO r

88−withClient x burl k = do

89− withClientEnvIO burl $ \env -> withClientM x env k

90−

91−testRunSourceIO :: SourceIO a

92− -> IO (Either String [a])

93−testRunSourceIO = runExceptT . runSourceT

94−

95−streamSpec :: Spec

96−streamSpec = beforeAll (CS.startWaiApp server) $ afterAll CS.endWaiApp $ do

97− it "works with Servant.API.StreamGet.Newline" $ \(_, baseUrl) -> do

98− withClient getGetNL baseUrl $ \(Right res) ->

99− testRunSourceIO res `shouldReturn` Right [alice, bob, alice]

100−

101− it "works with Servant.API.StreamGet.Netstring" $ \(_, baseUrl) -> do

102− withClient getGetNS baseUrl $ \(Right res) ->

103− testRunSourceIO res `shouldReturn` Right [alice, bob, alice]

104−

105− it "works with Servant.API.StreamBody" $ \(_, baseUrl) -> do

106− withClient (getStreamBody (source input)) baseUrl $ \(Right res) ->

107− testRunSourceIO res `shouldReturn` Right output

108− where

109− input = ["foo", "", "bar"]

110− output = ["foo", "bar"]

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

@@ -1 +0,0 @@

1−{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

servant-machines/CHANGELOG.mddeleted−4

@@ -1,4 +0,0 @@

1−0.15

2−----

3−

4−- First release with support for `servant-0.15` `Stream` refactoring.

servant-machines/LICENSEdeleted−30

@@ -1,30 +0,0 @@

1−Copyright (c) 2018, Servant Contributors

2−

3−All rights reserved.

4−

5−Redistribution and use in source and binary forms, with or without

6−modification, are permitted provided that the following conditions are met:

7−

8− * Redistributions of source code must retain the above copyright

9− notice, this list of conditions and the following disclaimer.

10−

11− * Redistributions in binary form must reproduce the above

12− copyright notice, this list of conditions and the following

13− disclaimer in the documentation and/or other materials provided

14− with the distribution.

15−

16− * Neither the name of Servant Contributors nor the names of other

17− contributors may be used to endorse or promote products derived

18− from this software without specific prior written permission.

19−

20−THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS

21−"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT

22−LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR

23−A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT

24−OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,

25−SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT

26−LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,

27−DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY

28−THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT

29−(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE

30−OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

servant-machines/README.mddeleted−3

@@ -1,3 +0,0 @@

1−# servant-machines - Servant Stream support for machines

2−

3−

servant-machines/Setup.hsdeleted−2

@@ -1,2 +0,0 @@

1−import Distribution.Simple

2−main = defaultMain

servant-machines/example/Main.hsdeleted−98

@@ -1,98 +0,0 @@

1−{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE DeriveGeneric #-}

3−{-# LANGUAGE TypeOperators #-}

4−module Main (main) where

5−

6−import Prelude ()

7−import Prelude.Compat

8−

9−import Control.Concurrent

10− (threadDelay)

11−import Control.Monad.IO.Class

12− (MonadIO (..))

13−import qualified Data.ByteString as BS

14−import Data.Maybe

15− (fromMaybe)

16−import Data.Void

17− (Void)

18−import Network.HTTP.Client

19− (defaultManagerSettings, newManager)

20−import Network.Wai

21− (Application)

22−import System.Environment

23− (getArgs, lookupEnv)

24−import Text.Read

25− (readMaybe)

26−

27−import Data.Machine

28−import Servant

29−import Servant.Client.Streaming

30−import Servant.Machines ()

31−

32−import qualified Network.Wai.Handler.Warp as Warp

33−

34−type FastAPI = "get" :> Capture "num" Int :> StreamGet NewlineFraming JSON (MachineT IO (Is Void) Int)

35−

36−type API = FastAPI

37− :<|> "slow" :> Capture "num" Int :> StreamGet NewlineFraming JSON (MachineT IO (Is Void) Int)

38− :<|> "proxy"

39− :> StreamBody NoFraming OctetStream (MachineT IO (Is Void) BS.ByteString)

40− :> StreamPost NoFraming OctetStream (MachineT IO (Is Void) BS.ByteString)

41−

42−api :: Proxy API

43−api = Proxy

44−

45−server :: Server API

46−server = fast :<|> slow :<|> proxy

47− where

48− fast n = liftIO $ do

49− putStrLn ("/get/" ++ show n)

50− return $ fastMachine n

51−

52− slow n = liftIO $ do

53− putStrLn ("/slow/" ++ show n)

54− return $ slowMachine n

55−

56− proxy c = liftIO $ do

57− putStrLn "/proxy"

58− return c

59−

60− -- for some reason unfold leaks?

61− fastMachine m

62− | m < 0 = MachineT (return Stop)

63− | otherwise = MachineT (return (Yield m (fastMachine (m - 1))))

64−

65− slowMachine m

66− | m < 0 = MachineT (return Stop)

67− | otherwise = MachineT $ do

68− threadDelay 1000000

69− return (Yield m (slowMachine (m - 1)))

70−

71−app :: Application

72−app = serve api server

73−

74−cli :: Client ClientM FastAPI

75−cli :<|> _ = client api

76−

77−main :: IO ()

78−main = do

79− args <- getArgs

80− case args of

81− ("server":_) -> do

82− putStrLn "Starting servant-machines:example at http://localhost:8000"

83− port <- fromMaybe 8000 . (>>= readMaybe) <$> lookupEnv "PORT"

84− Warp.run port app

85− ("client":ns:_) -> do

86− n <- maybe (fail $ "not a number: " ++ ns) pure $ readMaybe ns

87− mgr <- newManager defaultManagerSettings

88− burl <- parseBaseUrl "http://localhost:8000/"

89− withClientM (cli n) (mkClientEnv mgr burl) $ \me -> case me of

90− Left err -> print err

91− Right m -> do

92− x <- runT $ fold (\p _ -> p + 1) (0 :: Int) <~ m

93− print x

94− _ -> do

95− putStrLn "Try:"

96− putStrLn "cabal new-run servant-machines:example server"

97− putStrLn "cabal new-run servant-machines:example client 10"

98− putStrLn "time curl -H 'Accept: application/json' localhost:8000/slow/5"

servant-machines/servant-machines.cabaldeleted−59

@@ -1,59 +0,0 @@

1−cabal-version: 2.2

2−name: servant-machines

3−version: 0.15.1

4−

5−synopsis: Servant Stream support for machines

6−category: Servant, Web, Enumerator

7−description: Servant Stream support for machines.

8− .

9− Provides 'ToSourceIO' and 'FromSourceIO' instances for 'MachineT'.

10−

11−homepage: http://docs.servant.dev/

12−bug-reports: http://github.com/haskell-servant/servant/issues

13−license: BSD-3-Clause

14−license-file: LICENSE

15−author: Servant Contributors

16−maintainer: haskell-servant-maintainers@googlegroups.com

17−copyright: 2018-2019 Servant Contributors

18−build-type: Simple

19−tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2

20−

21−extra-source-files:

22− CHANGELOG.md

23−

24−source-repository head

25− type: git

26− location: http://github.com/haskell-servant/servant.git

27−

28−library

29− exposed-modules: Servant.Machines

30− build-depends:

31− base >=4.9 && <5

32− , bytestring >=0.10.8.1 && <0.12

33− , machines >=0.6.4 && <0.8

34− , mtl ^>=2.2.2 || ^>=2.3.1

35− , servant >=0.15 && <0.20

36− hs-source-dirs: src

37− default-language: Haskell2010

38− ghc-options: -Wall

39−

40−test-suite example

41− type: exitcode-stdio-1.0

42− main-is: Main.hs

43− hs-source-dirs:

44− example

45− ghc-options: -Wall -rtsopts -threaded

46− build-depends:

47− base

48− , base-compat

49− , bytestring

50− , http-media

51− , servant

52− , machines

53− , servant-machines

54− , servant-server >=0.15 && <0.20

55− , servant-client >=0.15 && <0.20

56− , wai >=3.2.1.2 && <3.3

57− , warp >=3.2.25 && <3.4

58− , http-client

59− default-language: Haskell2010

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

@@ -1,46 +0,0 @@

1−{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE FlexibleInstances #-}

3−{-# LANGUAGE GADTs #-}

4−{-# LANGUAGE MultiParamTypeClasses #-}

5−{-# LANGUAGE ScopedTypeVariables #-}

6−{-# LANGUAGE UndecidableInstances #-}

7−{-# OPTIONS_GHC -Wno-orphans #-}

8−-- | This module exports 'ToSourceIO' and 'FromSourceIO' for 'MachineT' instances.

9−module Servant.Machines (

10− MachineToSourceIO (..),

11− ) where

12−

13−import Control.Monad.IO.Class

14− (MonadIO (..))

15−import Data.Machine

16− (MachineT (..), Step (..))

17−import Servant.API.Stream

18−import qualified Servant.Types.SourceT as S

19−

20−-- | Helper class to implement @'ToSourceIO' 'MachineT'@ instance

21−-- for various monads.

22−class MachineToSourceIO m where

23− machineToSourceIO :: MachineT m k o -> S.SourceT IO o

24−

25−instance MachineToSourceIO IO where

26− machineToSourceIO ma = S.SourceT ($ go ma) where

27− go (MachineT m) = S.Effect $ do

28− step <- m

29− case step of

30− Stop -> return S.Stop

31− Yield x m' -> return (S.Yield x (go m'))

32− Await _ _ m' -> return (S.Skip (go m'))

33−

34−instance MachineToSourceIO m => ToSourceIO o (MachineT m k o) where

35− toSourceIO = machineToSourceIO

36−

37−instance MonadIO m => FromSourceIO o (MachineT m k o) where

38− fromSourceIO src = MachineT $ liftIO $ S.unSourceT src go

39− where

40− go :: S.StepT IO o -> IO (Step k o (MachineT m k o))

41− go S.Stop = return Stop

42− go (S.Error err) = fail err

43− go (S.Skip s) = go s

44− go (S.Effect ms) = ms >>= go

45− go (S.Yield x s) = return (Yield x (MachineT (liftIO (go s))))

46− {-# SPECIALIZE INLINE fromSourceIO :: SourceIO o -> MachineT IO k o #-}

servant-pipes/CHANGELOG.mddeleted−22

@@ -1,22 +0,0 @@

1−0.15.3

2−------

3−

4−### Other changes

5−

6−- Support GHC-9.0.1.

7−- Bump `bytestring` dependency.

8−

9−0.15.2

10−------

11−

12−0.15.1

13−------

14−

15−- `FromSourceIO Proxy` (`ListT`) instance `fail`s in `IO`, not in `m`.

16− This works around `MonadFail` proposal, and makes `servant-pipes`

17− behave like `servant-conduit` and `servant-machines`.

18−

19−0.15

20−----

21−

22−- First release with support for `servant-0.15` `Stream` refactoring.

servant-pipes/LICENSEdeleted−30

@@ -1,30 +0,0 @@

1−Copyright (c) 2018, Servant Contributors

2−

3−All rights reserved.

4−

5−Redistribution and use in source and binary forms, with or without

6−modification, are permitted provided that the following conditions are met:

7−

8− * Redistributions of source code must retain the above copyright

9− notice, this list of conditions and the following disclaimer.

10−

11− * Redistributions in binary form must reproduce the above

12− copyright notice, this list of conditions and the following

13− disclaimer in the documentation and/or other materials provided

14− with the distribution.

15−

16− * Neither the name of Servant Contributors nor the names of other

17− contributors may be used to endorse or promote products derived

18− from this software without specific prior written permission.

19−

20−THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS

21−"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT

22−LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR

23−A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT

24−OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,

25−SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT

26−LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,

27−DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY

28−THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT

29−(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE

30−OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

servant-pipes/README.mddeleted−3

@@ -1,3 +0,0 @@

1−# servant-pipes - Servant Stream support for pipes

2−

3−

servant-pipes/Setup.hsdeleted−2

@@ -1,2 +0,0 @@

1−import Distribution.Simple

2−main = defaultMain

servant-pipes/example/Main.hsdeleted−107

@@ -1,107 +0,0 @@

1−{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE DeriveGeneric #-}

3−{-# LANGUAGE TypeOperators #-}

4−module Main (main) where

5−

6−import Prelude ()

7−import Prelude.Compat

8−

9−import Control.Concurrent

10− (threadDelay)

11−import Control.Monad.IO.Class

12− (MonadIO (..))

13−import qualified Data.ByteString as BS

14−import Data.Maybe

15− (fromMaybe)

16−import Network.HTTP.Client

17− (defaultManagerSettings, newManager)

18−import Network.Wai

19− (Application)

20−import System.Environment

21− (getArgs, lookupEnv)

22−import System.IO

23− (IOMode (..))

24−import Text.Read

25− (readMaybe)

26−

27−import qualified Pipes as P

28−import Pipes.ByteString as PBS

29−import qualified Pipes.Prelude as P

30−import Pipes.Safe

31− (SafeT)

32−import qualified Pipes.Safe.Prelude as P

33−import Servant

34−import Servant.Client.Streaming

35−import Servant.Pipes ()

36−

37−import qualified Network.Wai.Handler.Warp as Warp

38−

39−type FastAPI = "get" :> Capture "num" Int :> StreamGet NewlineFraming JSON (P.Producer Int IO ())

40−

41−-- TODO: Change IO to something with MonadError ServantUnrenderError

42−type API = FastAPI

43− :<|> "slow" :> Capture "num" Int :> StreamGet NewlineFraming JSON (P.Producer Int IO ())

44− -- monad can be SafeT IO too.

45− :<|> "readme" :> StreamGet NoFraming OctetStream (P.Producer BS.ByteString (SafeT IO) ())

46− -- we can have streaming request body

47− :<|> "proxy"

48− :> StreamBody NoFraming OctetStream (P.Producer BS.ByteString IO ())

49− :> StreamPost NoFraming OctetStream (P.Producer BS.ByteString IO ())

50−

51−api :: Proxy API

52−api = Proxy

53−

54−server :: Server API

55−server = fast :<|> slow :<|> readme :<|> proxy

56− where

57− fast n = liftIO $ do

58− putStrLn ("/get/" ++ show n)

59− return $ fastPipe n

60−

61− slow n = liftIO $ do

62− putStrLn ("/slow/" ++ show n)

63− return $ slowPipe n

64−

65− readme = liftIO $ do

66− putStrLn "/readme"

67− return $ P.withFile "README.md" ReadMode $ \h -> PBS.fromHandle h

68−

69− proxy c = liftIO $ do

70− putStrLn "/proxy"

71− return c

72−

73− -- for some reason unfold leaks?

74− fastPipe m

75− | m < 0 = return ()

76− | otherwise = P.yield m >> fastPipe (m - 1)

77−

78− slowPipe m = fastPipe m P.>-> P.mapM (<$ threadDelay 1000000)

79−

80−app :: Application

81−app = serve api server

82−

83−cli :: Client ClientM FastAPI

84−cli :<|> _ :<|> _ :<|> _ = client api

85−

86−main :: IO ()

87−main = do

88− args <- getArgs

89− case args of

90− ("server":_) -> do

91− putStrLn "Starting servant-pipes:example at http://localhost:8000"

92− port <- fromMaybe 8000 . (>>= readMaybe) <$> lookupEnv "PORT"

93− Warp.run port app

94− ("client":ns:_) -> do

95− n <- maybe (fail $ "not a number: " ++ ns) pure $ readMaybe ns

96− mgr <- newManager defaultManagerSettings

97− burl <- parseBaseUrl "http://localhost:8000/"

98− withClientM (cli n) (mkClientEnv mgr burl) $ \me -> case me of

99− Left err -> print err

100− Right p -> do

101− x <- P.fold (\c _ -> c + 1) (0 :: Int) id p

102− print x

103− _ -> do

104− putStrLn "Try:"

105− putStrLn "cabal new-run servant-pipes:example server"

106− putStrLn "cabal new-run servant-pipes:example client 10"

107− putStrLn "time curl -H 'Accept: application/json' localhost:8000/slow/5"

servant-pipes/servant-pipes.cabaldeleted−63

@@ -1,63 +0,0 @@

1−cabal-version: 2.2

2−name: servant-pipes

3−version: 0.15.3

4−

5−synopsis: Servant Stream support for pipes

6−category: Servant, Web, Pipes

7−description: Servant Stream support for pipes.

8− .

9− Provides 'ToSourceIO' and 'FromSourceIO' instances for 'Proxy' and 'SafeT'.

10−

11−homepage: http://docs.servant.dev/

12−bug-reports: http://github.com/haskell-servant/servant/issues

13−license: BSD-3-Clause

14−license-file: LICENSE

15−author: Servant Contributors

16−maintainer: haskell-servant-maintainers@googlegroups.com

17−copyright: 2018-2019 Servant Contributors

18−build-type: Simple

19−tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2

20−

21−extra-source-files:

22− CHANGELOG.md

23−

24−source-repository head

25− type: git

26− location: http://github.com/haskell-servant/servant.git

27−

28−library

29− exposed-modules: Servant.Pipes

30− build-depends:

31− base >=4.9 && <5

32− , bytestring >=0.10.8.1 && <0.12

33− , pipes >=4.3.9 && <4.4

34− , pipes-safe >=2.3.1 && <2.4

35− , mtl ^>=2.2.2 || ^>=2.3.1

36− , monad-control >=1.0.2.3 && <1.1

37− , servant >=0.15 && <0.20

38− hs-source-dirs: src

39− default-language: Haskell2010

40− ghc-options: -Wall

41−

42−test-suite example

43− type: exitcode-stdio-1.0

44− main-is: Main.hs

45− hs-source-dirs:

46− example

47− ghc-options: -Wall -rtsopts -threaded

48− build-depends:

49− base

50− , base-compat

51− , bytestring

52− , http-media

53− , servant

54− , pipes

55− , pipes-safe

56− , servant-pipes

57− , pipes-bytestring >=2.1.6 && <2.2

58− , servant-server >=0.15 && <0.20

59− , servant-client >=0.15 && <0.20

60− , wai >=3.2.1.2 && <3.3

61− , warp >=3.2.25 && <3.4

62− , http-client

63− default-language: Haskell2010

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

@@ -1,75 +0,0 @@

1−{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE FlexibleInstances #-}

3−{-# LANGUAGE GADTs #-}

4−{-# LANGUAGE MultiParamTypeClasses #-}

5−{-# LANGUAGE RankNTypes #-}

6−{-# LANGUAGE ScopedTypeVariables #-}

7−{-# LANGUAGE UndecidableInstances #-}

8−{-# OPTIONS_GHC -Wno-orphans #-}

9−-- | This module exports 'ToSourceIO' and 'FromSourceIO' for 'Proxy' and 'SafeT' instances.

10−module Servant.Pipes (

11− PipesToSourceIO (..),

12− ) where

13−

14−import Control.Monad.IO.Class

15− (MonadIO (..))

16−import Control.Monad.Trans.Control

17− (liftBaseWith)

18−import Pipes

19− (ListT (..))

20−import Pipes.Internal

21− (Proxy (..), X, closed)

22−import Pipes.Safe

23− (SafeT, runSafeT)

24−import Servant.API.Stream

25−import qualified Servant.Types.SourceT as S

26−

27−-- | Helper class to implement @'ToSourceIO' 'Proxy'@ instance

28−-- for various monads.

29−class PipesToSourceIO m where

30− pipesToSourceIO :: Proxy X () () b m () -> SourceIO b

31−

32−instance PipesToSourceIO IO where

33− pipesToSourceIO ma = S.SourceT ($ go ma) where

34− go :: Proxy X () () b IO () -> S.StepT IO b

35− go (Pure ()) = S.Stop

36− go (M p) = S.Effect (fmap go p)

37− go (Request v _) = closed v

38− go (Respond b n) = S.Yield b (go (n ()))

39−

40−instance m ~ IO => PipesToSourceIO (SafeT m) where

41− pipesToSourceIO ma =

42− S.SourceT $ \k ->

43− runSafeT $ liftBaseWith $ \runSafe ->

44− k (go runSafe ma)

45− where

46− go :: (forall x. SafeT m x -> m x)

47− -> Proxy X () () b (SafeT m) ()

48− -> S.StepT IO b

49− go _ (Pure ()) = S.Stop

50− go runSafe (M p) = S.Effect $ runSafe $ fmap (go runSafe) p

51− go _ (Request v _) = closed v

52− go runSafe (Respond b n) = S.Yield b (go runSafe (n ()))

53−

54−instance (PipesToSourceIO m, a' ~ X, a ~ (), b' ~ (), r ~ ())

55− => ToSourceIO b (Proxy a' a b' b m r)

56− where

57− toSourceIO = pipesToSourceIO

58−

59−instance PipesToSourceIO m => ToSourceIO a (ListT m a) where

60− toSourceIO = pipesToSourceIO . enumerate

61−

62−instance (MonadIO m, a' ~ X, a ~ (), b' ~ (), r ~ ())

63− => FromSourceIO b (Proxy a' a b' b m r)

64− where

65− fromSourceIO src = M $ liftIO $ S.unSourceT src (return . go) where

66− go :: S.StepT IO b -> Proxy X () () b m ()

67− go S.Stop = Pure ()

68− go (S.Error err) = M (liftIO (fail err))

69− go (S.Skip s) = go s -- drives

70− go (S.Effect ms) = M (liftIO (fmap go ms))

71− go (S.Yield x s) = Respond x (const (go s))

72− {-# SPECIALIZE INLINE fromSourceIO :: SourceIO x -> Proxy X () () x IO () #-}

73−

74−instance MonadIO m => FromSourceIO a (ListT m a) where

75− fromSourceIO = Select . fromSourceIO

servant-server/CHANGELOG.md−193

@@ -1,199 +1,6 @@

1[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-server/CHANGELOG.md)

1[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-server/CHANGELOG.md)

2[Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)

2[Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)

3

3

4−Package versions follow the [Package Versioning Policy](https://pvp.haskell.org/): in A.B.C, bumps to either A or B represent major versions.

5−

6−0.19.2

7−------

8−

9−Compatibility with GHC 9.4, see [PR #1592](https://github.com/haskell-servant/servant/pull/1592).

10−

11−0.19.1

12−------

13−

14−- Add `MonadFail` instance for `Handler` wrt [#1545](https://github.com/haskell-servant/servant/issues/1545)

15−- Support GHC 9.2 [#1525](https://github.com/haskell-servant/servant/issues/1525)

16−- Add capture hints in `Router` type for debug and display purposes [PR #1556] (https://github.com/haskell-servant/servant/pull/1556)

17−

18−0.19

19−----

20−

21−### Significant changes

22−

23−- Drop support for GHC < 8.6.

24−- Support GHC 9.0 (GHC 9.2 should work as well, but isn't fully tested yet).

25−- Support Aeson 2 ([#1475](https://github.com/haskell-servant/servant/pull/1475)),

26− which fixes a [DOS vulnerability](https://github.com/haskell/aeson/issues/864)

27− related to hash collisions.

28−- Add `NamedRoutes` combinator, making support for records first-class in Servant

29− ([#1388](https://github.com/haskell-servant/servant/pull/1388)).

30−- Add custom type errors for partially applied combinators

31− ([#1289](https://github.com/haskell-servant/servant/pull/1289),

32− [#1486](https://github.com/haskell-servant/servant/pull/1486)).

33−

34−0.18.3

35−------

36−

37−### Significant changes

38−

39−- Add response header support to UVerb (#1420)

40−

41−### Other changes

42−

43−- Support GHC-9.0.1.

44−- Bump `bytestring`, `hspec` and `base64-bytestring` dependencies.

45−

46−0.18.2

47−------

48−

49−### Significant changes

50−

51−- Support `Fragment` combinator.

52−

53−0.18.1

54−------

55−

56−### Significant changes

57−

58−- Union verbs

59−

60−### Other changes

61−

62−- Bump "tested-with" ghc versions

63−- Allow newer dependencies

64−

65−0.18

66−----

67−

68−### Significant changes

69−

70−- Support for ghc8.8 (#1318, #1326, #1327)

71−

72−- Configurable error messages for automatic errors thrown by servant,

73− like "no route" or "could not parse json body" (#1312, #1326, #1327)

74−

75−

76−0.17

77−----

78−

79−### Significant changes

80−

81−- Add NoContentVerb [#1028](https://github.com/haskell-servant/servant/issues/1028) [#1219](https://github.com/haskell-servant/servant/pull/1219) [#1228](https://github.com/haskell-servant/servant/pull/1228)

82−

83− The `NoContent` API endpoints should now use `NoContentVerb` combinator.

84− The API type changes are usually of the kind

85−

86− ```diff

87− - :<|> PostNoContent '[JSON] NoContent

88− + :<|> PostNoContent

89− ```

90−

91− i.e. one doesn't need to specify the content-type anymore. There is no content.

92−

93−- `Capture` can be `Lenient` [#1155](https://github.com/haskell-servant/servant/issues/1155) [#1156](https://github.com/haskell-servant/servant/pull/1156)

94−

95− You can specify a lenient capture as

96−

97− ```haskell

98− :<|> "capture-lenient" :> Capture' '[Lenient] "foo" Int :> GET

99− ```

100−

101− which will make the capture always succeed. Handlers will be of the

102− type `Either String CapturedType`, where `Left err` represents

103− the possible parse failure.

104−

105−- *servant-server* use queryString to parse QueryParam, QueryParams and QueryFlag [#1249](https://github.com/haskell-servant/servant/pull/1249) [#1262](https://github.com/haskell-servant/servant/pull/1262)

106−

107− Some APIs need query parameters rewriting, e.g. in order to support

108− for multiple casing (camel, snake, etc) or something to that effect.

109−

110− This could be easily achieved by using WAI Middleware and modifying

111− request's `Query`. But QueryParam, QueryParams and QueryFlag use

112− `rawQueryString`. By using `queryString` rather then `rawQueryString`

113− we can enable such rewritings.

114−

115−- *servant* *servant-server* Make packages `build-type: Simple` [#1263](https://github.com/haskell-servant/servant/pull/1263)

116−

117− We used `build-type: Custom`, but it's problematic e.g.

118− for cross-compiling. The benefit is small, as the doctests

119− can be run other ways too (though not so conveniently).

120−

121−0.16.2

122−------

123−

124−* `singleton-bool-0.1.5` (`SBool` is re-exported)

125− - Add `discreteBool :: Dec (a :~: b)` (GHC-7.8+)

126− - Add `Show`, `Eq`, `Ord` `SBool b` instances.

127−* dependencies update

128−

129−0.16.1

130−------

131−

132−* Use `http-api-data-0.4.1` (a part of its API is re-exported)

133− [#1181](https://github.com/haskell-servant/servant/pull/1181)

134−

135−0.16

136−----

137−

138−- Rename `ServantError` to `ClientError`, `ServantErr` to `ServerError`

139− [#1131](https://github.com/haskell-servant/servant/pull/1131)

140−- *servant-server* Reorder HTTP failure code priorities

141− [#1103](https://github.com/haskell-servant/servant/pull/1103)

142−- *servant-server* Re-organise internal modules

143− [#1139](https://github.com/haskell-servant/servant/pull/1139)

144−- Allow `network-3.0`

145− [#1107](https://github.com/haskell-servant/servant/pull/1107)

146−

147−0.15

148−----

149−

150−- Streaming refactoring.

151− [#991](https://github.com/haskell-servant/servant/pull/991)

152− [#1076](https://github.com/haskell-servant/servant/pull/1076)

153− [#1077](https://github.com/haskell-servant/servant/pull/1077)

154−

155− The streaming functionality (`Servant.API.Stream`) is refactored to use

156− `servant`'s own `SourceIO` type (see `Servant.Types.SourceT` documentation),

157− which replaces both `StreamGenerator` and `ResultStream` types.

158−

159− New conversion type-classes are `ToSourceIO` and `FromSourceIO`

160− (replacing `ToStreamGenerator` and `BuildFromStream`).

161− There are instances for *conduit*, *pipes* and *machines* in new packages:

162− [servant-conduit](https://hackage.haskell.org/package/servant-conduit)

163− [servant-pipes](https://hackage.haskell.org/package/servant-pipes) and

164− [servant-machines](https://hackage.haskell.org/package/servant-machines)

165− respectively.

166−

167− Writing new framing strategies is simpler. Check existing strategies for examples.

168−

169− This change shouldn't affect you, if you don't use streaming endpoints.

170−

171−- Drop support for GHC older than 8.0

172− [#1008](https://github.com/haskell-servant/servant/pull/1008)

173− [#1009](https://github.com/haskell-servant/servant/pull/1009)

174−

175−- *servant* NewlineFraming encodes newline after each element (i.e last)

176− [#1079](https://github.com/haskell-servant/servant/pull/1079)

177− [#1011](https://github.com/haskell-servant/servant/issues/1011)

178−

179−- *servant* Add `lookupResponseHeader :: ... => Headers headers r -> ResponseHeader h a`

180− [#1064](https://github.com/haskell-servant/servant/pull/1064)

181−

182−- *servant-server* Add `MonadMask Handler`

183− [#1068](https://github.com/haskell-servant/servant/pull/1068)

184−

185−- *servant* Export `GetHeaders'`

186− [#1052](https://github.com/haskell-servant/servant/pull/1052)

187−

188−- *servant* Add `Bitraversable` and other `Bi-` instances for `:<|>`

189− [#1032](https://github.com/haskell-servant/servant/pull/1032)

190−

191−- *servant* Add `PutCreated` method type alias

192− [#1024](https://github.com/haskell-servant/servant/pull/1024)

193−

194−- *servant* Add `ToSourceIO (NonEmpty a)` instance

195− [#988](https://github.com/haskell-servant/servant/pull/988)

196−

1970.14.1

40.14.1

198------

5------

199

6

servant-server/LICENSE+1−1

@@ -1,4 +1,4 @@

1−Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, 2016-2018 Servant Contributors

1+Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, Servant Contributors

2

2

3All rights reserved.

3All rights reserved.

4

4

servant-server/README.md+1−1

@@ -6,4 +6,4 @@ This library lets you *implement* an HTTP server with handlers for each endpoint

6

6

7## Getting started

7## Getting started

8

8

9−We've written a [tutorial](http://docs.servant.dev/en/stable/tutorial/index.html) guide that introduces the core types and features of servant. After this article, you should be able to write your first servant webservices, learning the rest from the haddocks' examples.

9+We've written a [tutorial](http://haskell-servant.readthedocs.org/en/stable/tutorial/index.html) guide that introduces the core types and features of servant. After this article, you should be able to write your first servant webservices, learning the rest from the haddocks' examples.

servant-server/Setup.hs+32−1

@@ -1,2 +1,33 @@

1+{-# LANGUAGE CPP #-}

2+{-# OPTIONS_GHC -Wall #-}

3+module Main (main) where

4+

5+#ifndef MIN_VERSION_cabal_doctest

6+#define MIN_VERSION_cabal_doctest(x,y,z) 0

7+#endif

8+

9+#if MIN_VERSION_cabal_doctest(1,0,0)

10+

11+import Distribution.Extra.Doctest ( defaultMainWithDoctests )

12+main :: IO ()

13+main = defaultMainWithDoctests "doctests"

14+

15+#else

16+

17+#ifdef MIN_VERSION_Cabal

18+-- If the macro is defined, we have new cabal-install,

19+-- but for some reason we don't have cabal-doctest in package-db

20+--

21+-- Probably we are running cabal sdist, when otherwise using new-build

22+-- workflow

23+#warning You are configuring this package without cabal-doctest installed. \

24+ The doctests test-suite will not work as a result. \

25+ To fix this, install cabal-doctest before configuring.

26+#endif

27+

1−import Distribution.Simple

28+import Distribution.Simple

29+

30+main :: IO ()

2main = defaultMain

31main = defaultMain

32+

33+#endif

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

@@ -1,2 +1,2 @@

1- `greet.hs` shows how to write a simple webservice, run it, query it with automatically-derived haskell functions and print the (generated) markdown documentation for the API.

1- `greet.hs` shows how to write a simple webservice, run it, query it with automatically-derived haskell functions and print the (generated) markdown documentation for the API.

2−- `greet.md` contains the aforementioned generated documentation.

2+- `greet.md` contains the aforementionned generated documentation.

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

@@ -1,15 +1,12 @@

1{-# LANGUAGE DataKinds #-}

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DeriveGeneric #-}

2{-# LANGUAGE DeriveGeneric #-}

3−{-# LANGUAGE RecordWildCards #-}

4{-# LANGUAGE OverloadedStrings #-}

3{-# LANGUAGE OverloadedStrings #-}

5{-# LANGUAGE PolyKinds #-}

4{-# LANGUAGE PolyKinds #-}

6{-# LANGUAGE TypeFamilies #-}

5{-# LANGUAGE TypeFamilies #-}

7{-# LANGUAGE TypeOperators #-}

6{-# LANGUAGE TypeOperators #-}

8

7

9−import Prelude ()

10−import Prelude.Compat

11−

12import Data.Aeson

8import Data.Aeson

9+import Data.Monoid

13import Data.Proxy

10import Data.Proxy

14import Data.Text

11import Data.Text

15import GHC.Generics

12import GHC.Generics

@@ -17,7 +14,6 @@ import Network.Wai

17import Network.Wai.Handler.Warp

14import Network.Wai.Handler.Warp

18

15

19import Servant

16import Servant

20−import Servant.Server.Generic ()

21

17

22-- * Example

18-- * Example

23

19

@@ -40,14 +36,6 @@ type TestApi =

40 -- DELETE /greet/:greetid

36 -- DELETE /greet/:greetid

41 :<|> "greet" :> Capture "greetid" Text :> Delete '[JSON] NoContent

37 :<|> "greet" :> Capture "greetid" Text :> Delete '[JSON] NoContent

42

38

43− :<|> NamedRoutes OtherRoutes

44−

45−data OtherRoutes mode = OtherRoutes

46− { version :: mode :- Get '[JSON] Int

47− , bye :: mode :- "bye" :> Capture "name" Text :> Get '[JSON] Text

48− }

49− deriving Generic

50−

51testApi :: Proxy TestApi

39testApi :: Proxy TestApi

52testApi = Proxy

40testApi = Proxy

53

41

@@ -58,13 +46,9 @@ testApi = Proxy

58--

46--

59-- Each handler runs in the 'Handler' monad.

47-- Each handler runs in the 'Handler' monad.

60server :: Server TestApi

48server :: Server TestApi

61−server = helloH :<|> postGreetH :<|> deleteGreetH :<|> otherRoutes

49+server = helloH :<|> postGreetH :<|> deleteGreetH

62− where otherRoutes = OtherRoutes {..}

63−

64− bye name = pure $ "Bye, " <> name <> " !"

65− version = pure 42

66

50

67− helloH name Nothing = helloH name (Just False)

51+ where helloH name Nothing = helloH name (Just False)

68 helloH name (Just False) = return . Greet $ "Hello, " <> name

52 helloH name (Just False) = return . Greet $ "Hello, " <> name

69 helloH name (Just True) = return . Greet . toUpper $ "Hello, " <> name

53 helloH name (Just True) = return . Greet . toUpper $ "Hello, " <> name

70

54

servant-server/servant-server.cabal+71−55

@@ -1,30 +1,31 @@

1−cabal-version: 2.2

2name: servant-server

1name: servant-server

3−version: 0.19.2

2+version: 0.14.1

4−

5synopsis: A family of combinators for defining webservices APIs and serving them

3synopsis: A family of combinators for defining webservices APIs and serving them

6−category: Servant, Web

7description:

4description:

8 A family of combinators for defining webservices APIs and serving them

5 A family of combinators for defining webservices APIs and serving them

9 .

6 .

10− You can learn about the basics in the <http://docs.servant.dev/en/stable/tutorial/index.html tutorial>.

7+ You can learn about the basics in the <http://haskell-servant.readthedocs.org/en/stable/tutorial/index.html tutorial>.

11 .

8 .

12 <https://github.com/haskell-servant/servant/blob/master/servant-server/example/greet.hs Here>

9 <https://github.com/haskell-servant/servant/blob/master/servant-server/example/greet.hs Here>

13 is a runnable example, with comments, that defines a dummy API and implements

10 is a runnable example, with comments, that defines a dummy API and implements

14 a webserver that serves this API, using this package.

11 a webserver that serves this API, using this package.

15 .

12 .

16 <https://github.com/haskell-servant/servant/blob/master/servant-server/CHANGELOG.md CHANGELOG>

13 <https://github.com/haskell-servant/servant/blob/master/servant-server/CHANGELOG.md CHANGELOG>

17−

14+homepage: http://haskell-servant.readthedocs.org/

18−homepage: http://docs.servant.dev/

19−bug-reports: http://github.com/haskell-servant/servant/issues

15+Bug-reports: http://github.com/haskell-servant/servant/issues

20−license: BSD-3-Clause

16+license: BSD3

21license-file: LICENSE

17license-file: LICENSE

22author: Servant Contributors

18author: Servant Contributors

23maintainer: haskell-servant-maintainers@googlegroups.com

19maintainer: haskell-servant-maintainers@googlegroups.com

24−copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors

20+copyright: 2014-2016 Zalora South East Asia Pte Ltd, Servant Contributors

21+category: Servant, Web

25−build-type: Simple

22+build-type: Custom

23+cabal-version: >=1.10

26−tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.4 || ==9.4.3

24+tested-with:

27−

25+ GHC==8.0.2

26+ GHC==8.2.2

27+ GHC==8.4.4

28+ GHC==8.6.1

28extra-source-files:

29extra-source-files:

29 CHANGELOG.md

30 CHANGELOG.md

30 README.md

31 README.md

@@ -33,6 +34,12 @@ source-repository head

33 type: git

34 type: git

34 location: http://github.com/haskell-servant/servant.git

35 location: http://github.com/haskell-servant/servant.git

35

36

37+custom-setup

38+ setup-depends:

39+ base >= 4 && <5,

40+ Cabal,

41+ cabal-doctest >= 1.0.6 && <1.1

42+

36library

43library

37 exposed-modules:

44 exposed-modules:

38 Servant

45 Servant

@@ -42,16 +49,11 @@ library

42 Servant.Server.Internal

49 Servant.Server.Internal

43 Servant.Server.Internal.BasicAuth

50 Servant.Server.Internal.BasicAuth

44 Servant.Server.Internal.Context

51 Servant.Server.Internal.Context

45− Servant.Server.Internal.Delayed

46− Servant.Server.Internal.DelayedIO

47− Servant.Server.Internal.ErrorFormatter

48 Servant.Server.Internal.Handler

52 Servant.Server.Internal.Handler

49− Servant.Server.Internal.RouteResult

50 Servant.Server.Internal.Router

53 Servant.Server.Internal.Router

51 Servant.Server.Internal.RoutingApplication

54 Servant.Server.Internal.RoutingApplication

52− Servant.Server.Internal.ServerError

55+ Servant.Server.Internal.ServantErr

53 Servant.Server.StaticFiles

56 Servant.Server.StaticFiles

54− Servant.Server.UVerb

55

57

56 -- deprecated

58 -- deprecated

57 exposed-modules:

59 exposed-modules:

@@ -59,45 +61,48 @@ library

59

61

60 -- Bundled with GHC: Lower bound to not force re-installs

62 -- Bundled with GHC: Lower bound to not force re-installs

61 -- text and mtl are bundled starting with GHC-8.4

63 -- text and mtl are bundled starting with GHC-8.4

64+ --

65+ -- note: mtl lower bound is so low because of GHC-7.8

62 build-depends:

66 build-depends:

63− base >= 4.9 && < 4.18

67+ base >= 4.7 && < 4.13

64− , bytestring >= 0.10.8.1 && < 0.12

68+ , bytestring >= 0.10.4.0 && < 0.11

65− , constraints >= 0.2 && < 0.14

66− , containers >= 0.5.7.1 && < 0.7

69+ , containers >= 0.5.5.1 && < 0.7

67− , mtl ^>= 2.2.2 || ^>= 2.3.1

70+ , mtl >= 2.1 && < 2.3

68− , text >= 1.2.3.0 && < 2.1

71+ , text >= 1.2.3.0 && < 1.3

69− , transformers >= 0.5.2.0 && < 0.7

72+ , transformers >= 0.3.0.0 && < 0.6

70− , filepath >= 1.4.1.1 && < 1.5

73+ , filepath >= 1.3.0.2 && < 1.5

74+

75+ if !impl(ghc >= 8.0)

76+ build-depends:

77+ semigroups >= 0.18.4 && < 0.19

71

78

72 -- Servant dependencies

79 -- Servant dependencies

73− -- strict dependency as we re-export 'servant' things.

74 build-depends:

80 build-depends:

75− servant >= 0.19 && < 0.20

81+ servant >= 0.14.1 && <0.15

76− , http-api-data >= 0.4.1 && < 0.5.1

77

82

78 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.

83 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.

79 -- Here can be exceptions if we really need features from the newer versions.

84 -- Here can be exceptions if we really need features from the newer versions.

80 build-depends:

85 build-depends:

81− base-compat >= 0.10.5 && < 0.13

86+ base-compat >= 0.10.1 && < 0.11

82− , base64-bytestring >= 1.0.0.1 && < 1.3

87+ , base64-bytestring >= 1.0.0.1 && < 1.1

83 , exceptions >= 0.10.0 && < 0.11

88 , exceptions >= 0.10.0 && < 0.11

84− , http-media >= 0.7.1.3 && < 0.9

89+ , http-api-data >= 0.3.8.1 && < 0.4

90+ , http-media >= 0.7.1.2 && < 0.8

85− , http-types >= 0.12.2 && < 0.13

91+ , http-types >= 0.12.1 && < 0.13

86− , network-uri >= 2.6.1.0 && < 2.8

92+ , network-uri >= 2.6.1.0 && < 2.7

87 , monad-control >= 1.0.2.3 && < 1.1

93 , monad-control >= 1.0.2.3 && < 1.1

88− , network >= 2.8 && < 3.2

94+ , network >= 2.6.3.5 && < 2.9

89− , sop-core >= 0.4.0.0 && < 0.6

90 , string-conversions >= 0.4.0.1 && < 0.5

95 , string-conversions >= 0.4.0.1 && < 0.5

91− , resourcet >= 1.2.2 && < 1.4

96+ , resourcet >= 1.1.11 && < 1.3

92− , tagged >= 0.8.6 && < 0.9

97+ , tagged >= 0.8.5 && < 0.9

93− , transformers-base >= 0.4.5.2 && < 0.5

98+ , transformers-base >= 0.4.4 && < 0.5

99+ , transformers-compat >= 0.6.2 && < 0.7

94− , wai >= 3.2.2.1 && < 3.3

100+ , wai >= 3.2.1.1 && < 3.3

95− , wai-app-static >= 3.1.6.2 && < 3.2

101+ , wai-app-static >= 3.1.6.1 && < 3.2

96 , word8 >= 0.1.3 && < 0.2

102 , word8 >= 0.1.3 && < 0.2

97

103

98 hs-source-dirs: src

104 hs-source-dirs: src

99 default-language: Haskell2010

105 default-language: Haskell2010

100−

101 ghc-options: -Wall -Wno-redundant-constraints

106 ghc-options: -Wall -Wno-redundant-constraints

102

107

103executable greet

108executable greet

@@ -107,15 +112,14 @@ executable greet

107 default-language: Haskell2010

112 default-language: Haskell2010

108 build-depends:

113 build-depends:

109 base

114 base

110− , base-compat

111 , servant

115 , servant

112 , servant-server

116 , servant-server

113 , wai

117 , wai

114 , text

118 , text

115

119

116 build-depends:

120 build-depends:

117− aeson >= 1.4.1.0 && < 3

121+ aeson >= 1.3.1.1 && < 1.5

118− , warp >= 3.2.25 && < 3.4

122+ , warp >= 3.2.13 && < 3.3

119

123

120test-suite spec

124test-suite spec

121 type: exitcode-stdio-1.0

125 type: exitcode-stdio-1.0

@@ -148,23 +152,35 @@ test-suite spec

148 , safe

152 , safe

149 , servant

153 , servant

150 , servant-server

154 , servant-server

151− , sop-core

152 , string-conversions

155 , string-conversions

153 , text

156 , text

154 , transformers

157 , transformers

155 , transformers-compat

158 , transformers-compat

156 , wai

159 , wai

157

160

158− -- Additional dependencies

161+ -- Additonal dependencies

159 build-depends:

162 build-depends:

160− aeson >= 1.4.1.0 && < 3

163+ aeson >= 1.3.1.1 && < 1.5

161− , directory >= 1.3.0.0 && < 1.4

164+ , directory >= 1.2.1.0 && < 1.4

162− , hspec >= 2.6.0 && < 2.10

165+ , hspec >= 2.5.1 && < 2.6

163− , hspec-wai >= 0.10.1 && < 0.12

166+ , hspec-wai >= 0.9.0 && < 0.10

164− , QuickCheck >= 2.12.6.1 && < 2.15

167+ , QuickCheck >= 2.11.3 && < 2.12

165 , should-not-typecheck >= 2.1.0 && < 2.2

168 , should-not-typecheck >= 2.1.0 && < 2.2

166 , temporary >= 1.3 && < 1.4

169 , temporary >= 1.3 && < 1.4

167− , wai-extra >= 3.0.24.3 && < 3.2

170+ , wai-extra >= 3.0.21.0 && < 3.1

168

171

169 build-tool-depends:

172 build-tool-depends:

170− hspec-discover:hspec-discover >= 2.6.0 && <2.10

173+ hspec-discover:hspec-discover >= 2.5.1 && <2.6

174+

175+test-suite doctests

176+ build-depends:

177+ base

178+ , servant-server

179+ , doctest >= 0.16.0 && <0.17

180+ type: exitcode-stdio-1.0

181+ main-is: test/doctests.hs

182+ buildable: True

183+ default-language: Haskell2010

184+ ghc-options: -Wall -threaded

185+ if impl(ghc >= 8.2)

186+ x-doctest-options: -fdiagnostics-color=never

servant-server/src/Servant/Server.hs+12−65

@@ -1,10 +1,8 @@

1−{-# LANGUAGE ConstraintKinds #-}

1+{-# LANGUAGE ConstraintKinds #-}

2−{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE FlexibleContexts #-}

3+{-# LANGUAGE FlexibleContexts #-}

4−{-# LANGUAGE RankNTypes #-}

4+{-# LANGUAGE RankNTypes #-}

5−{-# LANGUAGE ScopedTypeVariables #-}

6−{-# LANGUAGE TypeFamilies #-}

5+{-# LANGUAGE TypeFamilies #-}

7−{-# LANGUAGE TypeOperators #-}

8

6

9-- | This module lets you implement 'Server's for defined APIs. You'll

7-- | This module lets you implement 'Server's for defined APIs. You'll

10-- most likely just need 'serve'.

8-- most likely just need 'serve'.

@@ -12,8 +10,6 @@ module Servant.Server

12 ( -- * Run a wai application from an API

10 ( -- * Run a wai application from an API

13 serve

11 serve

14 , serveWithContext

12 , serveWithContext

15− , serveWithContextT

16− , ServerContext

17

13

18 , -- * Construct a wai Application from an API

14 , -- * Construct a wai Application from an API

19 toApplication

15 toApplication

@@ -39,8 +35,6 @@ module Servant.Server

39 -- * Context

35 -- * Context

40 , Context(..)

36 , Context(..)

41 , HasContextEntry(getContextEntry)

37 , HasContextEntry(getContextEntry)

42− , type (.++)

43− , (.++)

44 -- ** NamedContext

38 -- ** NamedContext

45 , NamedContext(..)

39 , NamedContext(..)

46 , descendIntoNamedContext

40 , descendIntoNamedContext

@@ -55,7 +49,7 @@ module Servant.Server

55 -- , mkAuthHandler

49 -- , mkAuthHandler

56

50

57 -- * Default error type

51 -- * Default error type

58− , ServerError(..)

52+ , ServantErr(..)

59 -- ** 3XX

53 -- ** 3XX

60 , err300

54 , err300

61 , err301

55 , err301

@@ -92,28 +86,9 @@ module Servant.Server

92 , err504

86 , err504

93 , err505

87 , err505

94

88

95− -- * Formatting of errors from combinators

96− --

97− -- | You can configure how Servant will render errors that occur while parsing the request.

98−

99− , ErrorFormatter

100− , NotFoundErrorFormatter

101− , ErrorFormatters

102−

103− , bodyParserErrorFormatter

104− , urlParseErrorFormatter

105− , headerParseErrorFormatter

106− , notFoundErrorFormatter

107−

108− , DefaultErrorFormatters

109− , defaultErrorFormatters

110−

111− , getAcceptHeader

112−

113 -- * Re-exports

89 -- * Re-exports

114 , Application

90 , Application

115 , Tagged (..)

91 , Tagged (..)

116− , module Servant.Server.UVerb

117

92

118 ) where

93 ) where

119

94

@@ -126,26 +101,16 @@ import Data.Text

126import Network.Wai

101import Network.Wai

127 (Application)

102 (Application)

128import Servant.Server.Internal

103import Servant.Server.Internal

129−import Servant.Server.UVerb

130

104

131

105

132-- * Implementing Servers

106-- * Implementing Servers

133

107

134−-- | Constraints that need to be satisfied on a context for it to be passed to 'serveWithContext'.

135−--

136−-- Typically, this will add default context entries to the context. You shouldn't typically

137−-- need to worry about these constraints, but if you write a helper function that wraps

138−-- 'serveWithContext', you might need to include this constraint.

139−type ServerContext context =

140− ( HasContextEntry (context .++ DefaultErrorFormatters) ErrorFormatters

141− )

142−

143-- | 'serve' allows you to implement an API and produce a wai 'Application'.

108-- | 'serve' allows you to implement an API and produce a wai 'Application'.

144--

109--

145-- Example:

110-- Example:

146--

111--

147-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books

112-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books

148−-- > :<|> "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book -- POST /books

113+-- > :<|> "books" :> ReqBody Book :> Post '[JSON] Book -- POST /books

149-- >

114-- >

150-- > server :: Server MyApi

115-- > server :: Server MyApi

151-- > server = listAllBooks :<|> postBook

116-- > server = listAllBooks :<|> postBook

@@ -164,27 +129,10 @@ type ServerContext context =

164serve :: (HasServer api '[]) => Proxy api -> Server api -> Application

129serve :: (HasServer api '[]) => Proxy api -> Server api -> Application

165serve p = serveWithContext p EmptyContext

130serve p = serveWithContext p EmptyContext

166

131

167−-- | Like 'serve', but allows you to pass custom context.

168−--

169−-- 'defaultErrorFormatters' will always be appended to the end of the passed context,

170−-- but if you pass your own formatter, it will override the default one.

171−serveWithContext :: ( HasServer api context

132+serveWithContext :: (HasServer api context)

172− , ServerContext context

173− )

174 => Proxy api -> Context context -> Server api -> Application

133 => Proxy api -> Context context -> Server api -> Application

175−serveWithContext p context = serveWithContextT p context id

134+serveWithContext p context server =

176−

177−-- | A general 'serve' function that allows you to pass a custom context and hoisting function to

178−-- apply on all routes.

179−serveWithContextT ::

180− forall api context m.

181− (HasServer api context, ServerContext context) =>

182− Proxy api -> Context context -> (forall x. m x -> Handler x) -> ServerT api m -> Application

183−serveWithContextT p context toHandler server =

184− toApplication (runRouter format404 (route p context (emptyDelayed router)))

135+ toApplication (runRouter (route p context (emptyDelayed (Route server))))

185− where

186− router = Route $ hoistServerWithContext p (Proxy :: Proxy context) toHandler server

187− format404 = notFoundErrorFormatter . getContextEntry . mkContextWithErrorFormatter $ context

188

136

189-- | Hoist server implementation.

137-- | Hoist server implementation.

190--

138--

@@ -235,7 +183,7 @@ hoistServer p = hoistServerWithContext p (Proxy :: Proxy '[])

235-- > │ └─ e/

183-- > │ └─ e/

236-- > │ └─•

184-- > │ └─•

237-- > ├─ b/

185-- > ├─ b/

238−-- > │ └─ <x::Int>/

186+-- > │ └─ <capture>/

239-- > │ ├─•

187-- > │ ├─•

240-- > │ ┆

188-- > │ ┆

241-- > │ └─•

189-- > │ └─•

@@ -252,8 +200,7 @@ hoistServer p = hoistServerWithContext p (Proxy :: Proxy '[])

252--

200--

253-- [@─•@] Leaves reflect endpoints.

201-- [@─•@] Leaves reflect endpoints.

254--

202--

255−-- [@\<x::Int\>/@] This is a delayed capture of a single

203+-- [@\<capture\>/@] This is a delayed capture of a path component.

256−-- path component named @x@, of expected type @Int@.

257--

204--

258-- [@\<raw\>@] This is a part of the API we do not know anything about.

205-- [@\<raw\>@] This is a part of the API we do not know anything about.

259--

206--

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

@@ -1,6 +1,5 @@

1{-# OPTIONS_GHC -fno-warn-orphans #-}

1{-# OPTIONS_GHC -fno-warn-orphans #-}

2{-# LANGUAGE DeriveDataTypeable #-}

2{-# LANGUAGE DeriveDataTypeable #-}

3−{-# LANGUAGE DeriveFunctor #-}

4{-# LANGUAGE DeriveGeneric #-}

3{-# LANGUAGE DeriveGeneric #-}

5{-# LANGUAGE FlexibleContexts #-}

4{-# LANGUAGE FlexibleContexts #-}

6{-# LANGUAGE FlexibleInstances #-}

5{-# LANGUAGE FlexibleInstances #-}

@@ -28,9 +27,11 @@ import Servant

28 ((:>))

27 ((:>))

29import Servant.API.Experimental.Auth

28import Servant.API.Experimental.Auth

30import Servant.Server.Internal

29import Servant.Server.Internal

31− (DelayedIO, Handler, HasContextEntry, HasServer (..),

30+ (HasContextEntry, HasServer (..), getContextEntry)

31+import Servant.Server.Internal.Handler

32+ (Handler, runHandler)

33+import Servant.Server.Internal.RoutingApplication

32− addAuthCheck, delayedFailFatal, getContextEntry, runHandler,

34+ (DelayedIO, addAuthCheck, delayedFailFatal, withRequest)

33− withRequest)

34

35

35-- * General Auth

36-- * General Auth

36

37

@@ -45,7 +46,7 @@ type family AuthServerData a :: *

45-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE

46-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE

46newtype AuthHandler r usr = AuthHandler

47newtype AuthHandler r usr = AuthHandler

47 { unAuthHandler :: r -> Handler usr }

48 { unAuthHandler :: r -> Handler usr }

48− deriving (Functor, Generic, Typeable)

49+ deriving (Generic, Typeable)

49

50

50-- | NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE

51-- | NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE

51mkAuthHandler :: (r -> Handler usr) -> AuthHandler r usr

52mkAuthHandler :: (r -> Handler usr) -> AuthHandler r usr

servant-server/src/Servant/Server/Generic.hs+19−59

@@ -1,29 +1,34 @@

1+{-# LANGUAGE ConstraintKinds #-}

1−{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE FlexibleContexts #-}

3+{-# LANGUAGE FlexibleContexts #-}

3−{-# LANGUAGE RankNTypes #-}

4+{-# LANGUAGE KindSignatures #-}

4−{-# LANGUAGE ScopedTypeVariables #-}

5+{-# LANGUAGE ScopedTypeVariables #-}

5−{-# LANGUAGE TypeFamilies #-}

6+{-# LANGUAGE TypeFamilies #-}

6−{-# LANGUAGE TypeOperators #-}

7+{-# LANGUAGE TypeOperators #-}

7−

8+{-# LANGUAGE UndecidableInstances #-}

8-- | @since 0.14.1

9-- | @since 0.14.1

9module Servant.Server.Generic (

10module Servant.Server.Generic (

10 AsServerT,

11 AsServerT,

11 AsServer,

12 AsServer,

12 genericServe,

13 genericServe,

13− genericServeT,

14− genericServeTWithContext,

15 genericServer,

14 genericServer,

16− genericServerT

15+ genericServerT,

17 ) where

16 ) where

18

17

19import Data.Proxy

18import Data.Proxy

20 (Proxy (..))

19 (Proxy (..))

21

20

22−import Servant.Server

23import Servant.API.Generic

21import Servant.API.Generic

24−import Servant.Server.Internal

22+import Servant.Server

23+

24+-- | A type that specifies that an API record contains a server implementation.

25+data AsServerT (m :: * -> *)

26+instance GenericMode (AsServerT m) where

27+ type AsServerT m :- api = ServerT api m

25

28

29+type AsServer = AsServerT Handler

30+

26−-- | Transform a record of routes into a WAI 'Application'.

31+-- | Transform record of routes into a WAI 'Application'.

27genericServe

32genericServe

28 :: forall routes.

33 :: forall routes.

29 ( HasServer (ToServantApi routes) '[]

34 ( HasServer (ToServantApi routes) '[]

@@ -33,60 +38,15 @@ genericServe

33 => routes AsServer -> Application

38 => routes AsServer -> Application

34genericServe = serve (Proxy :: Proxy (ToServantApi routes)) . genericServer

39genericServe = serve (Proxy :: Proxy (ToServantApi routes)) . genericServer

35

40

36−-- | Transform a record of routes with custom monad into a WAI 'Application',

37−-- by providing a transformation to bring each handler back in the 'Handler'

38−-- monad.

39−genericServeT

40− :: forall (routes :: * -> *) (m :: * -> *).

41− ( GenericServant routes (AsServerT m)

42− , GenericServant routes AsApi

43− , HasServer (ToServantApi routes) '[]

44− , ServerT (ToServantApi routes) m ~ ToServant routes (AsServerT m)

45− )

46− => (forall a. m a -> Handler a) -- ^ 'hoistServer' argument to come back to 'Handler'

47− -> routes (AsServerT m) -- ^ your record full of request handlers

48− -> Application

49−genericServeT f server = serve p $ hoistServer p f (genericServerT server)

50− where

51− p = genericApi (Proxy :: Proxy routes)

52−

53−-- | Transform a record of routes with custom monad into a WAI 'Application',

54−-- while using the given 'Context' to serve the application (contexts are typically

55−-- used by auth-related combinators in servant, e.g to hold auth checks) and the given

56−-- transformation to map all the handlers back to the 'Handler' monad.

57−genericServeTWithContext

58− :: forall (routes :: * -> *) (m :: * -> *) (ctx :: [*]).

59− ( GenericServant routes (AsServerT m)

60− , GenericServant routes AsApi

61− , HasServer (ToServantApi routes) ctx

62− , HasContextEntry (ctx .++ DefaultErrorFormatters) ErrorFormatters

63− , ServerT (ToServantApi routes) m ~ ToServant routes (AsServerT m)

64− )

65− => (forall a. m a -> Handler a) -- ^ 'hoistServer' argument to come back to 'Handler'

66− -> routes (AsServerT m) -- ^ your record full of request handlers

67− -> Context ctx -- ^ the 'Context' to serve the application with

68− -> Application

69−genericServeTWithContext f server ctx =

70− serveWithContext p ctx $

71− hoistServerWithContext p pctx f (genericServerT server)

72− where

73− p = genericApi (Proxy :: Proxy routes)

74− pctx = Proxy :: Proxy ctx

75−

76−-- | Transform a record of endpoints into a 'Server'.

41+-- | Transform record of endpoints into a 'Server'.

77genericServer

42genericServer

78 :: GenericServant routes AsServer

43 :: GenericServant routes AsServer

79 => routes AsServer

44 => routes AsServer

80 -> ToServant routes AsServer

45 -> ToServant routes AsServer

81genericServer = toServant

46genericServer = toServant

82

47

83−-- | Transform a record of endpoints into a @'ServerT' m@.

84−--

85−-- You can see an example usage of this function

86−-- <https://docs.servant.dev/en/stable/cookbook/generic/Generic.html#using-generics-together-with-a-custom-monad in the Servant Cookbook>.

87genericServerT

48genericServerT

88 :: GenericServant routes (AsServerT m)

49 :: GenericServant routes (AsServerT m)

89 => routes (AsServerT m)

50 => routes (AsServerT m)

90 -> ToServant routes (AsServerT m)

51 -> ToServant routes (AsServerT m)

91genericServerT = toServant

52genericServerT = toServant

92−

servant-server/src/Servant/Server/Internal.hs+143−376

@@ -1,54 +1,49 @@

1−{-# LANGUAGE AllowAmbiguousTypes #-}

2−{-# LANGUAGE ConstraintKinds #-}

3{-# LANGUAGE CPP #-}

1{-# LANGUAGE CPP #-}

2+{-# LANGUAGE ConstraintKinds #-}

4{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE DataKinds #-}

5{-# LANGUAGE DeriveDataTypeable #-}

4{-# LANGUAGE DeriveDataTypeable #-}

6{-# LANGUAGE FlexibleContexts #-}

5{-# LANGUAGE FlexibleContexts #-}

7{-# LANGUAGE FlexibleInstances #-}

6{-# LANGUAGE FlexibleInstances #-}

8−{-# LANGUAGE InstanceSigs #-}

9−{-# LANGUAGE LambdaCase #-}

10{-# LANGUAGE MultiParamTypeClasses #-}

7{-# LANGUAGE MultiParamTypeClasses #-}

11{-# LANGUAGE OverloadedStrings #-}

8{-# LANGUAGE OverloadedStrings #-}

12{-# LANGUAGE PolyKinds #-}

9{-# LANGUAGE PolyKinds #-}

13−{-# LANGUAGE QuantifiedConstraints #-}

14{-# LANGUAGE RankNTypes #-}

10{-# LANGUAGE RankNTypes #-}

15{-# LANGUAGE ScopedTypeVariables #-}

11{-# LANGUAGE ScopedTypeVariables #-}

16{-# LANGUAGE TupleSections #-}

12{-# LANGUAGE TupleSections #-}

17−{-# LANGUAGE TypeApplications #-}

18{-# LANGUAGE TypeFamilies #-}

13{-# LANGUAGE TypeFamilies #-}

19{-# LANGUAGE TypeOperators #-}

14{-# LANGUAGE TypeOperators #-}

20{-# LANGUAGE UndecidableInstances #-}

15{-# LANGUAGE UndecidableInstances #-}

21

16

17+#if MIN_VERSION_base(4,9,0) && __GLASGOW_HASKELL__ >= 802

18+#define HAS_TYPE_ERROR

19+#endif

20+

22module Servant.Server.Internal

21module Servant.Server.Internal

23 ( module Servant.Server.Internal

22 ( module Servant.Server.Internal

24 , module Servant.Server.Internal.BasicAuth

23 , module Servant.Server.Internal.BasicAuth

25 , module Servant.Server.Internal.Context

24 , module Servant.Server.Internal.Context

26− , module Servant.Server.Internal.Delayed

27− , module Servant.Server.Internal.DelayedIO

28− , module Servant.Server.Internal.ErrorFormatter

29 , module Servant.Server.Internal.Handler

25 , module Servant.Server.Internal.Handler

30 , module Servant.Server.Internal.Router

26 , module Servant.Server.Internal.Router

31− , module Servant.Server.Internal.RouteResult

32 , module Servant.Server.Internal.RoutingApplication

27 , module Servant.Server.Internal.RoutingApplication

33− , module Servant.Server.Internal.ServerError

28+ , module Servant.Server.Internal.ServantErr

34 ) where

29 ) where

35

30

36import Control.Monad

31import Control.Monad

37 (join, when)

32 (join, when)

38import Control.Monad.Trans

33import Control.Monad.Trans

39− (liftIO, lift)

34+ (liftIO)

40import Control.Monad.Trans.Resource

35import Control.Monad.Trans.Resource

41− (runResourceT, ReleaseKey)

36+ (runResourceT)

42−import Data.Acquire

43import qualified Data.ByteString as B

37import qualified Data.ByteString as B

44import qualified Data.ByteString.Builder as BB

38import qualified Data.ByteString.Builder as BB

45import qualified Data.ByteString.Char8 as BC8

39import qualified Data.ByteString.Char8 as BC8

46import qualified Data.ByteString.Lazy as BL

40import qualified Data.ByteString.Lazy as BL

47−import Data.Constraint (Constraint, Dict(..))

48import Data.Either

41import Data.Either

49 (partitionEithers)

42 (partitionEithers)

50import Data.Maybe

43import Data.Maybe

51 (fromMaybe, isNothing, mapMaybe, maybeToList)

44 (fromMaybe, isNothing, mapMaybe, maybeToList)

45+import Data.Semigroup

46+ ((<>))

52import Data.String

47import Data.String

53 (IsString (..))

48 (IsString (..))

54import Data.String.Conversions

49import Data.String.Conversions

@@ -57,70 +52,53 @@ import Data.Tagged

57 (Tagged (..), retag, untag)

52 (Tagged (..), retag, untag)

58import qualified Data.Text as T

53import qualified Data.Text as T

59import Data.Typeable

54import Data.Typeable

60−import GHC.Generics

61import GHC.TypeLits

55import GHC.TypeLits

62− (KnownNat, KnownSymbol, TypeError, symbolVal)

56+ (KnownNat, KnownSymbol, natVal, symbolVal)

63import qualified Network.HTTP.Media as NHM

57import qualified Network.HTTP.Media as NHM

64import Network.HTTP.Types hiding

58import Network.HTTP.Types hiding

65 (Header, ResponseHeaders)

59 (Header, ResponseHeaders)

66import Network.Socket

60import Network.Socket

67 (SockAddr)

61 (SockAddr)

68import Network.Wai

62import Network.Wai

69− (Application, Request, Response, ResponseReceived, httpVersion, isSecure, lazyRequestBody,

63+ (Application, Request, httpVersion, isSecure, lazyRequestBody,

70− queryString, remoteHost, getRequestBodyChunk, requestHeaders,

64+ rawQueryString, remoteHost, requestHeaders, requestMethod,

71− requestMethod, responseLBS, responseStream, vault)

65+ responseLBS, responseStream, vault)

72import Prelude ()

66import Prelude ()

73import Prelude.Compat

67import Prelude.Compat

74import Servant.API

68import Servant.API

75− ((:<|>) (..), (:>), Accept (..), BasicAuth, Capture',

69+ ((:<|>) (..), (:>), Accept (..), BasicAuth,

76− CaptureAll, Description, EmptyAPI, Fragment,

70+ BoundaryStrategy (..), Capture', CaptureAll, Description,

77− FramingRender (..), FramingUnrender (..), FromSourceIO (..),

78− Header', If, IsSecure (..), NoContentVerb, QueryFlag,

71+ EmptyAPI, FramingRender (..), Header', If, IsSecure (..),

79− QueryParam', QueryParams, Raw, RawM, ReflectMethod (reflectMethod),

72+ QueryFlag, QueryParam', QueryParams, Raw,

80− RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO,

73+ ReflectMethod (reflectMethod), RemoteHost, ReqBody',

74+ SBool (..), SBoolI (..), Stream, StreamGenerator (..),

81− Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb,

75+ Summary, ToStreamGenerator (..), Vault, Verb,

82− WithNamedContext, WithResource, NamedRoutes)

76+ WithNamedContext)

83−import Servant.API.Generic (GenericMode(..), ToServant, ToServantApi, GServantProduct, toServant, fromServant)

84import Servant.API.ContentTypes

77import Servant.API.ContentTypes

85 (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),

78 (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),

86− AllMime, MimeRender (..), MimeUnrender (..), NoContent,

87− canHandleAcceptH)

79+ AllMime, MimeRender (..), canHandleAcceptH)

88import Servant.API.Modifiers

80import Servant.API.Modifiers

89 (FoldLenient, FoldRequired, RequestArgument,

81 (FoldLenient, FoldRequired, RequestArgument,

90 unfoldRequestArgument)

82 unfoldRequestArgument)

91import Servant.API.ResponseHeaders

83import Servant.API.ResponseHeaders

92 (GetHeaders, Headers, getHeaders, getResponse)

84 (GetHeaders, Headers, getHeaders, getResponse)

93−import Servant.API.Status

94− (statusFromNat)

95−import qualified Servant.Types.SourceT as S

96−import Servant.API.TypeErrors

97import Web.HttpApiData

85import Web.HttpApiData

98− (FromHttpApiData, parseHeader, parseQueryParam, parseUrlPiece,

86+ (FromHttpApiData, parseHeader, parseQueryParam,

99− parseUrlPieces)

87+ parseUrlPieceMaybe, parseUrlPieces)

100−import Data.Kind

101− (Type)

102

88

103import Servant.Server.Internal.BasicAuth

89import Servant.Server.Internal.BasicAuth

104import Servant.Server.Internal.Context

90import Servant.Server.Internal.Context

105−import Servant.Server.Internal.Delayed

106−import Servant.Server.Internal.DelayedIO

107−import Servant.Server.Internal.ErrorFormatter

108import Servant.Server.Internal.Handler

91import Servant.Server.Internal.Handler

109import Servant.Server.Internal.Router

92import Servant.Server.Internal.Router

110−import Servant.Server.Internal.RouteResult

111import Servant.Server.Internal.RoutingApplication

93import Servant.Server.Internal.RoutingApplication

112−import Servant.Server.Internal.ServerError

94+import Servant.Server.Internal.ServantErr

113

95

96+#ifdef HAS_TYPE_ERROR

114import GHC.TypeLits

97import GHC.TypeLits

115 (ErrorMessage (..), TypeError)

98 (ErrorMessage (..), TypeError)

116−import Servant.API.TypeLevel

99+#endif

117− (AtLeastOneFragment, FragmentUnique)

118

100

119class HasServer api context where

101class HasServer api context where

120− -- | The type of a server for this API, given a monad to run effects in.

121− --

122− -- Note that the result kind is @*@, so it is /not/ a monad transformer, unlike

123− -- what the @T@ in the name might suggest.

124 type ServerT api (m :: * -> *) :: *

102 type ServerT api (m :: * -> *) :: *

125

103

126 route ::

104 route ::

@@ -182,31 +160,22 @@ instance (HasServer a context, HasServer b context) => HasServer (a :<|> b) cont

182-- > server = getBook

160-- > server = getBook

183-- > where getBook :: Text -> Handler Book

161-- > where getBook :: Text -> Handler Book

184-- > getBook isbn = ...

162-- > getBook isbn = ...

185−instance (KnownSymbol capture, FromHttpApiData a, Typeable a

163+instance (KnownSymbol capture, FromHttpApiData a, HasServer api context)

186− , HasServer api context, SBoolI (FoldLenient mods)

187− , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters

188− )

189 => HasServer (Capture' mods capture a :> api) context where

164 => HasServer (Capture' mods capture a :> api) context where

190

165

191 type ServerT (Capture' mods capture a :> api) m =

166 type ServerT (Capture' mods capture a :> api) m =

192− If (FoldLenient mods) (Either String a) a -> ServerT api m

167+ a -> ServerT api m

193

168

194 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s

169 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s

195

170

196 route Proxy context d =

171 route Proxy context d =

197− CaptureRouter [hint] $

172+ CaptureRouter $

198 route (Proxy :: Proxy api)

173 route (Proxy :: Proxy api)

199 context

174 context

200− (addCapture d $ \ txt -> withRequest $ \ request ->

175+ (addCapture d $ \ txt -> case parseUrlPieceMaybe txt of

201− case ( sbool :: SBool (FoldLenient mods)

176+ Nothing -> delayedFail err400

202− , parseUrlPiece txt :: Either T.Text a) of

203− (SFalse, Left e) -> delayedFail $ formatError rep request $ cs e

204− (SFalse, Right v) -> return v

177+ Just v -> return v

205− (STrue, piece) -> return $ (either (Left . cs) Right) piece)

178+ )

206− where

207− rep = typeRep (Proxy :: Proxy Capture')

208− formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)

209− hint = CaptureHint (T.pack $ symbolVal $ Proxy @capture) (typeRep (Proxy :: Proxy a))

210

179

211-- | If you use 'CaptureAll' in one of the endpoints for your API,

180-- | If you use 'CaptureAll' in one of the endpoints for your API,

212-- this automatically requires your server-side handler to be a

181-- this automatically requires your server-side handler to be a

@@ -225,10 +194,7 @@ instance (KnownSymbol capture, FromHttpApiData a, Typeable a

225-- > server = getSourceFile

194-- > server = getSourceFile

226-- > where getSourceFile :: [Text] -> Handler Book

195-- > where getSourceFile :: [Text] -> Handler Book

227-- > getSourceFile pathSegments = ...

196-- > getSourceFile pathSegments = ...

228−instance (KnownSymbol capture, FromHttpApiData a, Typeable a

197+instance (KnownSymbol capture, FromHttpApiData a, HasServer api context)

229− , HasServer api context

230− , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters

231− )

232 => HasServer (CaptureAll capture a :> api) context where

198 => HasServer (CaptureAll capture a :> api) context where

233

199

234 type ServerT (CaptureAll capture a :> api) m =

200 type ServerT (CaptureAll capture a :> api) m =

@@ -237,53 +203,13 @@ instance (KnownSymbol capture, FromHttpApiData a, Typeable a

237 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s

203 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s

238

204

239 route Proxy context d =

205 route Proxy context d =

240− CaptureAllRouter [hint] $

206+ CaptureAllRouter $

241 route (Proxy :: Proxy api)

207 route (Proxy :: Proxy api)

242 context

208 context

243− (addCapture d $ \ txts -> withRequest $ \ request ->

244− case parseUrlPieces txts of

209+ (addCapture d $ \ txts -> case parseUrlPieces txts of

245− Left e -> delayedFail $ formatError rep request $ cs e

210+ Left _ -> delayedFail err400

246− Right v -> return v

211+ Right v -> return v

247 )

212 )

248− where

249− rep = typeRep (Proxy :: Proxy CaptureAll)

250− formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)

251− hint = CaptureHint (T.pack $ symbolVal $ Proxy @capture) (typeRep (Proxy :: Proxy [a]))

252−

253−-- | If you use 'WithResource' in one of the endpoints for your API Servant

254−-- will provide the handler for this endpoint an argument of the specified type.

255−-- The lifespan of this resource will be automatically managed by Servant. This

256−-- resource will be created before the handler starts and it will be destoyed

257−-- after it ends. A new resource is created for each request to the endpoint.

258−

259−-- The creation and destruction are done using a 'Data.Acquire.Acquire'

260−-- provided via server 'Context'.

261−--

262−-- Example

263−--

264−-- > type MyApi = WithResource Handle :> "writeToFile" :> Post '[JSON] NoContent

265−-- >

266−-- > server :: Server MyApi

267−-- > server = writeToFile

268−-- > where writeToFile :: (ReleaseKey, Handle) -> Handler NoContent

269−-- > writeToFile (_, h) = hPutStrLn h "message"

270−--

271−-- In addition to the resource, the handler will also receive a 'ReleaseKey'

272−-- which can be used to deallocate the resource before the end of the request

273−-- if desired.

274−

275−instance (HasServer api ctx, HasContextEntry ctx (Acquire a))

276− => HasServer (WithResource a :> api) ctx where

277−

278− type ServerT (WithResource a :> api) m = (ReleaseKey, a) -> ServerT api m

279−

280− hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy @api) pc nt . s

281−

282− route Proxy context d = route (Proxy @api) context (d `addParameterCheck` allocateResource)

283− where

284− allocateResource :: DelayedIO (ReleaseKey, a)

285− allocateResource = DelayedIO $ lift $ allocateAcquire (getContextEntry context)

286−

287

213

288

214

289allowedMethodHead :: Method -> Request -> Bool

215allowedMethodHead :: Method -> Request -> Bool

@@ -304,10 +230,10 @@ methodCheck method request

304-- body check is no longer an option. However, we now run the accept

230-- body check is no longer an option. However, we now run the accept

305-- check before the body check and can therefore afford to make it

231-- check before the body check and can therefore afford to make it

306-- recoverable.

232-- recoverable.

307−acceptCheck :: (AllMime list) => Proxy list -> AcceptHeader -> DelayedIO ()

233+acceptCheck :: (AllMime list) => Proxy list -> B.ByteString -> DelayedIO ()

308acceptCheck proxy accH

234acceptCheck proxy accH

309− | canHandleAcceptH proxy accH = return ()

235+ | canHandleAcceptH proxy (AcceptHeader accH) = return ()

310− | otherwise = delayedFail err406

236+ | otherwise = delayedFail err406

311

237

312methodRouter :: (AllCTRender ctypes a)

238methodRouter :: (AllCTRender ctypes a)

313 => (b -> ([(HeaderName, B.ByteString)], a))

239 => (b -> ([(HeaderName, B.ByteString)], a))

@@ -317,28 +243,17 @@ methodRouter :: (AllCTRender ctypes a)

317methodRouter splitHeaders method proxy status action = leafRouter route'

243methodRouter splitHeaders method proxy status action = leafRouter route'

318 where

244 where

319 route' env request respond =

245 route' env request respond =

320− let accH = getAcceptHeader request

246+ let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

321 in runAction (action `addMethodCheck` methodCheck method request

247 in runAction (action `addMethodCheck` methodCheck method request

322 `addAcceptCheck` acceptCheck proxy accH

248 `addAcceptCheck` acceptCheck proxy accH

323 ) env request respond $ \ output -> do

249 ) env request respond $ \ output -> do

324 let (headers, b) = splitHeaders output

250 let (headers, b) = splitHeaders output

325− case handleAcceptH proxy accH b of

251+ case handleAcceptH proxy (AcceptHeader accH) b of

326 Nothing -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does

252 Nothing -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does

327 Just (contentT, body) ->

253 Just (contentT, body) ->

328 let bdy = if allowedMethodHead method request then "" else body

254 let bdy = if allowedMethodHead method request then "" else body

329 in Route $ responseLBS status ((hContentType, cs contentT) : headers) bdy

255 in Route $ responseLBS status ((hContentType, cs contentT) : headers) bdy

330

256

331−noContentRouter :: Method

332− -> Status

333− -> Delayed env (Handler b)

334− -> Router env

335−noContentRouter method status action = leafRouter route'

336− where

337− route' env request respond =

338− runAction (action `addMethodCheck` methodCheck method request)

339− env request respond $ \ _output ->

340− Route $ responseLBS status [] ""

341−

342instance {-# OVERLAPPABLE #-}

257instance {-# OVERLAPPABLE #-}

343 ( AllCTRender ctypes a, ReflectMethod method, KnownNat status

258 ( AllCTRender ctypes a, ReflectMethod method, KnownNat status

344 ) => HasServer (Verb method status ctypes a) context where

259 ) => HasServer (Verb method status ctypes a) context where

@@ -348,7 +263,7 @@ instance {-# OVERLAPPABLE #-}

348

263

349 route Proxy _ = methodRouter ([],) method (Proxy :: Proxy ctypes) status

264 route Proxy _ = methodRouter ([],) method (Proxy :: Proxy ctypes) status

350 where method = reflectMethod (Proxy :: Proxy method)

265 where method = reflectMethod (Proxy :: Proxy method)

351− status = statusFromNat (Proxy :: Proxy status)

266+ status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)

352

267

353instance {-# OVERLAPPING #-}

268instance {-# OVERLAPPING #-}

354 ( AllCTRender ctypes a, ReflectMethod method, KnownNat status

269 ( AllCTRender ctypes a, ReflectMethod method, KnownNat status

@@ -360,46 +275,37 @@ instance {-# OVERLAPPING #-}

360

275

361 route Proxy _ = methodRouter (\x -> (getHeaders x, getResponse x)) method (Proxy :: Proxy ctypes) status

276 route Proxy _ = methodRouter (\x -> (getHeaders x, getResponse x)) method (Proxy :: Proxy ctypes) status

362 where method = reflectMethod (Proxy :: Proxy method)

277 where method = reflectMethod (Proxy :: Proxy method)

363− status = statusFromNat (Proxy :: Proxy status)

278+ status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)

364−

365−instance (ReflectMethod method) =>

366− HasServer (NoContentVerb method) context where

367−

368− type ServerT (NoContentVerb method) m = m NoContent

369− hoistServerWithContext _ _ nt s = nt s

370

279

371− route Proxy _ = noContentRouter method status204

372− where method = reflectMethod (Proxy :: Proxy method)

373

280

374instance {-# OVERLAPPABLE #-}

281instance {-# OVERLAPPABLE #-}

375− ( MimeRender ctype chunk, ReflectMethod method, KnownNat status,

282+ ( MimeRender ctype a, ReflectMethod method, KnownNat status,

376− FramingRender framing, ToSourceIO chunk a

283+ FramingRender framing ctype, ToStreamGenerator b a

377− ) => HasServer (Stream method status framing ctype a) context where

284+ ) => HasServer (Stream method status framing ctype b) context where

378

285

379− type ServerT (Stream method status framing ctype a) m = m a

286+ type ServerT (Stream method status framing ctype b) m = m b

380 hoistServerWithContext _ _ nt s = nt s

287 hoistServerWithContext _ _ nt s = nt s

381

288

382 route Proxy _ = streamRouter ([],) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)

289 route Proxy _ = streamRouter ([],) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)

383 where method = reflectMethod (Proxy :: Proxy method)

290 where method = reflectMethod (Proxy :: Proxy method)

384− status = statusFromNat (Proxy :: Proxy status)

291+ status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)

385−

386

292

387instance {-# OVERLAPPING #-}

293instance {-# OVERLAPPING #-}

388− ( MimeRender ctype chunk, ReflectMethod method, KnownNat status,

294+ ( MimeRender ctype a, ReflectMethod method, KnownNat status,

389− FramingRender framing, ToSourceIO chunk a,

295+ FramingRender framing ctype, ToStreamGenerator b a,

390− GetHeaders (Headers h a)

296+ GetHeaders (Headers h b)

391− ) => HasServer (Stream method status framing ctype (Headers h a)) context where

297+ ) => HasServer (Stream method status framing ctype (Headers h b)) context where

392

298

393− type ServerT (Stream method status framing ctype (Headers h a)) m = m (Headers h a)

299+ type ServerT (Stream method status framing ctype (Headers h b)) m = m (Headers h b)

394 hoistServerWithContext _ _ nt s = nt s

300 hoistServerWithContext _ _ nt s = nt s

395

301

396 route Proxy _ = streamRouter (\x -> (getHeaders x, getResponse x)) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)

302 route Proxy _ = streamRouter (\x -> (getHeaders x, getResponse x)) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)

397 where method = reflectMethod (Proxy :: Proxy method)

303 where method = reflectMethod (Proxy :: Proxy method)

398− status = statusFromNat (Proxy :: Proxy status)

304+ status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)

399

305

400

306

401−streamRouter :: forall ctype a c chunk env framing. (MimeRender ctype chunk, FramingRender framing, ToSourceIO chunk a) =>

307+streamRouter :: (MimeRender ctype a, FramingRender framing ctype, ToStreamGenerator b a) =>

402− (c -> ([(HeaderName, B.ByteString)], a))

308+ (c -> ([(HeaderName, B.ByteString)], b))

403 -> Method

309 -> Method

404 -> Status

310 -> Status

405 -> Proxy framing

311 -> Proxy framing

@@ -407,7 +313,7 @@ streamRouter :: forall ctype a c chunk env framing. (MimeRender ctype chunk, Fra

407 -> Delayed env (Handler c)

313 -> Delayed env (Handler c)

408 -> Router env

314 -> Router env

409streamRouter splitHeaders method status framingproxy ctypeproxy action = leafRouter $ \env request respond ->

315streamRouter splitHeaders method status framingproxy ctypeproxy action = leafRouter $ \env request respond ->

410− let AcceptHeader accH = getAcceptHeader request

316+ let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

411 cmediatype = NHM.matchAccept [contentType ctypeproxy] accH

317 cmediatype = NHM.matchAccept [contentType ctypeproxy] accH

412 accCheck = when (isNothing cmediatype) $ delayedFail err406

318 accCheck = when (isNothing cmediatype) $ delayedFail err406

413 contentHeader = (hContentType, NHM.renderHeader . maybeToList $ cmediatype)

319 contentHeader = (hContentType, NHM.renderHeader . maybeToList $ cmediatype)

@@ -415,19 +321,28 @@ streamRouter splitHeaders method status framingproxy ctypeproxy action = leafRou

415 `addAcceptCheck` accCheck

321 `addAcceptCheck` accCheck

416 ) env request respond $ \ output ->

322 ) env request respond $ \ output ->

417 let (headers, fa) = splitHeaders output

323 let (headers, fa) = splitHeaders output

418− sourceT = toSourceIO fa

324+ k = getStreamGenerator . toStreamGenerator $ fa in

419− S.SourceT kStepLBS = framingRender framingproxy (mimeRender ctypeproxy :: chunk -> BL.ByteString) sourceT

420− in Route $ responseStream status (contentHeader : headers) $ \write flush -> do

325+ Route $ responseStream status (contentHeader : headers) $ \write flush -> do

421− let loop S.Stop = flush

326+ write . BB.lazyByteString $ header framingproxy ctypeproxy

422− loop (S.Error err) = fail err -- TODO: throw better error

327+ case boundary framingproxy ctypeproxy of

423− loop (S.Skip s) = loop s

328+ BoundaryStrategyBracket f ->

424− loop (S.Effect ms) = ms >>= loop

329+ let go x = let bs = mimeRender ctypeproxy x

425− loop (S.Yield lbs s) = do

330+ (before, after) = f bs

331+ in write ( BB.lazyByteString before

332+ <> BB.lazyByteString bs

333+ <> BB.lazyByteString after) >> flush

334+ in k go go

335+ BoundaryStrategyIntersperse sep -> k

336+ (\x -> do

337+ write . BB.lazyByteString . mimeRender ctypeproxy $ x

338+ flush)

339+ (\x -> do

426− write (BB.lazyByteString lbs)

340+ write . (BB.lazyByteString sep <>) . BB.lazyByteString . mimeRender ctypeproxy $ x

427− flush

341+ flush)

428− loop s

342+ BoundaryStrategyGeneral f ->

429−

343+ let go = (>> flush) . write . BB.lazyByteString . f . mimeRender ctypeproxy

430− kStepLBS loop

344+ in k go go

345+ write . BB.lazyByteString $ trailer framingproxy ctypeproxy

431

346

432-- | If you use 'Header' in one of the endpoints for your API,

347-- | If you use 'Header' in one of the endpoints for your API,

433-- this automatically requires your server-side handler to be a function

348-- this automatically requires your server-side handler to be a function

@@ -452,7 +367,6 @@ streamRouter splitHeaders method status framingproxy ctypeproxy action = leafRou

452instance

367instance

453 (KnownSymbol sym, FromHttpApiData a, HasServer api context

368 (KnownSymbol sym, FromHttpApiData a, HasServer api context

454 , SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)

369 , SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)

455− , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters

456 )

370 )

457 => HasServer (Header' mods sym a :> api) context where

371 => HasServer (Header' mods sym a :> api) context where

458------

372------

@@ -464,9 +378,6 @@ instance

464 route Proxy context subserver = route (Proxy :: Proxy api) context $

378 route Proxy context subserver = route (Proxy :: Proxy api) context $

465 subserver `addHeaderCheck` withRequest headerCheck

379 subserver `addHeaderCheck` withRequest headerCheck

466 where

380 where

467− rep = typeRep (Proxy :: Proxy Header')

468− formatError = headerParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)

469−

470 headerName :: IsString n => n

381 headerName :: IsString n => n

471 headerName = fromString $ symbolVal (Proxy :: Proxy sym)

382 headerName = fromString $ symbolVal (Proxy :: Proxy sym)

472

383

@@ -477,13 +388,15 @@ instance

477 mev :: Maybe (Either T.Text a)

388 mev :: Maybe (Either T.Text a)

478 mev = fmap parseHeader $ lookup headerName (requestHeaders req)

389 mev = fmap parseHeader $ lookup headerName (requestHeaders req)

479

390

480− errReq = delayedFailFatal $ formatError rep req

391+ errReq = delayedFailFatal err400

481− $ "Header " <> headerName <> " is required"

392+ { errBody = "Header " <> headerName <> " is required"

393+ }

482

394

483− errSt e = delayedFailFatal $ formatError rep req

395+ errSt e = delayedFailFatal err400

484− $ cs $ "Error parsing header "

396+ { errBody = cs $ "Error parsing header "

485− <> headerName

397+ <> headerName

486− <> " failed: " <> e

398+ <> " failed: " <> e

399+ }

487

400

488-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,

401-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,

489-- this automatically requires your server-side handler to be a function

402-- this automatically requires your server-side handler to be a function

@@ -509,7 +422,6 @@ instance

509instance

422instance

510 ( KnownSymbol sym, FromHttpApiData a, HasServer api context

423 ( KnownSymbol sym, FromHttpApiData a, HasServer api context

511 , SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)

424 , SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)

512− , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters

513 )

425 )

514 => HasServer (QueryParam' mods sym a :> api) context where

426 => HasServer (QueryParam' mods sym a :> api) context where

515------

427------

@@ -519,12 +431,9 @@ instance

519 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s

431 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s

520

432

521 route Proxy context subserver =

433 route Proxy context subserver =

522− let querytext = queryToQueryText . queryString

434+ let querytext req = parseQueryText $ rawQueryString req

523 paramname = cs $ symbolVal (Proxy :: Proxy sym)

435 paramname = cs $ symbolVal (Proxy :: Proxy sym)

524

436

525− rep = typeRep (Proxy :: Proxy QueryParam')

526− formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)

527−

528 parseParam :: Request -> DelayedIO (RequestArgument mods a)

437 parseParam :: Request -> DelayedIO (RequestArgument mods a)

529 parseParam req =

438 parseParam req =

530 unfoldRequestArgument (Proxy :: Proxy mods) errReq errSt mev

439 unfoldRequestArgument (Proxy :: Proxy mods) errReq errSt mev

@@ -532,12 +441,14 @@ instance

532 mev :: Maybe (Either T.Text a)

441 mev :: Maybe (Either T.Text a)

533 mev = fmap parseQueryParam $ join $ lookup paramname $ querytext req

442 mev = fmap parseQueryParam $ join $ lookup paramname $ querytext req

534

443

535− errReq = delayedFailFatal $ formatError rep req

444+ errReq = delayedFailFatal err400

536− $ cs $ "Query parameter " <> paramname <> " is required"

445+ { errBody = cs $ "Query parameter " <> paramname <> " is required"

446+ }

537

447

538− errSt e = delayedFailFatal $ formatError rep req

448+ errSt e = delayedFailFatal err400

539− $ cs $ "Error parsing query parameter "

449+ { errBody = cs $ "Error parsing query parameter "

540− <> paramname <> " failed: " <> e

450+ <> paramname <> " failed: " <> e

451+ }

541

452

542 delayed = addParameterCheck subserver . withRequest $ \req ->

453 delayed = addParameterCheck subserver . withRequest $ \req ->

543 parseParam req

454 parseParam req

@@ -563,8 +474,7 @@ instance

563-- > server = getBooksBy

474-- > server = getBooksBy

564-- > where getBooksBy :: [Text] -> Handler [Book]

475-- > where getBooksBy :: [Text] -> Handler [Book]

565-- > getBooksBy authors = ...return all books by these authors...

476-- > getBooksBy authors = ...return all books by these authors...

566−instance (KnownSymbol sym, FromHttpApiData a, HasServer api context

477+instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)

567− , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters)

568 => HasServer (QueryParams sym a :> api) context where

478 => HasServer (QueryParams sym a :> api) context where

569

479

570 type ServerT (QueryParams sym a :> api) m =

480 type ServerT (QueryParams sym a :> api) m =

@@ -575,23 +485,21 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer api context

575 route Proxy context subserver = route (Proxy :: Proxy api) context $

485 route Proxy context subserver = route (Proxy :: Proxy api) context $

576 subserver `addParameterCheck` withRequest paramsCheck

486 subserver `addParameterCheck` withRequest paramsCheck

577 where

487 where

578− rep = typeRep (Proxy :: Proxy QueryParams)

579− formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)

580−

581 paramname = cs $ symbolVal (Proxy :: Proxy sym)

488 paramname = cs $ symbolVal (Proxy :: Proxy sym)

582 paramsCheck req =

489 paramsCheck req =

583 case partitionEithers $ fmap parseQueryParam params of

490 case partitionEithers $ fmap parseQueryParam params of

584 ([], parsed) -> return parsed

491 ([], parsed) -> return parsed

585− (errs, _) -> delayedFailFatal $ formatError rep req

492+ (errs, _) -> delayedFailFatal err400

586− $ cs $ "Error parsing query parameter(s) "

493+ { errBody = cs $ "Error parsing query parameter(s) "

587− <> paramname <> " failed: "

494+ <> paramname <> " failed: "

588− <> T.intercalate ", " errs

495+ <> T.intercalate ", " errs

496+ }

589 where

497 where

590 params :: [T.Text]

498 params :: [T.Text]

591 params = mapMaybe snd

499 params = mapMaybe snd

592 . filter (looksLikeParam . fst)

500 . filter (looksLikeParam . fst)

593− . queryToQueryText

501+ . parseQueryText

594− . queryString

502+ . rawQueryString

595 $ req

503 $ req

596

504

597 looksLikeParam name = name == paramname || name == (paramname <> "[]")

505 looksLikeParam name = name == paramname || name == (paramname <> "[]")

@@ -617,7 +525,7 @@ instance (KnownSymbol sym, HasServer api context)

617 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s

525 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s

618

526

619 route Proxy context subserver =

527 route Proxy context subserver =

620− let querytext = queryToQueryText . queryString

528+ let querytext r = parseQueryText $ rawQueryString r

621 param r = case lookup paramname (querytext r) of

529 param r = case lookup paramname (querytext r) of

622 Just Nothing -> True -- param is there, with no value

530 Just Nothing -> True -- param is there, with no value

623 Just (Just v) -> examine v -- param with a value

531 Just (Just v) -> examine v -- param with a value

@@ -653,42 +561,13 @@ instance HasServer Raw context where

653 Fail a -> respond $ Fail a

561 Fail a -> respond $ Fail a

654 FailFatal e -> respond $ FailFatal e

562 FailFatal e -> respond $ FailFatal e

655

563

656−-- | Just pass the request to the underlying application and serve its response.

657−--

658−-- Example:

659−--

660−-- > type MyApi = "images" :> Raw

661−-- >

662−-- > server :: Server MyApi

663−-- > server = serveDirectory "/var/www/images"

664−instance HasServer RawM context where

665− type ServerT RawM m = Request -> (Response -> IO ResponseReceived) -> m ResponseReceived

666−

667− route

668− :: Proxy RawM

669− -> Context context

670− -> Delayed env (Request -> (Response -> IO ResponseReceived) -> Handler ResponseReceived) -> Router env

671− route _ _ handleDelayed = RawRouter $ \env request respond -> runResourceT $ do

672− routeResult <- runDelayed handleDelayed env request

673− let respond' = liftIO . respond

674− liftIO $ case routeResult of

675− Route handler -> runHandler (handler request (respond . Route)) >>=

676− \case

677− Left e -> respond' $ FailFatal e

678− Right a -> pure a

679− Fail e -> respond' $ Fail e

680− FailFatal e -> respond' $ FailFatal e

681−

682− hoistServerWithContext _ _ f srvM = \req respond -> f (srvM req respond)

683−

684−

685-- | If you use 'ReqBody' in one of the endpoints for your API,

564-- | If you use 'ReqBody' in one of the endpoints for your API,

686-- this automatically requires your server-side handler to be a function

565-- this automatically requires your server-side handler to be a function

687-- that takes an argument of the type specified by 'ReqBody'.

566-- that takes an argument of the type specified by 'ReqBody'.

688-- The @Content-Type@ header is inspected, and the list provided is used to

567-- The @Content-Type@ header is inspected, and the list provided is used to

689-- attempt deserialization. If the request does not have a @Content-Type@

568-- attempt deserialization. If the request does not have a @Content-Type@

690-- header, it is treated as @application/octet-stream@ (as specified in

569-- header, it is treated as @application/octet-stream@ (as specified in

691−-- [RFC 7231 section 3.1.1.5](http://tools.ietf.org/html/rfc7231#section-3.1.1.5)).

570+-- <http://tools.ietf.org/html/rfc7231#section-3.1.1.5 RFC7231>.

692-- This lets servant worry about extracting it from the request and turning

571-- This lets servant worry about extracting it from the request and turning

693-- it into a value of the type you specify.

572-- it into a value of the type you specify.

694--

573--

@@ -704,7 +583,6 @@ instance HasServer RawM context where

704-- > where postBook :: Book -> Handler Book

583-- > where postBook :: Book -> Handler Book

705-- > postBook book = ...insert into your db...

584-- > postBook book = ...insert into your db...

706instance ( AllCTUnrender list a, HasServer api context, SBoolI (FoldLenient mods)

585instance ( AllCTUnrender list a, HasServer api context, SBoolI (FoldLenient mods)

707− , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters

708 ) => HasServer (ReqBody' mods list a :> api) context where

586 ) => HasServer (ReqBody' mods list a :> api) context where

709

587

710 type ServerT (ReqBody' mods list a :> api) m =

588 type ServerT (ReqBody' mods list a :> api) m =

@@ -716,9 +594,6 @@ instance ( AllCTUnrender list a, HasServer api context, SBoolI (FoldLenient mods

716 = route (Proxy :: Proxy api) context $

594 = route (Proxy :: Proxy api) context $

717 addBodyCheck subserver ctCheck bodyCheck

595 addBodyCheck subserver ctCheck bodyCheck

718 where

596 where

719− rep = typeRep (Proxy :: Proxy ReqBody')

720− formatError = bodyParserErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)

721−

722 -- Content-Type check, we only lookup we can try to parse the request body

597 -- Content-Type check, we only lookup we can try to parse the request body

723 ctCheck = withRequest $ \ request -> do

598 ctCheck = withRequest $ \ request -> do

724 -- See HTTP RFC 2616, section 7.2.1

599 -- See HTTP RFC 2616, section 7.2.1

@@ -737,34 +612,9 @@ instance ( AllCTUnrender list a, HasServer api context, SBoolI (FoldLenient mods

737 case sbool :: SBool (FoldLenient mods) of

612 case sbool :: SBool (FoldLenient mods) of

738 STrue -> return mrqbody

613 STrue -> return mrqbody

739 SFalse -> case mrqbody of

614 SFalse -> case mrqbody of

740− Left e -> delayedFailFatal $ formatError rep request e

615+ Left e -> delayedFailFatal err400 { errBody = cs e }

741 Right v -> return v

616 Right v -> return v

742

617

743−instance

744− ( FramingUnrender framing, FromSourceIO chunk a, MimeUnrender ctype chunk

745− , HasServer api context

746− ) => HasServer (StreamBody' mods framing ctype a :> api) context

747− where

748− type ServerT (StreamBody' mods framing ctype a :> api) m = a -> ServerT api m

749−

750− hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s

751−

752− route Proxy context subserver = route (Proxy :: Proxy api) context $

753− addBodyCheck subserver ctCheck bodyCheck

754− where

755− ctCheck :: DelayedIO (SourceIO chunk -> a)

756− -- TODO: do content-type check

757− ctCheck = return fromSourceIO

758−

759− bodyCheck :: (SourceIO chunk -> a) -> DelayedIO a

760− bodyCheck fromRS = withRequest $ \req -> do

761− let mimeUnrender' = mimeUnrender (Proxy :: Proxy ctype) :: BL.ByteString -> Either String chunk

762− let framingUnrender' = framingUnrender (Proxy :: Proxy framing) mimeUnrender' :: SourceIO B.ByteString -> SourceIO chunk

763− let body = getRequestBodyChunk req

764− let rs = S.fromAction B.null body

765− let rs' = fromRS $ framingUnrender' rs

766− return rs'

767−

768-- | Make sure the incoming request starts with @"/path"@, strip it and

618-- | Make sure the incoming request starts with @"/path"@, strip it and

769-- pass the rest of the request path to @api@.

619-- pass the rest of the request path to @api@.

770instance (KnownSymbol path, HasServer api context) => HasServer (path :> api) context where

620instance (KnownSymbol path, HasServer api context) => HasServer (path :> api) context where

@@ -829,12 +679,12 @@ data EmptyServer = EmptyServer deriving (Typeable, Eq, Show, Bounded, Enum)

829emptyServer :: ServerT EmptyAPI m

679emptyServer :: ServerT EmptyAPI m

830emptyServer = Tagged EmptyServer

680emptyServer = Tagged EmptyServer

831

681

832−-- | The server for an `EmptyAPI` is `emptyServer`.

682+-- | The server for an `EmptyAPI` is `emptyAPIServer`.

833--

683--

834-- > type MyApi = "nothing" :> EmptyApi

684-- > type MyApi = "nothing" :> EmptyApi

835-- >

685-- >

836-- > server :: Server MyApi

686-- > server :: Server MyApi

837−-- > server = emptyServer

687+-- > server = emptyAPIServer

838instance HasServer EmptyAPI context where

688instance HasServer EmptyAPI context where

839 type ServerT EmptyAPI m = Tagged m EmptyServer

689 type ServerT EmptyAPI m = Tagged m EmptyServer

840

690

@@ -863,10 +713,7 @@ instance ( KnownSymbol realm

863-- * helpers

713-- * helpers

864

714

865ct_wildcard :: B.ByteString

715ct_wildcard :: B.ByteString

866−ct_wildcard = "*" <> "/" <> "*"

716+ct_wildcard = "*" <> "/" <> "*" -- Because CPP

867−

868−getAcceptHeader :: Request -> AcceptHeader

869−getAcceptHeader = AcceptHeader . fromMaybe ct_wildcard . lookup hAccept . requestHeaders

870

717

871-- * General Authentication

718-- * General Authentication

872

719

@@ -891,19 +738,39 @@ instance (HasContextEntry context (NamedContext name subContext), HasServer subA

891 hoistServerWithContext _ _ nt s = hoistServerWithContext (Proxy :: Proxy subApi) (Proxy :: Proxy subContext) nt s

738 hoistServerWithContext _ _ nt s = hoistServerWithContext (Proxy :: Proxy subApi) (Proxy :: Proxy subContext) nt s

892

739

893-------------------------------------------------------------------------------

740-------------------------------------------------------------------------------

894−-- Custom type errors

741+-- TypeError helpers

895-------------------------------------------------------------------------------

742-------------------------------------------------------------------------------

896

743

897−-- Erroring instance for 'HasServer' when a combinator is not fully applied

744+#ifdef HAS_TYPE_ERROR

898−instance TypeError (PartialApplication

745+-- | This instance catches mistakes when there are non-saturated

899−#if __GLASGOW_HASKELL__ >= 904

746+-- type applications on LHS of ':>'.

900− @(Type -> [Type] -> Constraint)

747+--

901−#endif

748+-- >>> serve (Proxy :: Proxy (Capture "foo" :> Get '[JSON] Int)) (error "...")

749+-- ...

750+-- ...Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'.

751+-- ...Maybe you haven't applied enough arguments to

752+-- ...Capture' '[] "foo"

753+-- ...

754+--

755+-- >>> undefined :: Server (Capture "foo" :> Get '[JSON] Int)

756+-- ...

757+-- ...Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'.

758+-- ...Maybe you haven't applied enough arguments to

759+-- ...Capture' '[] "foo"

760+-- ...

761+--

902− HasServer arr) => HasServer ((arr :: a -> b) :> sub) context

762+instance TypeError (HasServerArrowKindError arr) => HasServer ((arr :: k -> l) :> api) context

903 where

763 where

904− type ServerT (arr :> sub) _ = TypeError (PartialApplication (HasServer :: * -> [*] -> Constraint) arr)

764+ type ServerT (arr :> api) m = TypeError (HasServerArrowKindError arr)

905− route = error "unreachable"

765+ -- it doens't really matter what sub route we peak

766+ route _ _ _ = error "servant-server panic: impossible happened in HasServer (arr :> api)"

906− hoistServerWithContext _ _ _ _ = error "unreachable"

767+ hoistServerWithContext _ _ _ = id

768+

769+-- Cannot have TypeError here, otherwise use of this symbol will error :)

770+type HasServerArrowKindError arr =

771+ 'Text "Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'."

772+ ':$$: 'Text "Maybe you haven't applied enough arguments to"

773+ ':$$: 'ShowType arr

907

774

908-- | This instance prevents from accidentally using '->' instead of ':>'

775-- | This instance prevents from accidentally using '->' instead of ':>'

909--

776--

@@ -937,107 +804,7 @@ type HasServerArrowTypeError a b =

937 ':$$: 'ShowType a

804 ':$$: 'ShowType a

938 ':$$: 'Text "and"

805 ':$$: 'Text "and"

939 ':$$: 'ShowType b

806 ':$$: 'ShowType b

940−

941−-- Erroring instances for 'HasServer' for unknown API combinators

942−

943−-- XXX: This omits the @context@ parameter, e.g.:

944−--

945−-- "There is no instance for HasServer (Bool :> …)". Do we care ?

946−instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub

947−#if __GLASGOW_HASKELL__ >= 904

948− @(Type -> [Type] -> Constraint)

949#endif

807#endif

950− HasServer ty) => HasServer (ty :> sub) context

951−

952−instance {-# OVERLAPPABLE #-} TypeError (NoInstanceFor (HasServer api context)) => HasServer api context

953−

954−-- | Ignore @'Fragment'@ in server handlers.

955−-- See <https://ietf.org/rfc/rfc2616.html#section-15.1.3> for more details.

956−--

957−-- Example:

958−--

959−-- > type MyApi = "books" :> Fragment Text :> Get '[JSON] [Book]

960−-- >

961−-- > server :: Server MyApi

962−-- > server = getBooks

963−-- > where getBooks :: Handler [Book]

964−-- > getBooks = ...return all books...

965−instance (AtLeastOneFragment api, FragmentUnique (Fragment a1 :> api), HasServer api context)

966− => HasServer (Fragment a1 :> api) context where

967− type ServerT (Fragment a1 :> api) m = ServerT api m

968−

969− route _ = route (Proxy :: Proxy api)

970−

971− hoistServerWithContext _ = hoistServerWithContext (Proxy :: Proxy api)

972

808

973-- $setup

809-- $setup

974-- >>> import Servant

810-- >>> import Servant

975−

976−-- | A type that specifies that an API record contains a server implementation.

977−data AsServerT (m :: * -> *)

978−instance GenericMode (AsServerT m) where

979− type AsServerT m :- api = ServerT api m

980−

981−type AsServer = AsServerT Handler

982−

983−

984−-- | Set of constraints required to convert to / from vanilla server types.

985−type GServerConstraints api m =

986− ( ToServant api (AsServerT m) ~ ServerT (ToServantApi api) m

987− , GServantProduct (Rep (api (AsServerT m)))

988− )

989−

990−-- | This class is a necessary evil: in the implementation of 'HasServer' for

991−-- @'NamedRoutes' api@, we essentially need the quantified constraint @forall

992−-- m. 'GServerConstraints' m@ to hold.

993−--

994−-- We cannot require do that directly as the definition of 'GServerConstraints'

995−-- contains type family applications ('Rep' and 'ServerT'). The trick is to hide

996−-- those type family applications behind a typeclass providing evidence for

997−-- @'GServerConstraints' api m@ in the form of a dictionary, and require that

998−-- @forall m. 'GServer' api m@ instead.

999−--

1000−-- Users shouldn't have to worry about this class, as the only possible instance

1001−-- is provided in this module for all record APIs.

1002−

1003−class GServer (api :: * -> *) (m :: * -> *) where

1004− gServerProof :: Dict (GServerConstraints api m)

1005−

1006−instance

1007− ( ToServant api (AsServerT m) ~ ServerT (ToServantApi api) m

1008− , GServantProduct (Rep (api (AsServerT m)))

1009− ) => GServer api m where

1010− gServerProof = Dict

1011−

1012−instance

1013− ( HasServer (ToServantApi api) context

1014− , forall m. Generic (api (AsServerT m))

1015− , forall m. GServer api m

1016− ) => HasServer (NamedRoutes api) context where

1017−

1018− type ServerT (NamedRoutes api) m = api (AsServerT m)

1019−

1020− route

1021− :: Proxy (NamedRoutes api)

1022− -> Context context

1023− -> Delayed env (api (AsServerT Handler))

1024− -> Router env

1025− route _ ctx delayed =

1026− case gServerProof @api @Handler of

1027− Dict -> route (Proxy @(ToServantApi api)) ctx (toServant <$> delayed)

1028−

1029− hoistServerWithContext

1030− :: forall m n. Proxy (NamedRoutes api)

1031− -> Proxy context

1032− -> (forall x. m x -> n x)

1033− -> api (AsServerT m)

1034− -> api (AsServerT n)

1035− hoistServerWithContext _ pctx nat server =

1036− case (gServerProof @api @m, gServerProof @api @n) of

1037− (Dict, Dict) ->

1038− fromServant servantSrvN

1039− where

1040− servantSrvM :: ServerT (ToServantApi api) m =

1041− toServant server

1042− servantSrvN :: ServerT (ToServantApi api) n =

1043− hoistServerWithContext (Proxy @(ToServantApi api)) pctx nat servantSrvM

servant-server/src/Servant/Server/Internal/BasicAuth.hs+6−4

@@ -9,9 +9,11 @@ import Control.Monad

9 (guard)

9 (guard)

10import Control.Monad.Trans

10import Control.Monad.Trans

11 (liftIO)

11 (liftIO)

12−import qualified Data.ByteString as BS

12+import qualified Data.ByteString as BS

13import Data.ByteString.Base64

13import Data.ByteString.Base64

14 (decodeLenient)

14 (decodeLenient)

15+import Data.Monoid

16+ ((<>))

15import Data.Typeable

17import Data.Typeable

16 (Typeable)

18 (Typeable)

17import Data.Word8

19import Data.Word8

@@ -24,13 +26,13 @@ import Network.Wai

24

26

25import Servant.API.BasicAuth

27import Servant.API.BasicAuth

26 (BasicAuthData (BasicAuthData))

28 (BasicAuthData (BasicAuthData))

27−import Servant.Server.Internal.DelayedIO

29+import Servant.Server.Internal.RoutingApplication

28−import Servant.Server.Internal.ServerError

30+import Servant.Server.Internal.ServantErr

29

31

30-- * Basic Auth

32-- * Basic Auth

31

33

32-- | servant-server's current implementation of basic authentication is not

34-- | servant-server's current implementation of basic authentication is not

33−-- immune to certain kinds of timing attacks. Decoding payloads does not take

35+-- immune to certian kinds of timing attacks. Decoding payloads does not take

34-- a fixed amount of time.

36-- a fixed amount of time.

35

37

36-- | The result of authentication/authorization

38-- | The result of authentication/authorization

servant-server/src/Servant/Server/Internal/Context.hs+9−24

@@ -1,12 +1,11 @@

1−{-# LANGUAGE DataKinds #-}

1+{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE FlexibleContexts #-}

2+{-# LANGUAGE FlexibleContexts #-}

3−{-# LANGUAGE FlexibleInstances #-}

3+{-# LANGUAGE FlexibleInstances #-}

4−{-# LANGUAGE GADTs #-}

4+{-# LANGUAGE GADTs #-}

5−{-# LANGUAGE KindSignatures #-}

5+{-# LANGUAGE KindSignatures #-}

6−{-# LANGUAGE MultiParamTypeClasses #-}

6+{-# LANGUAGE MultiParamTypeClasses #-}

7−{-# LANGUAGE ScopedTypeVariables #-}

7+{-# LANGUAGE ScopedTypeVariables #-}

8−{-# LANGUAGE TypeFamilies #-}

9−{-# LANGUAGE TypeOperators #-}

8+{-# LANGUAGE TypeOperators #-}

10

9

11module Servant.Server.Internal.Context where

10module Servant.Server.Internal.Context where

12

11

@@ -21,7 +20,7 @@ import GHC.TypeLits

21--

20--

22-- If you are using combinators that require a non-empty 'Context' you have to

21-- If you are using combinators that require a non-empty 'Context' you have to

23-- use 'Servant.Server.serveWithContext' and pass it a 'Context' that contains all

22-- use 'Servant.Server.serveWithContext' and pass it a 'Context' that contains all

24−-- the values your combinators need. A 'Context' is essentially a heterogeneous

23+-- the values your combinators need. A 'Context' is essentially a heterogenous

25-- list and accessing the elements is being done by type (see 'getContextEntry').

24-- list and accessing the elements is being done by type (see 'getContextEntry').

26-- The parameter of the type 'Context' is a type-level list reflecting the types

25-- The parameter of the type 'Context' is a type-level list reflecting the types

27-- of the contained context entries. To create a 'Context' with entries, use the

26-- of the contained context entries. To create a 'Context' with entries, use the

@@ -46,20 +45,6 @@ instance Eq (Context '[]) where

46instance (Eq a, Eq (Context as)) => Eq (Context (a ': as)) where

45instance (Eq a, Eq (Context as)) => Eq (Context (a ': as)) where

47 x1 :. y1 == x2 :. y2 = x1 == x2 && y1 == y2

46 x1 :. y1 == x2 :. y2 = x1 == x2 && y1 == y2

48

47

49−-- | Append two type-level lists.

50−--

51−-- Hint: import it as

52−--

53−-- > import Servant.Server (type (.++))

54−type family (.++) (l1 :: [*]) (l2 :: [*]) where

55− '[] .++ a = a

56− (a ': as) .++ b = a ': (as .++ b)

57−

58−-- | Append two contexts.

59−(.++) :: Context l1 -> Context l2 -> Context (l1 .++ l2)

60−EmptyContext .++ a = a

61−(a :. as) .++ b = a :. (as .++ b)

62−

63-- | This class is used to access context entries in 'Context's. 'getContextEntry'

48-- | This class is used to access context entries in 'Context's. 'getContextEntry'

64-- returns the first value where the type matches:

49-- returns the first value where the type matches:

65--

50--

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

@@ -1,272 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE FlexibleInstances #-}

3−{-# LANGUAGE GADTs #-}

4−{-# LANGUAGE MultiParamTypeClasses #-}

5−{-# LANGUAGE RecordWildCards #-}

6−{-# LANGUAGE TypeFamilies #-}

7−{-# LANGUAGE TypeOperators #-}

8−{-# LANGUAGE UndecidableInstances #-}

9−module Servant.Server.Internal.Delayed where

10−

11−import Control.Monad.IO.Class

12− (MonadIO (..))

13−import Control.Monad.Reader

14− (ask)

15−import Control.Monad.Trans.Resource

16− (ResourceT, runResourceT)

17−import Network.Wai

18− (Request, Response)

19−

20−import Servant.Server.Internal.DelayedIO

21−import Servant.Server.Internal.Handler

22−import Servant.Server.Internal.RouteResult

23−import Servant.Server.Internal.ServerError

24−

25−-- | A 'Delayed' is a representation of a handler with scheduled

26−-- delayed checks that can trigger errors.

27−--

28−-- Why would we want to delay checks?

29−--

30−-- There are two reasons:

31−--

32−-- 1. In a straight-forward implementation, the order in which we

33−-- perform checks will determine the error we generate. This is

34−-- because once an error occurs, we would abort and not perform

35−-- any subsequent checks, but rather return the current error.

36−--

37−-- This is not a necessity: we could continue doing other checks,

38−-- and choose the preferred error. However, that would in general

39−-- mean more checking, which leads us to the other reason.

40−--

41−-- 2. We really want to avoid doing certain checks too early. For

42−-- example, captures involve parsing, and are much more costly

43−-- than static route matches. In particular, if several paths

44−-- contain the "same" capture, we'd like as much as possible to

45−-- avoid trying the same parse many times. Also tricky is the

46−-- request body. Again, this involves parsing, but also, WAI makes

47−-- obtaining the request body a side-effecting operation. We

48−-- could/can work around this by manually caching the request body,

49−-- but we'd rather keep the number of times we actually try to

50−-- decode the request body to an absolute minimum.

51−--

52−-- We prefer to have the following relative priorities of error

53−-- codes:

54−--

55−-- @

56−-- 404

57−-- 405 (bad method)

58−-- 401 (unauthorized)

59−-- 415 (unsupported media type)

60−-- 406 (not acceptable)

61−-- 400 (bad request)

62−-- @

63−--

64−-- Therefore, while routing, we delay most checks so that they

65−-- will ultimately occur in the right order.

66−--

67−-- A 'Delayed' contains many delayed blocks of tests, and

68−-- the actual handler:

69−--

70−-- 1. Delayed captures. These can actually cause 404, and

71−-- while they're costly, they should be done first among the

72−-- delayed checks (at least as long as we do not decouple the

73−-- check order from the error reporting, see above). Delayed

74−-- captures can provide inputs to the actual handler.

75−--

76−-- 2. Method check(s). This can cause a 405. On success,

77−-- it does not provide an input for the handler. Method checks

78−-- are comparatively cheap.

79−--

80−-- 3. Authentication checks. This can cause 401.

81−--

82−-- 4. Accept and content type header checks. These checks

83−-- can cause 415 and 406 errors.

84−--

85−-- 5. Query parameter checks. They require parsing and can cause 400 if the

86−-- parsing fails. Query parameter checks provide inputs to the handler

87−--

88−-- 6. Header Checks. They also require parsing and can cause 400 if parsing fails.

89−--

90−-- 7. Body check. The request body check can cause 400.

91−--

92−data Delayed env c where

93− Delayed :: { capturesD :: env -> DelayedIO captures

94− , methodD :: DelayedIO ()

95− , authD :: DelayedIO auth

96− , acceptD :: DelayedIO ()

97− , contentD :: DelayedIO contentType

98− , paramsD :: DelayedIO params

99− , headersD :: DelayedIO headers

100− , bodyD :: contentType -> DelayedIO body

101− , serverD :: captures

102− -> params

103− -> headers

104− -> auth

105− -> body

106− -> Request

107− -> RouteResult c

108− } -> Delayed env c

109−

110−instance Functor (Delayed env) where

111− fmap f Delayed{..} =

112− Delayed

113− { serverD = \ c p h a b req -> f <$> serverD c p h a b req

114− , ..

115− } -- Note [Existential Record Update]

116−

117−-- | A 'Delayed' without any stored checks.

118−emptyDelayed :: RouteResult a -> Delayed env a

119−emptyDelayed result =

120− Delayed (const r) r r r r r r (const r) (\ _ _ _ _ _ _ -> result)

121− where

122− r = return ()

123−

124−-- | Add a capture to the end of the capture block.

125−addCapture :: Delayed env (a -> b)

126− -> (captured -> DelayedIO a)

127− -> Delayed (captured, env) b

128−addCapture Delayed{..} new =

129− Delayed

130− { capturesD = \ (txt, env) -> (,) <$> capturesD env <*> new txt

131− , serverD = \ (x, v) p h a b req -> ($ v) <$> serverD x p h a b req

132− , ..

133− } -- Note [Existential Record Update]

134−

135−-- | Add a parameter check to the end of the params block

136−addParameterCheck :: Delayed env (a -> b)

137− -> DelayedIO a

138− -> Delayed env b

139−addParameterCheck Delayed {..} new =

140− Delayed

141− { paramsD = (,) <$> paramsD <*> new

142− , serverD = \c (p, pNew) h a b req -> ($ pNew) <$> serverD c p h a b req

143− , ..

144− }

145−

146−-- | Add a parameter check to the end of the params block

147−addHeaderCheck :: Delayed env (a -> b)

148− -> DelayedIO a

149− -> Delayed env b

150−addHeaderCheck Delayed {..} new =

151− Delayed

152− { headersD = (,) <$> headersD <*> new

153− , serverD = \c p (h, hNew) a b req -> ($ hNew) <$> serverD c p h a b req

154− , ..

155− }

156−

157−-- | Add a method check to the end of the method block.

158−addMethodCheck :: Delayed env a

159− -> DelayedIO ()

160− -> Delayed env a

161−addMethodCheck Delayed{..} new =

162− Delayed

163− { methodD = methodD <* new

164− , ..

165− } -- Note [Existential Record Update]

166−

167−-- | Add an auth check to the end of the auth block.

168−addAuthCheck :: Delayed env (a -> b)

169− -> DelayedIO a

170− -> Delayed env b

171−addAuthCheck Delayed{..} new =

172− Delayed

173− { authD = (,) <$> authD <*> new

174− , serverD = \ c p h (y, v) b req -> ($ v) <$> serverD c p h y b req

175− , ..

176− } -- Note [Existential Record Update]

177−

178−-- | Add a content type and body checks around parameter checks.

179−--

180−-- We'll report failed content type check (415), before trying to parse

181−-- query parameters (400). Which, in turn, happens before request body parsing.

182−addBodyCheck :: Delayed env (a -> b)

183− -> DelayedIO c -- ^ content type check

184− -> (c -> DelayedIO a) -- ^ body check

185− -> Delayed env b

186−addBodyCheck Delayed{..} newContentD newBodyD =

187− Delayed

188− { contentD = (,) <$> contentD <*> newContentD

189− , bodyD = \(content, c) -> (,) <$> bodyD content <*> newBodyD c

190− , serverD = \ c p h a (z, v) req -> ($ v) <$> serverD c p h a z req

191− , ..

192− } -- Note [Existential Record Update]

193−

194−

195−-- | Add an accept header check before handling parameters.

196−-- In principle, we'd like

197−-- to take a bad body (400) response take precedence over a

198−-- failed accept check (406). BUT to allow streaming the body,

199−-- we cannot run the body check and then still backtrack.

200−-- We therefore do the accept check before the body check,

201−-- when we can still backtrack. There are other solutions to

202−-- this, but they'd be more complicated (such as delaying the

203−-- body check further so that it can still be run in a situation

204−-- where we'd otherwise report 406).

205−addAcceptCheck :: Delayed env a

206− -> DelayedIO ()

207− -> Delayed env a

208−addAcceptCheck Delayed{..} new =

209− Delayed

210− { acceptD = acceptD *> new

211− , ..

212− } -- Note [Existential Record Update]

213−

214−-- | Many combinators extract information that is passed to

215−-- the handler without the possibility of failure. In such a

216−-- case, 'passToServer' can be used.

217−passToServer :: Delayed env (a -> b) -> (Request -> a) -> Delayed env b

218−passToServer Delayed{..} x =

219− Delayed

220− { serverD = \ c p h a b req -> ($ x req) <$> serverD c p h a b req

221− , ..

222− } -- Note [Existential Record Update]

223−

224−-- | Run a delayed server. Performs all scheduled operations

225−-- in order, and passes the results from the capture and body

226−-- blocks on to the actual handler.

227−--

228−-- This should only be called once per request; otherwise the guarantees about

229−-- effect and HTTP error ordering break down.

230−runDelayed :: Delayed env a

231− -> env

232− -> Request

233− -> ResourceT IO (RouteResult a)

234−runDelayed Delayed{..} env = runDelayedIO $ do

235− r <- ask

236− c <- capturesD env

237− methodD

238− a <- authD

239− acceptD

240− content <- contentD

241− p <- paramsD -- Has to be before body parsing, but after content-type checks

242− h <- headersD

243− b <- bodyD content

244− liftRouteResult (serverD c p h a b r)

245−

246−-- | Runs a delayed server and the resulting action.

247−-- Takes a continuation that lets us send a response.

248−-- Also takes a continuation for how to turn the

249−-- result of the delayed server into a response.

250−runAction :: Delayed env (Handler a)

251− -> env

252− -> Request

253− -> (RouteResult Response -> IO r)

254− -> (a -> RouteResult Response)

255− -> IO r

256−runAction action env req respond k = runResourceT $

257− runDelayed action env req >>= go >>= liftIO . respond

258− where

259− go (Fail e) = return $ Fail e

260− go (FailFatal e) = return $ FailFatal e

261− go (Route a) = liftIO $ do

262− e <- runHandler a

263− case e of

264− Left err -> return . Route $ responseServerError err

265− Right x -> return $! k x

266−

267−{- Note [Existential Record Update]

268−~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

269−

270−Due to GHC issue <https://ghc.haskell.org/trac/ghc/ticket/2595 2595>, we cannot

271−do the more succinct thing - just update the records we actually change.

272−-}

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

@@ -1,71 +0,0 @@

1−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

2−{-# LANGUAGE MultiParamTypeClasses #-}

3−{-# LANGUAGE TypeFamilies #-}

4−module Servant.Server.Internal.DelayedIO where

5−

6−import Control.Monad.Base

7− (MonadBase (..))

8−import Control.Monad.Catch

9− (MonadThrow (..))

10−import Control.Monad.Reader

11− (MonadReader (..), ReaderT (..), runReaderT)

12−import Control.Monad.Trans

13− (MonadIO (..), MonadTrans (..))

14−import Control.Monad.Trans.Control

15− (MonadBaseControl (..))

16−import Control.Monad.Trans.Resource

17− (MonadResource (..), ResourceT, runInternalState,

18− transResourceT, withInternalState)

19−import Network.Wai

20− (Request)

21−

22−import Servant.Server.Internal.RouteResult

23−import Servant.Server.Internal.ServerError

24−

25−-- | Computations used in a 'Delayed' can depend on the

26−-- incoming 'Request', may perform 'IO', and result in a

27−-- 'RouteResult', meaning they can either succeed, fail

28−-- (with the possibility to recover), or fail fatally.

29−--

30−newtype DelayedIO a = DelayedIO { runDelayedIO' :: ReaderT Request (ResourceT (RouteResultT IO)) a }

31− deriving

32− ( Functor, Applicative, Monad

33− , MonadIO, MonadReader Request

34− , MonadThrow

35− , MonadResource

36− )

37−

38−instance MonadBase IO DelayedIO where

39− liftBase = liftIO

40−

41−liftRouteResult :: RouteResult a -> DelayedIO a

42−liftRouteResult x = DelayedIO $ lift . lift $ RouteResultT . return $ x

43−

44−instance MonadBaseControl IO DelayedIO where

45− -- type StM DelayedIO a = StM (ReaderT Request (ResourceT (RouteResultT IO))) a

46− -- liftBaseWith f = DelayedIO $ liftBaseWith $ \g -> f (g . runDelayedIO')

47− -- restoreM = DelayedIO . restoreM

48−

49− type StM DelayedIO a = RouteResult a

50− liftBaseWith f = DelayedIO $ ReaderT $ \req -> withInternalState $ \s ->

51− liftBaseWith $ \runInBase -> f $ \x ->

52− runInBase (runInternalState (runReaderT (runDelayedIO' x) req) s)

53− restoreM = DelayedIO . lift . withInternalState . const . restoreM

54−

55−

56−runDelayedIO :: DelayedIO a -> Request -> ResourceT IO (RouteResult a)

57−runDelayedIO m req = transResourceT runRouteResultT $ runReaderT (runDelayedIO' m) req

58−

59−-- | Fail with the option to recover.

60−delayedFail :: ServerError -> DelayedIO a

61−delayedFail err = liftRouteResult $ Fail err

62−

63−-- | Fail fatally, i.e., without any option to recover.

64−delayedFailFatal :: ServerError -> DelayedIO a

65−delayedFailFatal err = liftRouteResult $ FailFatal err

66−

67−-- | Gain access to the incoming request.

68−withRequest :: (Request -> DelayedIO a) -> DelayedIO a

69−withRequest f = do

70− req <- ask

71− f req

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

@@ -1,87 +0,0 @@

1−{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE PolyKinds #-}

3−{-# LANGUAGE RankNTypes #-}

4−{-# LANGUAGE TypeOperators #-}

5−

6−module Servant.Server.Internal.ErrorFormatter

7− ( ErrorFormatters(..)

8− , ErrorFormatter

9− , NotFoundErrorFormatter

10−

11− , DefaultErrorFormatters

12− , defaultErrorFormatters

13−

14− , MkContextWithErrorFormatter

15− , mkContextWithErrorFormatter

16− ) where

17−

18−import Data.String.Conversions

19− (cs)

20−import Data.Typeable

21−import Network.Wai.Internal

22− (Request)

23−

24−import Servant.API

25− (Capture, ReqBody)

26−import Servant.Server.Internal.Context

27−import Servant.Server.Internal.ServerError

28−

29−-- | 'Context' that contains default error formatters.

30−type DefaultErrorFormatters = '[ErrorFormatters]

31−

32−-- | A collection of error formatters for different situations.

33−--

34−-- If you need to override one of them, use 'defaultErrorFormatters' with record update syntax.

35−data ErrorFormatters = ErrorFormatters

36− { -- | Format error from parsing the request body.

37− bodyParserErrorFormatter :: ErrorFormatter

38− -- | Format error from parsing url parts or query parameters.

39− , urlParseErrorFormatter :: ErrorFormatter

40− -- | Format error from parsing request headers.

41− , headerParseErrorFormatter :: ErrorFormatter

42− -- | Format error for not found URLs.

43− , notFoundErrorFormatter :: NotFoundErrorFormatter

44− }

45−

46−-- | Default formatters will just return HTTP 400 status code with error

47−-- message as response body.

48−defaultErrorFormatters :: ErrorFormatters

49−defaultErrorFormatters = ErrorFormatters

50− { bodyParserErrorFormatter = err400Formatter

51− , urlParseErrorFormatter = err400Formatter

52− , headerParseErrorFormatter = err400Formatter

53− , notFoundErrorFormatter = const err404

54− }

55−

56−-- | A custom formatter for errors produced by parsing combinators like

57−-- 'ReqBody' or 'Capture'.

58−--

59−-- A 'TypeRep' argument described the concrete combinator that raised

60−-- the error, allowing formatter to customize the message for different

61−-- combinators.

62−--

63−-- A full 'Request' is also passed so that the formatter can react to @Accept@ header,

64−-- for example.

65−type ErrorFormatter = TypeRep -> Request -> String -> ServerError

66−

67−-- | This formatter does not get neither 'TypeRep' nor error message.

68−type NotFoundErrorFormatter = Request -> ServerError

69−

70−type MkContextWithErrorFormatter (ctx :: [*]) = ctx .++ DefaultErrorFormatters

71−

72−mkContextWithErrorFormatter :: forall (ctx :: [*]). Context ctx -> Context (MkContextWithErrorFormatter ctx)

73−mkContextWithErrorFormatter ctx = ctx .++ (defaultErrorFormatters :. EmptyContext)

74−

75−-- Internal

76−

77−err400Formatter :: ErrorFormatter

78−err400Formatter _ _ e = err400 { errBody = cs e }

79−

80−-- These definitions suppress "unused import" warning.

81−-- The imorts are needed for Haddock to correctly link to them.

82−_RB :: Proxy ReqBody

83−_RB = Proxy

84−_C :: Proxy Capture

85−_C = Proxy

86−_CT :: Proxy Context

87−_CT = Proxy

servant-server/src/Servant/Server/Internal/Handler.hs+9−14

@@ -11,37 +11,32 @@ import Prelude.Compat

11import Control.Monad.Base

11import Control.Monad.Base

12 (MonadBase (..))

12 (MonadBase (..))

13import Control.Monad.Catch

13import Control.Monad.Catch

14− (MonadCatch, MonadMask, MonadThrow)

14+ (MonadCatch, MonadThrow)

15import Control.Monad.Error.Class

15import Control.Monad.Error.Class

16− (MonadError, throwError)

16+ (MonadError)

17import Control.Monad.IO.Class

17import Control.Monad.IO.Class

18 (MonadIO)

18 (MonadIO)

19import Control.Monad.Trans.Control

19import Control.Monad.Trans.Control

20 (MonadBaseControl (..))

20 (MonadBaseControl (..))

21import Control.Monad.Trans.Except

21import Control.Monad.Trans.Except

22 (ExceptT, runExceptT)

22 (ExceptT, runExceptT)

23−import Data.String

24− (fromString)

25import GHC.Generics

23import GHC.Generics

26 (Generic)

24 (Generic)

27−import Servant.Server.Internal.ServerError

25+import Servant.Server.Internal.ServantErr

28− (ServerError, errBody, err500)

26+ (ServantErr)

29

27

30−newtype Handler a = Handler { runHandler' :: ExceptT ServerError IO a }

28+newtype Handler a = Handler { runHandler' :: ExceptT ServantErr IO a }

31 deriving

29 deriving

32 ( Functor, Applicative, Monad, MonadIO, Generic

30 ( Functor, Applicative, Monad, MonadIO, Generic

33− , MonadError ServerError

31+ , MonadError ServantErr

34− , MonadThrow, MonadCatch, MonadMask

32+ , MonadThrow, MonadCatch

35 )

33 )

36

34

37−instance MonadFail Handler where

38− fail str = throwError err500 { errBody = fromString str }

39−

40instance MonadBase IO Handler where

35instance MonadBase IO Handler where

41 liftBase = Handler . liftBase

36 liftBase = Handler . liftBase

42

37

43instance MonadBaseControl IO Handler where

38instance MonadBaseControl IO Handler where

44− type StM Handler a = Either ServerError a

39+ type StM Handler a = Either ServantErr a

45

40

46 -- liftBaseWith :: (RunInBase Handler IO -> IO a) -> Handler a

41 -- liftBaseWith :: (RunInBase Handler IO -> IO a) -> Handler a

47 liftBaseWith f = Handler (liftBaseWith (\g -> f (g . runHandler')))

42 liftBaseWith f = Handler (liftBaseWith (\g -> f (g . runHandler')))

@@ -49,5 +44,5 @@ instance MonadBaseControl IO Handler where

49 -- restoreM :: StM Handler a -> Handler a

44 -- restoreM :: StM Handler a -> Handler a

50 restoreM st = Handler (restoreM st)

45 restoreM st = Handler (restoreM st)

51

46

52−runHandler :: Handler a -> IO (Either ServerError a)

47+runHandler :: Handler a -> IO (Either ServantErr a)

53runHandler = runExceptT . runHandler'

48runHandler = runExceptT . runHandler'

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

@@ -1,76 +0,0 @@

1−{-# LANGUAGE DeriveFunctor #-}

2−{-# LANGUAGE FlexibleInstances #-}

3−{-# LANGUAGE MultiParamTypeClasses #-}

4−{-# LANGUAGE TypeFamilies #-}

5−{-# LANGUAGE UndecidableInstances #-}

6−module Servant.Server.Internal.RouteResult where

7−

8−import Control.Monad

9− (ap, liftM)

10−import Control.Monad.Base

11− (MonadBase (..))

12−import Control.Monad.Catch

13− (MonadThrow (..))

14−import Control.Monad.Trans

15− (MonadIO (..), MonadTrans (..))

16−import Control.Monad.Trans.Control

17− (ComposeSt, MonadBaseControl (..), MonadTransControl (..),

18− defaultLiftBaseWith, defaultRestoreM)

19−

20−import Servant.Server.Internal.ServerError

21−

22−-- | The result of matching against a path in the route tree.

23−data RouteResult a =

24− Fail ServerError -- ^ Keep trying other paths.

25− -- The 'ServantError' should only be 404, 405 or 406.

26− | FailFatal !ServerError -- ^ Don't try other paths.

27− | Route !a

28− deriving (Eq, Show, Read, Functor)

29−

30−instance Applicative RouteResult where

31− pure = return

32− (<*>) = ap

33−

34−instance Monad RouteResult where

35− return = Route

36− Route a >>= f = f a

37− Fail e >>= _ = Fail e

38− FailFatal e >>= _ = FailFatal e

39−

40−newtype RouteResultT m a = RouteResultT { runRouteResultT :: m (RouteResult a) }

41− deriving (Functor)

42−

43−instance MonadTrans RouteResultT where

44− lift = RouteResultT . liftM Route

45−

46−instance (Functor m, Monad m) => Applicative (RouteResultT m) where

47− pure = return

48− (<*>) = ap

49−

50−instance Monad m => Monad (RouteResultT m) where

51− return = RouteResultT . return . Route

52− m >>= k = RouteResultT $ do

53− a <- runRouteResultT m

54− case a of

55− Fail e -> return $ Fail e

56− FailFatal e -> return $ FailFatal e

57− Route b -> runRouteResultT (k b)

58−

59−instance MonadIO m => MonadIO (RouteResultT m) where

60− liftIO = lift . liftIO

61−

62−instance MonadBase b m => MonadBase b (RouteResultT m) where

63− liftBase = lift . liftBase

64−

65−instance MonadBaseControl b m => MonadBaseControl b (RouteResultT m) where

66− type StM (RouteResultT m) a = ComposeSt RouteResultT m a

67− liftBaseWith = defaultLiftBaseWith

68− restoreM = defaultRestoreM

69−

70−instance MonadTransControl RouteResultT where

71− type StT RouteResultT a = RouteResult a

72− liftWith f = RouteResultT $ liftM return $ f runRouteResultT

73− restoreT = RouteResultT

74−

75−instance MonadThrow m => MonadThrow (RouteResultT m) where

76− throwM = lift . throwM

servant-server/src/Servant/Server/Internal/Router.hs+37−85

@@ -4,45 +4,20 @@

4{-# LANGUAGE OverloadedStrings #-}

4{-# LANGUAGE OverloadedStrings #-}

5module Servant.Server.Internal.Router where

5module Servant.Server.Internal.Router where

6

6

7−import Prelude ()

8−import Prelude.Compat

9−

10−import Data.Function

11− (on)

12−import Data.List

13− (nub)

14import Data.Map

7import Data.Map

15 (Map)

8 (Map)

16import qualified Data.Map as M

9import qualified Data.Map as M

10+import Data.Monoid

17import Data.Text

11import Data.Text

18 (Text)

12 (Text)

19import qualified Data.Text as T

13import qualified Data.Text as T

20−import Data.Typeable

21− (TypeRep)

22import Network.Wai

14import Network.Wai

23 (Response, pathInfo)

15 (Response, pathInfo)

24−import Servant.Server.Internal.ErrorFormatter

25−import Servant.Server.Internal.RouteResult

26import Servant.Server.Internal.RoutingApplication

16import Servant.Server.Internal.RoutingApplication

27−import Servant.Server.Internal.ServerError

17+import Servant.Server.Internal.ServantErr

28

18

29type Router env = Router' env RoutingApplication

19type Router env = Router' env RoutingApplication

30

20

31−-- | Holds information about pieces of url that are captured as variables.

32−data CaptureHint = CaptureHint

33− { captureName :: Text

34− -- ^ Holds the name of the captured variable

35− , captureType :: TypeRep

36− -- ^ Holds the type of the captured variable

37− }

38− deriving (Show, Eq)

39−

40−toCaptureTag :: CaptureHint -> Text

41−toCaptureTag hint = captureName hint <> "::" <> (T.pack . show) (captureType hint)

42−

43−toCaptureTags :: [CaptureHint] -> Text

44−toCaptureTags hints = "<" <> T.intercalate "|" (map toCaptureTag hints) <> ">"

45−

46-- | Internal representation of a router.

21-- | Internal representation of a router.

47--

22--

48-- The first argument describes an environment type that is

23-- The first argument describes an environment type that is

@@ -55,23 +30,12 @@ data Router' env a =

55 -- ^ the map contains routers for subpaths (first path component used

30 -- ^ the map contains routers for subpaths (first path component used

56 -- for lookup and removed afterwards), the list contains handlers

31 -- for lookup and removed afterwards), the list contains handlers

57 -- for the empty path, to be tried in order

32 -- for the empty path, to be tried in order

58− | CaptureRouter [CaptureHint] (Router' (Text, env) a)

33+ | CaptureRouter (Router' (Text, env) a)

59 -- ^ first path component is passed to the child router in its

34 -- ^ first path component is passed to the child router in its

60− -- environment and removed afterwards.

35+ -- environment and removed afterwards

61− -- The first argument is a list of hints for all variables that can be

62− -- captured by the router. The fact that it is a list is counter-intuitive,

63− -- because the 'Capture' combinator only allows to capture a single varible,

64− -- with a single name and a single type. However, the 'choice' smart

65− -- constructor may merge two 'Capture' combinators with different hints, thus

66− -- forcing the type to be '[CaptureHint]'.

67− -- Because 'CaptureRouter' is built from a 'Capture' combinator, the list of

68− -- hints should always be non-empty.

69− | CaptureAllRouter [CaptureHint] (Router' ([Text], env) a)

36+ | CaptureAllRouter (Router' ([Text], env) a)

70 -- ^ all path components are passed to the child router in its

37 -- ^ all path components are passed to the child router in its

71 -- environment and are removed afterwards

38 -- environment and are removed afterwards

72− -- The first argument is a hint for the list of variables that can be

73− -- captured by the router. Note that the 'captureType' field of the hint

74− -- should always be '[a]' for some 'a'.

75 | RawRouter (env -> a)

39 | RawRouter (env -> a)

76 -- ^ to be used for routes we do not know anything about

40 -- ^ to be used for routes we do not know anything about

77 | Choice (Router' env a) (Router' env a)

41 | Choice (Router' env a) (Router' env a)

@@ -99,8 +63,8 @@ leafRouter l = StaticRouter M.empty [l]

99choice :: Router' env a -> Router' env a -> Router' env a

63choice :: Router' env a -> Router' env a -> Router' env a

100choice (StaticRouter table1 ls1) (StaticRouter table2 ls2) =

64choice (StaticRouter table1 ls1) (StaticRouter table2 ls2) =

101 StaticRouter (M.unionWith choice table1 table2) (ls1 ++ ls2)

65 StaticRouter (M.unionWith choice table1 table2) (ls1 ++ ls2)

102−choice (CaptureRouter hints1 router1) (CaptureRouter hints2 router2) =

66+choice (CaptureRouter router1) (CaptureRouter router2) =

103− CaptureRouter (nub $ hints1 ++ hints2) (choice router1 router2)

67+ CaptureRouter (choice router1 router2)

104choice router1 (Choice router2 router3) = Choice (choice router1 router2) router3

68choice router1 (Choice router2 router3) = Choice (choice router1 router2) router3

105choice router1 router2 = Choice router1 router2

69choice router1 router2 = Choice router1 router2

106

70

@@ -114,11 +78,7 @@ choice router1 router2 = Choice router1 router2

114--

78--

115data RouterStructure =

79data RouterStructure =

116 StaticRouterStructure (Map Text RouterStructure) Int

80 StaticRouterStructure (Map Text RouterStructure) Int

117− | CaptureRouterStructure [CaptureHint] RouterStructure

81+ | CaptureRouterStructure RouterStructure

118− -- ^ The first argument holds information about variables

119− -- that are captured by the router. There may be several hints

120− -- if several routers have been aggregated by the 'choice'

121− -- smart constructor.

122 | RawRouterStructure

82 | RawRouterStructure

123 | ChoiceStructure RouterStructure RouterStructure

83 | ChoiceStructure RouterStructure RouterStructure

124 deriving (Eq, Show)

84 deriving (Eq, Show)

@@ -132,11 +92,11 @@ data RouterStructure =

132routerStructure :: Router' env a -> RouterStructure

92routerStructure :: Router' env a -> RouterStructure

133routerStructure (StaticRouter m ls) =

93routerStructure (StaticRouter m ls) =

134 StaticRouterStructure (fmap routerStructure m) (length ls)

94 StaticRouterStructure (fmap routerStructure m) (length ls)

135−routerStructure (CaptureRouter hints router) =

95+routerStructure (CaptureRouter router) =

136− CaptureRouterStructure hints $

96+ CaptureRouterStructure $

137 routerStructure router

97 routerStructure router

138−routerStructure (CaptureAllRouter hints router) =

98+routerStructure (CaptureAllRouter router) =

139− CaptureRouterStructure hints $

99+ CaptureRouterStructure $

140 routerStructure router

100 routerStructure router

141routerStructure (RawRouter _) =

101routerStructure (RawRouter _) =

142 RawRouterStructure

102 RawRouterStructure

@@ -148,8 +108,8 @@ routerStructure (Choice r1 r2) =

148-- | Compare the structure of two routers.

108-- | Compare the structure of two routers.

149--

109--

150sameStructure :: Router' env a -> Router' env b -> Bool

110sameStructure :: Router' env a -> Router' env b -> Bool

151−sameStructure router1 router2 =

111+sameStructure r1 r2 =

152− routerStructure router1 == routerStructure router2

112+ routerStructure r1 == routerStructure r2

153

113

154-- | Provide a textual representation of the

114-- | Provide a textual representation of the

155-- structure of a router.

115-- structure of a router.

@@ -160,8 +120,7 @@ routerLayout router =

160 where

120 where

161 mkRouterLayout :: Bool -> RouterStructure -> [Text]

121 mkRouterLayout :: Bool -> RouterStructure -> [Text]

162 mkRouterLayout c (StaticRouterStructure m n) = mkSubTrees c (M.toList m) n

122 mkRouterLayout c (StaticRouterStructure m n) = mkSubTrees c (M.toList m) n

163− mkRouterLayout c (CaptureRouterStructure hints r) =

123+ mkRouterLayout c (CaptureRouterStructure r) = mkSubTree c "<capture>" (mkRouterLayout False r)

164− mkSubTree c (toCaptureTags hints) (mkRouterLayout False r)

165 mkRouterLayout c RawRouterStructure =

124 mkRouterLayout c RawRouterStructure =

166 if c then ["├─ <raw>"] else ["└─ <raw>"]

125 if c then ["├─ <raw>"] else ["└─ <raw>"]

167 mkRouterLayout c (ChoiceStructure r1 r2) =

126 mkRouterLayout c (ChoiceStructure r1 r2) =

@@ -189,52 +148,52 @@ tweakResponse :: (RouteResult Response -> RouteResult Response) -> Router env ->

189tweakResponse f = fmap (\a -> \req cont -> a req (cont . f))

148tweakResponse f = fmap (\a -> \req cont -> a req (cont . f))

190

149

191-- | Interpret a router as an application.

150-- | Interpret a router as an application.

192−runRouter :: NotFoundErrorFormatter -> Router () -> RoutingApplication

151+runRouter :: Router () -> RoutingApplication

193−runRouter fmt r = runRouterEnv fmt r ()

152+runRouter r = runRouterEnv r ()

194

153

195−runRouterEnv :: NotFoundErrorFormatter -> Router env -> env -> RoutingApplication

154+runRouterEnv :: Router env -> env -> RoutingApplication

196−runRouterEnv fmt router env request respond =

155+runRouterEnv router env request respond =

197 case router of

156 case router of

198 StaticRouter table ls ->

157 StaticRouter table ls ->

199 case pathInfo request of

158 case pathInfo request of

200− [] -> runChoice fmt ls env request respond

159+ [] -> runChoice ls env request respond

201 -- This case is to handle trailing slashes.

160 -- This case is to handle trailing slashes.

202− [""] -> runChoice fmt ls env request respond

161+ [""] -> runChoice ls env request respond

203 first : rest | Just router' <- M.lookup first table

162 first : rest | Just router' <- M.lookup first table

204 -> let request' = request { pathInfo = rest }

163 -> let request' = request { pathInfo = rest }

205− in runRouterEnv fmt router' env request' respond

164+ in runRouterEnv router' env request' respond

206− _ -> respond $ Fail $ fmt request

165+ _ -> respond $ Fail err404

207− CaptureRouter _ router' ->

166+ CaptureRouter router' ->

208 case pathInfo request of

167 case pathInfo request of

209− [] -> respond $ Fail $ fmt request

168+ [] -> respond $ Fail err404

210 -- This case is to handle trailing slashes.

169 -- This case is to handle trailing slashes.

211− [""] -> respond $ Fail $ fmt request

170+ [""] -> respond $ Fail err404

212 first : rest

171 first : rest

213 -> let request' = request { pathInfo = rest }

172 -> let request' = request { pathInfo = rest }

214− in runRouterEnv fmt router' (first, env) request' respond

173+ in runRouterEnv router' (first, env) request' respond

215− CaptureAllRouter _ router' ->

174+ CaptureAllRouter router' ->

216 let segments = pathInfo request

175 let segments = pathInfo request

217 request' = request { pathInfo = [] }

176 request' = request { pathInfo = [] }

218− in runRouterEnv fmt router' (segments, env) request' respond

177+ in runRouterEnv router' (segments, env) request' respond

219 RawRouter app ->

178 RawRouter app ->

220 app env request respond

179 app env request respond

221 Choice r1 r2 ->

180 Choice r1 r2 ->

222− runChoice fmt [runRouterEnv fmt r1, runRouterEnv fmt r2] env request respond

181+ runChoice [runRouterEnv r1, runRouterEnv r2] env request respond

223

182

224-- | Try a list of routing applications in order.

183-- | Try a list of routing applications in order.

225-- We stop as soon as one fails fatally or succeeds.

184-- We stop as soon as one fails fatally or succeeds.

226-- If all fail normally, we pick the "best" error.

185-- If all fail normally, we pick the "best" error.

227--

186--

228−runChoice :: NotFoundErrorFormatter -> [env -> RoutingApplication] -> env -> RoutingApplication

187+runChoice :: [env -> RoutingApplication] -> env -> RoutingApplication

229−runChoice fmt ls =

188+runChoice ls =

230 case ls of

189 case ls of

231− [] -> \ _ request respond -> respond (Fail $ fmt request)

190+ [] -> \ _ _ respond -> respond (Fail err404)

232 [r] -> r

191 [r] -> r

233 (r : rs) ->

192 (r : rs) ->

234 \ env request respond ->

193 \ env request respond ->

235 r env request $ \ response1 ->

194 r env request $ \ response1 ->

236 case response1 of

195 case response1 of

237− Fail _ -> runChoice fmt rs env request $ \ response2 ->

196+ Fail _ -> runChoice rs env request $ \ response2 ->

238 respond $ highestPri response1 response2

197 respond $ highestPri response1 response2

239 _ -> respond response1

198 _ -> respond response1

240 where

199 where

@@ -247,14 +206,7 @@ runChoice fmt ls =

247

206

248-- Priority on HTTP codes.

207-- Priority on HTTP codes.

249--

208--

209+-- It just so happens that 404 < 405 < 406 as far as

210+-- we are concerned here, so we can use (<).

250worseHTTPCode :: Int -> Int -> Bool

211worseHTTPCode :: Int -> Int -> Bool

251−worseHTTPCode = on (<) toPriority

212+worseHTTPCode = (<)

252− where

253− toPriority :: Int -> Int

254− toPriority 404 = 0 -- not found

255− toPriority 405 = 1 -- method not allowed

256− toPriority 401 = 2 -- unauthorized

257− toPriority 415 = 3 -- unsupported media type

258− toPriority 406 = 4 -- not acceptable

259− toPriority 400 = 6 -- bad request

260− toPriority _ = 5

servant-server/src/Servant/Server/Internal/RoutingApplication.hs+383−4

@@ -1,20 +1,399 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE DeriveFunctor #-}

3+{-# LANGUAGE FlexibleInstances #-}

4+{-# LANGUAGE GADTs #-}

5+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

6+{-# LANGUAGE MultiParamTypeClasses #-}

7+{-# LANGUAGE RecordWildCards #-}

8+{-# LANGUAGE TypeFamilies #-}

9+{-# LANGUAGE TypeOperators #-}

10+{-# LANGUAGE UndecidableInstances #-}

1module Servant.Server.Internal.RoutingApplication where

11module Servant.Server.Internal.RoutingApplication where

2

12

13+import Control.Monad

14+ (ap, liftM)

15+import Control.Monad.Base

16+ (MonadBase (..))

17+import Control.Monad.Catch

18+ (MonadThrow (..))

19+import Control.Monad.Reader

20+ (MonadReader (..), ReaderT (..), runReaderT)

21+import Control.Monad.Trans

22+ (MonadIO (..), MonadTrans (..))

23+import Control.Monad.Trans.Control

24+ (ComposeSt, MonadBaseControl (..), MonadTransControl (..),

25+ defaultLiftBaseWith, defaultRestoreM)

26+import Control.Monad.Trans.Resource

27+ (MonadResource (..), ResourceT, runInternalState,

28+ runResourceT, transResourceT, withInternalState)

3import Network.Wai

29import Network.Wai

4 (Application, Request, Response, ResponseReceived)

30 (Application, Request, Response, ResponseReceived)

5import Prelude ()

31import Prelude ()

6import Prelude.Compat

32import Prelude.Compat

7−import Servant.Server.Internal.RouteResult

33+import Servant.Server.Internal.Handler

8−import Servant.Server.Internal.ServerError

34+import Servant.Server.Internal.ServantErr

9

35

10type RoutingApplication =

36type RoutingApplication =

11 Request -- ^ the request, the field 'pathInfo' may be modified by url routing

37 Request -- ^ the request, the field 'pathInfo' may be modified by url routing

12 -> (RouteResult Response -> IO ResponseReceived) -> IO ResponseReceived

38 -> (RouteResult Response -> IO ResponseReceived) -> IO ResponseReceived

13

39

40+-- | The result of matching against a path in the route tree.

41+data RouteResult a =

42+ Fail ServantErr -- ^ Keep trying other paths. The @ServantErr@

43+ -- should only be 404, 405 or 406.

44+ | FailFatal !ServantErr -- ^ Don't try other paths.

45+ | Route !a

46+ deriving (Eq, Show, Read, Functor)

47+

48+instance Applicative RouteResult where

49+ pure = return

50+ (<*>) = ap

51+

52+instance Monad RouteResult where

53+ return = Route

54+ Route a >>= f = f a

55+ Fail e >>= _ = Fail e

56+ FailFatal e >>= _ = FailFatal e

57+

58+newtype RouteResultT m a = RouteResultT { runRouteResultT :: m (RouteResult a) }

59+ deriving (Functor)

60+

61+instance MonadTrans RouteResultT where

62+ lift = RouteResultT . liftM Route

63+

64+instance (Functor m, Monad m) => Applicative (RouteResultT m) where

65+ pure = return

66+ (<*>) = ap

67+

68+instance Monad m => Monad (RouteResultT m) where

69+ return = RouteResultT . return . Route

70+ m >>= k = RouteResultT $ do

71+ a <- runRouteResultT m

72+ case a of

73+ Fail e -> return $ Fail e

74+ FailFatal e -> return $ FailFatal e

75+ Route b -> runRouteResultT (k b)

76+

77+instance MonadIO m => MonadIO (RouteResultT m) where

78+ liftIO = lift . liftIO

79+

80+instance MonadBase b m => MonadBase b (RouteResultT m) where

81+ liftBase = lift . liftBase

82+

83+instance MonadBaseControl b m => MonadBaseControl b (RouteResultT m) where

84+ type StM (RouteResultT m) a = ComposeSt RouteResultT m a

85+ liftBaseWith = defaultLiftBaseWith

86+ restoreM = defaultRestoreM

87+

88+instance MonadTransControl RouteResultT where

89+ type StT RouteResultT a = RouteResult a

90+ liftWith f = RouteResultT $ liftM return $ f runRouteResultT

91+ restoreT = RouteResultT

92+

93+instance MonadThrow m => MonadThrow (RouteResultT m) where

94+ throwM = lift . throwM

95+

14toApplication :: RoutingApplication -> Application

96toApplication :: RoutingApplication -> Application

15toApplication ra request respond = ra request routingRespond

97toApplication ra request respond = ra request routingRespond

16 where

98 where

17 routingRespond :: RouteResult Response -> IO ResponseReceived

99 routingRespond :: RouteResult Response -> IO ResponseReceived

18− routingRespond (Fail err) = respond $ responseServerError err

100+ routingRespond (Fail err) = respond $ responseServantErr err

19− routingRespond (FailFatal err) = respond $ responseServerError err

101+ routingRespond (FailFatal err) = respond $ responseServantErr err

20 routingRespond (Route v) = respond v

102 routingRespond (Route v) = respond v

103+

104+-- | A 'Delayed' is a representation of a handler with scheduled

105+-- delayed checks that can trigger errors.

106+--

107+-- Why would we want to delay checks?

108+--

109+-- There are two reasons:

110+--

111+-- 1. In a straight-forward implementation, the order in which we

112+-- perform checks will determine the error we generate. This is

113+-- because once an error occurs, we would abort and not perform

114+-- any subsequent checks, but rather return the current error.

115+--

116+-- This is not a necessity: we could continue doing other checks,

117+-- and choose the preferred error. However, that would in general

118+-- mean more checking, which leads us to the other reason.

119+--

120+-- 2. We really want to avoid doing certain checks too early. For

121+-- example, captures involve parsing, and are much more costly

122+-- than static route matches. In particular, if several paths

123+-- contain the "same" capture, we'd like as much as possible to

124+-- avoid trying the same parse many times. Also tricky is the

125+-- request body. Again, this involves parsing, but also, WAI makes

126+-- obtaining the request body a side-effecting operation. We

127+-- could/can work around this by manually caching the request body,

128+-- but we'd rather keep the number of times we actually try to

129+-- decode the request body to an absolute minimum.

130+--

131+-- We prefer to have the following relative priorities of error

132+-- codes:

133+--

134+-- @

135+-- 404

136+-- 405 (bad method)

137+-- 401 (unauthorized)

138+-- 415 (unsupported media type)

139+-- 406 (not acceptable)

140+-- 400 (bad request)

141+-- @

142+--

143+-- Therefore, while routing, we delay most checks so that they

144+-- will ultimately occur in the right order.

145+--

146+-- A 'Delayed' contains many delayed blocks of tests, and

147+-- the actual handler:

148+--

149+-- 1. Delayed captures. These can actually cause 404, and

150+-- while they're costly, they should be done first among the

151+-- delayed checks (at least as long as we do not decouple the

152+-- check order from the error reporting, see above). Delayed

153+-- captures can provide inputs to the actual handler.

154+--

155+-- 2. Method check(s). This can cause a 405. On success,

156+-- it does not provide an input for the handler. Method checks

157+-- are comparatively cheap.

158+--

159+-- 3. Authentication checks. This can cause 401.

160+--

161+-- 4. Accept and content type header checks. These checks

162+-- can cause 415 and 406 errors.

163+--

164+-- 5. Query parameter checks. They require parsing and can cause 400 if the

165+-- parsing fails. Query parameter checks provide inputs to the handler

166+--

167+-- 6. Header Checks. They also require parsing and can cause 400 if parsing fails.

168+--

169+-- 7. Body check. The request body check can cause 400.

170+--

171+data Delayed env c where

172+ Delayed :: { capturesD :: env -> DelayedIO captures

173+ , methodD :: DelayedIO ()

174+ , authD :: DelayedIO auth

175+ , acceptD :: DelayedIO ()

176+ , contentD :: DelayedIO contentType

177+ , paramsD :: DelayedIO params

178+ , headersD :: DelayedIO headers

179+ , bodyD :: contentType -> DelayedIO body

180+ , serverD :: captures

181+ -> params

182+ -> headers

183+ -> auth

184+ -> body

185+ -> Request

186+ -> RouteResult c

187+ } -> Delayed env c

188+

189+instance Functor (Delayed env) where

190+ fmap f Delayed{..} =

191+ Delayed

192+ { serverD = \ c p h a b req -> f <$> serverD c p h a b req

193+ , ..

194+ } -- Note [Existential Record Update]

195+

196+-- | Computations used in a 'Delayed' can depend on the

197+-- incoming 'Request', may perform 'IO, and result in a

198+-- 'RouteResult, meaning they can either suceed, fail

199+-- (with the possibility to recover), or fail fatally.

200+--

201+newtype DelayedIO a = DelayedIO { runDelayedIO' :: ReaderT Request (ResourceT (RouteResultT IO)) a }

202+ deriving

203+ ( Functor, Applicative, Monad

204+ , MonadIO, MonadReader Request

205+ , MonadThrow

206+ , MonadResource

207+ )

208+

209+instance MonadBase IO DelayedIO where

210+ liftBase = liftIO

211+

212+liftRouteResult :: RouteResult a -> DelayedIO a

213+liftRouteResult x = DelayedIO $ lift . lift $ RouteResultT . return $ x

214+

215+instance MonadBaseControl IO DelayedIO where

216+ -- type StM DelayedIO a = StM (ReaderT Request (ResourceT (RouteResultT IO))) a

217+ -- liftBaseWith f = DelayedIO $ liftBaseWith $ \g -> f (g . runDelayedIO')

218+ -- restoreM = DelayedIO . restoreM

219+

220+ type StM DelayedIO a = RouteResult a

221+ liftBaseWith f = DelayedIO $ ReaderT $ \req -> withInternalState $ \s ->

222+ liftBaseWith $ \runInBase -> f $ \x ->

223+ runInBase (runInternalState (runReaderT (runDelayedIO' x) req) s)

224+ restoreM = DelayedIO . lift . withInternalState . const . restoreM

225+

226+

227+runDelayedIO :: DelayedIO a -> Request -> ResourceT IO (RouteResult a)

228+runDelayedIO m req = transResourceT runRouteResultT $ runReaderT (runDelayedIO' m) req

229+

230+-- | A 'Delayed' without any stored checks.

231+emptyDelayed :: RouteResult a -> Delayed env a

232+emptyDelayed result =

233+ Delayed (const r) r r r r r r (const r) (\ _ _ _ _ _ _ -> result)

234+ where

235+ r = return ()

236+

237+-- | Fail with the option to recover.

238+delayedFail :: ServantErr -> DelayedIO a

239+delayedFail err = liftRouteResult $ Fail err

240+

241+-- | Fail fatally, i.e., without any option to recover.

242+delayedFailFatal :: ServantErr -> DelayedIO a

243+delayedFailFatal err = liftRouteResult $ FailFatal err

244+

245+-- | Gain access to the incoming request.

246+withRequest :: (Request -> DelayedIO a) -> DelayedIO a

247+withRequest f = do

248+ req <- ask

249+ f req

250+

251+-- | Add a capture to the end of the capture block.

252+addCapture :: Delayed env (a -> b)

253+ -> (captured -> DelayedIO a)

254+ -> Delayed (captured, env) b

255+addCapture Delayed{..} new =

256+ Delayed

257+ { capturesD = \ (txt, env) -> (,) <$> capturesD env <*> new txt

258+ , serverD = \ (x, v) p h a b req -> ($ v) <$> serverD x p h a b req

259+ , ..

260+ } -- Note [Existential Record Update]

261+

262+-- | Add a parameter check to the end of the params block

263+addParameterCheck :: Delayed env (a -> b)

264+ -> DelayedIO a

265+ -> Delayed env b

266+addParameterCheck Delayed {..} new =

267+ Delayed

268+ { paramsD = (,) <$> paramsD <*> new

269+ , serverD = \c (p, pNew) h a b req -> ($ pNew) <$> serverD c p h a b req

270+ , ..

271+ }

272+

273+-- | Add a parameter check to the end of the params block

274+addHeaderCheck :: Delayed env (a -> b)

275+ -> DelayedIO a

276+ -> Delayed env b

277+addHeaderCheck Delayed {..} new =

278+ Delayed

279+ { headersD = (,) <$> headersD <*> new

280+ , serverD = \c p (h, hNew) a b req -> ($ hNew) <$> serverD c p h a b req

281+ , ..

282+ }

283+

284+-- | Add a method check to the end of the method block.

285+addMethodCheck :: Delayed env a

286+ -> DelayedIO ()

287+ -> Delayed env a

288+addMethodCheck Delayed{..} new =

289+ Delayed

290+ { methodD = methodD <* new

291+ , ..

292+ } -- Note [Existential Record Update]

293+

294+-- | Add an auth check to the end of the auth block.

295+addAuthCheck :: Delayed env (a -> b)

296+ -> DelayedIO a

297+ -> Delayed env b

298+addAuthCheck Delayed{..} new =

299+ Delayed

300+ { authD = (,) <$> authD <*> new

301+ , serverD = \ c p h (y, v) b req -> ($ v) <$> serverD c p h y b req

302+ , ..

303+ } -- Note [Existential Record Update]

304+

305+-- | Add a content type and body checks around parameter checks.

306+--

307+-- We'll report failed content type check (415), before trying to parse

308+-- query parameters (400). Which, in turn, happens before request body parsing.

309+addBodyCheck :: Delayed env (a -> b)

310+ -> DelayedIO c -- ^ content type check

311+ -> (c -> DelayedIO a) -- ^ body check

312+ -> Delayed env b

313+addBodyCheck Delayed{..} newContentD newBodyD =

314+ Delayed

315+ { contentD = (,) <$> contentD <*> newContentD

316+ , bodyD = \(content, c) -> (,) <$> bodyD content <*> newBodyD c

317+ , serverD = \ c p h a (z, v) req -> ($ v) <$> serverD c p h a z req

318+ , ..

319+ } -- Note [Existential Record Update]

320+

321+

322+-- | Add an accept header check before handling parameters.

323+-- In principle, we'd like

324+-- to take a bad body (400) response take precedence over a

325+-- failed accept check (406). BUT to allow streaming the body,

326+-- we cannot run the body check and then still backtrack.

327+-- We therefore do the accept check before the body check,

328+-- when we can still backtrack. There are other solutions to

329+-- this, but they'd be more complicated (such as delaying the

330+-- body check further so that it can still be run in a situation

331+-- where we'd otherwise report 406).

332+addAcceptCheck :: Delayed env a

333+ -> DelayedIO ()

334+ -> Delayed env a

335+addAcceptCheck Delayed{..} new =

336+ Delayed

337+ { acceptD = acceptD *> new

338+ , ..

339+ } -- Note [Existential Record Update]

340+

341+-- | Many combinators extract information that is passed to

342+-- the handler without the possibility of failure. In such a

343+-- case, 'passToServer' can be used.

344+passToServer :: Delayed env (a -> b) -> (Request -> a) -> Delayed env b

345+passToServer Delayed{..} x =

346+ Delayed

347+ { serverD = \ c p h a b req -> ($ x req) <$> serverD c p h a b req

348+ , ..

349+ } -- Note [Existential Record Update]

350+

351+-- | Run a delayed server. Performs all scheduled operations

352+-- in order, and passes the results from the capture and body

353+-- blocks on to the actual handler.

354+--

355+-- This should only be called once per request; otherwise the guarantees about

356+-- effect and HTTP error ordering break down.

357+runDelayed :: Delayed env a

358+ -> env

359+ -> Request

360+ -> ResourceT IO (RouteResult a)

361+runDelayed Delayed{..} env = runDelayedIO $ do

362+ r <- ask

363+ c <- capturesD env

364+ methodD

365+ a <- authD

366+ acceptD

367+ content <- contentD

368+ p <- paramsD -- Has to be before body parsing, but after content-type checks

369+ h <- headersD

370+ b <- bodyD content

371+ liftRouteResult (serverD c p h a b r)

372+

373+-- | Runs a delayed server and the resulting action.

374+-- Takes a continuation that lets us send a response.

375+-- Also takes a continuation for how to turn the

376+-- result of the delayed server into a response.

377+runAction :: Delayed env (Handler a)

378+ -> env

379+ -> Request

380+ -> (RouteResult Response -> IO r)

381+ -> (a -> RouteResult Response)

382+ -> IO r

383+runAction action env req respond k = runResourceT $

384+ runDelayed action env req >>= go >>= liftIO . respond

385+ where

386+ go (Fail e) = return $ Fail e

387+ go (FailFatal e) = return $ FailFatal e

388+ go (Route a) = liftIO $ do

389+ e <- runHandler a

390+ case e of

391+ Left err -> return . Route $ responseServantErr err

392+ Right x -> return $! k x

393+

394+{- Note [Existential Record Update]

395+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

396+

397+Due to GHC issue <https://ghc.haskell.org/trac/ghc/ticket/2595 2595>, we cannot

398+do the more succint thing - just update the records we actually change.

399+-}

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

@@ -1,7 +1,7 @@

1{-# LANGUAGE DeriveDataTypeable #-}

1{-# LANGUAGE DeriveDataTypeable #-}

2{-# LANGUAGE OverloadedStrings #-}

2{-# LANGUAGE OverloadedStrings #-}

3{-# LANGUAGE RecordWildCards #-}

3{-# LANGUAGE RecordWildCards #-}

4−module Servant.Server.Internal.ServerError where

4+module Servant.Server.Internal.ServantErr where

5

5

6import Control.Exception

6import Control.Exception

7 (Exception)

7 (Exception)

@@ -13,18 +13,16 @@ import qualified Network.HTTP.Types as HTTP

13import Network.Wai

13import Network.Wai

14 (Response, responseLBS)

14 (Response, responseLBS)

15

15

16−data ServerError = ServerError

17− { errHTTPCode :: Int

16+data ServantErr = ServantErr { errHTTPCode :: Int

18− , errReasonPhrase :: String

17+ , errReasonPhrase :: String

19− , errBody :: LBS.ByteString

18+ , errBody :: LBS.ByteString

20− , errHeaders :: [HTTP.Header]

19+ , errHeaders :: [HTTP.Header]

21− }

22− deriving (Show, Eq, Read, Typeable)

20+ } deriving (Show, Eq, Read, Typeable)

23

21

24−instance Exception ServerError

22+instance Exception ServantErr

25

23

26−responseServerError :: ServerError -> Response

24+responseServantErr :: ServantErr -> Response

27−responseServerError ServerError{..} = responseLBS status errHeaders errBody

25+responseServantErr ServantErr{..} = responseLBS status errHeaders errBody

28 where

26 where

29 status = HTTP.mkStatus errHTTPCode (BS.pack errReasonPhrase)

27 status = HTTP.mkStatus errHTTPCode (BS.pack errReasonPhrase)

30

28

@@ -35,8 +33,8 @@ responseServerError ServerError{..} = responseLBS status errHeaders errBody

35-- > failingHandler :: Handler ()

33-- > failingHandler :: Handler ()

36-- > failingHandler = throwError $ err300 { errBody = "I can't choose." }

34-- > failingHandler = throwError $ err300 { errBody = "I can't choose." }

37--

35--

38−err300 :: ServerError

36+err300 :: ServantErr

39−err300 = ServerError { errHTTPCode = 300

37+err300 = ServantErr { errHTTPCode = 300

40 , errReasonPhrase = "Multiple Choices"

38 , errReasonPhrase = "Multiple Choices"

41 , errBody = ""

39 , errBody = ""

42 , errHeaders = []

40 , errHeaders = []

@@ -49,8 +47,8 @@ err300 = ServerError { errHTTPCode = 300

49-- > failingHandler :: Handler ()

47-- > failingHandler :: Handler ()

50-- > failingHandler = throwError err301

48-- > failingHandler = throwError err301

51--

49--

52−err301 :: ServerError

50+err301 :: ServantErr

53−err301 = ServerError { errHTTPCode = 301

51+err301 = ServantErr { errHTTPCode = 301

54 , errReasonPhrase = "Moved Permanently"

52 , errReasonPhrase = "Moved Permanently"

55 , errBody = ""

53 , errBody = ""

56 , errHeaders = []

54 , errHeaders = []

@@ -63,8 +61,8 @@ err301 = ServerError { errHTTPCode = 301

63-- > failingHandler :: Handler ()

61-- > failingHandler :: Handler ()

64-- > failingHandler = throwError err302

62-- > failingHandler = throwError err302

65--

63--

66−err302 :: ServerError

64+err302 :: ServantErr

67−err302 = ServerError { errHTTPCode = 302

65+err302 = ServantErr { errHTTPCode = 302

68 , errReasonPhrase = "Found"

66 , errReasonPhrase = "Found"

69 , errBody = ""

67 , errBody = ""

70 , errHeaders = []

68 , errHeaders = []

@@ -77,8 +75,8 @@ err302 = ServerError { errHTTPCode = 302

77-- > failingHandler :: Handler ()

75-- > failingHandler :: Handler ()

78-- > failingHandler = throwError err303

76-- > failingHandler = throwError err303

79--

77--

80−err303 :: ServerError

78+err303 :: ServantErr

81−err303 = ServerError { errHTTPCode = 303

79+err303 = ServantErr { errHTTPCode = 303

82 , errReasonPhrase = "See Other"

80 , errReasonPhrase = "See Other"

83 , errBody = ""

81 , errBody = ""

84 , errHeaders = []

82 , errHeaders = []

@@ -91,8 +89,8 @@ err303 = ServerError { errHTTPCode = 303

91-- > failingHandler :: Handler ()

89-- > failingHandler :: Handler ()

92-- > failingHandler = throwError err304

90-- > failingHandler = throwError err304

93--

91--

94−err304 :: ServerError

92+err304 :: ServantErr

95−err304 = ServerError { errHTTPCode = 304

93+err304 = ServantErr { errHTTPCode = 304

96 , errReasonPhrase = "Not Modified"

94 , errReasonPhrase = "Not Modified"

97 , errBody = ""

95 , errBody = ""

98 , errHeaders = []

96 , errHeaders = []

@@ -105,8 +103,8 @@ err304 = ServerError { errHTTPCode = 304

105-- > failingHandler :: Handler ()

103-- > failingHandler :: Handler ()

106-- > failingHandler = throwError err305

104-- > failingHandler = throwError err305

107--

105--

108−err305 :: ServerError

106+err305 :: ServantErr

109−err305 = ServerError { errHTTPCode = 305

107+err305 = ServantErr { errHTTPCode = 305

110 , errReasonPhrase = "Use Proxy"

108 , errReasonPhrase = "Use Proxy"

111 , errBody = ""

109 , errBody = ""

112 , errHeaders = []

110 , errHeaders = []

@@ -119,8 +117,8 @@ err305 = ServerError { errHTTPCode = 305

119-- > failingHandler :: Handler ()

117-- > failingHandler :: Handler ()

120-- > failingHandler = throwError err307

118-- > failingHandler = throwError err307

121--

119--

122−err307 :: ServerError

120+err307 :: ServantErr

123−err307 = ServerError { errHTTPCode = 307

121+err307 = ServantErr { errHTTPCode = 307

124 , errReasonPhrase = "Temporary Redirect"

122 , errReasonPhrase = "Temporary Redirect"

125 , errBody = ""

123 , errBody = ""

126 , errHeaders = []

124 , errHeaders = []

@@ -133,8 +131,8 @@ err307 = ServerError { errHTTPCode = 307

133-- > failingHandler :: Handler ()

131-- > failingHandler :: Handler ()

134-- > failingHandler = throwError $ err400 { errBody = "Your request makes no sense to me." }

132-- > failingHandler = throwError $ err400 { errBody = "Your request makes no sense to me." }

135--

133--

136−err400 :: ServerError

134+err400 :: ServantErr

137−err400 = ServerError { errHTTPCode = 400

135+err400 = ServantErr { errHTTPCode = 400

138 , errReasonPhrase = "Bad Request"

136 , errReasonPhrase = "Bad Request"

139 , errBody = ""

137 , errBody = ""

140 , errHeaders = []

138 , errHeaders = []

@@ -147,8 +145,8 @@ err400 = ServerError { errHTTPCode = 400

147-- > failingHandler :: Handler ()

145-- > failingHandler :: Handler ()

148-- > failingHandler = throwError $ err401 { errBody = "Your credentials are invalid." }

146-- > failingHandler = throwError $ err401 { errBody = "Your credentials are invalid." }

149--

147--

150−err401 :: ServerError

148+err401 :: ServantErr

151−err401 = ServerError { errHTTPCode = 401

149+err401 = ServantErr { errHTTPCode = 401

152 , errReasonPhrase = "Unauthorized"

150 , errReasonPhrase = "Unauthorized"

153 , errBody = ""

151 , errBody = ""

154 , errHeaders = []

152 , errHeaders = []

@@ -161,8 +159,8 @@ err401 = ServerError { errHTTPCode = 401

161-- > failingHandler :: Handler ()

159-- > failingHandler :: Handler ()

162-- > failingHandler = throwError $ err402 { errBody = "You have 0 credits. Please give me $$$." }

160-- > failingHandler = throwError $ err402 { errBody = "You have 0 credits. Please give me $$$." }

163--

161--

164−err402 :: ServerError

162+err402 :: ServantErr

165−err402 = ServerError { errHTTPCode = 402

163+err402 = ServantErr { errHTTPCode = 402

166 , errReasonPhrase = "Payment Required"

164 , errReasonPhrase = "Payment Required"

167 , errBody = ""

165 , errBody = ""

168 , errHeaders = []

166 , errHeaders = []

@@ -175,8 +173,8 @@ err402 = ServerError { errHTTPCode = 402

175-- > failingHandler :: Handler ()

173-- > failingHandler :: Handler ()

176-- > failingHandler = throwError $ err403 { errBody = "Please login first." }

174-- > failingHandler = throwError $ err403 { errBody = "Please login first." }

177--

175--

178−err403 :: ServerError

176+err403 :: ServantErr

179−err403 = ServerError { errHTTPCode = 403

177+err403 = ServantErr { errHTTPCode = 403

180 , errReasonPhrase = "Forbidden"

178 , errReasonPhrase = "Forbidden"

181 , errBody = ""

179 , errBody = ""

182 , errHeaders = []

180 , errHeaders = []

@@ -187,10 +185,10 @@ err403 = ServerError { errHTTPCode = 403

187-- Example:

185-- Example:

188--

186--

189-- > failingHandler :: Handler ()

187-- > failingHandler :: Handler ()

190−-- > failingHandler = throwError $ err404 { errBody = "Are you lost?" }

188+-- > failingHandler = throwError $ err404 { errBody = "(╯°□°）╯︵ ┻━┻)." }

191--

189--

192−err404 :: ServerError

190+err404 :: ServantErr

193−err404 = ServerError { errHTTPCode = 404

191+err404 = ServantErr { errHTTPCode = 404

194 , errReasonPhrase = "Not Found"

192 , errReasonPhrase = "Not Found"

195 , errBody = ""

193 , errBody = ""

196 , errHeaders = []

194 , errHeaders = []

@@ -203,8 +201,8 @@ err404 = ServerError { errHTTPCode = 404

203-- > failingHandler :: Handler ()

201-- > failingHandler :: Handler ()

204-- > failingHandler = throwError $ err405 { errBody = "Your account privileges does not allow for this. Please pay $$$." }

202-- > failingHandler = throwError $ err405 { errBody = "Your account privileges does not allow for this. Please pay $$$." }

205--

203--

206−err405 :: ServerError

204+err405 :: ServantErr

207−err405 = ServerError { errHTTPCode = 405

205+err405 = ServantErr { errHTTPCode = 405

208 , errReasonPhrase = "Method Not Allowed"

206 , errReasonPhrase = "Method Not Allowed"

209 , errBody = ""

207 , errBody = ""

210 , errHeaders = []

208 , errHeaders = []

@@ -217,8 +215,8 @@ err405 = ServerError { errHTTPCode = 405

217-- > failingHandler :: Handler ()

215-- > failingHandler :: Handler ()

218-- > failingHandler = throwError err406

216-- > failingHandler = throwError err406

219--

217--

220−err406 :: ServerError

218+err406 :: ServantErr

221−err406 = ServerError { errHTTPCode = 406

219+err406 = ServantErr { errHTTPCode = 406

222 , errReasonPhrase = "Not Acceptable"

220 , errReasonPhrase = "Not Acceptable"

223 , errBody = ""

221 , errBody = ""

224 , errHeaders = []

222 , errHeaders = []

@@ -231,8 +229,8 @@ err406 = ServerError { errHTTPCode = 406

231-- > failingHandler :: Handler ()

229-- > failingHandler :: Handler ()

232-- > failingHandler = throwError err407

230-- > failingHandler = throwError err407

233--

231--

234−err407 :: ServerError

232+err407 :: ServantErr

235−err407 = ServerError { errHTTPCode = 407

233+err407 = ServantErr { errHTTPCode = 407

236 , errReasonPhrase = "Proxy Authentication Required"

234 , errReasonPhrase = "Proxy Authentication Required"

237 , errBody = ""

235 , errBody = ""

238 , errHeaders = []

236 , errHeaders = []

@@ -245,8 +243,8 @@ err407 = ServerError { errHTTPCode = 407

245-- > failingHandler :: Handler ()

243-- > failingHandler :: Handler ()

246-- > failingHandler = throwError $ err409 { errBody = "Transaction conflicts with 59879cb56c7c159231eeacdd503d755f7e835f74" }

244-- > failingHandler = throwError $ err409 { errBody = "Transaction conflicts with 59879cb56c7c159231eeacdd503d755f7e835f74" }

247--

245--

248−err409 :: ServerError

246+err409 :: ServantErr

249−err409 = ServerError { errHTTPCode = 409

247+err409 = ServantErr { errHTTPCode = 409

250 , errReasonPhrase = "Conflict"

248 , errReasonPhrase = "Conflict"

251 , errBody = ""

249 , errBody = ""

252 , errHeaders = []

250 , errHeaders = []

@@ -259,8 +257,8 @@ err409 = ServerError { errHTTPCode = 409

259-- > failingHandler :: Handler ()

257-- > failingHandler :: Handler ()

260-- > failingHandler = throwError $ err410 { errBody = "I know it was here at some point, but.. I blame bad luck." }

258-- > failingHandler = throwError $ err410 { errBody = "I know it was here at some point, but.. I blame bad luck." }

261--

259--

262−err410 :: ServerError

260+err410 :: ServantErr

263−err410 = ServerError { errHTTPCode = 410

261+err410 = ServantErr { errHTTPCode = 410

264 , errReasonPhrase = "Gone"

262 , errReasonPhrase = "Gone"

265 , errBody = ""

263 , errBody = ""

266 , errHeaders = []

264 , errHeaders = []

@@ -273,8 +271,8 @@ err410 = ServerError { errHTTPCode = 410

273-- > failingHandler :: Handler ()

271-- > failingHandler :: Handler ()

274-- > failingHandler = throwError err411

272-- > failingHandler = throwError err411

275--

273--

276−err411 :: ServerError

274+err411 :: ServantErr

277−err411 = ServerError { errHTTPCode = 411

275+err411 = ServantErr { errHTTPCode = 411

278 , errReasonPhrase = "Length Required"

276 , errReasonPhrase = "Length Required"

279 , errBody = ""

277 , errBody = ""

280 , errHeaders = []

278 , errHeaders = []

@@ -287,8 +285,8 @@ err411 = ServerError { errHTTPCode = 411

287-- > failingHandler :: Handler ()

285-- > failingHandler :: Handler ()

288-- > failingHandler = throwError $ err412 { errBody = "Precondition fail: x < 42 && y > 57" }

286-- > failingHandler = throwError $ err412 { errBody = "Precondition fail: x < 42 && y > 57" }

289--

287--

290−err412 :: ServerError

288+err412 :: ServantErr

291−err412 = ServerError { errHTTPCode = 412

289+err412 = ServantErr { errHTTPCode = 412

292 , errReasonPhrase = "Precondition Failed"

290 , errReasonPhrase = "Precondition Failed"

293 , errBody = ""

291 , errBody = ""

294 , errHeaders = []

292 , errHeaders = []

@@ -301,8 +299,8 @@ err412 = ServerError { errHTTPCode = 412

301-- > failingHandler :: Handler ()

299-- > failingHandler :: Handler ()

302-- > failingHandler = throwError $ err413 { errBody = "Request exceeded 64k." }

300-- > failingHandler = throwError $ err413 { errBody = "Request exceeded 64k." }

303--

301--

304−err413 :: ServerError

302+err413 :: ServantErr

305−err413 = ServerError { errHTTPCode = 413

303+err413 = ServantErr { errHTTPCode = 413

306 , errReasonPhrase = "Request Entity Too Large"

304 , errReasonPhrase = "Request Entity Too Large"

307 , errBody = ""

305 , errBody = ""

308 , errHeaders = []

306 , errHeaders = []

@@ -315,8 +313,8 @@ err413 = ServerError { errHTTPCode = 413

315-- > failingHandler :: Handler ()

313-- > failingHandler :: Handler ()

316-- > failingHandler = throwError $ err414 { errBody = "Maximum length is 64." }

314-- > failingHandler = throwError $ err414 { errBody = "Maximum length is 64." }

317--

315--

318−err414 :: ServerError

316+err414 :: ServantErr

319−err414 = ServerError { errHTTPCode = 414

317+err414 = ServantErr { errHTTPCode = 414

320 , errReasonPhrase = "Request-URI Too Large"

318 , errReasonPhrase = "Request-URI Too Large"

321 , errBody = ""

319 , errBody = ""

322 , errHeaders = []

320 , errHeaders = []

@@ -329,8 +327,8 @@ err414 = ServerError { errHTTPCode = 414

329-- > failingHandler :: Handler ()

327-- > failingHandler :: Handler ()

330-- > failingHandler = throwError $ err415 { errBody = "Supported media types: gif, png" }

328-- > failingHandler = throwError $ err415 { errBody = "Supported media types: gif, png" }

331--

329--

332−err415 :: ServerError

330+err415 :: ServantErr

333−err415 = ServerError { errHTTPCode = 415

331+err415 = ServantErr { errHTTPCode = 415

334 , errReasonPhrase = "Unsupported Media Type"

332 , errReasonPhrase = "Unsupported Media Type"

335 , errBody = ""

333 , errBody = ""

336 , errHeaders = []

334 , errHeaders = []

@@ -343,8 +341,8 @@ err415 = ServerError { errHTTPCode = 415

343-- > failingHandler :: Handler ()

341-- > failingHandler :: Handler ()

344-- > failingHandler = throwError $ err416 { errBody = "Valid range is [0, 424242]." }

342-- > failingHandler = throwError $ err416 { errBody = "Valid range is [0, 424242]." }

345--

343--

346−err416 :: ServerError

344+err416 :: ServantErr

347−err416 = ServerError { errHTTPCode = 416

345+err416 = ServantErr { errHTTPCode = 416

348 , errReasonPhrase = "Request range not satisfiable"

346 , errReasonPhrase = "Request range not satisfiable"

349 , errBody = ""

347 , errBody = ""

350 , errHeaders = []

348 , errHeaders = []

@@ -357,8 +355,8 @@ err416 = ServerError { errHTTPCode = 416

357-- > failingHandler :: Handler ()

355-- > failingHandler :: Handler ()

358-- > failingHandler = throwError $ err417 { errBody = "I found a quux in the request. This isn't going to work." }

356-- > failingHandler = throwError $ err417 { errBody = "I found a quux in the request. This isn't going to work." }

359--

357--

360−err417 :: ServerError

358+err417 :: ServantErr

361−err417 = ServerError { errHTTPCode = 417

359+err417 = ServantErr { errHTTPCode = 417

362 , errReasonPhrase = "Expectation Failed"

360 , errReasonPhrase = "Expectation Failed"

363 , errBody = ""

361 , errBody = ""

364 , errHeaders = []

362 , errHeaders = []

@@ -371,8 +369,8 @@ err417 = ServerError { errHTTPCode = 417

371-- > failingHandler :: Handler ()

369-- > failingHandler :: Handler ()

372-- > failingHandler = throwError $ err418 { errBody = "Apologies, this is not a webserver but a teapot." }

370-- > failingHandler = throwError $ err418 { errBody = "Apologies, this is not a webserver but a teapot." }

373--

371--

374−err418 :: ServerError

372+err418 :: ServantErr

375−err418 = ServerError { errHTTPCode = 418

373+err418 = ServantErr { errHTTPCode = 418

376 , errReasonPhrase = "I'm a teapot"

374 , errReasonPhrase = "I'm a teapot"

377 , errBody = ""

375 , errBody = ""

378 , errHeaders = []

376 , errHeaders = []

@@ -385,8 +383,8 @@ err418 = ServerError { errHTTPCode = 418

385-- > failingHandler :: Handler ()

383-- > failingHandler :: Handler ()

386-- > failingHandler = throwError $ err422 { errBody = "I understood your request, but can't process it." }

384-- > failingHandler = throwError $ err422 { errBody = "I understood your request, but can't process it." }

387--

385--

388−err422 :: ServerError

386+err422 :: ServantErr

389−err422 = ServerError { errHTTPCode = 422

387+err422 = ServantErr { errHTTPCode = 422

390 , errReasonPhrase = "Unprocessable Entity"

388 , errReasonPhrase = "Unprocessable Entity"

391 , errBody = ""

389 , errBody = ""

392 , errHeaders = []

390 , errHeaders = []

@@ -399,8 +397,8 @@ err422 = ServerError { errHTTPCode = 422

399-- > failingHandler :: Handler ()

397-- > failingHandler :: Handler ()

400-- > failingHandler = throwError $ err500 { errBody = "Exception in module A.B.C:55. Have a great day!" }

398-- > failingHandler = throwError $ err500 { errBody = "Exception in module A.B.C:55. Have a great day!" }

401--

399--

402−err500 :: ServerError

400+err500 :: ServantErr

403−err500 = ServerError { errHTTPCode = 500

401+err500 = ServantErr { errHTTPCode = 500

404 , errReasonPhrase = "Internal Server Error"

402 , errReasonPhrase = "Internal Server Error"

405 , errBody = ""

403 , errBody = ""

406 , errHeaders = []

404 , errHeaders = []

@@ -413,8 +411,8 @@ err500 = ServerError { errHTTPCode = 500

413-- > failingHandler :: Handler ()

411-- > failingHandler :: Handler ()

414-- > failingHandler = throwError $ err501 { errBody = "/v1/foo is not supported with quux in the request." }

412-- > failingHandler = throwError $ err501 { errBody = "/v1/foo is not supported with quux in the request." }

415--

413--

416−err501 :: ServerError

414+err501 :: ServantErr

417−err501 = ServerError { errHTTPCode = 501

415+err501 = ServantErr { errHTTPCode = 501

418 , errReasonPhrase = "Not Implemented"

416 , errReasonPhrase = "Not Implemented"

419 , errBody = ""

417 , errBody = ""

420 , errHeaders = []

418 , errHeaders = []

@@ -427,8 +425,8 @@ err501 = ServerError { errHTTPCode = 501

427-- > failingHandler :: Handler ()

425-- > failingHandler :: Handler ()

428-- > failingHandler = throwError $ err502 { errBody = "Tried gateway foo, bar, and baz. None responded." }

426-- > failingHandler = throwError $ err502 { errBody = "Tried gateway foo, bar, and baz. None responded." }

429--

427--

430−err502 :: ServerError

428+err502 :: ServantErr

431−err502 = ServerError { errHTTPCode = 502

429+err502 = ServantErr { errHTTPCode = 502

432 , errReasonPhrase = "Bad Gateway"

430 , errReasonPhrase = "Bad Gateway"

433 , errBody = ""

431 , errBody = ""

434 , errHeaders = []

432 , errHeaders = []

@@ -441,8 +439,8 @@ err502 = ServerError { errHTTPCode = 502

441-- > failingHandler :: Handler ()

439-- > failingHandler :: Handler ()

442-- > failingHandler = throwError $ err503 { errBody = "We're rewriting in PHP." }

440-- > failingHandler = throwError $ err503 { errBody = "We're rewriting in PHP." }

443--

441--

444−err503 :: ServerError

442+err503 :: ServantErr

445−err503 = ServerError { errHTTPCode = 503

443+err503 = ServantErr { errHTTPCode = 503

446 , errReasonPhrase = "Service Unavailable"

444 , errReasonPhrase = "Service Unavailable"

447 , errBody = ""

445 , errBody = ""

448 , errHeaders = []

446 , errHeaders = []

@@ -455,8 +453,8 @@ err503 = ServerError { errHTTPCode = 503

455-- > failingHandler :: Handler ()

453-- > failingHandler :: Handler ()

456-- > failingHandler = throwError $ err504 { errBody = "Backend foobar did not respond in 5 seconds." }

454-- > failingHandler = throwError $ err504 { errBody = "Backend foobar did not respond in 5 seconds." }

457--

455--

458−err504 :: ServerError

456+err504 :: ServantErr

459−err504 = ServerError { errHTTPCode = 504

457+err504 = ServantErr { errHTTPCode = 504

460 , errReasonPhrase = "Gateway Time-out"

458 , errReasonPhrase = "Gateway Time-out"

461 , errBody = ""

459 , errBody = ""

462 , errHeaders = []

460 , errHeaders = []

@@ -469,8 +467,8 @@ err504 = ServerError { errHTTPCode = 504

469-- > failingHandler :: Handler ()

467-- > failingHandler :: Handler ()

470-- > failingHandler = throwError $ err505 { errBody = "I support HTTP/4.0 only." }

468-- > failingHandler = throwError $ err505 { errBody = "I support HTTP/4.0 only." }

471--

469--

472−err505 :: ServerError

470+err505 :: ServantErr

473−err505 = ServerError { errHTTPCode = 505

471+err505 = ServantErr { errHTTPCode = 505

474 , errReasonPhrase = "HTTP Version not supported"

472 , errReasonPhrase = "HTTP Version not supported"

475 , errBody = ""

473 , errBody = ""

476 , errHeaders = []

474 , errHeaders = []

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

This diff is too big to show here.

servant-server/test/Servant/Server/ErrorSpec.hs+2−58

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

servant-server/tinc.yamlnew file+3

This diff is too big to show here.

servant-swagger/CHANGELOG.mddeleted−143

This diff is too big to show here.

servant-swagger/LICENSEdeleted−28

This diff is too big to show here.

servant-swagger/README.mddeleted−46

This diff is too big to show here.

servant-swagger/Setup.hsdeleted−33

This diff is too big to show here.

servant-swagger/example/LICENSEdeleted−28

This diff is too big to show here.

servant-swagger/example/example.cabaldeleted−62

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

servant-swagger/example/swagger.jsondeleted−158

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

servant-swagger/servant-swagger.cabaldeleted−127

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

servant-swagger/test/Spec.hsdeleted−1

This diff is too big to show here.

servant-swagger/test/doctests.hsdeleted−12

This diff is too big to show here.

servant/CHANGELOG.md+11−541

This diff is too big to show here.

servant/LICENSE+1−1

This diff is too big to show here.

servant/Setup.hs+32−1

This diff is too big to show here.

servant/servant.cabal+74−74

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

servant/test/doctests.hsnew file+27

This diff is too big to show here.

stack.yaml+3−11

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.