git.iko.soy/typeable/servant

on master help sign in

from

swap

tob3279d9492 ahead, 0 behind

compare

.github/FUNDING.ymlnew file+12

since splitsnapshots

unifiedsplit

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

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.shnew file+14

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

1+#!/usr/bin/env bash

2+#

3+# cabal v2-test does not work with GHCJS

4+# See: https://github.com/haskell/cabal/issues/6175

5+#

6+# This invokes cabal-plan to figure out test binaries, and invokes them with node.

7+

8+cabal-plan list-bins '*:test:*' | while read -r line

9+do

10+ testpkg=$(echo "$line" | perl -pe 's/:.*//')

11+ testexe=$(echo "$line" | awk '{ print $2 }')

12+ echo "testing $textexe in package $textpkg"

13+ (cd "$testpkg" && node "$testexe".jsexe/all.js)

14+done

.github/workflows/master.ymlnew file+147

@@ -0,0 +1,147 @@

1+name: CI

2+

3+# Trigger the workflow on push or pull request, but only for the master branch

4+on:

5+ pull_request:

6+ push:

7+ branches: [master]

8+

9+jobs:

10+ cabal:

11+ name: ${{ matrix.os }} / ghc ${{ matrix.ghc }}

12+ runs-on: ${{ matrix.os }}

13+ strategy:

14+ matrix:

15+ os: [ubuntu-latest]

16+ cabal: ["3.6"]

17+ ghc:

18+ - "8.6.5"

19+ - "8.8.4"

20+ - "8.10.7"

21+ - "9.0.2"

22+ - "9.2.2"

23+

24+ steps:

25+ - uses: actions/checkout@v2

26+

27+ - uses: haskell/actions/setup@v1

28+ id: setup-haskell-cabal

29+ name: Setup Haskell

30+ with:

31+ ghc-version: ${{ matrix.ghc }}

32+ cabal-version: ${{ matrix.cabal }}

33+

34+ - name: Freeze

35+ run: |

36+ cabal configure --enable-tests --enable-benchmarks --test-show-details=direct

37+ cabal freeze

38+

39+ - uses: actions/cache@v2.1.3

40+ name: Cache ~/.cabal/store and dist-newstyle

41+ with:

42+ path: |

43+ ${{ steps.setup-haskell-cabal.outputs.cabal-store }}

44+ dist-newstyle

45+ key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }}

46+ restore-keys: |

47+ ${{ runner.os }}-${{ matrix.ghc }}-

48+

49+ - name: Configure

50+ run: |

51+ cabal install --ignore-project -j2 doctest --constraint='doctest ^>=0.20'

52+

53+ - name: Build

54+ run: |

55+ cabal build all

56+

57+ - name: Test

58+ run: |

59+ cabal test all

60+

61+ - name: Run doctests

62+ run: |

63+ # Necessary for doctest to be found in $PATH

64+ export PATH="$HOME/.cabal/bin:$PATH"

65+

66+ DOCTEST="cabal repl --with-ghc=doctest --ghc-options=-w"

67+ (cd servant && eval $DOCTEST)

68+ (cd servant-client && eval $DOCTEST)

69+ (cd servant-client-core && eval $DOCTEST)

70+ (cd servant-http-streams && eval $DOCTEST)

71+ (cd servant-docs && eval $DOCTEST)

72+ (cd servant-foreign && eval $DOCTEST)

73+ (cd servant-server && eval $DOCTEST)

74+ (cd servant-machines && eval $DOCTEST)

75+ (cd servant-conduit && eval $DOCTEST)

76+ (cd servant-pipes && eval $DOCTEST)

77+

78+ stack:

79+ name: stack / ghc ${{ matrix.ghc }}

80+ runs-on: ubuntu-latest

81+ strategy:

82+ matrix:

83+ stack: ["2.7.5"]

84+ ghc: ["8.10.7"]

85+

86+ steps:

87+ - uses: actions/checkout@v2

88+

89+ - uses: haskell/actions/setup@v1

90+ name: Setup Haskell Stack

91+ with:

92+ ghc-version: ${{ matrix.ghc }}

93+ stack-version: ${{ matrix.stack }}

94+

95+ - uses: actions/cache@v2.1.3

96+ name: Cache ~/.stack

97+ with:

98+ path: ~/.stack

99+ key: ${{ runner.os }}-${{ matrix.ghc }}-stack

100+

101+ - name: Install dependencies

102+ run: |

103+ stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks --only-dependencies

104+

105+ - name: Build

106+ run: |

107+ stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks

108+

109+ - name: Test

110+ run: |

111+ stack test --system-ghc

112+

113+ ghcjs:

114+ name: ubuntu-latest / ghcjs 8.6

115+ runs-on: "ubuntu-latest"

116+

117+ steps:

118+ - uses: actions/checkout@v2

119+ - uses: cachix/install-nix-action@v13

120+ with:

121+ extra_nix_config: |

122+ trusted-public-keys = ryantrinkle.com-1:JJiAKaRv9mWgpVAz8dwewnZe0AzzEAzPkagE9SP5NWI=1aba6f367982bd6dd78ec2fda75ab246a62d32c5 cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY=

123+ substituters = https://nixcache.reflex-frp.org https://cache.nixos.org/

124+ - name: Setup

125+ run: |

126+ # Override cabal.project with the lightweight GHCJS one

127+ cp cabal.ghcjs.project cabal.project

128+ cat cabal.project

129+ nix-shell ghcjs.nix --run "cabal v2-update && cabal v2-freeze"

130+

131+ - uses: actions/cache@v2.1.3

132+ name: Cache ~/.cabal/store and dist-newstyle

133+ with:

134+ path: |

135+ ~/.cabal/store

136+ dist-newstyle

137+ key: ${{ runner.os }}-ghcjs8.6-${{ hashFiles('cabal.project.freeze') }}

138+ restore-keys: |

139+ ${{ runner.os }}-ghcjs8.6-

140+

141+ - name: Build

142+ run: |

143+ nix-shell ghcjs.nix --run "cabal v2-build --ghcjs --enable-tests --enable-benchmarks all"

144+

145+ - name: Tests

146+ run: |

147+ nix-shell ghcjs.nix --run ".github/run-ghcjs-tests.sh"

.gitignore+7−1

@@ -1,5 +1,6 @@

1**/*/dist

1**/*/dist

2+*~

2−dist-newstyle

3+dist-*

3.ghc.environment.*

4.ghc.environment.*

4/bin

5/bin

5/lib

6/lib

@@ -29,6 +30,11 @@ doc/_build

29doc/venv

30doc/venv

30doc/tutorial/static/api.js

31doc/tutorial/static/api.js

31doc/tutorial/static/jq.js

32doc/tutorial/static/jq.js

33+shell.nix

34+.hspec-failures

35+

36+# nix

37+result*

32

38

33# local versions of things

39# local versions of things

34servant-multipart

40servant-multipart

.travis.ymldeleted−189

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

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.2"

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

37− addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.6.2], 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\" \"servant-machines\" \"servant-conduit\" \"servant-pipes\" \"doc/cookbook/basic-auth\" \"doc/cookbook/curl-mock\" \"doc/cookbook/basic-streaming\" \"doc/cookbook/db-postgres-pool\" \"doc/cookbook/db-sqlite-simple\" \"doc/cookbook/file-upload\" \"doc/cookbook/generic\" \"doc/cookbook/hoist-server-with-context\" \"doc/cookbook/https\" \"doc/cookbook/jwt-and-basic-auth\" \"doc/cookbook/testing\" \"doc/cookbook/structuring-apis\" \"doc/cookbook/using-custom-monad\" \"doc/cookbook/using-free-client\"\\n' > cabal.project"

73− - "printf 'write-ghc-environment-files: always\\n' >> cabal.project"

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

75− - "echo 'allow-newer: servant-js:base, servant-quickcheck:servant, servant-quickcheck:servant-client, servant-quickcheck:servant-server,servant-quickcheck:hspec,servant-quickcheck:http-client' >> cabal.project"

76− - touch cabal.project.local

77− - "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 -- servant-machines | grep -vw -- servant-conduit | grep -vw -- servant-pipes | grep -vw -- cookbook-basic-auth | grep -vw -- cookbook-curl-mock | grep -vw -- cookbook-basic-streaming | grep -vw -- cookbook-db-postgres-pool | grep -vw -- cookbook-db-sqlite-simple | grep -vw -- cookbook-file-upload | grep -vw -- cookbook-generic | grep -vw -- cookbook-hoist-server-with-context | grep -vw -- cookbook-https | grep -vw -- cookbook-jwt-and-basic-auth | 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"

78− - cat cabal.project || true

79− - cat cabal.project.local || true

80− - if [ -f "servant/configure.ac" ]; then

81− (cd "servant" && autoreconf -i);

82− fi

83− - if [ -f "servant-client/configure.ac" ]; then

84− (cd "servant-client" && autoreconf -i);

85− fi

86− - if [ -f "servant-client-core/configure.ac" ]; then

87− (cd "servant-client-core" && autoreconf -i);

88− fi

89− - if [ -f "servant-docs/configure.ac" ]; then

90− (cd "servant-docs" && autoreconf -i);

91− fi

92− - if [ -f "servant-foreign/configure.ac" ]; then

93− (cd "servant-foreign" && autoreconf -i);

94− fi

95− - if [ -f "servant-server/configure.ac" ]; then

96− (cd "servant-server" && autoreconf -i);

97− fi

98− - if [ -f "doc/tutorial/configure.ac" ]; then

99− (cd "doc/tutorial" && autoreconf -i);

100− fi

101− - if [ -f "servant-machines/configure.ac" ]; then

102− (cd "servant-machines" && autoreconf -i);

103− fi

104− - if [ -f "servant-conduit/configure.ac" ]; then

105− (cd "servant-conduit" && autoreconf -i);

106− fi

107− - if [ -f "servant-pipes/configure.ac" ]; then

108− (cd "servant-pipes" && autoreconf -i);

109− fi

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

111− (cd "doc/cookbook/basic-auth" && autoreconf -i);

112− fi

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

114− (cd "doc/cookbook/curl-mock" && autoreconf -i);

115− fi

116− - if [ -f "doc/cookbook/basic-streaming/configure.ac" ]; then

117− (cd "doc/cookbook/basic-streaming" && autoreconf -i);

118− fi

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

120− (cd "doc/cookbook/db-postgres-pool" && autoreconf -i);

121− fi

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

123− (cd "doc/cookbook/db-sqlite-simple" && autoreconf -i);

124− fi

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

126− (cd "doc/cookbook/file-upload" && autoreconf -i);

127− fi

128− - if [ -f "doc/cookbook/generic/configure.ac" ]; then

129− (cd "doc/cookbook/generic" && autoreconf -i);

130− fi

131− - if [ -f "doc/cookbook/hoist-server-with-context/configure.ac" ]; then

132− (cd "doc/cookbook/hoist-server-with-context" && autoreconf -i);

133− fi

134− - if [ -f "doc/cookbook/https/configure.ac" ]; then

135− (cd "doc/cookbook/https" && autoreconf -i);

136− fi

137− - if [ -f "doc/cookbook/jwt-and-basic-auth/configure.ac" ]; then

138− (cd "doc/cookbook/jwt-and-basic-auth" && autoreconf -i);

139− fi

140− - if [ -f "doc/cookbook/testing/configure.ac" ]; then

141− (cd "doc/cookbook/testing" && autoreconf -i);

142− fi

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

144− (cd "doc/cookbook/structuring-apis" && autoreconf -i);

145− fi

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

147− (cd "doc/cookbook/using-custom-monad" && autoreconf -i);

148− fi

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

150− (cd "doc/cookbook/using-free-client" && autoreconf -i);

151− fi

152− - rm -f cabal.project.freeze

153− - 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 "servant-machines"/dist "servant-conduit"/dist "servant-pipes"/dist "doc/cookbook/basic-auth"/dist "doc/cookbook/curl-mock"/dist "doc/cookbook/basic-streaming"/dist "doc/cookbook/db-postgres-pool"/dist "doc/cookbook/db-sqlite-simple"/dist "doc/cookbook/file-upload"/dist "doc/cookbook/generic"/dist "doc/cookbook/hoist-server-with-context"/dist "doc/cookbook/https"/dist "doc/cookbook/jwt-and-basic-auth"/dist "doc/cookbook/testing"/dist "doc/cookbook/structuring-apis"/dist "doc/cookbook/using-custom-monad"/dist "doc/cookbook/using-free-client"/dist

154− - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)

155−

156−# Here starts the actual work to be performed for the package under test;

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

158−script:

159− # test that source-distributions can be generated

160− - echo Packaging... && echo -en 'travis_fold:start:sdist\\r'

161− - cabal new-sdist all

162− - echo -en 'travis_fold:end:sdist\\r'

163− - echo Unpacking... && echo -en 'travis_fold:start:unpack\\r'

164− - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/

165− - cd ${DISTDIR} || false

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

167− - "printf 'packages: servant-*/*.cabal servant-client-*/*.cabal servant-client-core-*/*.cabal servant-docs-*/*.cabal servant-foreign-*/*.cabal servant-server-*/*.cabal tutorial-*/*.cabal servant-machines-*/*.cabal servant-conduit-*/*.cabal servant-pipes-*/*.cabal cookbook-basic-auth-*/*.cabal cookbook-curl-mock-*/*.cabal cookbook-basic-streaming-*/*.cabal cookbook-db-postgres-pool-*/*.cabal cookbook-db-sqlite-simple-*/*.cabal cookbook-file-upload-*/*.cabal cookbook-generic-*/*.cabal cookbook-hoist-server-with-context-*/*.cabal cookbook-https-*/*.cabal cookbook-jwt-and-basic-auth-*/*.cabal cookbook-testing-*/*.cabal cookbook-structuring-apis-*/*.cabal cookbook-using-custom-monad-*/*.cabal cookbook-using-free-client-*/*.cabal\\n' > cabal.project"

168− - "printf 'write-ghc-environment-files: always\\n' >> cabal.project"

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

170− - "echo 'allow-newer: servant-js:base, servant-quickcheck:servant, servant-quickcheck:servant-client, servant-quickcheck:servant-server,servant-quickcheck:hspec,servant-quickcheck:http-client' >> cabal.project"

171− - touch cabal.project.local

172− - "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 -- servant-machines | grep -vw -- servant-conduit | grep -vw -- servant-pipes | grep -vw -- cookbook-basic-auth | grep -vw -- cookbook-curl-mock | grep -vw -- cookbook-basic-streaming | grep -vw -- cookbook-db-postgres-pool | grep -vw -- cookbook-db-sqlite-simple | grep -vw -- cookbook-file-upload | grep -vw -- cookbook-generic | grep -vw -- cookbook-hoist-server-with-context | grep -vw -- cookbook-https | grep -vw -- cookbook-jwt-and-basic-auth | 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"

173− - cat cabal.project || true

174− - cat cabal.project.local || true

175− - echo -en 'travis_fold:end:unpack\\r'

176−

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

178− # build & run tests, build benchmarks

179− - cabal new-build -w ${HC} ${TEST} ${BENCH} all

180− - echo -en 'travis_fold:end:build-everything\\r'

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

182−

183− - echo Haddock... && echo -en 'travis_fold:start:haddock\\r'

184− # haddock

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

186−

187− - echo -en 'travis_fold:end:haddock\\r'

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

189−# EOF

CONTRIBUTING.md+34−4

@@ -21,6 +21,7 @@ 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`.

24

25

25## General

26## General

26

27

@@ -34,7 +35,34 @@ Some things we like:

34Though we aren't sticklers for style, the `.stylish-haskell.yaml` and `HLint.hs`

35Though we aren't sticklers for style, the `.stylish-haskell.yaml` and `HLint.hs`

35files in the repository provide a good baseline for consistency.

36files in the repository provide a good baseline for consistency.

36

37

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.

38+**Important**: please do not modify the versions of the servant packages you are sending patches for.

39+

40+## Changelog entries

41+

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

43+You are not required to install it.

44+

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

46+

47+```cabal

48+synopsis: One sentence summary of the change.

49+prs: #1219

50+issues: #1028

51+

52+description: {

53+

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

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

56+for breaking changes.

57+

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

59+

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

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

62+for prose.

63+

64+}

65+```

38

66

39## PR process

67## PR process

40

68

@@ -51,8 +79,10 @@ not been a timely response to a PR, you can ping the Maintainers group (with

51We encourage people to experiment with new combinators and instances - it is

79We encourage people to experiment with new combinators and instances - it is

52one of the most powerful ways of using `servant`, and a wonderful way of

80one of the most powerful ways of using `servant`, and a wonderful way of

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

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

54−know about it! Either hop on #servant on freenode and let us know, or open an

82+know about it! Either hop on

83+[#haskell-servant on libera.chat](https://web.libera.chat/#haskell-servant) and

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

84+let us know, or open an issue with the `news` tag (which we will close when we

85+read it).

56

86

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

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

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

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

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

75

105

76## Release policy

106## Release policy

77

107

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

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

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

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

80releases it may take some time in between releases.

110releases it may take some time in between releases.

81

111

README.md+27−17

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

4

4

5## Getting Started

5## Getting Started

6

6

7−We have a [tutorial](http://haskell-servant.readthedocs.org/en/stable/tutorial/index.html) that

7+We have a [tutorial](http://docs.servant.dev/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 central documentation can be found [here](http://haskell-servant.readthedocs.org/).

12+The core documentation can be found [here](http://docs.servant.dev/).

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://haskell-servant.github.io/).

14+[website](http://www.servant.dev/).

15

15

16−If you need help, drop by the IRC channel (#servant on freenode) or [mailing

16+If you need help, drop by the IRC channel (#haskell-servant on libera.chat) or [mailing

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`, and *protect it* from accidental force pushes.

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

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 good idea to test against older `servant` version too.

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

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,22 +40,32 @@ 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−## travis

43+## TechEmpower framework benchmarks

44

44

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

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

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

47

46

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

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

49

48

50−```

49+```sh

51−runghc ~/Documents/other-haskell/multi-ghc-travis/make_travis_yml_2.hs regenerate

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

52```

51```

53

52

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

53+To compare with `warp`

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

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

57

54

55+```sh

56+./tfb --mode benchmark --test warp servant servant-beam servant-psql-simple --type json plaintext db fortune

58```

57```

59−constraints:

58+

60− troublemaker <13.37 && > 13.37

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

60+

61+```sh

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

61```

63```

64+

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

66+

67+## Nix

68+

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

70+

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

cabal.ghcjs.project+5−15

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

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

4

2

5packages:

3packages:

6 servant/

4 servant/

5+ servant-client/

7 servant-client-core/

6 servant-client-core/

8− servant-client-ghcjs/

9

7

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

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

11compiler: ghcjs

9compiler: ghcjs

10+tests: True

12

11

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

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

14−constraints: primitive <0.6.4

13+constraints: attoparsec == 0.13.2.2

15−

14+constraints: hashable == 1.3.0.0

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-ymldeleted−15

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

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+28−27

@@ -1,19 +1,35 @@

1−packages: servant/

1+packages:

2+ servant/

3+ servant-auth/servant-auth

4+ servant-auth/servant-auth-client

5+ servant-auth/servant-auth-docs

6+ servant-auth/servant-auth-server

7+ servant-auth/servant-auth-swagger

8+

2 servant-client/

9 servant-client/

3 servant-client-core/

10 servant-client-core/

11+ servant-http-streams/

4 servant-docs/

12 servant-docs/

5 servant-foreign/

13 servant-foreign/

6 servant-server/

14 servant-server/

15+ servant-swagger/

7 doc/tutorial/

16 doc/tutorial/

8

17

18+-- servant streaming

19+packages:

9 servant-machines/

20 servant-machines/

10 servant-conduit/

21 servant-conduit/

11 servant-pipes/

22 servant-pipes/

12

23

13− -- doc/cookbook/*/*.cabal

24+-- servant GHCJS

25+-- packages:

26+-- servant-jsaddle/

14

27

28+-- Cookbooks

29+packages:

15 doc/cookbook/basic-auth

30 doc/cookbook/basic-auth

16 doc/cookbook/curl-mock

31 doc/cookbook/curl-mock

32+ doc/cookbook/custom-errors

17 doc/cookbook/basic-streaming

33 doc/cookbook/basic-streaming

18 doc/cookbook/db-postgres-pool

34 doc/cookbook/db-postgres-pool

19 doc/cookbook/db-sqlite-simple

35 doc/cookbook/db-sqlite-simple

@@ -21,32 +37,17 @@ packages: servant/

21 doc/cookbook/generic

37 doc/cookbook/generic

22 doc/cookbook/hoist-server-with-context

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

23 doc/cookbook/https

39 doc/cookbook/https

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

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

25− -- doc/cookbook/pagination

41+ doc/cookbook/pagination

26− -- doc/cookbook/sentry

42+ -- doc/cookbook/sentry

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

27− doc/cookbook/testing

44+ -- doc/cookbook/testing

45+ doc/cookbook/uverb

28 doc/cookbook/structuring-apis

46 doc/cookbook/structuring-apis

29 doc/cookbook/using-custom-monad

47 doc/cookbook/using-custom-monad

30 doc/cookbook/using-free-client

48 doc/cookbook/using-free-client

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

31

50

32−tests: true

51+tests: True

33−

52+optimization: False

34−allow-newer:

53+-- reorder-goals: True

35− servant-js:base

36−

37−constraints:

38− -- see https://github.com/haskell-infra/hackage-trustees/issues/119

39− foundation >=0.0.14,

40− memory <0.14.12 || >0.14.12

41−

42−allow-newer:

43−-- servant-pagination:servant, servant-pagination:servant-server,

44−-- servant-multipart:servant, servant-multipart:servant-server,

45−-- servant-auth-server:servant, servant-auth-server:servant-server, servant-auth-server:http-api-data,

46−-- servant-js:servant, servant-js:servant-foreign,

47−

48−-- servant-quickcheck

49−allow-newer:

50− servant-quickcheck:servant, servant-quickcheck:servant-client, servant-quickcheck:servant-server,

51− servant-quickcheck:hspec,

52− servant-quickcheck:http-client

changelog.d/1432new file+9

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

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

2+prs: #1432

3+issues: #1418

4+description: {

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

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

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

8+query parameters.

9+}

changelog.d/1469new file+11

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

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

2+prs: #1469

3+description: {

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

5+`clientWithRoute` definitions.

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

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

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

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

10+the `Verb` status.

11+}

changelog.d/1477new file+9

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

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

2+prs: #1477

3+

4+description: {

5+

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

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

8+

9+}

changelog.d/1529new file+10

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

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

2+prs: #1529

3+

4+description: {

5+

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

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

8+functionality to match what servant-client provides.

9+

10+}

changelog.d/1556new file+81

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

1+synopsis: Display capture hints in router layout

2+prs: #1556

3+

4+description: {

5+

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

7+

8+Example:

9+

10+For the following API

11+```haskell

12+type API =

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

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

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

16+```

17+

18+we previously got the following output:

19+

20+```

21+/

22+├─ a/

23+│ ├─ d/

24+│ │ └─•

25+│ └─ e/

26+│ └─•

27+└─ b/

28+ └─ <capture>/

29+ ├─•

30+ ┆

31+ └─•

32+```

33+

34+now we get:

35+

36+```

37+/

38+├─ a/

39+│ ├─ d/

40+│ │ └─•

41+│ └─ e/

42+│ └─•

43+└─ b/

44+ └─ <x::Int>/

45+ ├─•

46+ ┆

47+ └─•

48+```

49+

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

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

52+

53+N.B.:

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

55+

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

57+

58+Warning:

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

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

61+

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

63+```haskell

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

65+

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

67+myServer = const $ return ()

68+

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

70+myApi = Proxy

71+

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

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

74+```

75+

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

77+```haskell

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

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

80+```

81+}

changelog.d/1569new file+13

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

1+synopsis: Encode captures using toEncodedUrlPiece

2+prs: #1569

3+issues: #1511

4+

5+description: {

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

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

8+URL-encoding however they need.

9+

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

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

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

13+}

changelog.d/1580new file+12

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

1+synopsis: Allow IO in validationKeys

2+prs: #1580

3+issues: #1579

4+

5+description: {

6+

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

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

9+discover new and expired keys.

10+

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

12+}

changelog.d/1589new file+2

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

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

2+prs: 1589

changelog.d/1595new file+2

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

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

2+prs: #1595

changelog.d/confignew file+2

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

1+organization: haskell-servant

2+repository: servant

changelog.d/servant-docs-curlnew file+16

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

1+synopsis: Add sample cURL requests to generated documentation

2+prs: #1401

3+

4+description: {

5+

6+Add sample cURL requests to generated documentation.

7+

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

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

10+

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

12+

13+becomes

14+

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

16+}

default.nixnew file+38

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

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

2+{

3+ pkgs ? import (builtins.fetchTarball {

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

5+ inherit sha256;

6+ }) {}

7+, compiler ? "ghc883"

8+}:

9+let

10+ overrides = self: super: {

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

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

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

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

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

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

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

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

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

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

21+ };

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

23+in

24+ with hPkgs;

25+ {

26+ inherit

27+ servant

28+ servant-client

29+ servant-client-core

30+ servant-conduit

31+ servant-docs

32+ servant-foreign

33+ servant-http-streams

34+ servant-machines

35+ servant-pipes

36+ servant-server;

37+ }

38+

doc/Makefile+1−1

@@ -10,7 +10,7 @@ BUILDDIR = _build

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 building-the-docs file."; fi

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

14 @if [ ! "z$$(which $(SPHINXBUILD))" = "z$$(pwd)/venv/bin/sphinx-build" ]; then echo "WARNING: Did you forgot to 'source venv/bin/activate'"; 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)

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

16

16

doc/README.mdnew 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/building-the-docsdeleted−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/conf.py+1−3

@@ -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'2018, Servant Contributors'

49+copyright = u'2022, 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,7 +167,5 @@ texinfo_documents = [

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

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

168

168

169source_parsers = {

169source_parsers = {

170− '.md': CommonMarkParser,

171 '.lhs': CommonMarkParser,

170 '.lhs': CommonMarkParser,

172}

171}

173−

doc/cookbook/basic-auth/basic-auth.cabal+4−4

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

1+cabal-version: 2.2

1name: cookbook-basic-auth

2name: cookbook-basic-auth

2version: 0.1

3version: 0.1

3synopsis: Basic Authentication cookbook example

4synopsis: Basic Authentication cookbook example

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

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

5−license: BSD3

6+license: BSD-3-Clause

6license-file: ../../../servant/LICENSE

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

7author: Servant Contributors

8author: Servant Contributors

8maintainer: haskell-servant-maintainers@googlegroups.com

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

9build-type: Simple

10build-type: Simple

10−cabal-version: >=1.10

11−tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.2

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

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.lhs+4−1

@@ -8,7 +8,10 @@ In other words, without streaming libraries.

8- Some basic usage doesn't require usage of streaming libraries,

8- Some basic usage doesn't require usage of streaming libraries,

9 like `conduit`, `pipes`, `machines` or `streaming`.

9 like `conduit`, `pipes`, `machines` or `streaming`.

10 We have bindings for them though.

10 We have bindings for them though.

11−- This is similar example file, which is bundled with each of the packages (TODO: links)

11+- Similar example is bundled with each of our streaming library interop packages (see

12+[servant-pipes](https://github.com/haskell-servant/servant/blob/master/servant-pipes/example/Main.hs),

13+[servant-conduit](https://github.com/haskell-servant/servant/blob/master/servant-conduit/example/Main.hs) and

14+[servant-machines](https://github.com/haskell-servant/servant/blob/master/servant-machines/example/Main.hs))

12- `SourceT` doesn't have *Prelude* with handy combinators, so we have to write

15- `SourceT` doesn't have *Prelude* with handy combinators, so we have to write

13 things ourselves. (Note to self: `mapM` and `foldM` would be handy to have).

16 things ourselves. (Note to self: `mapM` and `foldM` would be handy to have).

14

17

doc/cookbook/basic-streaming/basic-streaming.cabal+5−5

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

1+cabal-version: 2.2

1name: cookbook-basic-streaming

2name: cookbook-basic-streaming

2version: 2.1

3version: 2.1

3synopsis: Streaming in servant without streaming libs

4synopsis: Streaming in servant without streaming libs

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

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

5−license: BSD3

6+license: BSD-3-Clause

6license-file: ../../../servant/LICENSE

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

7author: Servant Contributors

8author: Servant Contributors

8maintainer: haskell-servant-maintainers@googlegroups.com

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

9build-type: Simple

10build-type: Simple

10−cabal-version: >=1.10

11−tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.2

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

12

12

13executable cookbook-basic-streaming

13executable cookbook-basic-streaming

14 main-is: Streaming.lhs

14 main-is: Streaming.lhs

@@ -17,7 +17,7 @@ executable cookbook-basic-streaming

17 ghc-options: -Wall -pgmL markdown-unlit -threaded -rtsopts

17 ghc-options: -Wall -pgmL markdown-unlit -threaded -rtsopts

18

18

19 hs-source-dirs: .

19 hs-source-dirs: .

20− build-depends: base >= 4.8 && <4.13

20+ build-depends: base >= 4.8 && <5

21 , aeson

21 , aeson

22 , bytestring

22 , bytestring

23 , servant

23 , servant

doc/cookbook/cabal.project+2

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

1packages:

1packages:

2 basic-auth/

2 basic-auth/

3 curl-mock/

3 curl-mock/

4+ db-mysql-basics/

4 db-sqlite-simple/

5 db-sqlite-simple/

5 db-postgres-pool/

6 db-postgres-pool/

6 using-custom-monad/

7 using-custom-monad/

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

12 pagination/

13 pagination/

13 sentry/

14 sentry/

14 testing/

15 testing/

16+ open-id-connect/

15 ../../servant

17 ../../servant

16 ../../servant-server

18 ../../servant-server

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

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

doc/cookbook/cabal.project.localnew file

No changes to the content.

doc/cookbook/curl-mock/CurlMock.lhs+9−22

@@ -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 usefull for testing and development purposes.

4+This may be useful 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.

@@ -24,7 +24,6 @@ Language extensions and imports:

24import Control.Lens ((^.))

24import Control.Lens ((^.))

25import Data.Aeson

25import Data.Aeson

26import Data.Aeson.Text

26import Data.Aeson.Text

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

28import Data.Proxy (Proxy (Proxy))

27import Data.Proxy (Proxy (Proxy))

29import Data.Text (Text)

28import Data.Text (Text)

30import Data.Text.Encoding (decodeUtf8)

29import Data.Text.Encoding (decodeUtf8)

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

76```

75```

77

76

78

77

79−## servant-forgein and the HasForeignType Class

78+## servant-foreign and the HasForeignType Class

80

79

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

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

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

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

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

86```

85```

87

86

88This looks a bit confusing...

87This looks a bit confusing...

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

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

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.

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.

91

90

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

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

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

130generateCurl p host =

129generateCurl p host =

131 fmap T.unlines body

130 fmap T.unlines body

132 where

131 where

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

132+ body = mapM (generateEndpoint host)

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

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

135```

134```

136

135

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

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

138−

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

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:

151

138

152``` haskell

139``` haskell

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

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

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

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

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

170

157

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

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

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

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

173

160

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

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

175

162

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

201``` haskell

188``` haskell

202main :: IO ()

189main :: IO ()

203main =

190main =

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

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

205```

192```

206

193

207Done:

194Done:

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

213```

200```

214

201

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

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

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

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

217

204

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

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

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

@@ -1,16 +1,19 @@

1+cabal-version: 2.2

1name: cookbook-curl-mock

2name: cookbook-curl-mock

2version: 0.1

3version: 0.1

3synopsis: Generate curl mock requests cookbook example

4synopsis: Generate curl mock requests cookbook example

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

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

5−license: BSD3

6+license: BSD-3-Clause

6license-file: ../../../servant/LICENSE

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

7author: Servant Contributors

8author: Servant Contributors

8maintainer: haskell-servant-maintainers@googlegroups.com

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

9build-type: Simple

10build-type: Simple

10−cabal-version: >=1.10

11−tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.2

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

12

12

13executable cookbock-curl-mock

13executable cookbock-curl-mock

14+ if impl(ghc >= 9.2)

15+ -- generic-arbitrary is incompatible

16+ buildable: False

14 main-is: CurlMock.lhs

17 main-is: CurlMock.lhs

15 build-depends: base == 4.*

18 build-depends: base == 4.*

16 , aeson

19 , aeson

doc/cookbook/custom-errors/CustomErrors.lhsnew file+189

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

1+# Customizing errors from Servant

2+

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

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

5+

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

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

8+

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

10+

11+Extensions and imports:

12+```haskell

13+{-# LANGUAGE DataKinds #-}

14+{-# LANGUAGE DeriveGeneric #-}

15+{-# LANGUAGE OverloadedStrings #-}

16+{-# LANGUAGE PolyKinds #-}

17+{-# LANGUAGE TypeFamilies #-}

18+{-# LANGUAGE TypeOperators #-}

19+

20+import Data.Aeson

21+import Data.Proxy

22+import Data.Text

23+import GHC.Generics

24+import Network.Wai

25+import Network.Wai.Handler.Warp

26+

27+import Servant

28+

29+import Data.String.Conversions

30+ (cs)

31+import Servant.API.ContentTypes

32+```

33+

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

35+

36+```haskell

37+-- | A greet message data type

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

39+ deriving (Generic, Show)

40+

41+instance FromJSON Greet

42+instance ToJSON Greet

43+

44+-- API specification

45+type TestApi =

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

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

48+

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

50+ -- returns a Greet as JSON

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

52+

53+ -- DELETE /greet/:greetid

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

55+

56+testApi :: Proxy TestApi

57+testApi = Proxy

58+

59+-- Server-side handlers.

60+--

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

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

63+--

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

65+server :: Server TestApi

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

67+

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

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

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

71+

72+ postGreetH greet = return greet

73+

74+ deleteGreetH _ = return NoContent

75+```

76+

77+## Error formatters

78+

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

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

81+

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

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

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

85+ `Type.Reflection` modules.

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

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

88+

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

90+

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

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

93+

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

95+

96+```json

97+{

98+ "error": "ERROR MESSAGE",

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

100+}

101+```

102+

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

104+message only if client can accept it.

105+

106+```haskell

107+customFormatter :: ErrorFormatter

108+customFormatter tr req err =

109+ let

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

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

112+ -- Accept header of the request

113+ accH = getAcceptHeader req

114+ in

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

116+ -- certain message type.

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

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

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

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

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

122+ Just (ctypeH, body) -> err400

123+ { errBody = body

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

125+ }

126+

127+notFoundFormatter :: NotFoundErrorFormatter

128+notFoundFormatter req =

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

130+```

131+

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

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

134+

135+```

136+err400

137+ { errBody = encode body

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

139+ }

140+```

141+

142+## Passing formatters to Servant

143+

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

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

146+

147+- `bodyParserErrorFormatter :: ErrorFormatter`

148+- `urlParseErrorFormatter :: ErrorFormatter`

149+- `headerParseErrorFormatter :: ErrorFormatter`

150+- `notFoundErrorFormatter :: NotFoundErrorFormatter`

151+

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

153+set the only ones you need:

154+

155+```haskell

156+customFormatters :: ErrorFormatters

157+customFormatters = defaultErrorFormatters

158+ { bodyParserErrorFormatter = customFormatter

159+ , notFoundErrorFormatter = notFoundFormatter

160+ }

161+```

162+

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

164+

165+```haskell

166+app :: Application

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

168+

169+main :: IO ()

170+main = run 8000 app

171+```

172+

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

174+

175+```

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

177+HTTP/1.1 400 Bad Request

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

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

180+Server: Warp/3.3.12

181+Transfer-Encoding: chunked

182+

183+{

184+ "combinator": "ReqBody'",

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

186+}

187+```

188+

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

doc/cookbook/custom-errors/custom-errors.cabalnew file+25

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

1+cabal-version: 2.2

2+name: cookbook-custom-errors

3+version: 0.1

4+synopsis: Return custom error messages from combinators

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

6+license: BSD-3-Clause

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

8+author: Servant Contributors

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

10+build-type: Simple

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

12+

13+executable cookbook-custom-errors

14+ main-is: CustomErrors.lhs

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

16+ , aeson

17+ , servant

18+ , servant-server

19+ , string-conversions

20+ , text

21+ , wai

22+ , warp

23+ default-language: Haskell2010

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

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

doc/cookbook/db-mysql-basics/MysqlBasics.lhsnew file+236

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

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.cabalnew file+40

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

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

1name: cookbook-db-postgres-pool

2name: cookbook-db-postgres-pool

2version: 0.1

3version: 0.1

3synopsis: Simple PostgreSQL connection pool cookbook example

4synopsis: Simple PostgreSQL connection pool cookbook example

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

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

5−license: BSD3

6+license: BSD-3-Clause

6license-file: ../../../servant/LICENSE

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

7author: Servant Contributors

8author: Servant Contributors

8maintainer: haskell-servant-maintainers@googlegroups.com

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

9build-type: Simple

10build-type: Simple

10−cabal-version: >=1.10

11−tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.2

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

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

1name: cookbook-db-sqlite-simple

2name: cookbook-db-sqlite-simple

2version: 0.1

3version: 0.1

3synopsis: Simple SQLite DB cookbook example

4synopsis: Simple SQLite DB cookbook example

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

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

5−license: BSD3

6+license: BSD-3-Clause

6license-file: ../../../servant/LICENSE

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

7author: Servant Contributors

8author: Servant Contributors

8maintainer: haskell-servant-maintainers@googlegroups.com

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

9build-type: Simple

10build-type: Simple

10−cabal-version: >=1.10

11−tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.2

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

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

26+ , sqlite-simple >= 0.4.5.0

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

@@ -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, has servant-multipart does not

93+servant-client this time, as 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://haskell-servant.readthedocs.org/en/stable/tutorial/index.html) that

129+We have a [tutorial](http://docs.servant.dev/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

1name: cookbook-file-upload

2name: cookbook-file-upload

2version: 0.1

3version: 0.1

3synopsis: File upload cookbook example

4synopsis: File upload cookbook example

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

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

5−license: BSD3

6+license: BSD-3-Clause

6license-file: ../../../servant/LICENSE

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

7author: Servant Contributors

8author: Servant Contributors

8maintainer: haskell-servant-maintainers@googlegroups.com

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

9build-type: Simple

10build-type: Simple

10−cabal-version: >=1.10

11−tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.2

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

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

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

43api = genericApi (Proxy :: Proxy Routes)

43api = genericApi (Proxy :: Proxy Routes)

44```

44```

45

45

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

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

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

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

48

48

49## Links

49## Links

50

50

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

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

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

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

53as field accessors work as proxies:

53as field accessors work as proxies:

54

54

55```haskell

55```haskell

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

67## Client

67## Client

68

68

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

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

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

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

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

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

72

72

73```haskell

73```haskell

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

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

1+cabal-version: 2.2

1name: cookbook-generic

2name: cookbook-generic

2version: 0.1

3version: 0.1

3synopsis: Using custom monad to pass a state between handlers

4synopsis: Using custom monad to pass a state between handlers

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

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

5−license: BSD3

6+license: BSD-3-Clause

6license-file: ../../../servant/LICENSE

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

7author: Servant Contributors

8author: Servant Contributors

8maintainer: haskell-servant-maintainers@googlegroups.com

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

9build-type: Simple

10build-type: Simple

10−cabal-version: >=1.10

11−tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.2

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

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

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

254 liftIO $ pushLogStrLn logset $ toLogStr logMsg

254 liftIO $ pushLogStrLn logset $ toLogStr logMsg

255 throwError err401

255 throwError err401

256 Just applyCookies -> do

256 Just applyCookies -> do

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

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

258 liftIO $ pushLogStrLn logset $ toLogStr successMsg

258 liftIO $ pushLogStrLn logset $ toLogStr successMsg

259 pure $ applyCookies successMsg

259 pure $ applyCookies successMsg

260loginHandler _ _ _ = throwError err401

260loginHandler _ _ _ = throwError err401

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

287 (flip runReaderT ctx) (adminServer cs jwts)

287 (flip runReaderT ctx) (adminServer cs jwts)

288```

288```

289

289

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

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

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

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

292

292

293```haskell

293```haskell

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

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

1+cabal-version: 2.2

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

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

2version: 0.0.1

3version: 0.0.1

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

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

4description: Using servant-auth to support both JWT-based and basic

5description: Using servant-auth to support both JWT-based and basic

5 authentication.

6 authentication.

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

7+homepage: http://docs.servant.dev/

7−license: BSD3

8+license: BSD-3-Clause

8license-file: ../../../servant/LICENSE

9license-file: ../../../servant/LICENSE

9author: Servant Contributors

10author: Servant Contributors

10maintainer: haskell-servant-maintainers@googlegroups.com

11maintainer: haskell-servant-maintainers@googlegroups.com

11category: Servant

12category: Servant

12build-type: Simple

13build-type: Simple

13−cabal-version: >=1.10

14−tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.2

14+tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7

15

15

16executable cookbook-hoist-server-with-context

16executable cookbook-hoist-server-with-context

17 main-is: HoistServerWithContext.lhs

17 main-is: HoistServerWithContext.lhs

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

24 , servant

24 , servant

25 , servant-server

25 , servant-server

26 , servant-auth >= 0.3.2

26 , servant-auth >= 0.3.2

27− , servant-auth-server

27+ , servant-auth-server >= 0.4.4.0

28 , time

28 , time

29 , warp >= 3.2

29 , warp >= 3.2

30 , wai >= 3.2

30 , 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-3.2.4/docs/Network-Wai-Handler-WarpTLS.html)

37+The [`warp-tls`](https://hackage.haskell.org/package/warp-tls/docs/Network-Wai-Handler-WarpTLS.html)

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-3.2.4/docs/Network-Wai-Handler-WarpTLS.html#v:runTLS)

39+[`runTLS`](https://hackage.haskell.org/package/warp-tls/docs/Network-Wai-Handler-WarpTLS.html#v:runTLS)

40−and [`runTLSSocket`](https://hackage.haskell.org/package/warp-tls-3.2.4/docs/Network-Wai-Handler-WarpTLS.html#v:runTLSSocket).

40+and [`runTLSSocket`](https://hackage.haskell.org/package/warp-tls/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-3.2.4/docs/Network-Wai-Handler-WarpTLS.html#t:TLSSettings)

44+[the TLS settings](https://hackage.haskell.org/package/warp-tls/docs/Network-Wai-Handler-WarpTLS.html#t:TLSSettings)

45(certificates, keys, ciphers, etc)

45(certificates, keys, ciphers, etc)

46−and [the warp settings](https://hackage.haskell.org/package/warp-3.2.12/docs/Network-Wai-Handler-Warp-Internal.html#t:Settings)

46+and [the warp settings](https://hackage.haskell.org/package/warp/docs/Network-Wai-Handler-Warp-Internal.html#t:Settings)

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

1name: cookbook-https

2name: cookbook-https

2version: 0.1

3version: 0.1

3synopsis: HTTPS cookbook example

4synopsis: HTTPS cookbook example

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

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

5−license: BSD3

6+license: BSD-3-Clause

6license-file: ../../../servant/LICENSE

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

7author: Servant Contributors

8author: Servant Contributors

8maintainer: haskell-servant-maintainers@googlegroups.com

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

9build-type: Simple

10build-type: Simple

10−cabal-version: >=1.10

11−tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.2

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

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

20+ , warp-tls >= 3.2.9

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

@@ -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 **#servant** IRC channel

9+or even to just get in touch with us on the `**#haskell-servant** IRC channel

10−on freenode or on

10+on libera.chat <https://web.libera.chat/#haskell-servant>_ 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,11 +20,15 @@ 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

23 db-sqlite-simple/DBConnection.lhs

24 db-sqlite-simple/DBConnection.lhs

24 db-postgres-pool/PostgresPool.lhs

25 db-postgres-pool/PostgresPool.lhs

25 using-custom-monad/UsingCustomMonad.lhs

26 using-custom-monad/UsingCustomMonad.lhs

26 using-free-client/UsingFreeClient.lhs

27 using-free-client/UsingFreeClient.lhs

28+ custom-errors/CustomErrors.lhs

29+ uverb/UVerb.lhs

27 basic-auth/BasicAuth.lhs

30 basic-auth/BasicAuth.lhs

31+ basic-streaming/Streaming.lhs

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

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

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

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

30 file-upload/FileUpload.lhs

34 file-upload/FileUpload.lhs

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

32 curl-mock/CurlMock.lhs

36 curl-mock/CurlMock.lhs

33 sentry/Sentry.lhs

37 sentry/Sentry.lhs

34 testing/Testing.lhs

38 testing/Testing.lhs

39+ open-id-connect/OpenIdConnect.lhs

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

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

1+cabal-version: 2.2

1name: cookbook-jwt-and-basic-auth

2name: cookbook-jwt-and-basic-auth

2version: 0.0.1

3version: 0.0.1

3synopsis: JWT and basic access authentication cookbook example

4synopsis: JWT and basic access authentication cookbook example

4description: Using servant-auth to support both JWT-based and basic

5description: Using servant-auth to support both JWT-based and basic

5 authentication.

6 authentication.

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

7+homepage: http://docs.servant.dev/

7−license: BSD3

8+license: BSD-3-Clause

8license-file: ../../../servant/LICENSE

9license-file: ../../../servant/LICENSE

9author: Servant Contributors

10author: Servant Contributors

10maintainer: haskell-servant-maintainers@googlegroups.com

11maintainer: haskell-servant-maintainers@googlegroups.com

11category: Servant

12category: Servant

12build-type: Simple

13build-type: Simple

13−cabal-version: >=1.10

14−tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.2

14+tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7

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.3.*

25+ , servant-auth == 0.4.*

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/open-id-connect/OpenIdConnect.cabalnew file+45

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

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.lhsnew file+472

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

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 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 document, and augment the

21+As a response, the server may return the list of corresponding documents, 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 definintion

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

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 mentionned in introduction. Expanding the alias boils down to the following:

151+we mentioned 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 (tight to the `Range` HTTP header) indicates the server to parse any `Range`

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

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 deducted from the `RangeOptions` that are part of the `HasPagination` instance. Therefore, all

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

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 annotation are

222+instance. Doing so will make the other helper functions more ambiguous and type annotations 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 overwritten when defining the instance to provide

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

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

239+your own options. These 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

1name: cookbook-pagination

2name: cookbook-pagination

2version: 2.1

3version: 2.1

3synopsis: Pagination with Servant example

4synopsis: Pagination with Servant example

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

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

5−license: BSD3

6+license: BSD-3-Clause

6license-file: ../../../servant/LICENSE

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

7author: Servant Contributors

8author: Servant Contributors

8maintainer: haskell-servant-maintainers@googlegroups.com

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

9build-type: Simple

10build-type: Simple

10−cabal-version: >=1.10

11−tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.2

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

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.8 && <4.13

18+ build-depends: base >= 4.9 && <5

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 trasport, which generally would be `sendRecord`, an HTTPS capable trasport which uses http-conduit

82+- an event transport, which generally would be `sendRecord`, an HTTPS capable transport which uses http-conduit

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-0.1.2.0/docs/System-Log-Raven-Types.html#t:SentryLevel) for the possible options)

89+- the error level (see [SentryLevel](https://hackage.haskell.org/package/raven-haskell/docs/System-Log-Raven-Types.html#t:SentryLevel) for the possible options)

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

1name: cookbook-sentry

2name: cookbook-sentry

2version: 0.1

3version: 0.1

3synopsis: Collecting runtime exceptions using Sentry

4synopsis: Collecting runtime exceptions using Sentry

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

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

5−license: BSD3

6+license: BSD-3-Clause

6license-file: ../../../servant/LICENSE

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

7author: Servant Contributors

8author: Servant Contributors

8maintainer: haskell-servant-maintainers@googlegroups.com

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

9build-type: Simple

10build-type: Simple

10−cabal-version: >=1.10

11−tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.2

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

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− -> Server (SimpleAPI name a i) m

147+ -> ServerT (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

1name: cookbook-structuring-apis

2name: cookbook-structuring-apis

2version: 0.1

3version: 0.1

3synopsis: Example that shows how APIs can be structured

4synopsis: Example that shows how APIs can be structured

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

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

5−license: BSD3

6+license: BSD-3-Clause

6license-file: ../../../servant/LICENSE

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

7author: Servant Contributors

8author: Servant Contributors

8maintainer: haskell-servant-maintainers@googlegroups.com

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

9build-type: Simple

10build-type: Simple

10−cabal-version: >=1.10

11−tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.2

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

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+13−15

@@ -142,33 +142,31 @@ of it and see how it responds.

142Let's write some tests:

142Let's write some tests:

143

143

144```haskell

144```haskell

145−withUserApp :: IO () -> IO ()

145+withUserApp :: (Warp.Port -> IO ()) -> IO ()

146withUserApp action =

146withUserApp action =

147− -- we can spin up a server in another thread and kill that thread when done

147+ -- testWithApplication makes sure the action is executed after the server has

148− -- in an exception-safe way

148+ -- started and is being properly shutdown.

149− bracket (liftIO $ C.forkIO $ Warp.run 8888 userApp)

149+ Warp.testWithApplication (pure userApp) action

150− C.killThread

151− (const action)

152

150

153

151

154businessLogicSpec :: Spec

152businessLogicSpec :: Spec

155businessLogicSpec =

153businessLogicSpec =

156 -- `around` will start our Server before the tests and turn it off after

154 -- `around` will start our Server before the tests and turn it off after

157− around_ withUserApp $ do

155+ around withUserApp $ do

158 -- create a test client function

156 -- create a test client function

159 let createUser = client (Proxy :: Proxy UserApi)

157 let createUser = client (Proxy :: Proxy UserApi)

160 -- create a servant-client ClientEnv

158 -- create a servant-client ClientEnv

161− baseUrl <- runIO $ parseBaseUrl "http://localhost:8888"

159+ baseUrl <- runIO $ parseBaseUrl "http://localhost"

162 manager <- runIO $ newManager defaultManagerSettings

160 manager <- runIO $ newManager defaultManagerSettings

163− let clientEnv = mkClientEnv manager baseUrl

161+ let clientEnv port = mkClientEnv manager (baseUrl { baseUrlPort = port })

164

162

165 -- testing scenarios start here

163 -- testing scenarios start here

166 describe "POST /user" $ do

164 describe "POST /user" $ do

167− it "should create a user with a high enough ID" $ do

165+ it "should create a user with a high enough ID" $ \port -> do

168− result <- runClientM (createUser 50001) clientEnv

166+ result <- runClientM (createUser 50001) (clientEnv port)

169 result `shouldBe` (Right $ User { name = "some user", user_id = 50001})

167 result `shouldBe` (Right $ User { name = "some user", user_id = 50001})

170− it "will it fail with a too-small ID?" $ do

168+ it "will it fail with a too-small ID?" $ \port -> do

171− result <- runClientM (createUser 4999) clientEnv

169+ result <- runClientM (createUser 4999) (clientEnv port)

172 result `shouldBe` (Right $ User { name = "some user", user_id = 50001})

170 result `shouldBe` (Right $ User { name = "some user", user_id = 50001})

173```

171```

174

172

@@ -234,7 +232,7 @@ clientEnv esHost esPort = do

234 manager <- newManager defaultManagerSettings

232 manager <- newManager defaultManagerSettings

235 pure $ mkClientEnv manager baseUrl

233 pure $ mkClientEnv manager baseUrl

236

234

237−runSearchClient :: Text -> Text -> ClientM a -> IO (Either ServantError a)

235+runSearchClient :: Text -> Text -> ClientM a -> IO (Either ClientError a)

238runSearchClient esHost esPort = (clientEnv esHost esPort >>=) . runClientM

236runSearchClient esHost esPort = (clientEnv esHost esPort >>=) . runClientM

239```

237```

240

238

@@ -267,7 +265,7 @@ docServer esHost esPort = getDocById esHost esPort

267-- actions

265-- actions

268getDocById :: Text -> Text -> Integer -> Handler Value

266getDocById :: Text -> Text -> Integer -> Handler Value

269getDocById esHost esPort docId = do

267getDocById esHost esPort docId = do

270− -- Our Servant Client function returns Either ServantError Value here:

268+ -- Our Servant Client function returns Either ClientError Value here:

271 docRes <- liftIO $ runSearchClient esHost esPort (getDocument docId)

269 docRes <- liftIO $ runSearchClient esHost esPort (getDocument docId)

272 case docRes of

270 case docRes of

273 Left err -> throwError $ err404 { errBody = "Failed looking up content" }

271 Left err -> throwError $ err404 { errBody = "Failed looking up content" }

doc/cookbook/testing/testing.cabal+5−5

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

1+cabal-version: 2.2

1name: cookbook-testing

2name: cookbook-testing

2version: 0.0.1

3version: 0.0.1

3synopsis: Common testing patterns in Servant apps

4synopsis: Common testing patterns in Servant apps

4description: This recipe includes various strategies for writing tests for Servant.

5description: This recipe includes various strategies for writing tests for Servant.

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

6+homepage: http://docs.servant.dev/

6−license: BSD3

7+license: BSD-3-Clause

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

8license-file: ../../../servant/LICENSE

8author: Servant Contributors

9author: Servant Contributors

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

10maintainer: haskell-servant-maintainers@googlegroups.com

10category: Servant

11category: Servant

11build-type: Simple

12build-type: Simple

12−cabal-version: >=1.10

13−tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.2

13+tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7

14

14

15executable cookbook-testing

15executable cookbook-testing

16 main-is: Testing.lhs

16 main-is: Testing.lhs

@@ -23,7 +23,7 @@ executable cookbook-testing

23 , servant

23 , servant

24 , servant-client

24 , servant-client

25 , servant-server

25 , servant-server

26− , servant-quickcheck

26+ , servant-quickcheck >= 0.0.10

27 , http-client

27 , http-client

28 , http-types >= 0.12

28 , http-types >= 0.12

29 , hspec

29 , hspec

doc/cookbook/using-custom-monad/UsingCustomMonad.lhs+1−1

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

1# Using a custom monad

1# Using a custom monad

2

2

3−In this section we will create and API for a book shelf without any backing DB storage.

3+In this section we will create an API for a book shelf without any backing DB storage.

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:

doc/cookbook/using-custom-monad/using-custom-monad.cabal+4−4

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

1+cabal-version: 2.2

1name: cookbook-using-custom-monad

2name: cookbook-using-custom-monad

2version: 0.1

3version: 0.1

3synopsis: Using custom monad to pass a state between handlers

4synopsis: Using custom monad to pass a state between handlers

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

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

5−license: BSD3

6+license: BSD-3-Clause

6license-file: ../../../servant/LICENSE

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

7author: Servant Contributors

8author: Servant Contributors

8maintainer: haskell-servant-maintainers@googlegroups.com

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

9build-type: Simple

10build-type: Simple

10−cabal-version: >=1.10

11−tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.2

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

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

@@ -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,8 +99,6 @@ 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 :(

104```

102```

105

103

106We are interested in `RunRequest`, that's what client should block on:

104We are interested in `RunRequest`, that's what client should block on:

@@ -121,7 +119,7 @@ Now we can use `servant-client`'s internals to convert servant's `Request`

121to http-client's `Request`, and we can inspect it:

119to http-client's `Request`, and we can inspect it:

122

120

123```haskell

121```haskell

124− let req' = I.requestToClientRequest burl req

122+ req' <- I.defaultMakeClientRequest burl req

125 putStrLn $ "Making request: " ++ show req'

123 putStrLn $ "Making request: " ++ show req'

126```

124```

127

125

@@ -137,13 +135,13 @@ And we continue by turning http-client's `Response` into servant's `Response`,

137and calling the continuation. We should get a `Pure` value.

135and calling the continuation. We should get a `Pure` value.

138

136

139```haskell

137```haskell

140− let res = I.clientResponseToResponse res'

138+ let res = I.clientResponseToResponse id res'

141−

139+

142 case k res of

140 case k res of

143 Pure n ->

141 Pure n ->

144 putStrLn $ "Expected 1764, got " ++ show n

142 putStrLn $ "Expected 1764, got " ++ show n

145− _ ->

143+ _ ->

146− putStrLn "ERROR: didn't got a response"

144+ putStrLn "ERROR: didn't get a response"

147```

145```

148

146

149So that's it. Using `Free` we can evaluate servant clients step-by-step, and

147So that's it. Using `Free` we can evaluate servant clients step-by-step, and

@@ -155,7 +153,7 @@ and responses available for us to inspect, since `RunClient` only gives us

155access to one `Request` or `Response` at a time.

153access to one `Request` or `Response` at a time.

156

154

157On the other hand, a "batch collection" of requests and/or responses can be achieved

155On the other hand, a "batch collection" of requests and/or responses can be achieved

158−with both free clients and a custom `RunClient` instance rather easily, for example

156+with both free clients and a custom `RunClient` instance rather easily, for example

159by using a `Writer [(Request, Response)]` monad.

157by using a `Writer [(Request, Response)]` monad.

160

158

161Here is an example of running our small `test` against a running server:

159Here 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

1name: cookbook-using-free-client

2name: cookbook-using-free-client

2version: 0.1

3version: 0.1

3synopsis: Using Free client

4synopsis: Using Free client

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

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

5−license: BSD3

6+license: BSD-3-Clause

6license-file: ../../../servant/LICENSE

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

7author: Servant Contributors

8author: Servant Contributors

8maintainer: haskell-servant-maintainers@googlegroups.com

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

9build-type: Simple

10build-type: Simple

10−cabal-version: >=1.10

11−tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.2

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

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.lhsnew file+223

@@ -0,0 +1,223 @@

1+# Listing alternative responses and exceptions in your API types

2+

3+Servant allows you to talk about the exceptions you throw in your API

4+types. This is not limited to actual exceptions, you can write

5+handlers that respond with arbitrary open unions of types.

6+

7+## Compatibility

8+

9+:warning: This cookbook is compatible with GHC 8.6.1 or higher :warning:

10+

11+## Preliminaries

12+

13+```haskell

14+{-# LANGUAGE ConstraintKinds #-}

15+{-# LANGUAGE DataKinds #-}

16+{-# LANGUAGE DeriveGeneric #-}

17+{-# LANGUAGE DerivingStrategies #-}

18+{-# LANGUAGE DeriveAnyClass #-}

19+{-# LANGUAGE DerivingVia #-}

20+{-# LANGUAGE FlexibleContexts #-}

21+{-# LANGUAGE FlexibleInstances #-}

22+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

23+{-# LANGUAGE InstanceSigs #-}

24+{-# LANGUAGE MultiParamTypeClasses #-}

25+{-# LANGUAGE OverloadedStrings #-}

26+{-# LANGUAGE ScopedTypeVariables #-}

27+{-# LANGUAGE StandaloneDeriving #-}

28+{-# LANGUAGE TypeApplications #-}

29+{-# LANGUAGE TypeFamilies #-}

30+{-# LANGUAGE TypeOperators #-}

31+{-# LANGUAGE UndecidableInstances #-}

32+{-# OPTIONS_GHC -Wall -Wno-orphans #-}

33+

34+import Control.Concurrent (threadDelay)

35+import Control.Concurrent.Async (async)

36+import Control.Monad (when)

37+import Control.Monad.Except (ExceptT (..), MonadError (..), MonadTrans (..), runExceptT)

38+import Data.Aeson (FromJSON (..), ToJSON (..))

39+import Data.Aeson.Encode.Pretty (encodePretty)

40+import Data.String.Conversions (cs)

41+import Data.Swagger (ToSchema)

42+import Data.Typeable (Proxy (Proxy))

43+import qualified GHC.Generics as GHC

44+import qualified Network.HTTP.Client as Client

45+import qualified Network.Wai.Handler.Warp as Warp

46+import Servant.API

47+import Servant.Client

48+import Servant.Server

49+import Servant.Swagger

50+```

51+

52+## The API

53+

54+This looks like a `Verb`-based routing table, except that `UVerb` has

55+no status, and carries a list of response types rather than a single

56+one. Each entry in the list carries its own response code.

57+

58+```haskell

59+type API =

60+ "fisx" :> Capture "bool" Bool

61+ :> UVerb 'GET '[JSON] '[FisxUser, WithStatus 303 String]

62+ :<|> "arian"

63+ :> UVerb 'GET '[JSON] '[WithStatus 201 ArianUser]

64+```

65+

66+Here are the details:

67+

68+```haskell

69+data FisxUser = FisxUser {name :: String}

70+ deriving (Eq, Show, GHC.Generic)

71+

72+instance ToJSON FisxUser

73+instance FromJSON FisxUser

74+instance ToSchema FisxUser

75+

76+-- | 'HasStatus' allows us to can get around 'WithStatus' if we want

77+-- to, and associate the status code with our resource types directly.

78+--

79+-- (To avoid orphan instances and make it more explicit what's in the

80+-- API and what isn't, we could even introduce a newtype 'Resource'

81+-- that wraps all the types we're using in our routing table, and then

82+-- define lots of 'HasStatus' instances for @Resource This@ and

83+-- @Resource That@.)

84+instance HasStatus FisxUser where

85+ type StatusOf FisxUser = 203

86+

87+data ArianUser = ArianUser

88+ deriving (Eq, Show, GHC.Generic)

89+

90+instance ToJSON ArianUser

91+instance FromJSON ArianUser

92+instance ToSchema ArianUser

93+```

94+

95+## Server, Client, Swagger

96+

97+You can just respond with any of the elements of the union in handlers.

98+

99+```haskell

100+fisx :: Bool -> Handler (Union '[FisxUser, WithStatus 303 String])

101+fisx True = respond (FisxUser "fisx")

102+fisx False = respond (WithStatus @303 ("still fisx" :: String))

103+

104+arian :: Handler (Union '[WithStatus 201 ArianUser])

105+arian = respond (WithStatus @201 ArianUser)

106+```

107+

108+You can create client functions like you're used to:

109+

110+```

111+fisxClient :: Bool -> ClientM (Union '[FisxUser, WithStatus 303 String])

112+arianClient :: ClientM (Union '[WithStatus 201 ArianUser])

113+(fisxClient :<|> arianClient) = client (Proxy @API)

114+```

115+

116+... and that's basically it! Here are a few sample commands that

117+show you how the swagger docs look like and how you can handle the

118+result unions in clients:

119+

120+```

121+main :: IO ()

122+main = do

123+ putStrLn . cs . encodePretty $ toSwagger (Proxy @API)

124+ _ <- async . Warp.run 8080 $ serve (Proxy @API) (fisx :<|> arian)

125+ threadDelay 50000

126+ mgr <- Client.newManager Client.defaultManagerSettings

127+ let cenv = mkClientEnv mgr (BaseUrl Http "localhost" 8080 "")

128+ result <- runClientM (fisxClient True) cenv

129+ print $ foldMapUnion (Proxy @Show) show <$> result

130+ print $ matchUnion @FisxUser <$> result

131+ print $ matchUnion @(WithStatus 303 String) <$> result

132+ pure ()

133+```

134+

135+## Idiomatic exceptions

136+

137+Since `UVerb` (probably) will mostly be used for error-like responses, it may be desirable to be able to early abort handler, like with current servant one would use `throwError` with `ServerError`.

138+

139+```haskell

140+newtype UVerbT xs m a = UVerbT { unUVerbT :: ExceptT (Union xs) m a }

141+ deriving (Functor, Applicative, Monad, MonadTrans)

142+

143+-- | Deliberately hide 'ExceptT's 'MonadError' instance to be able to use

144+-- underlying monad's instance.

145+instance MonadError e m => MonadError e (UVerbT xs m) where

146+ throwError = lift . throwError

147+ catchError (UVerbT act) h = UVerbT $ ExceptT $

148+ runExceptT act `catchError` (runExceptT . unUVerbT . h)

149+

150+-- | This combinator runs 'UVerbT'. It applies 'respond' internally, so the handler

151+-- may use the usual 'return'.

152+runUVerbT :: (Monad m, HasStatus x, IsMember x xs) => UVerbT xs m x -> m (Union xs)

153+runUVerbT (UVerbT act) = either id id <$> runExceptT (act >>= respond)

154+

155+-- | Short-circuit 'UVerbT' computation returning one of the response types.

156+throwUVerb :: (Monad m, HasStatus x, IsMember x xs) => x -> UVerbT xs m a

157+throwUVerb = UVerbT . ExceptT . fmap Left . respond

158+```

159+

160+Example usage:

161+

162+```haskell

163+data Foo = Foo Int Int Int

164+ deriving (Show, Eq, GHC.Generic, ToJSON)

165+ deriving HasStatus via WithStatus 200 Foo

166+

167+data Bar = Bar

168+ deriving (Show, Eq, GHC.Generic)

169+

170+instance ToJSON Bar

171+

172+h :: Handler (Union '[Foo, WithStatus 400 Bar])

173+h = runUVerbT $ do

174+ when ({- something bad -} True) $

175+ throwUVerb $ WithStatus @400 Bar

176+

177+ when ({- really bad -} False) $

178+ throwError $ err500

179+

180+ -- a lot of code here...

181+

182+ return $ Foo 1 2 3

183+```

184+

185+## Related Work

186+

187+There is the [issue from

188+2017](https://github.com/haskell-servant/servant/issues/841) that was

189+resolved by the introduction of `UVerb`, with a long discussion on

190+alternative designs.

191+

192+[servant-checked-exceptions](https://hackage.haskell.org/package/servant-checked-exceptions)

193+is a good solution to the problem, but it restricts the user to JSON

194+and a very specific envelop encoding for the union type, which is

195+often not acceptable. (One good reason for this design choice is that

196+it makes writing clients easier, where you need to get to the union

197+type from one representative, and you don't want to run several

198+parsers in the hope that the ones that should will always error out so

199+you can try until the right one returns a value.)

200+

201+[servant-exceptions](https://github.com/ch1bo/servant-exceptions) is

202+another shot at at the problem. It is inspired by

203+servant-checked-exceptions, so it may be worth taking a closer look.

204+The README claims that

205+[cardano-sl](https://github.com/input-output-hk/cardano-sl) also has

206+some code for generalized error handling.

207+

208+In an earier version of the `UVerb` implementation, we have used some

209+code from

210+[world-peace](https://hackage.haskell.org/package/world-peace), but

211+that package itself wasn't flexible enough, and we had to use

212+[sop-core](https://hackage.haskell.org/package/sop-core) to implement

213+the `HasServer` instance.

214+

215+Here is a blog post we found on the subject:

216+https://lukwagoallan.com/posts/unifying-servant-server-error-responses

217+

218+(If you have anything else, please add it here or let us know.)

219+

220+```haskell

221+main :: IO ()

222+main = return ()

223+```

doc/cookbook/uverb/uverb.cabalnew file+35

@@ -0,0 +1,35 @@

1+cabal-version: 2.2

2+name: cookbook-uverb

3+version: 0.0.1

4+synopsis: How to use the 'UVerb' type.

5+description: Listing alternative responses and exceptions in your API types.

6+homepage: http://docs.servant.dev/

7+license: BSD-3-Clause

8+license-file: ../../../servant/LICENSE

9+author: Servant Contributors

10+maintainer: haskell-servant-maintainers@googlegroups.com

11+category: Servant

12+build-type: Simple

13+tested-with: GHC==8.6.5, GHC==8.8.4, GHC==8.10.7

14+

15+executable cookbook-uverb

16+ main-is: UVerb.lhs

17+ build-depends: base == 4.*

18+ , aeson >= 1.2

19+ , aeson-pretty >= 0.8.8

20+ , async

21+ , http-client

22+ , mtl

23+ , servant

24+ , servant-client

25+ , servant-server

26+ , servant-swagger

27+ , string-conversions

28+ , swagger2

29+ , wai

30+ , warp

31+ if impl(ghc >= 9)

32+ buildable: False

33+ default-language: Haskell2010

34+ ghc-options: -Wall -pgmL markdown-unlit

35+ build-tool-depends: markdown-unlit:markdown-unlit

doc/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://haskell-servant.readthedocs.io/en/latest/cookbook/index.html) but

11+ Similar to [the cookbook](https://docs.servant.dev/en/latest/cookbook/index.html) but

12 with no explanations, for developers who just want to look at code examples to find out how to do X or Y

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− `haskell-servant.readthedocs.org <http://haskell-servant.readthedocs.org/>`_

6+ `docs.servant.dev <http://docs.servant.dev/>`_

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− ``#servant`` on freenode

15+ `#haskell-servant on libera.chat <https://web.libera.chat/#haskell-servant>`_

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− `haskell-servant.github.io <http://haskell-servant.github.io>`_

21+ `www.servant.dev <http://www.servant.dev>`_

22

22

23- the servant packages on hackage:

23- the servant packages on hackage:

24

24

doc/requirements.txt+3−3

@@ -1,3 +1,3 @@

1−recommonmark==0.4.0

1+recommonmark==0.5.0

2−Sphinx==1.7.5

2+Sphinx==1.8.4

3−sphinx_rtd_theme>=0.4.0

3+sphinx_rtd_theme>=0.4.2

doc/tutorial/ApiType.lhs+30−4

@@ -177,13 +177,12 @@ type UserAPI5 = "user" :> Capture "userid" Integer :> Get '[JSON] User

177 -- except that we explicitly say that "userid"

177 -- except that we explicitly say that "userid"

178 -- must be an integer

178 -- must be an integer

179

179

180− :<|> "user" :> Capture "userid" Integer :> DeleteNoContent '[JSON] NoContent

180+ :<|> "user" :> Capture "userid" Integer :> DeleteNoContent

181 -- equivalent to 'DELETE /user/:userid'

181 -- equivalent to 'DELETE /user/:userid'

182```

182```

183

183

184−In the second case, `DeleteNoContent` specifies a 204 response code,

184+In the second case, `DeleteNoContent` specifies a 204 response code

185−`JSON` specifies the content types on which the handler will match,

186−and `NoContent` says that the response will always be empty.

185+and that the response will always be empty.

187

186

188### `QueryParam`, `QueryParams`, `QueryFlag`

187### `QueryParam`, `QueryParams`, `QueryFlag`

189

188

@@ -390,3 +389,30 @@ One example for this is if you want to serve a directory of static files along

390with the rest of your API. But you can plug in everything that is an

389with the rest of your API. But you can plug in everything that is an

391`Application`, e.g. a whole web application written in any of the web

390`Application`, e.g. a whole web application written in any of the web

392frameworks that support `wai`.

391frameworks 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+10−11

@@ -47,7 +47,6 @@ 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 ((<>))

51import qualified Data.Map as Map

50import qualified Data.Map as Map

52import Data.Proxy (Proxy (Proxy))

51import Data.Proxy (Proxy (Proxy))

53import Data.Text (Text)

52import Data.Text (Text)

@@ -108,7 +107,7 @@ API with "private." Additionally, the private parts of our API use the

108realm for this authentication is `"foo-realm"`).

107realm for this authentication is `"foo-realm"`).

109

108

110Unfortunately we're not done. When someone makes a request to our `"private"`

109Unfortunately we're not done. When someone makes a request to our `"private"`

111−API, we're going to need to provide to servant the logic for validifying

110+API, we're going to need to provide to servant the logic for validating

112usernames and passwords. This adds a certain conceptual wrinkle in servant's

111usernames and passwords. This adds a certain conceptual wrinkle in servant's

113design that we'll briefly discuss. If you want the **TL;DR**: we supply a lookup

112design that we'll briefly discuss. If you want the **TL;DR**: we supply a lookup

114function to servant's new `Context` primitive.

113function to servant's new `Context` primitive.

@@ -133,7 +132,7 @@ combinator. Using `Context`, we can supply a function of type

133handler. This will allow the handler to check authentication and return a `User`

132handler. This will allow the handler to check authentication and return a `User`

134to downstream handlers if successful.

133to downstream handlers if successful.

135

134

136−In practice we wrap `BasicAuthData -> Handler` into a slightly

135+In practice we wrap `BasicAuthData -> Handler User` into a slightly

137different function to better capture the semantics of basic authentication:

136different function to better capture the semantics of basic authentication:

138

137

139``` haskell ignore

138``` haskell ignore

@@ -260,7 +259,7 @@ this.

260

259

261Let's implement a trivial authentication scheme. We will protect our API by

260Let's implement a trivial authentication scheme. We will protect our API by

262looking for a cookie named `"servant-auth-cookie"`. This cookie's value will

261looking for a cookie named `"servant-auth-cookie"`. This cookie's value will

263−contain a key from which we can lookup a `Account`.

262+contain a key from which we can lookup an `Account`.

264

263

265```haskell

264```haskell

266-- | An account type that we "fetch from the database" after

265-- | An account type that we "fetch from the database" after

@@ -274,7 +273,7 @@ database = fromList [ ("key1", Account "Anne Briggs")

274 , ("key3", Account "Ghédalia Tazartès")

273 , ("key3", Account "Ghédalia Tazartès")

275 ]

274 ]

276

275

277−-- | A method that, when given a password, will return a Account.

276+-- | A method that, when given a password, will return an Account.

278-- This is our bespoke (and bad) authentication logic.

277-- This is our bespoke (and bad) authentication logic.

279lookupAccount :: ByteString -> Handler Account

278lookupAccount :: ByteString -> Handler Account

280lookupAccount key = case Map.lookup key database of

279lookupAccount key = case Map.lookup key database of

@@ -318,7 +317,7 @@ genAuthAPI = Proxy

318

317

319Now we need to bring everything together for the server. We have the

318Now we need to bring everything together for the server. We have the

320`AuthHandler Request Account` value and an `AuthProtected` endpoint. To bind these

319`AuthHandler Request Account` value and an `AuthProtected` endpoint. To bind these

321−together, we need to provide a [Type Family](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/type-families.html)

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)

322instance that tells the `HasServer` instance that our `Context` will supply a

321instance that tells the `HasServer` instance that our `Context` will supply a

323`Account` (via `AuthHandler Request Account`) and that downstream combinators will

322`Account` (via `AuthHandler Request Account`) and that downstream combinators will

324have access to this `Account` value (or an error will be thrown if authentication

323have access to this `Account` value (or an error will be thrown if authentication

@@ -346,7 +345,7 @@ genAuthServerContext = authHandler :. EmptyContext

346

345

347-- | Our API, where we provide all the author-supplied handlers for each end

346-- | Our API, where we provide all the author-supplied handlers for each end

348-- point. Note that 'privateDataFunc' is a function that takes 'Account' as an

347-- point. Note that 'privateDataFunc' is a function that takes 'Account' as an

349−-- argument. We dont' worry about the authentication instrumentation here,

348+-- argument. We don't worry about the authentication instrumentation here,

350-- that is taken care of by supplying context

349-- that is taken care of by supplying context

351genAuthServer :: Server AuthGenAPI

350genAuthServer :: Server AuthGenAPI

352genAuthServer =

351genAuthServer =

@@ -368,10 +367,10 @@ genAuthMain = run 8080 (serveWithContext genAuthAPI genAuthServerContext genAuth

368$ curl -XGET localhost:8080/private

367$ curl -XGET localhost:8080/private

369Missing auth header

368Missing auth header

370

369

371−$ curl -XGET localhost:8080/private -H "servant-auth-cookie: key3"

370+$ curl -XGET localhost:8080/private -H "Cookie: servant-auth-cookie=key3"

372[{"ssshhh":"this is a secret: Ghédalia Tazartès"}]

371[{"ssshhh":"this is a secret: Ghédalia Tazartès"}]

373

372

374−$ curl -XGET localhost:8080/private -H "servant-auth-cookie: bad-key"

373+$ curl -XGET localhost:8080/private -H "Cookie: servant-auth-cookie=bad-key"

375Invalid Cookie

374Invalid Cookie

376

375

377$ curl -XGET localhost:8080/public

376$ curl -XGET localhost:8080/public

@@ -385,11 +384,11 @@ Creating a generalized, ad-hoc authentication scheme was fairly straight

385forward:

384forward:

386

385

3871. use the `AuthProtect` combinator to protect your API.

3861. use the `AuthProtect` combinator to protect your API.

388−2. choose a application-specific data type used by your server when

387+2. choose an application-specific data type used by your server when

389authentication is successful (in our case this was `Account`).

388authentication is successful (in our case this was `Account`).

3903. Create a value of `AuthHandler Request Account` which encapsulates the

3893. Create a value of `AuthHandler Request Account` which encapsulates the

391authentication logic (`Request -> Handler Account`). This function

390authentication logic (`Request -> Handler Account`). This function

392−will be executed everytime a request matches a protected route.

391+will be executed every time a request matches a protected route.

3934. Provide an instance of the `AuthServerData` type family, specifying your

3924. Provide an instance of the `AuthServerData` type family, specifying your

394application-specific data type returned when authentication is successful (in

393application-specific data type returned when authentication is successful (in

395our case this was `Account`).

394our case this was `Account`).

doc/tutorial/Client.lhs+4−4

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

1# Querying an API

1# Querying an API

2

2

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.

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.

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

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.

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

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

161## Changing the monad the client functions live in

162

162

163Just like `hoistServer` allows us to change the monad in which request handlers

163Just like `hoistServer` allows us to change the monad in which request handlers

164−of a web application live in, we also have `hoistClient` for changing the monad

164+of a web application live, we also have `hoistClient` for changing the monad

165in which _client functions_ live. Consider the following trivial API:

165in which _client functions_ live. Consider the following trivial API:

166

166

167``` haskell

167``` haskell

@@ -173,7 +173,7 @@ hoistClientAPI = Proxy

173

173

174We already know how to derive client functions for this API, and as we have

174We 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`.

175seen above they all return results in the `ClientM` monad when using `servant-client`.

176−However, `ClientM` rarely (or never) is the actual monad we need to use the client

176+However, `ClientM` is rarely (or never) the actual monad we need to use the client

177functions in. Sometimes we need to run them in IO, sometimes in a custom monad

177functions 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

178stack. `hoistClient` is a very simple solution to the problem of "changing" the monad

179the clients run in.

179the clients run in.

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− -- mutliple examples to display this time

80+ -- multiple 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 down in markdown, by looking at `markdown apiDocs`.

111+That lets us see what our API docs look like in markdown, by looking at `markdown apiDocs`.

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 want to send the request body (to let you redefine it)

231+ -- | name used when a user wants to send the request body (to let you redefine it)

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 mean local var)

237+ -- | namespace on which we define the js function (empty means 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+31−31

@@ -183,7 +183,7 @@ users2 = [isaac, albert]

183

183

184Now, just like we separate the various endpoints in `UserAPI` with `:<|>`, we

184Now, just like we separate the various endpoints in `UserAPI` with `:<|>`, we

185are going to separate the handlers with `:<|>` too! They must be provided in

185are going to separate the handlers with `:<|>` too! They must be provided in

186−the same order as in in the API type.

186+the same order as in the API type.

187

187

188``` haskell

188``` haskell

189server2 :: Server UserAPI2

189server2 :: Server UserAPI2

@@ -313,8 +313,8 @@ For reference, here's a list of some combinators from **servant**:

313## The `FromHttpApiData`/`ToHttpApiData` classes

313## The `FromHttpApiData`/`ToHttpApiData` classes

314

314

315Wait... How does **servant** know how to decode the `Int`s from the URL? Or how

315Wait... How does **servant** know how to decode the `Int`s from the URL? Or how

316−to decode a `ClientInfo` value from the request body? This is what this and the

316+to decode a `ClientInfo` value from the request body? The following three sections will

317−following two sections address.

317+help us answer these questions.

318

318

319`Capture`s and `QueryParam`s are represented by some textual value in URLs.

319`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

320`Header`s are similarly represented by a pair of a header name and a

@@ -599,7 +599,7 @@ $ curl -H 'Accept: text/html' http://localhost:8081/persons

599

599

600## The `Handler` monad

600## The `Handler` monad

601

601

602−At the heart of the handlers is the monad they run in, namely a newtype `Handler` around `ExceptT ServantErr IO`

602+At the heart of the handlers is the monad they run in, namely a newtype `Handler` around `ExceptT ServerError IO`

603([haddock documentation for `ExceptT`](http://hackage.haskell.org/package/mtl-2.2.1/docs/Control-Monad-Except.html#t:ExceptT)).

603([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

604One might wonder: why this monad? The answer is that it is the

605simplest monad with the following properties:

605simplest monad with the following properties:

@@ -617,12 +617,12 @@ newtype ExceptT e m a = ExceptT (m (Either e a))

617```

617```

618

618

619In short, this means that a handler of type `Handler a` is simply

619In short, this means that a handler of type `Handler a` is simply

620−equivalent to a computation of type `IO (Either ServantErr a)`, that is, an IO

620+equivalent to a computation of type `IO (Either ServerError a)`, that is, an IO

621action that either returns an error or a result.

621action that either returns an error or a result.

622

622

623−The module [`Control.Monad.Except`](https://hackage.haskell.org/package/mtl-2.2.1/docs/Control-Monad-Except.html#t:ExceptT)

623+The module [`Control.Monad.Except`](https://hackage.haskell.org/package/mtl/docs/Control-Monad-Except.html#t:ExceptT)

624from which `ExceptT` comes is worth looking at.

624from which `ExceptT` comes is worth looking at.

625−Perhaps most importantly, `ExceptT` and `Handler` are an instances of `MonadError`, so

625+Perhaps most importantly, `ExceptT` and `Handler` are instances of `MonadError`, so

626`throwError` can be used to return an error from your handler (whereas `return`

626`throwError` can be used to return an error from your handler (whereas `return`

627 is enough to return a success).

627 is enough to return a success).

628

628

@@ -632,9 +632,9 @@ kind and abort early. The next two sections cover how to do just that.

632

632

633### Performing IO

633### Performing IO

634

634

635−Another important instances from the list above are `MonadIO m => MonadIO

635+Other important instances from the list above are `MonadIO m => MonadIO

636−(ExceptT e m)`, and therefore also `MonadIO Handler` as there is `MonadIO IO` instance.

636+(ExceptT e m)`, and therefore also `MonadIO Handler` as there is a `MonadIO IO` instance.

637−[`MonadIO`](http://hackage.haskell.org/package/transformers-0.4.3.0/docs/Control-Monad-IO-Class.html)

637+[`MonadIO`](http://hackage.haskell.org/package/base/docs/Control-Monad-IO-Class.html#t:MonadIO)

638is a class from the **transformers** package defined as:

638is a class from the **transformers** package defined as:

639

639

640``` haskell ignore

640``` haskell ignore

@@ -660,16 +660,16 @@ server5 = do

660 return (FileContent filecontent)

660 return (FileContent filecontent)

661```

661```

662

662

663−### Failing, through `ServantErr`

663+### Failing, through `ServerError`

664

664

665If you want to explicitly fail at providing the result promised by an endpoint

665If 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

666using 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

667error message, all you have to do is use the `throwError` function mentioned above

668−and provide it with the appropriate value of type `ServantErr`, which is

668+and provide it with the appropriate value of type `ServerError`, which is

669defined as:

669defined as:

670

670

671``` haskell ignore

671``` haskell ignore

672−data ServantErr = ServantErr

672+data ServerError = ServerError

673 { errHTTPCode :: Int

673 { errHTTPCode :: Int

674 , errReasonPhrase :: String

674 , errReasonPhrase :: String

675 , errBody :: ByteString -- lazy bytestring

675 , errBody :: ByteString -- lazy bytestring

@@ -685,7 +685,7 @@ use record update syntax:

685failingHandler :: Handler ()

685failingHandler :: Handler ()

686failingHandler = throwError myerr

686failingHandler = throwError myerr

687

687

688− where myerr :: ServantErr

688+ where myerr :: ServerError

689 myerr = err503 { errBody = "Sorry dear user." }

689 myerr = err503 { errBody = "Sorry dear user." }

690```

690```

691

691

@@ -716,7 +716,7 @@ $ curl --verbose http://localhost:8081/myfile.txt

716>

716>

717< HTTP/1.1 404 Not Found

717< HTTP/1.1 404 Not Found

718[snip]

718[snip]

719−myfile.txt just isnt there, please leave this server alone.

719+myfile.txt just isn't there, please leave this server alone.

720

720

721$ echo Hello > myfile.txt

721$ echo Hello > myfile.txt

722

722

@@ -818,7 +818,7 @@ If it doesn't exist, the handler will fail with a `404` status code.

818

818

819`serveDirectoryWebApp` uses some standard settings that fit the use case of

819`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

820serving static files for most web apps. You can find out about the other

821−options in the documentation of the `Servant.Utils.StaticFiles` module.

821+options in the documentation of the `Servant.Server.StaticFiles` module.

822

822

823## Nested APIs

823## Nested APIs

824

824

@@ -830,7 +830,7 @@ type UserAPI3 = -- view the user with given userid, in JSON

830 Capture "userid" Int :> Get '[JSON] User

830 Capture "userid" Int :> Get '[JSON] User

831

831

832 :<|> -- delete the user with given userid. empty response

832 :<|> -- delete the user with given userid. empty response

833− Capture "userid" Int :> DeleteNoContent '[JSON] NoContent

833+ Capture "userid" Int :> DeleteNoContent

834```

834```

835

835

836We can instead factor out the `userid`:

836We can instead factor out the `userid`:

@@ -838,7 +838,7 @@ We can instead factor out the `userid`:

838``` haskell

838``` haskell

839type UserAPI4 = Capture "userid" Int :>

839type UserAPI4 = Capture "userid" Int :>

840 ( Get '[JSON] User

840 ( Get '[JSON] User

841− :<|> DeleteNoContent '[JSON] NoContent

841+ :<|> DeleteNoContent

842 )

842 )

843```

843```

844

844

@@ -896,13 +896,13 @@ type API1 = "users" :>

896-- we factor out the Request Body

896-- we factor out the Request Body

897type API2 = ReqBody '[JSON] User :>

897type API2 = ReqBody '[JSON] User :>

898 ( Get '[JSON] User -- just display the same user back, don't register it

898 ( Get '[JSON] User -- just display the same user back, don't register it

899− :<|> PostNoContent '[JSON] NoContent -- register the user. empty response

899+ :<|> PostNoContent -- register the user. empty response

900 )

900 )

901

901

902-- we factor out a Header

902-- we factor out a Header

903type API3 = Header "Authorization" Token :>

903type API3 = Header "Authorization" Token :>

904 ( Get '[JSON] SecretData -- get some secret data, if authorized

904 ( Get '[JSON] SecretData -- get some secret data, if authorized

905− :<|> ReqBody '[JSON] SecretData :> PostNoContent '[JSON] NoContent -- add some secret data, if authorized

905+ :<|> ReqBody '[JSON] SecretData :> PostNoContent -- add some secret data, if authorized

906 )

906 )

907

907

908newtype Token = Token ByteString

908newtype Token = Token ByteString

@@ -915,11 +915,11 @@ API type only at the end.

915``` haskell

915``` haskell

916type UsersAPI =

916type UsersAPI =

917 Get '[JSON] [User] -- list users

917 Get '[JSON] [User] -- list users

918− :<|> ReqBody '[JSON] User :> PostNoContent '[JSON] NoContent -- add a user

918+ :<|> ReqBody '[JSON] User :> PostNoContent -- add a user

919 :<|> Capture "userid" Int :>

919 :<|> Capture "userid" Int :>

920 ( Get '[JSON] User -- view a user

920 ( Get '[JSON] User -- view a user

921− :<|> ReqBody '[JSON] User :> PutNoContent '[JSON] NoContent -- update a user

921+ :<|> ReqBody '[JSON] User :> PutNoContent -- update a user

922− :<|> DeleteNoContent '[JSON] NoContent -- delete a user

922+ :<|> DeleteNoContent -- delete a user

923 )

923 )

924

924

925usersServer :: Server UsersAPI

925usersServer :: Server UsersAPI

@@ -948,11 +948,11 @@ usersServer = getUsers :<|> newUser :<|> userOperations

948``` haskell

948``` haskell

949type ProductsAPI =

949type ProductsAPI =

950 Get '[JSON] [Product] -- list products

950 Get '[JSON] [Product] -- list products

951− :<|> ReqBody '[JSON] Product :> PostNoContent '[JSON] NoContent -- add a product

951+ :<|> ReqBody '[JSON] Product :> PostNoContent -- add a product

952 :<|> Capture "productid" Int :>

952 :<|> Capture "productid" Int :>

953 ( Get '[JSON] Product -- view a product

953 ( Get '[JSON] Product -- view a product

954− :<|> ReqBody '[JSON] Product :> PutNoContent '[JSON] NoContent -- update a product

954+ :<|> ReqBody '[JSON] Product :> PutNoContent -- update a product

955− :<|> DeleteNoContent '[JSON] NoContent -- delete a product

955+ :<|> DeleteNoContent -- delete a product

956 )

956 )

957

957

958data Product = Product { productId :: Int }

958data Product = Product { productId :: Int }

@@ -996,11 +996,11 @@ abstract that away:

996-- indexed by values of type 'i'

996-- indexed by values of type 'i'

997type APIFor a i =

997type APIFor a i =

998 Get '[JSON] [a] -- list 'a's

998 Get '[JSON] [a] -- list 'a's

999− :<|> ReqBody '[JSON] a :> PostNoContent '[JSON] NoContent -- add an 'a'

999+ :<|> ReqBody '[JSON] a :> PostNoContent -- add an 'a'

1000 :<|> Capture "id" i :>

1000 :<|> Capture "id" i :>

1001 ( Get '[JSON] a -- view an 'a' given its "identifier" of type 'i'

1001 ( Get '[JSON] a -- view an 'a' given its "identifier" of type 'i'

1002− :<|> ReqBody '[JSON] a :> PutNoContent '[JSON] NoContent -- update an 'a'

1002+ :<|> ReqBody '[JSON] a :> PutNoContent -- update an 'a'

1003− :<|> DeleteNoContent '[JSON] NoContent -- delete an 'a'

1003+ :<|> DeleteNoContent -- delete an 'a'

1004 )

1004 )

1005

1005

1006-- Build the appropriate 'Server'

1006-- Build the appropriate 'Server'

@@ -1135,7 +1135,7 @@ true

1135### An arrow is a reader too.

1135### An arrow is a reader too.

1136

1136

1137In previous versions of `servant` we had an `enter` to do what `hoistServer`

1137In previous versions of `servant` we had an `enter` to do what `hoistServer`

1138−does now. `enter` had a ambitious design goals, but was problematic in practice.

1138+does now. `enter` had an ambitious design goals, but was problematic in practice.

1139

1139

1140One problematic situation was when the source monad was `(->) r`, yet it's

1140One problematic situation was when the source monad was `(->) r`, yet it's

1141handy in practice, because `(->) r` is isomorphic to `Reader r`.

1141handy in practice, because `(->) r` is isomorphic to `Reader r`.

@@ -1166,7 +1166,7 @@ back a *stream* of results, served one at a time. Stream endpoints only provide

1166a single content type, and also specify what framing strategy is used to

1166a single content type, and also specify what framing strategy is used to

1167delineate the results. To serve these results, we need to give back a stream

1167delineate the results. To serve these results, we need to give back a stream

1168producer. Adapters can be written to *Pipes*, *Conduit* and the like, or

1168producer. Adapters can be written to *Pipes*, *Conduit* and the like, or

1169−written directly as `SourceIO`s. SourceIO builts upon servant's own `SourceT`

1169+written directly as `SourceIO`s. SourceIO builds upon servant's own `SourceT`

1170stream type (it's simpler than *Pipes* or *Conduit*).

1170stream type (it's simpler than *Pipes* or *Conduit*).

1171The API of a streaming endpoint needs to explicitly specify which sort of

1171The API of a streaming endpoint needs to explicitly specify which sort of

1172generator it produces. Note that the generator itself is returned by a

1172generator it produces. Note that the generator itself is returned by a

doc/tutorial/index.rst+1−20

@@ -6,29 +6,10 @@ 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−

29.. toctree::

9.. toctree::

30 :maxdepth: 1

10 :maxdepth: 1

31

11

12+ install.rst

32 ApiType.lhs

13 ApiType.lhs

33 Server.lhs

14 Server.lhs

34 Client.lhs

15 Client.lhs

doc/tutorial/install.rstnew file+68

@@ -0,0 +1,68 @@

1+Install

2+========

3+

4+cabal-install

5+--------

6+

7+The whole tutorial is a `cabal <https://cabal.readthedocs.io/en/latest/>`_

8+project and can be built locally as follows:

9+

10+.. code-block:: bash

11+

12+ $ git clone https://github.com/haskell-servant/servant.git

13+ $ cd servant

14+ # build

15+ $ cabal new-build tutorial

16+ # load in ghci to play with it

17+ $ cabal new-repl tutorial

18+

19+stack

20+--------

21+

22+The servant `stack <https://docs.haskellstack.org/en/stable/README/>`_ template includes the working tutorial. To initialize this template, run:

23+

24+.. code-block:: bash

25+

26+ $ stack new myproj servant

27+ $ cd myproj

28+ # build

29+ $ stack build

30+ # start server

31+ $ stack exec myproj-exe

32+

33+The code can be found in the `*.lhs` files under `doc/tutorial/` in the

34+repository. Feel free to edit it while you're reading this documentation and

35+see the effect of your changes.

36+

37+nix

38+--------

39+

40+`Nix <https://nixos.org/nix/>`_ users should feel free to take a look at

41+the `nix/shell.nix` file in the repository and use it to provision a suitable

42+environment to build and run the examples.

43+

44+Note for Ubuntu users

45+--------

46+

47+Ubuntu's packages for `ghc`, `cabal`, and `stack` are years out of date.

48+If the instructions above fail for you,

49+try replacing the Ubuntu packages with up-to-date versions.

50+First remove the installed versions:

51+

52+.. code-block:: bash

53+

54+ # remove the obsolete versions

55+ $ sudo apt remove ghc haskell-stack cabal-install

56+

57+Then install fresh versions of the Haskell toolchain

58+using the `ghcup <https://www.haskell.org/ghcup/install/>`_ installer.

59+

60+As of February 2022, one easy way to do this is by running a bootstrap script:

61+

62+.. code-block:: bash

63+

64+ $ curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh

65+

66+The script is interactive and will prompt you for details about what

67+you want installed and where. To install manually,

68+see `the detailed instructions <https://www.haskell.org/ghcup/install/#manual-install>`_.

doc/tutorial/test/Spec.hs+11−1

@@ -1 +1,11 @@

1−{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

1+module Main where

2+

3+import qualified JavascriptSpec

4+

5+import Test.Hspec (Spec, hspec, describe)

6+

7+main :: IO ()

8+main = hspec spec

9+

10+spec :: Spec

11+spec = describe "Javascript" JavascriptSpec.spec

doc/tutorial/tutorial.cabal+11−15

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

1+cabal-version: 2.2

1name: tutorial

2name: tutorial

2version: 0.10

3version: 0.10

3synopsis: The servant tutorial

4synopsis: The servant tutorial

4description:

5description:

5 The servant tutorial can be found at

6 The servant tutorial can be found at

6− <http://haskell-servant.readthedocs.org/>

7+ <http://docs.servant.dev/>

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

8+homepage: http://docs.servant.dev/

8category: Servant, Documentation

9category: Servant, Documentation

9−license: BSD3

10+license: BSD-3-Clause

10license-file: LICENSE

11license-file: LICENSE

11author: Servant Contributors

12author: Servant Contributors

12maintainer: haskell-servant-maintainers@googlegroups.com

13maintainer: haskell-servant-maintainers@googlegroups.com

13build-type: Simple

14build-type: Simple

14−cabal-version: >=1.10

15tested-with:

15tested-with:

16− GHC==8.0.2

16+ GHC==8.6.5

17− GHC==8.2.2

17+ GHC==8.8.3, GHC ==8.10.7

18− GHC==8.4.4

19− GHC==8.6.2

20extra-source-files:

18extra-source-files:

21 static/index.html

19 static/index.html

22 static/ui.js

20 static/ui.js

@@ -34,7 +32,7 @@ library

34 -- Packages `servant` depends on.

32 -- Packages `servant` depends on.

35 -- We don't need to specify bounds here as this package is never released.

33 -- We don't need to specify bounds here as this package is never released.

36 build-depends:

34 build-depends:

37− base >= 4.7 && <4.13

35+ base >= 4.7 && <5

38 , aeson

36 , aeson

39 , attoparsec

37 , attoparsec

40 , base-compat

38 , base-compat

@@ -65,11 +63,11 @@ library

65 blaze-html >= 0.9.0.1 && < 0.10

63 blaze-html >= 0.9.0.1 && < 0.10

66 , blaze-markup >= 0.8.0.0 && < 0.9

64 , blaze-markup >= 0.8.0.0 && < 0.9

67 , cookie >= 0.4.3 && < 0.5

65 , cookie >= 0.4.3 && < 0.5

68− , js-jquery >= 3.2.1 && < 3.3

66+ , js-jquery >= 3.3.1 && < 3.4

69− , lucid >= 2.9.11 && < 2.10

67+ , lucid >= 2.9.11 && < 2.12

70− , random >= 1.1 && < 1.2

68+ , random >= 1.1 && < 1.3

71 , servant-js >= 0.9 && < 0.10

69 , servant-js >= 0.9 && < 0.10

72− , time >= 1.6.0.1 && < 1.9

70+ , time >= 1.6.0.1 && < 1.13

73

71

74 -- For legacy tools, we need to specify build-depends too

72 -- For legacy tools, we need to specify build-depends too

75 build-depends: markdown-unlit >= 0.5.0 && <0.6

73 build-depends: markdown-unlit >= 0.5.0 && <0.6

@@ -82,8 +80,6 @@ test-suite spec

82 hs-source-dirs: test

80 hs-source-dirs: test

83 main-is: Spec.hs

81 main-is: Spec.hs

84 other-modules: JavascriptSpec

82 other-modules: JavascriptSpec

85− build-tool-depends:

86− hspec-discover:hspec-discover

87 build-depends: base

83 build-depends: base

88 , tutorial

84 , tutorial

89 , hspec

85 , hspec

ghcjs.nixnew file+22

@@ -0,0 +1,22 @@

1+let reflex-platform = import (builtins.fetchTarball

2+ { name = "reflex-platform";

3+ url = "https://github.com/reflex-frp/reflex-platform/archive/1aba6f367982bd6dd78ec2fda75ab246a62d32c5.tar.gz";

4+ }) {};

5+ pkgs = import ./nix/nixpkgs.nix; in

6+

7+pkgs.stdenv.mkDerivation {

8+ name = "ghcjs-shell";

9+ buildInputs =

10+ [ (reflex-platform.ghcjs.ghcWithPackages (p: with p; [

11+ attoparsec

12+ hashable

13+ ]))

14+ pkgs.cabal-install

15+ pkgs.gmp

16+ pkgs.haskellPackages.cabal-plan

17+ pkgs.haskellPackages.hspec-discover

18+ pkgs.nodejs

19+ pkgs.perl

20+ pkgs.zlib

21+ ];

22+}

nix/README.md+18

@@ -21,3 +21,21 @@ a particular ghc version, e.g:

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.jsonnew file+4

@@ -0,0 +1,4 @@

1+{

2+ "rev" : "05f0934825c2a0750d4888c4735f9420c906b388",

3+ "sha256" : "1g8c2w0661qn89ajp44znmwfmghbbiygvdzq0rzlvlpdiz28v6gy"

4+}

nix/nixpkgs.nixnew file+4

@@ -0,0 +1,4 @@

1+import (builtins.fetchTarball {

2+ url = "https://github.com/NixOS/nixpkgs/archive/refs/tags/21.05.tar.gz";

3+ sha256 = "sha256:1ckzhh24mgz6jd1xhfgx0i9mijk6xjqxwsshnvq789xsavrmsc36";

4+}) {}

nix/shell.nix+17−18

@@ -1,21 +1,20 @@

1−{ pkgs ? import <nixpkgs> {}

2−, compiler ? "ghc822"

1+{ compiler ? "ghc8104"

3, tutorial ? false

2, tutorial ? false

3+, pkgs ? import ./nixpkgs.nix

4}:

4}:

5+

6+ with pkgs;

5

7

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−

13−stdenv.mkDerivation {

12+ stdenv.mkDerivation {

14− name = "servant-dev";

13+ name = "servant-dev";

15− buildInputs = [ ghc zlib python3 wget ]

14+ buildInputs = [ ghc zlib python3 wget cabal-install postgresql openssl stack haskellPackages.hspec-discover ]

16− ++ (if tutorial then [docstuffs postgresql] else []);

15+ ++ (if tutorial then [docstuffs postgresql] else []);

17− shellHook = ''

16+ shellHook = ''

18− eval $(grep export ${ghc}/bin/ghc)

17+ eval $(grep export ${ghc}/bin/ghc)

19− export LD_LIBRARY_PATH="${zlib}/lib";

18+ export LD_LIBRARY_PATH=$LD_LIBRARY_PATH:"${zlib}/lib";

20− '';

19+ '';

21−}

20+ }

servant-auth/README.mdnew file+1

@@ -0,0 +1 @@

1+servant-auth-server/README.lhs

servant-auth/servant-auth-client/.ghcinew file+1

@@ -0,0 +1 @@

1+:set -isrc -itest -idoctest/ghci-wrapper/src

servant-auth/servant-auth-client/CHANGELOG.mdnew file+26

@@ -0,0 +1,26 @@

1+# Changelog

2+

3+All notable changes to this project will be documented in this file.

4+

5+The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/)

6+and this project adheres to [PVP Versioning](https://pvp.haskell.org/).

7+

8+## [Unreleased]

9+

10+## [0.4.1.0] - 2020-10-06

11+

12+- Support generic Bearer token auth

13+

14+## [0.4.0.0] - 2019-03-08

15+

16+## Changed

17+

18+- #145 Support servant-0.16 in tests @domenkozar

19+- #145 Drop GHC 7.10 support @domenkozar

20+

21+## [0.3.3.0] - 2018-06-18

22+

23+### Added

24+- Support for GHC 8.4 by @phadej

25+- Support for servant-0.14 by @phadej

26+- Changelog by @domenkozar

servant-auth/servant-auth-client/LICENSEnew file+31

@@ -0,0 +1,31 @@

1+Copyright Julian K. Arni (c) 2015

2+

3+All rights reserved.

4+

5+Redistribution and use in source and binary forms, with or without

6+modification, are permitted provided that the following conditions are met:

7+

8+ * Redistributions of source code must retain the above copyright

9+ notice, this list of conditions and the following disclaimer.

10+

11+ * Redistributions in binary form must reproduce the above

12+ copyright notice, this list of conditions and the following

13+ disclaimer in the documentation and/or other materials provided

14+ with the distribution.

15+

16+ * Neither the name of Julian K. Arni nor the names of other

17+ contributors may be used to endorse or promote products derived

18+ from this software without specific prior written permission.

19+

20+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS

21+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT

22+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR

23+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT

24+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,

25+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT

26+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,

27+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY

28+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT

29+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE

30+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

31+

servant-auth/servant-auth-client/Setup.hsnew file+2

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

1+import Distribution.Simple

2+main = defaultMain

servant-auth/servant-auth-client/servant-auth-client.cabalnew file+80

@@ -0,0 +1,80 @@

1+cabal-version: 2.2

2+name: servant-auth-client

3+version: 0.4.1.0

4+synopsis: servant-client/servant-auth compatibility

5+description: This package provides instances that allow generating clients from

6+ <https://hackage.haskell.org/package/servant servant>

7+ APIs that use

8+ <https://hackage.haskell.org/package/servant-auth servant-auth's> @Auth@ combinator.

9+ .

10+ For a quick overview of the usage, see the <https://github.com/haskell-servant/servant/tree/master/servant-auth#readme README>.

11+category: Web, Servant, Authentication

12+homepage: https://github.com/haskell-servant/servant/tree/master/servant-auth#readme

13+bug-reports: https://github.com/haskell-servant/servant/issues

14+author: Julian K. Arni

15+maintainer: jkarni@gmail.com

16+copyright: (c) Julian K. Arni

17+license: BSD-3-Clause

18+license-file: LICENSE

19+tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1

20+build-type: Simple

21+extra-source-files:

22+ CHANGELOG.md

23+

24+source-repository head

25+ type: git

26+ location: https://github.com/haskell-servant/servant

27+

28+library

29+ hs-source-dirs:

30+ src

31+ default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators

32+ ghc-options: -Wall

33+ build-depends:

34+ base >= 4.10 && < 4.17

35+ , bytestring >= 0.10.6.0 && < 0.12

36+ , containers >= 0.5.6.2 && < 0.7

37+ , servant-auth == 0.4.*

38+ , servant >= 0.13 && < 0.20

39+ , servant-client-core >= 0.13 && < 0.20

40+

41+ exposed-modules:

42+ Servant.Auth.Client

43+ Servant.Auth.Client.Internal

44+ default-language: Haskell2010

45+

46+test-suite spec

47+ type: exitcode-stdio-1.0

48+ main-is: Spec.hs

49+ hs-source-dirs:

50+ test

51+ default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators

52+ ghc-options: -Wall

53+ build-tool-depends: hspec-discover:hspec-discover >=2.5.5 && <2.10

54+

55+ -- dependencies with bounds inherited from the library stanza

56+ build-depends:

57+ base

58+ , servant-client

59+ , servant-auth

60+ , servant

61+ , servant-auth-client

62+

63+ -- test dependencies

64+ build-depends:

65+ hspec >= 2.5.5 && < 2.10

66+ , QuickCheck >= 2.11.3 && < 2.15

67+ , aeson >= 1.3.1.1 && < 3

68+ , bytestring >= 0.10.6.0 && < 0.12

69+ , http-client >= 0.5.13.1 && < 0.8

70+ , http-types >= 0.12.2 && < 0.13

71+ , servant-auth-server >= 0.4.2.0 && < 0.5

72+ , servant-server >= 0.13 && < 0.20

73+ , time >= 1.5.0.1 && < 1.13

74+ , transformers >= 0.4.2.0 && < 0.6

75+ , wai >= 3.2.1.2 && < 3.3

76+ , warp >= 3.2.25 && < 3.4

77+ , jose >= 0.7.0.0 && < 0.10

78+ other-modules:

79+ Servant.Auth.ClientSpec

80+ default-language: Haskell2010

servant-auth/servant-auth-client/src/Servant/Auth/Client.hsnew file+3

@@ -0,0 +1,3 @@

1+module Servant.Auth.Client (Token(..), Bearer) where

2+

3+import Servant.Auth.Client.Internal (Bearer, Token(..))

servant-auth/servant-auth-client/src/Servant/Auth/Client/Internal.hsnew file+64

@@ -0,0 +1,64 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

3+{-# LANGUAGE UndecidableInstances #-}

4+{-# OPTIONS_GHC -fno-warn-orphans #-}

5+#if __GLASGOW_HASKELL__ == 800

6+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}

7+#endif

8+module Servant.Auth.Client.Internal where

9+

10+import qualified Data.ByteString as BS

11+import Data.Monoid

12+import Data.Proxy (Proxy (..))

13+import Data.String (IsString)

14+import GHC.Exts (Constraint)

15+import GHC.Generics (Generic)

16+import Servant.API ((:>))

17+import Servant.Auth

18+

19+import Servant.Client.Core

20+import Data.Sequence ((<|))

21+

22+-- | A simple bearer token.

23+newtype Token = Token { getToken :: BS.ByteString }

24+ deriving (Eq, Show, Read, Generic, IsString)

25+

26+type family HasBearer xs :: Constraint where

27+ HasBearer (Bearer ': xs) = ()

28+ HasBearer (JWT ': xs) = ()

29+ HasBearer (x ': xs) = HasBearer xs

30+ HasBearer '[] = BearerAuthNotEnabled

31+

32+class BearerAuthNotEnabled

33+

34+-- | @'HasBearer' auths@ is nominally a redundant constraint, but ensures we're not

35+-- trying to send a token to an API that doesn't accept them.

36+instance (HasBearer auths, HasClient m api) => HasClient m (Auth auths a :> api) where

37+ type Client m (Auth auths a :> api) = Token -> Client m api

38+

39+ clientWithRoute m _ req (Token token)

40+ = clientWithRoute m (Proxy :: Proxy api)

41+ $ req { requestHeaders = ("Authorization", headerVal) <| requestHeaders req }

42+ where

43+ headerVal = "Bearer " <> token

44+

45+#if MIN_VERSION_servant_client_core(0,14,0)

46+ hoistClientMonad pm _ nt cl = hoistClientMonad pm (Proxy :: Proxy api) nt . cl

47+#endif

48+

49+

50+-- * Authentication combinators

51+

52+-- | A Bearer token in the Authorization header:

53+--

54+-- @Authorization: Bearer <token>@

55+--

56+-- This can be any token recognized by the server, for example,

57+-- a JSON Web Token (JWT).

58+--

59+-- Note that, since the exact way the token is validated is not specified,

60+-- this combinator can only be used in the client. The server would not know

61+-- how to validate it, while the client does not care.

62+-- If you want to implement Bearer authentication in your server, you have to

63+-- choose a specific combinator, such as 'JWT'.

64+data Bearer

servant-auth/servant-auth-client/test/Servant/Auth/ClientSpec.hsnew file+161

@@ -0,0 +1,161 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE DeriveAnyClass #-}

3+module Servant.Auth.ClientSpec (spec) where

4+

5+import Crypto.JOSE (JWK,

6+ KeyMaterialGenParam (OctGenParam),

7+ genJWK)

8+import Data.Aeson (FromJSON (..), ToJSON (..))

9+import qualified Data.ByteString.Lazy as BSL

10+import Data.Time (UTCTime, defaultTimeLocale,

11+ parseTimeOrError)

12+import GHC.Generics (Generic)

13+import Network.HTTP.Client (Manager, defaultManagerSettings,

14+ newManager)

15+import Network.HTTP.Types (status401)

16+import Network.Wai.Handler.Warp (testWithApplication)

17+import Servant

18+import Servant.Client (BaseUrl (..), Scheme (Http),

19+ ClientError (FailureResponse),

20+#if MIN_VERSION_servant_client(0,16,0)

21+ ResponseF(..),

22+#elif MIN_VERSION_servant_client(0,13,0)

23+ GenResponse(..),

24+#elif MIN_VERSION_servant_client(0,12,0)

25+ Response(..),

26+#endif

27+ client)

28+import System.IO.Unsafe (unsafePerformIO)

29+import Test.Hspec

30+import Test.QuickCheck

31+

32+#if MIN_VERSION_servant_client(0,13,0)

33+import Servant.Client (mkClientEnv, runClientM)

34+#elif MIN_VERSION_servant_client(0,9,0)

35+import Servant.Client (ClientEnv (..), runClientM)

36+#else

37+import Control.Monad.Trans.Except (runExceptT)

38+#endif

39+#if !MIN_VERSION_servant_server(0,16,0)

40+#define ClientError ServantError

41+#endif

42+

43+import Servant.Auth.Client

44+import Servant.Auth.Server

45+import Servant.Auth.Server.SetCookieOrphan ()

46+

47+spec :: Spec

48+spec = describe "The JWT combinator" $ do

49+ hasClientSpec

50+

51+

52+------------------------------------------------------------------------------

53+-- * HasClient {{{

54+

55+hasClientSpec :: Spec

56+hasClientSpec = describe "HasClient" $ around (testWithApplication $ return app) $ do

57+

58+ let mkTok :: User -> Maybe UTCTime -> IO Token

59+ mkTok user mexp = do

60+ Right tok <- makeJWT user jwtCfg mexp

61+ return $ Token $ BSL.toStrict tok

62+

63+ it "succeeds when the token does not have expiry" $ \port -> property $ \user -> do

64+ tok <- mkTok user Nothing

65+ v <- getIntClient tok mgr (BaseUrl Http "localhost" port "")

66+ v `shouldBe` Right (length $ name user)

67+

68+ it "succeeds when the token is not expired" $ \port -> property $ \user -> do

69+ tok <- mkTok user (Just future)

70+ v <- getIntClient tok mgr (BaseUrl Http "localhost" port "")

71+ v `shouldBe` Right (length $ name user)

72+

73+ it "fails when token is expired" $ \port -> property $ \user -> do

74+ tok <- mkTok user (Just past)

75+#if MIN_VERSION_servant_client(0,16,0)

76+ Left (FailureResponse _ (Response stat _ _ _))

77+#elif MIN_VERSION_servant_client(0,12,0)

78+ Left (FailureResponse (Response stat _ _ _))

79+#elif MIN_VERSION_servant_client(0,11,0)

80+ Left (FailureResponse _ stat _ _)

81+#else

82+ Left (FailureResponse stat _ _)

83+#endif

84+ <- getIntClient tok mgr (BaseUrl Http "localhost" port "")

85+ stat `shouldBe` status401

86+

87+

88+getIntClient :: Token -> Manager -> BaseUrl -> IO (Either ClientError Int)

89+#if MIN_VERSION_servant(0,13,0)

90+getIntClient tok m burl = runClientM (client api tok) (mkClientEnv m burl)

91+#elif MIN_VERSION_servant(0,9,0)

92+getIntClient tok m burl = runClientM (client api tok) (ClientEnv m burl)

93+#else

94+getIntClient tok m burl = runExceptT $ client api tok m burl

95+#endif

96+-- }}}

97+------------------------------------------------------------------------------

98+-- * API and Server {{{

99+

100+type API = Auth '[JWT] User :> Get '[JSON] Int

101+

102+api :: Proxy API

103+api = Proxy

104+

105+theKey :: JWK

106+theKey = unsafePerformIO . genJWK $ OctGenParam 256

107+{-# NOINLINE theKey #-}

108+

109+mgr :: Manager

110+mgr = unsafePerformIO $ newManager defaultManagerSettings

111+{-# NOINLINE mgr #-}

112+

113+app :: Application

114+app = serveWithContext api ctx server

115+ where

116+ ctx = cookieCfg :. jwtCfg :. EmptyContext

117+

118+jwtCfg :: JWTSettings

119+jwtCfg = defaultJWTSettings theKey

120+

121+cookieCfg :: CookieSettings

122+cookieCfg = defaultCookieSettings

123+

124+

125+server :: Server API

126+server = getInt

127+ where

128+ getInt :: AuthResult User -> Handler Int

129+ getInt (Authenticated u) = return . length $ name u

130+ getInt _ = throwAll err401

131+

132+

133+-- }}}

134+------------------------------------------------------------------------------

135+-- * Utils {{{

136+

137+past :: UTCTime

138+past = parseTimeOrError True defaultTimeLocale "%Y-%m-%d" "1970-01-01"

139+

140+future :: UTCTime

141+future = parseTimeOrError True defaultTimeLocale "%Y-%m-%d" "2070-01-01"

142+

143+

144+-- }}}

145+------------------------------------------------------------------------------

146+-- * Types {{{

147+

148+data User = User

149+ { name :: String

150+ , _id :: String

151+ } deriving (Eq, Show, Read, Generic)

152+

153+instance FromJWT User

154+instance ToJWT User

155+instance FromJSON User

156+instance ToJSON User

157+

158+instance Arbitrary User where

159+ arbitrary = User <$> arbitrary <*> arbitrary

160+

161+-- }}}

servant-auth/servant-auth-client/test/Spec.hsnew file+1

@@ -0,0 +1 @@

1+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

servant-auth/servant-auth-docs/.ghcinew file+1

@@ -0,0 +1 @@

1+:set -isrc -itest -idoctest/ghci-wrapper/src

servant-auth/servant-auth-docs/CHANGELOG.mdnew file+14

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

1+# Changelog

2+

3+All notable changes to this project will be documented in this file.

4+

5+The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/)

6+and this project adheres to [PVP Versioning](https://pvp.haskell.org/).

7+

8+## [Unreleased]

9+

10+## [0.2.10.0] - 2018-06-18

11+

12+### Added

13+- Support for GHC 8.4 by @phadej

14+- Changelog by @domenkozar

servant-auth/servant-auth-docs/LICENSEnew file+31

@@ -0,0 +1,31 @@

1+Copyright Julian K. Arni (c) 2015

2+

3+All rights reserved.

4+

5+Redistribution and use in source and binary forms, with or without

6+modification, are permitted provided that the following conditions are met:

7+

8+ * Redistributions of source code must retain the above copyright

9+ notice, this list of conditions and the following disclaimer.

10+

11+ * Redistributions in binary form must reproduce the above

12+ copyright notice, this list of conditions and the following

13+ disclaimer in the documentation and/or other materials provided

14+ with the distribution.

15+

16+ * Neither the name of Julian K. Arni nor the names of other

17+ contributors may be used to endorse or promote products derived

18+ from this software without specific prior written permission.

19+

20+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS

21+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT

22+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR

23+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT

24+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,

25+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT

26+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,

27+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY

28+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT

29+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE

30+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

31+

servant-auth/servant-auth-docs/Setup.hsnew file+33

@@ -0,0 +1,33 @@

1+{-# LANGUAGE CPP #-}

2+{-# OPTIONS_GHC -Wall #-}

3+module Main (main) where

4+

5+#ifndef MIN_VERSION_cabal_doctest

6+#define MIN_VERSION_cabal_doctest(x,y,z) 0

7+#endif

8+

9+#if MIN_VERSION_cabal_doctest(1,0,0)

10+

11+import Distribution.Extra.Doctest ( defaultMainWithDoctests )

12+main :: IO ()

13+main = defaultMainWithDoctests "doctests"

14+

15+#else

16+

17+#ifdef MIN_VERSION_Cabal

18+-- If the macro is defined, we have new cabal-install,

19+-- but for some reason we don't have cabal-doctest in package-db

20+--

21+-- Probably we are running cabal sdist, when otherwise using new-build

22+-- workflow

23+#warning You are configuring this package without cabal-doctest installed. \

24+ The doctests test-suite will not work as a result. \

25+ To fix this, install cabal-doctest before configuring.

26+#endif

27+

28+import Distribution.Simple

29+

30+main :: IO ()

31+main = defaultMain

32+

33+#endif

servant-auth/servant-auth-docs/servant-auth-docs.cabalnew file+84

@@ -0,0 +1,84 @@

1+cabal-version: 2.2

2+name: servant-auth-docs

3+version: 0.2.10.0

4+synopsis: servant-docs/servant-auth compatibility

5+description: This package provides instances that allow generating docs from

6+ <https://hackage.haskell.org/package/servant servant>

7+ APIs that use

8+ <https://hackage.haskell.org/package/servant-auth servant-auth's> @Auth@ combinator.

9+ .

10+ For a quick overview of the usage, see the <https://github.com/haskell-servant/servant/tree/master/servant-auth#readme README>.

11+category: Web, Servant, Authentication

12+homepage: https://github.com/haskell-servant/servant/tree/master/servant-auth#readme

13+bug-reports: https://github.com/haskell-servant/servant/issues

14+author: Julian K. Arni

15+maintainer: jkarni@gmail.com

16+copyright: (c) Julian K. Arni

17+license: BSD-3-Clause

18+license-file: LICENSE

19+tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1

20+build-type: Custom

21+extra-source-files:

22+ CHANGELOG.md

23+

24+custom-setup

25+ setup-depends:

26+ base, Cabal, cabal-doctest >=1.0.6 && <1.1

27+

28+source-repository head

29+ type: git

30+ location: https://github.com/haskell-servant/servant

31+

32+library

33+ hs-source-dirs:

34+ src

35+ default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators

36+ ghc-options: -Wall

37+ build-depends:

38+ base >= 4.10 && < 4.17

39+ , servant-docs >= 0.11.2 && < 0.13

40+ , servant >= 0.13 && < 0.20

41+ , servant-auth == 0.4.*

42+ , lens >= 4.16.1 && <5.2

43+ exposed-modules:

44+ Servant.Auth.Docs

45+ default-language: Haskell2010

46+

47+test-suite doctests

48+ type: exitcode-stdio-1.0

49+ main-is: doctests.hs

50+ build-depends:

51+ base,

52+ servant-auth-docs,

53+ doctest >= 0.16 && < 0.19,

54+ QuickCheck >= 2.11.3 && < 2.15,

55+ template-haskell

56+ ghc-options: -Wall -threaded

57+ hs-source-dirs: test

58+ default-language: Haskell2010

59+

60+test-suite spec

61+ type: exitcode-stdio-1.0

62+ main-is: Spec.hs

63+ hs-source-dirs:

64+ test

65+ default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators

66+ ghc-options: -Wall

67+ build-tool-depends: hspec-discover:hspec-discover >=2.5.5 && <2.10

68+

69+ -- dependencies with bounds inherited from the library stanza

70+ build-depends:

71+ base

72+ , text

73+ , servant-docs

74+ , servant

75+ , servant-auth

76+ , lens

77+

78+ -- test dependencies

79+ build-depends:

80+ servant-auth-docs

81+ , hspec >= 2.5.5 && < 2.10

82+ , QuickCheck >= 2.11.3 && < 2.15

83+

84+ default-language: Haskell2010

servant-auth/servant-auth-docs/src/Servant/Auth/Docs.hsnew file+96

@@ -0,0 +1,96 @@

1+{-# OPTIONS_GHC -fno-warn-orphans #-}

2+module Servant.Auth.Docs

3+ (

4+ -- | The purpose of this package is provide the instance for 'servant-auth'

5+ -- combinators needed for 'servant-docs' documentation generation.

6+ --

7+ -- >>> type API = Auth '[JWT, Cookie, BasicAuth] Int :> Get '[JSON] Int

8+ -- >>> putStr $ markdown $ docs (Proxy :: Proxy API)

9+ -- ## GET /

10+ -- ...

11+ -- ... Authentication

12+ -- ...

13+ -- This part of the API is protected by the following authentication mechanisms:

14+ -- ...

15+ -- * JSON Web Tokens ([JWTs](https://en.wikipedia.org/wiki/JSON_Web_Token))

16+ -- * [Cookies](https://en.wikipedia.org/wiki/HTTP_cookie)

17+ -- * [Basic Authentication](https://en.wikipedia.org/wiki/Basic_access_authentication)

18+ -- ...

19+ -- Clients must supply the following data

20+ -- ...

21+ -- One of the following:

22+ -- ...

23+ -- * A JWT Token signed with this server's key

24+ -- * Cookies automatically set by browsers, plus a header

25+ -- * Cookies automatically set by browsers, plus a header

26+ -- ...

27+

28+ -- * Re-export

29+ JWT

30+ , BasicAuth

31+ , Cookie

32+ , Auth

33+ ) where

34+

35+import Control.Lens ((%~), (&), (|>))

36+import Data.List (intercalate)

37+import Data.Monoid

38+import Data.Proxy (Proxy (Proxy))

39+import Servant.API hiding (BasicAuth)

40+import Servant.Auth

41+import Servant.Docs hiding (pretty)

42+import Servant.Docs.Internal (DocAuthentication (..), authInfo)

43+

44+instance (AllDocs auths, HasDocs api) => HasDocs (Auth auths r :> api) where

45+ docsFor _ (endpoint, action) =

46+ docsFor (Proxy :: Proxy api) (endpoint, action & authInfo %~ (|> info))

47+ where

48+ (intro, reqData) = pretty $ allDocs (Proxy :: Proxy auths)

49+ info = DocAuthentication intro reqData

50+

51+

52+pretty :: [(String, String)] -> (String, String)

53+pretty [] = error "shouldn't happen"

54+pretty [(i, d)] =

55+ ( "This part of the API is protected by " <> i

56+ , d

57+ )

58+pretty rs =

59+ ( "This part of the API is protected by the following authentication mechanisms:\n\n"

60+ ++ " * " <> intercalate "\n * " (fst <$> rs)

61+ , "\nOne of the following:\n\n"

62+ ++ " * " <> intercalate "\n * " (snd <$> rs)

63+ )

64+

65+

66+class AllDocs (x :: [*]) where

67+ allDocs :: proxy x

68+ -- intro, req

69+ -> [(String, String)]

70+

71+instance (OneDoc a, AllDocs as) => AllDocs (a ': as) where

72+ allDocs _ = oneDoc (Proxy :: Proxy a) : allDocs (Proxy :: Proxy as)

73+

74+instance AllDocs '[] where

75+ allDocs _ = []

76+

77+class OneDoc a where

78+ oneDoc :: proxy a -> (String, String)

79+

80+instance OneDoc JWT where

81+ oneDoc _ =

82+ ("JSON Web Tokens ([JWTs](https://en.wikipedia.org/wiki/JSON_Web_Token))"

83+ , "A JWT Token signed with this server's key")

84+

85+instance OneDoc Cookie where

86+ oneDoc _ =

87+ ("[Cookies](https://en.wikipedia.org/wiki/HTTP_cookie)"

88+ , "Cookies automatically set by browsers, plus a header")

89+

90+instance OneDoc BasicAuth where

91+ oneDoc _ =

92+ ( "[Basic Authentication](https://en.wikipedia.org/wiki/Basic_access_authentication)"

93+ , "Cookies automatically set by browsers, plus a header")

94+

95+-- $setup

96+-- >>> instance ToSample Int where toSamples _ = singleSample 1729

servant-auth/servant-auth-docs/test/Spec.hsnew file+1

@@ -0,0 +1 @@

1+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

servant-auth/servant-auth-docs/test/doctests.hsnew file+12

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

1+module Main where

2+

3+import Build_doctests (flags, pkgs, module_sources)

4+import Data.Foldable (traverse_)

5+import Test.DocTest

6+

7+main :: IO ()

8+main = do

9+ traverse_ putStrLn args

10+ doctest args

11+ where

12+ args = flags ++ pkgs ++ module_sources

servant-auth/servant-auth-server/.ghcinew file+1

@@ -0,0 +1 @@

1+:set -isrc -itest -idoctest/ghci-wrapper/src

servant-auth/servant-auth-server/CHANGELOG.mdnew file+130

@@ -0,0 +1,130 @@

1+# Changelog

2+

3+All notable changes to this project will be documented in this file.

4+

5+The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/)

6+and this project adheres to [PVP Versioning](https://pvp.haskell.org/).

7+

8+## [Unreleased]

9+

10+## [0.4.6.0] - 2020-10-06

11+

12+## Changed

13+

14+- expose verifyJWT and use it in two places [@domenkozar]

15+- support GHC 8.10 [@domenkozar]

16+- move ToJWT/FromJWT to servant-auth [@erewok]

17+- #165 fix AnySite with Cookie 3.5.0 [@odr]

18+

19+## [0.4.5.1] - 2020-02-06

20+

21+## Changed

22+

23+- #158 servant 0.17 support [@phadej]

24+

25+## [0.4.5.0] - 2019-12-28

26+

27+## Changed

28+- #144 servant 0.16 support and drop GHC 7.10 support [@domenkozar]

29+- #148 removed unused constaint in HasServer instance for Auth

30+- #154 GHC 8.8 support [@phadej]

31+

32+### Added

33+- #141 Support Stream combinator [@domenkozar]

34+- #143 Allow servant-0.16 [@phadej]

35+

36+## [0.4.4.0] - 2019-03-02

37+

38+### Added

39+- #141 Support Stream combinator [@domenkozar]

40+- #143 Allow servant-0.16 [@phadej]

41+

42+## [0.4.3.0] - 2019-01-17

43+

44+## Changed

45+- #117 Avoid running auth checks unnecessarily [@sopvop]

46+- #110 Get rid of crypto-api dependency [@domenkozar]

47+- #130 clearSession: improve cross-browser compatibility [@domenkozar]

48+- #136 weed out bytestring-conversion [@stephenirl]

49+

50+## [0.4.2.0] - 2018-11-05

51+

52+### Added

53+- `Headers hs a` instance for AddSetCookieApi [@domenkozar]

54+- GHC 8.6.x support [@domenkozar]

55+

56+## [0.4.1.0] - 2018-10-05

57+

58+### Added

59+- #125 Allow setting domain name for a cookie [@domenkozar]

60+

61+## Changed

62+- bump http-api-data to 0.3.10 that includes Cookie orphan instances previously located in servant-auth-server [@phadej]

63+- #114 Export `HasSecurity` typeclass [@rockbmb]

64+

65+## [0.4.0.1] - 2018-09-23

66+

67+### Security

68+- #123 Session cookie did not apply SameSite attribute [@domenkozar]

69+

70+### Added

71+- #112 HasLink instance for Auth combinator [@adetokunbo]

72+- #111 Documentation for using hoistServer [@mschristiansen]

73+- #107 Add utility functions for reading and writing a key to a file [@mschristiansen]

74+

75+## [0.4.0.0] - 2018-06-17

76+

77+### Added

78+- Support GHC 8.4 by @phadej and @domenkozar

79+- Support for servant-0.14 by @phadej

80+- #96 Support for jose-0.7 by @xaviershay

81+- #92 add `clearSession` for logout by @plredmond and @3noch

82+- #95 makeJWT: allow setting Alg via defaultJWTSettings by @domenkozar

83+- #89 Validate JWT against a JWKSet instead of JWK by @sopvop

84+

85+### Changed

86+- #92 Rename CSRF to XSRF by @plredmond and @3noch

87+- #92 extract 'XsrfCookieSettings' from 'CookieSettings' and make XSRF checking optional

88+ by @plredmond and @3noch

89+- #69 export SameSite by @domenkozar

90+- #102 Reuse Servant.Api.IsSecure instead of duplicating ADT by @domenkozar

91+

92+### Deprecated

93+- #92 Renamed 'makeCsrfCookie' to 'makeXsrfCookie' and marked the former as deprecated

94+ by @plredmond and @3noc

95+- #92 Made several changes to the structure of 'CookieSettings' which will require

96+ attention by users who have modified the XSRF settings by @plredmond and @3noch

97+

98+### Security

99+- #94 Force cookie expiration on serverside by @karshan

100+

101+## [0.3.2.0] - 2018-02-21

102+

103+### Added

104+- #76 Export wwwAuthenticatedErr and elaborate its annotation by @defanor

105+- Support for servant-0.14 by @phadej

106+

107+### Changed

108+- Disable the readme executable for ghcjs builds by @hamishmack

109+- #84 Make AddSetCookieApi type family open by @qnikst

110+- #79 Make CSRF checks optional for GET requests by @harendra-kumar

111+

112+## [0.3.1.0] - 2017-11-08

113+

114+### Added

115+- Support for servant-0.12 by @phadej

116+

117+## [0.3.0.0] - 2017-11-07

118+

119+### Changed

120+- #47 'cookiePath' and 'xsrfCookiePath' added to 'CookieSettings' by @mchaver

121+

122+## [0.2.8.0] - 2017-05-26

123+

124+### Added

125+- #45 Support for servant-0.11 by @phadej

126+

127+## [0.2.7.0] - 2017-02-11

128+

129+### Changed

130+- #27 #41 'acceptLogin' and 'makeCsrfCookie' functions by @bts

servant-auth/servant-auth-server/LICENSEnew file+31

@@ -0,0 +1,31 @@

1+Copyright Julian K. Arni (c) 2015

2+

3+All rights reserved.

4+

5+Redistribution and use in source and binary forms, with or without

6+modification, are permitted provided that the following conditions are met:

7+

8+ * Redistributions of source code must retain the above copyright

9+ notice, this list of conditions and the following disclaimer.

10+

11+ * Redistributions in binary form must reproduce the above

12+ copyright notice, this list of conditions and the following

13+ disclaimer in the documentation and/or other materials provided

14+ with the distribution.

15+

16+ * Neither the name of Julian K. Arni nor the names of other

17+ contributors may be used to endorse or promote products derived

18+ from this software without specific prior written permission.

19+

20+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS

21+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT

22+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR

23+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT

24+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,

25+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT

26+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,

27+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY

28+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT

29+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE

30+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

31+

servant-auth/servant-auth-server/README.lhsnew file+291

@@ -0,0 +1,291 @@

1+# servant-auth

2+

3+These packages provides safe and easy-to-use authentication options for

4+`servant`. The same API can be protected via:

5+- basicauth

6+- cookies

7+- JWT tokens

8+

9+

10+| Package | Hackage |

11+| -------------------- | ----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- |

12+| servant-auth | [](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.mdnew file+1

@@ -0,0 +1 @@

1+README.lhs

servant-auth/servant-auth-server/Setup.hsnew file+2

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

1+import Distribution.Simple

2+main = defaultMain

servant-auth/servant-auth-server/servant-auth-server.cabalnew file+134

@@ -0,0 +1,134 @@

1+cabal-version: 2.2

2+name: servant-auth-server

3+version: 0.4.7.0

4+synopsis: servant-server/servant-auth compatibility

5+description: This package provides the required instances for using the @Auth@ combinator

6+ in your 'servant' server.

7+ .

8+ Both cookie- and token- (REST API) based authentication is provided.

9+ .

10+ For a quick overview of the usage, see the <https://github.com/haskell-servant/servant/tree/master/servant-auth#readme README>.

11+category: Web, Servant, Authentication

12+homepage: https://github.com/haskell-servant/servant/tree/master/servant-auth#readme

13+bug-reports: https://github.com/haskell-servant/servant/issues

14+author: Julian K. Arni

15+maintainer: jkarni@gmail.com

16+copyright: (c) Julian K. Arni

17+license: BSD-3-Clause

18+license-file: LICENSE

19+tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1

20+build-type: Simple

21+extra-source-files:

22+ CHANGELOG.md

23+

24+source-repository head

25+ type: git

26+ location: https://github.com/haskell-servant/servant

27+

28+library

29+ hs-source-dirs:

30+ src

31+ default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators

32+ ghc-options: -Wall

33+ build-depends:

34+ base >= 4.10 && < 4.17

35+ , aeson >= 1.0.0.1 && < 3

36+ , base64-bytestring >= 1.0.0.1 && < 2

37+ , blaze-builder >= 0.4.1.0 && < 0.5

38+ , bytestring >= 0.10.6.0 && < 0.12

39+ , case-insensitive >= 1.2.0.11 && < 1.3

40+ , cookie >= 0.4.4 && < 0.5

41+ , data-default-class >= 0.1.2.0 && < 0.2

42+ , entropy >= 0.4.1.3 && < 0.5

43+ , http-types >= 0.12.2 && < 0.13

44+ , jose >= 0.7.0.0 && < 0.10

45+ , lens >= 4.16.1 && < 5.2

46+ , memory >= 0.14.16 && < 0.18

47+ , monad-time >= 0.3.1.0 && < 0.4

48+ , mtl >= 2.2.2 && < 2.3

49+ , servant >= 0.13 && < 0.20

50+ , servant-auth == 0.4.*

51+ , servant-server >= 0.13 && < 0.20

52+ , tagged >= 0.8.4 && < 0.9

53+ , text >= 1.2.3.0 && < 2.1

54+ , time >= 1.5.0.1 && < 1.12

55+ , unordered-containers >= 0.2.9.0 && < 0.3

56+ , wai >= 3.2.1.2 && < 3.3

57+

58+ if impl(ghc >= 9)

59+ build-depends:

60+ -- base64-bytestring 1.2.1.0 contains important fix for GHC-9, lower versions

61+ -- produce wrong results, thus corrupring JWT via jose package.

62+ -- See: https://github.com/haskell/base64-bytestring/pull/46

63+ base64-bytestring >= 1.2.1.0

64+

65+ exposed-modules:

66+ Servant.Auth.Server

67+ Servant.Auth.Server.Internal

68+ Servant.Auth.Server.Internal.AddSetCookie

69+ Servant.Auth.Server.Internal.BasicAuth

70+ Servant.Auth.Server.Internal.Class

71+ Servant.Auth.Server.Internal.ConfigTypes

72+ Servant.Auth.Server.Internal.Cookie

73+ Servant.Auth.Server.Internal.FormLogin

74+ Servant.Auth.Server.Internal.JWT

75+ Servant.Auth.Server.Internal.ThrowAll

76+ Servant.Auth.Server.Internal.Types

77+ Servant.Auth.Server.SetCookieOrphan

78+ default-language: Haskell2010

79+

80+test-suite readme

81+ type: exitcode-stdio-1.0

82+ main-is: README.lhs

83+ default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators

84+ ghc-options: -Wall -pgmL markdown-unlit

85+ build-tool-depends: markdown-unlit:markdown-unlit

86+ build-depends:

87+ base

88+ , servant-auth

89+ , servant-auth-server

90+ , servant-server

91+ , aeson

92+ , mtl

93+ , warp

94+ default-language: Haskell2010

95+ if impl(ghcjs)

96+ buildable: False

97+

98+test-suite spec

99+ type: exitcode-stdio-1.0

100+ main-is: Spec.hs

101+ hs-source-dirs:

102+ test

103+ default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators

104+ ghc-options: -Wall

105+ build-tool-depends: hspec-discover:hspec-discover >=2.5.5 && <2.10

106+

107+ -- dependencies with bounds inherited from the library stanza

108+ build-depends:

109+ base

110+ , aeson

111+ , bytestring

112+ , case-insensitive

113+ , jose

114+ , lens

115+ , mtl

116+ , time

117+ , http-types

118+ , wai

119+ , servant

120+ , servant-server

121+ , transformers

122+

123+ -- test dependencies

124+ build-depends:

125+ servant-auth-server

126+ , hspec >= 2.5.5 && < 2.10

127+ , QuickCheck >= 2.11.3 && < 2.15

128+ , http-client >= 0.5.13.1 && < 0.8

129+ , lens-aeson >= 1.0.2 && < 1.3

130+ , warp >= 3.2.25 && < 3.4

131+ , wreq >= 0.5.2.1 && < 0.6

132+ other-modules:

133+ Servant.Auth.ServerSpec

134+ default-language: Haskell2010

servant-auth/servant-auth-server/src/Servant/Auth/Server.hsnew file+180

@@ -0,0 +1,180 @@

1+module Servant.Auth.Server

2+ (

3+ -- | This package provides implementations for some common authentication

4+ -- methods. Authentication yields a trustworthy (because generated by the

5+ -- server) value of an some arbitrary type:

6+ --

7+ -- > type MyApi = Protected

8+ -- >

9+ -- > type Protected = Auth '[JWT, Cookie] User :> Get '[JSON] UserAccountDetails

10+ -- >

11+ -- > server :: Server Protected

12+ -- > server (Authenticated usr) = ... -- here we know the client really is

13+ -- > -- who she claims to be

14+ -- > server _ = throwAll err401

15+ --

16+ -- Additional configuration happens via 'Context'.

17+ --

18+ -- == Example for Custom Handler

19+ -- To use a custom 'Servant.Server.Handler' it is necessary to use

20+ -- 'Servant.Server.hoistServerWithContext' instead of

21+ -- 'Servant.Server.hoistServer' and specify the 'Context'.

22+ --

23+ -- Below is an example of passing 'CookieSettings' and 'JWTSettings' in the

24+ -- 'Context' to create a specialized function equivalent to

25+ -- 'Servant.Server.hoistServer' for an API that includes cookie

26+ -- authentication.

27+ --

28+ -- > hoistServerWithAuth

29+ -- > :: HasServer api '[CookieSettings, JWTSettings]

30+ -- > => Proxy api

31+ -- > -> (forall x. m x -> n x)

32+ -- > -> ServerT api m

33+ -- > -> ServerT api n

34+ -- > hoistServerWithAuth api =

35+ -- > hoistServerWithContext api (Proxy :: Proxy '[CookieSettings, JWTSettings])

36+

37+ ----------------------------------------------------------------------------

38+ -- * Auth

39+ -- | Basic types

40+ Auth

41+ , AuthResult(..)

42+ , AuthCheck(..)

43+

44+ ----------------------------------------------------------------------------

45+ -- * JWT

46+ -- | JSON Web Tokens (JWT) are a compact and secure way of transferring

47+ -- information between parties. In this library, they are signed by the

48+ -- server (or by some other party posessing the relevant key), and used to

49+ -- indicate the bearer's identity or authorization.

50+ --

51+ -- Arbitrary information can be encoded - just declare instances for the

52+ -- 'FromJWT' and 'ToJWT' classes. Don't go overboard though - be aware that

53+ -- usually you'll be trasmitting this information on each request (and

54+ -- response!).

55+ --

56+ -- Note that, while the tokens are signed, they are not encrypted. Do not put

57+ -- any information you do not wish the client to know in them!

58+

59+ -- ** Combinator

60+ -- | Re-exported from 'servant-auth'

61+ , JWT

62+

63+ -- ** Classes

64+ , FromJWT(..)

65+ , ToJWT(..)

66+

67+ -- ** Related types

68+ , IsMatch(..)

69+

70+ -- ** Settings

71+ , JWTSettings(..)

72+ , defaultJWTSettings

73+

74+ -- ** Create check

75+ , jwtAuthCheck

76+

77+

78+ ----------------------------------------------------------------------------

79+ -- * Cookie

80+ -- | Cookies are also a method of identifying and authenticating a user. They

81+ -- are particular common when the client is a browser

82+

83+ -- ** Combinator

84+ -- | Re-exported from 'servant-auth'

85+ , Cookie

86+

87+ -- ** Settings

88+ , CookieSettings(..)

89+ , XsrfCookieSettings(..)

90+ , defaultCookieSettings

91+ , defaultXsrfCookieSettings

92+ , makeSessionCookie

93+ , makeSessionCookieBS

94+ , makeXsrfCookie

95+ , makeCsrfCookie

96+ , makeCookie

97+ , makeCookieBS

98+ , acceptLogin

99+ , clearSession

100+

101+

102+ -- ** Related types

103+ , IsSecure(..)

104+ , SameSite(..)

105+ , AreAuths

106+

107+ ----------------------------------------------------------------------------

108+ -- * BasicAuth

109+ -- ** Combinator

110+ -- | Re-exported from 'servant-auth'

111+ , BasicAuth

112+

113+ -- ** Classes

114+ , FromBasicAuthData(..)

115+

116+ -- ** Settings

117+ , BasicAuthCfg

118+

119+ -- ** Related types

120+ , BasicAuthData(..)

121+ , IsPasswordCorrect(..)

122+

123+ -- ** Authentication request

124+ , wwwAuthenticatedErr

125+

126+ ----------------------------------------------------------------------------

127+ -- * Utilies

128+ , ThrowAll(throwAll)

129+ , generateKey

130+ , generateSecret

131+ , fromSecret

132+ , writeKey

133+ , readKey

134+ , makeJWT

135+ , verifyJWT

136+

137+ -- ** Re-exports

138+ , Default(def)

139+ , SetCookie

140+ ) where

141+

142+import Prelude hiding (readFile, writeFile)

143+import Data.ByteString (ByteString, writeFile, readFile)

144+import Data.Default.Class (Default (def))

145+import Servant.Auth

146+import Servant.Auth.JWT

147+import Servant.Auth.Server.Internal ()

148+import Servant.Auth.Server.Internal.BasicAuth

149+import Servant.Auth.Server.Internal.Class

150+import Servant.Auth.Server.Internal.ConfigTypes

151+import Servant.Auth.Server.Internal.Cookie

152+import Servant.Auth.Server.Internal.JWT

153+import Servant.Auth.Server.Internal.ThrowAll

154+import Servant.Auth.Server.Internal.Types

155+

156+import Crypto.JOSE as Jose

157+import Servant (BasicAuthData (..))

158+import Web.Cookie (SetCookie)

159+

160+-- | Generate a key suitable for use with 'defaultConfig'.

161+generateKey :: IO Jose.JWK

162+generateKey = Jose.genJWK $ Jose.OctGenParam 256

163+

164+-- | Generate a bytestring suitable for use with 'fromSecret'.

165+generateSecret :: MonadRandom m => m ByteString

166+generateSecret = Jose.getRandomBytes 256

167+

168+-- | Restores a key from a bytestring.

169+fromSecret :: ByteString -> Jose.JWK

170+fromSecret = Jose.fromOctets

171+

172+-- | Writes a secret to a file. Can for instance be used from the REPL

173+-- to persist a key to a file, which can then be included with the

174+-- application. Restore the key using 'readKey'.

175+writeKey :: FilePath -> IO ()

176+writeKey fp = writeFile fp =<< generateSecret

177+

178+-- | Reads a key from a file.

179+readKey :: FilePath -> IO Jose.JWK

180+readKey fp = fromSecret <$> readFile fp

servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal.hsnew file+70

@@ -0,0 +1,70 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE UndecidableInstances #-}

3+{-# OPTIONS_GHC -fno-warn-orphans #-}

4+

5+module Servant.Auth.Server.Internal where

6+

7+import Control.Monad.Trans (liftIO)

8+import Servant ((:>), Handler, HasServer (..),

9+ Proxy (..),

10+ HasContextEntry(getContextEntry))

11+import Servant.Auth

12+import Servant.Auth.JWT (ToJWT)

13+

14+import Servant.Auth.Server.Internal.AddSetCookie

15+import Servant.Auth.Server.Internal.Class

16+import Servant.Auth.Server.Internal.Cookie

17+import Servant.Auth.Server.Internal.ConfigTypes

18+import Servant.Auth.Server.Internal.JWT

19+import Servant.Auth.Server.Internal.Types

20+

21+import Servant.Server.Internal (DelayedIO, addAuthCheck, withRequest)

22+

23+instance ( n ~ 'S ('S 'Z)

24+ , HasServer (AddSetCookiesApi n api) ctxs, AreAuths auths ctxs v

25+ , HasServer api ctxs -- this constraint is needed to implement hoistServer

26+ , AddSetCookies n (ServerT api Handler) (ServerT (AddSetCookiesApi n api) Handler)

27+ , ToJWT v

28+ , HasContextEntry ctxs CookieSettings

29+ , HasContextEntry ctxs JWTSettings

30+ ) => HasServer (Auth auths v :> api) ctxs where

31+ type ServerT (Auth auths v :> api) m = AuthResult v -> ServerT api m

32+

33+#if MIN_VERSION_servant_server(0,12,0)

34+ hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s

35+#endif

36+

37+ route _ context subserver =

38+ route (Proxy :: Proxy (AddSetCookiesApi n api))

39+ context

40+ (fmap go subserver `addAuthCheck` authCheck)

41+

42+ where

43+ authCheck :: DelayedIO (AuthResult v, SetCookieList ('S ('S 'Z)))

44+ authCheck = withRequest $ \req -> liftIO $ do

45+ authResult <- runAuthCheck (runAuths (Proxy :: Proxy auths) context) req

46+ cookies <- makeCookies authResult

47+ return (authResult, cookies)

48+

49+ jwtSettings :: JWTSettings

50+ jwtSettings = getContextEntry context

51+

52+ cookieSettings :: CookieSettings

53+ cookieSettings = getContextEntry context

54+

55+ makeCookies :: AuthResult v -> IO (SetCookieList ('S ('S 'Z)))

56+ makeCookies authResult = do

57+ xsrf <- makeXsrfCookie cookieSettings

58+ fmap (Just xsrf `SetCookieCons`) $

59+ case authResult of

60+ (Authenticated v) -> do

61+ ejwt <- makeSessionCookie cookieSettings jwtSettings v

62+ case ejwt of

63+ Nothing -> return $ Nothing `SetCookieCons` SetCookieNil

64+ Just jwt -> return $ Just jwt `SetCookieCons` SetCookieNil

65+ _ -> return $ Nothing `SetCookieCons` SetCookieNil

66+

67+ go :: (AuthResult v -> ServerT api Handler)

68+ -> (AuthResult v, SetCookieList n)

69+ -> ServerT (AddSetCookiesApi n api) Handler

70+ go fn (authResult, cookies) = addSetCookies cookies $ fn authResult

servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/AddSetCookie.hsnew file+106

@@ -0,0 +1,106 @@

1+{-# LANGUAGE PolyKinds #-}

2+{-# LANGUAGE TupleSections #-}

3+{-# LANGUAGE UndecidableInstances #-}

4+{-# LANGUAGE CPP #-}

5+

6+module Servant.Auth.Server.Internal.AddSetCookie where

7+

8+import Blaze.ByteString.Builder (toByteString)

9+import qualified Data.ByteString as BS

10+import Data.Tagged (Tagged (..))

11+import qualified Network.HTTP.Types as HTTP

12+import Network.Wai (mapResponseHeaders)

13+import Servant

14+import Servant.API.Generic

15+import Servant.Server.Generic

16+import Web.Cookie

17+

18+-- What are we doing here? Well, the idea is to add headers to the response,

19+-- but the headers come from the authentication check. In order to do that, we

20+-- tweak a little the general theme of recursing down the API tree; this time,

21+-- we recurse down a variation of it that adds headers to all the endpoints.

22+-- This involves the usual type-level checks.

23+--

24+-- TODO: If the endpoints already have headers, this will not work as is.

25+

26+data Nat = Z | S Nat

27+

28+type family AddSetCookiesApi (n :: Nat) a where

29+ AddSetCookiesApi ('S 'Z) a = AddSetCookieApi a

30+ AddSetCookiesApi ('S n) a = AddSetCookiesApi n (AddSetCookieApi a)

31+

32+type family AddSetCookieApiVerb a where

33+ AddSetCookieApiVerb (Headers ls a) = Headers (Header "Set-Cookie" SetCookie ': ls) a

34+ AddSetCookieApiVerb a = Headers '[Header "Set-Cookie" SetCookie] a

35+

36+type family AddSetCookieApi a :: *

37+type instance AddSetCookieApi (a :> b) = a :> AddSetCookieApi b

38+type instance AddSetCookieApi (a :<|> b) = AddSetCookieApi a :<|> AddSetCookieApi b

39+type instance AddSetCookieApi (NamedRoutes api) = AddSetCookieApi (ToServantApi api)

40+type instance AddSetCookieApi (Verb method stat ctyps a)

41+ = Verb method stat ctyps (AddSetCookieApiVerb a)

42+type instance AddSetCookieApi Raw = Raw

43+#if MIN_VERSION_servant_server(0,15,0)

44+type instance AddSetCookieApi (Stream method stat framing ctyps a)

45+ = Stream method stat framing ctyps (AddSetCookieApiVerb a)

46+#endif

47+type instance AddSetCookieApi (Headers hs a) = AddSetCookieApiVerb (Headers hs a)

48+

49+data SetCookieList (n :: Nat) :: * where

50+ SetCookieNil :: SetCookieList 'Z

51+ SetCookieCons :: Maybe SetCookie -> SetCookieList n -> SetCookieList ('S n)

52+

53+class AddSetCookies (n :: Nat) orig new where

54+ addSetCookies :: SetCookieList n -> orig -> new

55+

56+instance {-# OVERLAPS #-} AddSetCookies ('S n) oldb newb

57+ => AddSetCookies ('S n) (a -> oldb) (a -> newb) where

58+ addSetCookies cookies oldfn = addSetCookies cookies . oldfn

59+

60+instance AddSetCookies 'Z orig orig where

61+ addSetCookies _ = id

62+

63+instance {-# OVERLAPPABLE #-}

64+ ( Functor m

65+ , AddSetCookies n (m old) (m cookied)

66+ , AddHeader "Set-Cookie" SetCookie cookied new

67+ ) => AddSetCookies ('S n) (m old) (m new) where

68+ addSetCookies (mCookie `SetCookieCons` rest) oldVal =

69+ case mCookie of

70+ Nothing -> noHeader <$> addSetCookies rest oldVal

71+ Just cookie -> addHeader cookie <$> addSetCookies rest oldVal

72+

73+instance {-# OVERLAPS #-}

74+ (AddSetCookies ('S n) a a', AddSetCookies ('S n) b b')

75+ => AddSetCookies ('S n) (a :<|> b) (a' :<|> b') where

76+ addSetCookies cookies (a :<|> b) = addSetCookies cookies a :<|> addSetCookies cookies b

77+

78+instance {-# OVERLAPS #-}

79+ ( AddSetCookies ('S n) (ServerT (ToServantApi api) m) cookiedApi

80+ , Generic (api (AsServerT m))

81+ , GServantProduct (Rep (api (AsServerT m)))

82+ , ToServant api (AsServerT m) ~ ServerT (ToServantApi api) m

83+ )

84+ => AddSetCookies ('S n) (api (AsServerT m)) cookiedApi where

85+ addSetCookies cookies = addSetCookies cookies . toServant

86+

87+-- | for @servant <0.11@

88+instance

89+ AddSetCookies ('S n) Application Application where

90+ addSetCookies cookies r request respond

91+ = r request $ respond . mapResponseHeaders (++ mkHeaders cookies)

92+

93+-- | for @servant >=0.11@

94+instance

95+ AddSetCookies ('S n) (Tagged m Application) (Tagged m Application) where

96+ addSetCookies cookies r = Tagged $ \request respond ->

97+ unTagged r request $ respond . mapResponseHeaders (++ mkHeaders cookies)

98+

99+mkHeaders :: SetCookieList x -> [HTTP.Header]

100+mkHeaders x = ("Set-Cookie",) <$> mkCookies x

101+ where

102+ mkCookies :: forall y. SetCookieList y -> [BS.ByteString]

103+ mkCookies SetCookieNil = []

104+ mkCookies (SetCookieCons Nothing rest) = mkCookies rest

105+ mkCookies (SetCookieCons (Just y) rest)

106+ = toByteString (renderSetCookie y) : mkCookies rest

servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/BasicAuth.hsnew file+59

@@ -0,0 +1,59 @@

1+{-# LANGUAGE CPP #-}

2+module Servant.Auth.Server.Internal.BasicAuth where

3+

4+#if !MIN_VERSION_servant_server(0,16,0)

5+#define ServerError ServantErr

6+#endif

7+

8+import qualified Data.ByteString as BS

9+import Servant (BasicAuthData (..),

10+ ServerError (..), err401)

11+import Servant.Server.Internal.BasicAuth (decodeBAHdr,

12+ mkBAChallengerHdr)

13+

14+import Servant.Auth.Server.Internal.Types

15+

16+-- | A 'ServerError' that asks the client to authenticate via Basic

17+-- Authentication, should be invoked by an application whenever

18+-- appropriate. The argument is the realm.

19+wwwAuthenticatedErr :: BS.ByteString -> ServerError

20+wwwAuthenticatedErr realm = err401 { errHeaders = [mkBAChallengerHdr realm] }

21+

22+-- | A type holding the configuration for Basic Authentication.

23+-- It is defined as a type family with no arguments, so that

24+-- it can be instantiated to whatever type you need to

25+-- authenticate your users (use @type instance BasicAuthCfg = ...@).

26+--

27+-- Note that the instantiation is application-wide,

28+-- i.e. there can be only one instance.

29+-- As a consequence, it should not be instantiated in a library.

30+--

31+-- Basic Authentication expects an element of type 'BasicAuthCfg'

32+-- to be in the 'Context'; that element is then passed automatically

33+-- to the instance of 'FromBasicAuthData' together with the

34+-- authentication data obtained from the client.

35+--

36+-- If you do not need a configuration for Basic Authentication,

37+-- you can use just @BasicAuthCfg = ()@, and recall to also

38+-- add @()@ to the 'Context'.

39+-- A basic but more interesting example is to take as 'BasicAuthCfg'

40+-- a list of authorised username/password pairs:

41+--

42+-- > deriving instance Eq BasicAuthData

43+-- > type instance BasicAuthCfg = [BasicAuthData]

44+-- > instance FromBasicAuthData User where

45+-- > fromBasicAuthData authData authCfg =

46+-- > if elem authData authCfg then ...

47+type family BasicAuthCfg

48+

49+class FromBasicAuthData a where

50+ -- | Whether the username exists and the password is correct.

51+ -- Note that, rather than passing a 'Pass' to the function, we pass a

52+ -- function that checks an 'EncryptedPass'. This is to make sure you don't

53+ -- accidentally do something untoward with the password, like store it.

54+ fromBasicAuthData :: BasicAuthData -> BasicAuthCfg -> IO (AuthResult a)

55+

56+basicAuthCheck :: FromBasicAuthData usr => BasicAuthCfg -> AuthCheck usr

57+basicAuthCheck cfg = AuthCheck $ \req -> case decodeBAHdr req of

58+ Nothing -> return Indefinite

59+ Just baData -> fromBasicAuthData baData cfg

servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/Class.hsnew file+72

@@ -0,0 +1,72 @@

1+{-# LANGUAGE UndecidableInstances #-}

2+module Servant.Auth.Server.Internal.Class where

3+

4+import Servant.Auth

5+import Data.Monoid

6+import Servant hiding (BasicAuth)

7+

8+import Servant.Auth.JWT

9+import Servant.Auth.Server.Internal.Types

10+import Servant.Auth.Server.Internal.ConfigTypes

11+import Servant.Auth.Server.Internal.BasicAuth

12+import Servant.Auth.Server.Internal.Cookie

13+import Servant.Auth.Server.Internal.JWT (jwtAuthCheck)

14+

15+-- | @IsAuth a ctx v@ indicates that @a@ is an auth type that expects all

16+-- elements of @ctx@ to be the in the Context and whose authentication check

17+-- returns an @AuthCheck v@.

18+class IsAuth a v where

19+ type family AuthArgs a :: [*]

20+ runAuth :: proxy a -> proxy v -> Unapp (AuthArgs a) (AuthCheck v)

21+

22+instance FromJWT usr => IsAuth Cookie usr where

23+ type AuthArgs Cookie = '[CookieSettings, JWTSettings]

24+ runAuth _ _ = cookieAuthCheck

25+

26+instance FromJWT usr => IsAuth JWT usr where

27+ type AuthArgs JWT = '[JWTSettings]

28+ runAuth _ _ = jwtAuthCheck

29+

30+instance FromBasicAuthData usr => IsAuth BasicAuth usr where

31+ type AuthArgs BasicAuth = '[BasicAuthCfg]

32+ runAuth _ _ = basicAuthCheck

33+

34+-- * Helper

35+

36+class AreAuths (as :: [*]) (ctxs :: [*]) v where

37+ runAuths :: proxy as -> Context ctxs -> AuthCheck v

38+

39+instance AreAuths '[] ctxs v where

40+ runAuths _ _ = mempty

41+

42+instance ( AuthCheck v ~ App (AuthArgs a) (Unapp (AuthArgs a) (AuthCheck v))

43+ , IsAuth a v

44+ , AreAuths as ctxs v

45+ , AppCtx ctxs (AuthArgs a) (Unapp (AuthArgs a) (AuthCheck v))

46+ ) => AreAuths (a ': as) ctxs v where

47+ runAuths _ ctxs = go <> runAuths (Proxy :: Proxy as) ctxs

48+ where

49+ go = appCtx (Proxy :: Proxy (AuthArgs a))

50+ ctxs

51+ (runAuth (Proxy :: Proxy a) (Proxy :: Proxy v))

52+

53+type family Unapp ls res where

54+ Unapp '[] res = res

55+ Unapp (arg1 ': rest) res = arg1 -> Unapp rest res

56+

57+type family App ls res where

58+ App '[] res = res

59+ App (arg1 ': rest) (arg1 -> res) = App rest res

60+

61+-- | @AppCtx@ applies the function @res@ to the arguments in @ls@ by taking the

62+-- values from the Context provided.

63+class AppCtx ctx ls res where

64+ appCtx :: proxy ls -> Context ctx -> res -> App ls res

65+

66+instance ( HasContextEntry ctxs ctx

67+ , AppCtx ctxs rest res

68+ ) => AppCtx ctxs (ctx ': rest) (ctx -> res) where

69+ appCtx _ ctx fn = appCtx (Proxy :: Proxy rest) ctx $ fn $ getContextEntry ctx

70+

71+instance AppCtx ctx '[] res where

72+ appCtx _ _ r = r

servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/ConfigTypes.hsnew file+127

@@ -0,0 +1,127 @@

1+module Servant.Auth.Server.Internal.ConfigTypes

2+ ( module Servant.Auth.Server.Internal.ConfigTypes

3+ , Servant.API.IsSecure(..)

4+ ) where

5+

6+import Crypto.JOSE as Jose

7+import Crypto.JWT as Jose

8+import qualified Data.ByteString as BS

9+import Data.Default.Class

10+import Data.Time

11+import GHC.Generics (Generic)

12+import Servant.API (IsSecure(..))

13+

14+data IsMatch = Matches | DoesNotMatch

15+ deriving (Eq, Show, Read, Generic, Ord)

16+

17+data IsPasswordCorrect = PasswordCorrect | PasswordIncorrect

18+ deriving (Eq, Show, Read, Generic, Ord)

19+

20+-- The @SameSite@ attribute of cookies determines whether cookies will be sent

21+-- on cross-origin requests.

22+--

23+-- See <https://tools.ietf.org/html/draft-west-first-party-cookies-07 this document>

24+-- for more information.

25+data SameSite = AnySite | SameSiteStrict | SameSiteLax

26+ deriving (Eq, Show, Read, Generic, Ord)

27+

28+-- | @JWTSettings@ are used to generate cookies, and to verify JWTs.

29+data JWTSettings = JWTSettings

30+ {

31+ -- | Key used to sign JWT.

32+ signingKey :: Jose.JWK

33+ -- | Algorithm used to sign JWT.

34+ , jwtAlg :: Maybe Jose.Alg

35+ -- | Keys used to validate JWT.

36+ , validationKeys :: IO Jose.JWKSet

37+ -- | An @aud@ predicate. The @aud@ is a string or URI that identifies the

38+ -- intended recipient of the JWT.

39+ , audienceMatches :: Jose.StringOrURI -> IsMatch

40+ } deriving (Generic)

41+

42+-- | A @JWTSettings@ where the audience always matches.

43+defaultJWTSettings :: Jose.JWK -> JWTSettings

44+defaultJWTSettings k = JWTSettings

45+ { signingKey = k

46+ , jwtAlg = Nothing

47+ , validationKeys = pure $ Jose.JWKSet [k]

48+ , audienceMatches = const Matches }

49+

50+-- | The policies to use when generating cookies.

51+--

52+-- If *both* 'cookieMaxAge' and 'cookieExpires' are @Nothing@, browsers will

53+-- treat the cookie as a *session cookie*. These will be deleted when the

54+-- browser is closed.

55+--

56+-- Note that having the setting @Secure@ may cause testing failures if you are

57+-- not testing over HTTPS.

58+data CookieSettings = CookieSettings

59+ {

60+ -- | 'Secure' means browsers will only send cookies over HTTPS. Default:

61+ -- @Secure@.

62+ cookieIsSecure :: !IsSecure

63+ -- | How long from now until the cookie expires. Default: @Nothing@.

64+ , cookieMaxAge :: !(Maybe DiffTime)

65+ -- | At what time the cookie expires. Default: @Nothing@.

66+ , cookieExpires :: !(Maybe UTCTime)

67+ -- | The URL path and sub-paths for which this cookie is used. Default: @Just "/"@.

68+ , cookiePath :: !(Maybe BS.ByteString)

69+ -- | Domain name, if set cookie also allows subdomains. Default: @Nothing@.

70+ , cookieDomain :: !(Maybe BS.ByteString)

71+ -- | 'SameSite' settings. Default: @SameSiteLax@.

72+ , cookieSameSite :: !SameSite

73+ -- | What name to use for the cookie used for the session.

74+ , sessionCookieName :: !BS.ByteString

75+ -- | The optional settings to use for XSRF protection. Default: @Just def@.

76+ , cookieXsrfSetting :: !(Maybe XsrfCookieSettings)

77+ } deriving (Eq, Show, Generic)

78+

79+instance Default CookieSettings where

80+ def = defaultCookieSettings

81+

82+defaultCookieSettings :: CookieSettings

83+defaultCookieSettings = CookieSettings

84+ { cookieIsSecure = Secure

85+ , cookieMaxAge = Nothing

86+ , cookieExpires = Nothing

87+ , cookiePath = Just "/"

88+ , cookieDomain = Nothing

89+ , cookieSameSite = SameSiteLax

90+ , sessionCookieName = "JWT-Cookie"

91+ , cookieXsrfSetting = Just def

92+ }

93+

94+-- | The policies to use when generating and verifying XSRF cookies

95+data XsrfCookieSettings = XsrfCookieSettings

96+ {

97+ -- | What name to use for the cookie used for XSRF protection.

98+ xsrfCookieName :: !BS.ByteString

99+ -- | What path to use for the cookie used for XSRF protection. Default @Just "/"@.

100+ , xsrfCookiePath :: !(Maybe BS.ByteString)

101+ -- | What name to use for the header used for XSRF protection.

102+ , xsrfHeaderName :: !BS.ByteString

103+ -- | Exclude GET request method from XSRF protection.

104+ , xsrfExcludeGet :: !Bool

105+ } deriving (Eq, Show, Generic)

106+

107+instance Default XsrfCookieSettings where

108+ def = defaultXsrfCookieSettings

109+

110+defaultXsrfCookieSettings :: XsrfCookieSettings

111+defaultXsrfCookieSettings = XsrfCookieSettings

112+ { xsrfCookieName = "XSRF-TOKEN"

113+ , xsrfCookiePath = Just "/"

114+ , xsrfHeaderName = "X-XSRF-TOKEN"

115+ , xsrfExcludeGet = False

116+ }

117+

118+------------------------------------------------------------------------------

119+-- Internal {{{

120+

121+jwtSettingsToJwtValidationSettings :: JWTSettings -> Jose.JWTValidationSettings

122+jwtSettingsToJwtValidationSettings s

123+ = defaultJWTValidationSettings (toBool <$> audienceMatches s)

124+ where

125+ toBool Matches = True

126+ toBool DoesNotMatch = False

127+-- }}}

servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/Cookie.hsnew file+182

@@ -0,0 +1,182 @@

1+{-# LANGUAGE CPP #-}

2+module Servant.Auth.Server.Internal.Cookie where

3+

4+import Blaze.ByteString.Builder (toByteString)

5+import Control.Monad.Except

6+import Control.Monad.Reader

7+import qualified Crypto.JOSE as Jose

8+import qualified Crypto.JWT as Jose

9+import Data.ByteArray (constEq)

10+import qualified Data.ByteString as BS

11+import qualified Data.ByteString.Base64 as BS64

12+import qualified Data.ByteString.Lazy as BSL

13+import Data.CaseInsensitive (mk)

14+import Data.Maybe (fromMaybe)

15+import Data.Time.Calendar (Day(..))

16+import Data.Time.Clock (UTCTime(..), secondsToDiffTime)

17+import Network.HTTP.Types (methodGet)

18+import Network.HTTP.Types.Header(hCookie)

19+import Network.Wai (Request, requestHeaders, requestMethod)

20+import Servant (AddHeader, addHeader)

21+import System.Entropy (getEntropy)

22+import Web.Cookie

23+

24+import Servant.Auth.JWT (FromJWT (decodeJWT), ToJWT)

25+import Servant.Auth.Server.Internal.ConfigTypes

26+import Servant.Auth.Server.Internal.JWT (makeJWT, verifyJWT)

27+import Servant.Auth.Server.Internal.Types

28+

29+

30+cookieAuthCheck :: FromJWT usr => CookieSettings -> JWTSettings -> AuthCheck usr

31+cookieAuthCheck ccfg jwtSettings = do

32+ req <- ask

33+ jwtCookie <- maybe mempty return $ do

34+ cookies' <- lookup hCookie $ requestHeaders req

35+ let cookies = parseCookies cookies'

36+ -- Apply the XSRF check if enabled.

37+ guard $ fromMaybe True $ do

38+ xsrfCookieCfg <- xsrfCheckRequired ccfg req

39+ return $ xsrfCookieAuthCheck xsrfCookieCfg req cookies

40+ -- session cookie *must* be HttpOnly and Secure

41+ lookup (sessionCookieName ccfg) cookies

42+ verifiedJWT <- liftIO $ verifyJWT jwtSettings jwtCookie

43+ case verifiedJWT of

44+ Nothing -> mzero

45+ Just v -> return v

46+

47+xsrfCheckRequired :: CookieSettings -> Request -> Maybe XsrfCookieSettings

48+xsrfCheckRequired cookieSettings req = do

49+ xsrfCookieCfg <- cookieXsrfSetting cookieSettings

50+ let disableForGetReq = xsrfExcludeGet xsrfCookieCfg && requestMethod req == methodGet

51+ guard $ not disableForGetReq

52+ return xsrfCookieCfg

53+

54+xsrfCookieAuthCheck :: XsrfCookieSettings -> Request -> [(BS.ByteString, BS.ByteString)] -> Bool

55+xsrfCookieAuthCheck xsrfCookieCfg req cookies = fromMaybe False $ do

56+ xsrfCookie <- lookup (xsrfCookieName xsrfCookieCfg) cookies

57+ xsrfHeader <- lookup (mk $ xsrfHeaderName xsrfCookieCfg) $ requestHeaders req

58+ return $ xsrfCookie `constEq` xsrfHeader

59+

60+-- | Makes a cookie to be used for XSRF.

61+makeXsrfCookie :: CookieSettings -> IO SetCookie

62+makeXsrfCookie cookieSettings = case cookieXsrfSetting cookieSettings of

63+ Just xsrfCookieSettings -> makeRealCookie xsrfCookieSettings

64+ Nothing -> return $ noXsrfTokenCookie cookieSettings

65+ where

66+ makeRealCookie xsrfCookieSettings = do

67+ xsrfValue <- BS64.encode <$> getEntropy 32

68+ return

69+ $ applyXsrfCookieSettings xsrfCookieSettings

70+ $ applyCookieSettings cookieSettings

71+ $ def{ setCookieValue = xsrfValue }

72+

73+

74+-- | Alias for 'makeXsrfCookie'.

75+makeCsrfCookie :: CookieSettings -> IO SetCookie

76+makeCsrfCookie = makeXsrfCookie

77+{-# DEPRECATED makeCsrfCookie "Use makeXsrfCookie instead" #-}

78+

79+

80+-- | Makes a cookie with session information.

81+makeSessionCookie :: ToJWT v => CookieSettings -> JWTSettings -> v -> IO (Maybe SetCookie)

82+makeSessionCookie cookieSettings jwtSettings v = do

83+ ejwt <- makeJWT v jwtSettings (cookieExpires cookieSettings)

84+ case ejwt of

85+ Left _ -> return Nothing

86+ Right jwt -> return

87+ $ Just

88+ $ applySessionCookieSettings cookieSettings

89+ $ applyCookieSettings cookieSettings

90+ $ def{ setCookieValue = BSL.toStrict jwt }

91+

92+noXsrfTokenCookie :: CookieSettings -> SetCookie

93+noXsrfTokenCookie cookieSettings =

94+ applyCookieSettings cookieSettings $ def{ setCookieName = "NO-XSRF-TOKEN", setCookieValue = "" }

95+

96+applyCookieSettings :: CookieSettings -> SetCookie -> SetCookie

97+applyCookieSettings cookieSettings setCookie = setCookie

98+ { setCookieMaxAge = cookieMaxAge cookieSettings

99+ , setCookieExpires = cookieExpires cookieSettings

100+ , setCookiePath = cookiePath cookieSettings

101+ , setCookieDomain = cookieDomain cookieSettings

102+ , setCookieSecure = case cookieIsSecure cookieSettings of

103+ Secure -> True

104+ NotSecure -> False

105+ }

106+

107+applyXsrfCookieSettings :: XsrfCookieSettings -> SetCookie -> SetCookie

108+applyXsrfCookieSettings xsrfCookieSettings setCookie = setCookie

109+ { setCookieName = xsrfCookieName xsrfCookieSettings

110+ , setCookiePath = xsrfCookiePath xsrfCookieSettings

111+ , setCookieHttpOnly = False

112+ }

113+

114+applySessionCookieSettings :: CookieSettings -> SetCookie -> SetCookie

115+applySessionCookieSettings cookieSettings setCookie = setCookie

116+ { setCookieName = sessionCookieName cookieSettings

117+ , setCookieSameSite = case cookieSameSite cookieSettings of

118+ AnySite -> anySite

119+ SameSiteStrict -> Just sameSiteStrict

120+ SameSiteLax -> Just sameSiteLax

121+ , setCookieHttpOnly = True

122+ }

123+ where

124+#if MIN_VERSION_cookie(0,4,5)

125+ anySite = Just sameSiteNone

126+#else

127+ anySite = Nothing

128+#endif

129+

130+-- | For a JWT-serializable session, returns a function that decorates a

131+-- provided response object with XSRF and session cookies. This should be used

132+-- when a user successfully authenticates with credentials.

133+acceptLogin :: ( ToJWT session

134+ , AddHeader "Set-Cookie" SetCookie response withOneCookie

135+ , AddHeader "Set-Cookie" SetCookie withOneCookie withTwoCookies )

136+ => CookieSettings

137+ -> JWTSettings

138+ -> session

139+ -> IO (Maybe (response -> withTwoCookies))

140+acceptLogin cookieSettings jwtSettings session = do

141+ mSessionCookie <- makeSessionCookie cookieSettings jwtSettings session

142+ case mSessionCookie of

143+ Nothing -> pure Nothing

144+ Just sessionCookie -> do

145+ xsrfCookie <- makeXsrfCookie cookieSettings

146+ return $ Just $ addHeader sessionCookie . addHeader xsrfCookie

147+

148+-- | Arbitrary cookie expiry time set back in history after unix time 0

149+expireTime :: UTCTime

150+expireTime = UTCTime (ModifiedJulianDay 50000) 0

151+

152+-- | Adds headers to a response that clears all session cookies

153+-- | using max-age and expires cookie attributes.

154+clearSession :: ( AddHeader "Set-Cookie" SetCookie response withOneCookie

155+ , AddHeader "Set-Cookie" SetCookie withOneCookie withTwoCookies )

156+ => CookieSettings

157+ -> response

158+ -> withTwoCookies

159+clearSession cookieSettings = addHeader clearedSessionCookie . addHeader clearedXsrfCookie

160+ where

161+ -- According to RFC6265 max-age takes precedence, but IE/Edge ignore it completely so we set both

162+ cookieSettingsExpires = cookieSettings

163+ { cookieExpires = Just expireTime

164+ , cookieMaxAge = Just (secondsToDiffTime 0)

165+ }

166+ clearedSessionCookie = applySessionCookieSettings cookieSettingsExpires $ applyCookieSettings cookieSettingsExpires def

167+ clearedXsrfCookie = case cookieXsrfSetting cookieSettings of

168+ Just xsrfCookieSettings -> applyXsrfCookieSettings xsrfCookieSettings $ applyCookieSettings cookieSettingsExpires def

169+ Nothing -> noXsrfTokenCookie cookieSettingsExpires

170+

171+makeSessionCookieBS :: ToJWT v => CookieSettings -> JWTSettings -> v -> IO (Maybe BS.ByteString)

172+makeSessionCookieBS a b c = fmap (toByteString . renderSetCookie) <$> makeSessionCookie a b c

173+

174+-- | Alias for 'makeSessionCookie'.

175+makeCookie :: ToJWT v => CookieSettings -> JWTSettings -> v -> IO (Maybe SetCookie)

176+makeCookie = makeSessionCookie

177+{-# DEPRECATED makeCookie "Use makeSessionCookie instead" #-}

178+

179+-- | Alias for 'makeSessionCookieBS'.

180+makeCookieBS :: ToJWT v => CookieSettings -> JWTSettings -> v -> IO (Maybe BS.ByteString)

181+makeCookieBS = makeSessionCookieBS

182+{-# DEPRECATED makeCookieBS "Use makeSessionCookieBS instead" #-}

servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/FormLogin.hsnew file+3

@@ -0,0 +1,3 @@

1+module Servant.Auth.Server.Internal.FormLogin where

2+

3+

servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/JWT.hsnew file+72

@@ -0,0 +1,72 @@

1+module Servant.Auth.Server.Internal.JWT where

2+

3+import Control.Lens

4+import Control.Monad.Except

5+import Control.Monad.Reader

6+import qualified Crypto.JOSE as Jose

7+import qualified Crypto.JWT as Jose

8+import Data.Aeson (FromJSON, Result (..), ToJSON, fromJSON,

9+ toJSON)

10+import Data.ByteArray (constEq)

11+import qualified Data.ByteString as BS

12+import qualified Data.ByteString.Lazy as BSL

13+import qualified Data.HashMap.Strict as HM

14+import Data.Maybe (fromMaybe)

15+import qualified Data.Text as T

16+import Data.Time (UTCTime)

17+import Network.Wai (requestHeaders)

18+

19+import Servant.Auth.JWT (FromJWT(..), ToJWT(..))

20+import Servant.Auth.Server.Internal.ConfigTypes

21+import Servant.Auth.Server.Internal.Types

22+

23+

24+-- | A JWT @AuthCheck@. You likely won't need to use this directly unless you

25+-- are protecting a @Raw@ endpoint.

26+jwtAuthCheck :: FromJWT usr => JWTSettings -> AuthCheck usr

27+jwtAuthCheck jwtSettings = do

28+ req <- ask

29+ token <- maybe mempty return $ do

30+ authHdr <- lookup "Authorization" $ requestHeaders req

31+ let bearer = "Bearer "

32+ (mbearer, rest) = BS.splitAt (BS.length bearer) authHdr

33+ guard (mbearer `constEq` bearer)

34+ return rest

35+ verifiedJWT <- liftIO $ verifyJWT jwtSettings token

36+ case verifiedJWT of

37+ Nothing -> mzero

38+ Just v -> return v

39+

40+-- | Creates a JWT containing the specified data. The data is stored in the

41+-- @dat@ claim. The 'Maybe UTCTime' argument indicates the time at which the

42+-- token expires.

43+makeJWT :: ToJWT a

44+ => a -> JWTSettings -> Maybe UTCTime -> IO (Either Jose.Error BSL.ByteString)

45+makeJWT v cfg expiry = runExceptT $ do

46+ bestAlg <- Jose.bestJWSAlg $ signingKey cfg

47+ let alg = fromMaybe bestAlg $ jwtAlg cfg

48+ ejwt <- Jose.signClaims (signingKey cfg)

49+ (Jose.newJWSHeader ((), alg))

50+ (addExp $ encodeJWT v)

51+

52+ return $ Jose.encodeCompact ejwt

53+ where

54+ addExp claims = case expiry of

55+ Nothing -> claims

56+ Just e -> claims & Jose.claimExp ?~ Jose.NumericDate e

57+

58+

59+verifyJWT :: FromJWT a => JWTSettings -> BS.ByteString -> IO (Maybe a)

60+verifyJWT jwtCfg input = do

61+ keys <- validationKeys jwtCfg

62+ verifiedJWT <- runExceptT $ do

63+ unverifiedJWT <- Jose.decodeCompact (BSL.fromStrict input)

64+ Jose.verifyClaims

65+ (jwtSettingsToJwtValidationSettings jwtCfg)

66+ keys

67+ unverifiedJWT

68+ return $ case verifiedJWT of

69+ Left (_ :: Jose.JWTError) -> Nothing

70+ Right v -> case decodeJWT v of

71+ Left _ -> Nothing

72+ Right v' -> Just v'

servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/ThrowAll.hsnew file+58

@@ -0,0 +1,58 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE UndecidableInstances #-}

3+module Servant.Auth.Server.Internal.ThrowAll where

4+

5+#if !MIN_VERSION_servant_server(0,16,0)

6+#define ServerError ServantErr

7+#endif

8+

9+import Control.Monad.Error.Class

10+import Data.Tagged (Tagged (..))

11+import Servant ((:<|>) (..), ServerError(..), NamedRoutes(..))

12+import Servant.API.Generic

13+import Servant.Server.Generic

14+import Servant.Server

15+import Network.HTTP.Types

16+import Network.Wai

17+

18+import qualified Data.ByteString.Char8 as BS

19+

20+class ThrowAll a where

21+ -- | 'throwAll' is a convenience function to throw errors across an entire

22+ -- sub-API

23+ --

24+ --

25+ -- > throwAll err400 :: Handler a :<|> Handler b :<|> Handler c

26+ -- > == throwError err400 :<|> throwError err400 :<|> err400

27+ throwAll :: ServerError -> a

28+

29+instance (ThrowAll a, ThrowAll b) => ThrowAll (a :<|> b) where

30+ throwAll e = throwAll e :<|> throwAll e

31+

32+instance

33+ ( ThrowAll (ToServant api (AsServerT m)) , GenericServant api (AsServerT m)) =>

34+ ThrowAll (api (AsServerT m)) where

35+

36+ throwAll = fromServant . throwAll

37+

38+-- Really this shouldn't be necessary - ((->) a) should be an instance of

39+-- MonadError, no?

40+instance {-# OVERLAPPING #-} ThrowAll b => ThrowAll (a -> b) where

41+ throwAll e = const $ throwAll e

42+

43+instance {-# OVERLAPPABLE #-} (MonadError ServerError m) => ThrowAll (m a) where

44+ throwAll = throwError

45+

46+-- | for @servant <0.11@

47+instance {-# OVERLAPPING #-} ThrowAll Application where

48+ throwAll e _req respond

49+ = respond $ responseLBS (mkStatus (errHTTPCode e) (BS.pack $ errReasonPhrase e))

50+ (errHeaders e)

51+ (errBody e)

52+

53+-- | for @servant >=0.11@

54+instance {-# OVERLAPPING #-} MonadError ServerError m => ThrowAll (Tagged m Application) where

55+ throwAll e = Tagged $ \_req respond ->

56+ respond $ responseLBS (mkStatus (errHTTPCode e) (BS.pack $ errReasonPhrase e))

57+ (errHeaders e)

58+ (errBody e)

servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/Types.hsnew file+112

@@ -0,0 +1,112 @@

1+{-# LANGUAGE CPP #-}

2+module Servant.Auth.Server.Internal.Types where

3+

4+import Control.Applicative

5+import Control.Monad.Reader

6+import Control.Monad.Time

7+import Data.Monoid (Monoid (..))

8+import Data.Semigroup (Semigroup (..))

9+import Data.Time (getCurrentTime)

10+import GHC.Generics (Generic)

11+import Network.Wai (Request)

12+

13+import qualified Control.Monad.Fail as Fail

14+

15+-- | The result of an authentication attempt.

16+data AuthResult val

17+ = BadPassword

18+ | NoSuchUser

19+ -- | Authentication succeeded.

20+ | Authenticated val

21+ -- | If an authentication procedure cannot be carried out - if for example it

22+ -- expects a password and username in a header that is not present -

23+ -- @Indefinite@ is returned. This indicates that other authentication

24+ -- methods should be tried.

25+ | Indefinite

26+ deriving (Eq, Show, Read, Generic, Ord, Functor, Traversable, Foldable)

27+

28+instance Semigroup (AuthResult val) where

29+ Indefinite <> y = y

30+ x <> _ = x

31+

32+instance Monoid (AuthResult val) where

33+ mempty = Indefinite

34+ mappend = (<>)

35+

36+instance Applicative AuthResult where

37+ pure = return

38+ (<*>) = ap

39+

40+instance Monad AuthResult where

41+ return = Authenticated

42+ Authenticated v >>= f = f v

43+ BadPassword >>= _ = BadPassword

44+ NoSuchUser >>= _ = NoSuchUser

45+ Indefinite >>= _ = Indefinite

46+

47+instance Alternative AuthResult where

48+ empty = mzero

49+ (<|>) = mplus

50+

51+instance MonadPlus AuthResult where

52+ mzero = mempty

53+ mplus = (<>)

54+

55+

56+-- | An @AuthCheck@ is the function used to decide the authentication status

57+-- (the 'AuthResult') of a request. Different @AuthCheck@s may be combined as a

58+-- Monoid or Alternative; the semantics of this is that the *first*

59+-- non-'Indefinite' result from left to right is used and the rest are ignored.

60+newtype AuthCheck val = AuthCheck

61+ { runAuthCheck :: Request -> IO (AuthResult val) }

62+ deriving (Generic, Functor)

63+

64+instance Semigroup (AuthCheck val) where

65+ AuthCheck f <> AuthCheck g = AuthCheck $ \x -> do

66+ fx <- f x

67+ case fx of

68+ Indefinite -> g x

69+ r -> pure r

70+

71+instance Monoid (AuthCheck val) where

72+ mempty = AuthCheck $ const $ return mempty

73+ mappend = (<>)

74+

75+instance Applicative AuthCheck where

76+ pure = return

77+ (<*>) = ap

78+

79+instance Monad AuthCheck where

80+ return = AuthCheck . return . return . return

81+ AuthCheck ac >>= f = AuthCheck $ \req -> do

82+ aresult <- ac req

83+ case aresult of

84+ Authenticated usr -> runAuthCheck (f usr) req

85+ BadPassword -> return BadPassword

86+ NoSuchUser -> return NoSuchUser

87+ Indefinite -> return Indefinite

88+

89+#if !MIN_VERSION_base(4,13,0)

90+ fail = Fail.fail

91+#endif

92+

93+instance Fail.MonadFail AuthCheck where

94+ fail _ = AuthCheck . const $ return Indefinite

95+

96+instance MonadReader Request AuthCheck where

97+ ask = AuthCheck $ \x -> return (Authenticated x)

98+ local f (AuthCheck check) = AuthCheck $ \req -> check (f req)

99+

100+instance MonadIO AuthCheck where

101+ liftIO action = AuthCheck $ const $ Authenticated <$> action

102+

103+instance MonadTime AuthCheck where

104+ currentTime = liftIO getCurrentTime

105+

106+instance Alternative AuthCheck where

107+ empty = mzero

108+ (<|>) = mplus

109+

110+instance MonadPlus AuthCheck where

111+ mzero = mempty

112+ mplus = (<>)

servant-auth/servant-auth-server/src/Servant/Auth/Server/SetCookieOrphan.hsnew file+3

@@ -0,0 +1,3 @@

1+module Servant.Auth.Server.SetCookieOrphan

2+ {-# DEPRECATED "instance exists in http-api-data-0.3.9. This module will be removed in next major release." #-}

3+ () where

servant-auth/servant-auth-server/test/Servant/Auth/ServerSpec.hsnew file+607

@@ -0,0 +1,607 @@

1+{-# LANGUAGE CPP #-}

2+module Servant.Auth.ServerSpec (spec) where

3+

4+#if !MIN_VERSION_servant_server(0,16,0)

5+#define ServerError ServantErr

6+#endif

7+

8+import Control.Lens

9+import Control.Monad.Except (runExceptT)

10+import Control.Monad.IO.Class (liftIO)

11+import Crypto.JOSE (Alg (HS256, None), Error,

12+ JWK, JWSHeader,

13+ KeyMaterialGenParam (OctGenParam),

14+ ToCompact, encodeCompact,

15+ genJWK, newJWSHeader)

16+import Crypto.JWT (Audience (..), ClaimsSet,

17+ NumericDate (NumericDate),

18+ SignedJWT,

19+ claimAud, claimNbf,

20+ signClaims,

21+ emptyClaimsSet,

22+ unregisteredClaims)

23+import Data.Aeson (FromJSON, ToJSON, Value,

24+ toJSON, encode)

25+import Data.Aeson.Lens (_JSON)

26+import qualified Data.ByteString as BS

27+import qualified Data.ByteString.Lazy as BSL

28+import Data.CaseInsensitive (mk)

29+import Data.Foldable (find)

30+import Data.Monoid

31+import Data.Time

32+import Data.Time.Clock (getCurrentTime)

33+import GHC.Generics (Generic)

34+import Network.HTTP.Client (cookie_http_only,

35+ cookie_name, cookie_value,

36+ cookie_expiry_time,

37+ destroyCookieJar)

38+import Network.HTTP.Types (Status, status200,

39+ status401)

40+import Network.Wai (responseLBS)

41+import Network.Wai.Handler.Warp (testWithApplication)

42+import Network.Wreq (Options, auth, basicAuth,

43+ cookieExpiryTime, cookies,

44+ defaults, get, getWith, postWith,

45+ header, oauth2Bearer,

46+ responseBody,

47+ responseCookieJar,

48+ responseHeader,

49+ responseStatus)

50+import Network.Wreq.Types (Postable(..))

51+import Servant hiding (BasicAuth,

52+ IsSecure (..), header)

53+import Servant.API.Generic ((:-))

54+import Servant.Auth.Server

55+import Servant.Auth.Server.Internal.Cookie (expireTime)

56+import Servant.Auth.Server.SetCookieOrphan ()

57+#if MIN_VERSION_servant_server(0,15,0)

58+import qualified Servant.Types.SourceT as S

59+#endif

60+import System.IO.Unsafe (unsafePerformIO)

61+import Test.Hspec

62+import Test.QuickCheck

63+import qualified Network.HTTP.Client as HCli

64+

65+

66+

67+spec :: Spec

68+spec = do

69+ authSpec

70+ cookieAuthSpec

71+ jwtAuthSpec

72+ throwAllSpec

73+ basicAuthSpec

74+

75+------------------------------------------------------------------------------

76+-- * Auth {{{

77+

78+authSpec :: Spec

79+authSpec

80+ = describe "The Auth combinator"

81+ $ around (testWithApplication . return $ app jwtAndCookieApi) $ do

82+

83+ it "returns a 401 if all authentications are Indefinite" $ \port -> do

84+ get (url port) `shouldHTTPErrorWith` status401

85+

86+ it "succeeds if one authentication suceeds" $ \port -> property $

87+ \(user :: User) -> do

88+ jwt <- makeJWT user jwtCfg Nothing

89+ opts <- addJwtToHeader jwt

90+ resp <- getWith opts (url port)

91+ resp ^? responseBody . _JSON `shouldBe` Just (length $ name user)

92+

93+ it "fails (403) if one authentication fails" $ const $

94+ pendingWith "Authentications don't yet fail, only are Indefinite"

95+

96+ it "doesn't clobber pre-existing response headers" $ \port -> property $

97+ \(user :: User) -> do

98+ jwt <- makeJWT user jwtCfg Nothing

99+ opts <- addJwtToHeader jwt

100+ resp <- getWith opts (url port ++ "/header")

101+ resp ^. responseHeader "Blah" `shouldBe` "1797"

102+ resp ^. responseHeader "Set-Cookie" `shouldSatisfy` (/= "")

103+

104+ context "Raw" $ do

105+

106+ it "gets the response body" $ \port -> property $ \(user :: User) -> do

107+ jwt <- makeJWT user jwtCfg Nothing

108+ opts <- addJwtToHeader jwt

109+ resp <- getWith opts (url port ++ "/raw")

110+ resp ^. responseBody `shouldBe` "how are you?"

111+

112+ it "doesn't clobber pre-existing reponse headers" $ \port -> property $

113+ \(user :: User) -> do

114+ jwt <- makeJWT user jwtCfg Nothing

115+ opts <- addJwtToHeader jwt

116+ resp <- getWith opts (url port ++ "/raw")

117+ resp ^. responseHeader "hi" `shouldBe` "there"

118+ resp ^. responseHeader "Set-Cookie" `shouldSatisfy` (/= "")

119+

120+

121+ context "Setting cookies" $ do

122+

123+ it "sets cookies that it itself accepts" $ \port -> property $ \user -> do

124+ jwt <- createJWT theKey (newJWSHeader ((), HS256))

125+ (claims $ toJSON user)

126+ opts' <- addJwtToCookie cookieCfg jwt

127+ let opts = addCookie (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"])

128+ (xsrfField xsrfCookieName cookieCfg <> "=blah")

129+ resp <- getWith opts (url port)

130+ let (cookieJar:_) = resp ^.. responseCookieJar

131+ Just xxsrf = find (\x -> cookie_name x == xsrfField xsrfCookieName cookieCfg)

132+ $ destroyCookieJar cookieJar

133+ opts2 = defaults

134+ & cookies .~ Just cookieJar

135+ & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ [cookie_value xxsrf]

136+ resp2 <- getWith opts2 (url port)

137+ resp2 ^? responseBody . _JSON `shouldBe` Just (length $ name user)

138+

139+ it "uses the Expiry from the configuration" $ \port -> property $ \(user :: User) -> do

140+ jwt <- createJWT theKey (newJWSHeader ((), HS256))

141+ (claims $ toJSON user)

142+ opts' <- addJwtToCookie cookieCfg jwt

143+ let opts = addCookie (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"])

144+ (xsrfField xsrfCookieName cookieCfg <> "=blah")

145+ resp <- getWith opts (url port)

146+ let (cookieJar:_) = resp ^.. responseCookieJar

147+ Just xxsrf = find (\x -> cookie_name x == xsrfField xsrfCookieName cookieCfg)

148+ $ destroyCookieJar cookieJar

149+ xxsrf ^. cookieExpiryTime `shouldBe` future

150+

151+ it "sets the token cookie as HttpOnly" $ \port -> property $ \(user :: User) -> do

152+ jwt <- createJWT theKey (newJWSHeader ((), HS256))

153+ (claims $ toJSON user)

154+ opts' <- addJwtToCookie cookieCfg jwt

155+ let opts = addCookie (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"])

156+ (xsrfField xsrfCookieName cookieCfg <> "=blah")

157+ resp <- getWith opts (url port)

158+ let (cookieJar:_) = resp ^.. responseCookieJar

159+ Just token = find (\x -> cookie_name x == sessionCookieName cookieCfg)

160+ $ destroyCookieJar cookieJar

161+ cookie_http_only token `shouldBe` True

162+

163+

164+

165+-- }}}

166+------------------------------------------------------------------------------

167+-- * Cookie Auth {{{

168+

169+cookieAuthSpec :: Spec

170+cookieAuthSpec

171+ = describe "The Auth combinator" $ do

172+ describe "With XSRF check" $

173+ around (testWithApplication . return $ app cookieOnlyApi) $ do

174+

175+ it "fails if XSRF header and cookie don't match" $ \port -> property

176+ $ \(user :: User) -> do

177+ jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)

178+ opts' <- addJwtToCookie cookieCfg jwt

179+ let opts = addCookie (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"])

180+ (xsrfField xsrfCookieName cookieCfg <> "=blerg")

181+ getWith opts (url port) `shouldHTTPErrorWith` status401

182+

183+ it "fails with no XSRF header or cookie" $ \port -> property

184+ $ \(user :: User) -> do

185+ jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)

186+ opts <- addJwtToCookie cookieCfg jwt

187+ getWith opts (url port) `shouldHTTPErrorWith` status401

188+

189+ it "succeeds if XSRF header and cookie match, and JWT is valid" $ \port -> property

190+ $ \(user :: User) -> do

191+ jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)

192+ opts' <- addJwtToCookie cookieCfg jwt

193+ let opts = addCookie (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"])

194+ (xsrfField xsrfCookieName cookieCfg <> "=blah")

195+ resp <- getWith opts (url port)

196+ resp ^? responseBody . _JSON `shouldBe` Just (length $ name user)

197+

198+ it "sets and clears the right cookies" $ \port -> property

199+ $ \(user :: User) -> do

200+ let optsFromResp resp =

201+ let jar = resp ^. responseCookieJar

202+ Just xsrfCookieValue = cookie_value <$> find (\c -> cookie_name c == xsrfField xsrfCookieName cookieCfg) (destroyCookieJar jar)

203+ in defaults

204+ & cookies .~ Just jar -- real cookie jars aren't updated by being replaced

205+ & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ [xsrfCookieValue]

206+

207+ resp <- postWith defaults (url port ++ "/login") user

208+ (resp ^. responseCookieJar) `shouldMatchCookieNames`

209+ [ sessionCookieName cookieCfg

210+ , xsrfField xsrfCookieName cookieCfg

211+ ]

212+ let loggedInOpts = optsFromResp resp

213+

214+ resp <- getWith loggedInOpts (url port)

215+ resp ^? responseBody . _JSON `shouldBe` Just (length $ name user)

216+

217+ -- logout

218+ resp <- getWith loggedInOpts (url port ++ "/logout")

219+

220+ -- assert cookies were expired

221+ now <- getCurrentTime

222+ let assertCookie c = now >= cookie_expiry_time c

223+ all assertCookie (destroyCookieJar (resp ^. responseCookieJar)) `shouldBe` True

224+

225+ let loggedOutOpts = optsFromResp resp

226+ getWith loggedOutOpts (url port) `shouldHTTPErrorWith` status401

227+

228+ describe "With no XSRF check for GET requests" $ let

229+ noXsrfGet xsrfCfg = xsrfCfg { xsrfExcludeGet = True }

230+ cookieCfgNoXsrfGet = cookieCfg { cookieXsrfSetting = fmap noXsrfGet $ cookieXsrfSetting cookieCfg }

231+ in around (testWithApplication . return $ appWithCookie cookieOnlyApi cookieCfgNoXsrfGet) $ do

232+

233+ it "succeeds with no XSRF header or cookie for GET" $ \port -> property

234+ $ \(user :: User) -> do

235+ jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)

236+ opts <- addJwtToCookie cookieCfgNoXsrfGet jwt

237+ resp <- getWith opts (url port)

238+ resp ^? responseBody . _JSON `shouldBe` Just (length $ name user)

239+

240+ it "fails with no XSRF header or cookie for POST" $ \port -> property

241+ $ \(user :: User) number -> do

242+ jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)

243+ opts <- addJwtToCookie cookieCfgNoXsrfGet jwt

244+ postWith opts (url port) (toJSON (number :: Int)) `shouldHTTPErrorWith` status401

245+

246+ describe "With no XSRF check at all" $ let

247+ cookieCfgNoXsrf = cookieCfg { cookieXsrfSetting = Nothing }

248+ in around (testWithApplication . return $ appWithCookie cookieOnlyApi cookieCfgNoXsrf) $ do

249+

250+ it "succeeds with no XSRF header or cookie for GET" $ \port -> property

251+ $ \(user :: User) -> do

252+ jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)

253+ opts <- addJwtToCookie cookieCfgNoXsrf jwt

254+ resp <- getWith opts (url port)

255+ resp ^? responseBody . _JSON `shouldBe` Just (length $ name user)

256+

257+ it "succeeds with no XSRF header or cookie for POST" $ \port -> property

258+ $ \(user :: User) number -> do

259+ jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)

260+ opts <- addJwtToCookie cookieCfgNoXsrf jwt

261+ resp <- postWith opts (url port) $ toJSON (number :: Int)

262+ resp ^? responseBody . _JSON `shouldBe` Just number

263+

264+ it "sets and clears the right cookies" $ \port -> property

265+ $ \(user :: User) -> do

266+ let optsFromResp resp = defaults

267+ & cookies .~ Just (resp ^. responseCookieJar) -- real cookie jars aren't updated by being replaced

268+

269+ resp <- postWith defaults (url port ++ "/login") user

270+ (resp ^. responseCookieJar) `shouldMatchCookieNames`

271+ [ sessionCookieName cookieCfg

272+ , "NO-XSRF-TOKEN"

273+ ]

274+ let loggedInOpts = optsFromResp resp

275+

276+ resp <- getWith (loggedInOpts) (url port)

277+ resp ^? responseBody . _JSON `shouldBe` Just (length $ name user)

278+

279+ resp <- getWith loggedInOpts (url port ++ "/logout")

280+ (resp ^. responseCookieJar) `shouldMatchCookieNameValues`

281+ [ (sessionCookieName cookieCfg, "value")

282+ , ("NO-XSRF-TOKEN", "")

283+ ]

284+

285+ -- assert cookies were expired

286+ now <- getCurrentTime

287+ let assertCookie c = now >= cookie_expiry_time c

288+ all assertCookie (destroyCookieJar (resp ^. responseCookieJar)) `shouldBe` True

289+

290+ let loggedOutOpts = optsFromResp resp

291+

292+ getWith loggedOutOpts (url port) `shouldHTTPErrorWith` status401

293+

294+-- }}}

295+------------------------------------------------------------------------------

296+-- * JWT Auth {{{

297+

298+jwtAuthSpec :: Spec

299+jwtAuthSpec

300+ = describe "The JWT combinator"

301+ $ around (testWithApplication . return $ app jwtOnlyApi) $ do

302+

303+ it "fails if 'aud' does not match predicate" $ \port -> property $

304+ \(user :: User) -> do

305+ jwt <- createJWT theKey (newJWSHeader ((), HS256))

306+ (claims (toJSON user) & claimAud .~ Just (Audience ["boo"]))

307+ opts <- addJwtToHeader (jwt >>= (return . encodeCompact))

308+ getWith opts (url port) `shouldHTTPErrorWith` status401

309+

310+ it "succeeds if 'aud' does match predicate" $ \port -> property $

311+ \(user :: User) -> do

312+ jwt <- createJWT theKey (newJWSHeader ((), HS256))

313+ (claims (toJSON user) & claimAud .~ Just (Audience ["anythingElse"]))

314+ opts <- addJwtToHeader (jwt >>= (return . encodeCompact))

315+ resp <- getWith opts (url port)

316+ resp ^. responseStatus `shouldBe` status200

317+

318+ it "fails if 'nbf' is set to a future date" $ \port -> property $

319+ \(user :: User) -> do

320+ jwt <- createJWT theKey (newJWSHeader ((), HS256))

321+ (claims (toJSON user) & claimNbf .~ Just (NumericDate future))

322+ opts <- addJwtToHeader (jwt >>= (return . encodeCompact))

323+ getWith opts (url port) `shouldHTTPErrorWith` status401

324+

325+ it "fails if 'exp' is set to a past date" $ \port -> property $

326+ \(user :: User) -> do

327+ jwt <- makeJWT user jwtCfg (Just past)

328+ opts <- addJwtToHeader jwt

329+ getWith opts (url port) `shouldHTTPErrorWith` status401

330+

331+ it "succeeds if 'exp' is set to a future date" $ \port -> property $

332+ \(user :: User) -> do

333+ jwt <- makeJWT user jwtCfg (Just future)

334+ opts <- addJwtToHeader jwt

335+ resp <- getWith opts (url port)

336+ resp ^. responseStatus `shouldBe` status200

337+

338+ it "fails if JWT is not signed" $ \port -> property $ \(user :: User) -> do

339+ jwt <- createJWT theKey (newJWSHeader ((), None))

340+ (claims $ toJSON user)

341+ opts <- addJwtToHeader (jwt >>= (return . encodeCompact))

342+ getWith opts (url port) `shouldHTTPErrorWith` status401

343+

344+ it "fails if JWT does not use expected algorithm" $ const $

345+ pendingWith "Need https://github.com/frasertweedale/hs-jose/issues/19"

346+

347+ it "fails if data is not valid JSON" $ \port -> do

348+ jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims "{{")

349+ opts <- addJwtToHeader (jwt >>= (return .encodeCompact))

350+ getWith opts (url port) `shouldHTTPErrorWith` status401

351+

352+ it "suceeds as wreq's oauth2Bearer" $ \port -> property $ \(user :: User) -> do

353+ jwt <- createJWT theKey (newJWSHeader ((), HS256))

354+ (claims $ toJSON user)

355+ resp <- case jwt >>= (return . encodeCompact) of

356+ Left (e :: Error) -> fail $ show e

357+ Right v -> getWith (defaults & auth ?~ oauth2Bearer (BSL.toStrict v)) (url port)

358+ resp ^. responseStatus `shouldBe` status200

359+

360+-- }}}

361+------------------------------------------------------------------------------

362+-- * Basic Auth {{{

363+

364+basicAuthSpec :: Spec

365+basicAuthSpec = describe "The BasicAuth combinator"

366+ $ around (testWithApplication . return $ app basicAuthApi) $ do

367+

368+ it "succeeds with the correct password and username" $ \port -> do

369+ resp <- getWith (defaults & auth ?~ basicAuth "ali" "Open sesame") (url port)

370+ resp ^. responseStatus `shouldBe` status200

371+

372+ it "fails with non-existent user" $ \port -> do

373+ getWith (defaults & auth ?~ basicAuth "thief" "Open sesame") (url port)

374+ `shouldHTTPErrorWith` status401

375+

376+ it "fails with incorrect password" $ \port -> do

377+ getWith (defaults & auth ?~ basicAuth "ali" "phatic") (url port)

378+ `shouldHTTPErrorWith` status401

379+

380+ it "fails with no auth header" $ \port -> do

381+ get (url port) `shouldHTTPErrorWith` status401

382+

383+-- }}}

384+------------------------------------------------------------------------------

385+-- * ThrowAll {{{

386+

387+throwAllSpec :: Spec

388+throwAllSpec = describe "throwAll" $ do

389+

390+ it "works for plain values" $ do

391+ let t :: Either ServerError Int :<|> Either ServerError Bool :<|> Either ServerError String

392+ t = throwAll err401

393+ t `shouldBe` throwError err401 :<|> throwError err401 :<|> throwError err401

394+

395+ it "works for function types" $ property $ \i -> do

396+ let t :: Int -> (Either ServerError Bool :<|> Either ServerError String)

397+ t = throwAll err401

398+ expected _ = throwError err401 :<|> throwError err401

399+ t i `shouldBe` expected i

400+

401+-- }}}

402+------------------------------------------------------------------------------

403+-- * API and Server {{{

404+

405+type API auths

406+ = Auth auths User :>

407+ ( Get '[JSON] Int

408+ :<|> ReqBody '[JSON] Int :> Post '[JSON] Int

409+ :<|> NamedRoutes DummyRoutes

410+ :<|> "header" :> Get '[JSON] (Headers '[Header "Blah" Int] Int)

411+#if MIN_VERSION_servant_server(0,15,0)

412+ :<|> "stream" :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString)

413+#endif

414+ :<|> "raw" :> Raw

415+ )

416+ :<|> "login" :> ReqBody '[JSON] User :> Post '[JSON] (Headers '[ Header "Set-Cookie" SetCookie

417+ , Header "Set-Cookie" SetCookie ] NoContent)

418+ :<|> "logout" :> Get '[JSON] (Headers '[ Header "Set-Cookie" SetCookie

419+ , Header "Set-Cookie" SetCookie ] NoContent)

420+

421+data DummyRoutes mode = DummyRoutes

422+ { dummyInt :: mode :- "dummy" :> Get '[JSON] Int

423+ } deriving Generic

424+

425+jwtOnlyApi :: Proxy (API '[Servant.Auth.Server.JWT])

426+jwtOnlyApi = Proxy

427+

428+cookieOnlyApi :: Proxy (API '[Cookie])

429+cookieOnlyApi = Proxy

430+

431+basicAuthApi :: Proxy (API '[BasicAuth])

432+basicAuthApi = Proxy

433+

434+jwtAndCookieApi :: Proxy (API '[Servant.Auth.Server.JWT, Cookie])

435+jwtAndCookieApi = Proxy

436+

437+theKey :: JWK

438+theKey = unsafePerformIO . genJWK $ OctGenParam 256

439+{-# NOINLINE theKey #-}

440+

441+

442+cookieCfg :: CookieSettings

443+cookieCfg = def

444+ { cookieExpires = Just future

445+ , cookieIsSecure = NotSecure

446+ , sessionCookieName = "RuncibleSpoon"

447+ , cookieXsrfSetting = pure $ def

448+ { xsrfCookieName = "TheyDinedOnMince"

449+ , xsrfHeaderName = "AndSlicesOfQuince"

450+ }

451+ }

452+xsrfField :: (XsrfCookieSettings -> a) -> CookieSettings -> a

453+xsrfField f = maybe (error "expected XsrfCookieSettings for test") f . cookieXsrfSetting

454+

455+jwtCfg :: JWTSettings

456+jwtCfg = (defaultJWTSettings theKey) { audienceMatches = \x ->

457+ if x == "boo" then DoesNotMatch else Matches }

458+

459+instance FromBasicAuthData User where

460+ fromBasicAuthData (BasicAuthData usr pwd) _

461+ = return $ if usr == "ali" && pwd == "Open sesame"

462+ then Authenticated $ User "ali" "ali@the-thieves-den.com"

463+ else Indefinite

464+

465+-- Could be anything, really, but since this is already in the cfg we don't

466+-- have to add it

467+type instance BasicAuthCfg = JWK

468+

469+appWithCookie :: AreAuths auths '[CookieSettings, JWTSettings, JWK] User

470+ => Proxy (API auths) -> CookieSettings -> Application

471+appWithCookie api ccfg = serveWithContext api ctx $ server ccfg

472+ where

473+ ctx = ccfg :. jwtCfg :. theKey :. EmptyContext

474+

475+-- | Takes a proxy parameter indicating which authentication systems to enable.

476+app :: AreAuths auths '[CookieSettings, JWTSettings, JWK] User

477+ => Proxy (API auths) -> Application

478+app api = appWithCookie api cookieCfg

479+

480+server :: CookieSettings -> Server (API auths)

481+server ccfg =

482+ (\authResult -> case authResult of

483+ Authenticated usr -> getInt usr

484+ :<|> postInt usr

485+ :<|> DummyRoutes { dummyInt = getInt usr }

486+ :<|> getHeaderInt

487+#if MIN_VERSION_servant_server(0,15,0)

488+ :<|> return (S.source ["bytestring"])

489+#endif

490+ :<|> raw

491+ Indefinite -> throwAll err401

492+ _ -> throwAll err403

493+ )

494+ :<|> getLogin

495+ :<|> getLogout

496+ where

497+ getInt :: User -> Handler Int

498+ getInt usr = return . length $ name usr

499+

500+ postInt :: User -> Int -> Handler Int

501+ postInt _ = return

502+

503+ getHeaderInt :: Handler (Headers '[Header "Blah" Int] Int)

504+ getHeaderInt = return $ addHeader 1797 17

505+

506+ getLogin :: User -> Handler (Headers '[ Header "Set-Cookie" SetCookie

507+ , Header "Set-Cookie" SetCookie ] NoContent)

508+ getLogin user = do

509+ maybeApplyCookies <- liftIO $ acceptLogin ccfg jwtCfg user

510+ case maybeApplyCookies of

511+ Just applyCookies -> return $ applyCookies NoContent

512+ Nothing -> error "cookies failed to apply"

513+

514+ getLogout :: Handler (Headers '[ Header "Set-Cookie" SetCookie

515+ , Header "Set-Cookie" SetCookie ] NoContent)

516+ getLogout = return $ clearSession ccfg NoContent

517+

518+ raw :: Server Raw

519+ raw =

520+#if MIN_VERSION_servant_server(0,11,0)

521+ Tagged $

522+#endif

523+ \_req respond ->

524+ respond $ responseLBS status200 [("hi", "there")] "how are you?"

525+

526+-- }}}

527+------------------------------------------------------------------------------

528+-- * Utils {{{

529+

530+past :: UTCTime

531+past = parseTimeOrError True defaultTimeLocale "%Y-%m-%d" "1970-01-01"

532+

533+future :: UTCTime

534+future = parseTimeOrError True defaultTimeLocale "%Y-%m-%d" "2070-01-01"

535+

536+addJwtToHeader :: Either Error BSL.ByteString -> IO Options

537+addJwtToHeader jwt = case jwt of

538+ Left e -> fail $ show e

539+ Right v -> return

540+ $ defaults & header "Authorization" .~ ["Bearer " <> BSL.toStrict v]

541+

542+createJWT :: JWK -> JWSHeader () -> ClaimsSet -> IO (Either Error Crypto.JWT.SignedJWT)

543+createJWT k a b = runExceptT $ signClaims k a b

544+

545+addJwtToCookie :: ToCompact a => CookieSettings -> Either Error a -> IO Options

546+addJwtToCookie ccfg jwt = case jwt >>= (return . encodeCompact) of

547+ Left e -> fail $ show e

548+ Right v -> return

549+ $ defaults & header "Cookie" .~ [sessionCookieName ccfg <> "=" <> BSL.toStrict v]

550+

551+addCookie :: Options -> BS.ByteString -> Options

552+addCookie opts cookie' = opts & header "Cookie" %~ \c -> case c of

553+ [h] -> [cookie' <> "; " <> h]

554+ [] -> [cookie']

555+ _ -> error "expecting single cookie header"

556+

557+

558+shouldHTTPErrorWith :: IO a -> Status -> Expectation

559+shouldHTTPErrorWith act stat = act `shouldThrow` \e -> case e of

560+#if MIN_VERSION_http_client(0,5,0)

561+ HCli.HttpExceptionRequest _ (HCli.StatusCodeException resp _)

562+ -> HCli.responseStatus resp == stat

563+#else

564+ HCli.StatusCodeException x _ _ -> x == stat

565+#endif

566+ _ -> False

567+

568+shouldMatchCookieNames :: HCli.CookieJar -> [BS.ByteString] -> Expectation

569+shouldMatchCookieNames cj patterns

570+ = fmap cookie_name (destroyCookieJar cj)

571+ `shouldMatchList` patterns

572+

573+shouldMatchCookieNameValues :: HCli.CookieJar -> [(BS.ByteString, BS.ByteString)] -> Expectation

574+shouldMatchCookieNameValues cj patterns

575+ = fmap ((,) <$> cookie_name <*> cookie_value) (destroyCookieJar cj)

576+ `shouldMatchList` patterns

577+

578+url :: Int -> String

579+url port = "http://localhost:" <> show port

580+

581+claims :: Value -> ClaimsSet

582+claims val = emptyClaimsSet & unregisteredClaims . at "dat" .~ Just val

583+-- }}}

584+------------------------------------------------------------------------------

585+-- * Types {{{

586+

587+data User = User

588+ { name :: String

589+ , _id :: String

590+ } deriving (Eq, Show, Read, Generic)

591+

592+instance FromJWT User

593+instance ToJWT User

594+instance FromJSON User

595+instance ToJSON User

596+

597+instance Arbitrary User where

598+ arbitrary = User <$> arbitrary <*> arbitrary

599+

600+instance Postable User where

601+ postPayload user request = return $ request

602+ { HCli.requestBody = HCli.RequestBodyLBS $ encode user

603+ , HCli.requestHeaders = (mk "Content-Type", "application/json") : HCli.requestHeaders request

604+ }

605+

606+

607+-- }}}

servant-auth/servant-auth-server/test/Spec.hsnew file+1

@@ -0,0 +1 @@

1+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

servant-auth/servant-auth-swagger/.ghcinew file+1

@@ -0,0 +1 @@

1+:set -isrc -itest -idoctest/ghci-wrapper/src

servant-auth/servant-auth-swagger/CHANGELOG.mdnew file+24

@@ -0,0 +1,24 @@

1+# Changelog

2+

3+All notable changes to this project will be documented in this file.

4+

5+The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/)

6+and this project adheres to [PVP Versioning](https://pvp.haskell.org/).

7+

8+## [Unreleased]

9+

10+## [0.2.10.1] - 2020-10-06

11+

12+### Changed

13+

14+- Support GHC 8.10 @domenkozar

15+- Fix build with swagger 2.5.x @domenkozar

16+

17+## [0.2.10.0] - 2018-06-18

18+

19+### Added

20+

21+- Support for GHC 8.4 by @phadej

22+- Changelog by @domenkozar

23+- #93: Add Cookie in SwaggerSpec API by @domenkozar

24+- #42: Add dummy AllHasSecurity Cookie instance by @sordina

servant-auth/servant-auth-swagger/LICENSEnew file+31

@@ -0,0 +1,31 @@

1+Copyright Julian K. Arni (c) 2015

2+

3+All rights reserved.

4+

5+Redistribution and use in source and binary forms, with or without

6+modification, are permitted provided that the following conditions are met:

7+

8+ * Redistributions of source code must retain the above copyright

9+ notice, this list of conditions and the following disclaimer.

10+

11+ * Redistributions in binary form must reproduce the above

12+ copyright notice, this list of conditions and the following

13+ disclaimer in the documentation and/or other materials provided

14+ with the distribution.

15+

16+ * Neither the name of Julian K. Arni nor the names of other

17+ contributors may be used to endorse or promote products derived

18+ from this software without specific prior written permission.

19+

20+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS

21+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT

22+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR

23+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT

24+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,

25+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT

26+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,

27+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY

28+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT

29+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE

30+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

31+

servant-auth/servant-auth-swagger/Setup.hsnew file+2

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

1+import Distribution.Simple

2+main = defaultMain

servant-auth/servant-auth-swagger/servant-auth-swagger.cabalnew file+70

@@ -0,0 +1,70 @@

1+cabal-version: 2.2

2+name: servant-auth-swagger

3+version: 0.2.10.1

4+synopsis: servant-swagger/servant-auth compatibility

5+description: This package provides instances that allow generating swagger2 schemas from

6+ <https://hackage.haskell.org/package/servant servant>

7+ APIs that use

8+ <https://hackage.haskell.org/package/servant-auth servant-auth's> @Auth@ combinator.

9+ .

10+ For a quick overview of the usage, see the <https://github.com/haskell-servant/servant/tree/master/servant-auth#readme README>.

11+category: Web, Servant, Authentication

12+homepage: https://github.com/haskell-servant/servant/tree/master/servant-auth#readme

13+bug-reports: https://github.com/haskell-servant/servant/issues

14+author: Julian K. Arni

15+maintainer: jkarni@gmail.com

16+copyright: (c) Julian K. Arni

17+license: BSD-3-Clause

18+license-file: LICENSE

19+tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4

20+build-type: Simple

21+extra-source-files:

22+ CHANGELOG.md

23+

24+source-repository head

25+ type: git

26+ location: https://github.com/haskell-servant/servant

27+

28+library

29+ hs-source-dirs:

30+ src

31+ default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators

32+ ghc-options: -Wall

33+ build-depends:

34+ base >= 4.10 && < 4.17

35+ , text >= 1.2.3.0 && < 2.1

36+ , servant-swagger >= 1.1.5 && < 2

37+ , swagger2 >= 2.2.2 && < 3

38+ , servant >= 0.13 && < 0.20

39+ , servant-auth == 0.4.*

40+ , lens >= 4.16.1 && < 5.2

41+ exposed-modules:

42+ Servant.Auth.Swagger

43+ default-language: Haskell2010

44+

45+test-suite spec

46+ type: exitcode-stdio-1.0

47+ main-is: Spec.hs

48+ hs-source-dirs:

49+ test

50+ default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators

51+ ghc-options: -Wall

52+ build-tool-depends: hspec-discover:hspec-discover >= 2.5.5 && <2.10

53+ -- dependencies with bounds inherited from the library stanza

54+ build-depends:

55+ base

56+ , text

57+ , servant-swagger

58+ , swagger2

59+ , servant

60+ , servant-auth

61+ , lens

62+

63+ -- test dependencies

64+ build-depends:

65+ servant-auth-swagger

66+ , hspec >= 2.5.5 && < 2.10

67+ , QuickCheck >= 2.11.3 && < 2.15

68+ other-modules:

69+ Servant.Auth.SwaggerSpec

70+ default-language: Haskell2010

servant-auth/servant-auth-swagger/src/Servant/Auth/Swagger.hsnew file+87

@@ -0,0 +1,87 @@

1+{-# OPTIONS_GHC -fno-warn-orphans #-}

2+{-# LANGUAGE CPP #-}

3+module Servant.Auth.Swagger

4+ (

5+ -- | The purpose of this package is provide the instance for 'servant-auth'

6+ -- combinators needed for 'servant-swagger' documentation generation.

7+ --

8+ -- Currently only JWT and BasicAuth are supported.

9+

10+ -- * Re-export

11+ JWT

12+ , BasicAuth

13+ , Auth

14+

15+ -- * Needed to define instances of @HasSwagger@

16+ , HasSecurity (..)

17+ ) where

18+

19+import Control.Lens ((&), (<>~))

20+import Data.Proxy (Proxy (Proxy))

21+import Data.Swagger (ApiKeyLocation (..), ApiKeyParams (..),

22+ SecurityRequirement (..), SecurityScheme (..),

23+#if MIN_VERSION_swagger2(2,6,0)

24+ SecurityDefinitions(..),

25+#endif

26+ SecuritySchemeType (..), allOperations, security,

27+ securityDefinitions)

28+import GHC.Exts (fromList)

29+import Servant.API hiding (BasicAuth)

30+import Servant.Auth

31+import Servant.Swagger

32+

33+import qualified Data.Text as T

34+

35+instance (AllHasSecurity xs, HasSwagger api) => HasSwagger (Auth xs r :> api) where

36+ toSwagger _

37+ = toSwagger (Proxy :: Proxy api)

38+ & securityDefinitions <>~ mkSec (fromList secs)

39+ & allOperations.security <>~ secReqs

40+ where

41+ secs = securities (Proxy :: Proxy xs)

42+ secReqs = [ SecurityRequirement (fromList [(s,[])]) | (s,_) <- secs]

43+ mkSec =

44+#if MIN_VERSION_swagger2(2,6,0)

45+ SecurityDefinitions

46+#else

47+ id

48+#endif

49+

50+

51+class HasSecurity x where

52+ securityName :: Proxy x -> T.Text

53+ securityScheme :: Proxy x -> SecurityScheme

54+

55+instance HasSecurity BasicAuth where

56+ securityName _ = "BasicAuth"

57+ securityScheme _ = SecurityScheme type_ (Just desc)

58+ where

59+ type_ = SecuritySchemeBasic

60+ desc = "Basic access authentication"

61+

62+instance HasSecurity JWT where

63+ securityName _ = "JwtSecurity"

64+ securityScheme _ = SecurityScheme type_ (Just desc)

65+ where

66+ type_ = SecuritySchemeApiKey (ApiKeyParams "Authorization" ApiKeyHeader)

67+ desc = "JSON Web Token-based API key"

68+

69+class AllHasSecurity (x :: [*]) where

70+ securities :: Proxy x -> [(T.Text,SecurityScheme)]

71+

72+instance {-# OVERLAPPABLE #-} (HasSecurity x, AllHasSecurity xs) => AllHasSecurity (x ': xs) where

73+ securities _ = (securityName px, securityScheme px) : securities pxs

74+ where

75+ px :: Proxy x

76+ px = Proxy

77+ pxs :: Proxy xs

78+ pxs = Proxy

79+

80+instance {-# OVERLAPPING #-} AllHasSecurity xs => AllHasSecurity (Cookie ': xs) where

81+ securities _ = securities pxs

82+ where

83+ pxs :: Proxy xs

84+ pxs = Proxy

85+

86+instance AllHasSecurity '[] where

87+ securities _ = []

servant-auth/servant-auth-swagger/test/Servant/Auth/SwaggerSpec.hsnew file+38

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

1+{-# LANGUAGE CPP #-}

2+module Servant.Auth.SwaggerSpec (spec) where

3+

4+import Control.Lens

5+import Data.Proxy

6+import Servant.API

7+import Servant.Auth

8+import Servant.Auth.Swagger

9+import Data.Swagger

10+import Servant.Swagger

11+import Test.Hspec

12+

13+spec :: Spec

14+spec = describe "HasSwagger instance" $ do

15+

16+ let swag = toSwagger (Proxy :: Proxy API)

17+

18+ it "adds security definitions at the top level" $ do

19+#if MIN_VERSION_swagger2(2,6,0)

20+ let (SecurityDefinitions secDefs) = swag ^. securityDefinitions

21+#else

22+ let secDefs = swag ^. securityDefinitions

23+#endif

24+ length secDefs `shouldSatisfy` (> 0)

25+

26+ it "adds security at sub-apis" $ do

27+ swag ^. security `shouldBe` []

28+ show (swag ^. paths . at "/secure") `shouldContain` "JwtSecurity"

29+ show (swag ^. paths . at "/insecure") `shouldNotContain` "JwtSecurity"

30+

31+-- * API

32+

33+type API = "secure" :> Auth '[JWT, Cookie] Int :> SecureAPI

34+ :<|> "insecure" :> InsecureAPI

35+

36+type SecureAPI = Get '[JSON] Int :<|> ReqBody '[JSON] Int :> Post '[JSON] Int

37+

38+type InsecureAPI = SecureAPI

servant-auth/servant-auth-swagger/test/Spec.hsnew file+1

@@ -0,0 +1 @@

1+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

servant-auth/servant-auth/.ghcinew file+1

@@ -0,0 +1 @@

1+:set -isrc -itest -idoctest/ghci-wrapper/src

servant-auth/servant-auth/CHANGELOG.mdnew file+20

@@ -0,0 +1,20 @@

1+# Changelog

2+

3+All notable changes to this project will be documented in this file.

4+

5+The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/)

6+and this project adheres to [PVP Versioning](https://pvp.haskell.org/).

7+

8+## [Unreleased]

9+

10+## [0.4.0.0] - 2020-10-06

11+

12+- Support for GHC 8.10 by @domenkozar

13+- Support servant 0.18 by @domenkozar

14+- Move `ToJWT/FromJWT` from servant-auth-server

15+

16+## [0.3.2.0] - 2018-06-18

17+

18+### Added

19+- Support for GHC 8.4 by @phadej

20+- Changelog by @domenkozar

servant-auth/servant-auth/LICENSEnew file+31

@@ -0,0 +1,31 @@

1+Copyright Julian K. Arni (c) 2015

2+

3+All rights reserved.

4+

5+Redistribution and use in source and binary forms, with or without

6+modification, are permitted provided that the following conditions are met:

7+

8+ * Redistributions of source code must retain the above copyright

9+ notice, this list of conditions and the following disclaimer.

10+

11+ * Redistributions in binary form must reproduce the above

12+ copyright notice, this list of conditions and the following

13+ disclaimer in the documentation and/or other materials provided

14+ with the distribution.

15+

16+ * Neither the name of Julian K. Arni nor the names of other

17+ contributors may be used to endorse or promote products derived

18+ from this software without specific prior written permission.

19+

20+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS

21+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT

22+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR

23+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT

24+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,

25+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT

26+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,

27+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY

28+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT

29+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE

30+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

31+

servant-auth/servant-auth/Setup.hsnew file+2

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

1+import Distribution.Simple

2+main = defaultMain

servant-auth/servant-auth/servant-auth.cabalnew file+47

@@ -0,0 +1,47 @@

1+cabal-version: 2.2

2+name: servant-auth

3+version: 0.4.1.0

4+synopsis: Authentication combinators for servant

5+description: This package provides an @Auth@ combinator for 'servant'. This combinator

6+ allows using different authentication schemes in a straightforward way,

7+ and possibly in conjunction with one another.

8+ .

9+ 'servant-auth' additionally provides concrete authentication schemes, such

10+ as Basic Access Authentication, JSON Web Tokens, and Cookies.

11+ .

12+ For more details on how to use this, see the <https://github.com/haskell-servant/servant/tree/master/servant-auth#readme README>.

13+category: Web, Servant, Authentication

14+homepage: https://github.com/haskell-servant/servant/tree/master/servant-auth#readme

15+bug-reports: https://github.com/haskell-servant/servant/issues

16+author: Julian K. Arni

17+maintainer: jkarni@gmail.com

18+copyright: (c) Julian K. Arni

19+license: BSD-3-Clause

20+license-file: LICENSE

21+tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1

22+build-type: Simple

23+extra-source-files:

24+ CHANGELOG.md

25+

26+source-repository head

27+ type: git

28+ location: https://github.com/haskell-servant/servant

29+

30+library

31+ hs-source-dirs:

32+ src

33+ default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators

34+ ghc-options: -Wall

35+ build-depends:

36+ base >= 4.10 && < 4.17

37+ , containers >= 0.6 && < 0.7

38+ , aeson >= 1.3.1.1 && < 3

39+ , jose >= 0.7.0.0 && < 0.10

40+ , lens >= 4.16.1 && < 5.2

41+ , servant >= 0.15 && < 0.20

42+ , text >= 1.2.3.0 && < 2.1

43+ , unordered-containers >= 0.2.9.0 && < 0.3

44+ exposed-modules:

45+ Servant.Auth

46+ Servant.Auth.JWT

47+ default-language: Haskell2010

servant-auth/servant-auth/src/Servant/Auth.hsnew file+54

@@ -0,0 +1,54 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4+{-# LANGUAGE TypeFamilies #-}

5+{-# LANGUAGE TypeOperators #-}

6+module Servant.Auth where

7+

8+import Data.Proxy (Proxy(..))

9+import Servant.API ((:>))

10+import Servant.Links (HasLink (..))

11+

12+-- * Authentication

13+

14+-- | @Auth [auth1, auth2] val :> api@ represents an API protected *either* by

15+-- @auth1@ or @auth2@

16+data Auth (auths :: [*]) val

17+

18+-- | A @HasLink@ instance for @Auth@

19+instance HasLink sub => HasLink (Auth (tag :: [*]) value :> sub) where

20+#if MIN_VERSION_servant(0,14,0)

21+ type MkLink (Auth (tag :: [*]) value :> sub) a = MkLink sub a

22+ toLink toA _ = toLink toA (Proxy :: Proxy sub)

23+#else

24+ type MkLink (Auth (tag :: [*]) value :> sub) = MkLink sub

25+ toLink _ = toLink (Proxy :: Proxy sub)

26+#endif

27+

28+-- ** Combinators

29+

30+-- | A JSON Web Token (JWT) in the the Authorization header:

31+--

32+-- @Authorization: Bearer \<token\>@

33+--

34+-- Note that while the token is signed, it is not encrypted. Therefore do not

35+-- keep in it any information you would not like the client to know.

36+--

37+-- JWTs are described in IETF's <https://tools.ietf.org/html/rfc7519 RFC 7519>

38+data JWT

39+

40+-- | A cookie. The content cookie itself is a JWT. Another cookie is also used,

41+-- the contents of which are expected to be send back to the server in a

42+-- header, for XSRF protection.

43+data Cookie

44+

45+

46+-- We could use 'servant''s BasicAuth, but then we don't get control over the

47+-- documentation, and we'd have to polykind everything. (Also, we don't

48+-- currently depend on servant!)

49+--

50+-- | Basic Auth.

51+data BasicAuth

52+

53+-- | Login via a form.

54+data FormLogin form

servant-auth/servant-auth/src/Servant/Auth/JWT.hsnew file+40

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

1+{-# LANGUAGE CPP #-}

2+

3+module Servant.Auth.JWT where

4+

5+import Control.Lens ((^.))

6+import qualified Crypto.JWT as Jose

7+import Data.Aeson (FromJSON, Result (..), ToJSON, fromJSON,

8+ toJSON)

9+#if MIN_VERSION_aeson(2,0,0)

10+import qualified Data.Map as KM

11+#else

12+import qualified Data.HashMap.Strict as KM

13+#endif

14+

15+import qualified Data.Text as T

16+

17+

18+-- This should probably also be from ClaimSet

19+--

20+-- | How to decode data from a JWT.

21+--

22+-- The default implementation assumes the data is stored in the unregistered

23+-- @dat@ claim, and uses the @FromJSON@ instance to decode value from there.

24+class FromJWT a where

25+ decodeJWT :: Jose.ClaimsSet -> Either T.Text a

26+ default decodeJWT :: FromJSON a => Jose.ClaimsSet -> Either T.Text a

27+ decodeJWT m = case KM.lookup "dat" (m ^. Jose.unregisteredClaims) of

28+ Nothing -> Left "Missing 'dat' claim"

29+ Just v -> case fromJSON v of

30+ Error e -> Left $ T.pack e

31+ Success a -> Right a

32+

33+-- | How to encode data from a JWT.

34+--

35+-- The default implementation stores data in the unregistered @dat@ claim, and

36+-- uses the type's @ToJSON@ instance to encode the data.

37+class ToJWT a where

38+ encodeJWT :: a -> Jose.ClaimsSet

39+ default encodeJWT :: ToJSON a => a -> Jose.ClaimsSet

40+ encodeJWT a = Jose.addClaim "dat" (toJSON a) Jose.emptyClaimsSet

servant-auth/servant-auth/test/Spec.hsnew file+1

@@ -0,0 +1 @@

1+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

servant-client-core/CHANGELOG.md+159−2

@@ -1,6 +1,163 @@

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+

40.15

1610.15

5----

162----

6

163

@@ -118,9 +275,9 @@

118

275

119- *servant-client-core* Add `hoistClient` to `HasClient`.

276- *servant-client-core* Add `hoistClient` to `HasClient`.

120 Just like `hoistServer` allows us to change the monad in which request handlers

277 Just like `hoistServer` allows us to change the monad in which request handlers

121− of a web application live in, we also have `hoistClient` for changing the monad

278+ of a web application live, we also have `hoistClient` for changing the monad

122 in which *client functions* live.

279 in which *client functions* live.

123− 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).

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

124 ([#936](https://github.com/haskell-servant/servant/pull/936))

281 ([#936](https://github.com/haskell-servant/servant/pull/936))

125

282

126 iF you have own combinators, you'll need to define a new method of

283 iF you have own combinators, you'll need to define a new method of

servant-client-core/servant-client-core.cabal+38−32

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

1−cabal-version: >=1.10

1+cabal-version: 2.2

2name: servant-client-core

2name: servant-client-core

3−version: 0.15

3+version: 0.19

4

4

5synopsis: Core functionality and class for client function generation for servant APIs

5synopsis: Core functionality and class for client function generation for servant APIs

6category: Servant, Web

6category: Servant, Web

@@ -8,19 +8,16 @@ description:

8 This library provides backend-agnostic generation of client functions. For

8 This library provides backend-agnostic generation of client functions. For

9 more information, see the README.

9 more information, see the README.

10

10

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

11+homepage: http://docs.servant.dev/

12bug-reports: http://github.com/haskell-servant/servant/issues

12bug-reports: http://github.com/haskell-servant/servant/issues

13−license: BSD3

13+license: BSD-3-Clause

14license-file: LICENSE

14license-file: LICENSE

15author: Servant Contributors

15author: Servant Contributors

16maintainer: haskell-servant-maintainers@googlegroups.com

16maintainer: haskell-servant-maintainers@googlegroups.com

17−copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2018 Servant Contributors

17+copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors

18build-type: Simple

18build-type: Simple

19−tested-with:

19+tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1

20− GHC ==8.0.2

20+ , GHCJS ==8.6.0.1

21− || ==8.2.2

22− || ==8.4.4

23− || ==8.6.2

24

21

25extra-source-files:

22extra-source-files:

26 CHANGELOG.md

23 CHANGELOG.md

@@ -36,45 +33,53 @@ library

36 Servant.Client.Free

33 Servant.Client.Free

37 Servant.Client.Generic

34 Servant.Client.Generic

38 Servant.Client.Core.Reexport

35 Servant.Client.Core.Reexport

39− Servant.Client.Core.Internal.Auth

36+ Servant.Client.Core.Auth

40− Servant.Client.Core.Internal.BaseUrl

37+ Servant.Client.Core.BaseUrl

41− Servant.Client.Core.Internal.BasicAuth

38+ Servant.Client.Core.BasicAuth

42− Servant.Client.Core.Internal.ClientF

39+ Servant.Client.Core.ClientError

43− Servant.Client.Core.Internal.Generic

44− Servant.Client.Core.Internal.HasClient

40+ Servant.Client.Core.HasClient

45− Servant.Client.Core.Internal.Request

41+ Servant.Client.Core.Request

46− Servant.Client.Core.Internal.RunClient

42+ Servant.Client.Core.Response

43+ Servant.Client.Core.RunClient

44+

45+ other-modules:

46+ Servant.Client.Core.Internal

47

47

48 -- Bundled with GHC: Lower bound to not force re-installs

48 -- Bundled with GHC: Lower bound to not force re-installs

49 -- text and mtl are bundled starting with GHC-8.4

49 -- text and mtl are bundled starting with GHC-8.4

50 --

50 --

51 -- note: mtl lower bound is so low because of GHC-7.8

51 -- note: mtl lower bound is so low because of GHC-7.8

52 build-depends:

52 build-depends:

53− base >= 4.9 && < 4.13

53+ base >= 4.9 && < 4.17

54− , bytestring >= 0.10.8.1 && < 0.11

54+ , bytestring >= 0.10.8.1 && < 0.12

55+ , constraints >= 0.2 && < 0.14

55 , containers >= 0.5.7.1 && < 0.7

56 , containers >= 0.5.7.1 && < 0.7

56 , deepseq >= 1.4.2.0 && < 1.5

57 , deepseq >= 1.4.2.0 && < 1.5

57− , text >= 1.2.3.0 && < 1.3

58+ , text >= 1.2.3.0 && < 2.1

58 , transformers >= 0.5.2.0 && < 0.6

59 , transformers >= 0.5.2.0 && < 0.6

59− , template-haskell >= 2.11.1.0 && < 2.15

60+ , template-haskell >= 2.11.1.0 && < 2.19

61+

62+ if !impl(ghc >= 8.2)

63+ build-depends:

64+ bifunctors >= 5.5.3 && < 5.6

60

65

61 -- Servant dependencies

66 -- Servant dependencies

62 build-depends:

67 build-depends:

63− servant >= 0.15 && <0.16

68+ servant >= 0.19

64

69

65 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.

70 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.

66 -- Here can be exceptions if we really need features from the newer versions.

71 -- Here can be exceptions if we really need features from the newer versions.

67 build-depends:

72 build-depends:

68− aeson >= 1.4.1.0 && < 1.5

73+ aeson >= 1.4.1.0 && < 3

69− , base-compat >= 0.10.5 && < 0.11

74+ , base-compat >= 0.10.5 && < 0.13

70− , base64-bytestring >= 1.0.0.1 && < 1.1

75+ , base64-bytestring >= 1.0.0.1 && < 1.3

71 , exceptions >= 0.10.0 && < 0.11

76 , exceptions >= 0.10.0 && < 0.11

72 , free >= 5.1 && < 5.2

77 , free >= 5.1 && < 5.2

73− , generics-sop >= 0.4.0.1 && < 0.5

74− , http-media >= 0.7.1.3 && < 0.8

78+ , http-media >= 0.7.1.3 && < 0.9

75 , http-types >= 0.12.2 && < 0.13

79 , http-types >= 0.12.2 && < 0.13

76 , network-uri >= 2.6.1.0 && < 2.7

80 , network-uri >= 2.6.1.0 && < 2.7

77 , safe >= 0.3.17 && < 0.4

81 , safe >= 0.3.17 && < 0.4

82+ , sop-core >= 0.4.0.0 && < 0.6

78

83

79 hs-source-dirs: src

84 hs-source-dirs: src

80 default-language: Haskell2010

85 default-language: Haskell2010

@@ -88,6 +93,7 @@ test-suite spec

88 main-is: Spec.hs

93 main-is: Spec.hs

89 other-modules:

94 other-modules:

90 Servant.Client.Core.Internal.BaseUrlSpec

95 Servant.Client.Core.Internal.BaseUrlSpec

96+ Servant.Client.Core.RequestSpec

91

97

92 -- Dependencies inherited from the library. No need to specify bounds.

98 -- Dependencies inherited from the library. No need to specify bounds.

93 build-depends:

99 build-depends:

@@ -95,11 +101,11 @@ test-suite spec

95 , base-compat

101 , base-compat

96 , servant-client-core

102 , servant-client-core

97

103

98− -- Additonal dependencies

104+ -- Additional dependencies

99 build-depends:

105 build-depends:

100 deepseq >= 1.4.2.0 && < 1.5

106 deepseq >= 1.4.2.0 && < 1.5

101− , hspec >= 2.6.0 && < 2.8

107+ , hspec >= 2.6.0 && < 2.10

102− , QuickCheck >= 2.12.6.1 && < 2.13

108+ , QuickCheck >= 2.12.6.1 && < 2.15

103

109

104 build-tool-depends:

110 build-tool-depends:

105− hspec-discover:hspec-discover >= 2.6.0 && <2.8

111+ hspec-discover:hspec-discover >= 2.6.0 && <2.10

servant-client-core/src/Servant/Client/Core.hs+21−15

@@ -18,6 +18,8 @@ module Servant.Client.Core

18 -- * Client generation

18 -- * Client generation

19 clientIn

19 clientIn

20 , HasClient(..)

20 , HasClient(..)

21+ , foldMapUnion

22+ , matchUnion

21

23

22 -- * Request

24 -- * Request

23 , Request

25 , Request

@@ -32,18 +34,20 @@ module Servant.Client.Core

32 , AuthClientData

34 , AuthClientData

33

35

34 -- * Generic Client

36 -- * Generic Client

35− , ClientLike(..)

37+ , ClientError(..)

36− , genericMkClientL

37− , genericMkClientP

38− , ServantError(..)

39 , EmptyClient(..)

38 , EmptyClient(..)

40

39

41−

42 -- * Response

40 -- * Response

43 , Response

41 , Response

44− , GenResponse (..)

42+ , ResponseF (..)

45 , RunClient(..)

43 , RunClient(..)

46− , module Servant.Client.Core.Internal.BaseUrl

44+ -- * BaseUrl

45+ , BaseUrl (..)

46+ , Scheme (..)

47+ , showBaseUrl

48+ , parseBaseUrl

49+ , InvalidBaseUrlException (..)

50+

47 -- ** Streaming

51 -- ** Streaming

48 , RunStreamingClient(..)

52 , RunStreamingClient(..)

49 , StreamingResponse

53 , StreamingResponse

@@ -55,13 +59,15 @@ module Servant.Client.Core

55 , appendToPath

59 , appendToPath

56 , setRequestBodyLBS

60 , setRequestBodyLBS

57 , setRequestBody

61 , setRequestBody

62+ , encodeQueryParamValue

58 ) where

63 ) where

59−import Servant.Client.Core.Internal.Auth

64+import Servant.Client.Core.Auth

60−import Servant.Client.Core.Internal.BaseUrl

65+import Servant.Client.Core.BaseUrl

61− (BaseUrl (..), InvalidBaseUrlException, Scheme (..),

66+ (BaseUrl (..), InvalidBaseUrlException (..), Scheme (..),

62 parseBaseUrl, showBaseUrl)

67 parseBaseUrl, showBaseUrl)

63−import Servant.Client.Core.Internal.BasicAuth

68+import Servant.Client.Core.BasicAuth

64−import Servant.Client.Core.Internal.Generic

69+import Servant.Client.Core.ClientError

65−import Servant.Client.Core.Internal.HasClient

70+import Servant.Client.Core.HasClient

66−import Servant.Client.Core.Internal.Request

71+import Servant.Client.Core.Request

67−import Servant.Client.Core.Internal.RunClient

72+import Servant.Client.Core.Response

73+import Servant.Client.Core.RunClient

servant-client-core/src/Servant/Client/Core/Internal/Auth.hs → servant-client-core/src/Servant/Client/Core/Auth.hsrenamed+6−2

@@ -4,9 +4,13 @@

4

4

5-- | Authentication for clients

5-- | Authentication for clients

6

6

7−module Servant.Client.Core.Internal.Auth where

7+module Servant.Client.Core.Auth (

8+ AuthClientData,

9+ AuthenticatedRequest (..),

10+ mkAuthenticatedRequest,

11+ ) where

8

12

9−import Servant.Client.Core.Internal.Request

13+import Servant.Client.Core.Request

10 (Request)

14 (Request)

11

15

12-- | For a resource protected by authentication (e.g. AuthProtect), we need

16-- | For a resource protected by authentication (e.g. AuthProtect), we need

servant-client-core/src/Servant/Client/Core/Internal/BaseUrl.hs → servant-client-core/src/Servant/Client/Core/BaseUrl.hsrenamed+12−1

@@ -2,8 +2,16 @@

2{-# LANGUAGE DeriveGeneric #-}

2{-# LANGUAGE DeriveGeneric #-}

3{-# LANGUAGE DeriveLift #-}

3{-# LANGUAGE DeriveLift #-}

4{-# LANGUAGE ViewPatterns #-}

4{-# LANGUAGE ViewPatterns #-}

5−module Servant.Client.Core.Internal.BaseUrl where

5+module Servant.Client.Core.BaseUrl (

6+ BaseUrl (..),

7+ Scheme (..),

8+ showBaseUrl,

9+ parseBaseUrl,

10+ InvalidBaseUrlException (..),

11+ ) where

6

12

13+import Control.DeepSeq

14+ (NFData (..))

7import Control.Monad.Catch

15import Control.Monad.Catch

8 (Exception, MonadThrow, throwM)

16 (Exception, MonadThrow, throwM)

9import Data.Aeson

17import Data.Aeson

@@ -39,6 +47,9 @@ data BaseUrl = BaseUrl

39 } deriving (Show, Ord, Generic, Lift, Data)

47 } deriving (Show, Ord, Generic, Lift, Data)

40-- TODO: Ord is more precise than Eq

48-- TODO: Ord is more precise than Eq

41-- TODO: Add Hashable instance?

49-- TODO: Add Hashable instance?

50+--

51+instance NFData BaseUrl where

52+ rnf (BaseUrl a b c d) = a `seq` rnf b `seq` rnf c `seq` rnf d

42

53

43instance Eq BaseUrl where

54instance Eq BaseUrl where

44 BaseUrl a b c path == BaseUrl a' b' c' path'

55 BaseUrl a b c path == BaseUrl a' b' c' path'

servant-client-core/src/Servant/Client/Core/Internal/BasicAuth.hs → servant-client-core/src/Servant/Client/Core/BasicAuth.hsrenamed+4−5

@@ -3,18 +3,17 @@

3{-# LANGUAGE TypeSynonymInstances #-}

3{-# LANGUAGE TypeSynonymInstances #-}

4

4

5-- | Basic Authentication for clients

5-- | Basic Authentication for clients

6−

7−module Servant.Client.Core.Internal.BasicAuth where

6+module Servant.Client.Core.BasicAuth (

7+ basicAuthReq,

8+ ) where

8

9

9import Data.ByteString.Base64

10import Data.ByteString.Base64

10 (encode)

11 (encode)

11−import Data.Monoid

12− ((<>))

13import Data.Text.Encoding

12import Data.Text.Encoding

14 (decodeUtf8)

13 (decodeUtf8)

15import Servant.API.BasicAuth

14import Servant.API.BasicAuth

16 (BasicAuthData (BasicAuthData))

15 (BasicAuthData (BasicAuthData))

17−import Servant.Client.Core.Internal.Request

16+import Servant.Client.Core.Request

18 (Request, addHeader)

17 (Request, addHeader)

19

18

20-- | Authenticate a request using Basic Authentication

19-- | Authenticate a request using Basic Authentication

servant-client-core/src/Servant/Client/Core/ClientError.hsnew file+86

@@ -0,0 +1,86 @@

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/HasClient.hs → servant-client-core/src/Servant/Client/Core/HasClient.hsrenamed+403−43

@@ -1,3 +1,4 @@

1+{-# LANGUAGE ConstraintKinds #-}

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE FlexibleInstances #-}

@@ -5,54 +6,99 @@

5{-# LANGUAGE MultiParamTypeClasses #-}

6{-# LANGUAGE MultiParamTypeClasses #-}

6{-# LANGUAGE OverloadedStrings #-}

7{-# LANGUAGE OverloadedStrings #-}

7{-# LANGUAGE PolyKinds #-}

8{-# LANGUAGE PolyKinds #-}

9+{-# LANGUAGE QuantifiedConstraints #-}

8{-# LANGUAGE RankNTypes #-}

10{-# LANGUAGE RankNTypes #-}

9{-# LANGUAGE ScopedTypeVariables #-}

11{-# LANGUAGE ScopedTypeVariables #-}

12+{-# LANGUAGE TypeApplications #-}

10{-# LANGUAGE TypeFamilies #-}

13{-# LANGUAGE TypeFamilies #-}

11{-# LANGUAGE TypeOperators #-}

14{-# LANGUAGE TypeOperators #-}

12{-# LANGUAGE UndecidableInstances #-}

15{-# LANGUAGE UndecidableInstances #-}

13

16

14−module Servant.Client.Core.Internal.HasClient where

17+module Servant.Client.Core.HasClient (

18+ clientIn,

19+ HasClient (..),

20+ EmptyClient (..),

21+ AsClientT,

22+ (//),

23+ (/:),

24+ foldMapUnion,

25+ matchUnion,

26+ ) where

15

27

16import Prelude ()

28import Prelude ()

17import Prelude.Compat

29import Prelude.Compat

18

30

31+import Control.Arrow

32+ (left, (+++))

33+import Control.Monad

34+ (unless)

19−import qualified Data.ByteString as BS

35+import qualified Data.ByteString as BS

20−import qualified Data.ByteString.Lazy as BL

36+import qualified Data.ByteString.Lazy as BL

37+import Data.Either

38+ (partitionEithers)

39+import Data.Constraint (Dict(..))

21import Data.Foldable

40import Data.Foldable

22 (toList)

41 (toList)

23import Data.List

42import Data.List

24 (foldl')

43 (foldl')

25−import Data.Proxy

26− (Proxy (Proxy))

27import Data.Sequence

44import Data.Sequence

28 (fromList)

45 (fromList)

46+import qualified Data.Text as T

47+import Network.HTTP.Media

48+ (MediaType, matches, parseAccept)

49+import qualified Network.HTTP.Media as Media

50+import qualified Data.Sequence as Seq

51+import Data.SOP.BasicFunctors

52+ (I (I), (:.:) (Comp))

53+import Data.SOP.Constraint

54+ (All)

55+import Data.SOP.NP

56+ (NP (..), cpure_NP)

57+import Data.SOP.NS

58+ (NS (S))

29import Data.String

59import Data.String

30 (fromString)

60 (fromString)

31import Data.Text

61import Data.Text

32 (Text, pack)

62 (Text, pack)

63+import Data.Proxy

64+ (Proxy (Proxy))

33import GHC.TypeLits

65import GHC.TypeLits

34− (KnownSymbol, symbolVal)

66+ (KnownNat, KnownSymbol, TypeError, symbolVal)

67+import Network.HTTP.Types

68+ (Status)

35−import qualified Network.HTTP.Types as H

69+import qualified Network.HTTP.Types as H

36import Servant.API

70import Servant.API

37 ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, BasicAuthData,

71 ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, BasicAuthData,

38 BuildHeadersTo (..), Capture', CaptureAll, Description,

72 BuildHeadersTo (..), Capture', CaptureAll, Description,

39− EmptyAPI, FramingUnrender (..), FromSourceIO (..), Header',

73+ EmptyAPI, Fragment, FramingRender (..), FramingUnrender (..),

74+ FromSourceIO (..), Header', Headers (..), HttpVersion,

40− Headers (..), HttpVersion, IsSecure, MimeRender (mimeRender),

75+ IsSecure, MimeRender (mimeRender),

41− MimeUnrender (mimeUnrender), NoContent (NoContent), QueryFlag,

76+ MimeUnrender (mimeUnrender), NoContent (NoContent),

42− QueryParam', QueryParams, Raw, ReflectMethod (..), RemoteHost,

77+ NoContentVerb, QueryFlag, QueryParam', QueryParams, Raw,

78+ ReflectMethod (..), RemoteHost, ReqBody', SBoolI, Stream,

43− ReqBody', SBoolI, Stream, StreamBody', Summary, ToHttpApiData,

79+ StreamBody', Summary, ToHttpApiData, ToSourceIO (..), Vault,

44− Vault, Verb, WithNamedContext, contentType, getHeadersHList,

80+ Verb, WithNamedContext, WithStatus (..), contentType, getHeadersHList,

45− getResponse, toQueryParam, toUrlPiece)

81+ getResponse, toEncodedUrlPiece, toUrlPiece, NamedRoutes)

82+import Servant.API.Generic

83+ (GenericMode(..), ToServant, ToServantApi

84+ , GenericServant, toServant, fromServant)

46import Servant.API.ContentTypes

85import Servant.API.ContentTypes

47− (contentTypes)

86+ (contentTypes, AllMime (allMime), AllMimeUnrender (allMimeUnrender))

87+import Servant.API.Status

88+ (statusFromNat)

89+import Servant.API.TypeLevel (FragmentUnique, AtLeastOneFragment)

48import Servant.API.Modifiers

90import Servant.API.Modifiers

49 (FoldRequired, RequiredArgument, foldRequiredArgument)

91 (FoldRequired, RequiredArgument, foldRequiredArgument)

50−import qualified Servant.Types.SourceT as S

92+import Servant.API.TypeErrors

93+import Servant.API.UVerb

94+ (HasStatus, HasStatuses (Statuses, statuses), UVerb, Union, Unique, inject, statusOf, foldMapUnion, matchUnion)

51

95

52−import Servant.Client.Core.Internal.Auth

96+import Servant.Client.Core.Auth

53−import Servant.Client.Core.Internal.BasicAuth

97+import Servant.Client.Core.BasicAuth

54−import Servant.Client.Core.Internal.Request

98+import Servant.Client.Core.ClientError

99+import Servant.Client.Core.Request

55−import Servant.Client.Core.Internal.RunClient

100+import Servant.Client.Core.Response

101+import Servant.Client.Core.RunClient

56

102

57-- * Accessing APIs as a Client

103-- * Accessing APIs as a Client

58

104

@@ -162,7 +208,7 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m api)

162 clientWithRoute pm (Proxy :: Proxy api)

208 clientWithRoute pm (Proxy :: Proxy api)

163 (appendToPath p req)

209 (appendToPath p req)

164

210

165− where p = (toUrlPiece val)

211+ where p = toEncodedUrlPiece val

166

212

167 hoistClientMonad pm _ f cl = \a ->

213 hoistClientMonad pm _ f cl = \a ->

168 hoistClientMonad pm (Proxy :: Proxy api) f (cl a)

214 hoistClientMonad pm (Proxy :: Proxy api) f (cl a)

@@ -197,7 +243,7 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m sublayout)

197 clientWithRoute pm (Proxy :: Proxy sublayout)

243 clientWithRoute pm (Proxy :: Proxy sublayout)

198 (foldl' (flip appendToPath) req ps)

244 (foldl' (flip appendToPath) req ps)

199

245

200− where ps = map (toUrlPiece) vals

246+ where ps = map toEncodedUrlPiece vals

201

247

202 hoistClientMonad pm _ f cl = \as ->

248 hoistClientMonad pm _ f cl = \as ->

203 hoistClientMonad pm (Proxy :: Proxy sublayout) f (cl as)

249 hoistClientMonad pm (Proxy :: Proxy sublayout) f (cl as)

@@ -205,10 +251,11 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m sublayout)

205instance {-# OVERLAPPABLE #-}

251instance {-# OVERLAPPABLE #-}

206 -- Note [Non-Empty Content Types]

252 -- Note [Non-Empty Content Types]

207 ( RunClient m, MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)

253 ( RunClient m, MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)

254+ , KnownNat status

208 ) => HasClient m (Verb method status cts' a) where

255 ) => HasClient m (Verb method status cts' a) where

209 type Client m (Verb method status cts' a) = m a

256 type Client m (Verb method status cts' a) = m a

210 clientWithRoute _pm Proxy req = do

257 clientWithRoute _pm Proxy req = do

211− response <- runRequest req

258+ response <- runRequestAcceptStatus (Just [status]) req

212 { requestAccept = fromList $ toList accept

259 { requestAccept = fromList $ toList accept

213 , requestMethod = method

260 , requestMethod = method

214 }

261 }

@@ -216,14 +263,27 @@ instance {-# OVERLAPPABLE #-}

216 where

263 where

217 accept = contentTypes (Proxy :: Proxy ct)

264 accept = contentTypes (Proxy :: Proxy ct)

218 method = reflectMethod (Proxy :: Proxy method)

265 method = reflectMethod (Proxy :: Proxy method)

266+ status = statusFromNat (Proxy :: Proxy status)

219

267

220 hoistClientMonad _ _ f ma = f ma

268 hoistClientMonad _ _ f ma = f ma

221

269

222instance {-# OVERLAPPING #-}

270instance {-# OVERLAPPING #-}

223− ( RunClient m, ReflectMethod method

271+ ( RunClient m, ReflectMethod method, KnownNat status

224 ) => HasClient m (Verb method status cts NoContent) where

272 ) => HasClient m (Verb method status cts NoContent) where

225 type Client m (Verb method status cts NoContent)

273 type Client m (Verb method status cts NoContent)

226 = m NoContent

274 = m NoContent

275+ clientWithRoute _pm Proxy req = do

276+ _response <- runRequestAcceptStatus (Just [status]) req { requestMethod = method }

277+ return NoContent

278+ where method = reflectMethod (Proxy :: Proxy method)

279+ status = statusFromNat (Proxy :: Proxy status)

280+

281+ hoistClientMonad _ _ f ma = f ma

282+

283+instance (RunClient m, ReflectMethod method) =>

284+ HasClient m (NoContentVerb method) where

285+ type Client m (NoContentVerb method)

286+ = m NoContent

227 clientWithRoute _pm Proxy req = do

287 clientWithRoute _pm Proxy req = do

228 _response <- runRequest req { requestMethod = method }

288 _response <- runRequest req { requestMethod = method }

229 return NoContent

289 return NoContent

@@ -233,41 +293,129 @@ instance {-# OVERLAPPING #-}

233

293

234instance {-# OVERLAPPING #-}

294instance {-# OVERLAPPING #-}

235 -- Note [Non-Empty Content Types]

295 -- Note [Non-Empty Content Types]

236− ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls

296+ ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls, KnownNat status

237 , ReflectMethod method, cts' ~ (ct ': cts)

297 , ReflectMethod method, cts' ~ (ct ': cts)

238 ) => HasClient m (Verb method status cts' (Headers ls a)) where

298 ) => HasClient m (Verb method status cts' (Headers ls a)) where

239 type Client m (Verb method status cts' (Headers ls a))

299 type Client m (Verb method status cts' (Headers ls a))

240 = m (Headers ls a)

300 = m (Headers ls a)

241 clientWithRoute _pm Proxy req = do

301 clientWithRoute _pm Proxy req = do

242− response <- runRequest req

302+ response <- runRequestAcceptStatus (Just [status]) req

243 { requestMethod = method

303 { requestMethod = method

244 , requestAccept = fromList $ toList accept

304 , requestAccept = fromList $ toList accept

245 }

305 }

246− case mimeUnrender (Proxy :: Proxy ct) $ responseBody response of

306+ val <- response `decodedAs` (Proxy :: Proxy ct)

247− Left err -> throwServantError $ DecodeFailure (pack err) response

248− Right val -> return $ Headers

249− { getResponse = val

307+ return $ Headers { getResponse = val

250− , getHeadersHList = buildHeadersTo . toList $ responseHeaders response

308+ , getHeadersHList = buildHeadersTo . toList $ responseHeaders response

251− }

309+ }

310+ where

252− where method = reflectMethod (Proxy :: Proxy method)

311+ method = reflectMethod (Proxy :: Proxy method)

253− accept = contentTypes (Proxy :: Proxy ct)

312+ accept = contentTypes (Proxy :: Proxy ct)

313+ status = statusFromNat (Proxy :: Proxy status)

254

314

255 hoistClientMonad _ _ f ma = f ma

315 hoistClientMonad _ _ f ma = f ma

256

316

257instance {-# OVERLAPPING #-}

317instance {-# OVERLAPPING #-}

258− ( RunClient m, BuildHeadersTo ls, ReflectMethod method

318+ ( RunClient m, BuildHeadersTo ls, ReflectMethod method, KnownNat status

259 ) => HasClient m (Verb method status cts (Headers ls NoContent)) where

319 ) => HasClient m (Verb method status cts (Headers ls NoContent)) where

260 type Client m (Verb method status cts (Headers ls NoContent))

320 type Client m (Verb method status cts (Headers ls NoContent))

261 = m (Headers ls NoContent)

321 = m (Headers ls NoContent)

262 clientWithRoute _pm Proxy req = do

322 clientWithRoute _pm Proxy req = do

263− let method = reflectMethod (Proxy :: Proxy method)

264− response <- runRequest req { requestMethod = method }

323+ response <- runRequestAcceptStatus (Just [status]) req { requestMethod = method }

265 return $ Headers { getResponse = NoContent

324 return $ Headers { getResponse = NoContent

266 , getHeadersHList = buildHeadersTo . toList $ responseHeaders response

325 , getHeadersHList = buildHeadersTo . toList $ responseHeaders response

267 }

326 }

327+ where

328+ method = reflectMethod (Proxy :: Proxy method)

329+ status = statusFromNat (Proxy :: Proxy status)

268

330

269 hoistClientMonad _ _ f ma = f ma

331 hoistClientMonad _ _ f ma = f ma

270

332

333+data ClientParseError = ClientParseError MediaType String | ClientStatusMismatch | ClientNoMatchingStatus

334+ deriving (Eq, Show)

335+

336+class UnrenderResponse (cts :: [*]) (a :: *) where

337+ unrenderResponse :: Seq.Seq H.Header -> BL.ByteString -> Proxy cts

338+ -> [Either (MediaType, String) a]

339+

340+instance {-# OVERLAPPABLE #-} AllMimeUnrender cts a => UnrenderResponse cts a where

341+ unrenderResponse _ body = map parse . allMimeUnrender

342+ where parse (mediaType, parser) = left ((,) mediaType) (parser body)

343+

344+instance {-# OVERLAPPING #-} forall cts a h . (UnrenderResponse cts a, BuildHeadersTo h)

345+ => UnrenderResponse cts (Headers h a) where

346+ unrenderResponse hs body = (map . fmap) setHeaders . unrenderResponse hs body

347+ where

348+ setHeaders :: a -> Headers h a

349+ setHeaders x = Headers x (buildHeadersTo (toList hs))

350+

351+instance {-# OVERLAPPING #-} UnrenderResponse cts a

352+ => UnrenderResponse cts (WithStatus n a) where

353+ unrenderResponse hs body = (map . fmap) WithStatus . unrenderResponse hs body

354+

355+instance {-# OVERLAPPING #-}

356+ ( RunClient m,

357+ contentTypes ~ (contentType ': otherContentTypes),

358+ -- ('otherContentTypes' should be '_', but even -XPartialTypeSignatures does not seem

359+ -- allow this in instance types as of 8.8.3.)

360+ as ~ (a ': as'),

361+ AllMime contentTypes,

362+ ReflectMethod method,

363+ All (UnrenderResponse contentTypes) as,

364+ All HasStatus as, HasStatuses as',

365+ Unique (Statuses as)

366+ ) =>

367+ HasClient m (UVerb method contentTypes as)

368+ where

369+ type Client m (UVerb method contentTypes as) = m (Union as)

370+

371+ clientWithRoute _ _ request = do

372+ let accept = Seq.fromList . allMime $ Proxy @contentTypes

373+ -- offering to accept all mime types listed in the api gives best compatibility. eg.,

374+ -- we might not own the server implementation, and the server may choose to support

375+ -- only part of the api.

376+

377+ method = reflectMethod $ Proxy @method

378+ acceptStatus = statuses (Proxy @as)

379+ response <- runRequestAcceptStatus (Just acceptStatus) request {requestMethod = method, requestAccept = accept}

380+ responseContentType <- checkContentTypeHeader response

381+ unless (any (matches responseContentType) accept) $ do

382+ throwClientError $ UnsupportedContentType responseContentType response

383+

384+ let status = responseStatusCode response

385+ body = responseBody response

386+ headers = responseHeaders response

387+ res = tryParsers status $ mimeUnrenders (Proxy @contentTypes) headers body

388+ case res of

389+ Left errors -> throwClientError $ DecodeFailure (T.pack (show errors)) response

390+ Right x -> return x

391+ where

392+ -- | Given a list of parsers of 'mkres', returns the first one that succeeds and all the

393+ -- failures it encountered along the way

394+ -- TODO; better name, rewrite haddocs.

395+ tryParsers :: forall xs. All HasStatus xs => Status -> NP ([] :.: Either (MediaType, String)) xs -> Either [ClientParseError] (Union xs)

396+ tryParsers _ Nil = Left [ClientNoMatchingStatus]

397+ tryParsers status (Comp x :* xs)

398+ | status == statusOf (Comp x) =

399+ case partitionEithers x of

400+ (err', []) -> (map (uncurry ClientParseError) err' ++) +++ S $ tryParsers status xs

401+ (_, (res : _)) -> Right . inject . I $ res

402+ | otherwise = -- no reason to parse in the first place. This ain't the one we're looking for

403+ (ClientStatusMismatch :) +++ S $ tryParsers status xs

404+

405+ -- | Given a list of types, parses the given response body as each type

406+ mimeUnrenders ::

407+ forall cts xs.

408+ All (UnrenderResponse cts) xs =>

409+ Proxy cts ->

410+ Seq.Seq H.Header ->

411+ BL.ByteString ->

412+ NP ([] :.: Either (MediaType, String)) xs

413+ mimeUnrenders ctp headers body = cpure_NP

414+ (Proxy @(UnrenderResponse cts))

415+ (Comp . unrenderResponse headers body $ ctp)

416+

417+ hoistClientMonad _ _ nt s = nt s

418+

271instance {-# OVERLAPPABLE #-}

419instance {-# OVERLAPPABLE #-}

272 ( RunStreamingClient m, MimeUnrender ct chunk, ReflectMethod method,

420 ( RunStreamingClient m, MimeUnrender ct chunk, ReflectMethod method,

273 FramingUnrender framing, FromSourceIO chunk a

421 FramingUnrender framing, FromSourceIO chunk a

@@ -280,7 +428,32 @@ instance {-# OVERLAPPABLE #-}

280 clientWithRoute _pm Proxy req = withStreamingRequest req' $ \gres -> do

428 clientWithRoute _pm Proxy req = withStreamingRequest req' $ \gres -> do

281 let mimeUnrender' = mimeUnrender (Proxy :: Proxy ct) :: BL.ByteString -> Either String chunk

429 let mimeUnrender' = mimeUnrender (Proxy :: Proxy ct) :: BL.ByteString -> Either String chunk

282 framingUnrender' = framingUnrender (Proxy :: Proxy framing) mimeUnrender'

430 framingUnrender' = framingUnrender (Proxy :: Proxy framing) mimeUnrender'

283− return $ fromSourceIO $ framingUnrender' $ S.fromAction BS.null (responseBody gres)

431+ return $ fromSourceIO $ framingUnrender' $ responseBody gres

432+ where

433+ req' = req

434+ { requestAccept = fromList [contentType (Proxy :: Proxy ct)]

435+ , requestMethod = reflectMethod (Proxy :: Proxy method)

436+ }

437+

438+instance {-# OVERLAPPING #-}

439+ ( RunStreamingClient m, MimeUnrender ct chunk, ReflectMethod method,

440+ FramingUnrender framing, FromSourceIO chunk a,

441+ BuildHeadersTo hs

442+ ) => HasClient m (Stream method status framing ct (Headers hs a)) where

443+

444+ type Client m (Stream method status framing ct (Headers hs a)) = m (Headers hs a)

445+

446+ hoistClientMonad _ _ f ma = f ma

447+

448+ clientWithRoute _pm Proxy req = withStreamingRequest req' $ \gres -> do

449+ let mimeUnrender' = mimeUnrender (Proxy :: Proxy ct) :: BL.ByteString -> Either String chunk

450+ framingUnrender' = framingUnrender (Proxy :: Proxy framing) mimeUnrender'

451+ val = fromSourceIO $ framingUnrender' $ responseBody gres

452+ return $ Headers

453+ { getResponse = val

454+ , getHeadersHList = buildHeadersTo . toList $ responseHeaders gres

455+ }

456+

284 where

457 where

285 req' = req

458 req' = req

286 { requestAccept = fromList [contentType (Proxy :: Proxy ct)]

459 { requestAccept = fromList [contentType (Proxy :: Proxy ct)]

@@ -396,7 +569,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequire

396 (Proxy :: Proxy mods) add (maybe req add) mparam

569 (Proxy :: Proxy mods) add (maybe req add) mparam

397 where

570 where

398 add :: a -> Request

571 add :: a -> Request

399− add param = appendToQueryString pname (Just $ toQueryParam param) req

572+ add param = appendToQueryString pname (Just $ encodeQueryParamValue param) req

400

573

401 pname :: Text

574 pname :: Text

402 pname = pack $ symbolVal (Proxy :: Proxy sym)

575 pname = pack $ symbolVal (Proxy :: Proxy sym)

@@ -445,7 +618,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api)

445 )

618 )

446

619

447 where pname = pack $ symbolVal (Proxy :: Proxy sym)

620 where pname = pack $ symbolVal (Proxy :: Proxy sym)

448− paramlist' = map (Just . toQueryParam) paramlist

621+ paramlist' = map (Just . encodeQueryParamValue) paramlist

449

622

450 hoistClientMonad pm _ f cl = \as ->

623 hoistClientMonad pm _ f cl = \as ->

451 hoistClientMonad pm (Proxy :: Proxy api) f (cl as)

624 hoistClientMonad pm (Proxy :: Proxy api) f (cl as)

@@ -538,7 +711,7 @@ instance (MimeRender ct a, HasClient m api)

538 hoistClientMonad pm (Proxy :: Proxy api) f (cl a)

711 hoistClientMonad pm (Proxy :: Proxy api) f (cl a)

539

712

540instance

713instance

541− ( HasClient m api

714+ ( HasClient m api, MimeRender ctype chunk, FramingRender framing, ToSourceIO chunk a

542 ) => HasClient m (StreamBody' mods framing ctype a :> api)

715 ) => HasClient m (StreamBody' mods framing ctype a :> api)

543 where

716 where

544

717

@@ -547,7 +720,17 @@ instance

547 hoistClientMonad pm _ f cl = \a ->

720 hoistClientMonad pm _ f cl = \a ->

548 hoistClientMonad pm (Proxy :: Proxy api) f (cl a)

721 hoistClientMonad pm (Proxy :: Proxy api) f (cl a)

549

722

550− clientWithRoute _pm Proxy _req _body = error "HasClient @StreamBody"

723+ clientWithRoute pm Proxy req body

724+ = clientWithRoute pm (Proxy :: Proxy api)

725+ $ setRequestBody (RequestBodySource sourceIO) (contentType ctypeP) req

726+ where

727+ ctypeP = Proxy :: Proxy ctype

728+ framingP = Proxy :: Proxy framing

729+

730+ sourceIO = framingRender

731+ framingP

732+ (mimeRender ctypeP :: chunk -> BL.ByteString)

733+ (toSourceIO body)

551

734

552-- | Make the querying function append @path@ to the request path.

735-- | Make the querying function append @path@ to the request path.

553instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where

736instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where

@@ -557,7 +740,7 @@ instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where

557 clientWithRoute pm (Proxy :: Proxy api)

740 clientWithRoute pm (Proxy :: Proxy api)

558 (appendToPath p req)

741 (appendToPath p req)

559

742

560− where p = pack $ symbolVal (Proxy :: Proxy path)

743+ where p = toEncodedUrlPiece $ pack $ symbolVal (Proxy :: Proxy path)

561

744

562 hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl

745 hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl

563

746

@@ -604,6 +787,29 @@ instance ( HasClient m api

604 hoistClientMonad pm _ f cl = \authreq ->

787 hoistClientMonad pm _ f cl = \authreq ->

605 hoistClientMonad pm (Proxy :: Proxy api) f (cl authreq)

788 hoistClientMonad pm (Proxy :: Proxy api) f (cl authreq)

606

789

790+-- | Ignore @'Fragment'@ in client functions.

791+-- See <https://ietf.org/rfc/rfc2616.html#section-15.1.3> for more details.

792+--

793+-- Example:

794+--

795+-- > type MyApi = "books" :> Fragment Text :> Get '[JSON] [Book]

796+-- >

797+-- > myApi :: Proxy MyApi

798+-- > myApi = Proxy

799+-- >

800+-- > getBooks :: ClientM [Book]

801+-- > getBooks = client myApi

802+-- > -- then you can just use "getBooksBy" to query that endpoint.

803+-- > -- 'getBooks' for all books.

804+instance (AtLeastOneFragment api, FragmentUnique (Fragment a :> api), HasClient m api

805+ ) => HasClient m (Fragment a :> api) where

806+

807+ type Client m (Fragment a :> api) = Client m api

808+

809+ clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api)

810+

811+ hoistClientMonad pm _ = hoistClientMonad pm (Proxy :: Proxy api)

812+

607-- * Basic Authentication

813-- * Basic Authentication

608

814

609instance HasClient m api => HasClient m (BasicAuth realm usr :> api) where

815instance HasClient m api => HasClient m (BasicAuth realm usr :> api) where

@@ -615,6 +821,120 @@ instance HasClient m api => HasClient m (BasicAuth realm usr :> api) where

615 hoistClientMonad pm _ f cl = \bauth ->

821 hoistClientMonad pm _ f cl = \bauth ->

616 hoistClientMonad pm (Proxy :: Proxy api) f (cl bauth)

822 hoistClientMonad pm (Proxy :: Proxy api) f (cl bauth)

617

823

824+-- | A type that specifies that an API record contains a client implementation.

825+data AsClientT (m :: * -> *)

826+instance GenericMode (AsClientT m) where

827+ type AsClientT m :- api = Client m api

828+

829+

830+type GClientConstraints api m =

831+ ( GenericServant api (AsClientT m)

832+ , Client m (ToServantApi api) ~ ToServant api (AsClientT m)

833+ )

834+

835+class GClient (api :: * -> *) m where

836+ gClientProof :: Dict (GClientConstraints api m)

837+

838+instance GClientConstraints api m => GClient api m where

839+ gClientProof = Dict

840+

841+instance

842+ ( forall n. GClient api n

843+ , HasClient m (ToServantApi api)

844+ , RunClient m

845+ )

846+ => HasClient m (NamedRoutes api) where

847+ type Client m (NamedRoutes api) = api (AsClientT m)

848+

849+ clientWithRoute :: Proxy m -> Proxy (NamedRoutes api) -> Request -> Client m (NamedRoutes api)

850+ clientWithRoute pm _ request =

851+ case gClientProof @api @m of

852+ Dict -> fromServant $ clientWithRoute pm (Proxy @(ToServantApi api)) request

853+

854+ hoistClientMonad

855+ :: forall ma mb.

856+ Proxy m

857+ -> Proxy (NamedRoutes api)

858+ -> (forall x. ma x -> mb x)

859+ -> Client ma (NamedRoutes api)

860+ -> Client mb (NamedRoutes api)

861+ hoistClientMonad _ _ nat clientA =

862+ case (gClientProof @api @ma, gClientProof @api @mb) of

863+ (Dict, Dict) ->

864+ fromServant @api @(AsClientT mb) $

865+ hoistClientMonad @m @(ToServantApi api) @ma @mb Proxy Proxy nat $

866+ toServant @api @(AsClientT ma) clientA

867+

868+infixl 1 //

869+infixl 2 /:

870+

871+-- | Helper to make code using records of clients more readable.

872+--

873+-- Can be mixed with (/:) for supplying arguments.

874+--

875+-- Example:

876+--

877+-- @

878+-- type Api = NamedRoutes RootApi

879+--

880+-- data RootApi mode = RootApi

881+-- { subApi :: mode :- NamedRoutes SubApi

882+-- , …

883+-- } deriving Generic

884+--

885+-- data SubApi mode = SubApi

886+-- { endpoint :: mode :- Get '[JSON] Person

887+-- , …

888+-- } deriving Generic

889+--

890+-- api :: Proxy API

891+-- api = Proxy

892+--

893+-- rootClient :: RootApi (AsClientT ClientM)

894+-- rootClient = client api

895+--

896+-- endpointClient :: ClientM Person

897+-- endpointClient = client // subApi // endpoint

898+-- @

899+(//) :: a -> (a -> b) -> b

900+x // f = f x

901+

902+-- | Convenience function for supplying arguments to client functions when

903+-- working with records of clients.

904+--

905+-- Intended to be used in conjunction with '(//)'.

906+--

907+-- Example:

908+--

909+-- @

910+-- type Api = NamedRoutes RootApi

911+--

912+-- data RootApi mode = RootApi

913+-- { subApi :: mode :- Capture "token" String :> NamedRoutes SubApi

914+-- , hello :: mode :- Capture "name" String :> Get '[JSON] String

915+-- , …

916+-- } deriving Generic

917+--

918+-- data SubApi mode = SubApi

919+-- { endpoint :: mode :- Get '[JSON] Person

920+-- , …

921+-- } deriving Generic

922+--

923+-- api :: Proxy API

924+-- api = Proxy

925+--

926+-- rootClient :: RootApi (AsClientT ClientM)

927+-- rootClient = client api

928+--

929+-- hello :: String -> ClientM String

930+-- hello name = rootClient // hello /: name

931+--

932+-- endpointClient :: ClientM Person

933+-- endpointClient = client // subApi /: "foobar123" // endpoint

934+-- @

935+(/:) :: (a -> b -> c) -> b -> a -> c

936+(/:) = flip

937+

618

938

619{- Note [Non-Empty Content Types]

939{- Note [Non-Empty Content Types]

620~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

940~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

@@ -631,3 +951,43 @@ non-empty lists, but is otherwise more specific, no instance will be overall

631more specific. This in turn generally means adding yet another instance (one

951more specific. This in turn generally means adding yet another instance (one

632for empty and one for non-empty lists).

952for empty and one for non-empty lists).

633-}

953-}

954+

955+-------------------------------------------------------------------------------

956+-- helpers

957+-------------------------------------------------------------------------------

958+

959+checkContentTypeHeader :: RunClient m => Response -> m MediaType

960+checkContentTypeHeader response =

961+ case lookup "Content-Type" $ toList $ responseHeaders response of

962+ Nothing -> return $ "application" Media.// "octet-stream"

963+ Just t -> case parseAccept t of

964+ Nothing -> throwClientError $ InvalidContentTypeHeader response

965+ Just t' -> return t'

966+

967+decodedAs :: forall ct a m. (MimeUnrender ct a, RunClient m)

968+ => Response -> Proxy ct -> m a

969+decodedAs response ct = do

970+ responseContentType <- checkContentTypeHeader response

971+ unless (any (matches responseContentType) accept) $

972+ throwClientError $ UnsupportedContentType responseContentType response

973+ case mimeUnrender ct $ responseBody response of

974+ Left err -> throwClientError $ DecodeFailure (T.pack err) response

975+ Right val -> return val

976+ where

977+ accept = toList $ contentTypes ct

978+

979+-------------------------------------------------------------------------------

980+-- Custom type errors

981+-------------------------------------------------------------------------------

982+

983+-- Erroring instance for HasClient' when a combinator is not fully applied

984+instance (RunClient m, TypeError (PartialApplication HasClient arr)) => HasClient m ((arr :: a -> b) :> sub)

985+ where

986+ type Client m (arr :> sub) = TypeError (PartialApplication HasClient arr)

987+ clientWithRoute _ _ _ = error "unreachable"

988+ hoistClientMonad _ _ _ _ = error "unreachable"

989+

990+-- Erroring instances for 'HasClient' for unknown API combinators

991+instance {-# OVERLAPPABLE #-} (RunClient m, TypeError (NoInstanceForSub (HasClient m) ty)) => HasClient m (ty :> sub)

992+

993+instance {-# OVERLAPPABLE #-} (RunClient m, TypeError (NoInstanceFor (HasClient m api))) => HasClient m api

servant-client-core/src/Servant/Client/Core/Internal.hsnew file+12

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

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/Internal/ClientF.hsdeleted−10

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

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

@@ -1,155 +0,0 @@

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/Internal/Request.hsdeleted−164

@@ -1,164 +0,0 @@

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

19− (NFData (..))

20−import Control.Monad.Catch

21− (Exception)

22−import qualified Data.ByteString as BS

23−import qualified Data.ByteString.Builder as Builder

24−import qualified Data.ByteString.Lazy as LBS

25−import Data.Int

26− (Int64)

27−import Data.Semigroup

28− ((<>))

29−import qualified Data.Sequence as Seq

30−import Data.Text

31− (Text)

32−import Data.Text.Encoding

33− (encodeUtf8)

34−import Data.Typeable

35− (Typeable)

36−import GHC.Generics

37− (Generic)

38−import Network.HTTP.Media

39− (MediaType, mainType, parameters, subType)

40−import Network.HTTP.Types

41− (Header, HeaderName, HttpVersion (..), Method, QueryItem,

42− Status (..), http11, methodGet)

43−import Servant.API

44− (ToHttpApiData, toEncodedUrlPiece, toHeader)

45−

46−-- | A type representing possible errors in a request

47−--

48−-- Note that this type substantially changed in 0.12.

49−data ServantError =

50− -- | The server returned an error response

51− FailureResponse Response

52− -- | The body could not be decoded at the expected type

53− | DecodeFailure Text Response

54− -- | The content-type of the response is not supported

55− | UnsupportedContentType MediaType Response

56− -- | The content-type header is invalid

57− | InvalidContentTypeHeader Response

58− -- | There was a connection error, and no response was received

59− | ConnectionError Text

60− deriving (Eq, Show, Generic, Typeable)

61−

62−instance Exception ServantError

63−

64−instance NFData ServantError where

65− rnf (FailureResponse res) = rnf res

66− rnf (DecodeFailure err res) = rnf err `seq` rnf res

67− rnf (UnsupportedContentType mt' res) =

68− mediaTypeRnf mt' `seq`

69− rnf res

70− where

71− mediaTypeRnf mt =

72− rnf (mainType mt) `seq`

73− rnf (subType mt) `seq`

74− rnf (parameters mt)

75− rnf (InvalidContentTypeHeader res) = rnf res

76− rnf (ConnectionError err) = rnf err

77−

78−data RequestF a = Request

79− { requestPath :: a

80− , requestQueryString :: Seq.Seq QueryItem

81− , requestBody :: Maybe (RequestBody, MediaType)

82− , requestAccept :: Seq.Seq MediaType

83− , requestHeaders :: Seq.Seq Header

84− , requestHttpVersion :: HttpVersion

85− , requestMethod :: Method

86− } deriving (Generic, Typeable)

87−

88−type Request = RequestF Builder.Builder

89−

90−-- | The request body. A replica of the @http-client@ @RequestBody@.

91−data RequestBody

92− = RequestBodyLBS LBS.ByteString

93− | RequestBodyBS BS.ByteString

94− | RequestBodyBuilder Int64 Builder.Builder

95− | RequestBodyStream Int64 ((IO BS.ByteString -> IO ()) -> IO ())

96− | RequestBodyStreamChunked ((IO BS.ByteString -> IO ()) -> IO ())

97− | RequestBodyIO (IO RequestBody)

98− deriving (Generic, Typeable)

99−

100−data GenResponse a = Response

101− { responseStatusCode :: Status

102− , responseHeaders :: Seq.Seq Header

103− , responseHttpVersion :: HttpVersion

104− , responseBody :: a

105− } deriving (Eq, Show, Generic, Typeable, Functor, Foldable, Traversable)

106−

107−instance NFData a => NFData (GenResponse a) where

108− rnf (Response sc hs hv body) =

109− rnfStatus sc `seq`

110− rnf hs `seq`

111− rnfHttpVersion hv `seq`

112− rnf body

113− where

114− rnfStatus (Status code msg) = rnf code `seq` rnf msg

115− rnfHttpVersion (HttpVersion _ _) = () -- HttpVersion fields are strict

116−

117−type Response = GenResponse LBS.ByteString

118−type StreamingResponse = GenResponse (IO BS.ByteString)

119−

120−-- A GET request to the top-level path

121−defaultRequest :: Request

122−defaultRequest = Request

123− { requestPath = ""

124− , requestQueryString = Seq.empty

125− , requestBody = Nothing

126− , requestAccept = Seq.empty

127− , requestHeaders = Seq.empty

128− , requestHttpVersion = http11

129− , requestMethod = methodGet

130− }

131−

132−appendToPath :: Text -> Request -> Request

133−appendToPath p req

134− = req { requestPath = requestPath req <> "/" <> toEncodedUrlPiece p }

135−

136−appendToQueryString :: Text -- ^ param name

137− -> Maybe Text -- ^ param value

138− -> Request

139− -> Request

140−appendToQueryString pname pvalue req

141− = req { requestQueryString = requestQueryString req

142− Seq.|> (encodeUtf8 pname, encodeUtf8 <$> pvalue)}

143−

144−addHeader :: ToHttpApiData a => HeaderName -> a -> Request -> Request

145−addHeader name val req

146− = req { requestHeaders = requestHeaders req Seq.|> (name, toHeader val)}

147−

148−-- | Set body and media type of the request being constructed.

149−--

150−-- The body is set to the given bytestring using the 'RequestBodyLBS'

151−-- constructor.

152−--

153−-- @since 0.12

154−--

155−setRequestBodyLBS :: LBS.ByteString -> MediaType -> Request -> Request

156−setRequestBodyLBS b t req

157− = req { requestBody = Just (RequestBodyLBS b, t) }

158−

159−-- | Set body and media type of the request being constructed.

160−--

161−-- @since 0.12

162−--

163−setRequestBody :: RequestBody -> MediaType -> Request -> Request

164−setRequestBody b t req = req { requestBody = Just (b, t) }

servant-client-core/src/Servant/Client/Core/Internal/RunClient.hsdeleted−67

@@ -1,67 +0,0 @@

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− throwServantError :: ServantError -> m a

35−

36−class RunClient m => RunStreamingClient m where

37− withStreamingRequest :: Request -> (StreamingResponse -> IO a) -> m a

38−

39−checkContentTypeHeader :: RunClient m => Response -> m MediaType

40−checkContentTypeHeader response =

41− case lookup "Content-Type" $ toList $ responseHeaders response of

42− Nothing -> return $ "application"//"octet-stream"

43− Just t -> case parseAccept t of

44− Nothing -> throwServantError $ InvalidContentTypeHeader response

45− Just t' -> return t'

46−

47−decodedAs :: forall ct a m. (MimeUnrender ct a, RunClient m)

48− => Response -> Proxy ct -> m a

49−decodedAs response contentType = do

50− responseContentType <- checkContentTypeHeader response

51− unless (any (matches responseContentType) accept) $

52− throwServantError $ UnsupportedContentType responseContentType response

53− case mimeUnrender contentType $ responseBody response of

54− Left err -> throwServantError $ DecodeFailure (T.pack err) response

55− Right val -> return val

56− where

57− accept = toList $ contentTypes contentType

58−

59−instance ClientF ~ f => RunClient (Free f) where

60− runRequest req = liftF (RunRequest req id)

61− throwServantError = liftF . Throw

62−

63−{-

64−Free and streaming?

65−instance ClientF ~ f => RunStreamingClient (Free f) where

66− streamingRequest req = liftF (StreamingRequest req id)

67−-}

servant-client-core/src/Servant/Client/Core/Reexport.hs+13−10

@@ -5,17 +5,19 @@ module Servant.Client.Core.Reexport

5 (

5 (

6 -- * HasClient

6 -- * HasClient

7 HasClient(..)

7 HasClient(..)

8+ , foldMapUnion

9+ , matchUnion

10+ , AsClientT

11+ , (//)

12+ , (/:)

8

13

9 -- * Response (for @Raw@)

14 -- * Response (for @Raw@)

10 , Response

15 , Response

11 , StreamingResponse

16 , StreamingResponse

12− , GenResponse(..)

17+ , ResponseF(..)

13

18

14− -- * Generic Client

19+ -- * Data types

15− , ClientLike(..)

20+ , ClientError(..)

16− , genericMkClientL

17− , genericMkClientP

18− , ServantError(..)

19 , EmptyClient(..)

21 , EmptyClient(..)

20

22

21 -- * BaseUrl

23 -- * BaseUrl

@@ -24,10 +26,11 @@ module Servant.Client.Core.Reexport

24 , showBaseUrl

26 , showBaseUrl

25 , parseBaseUrl

27 , parseBaseUrl

26 , InvalidBaseUrlException

28 , InvalidBaseUrlException

29+

27 ) where

30 ) where

28

31

29

32

30−import Servant.Client.Core.Internal.BaseUrl

33+import Servant.Client.Core.BaseUrl

31−import Servant.Client.Core.Internal.Generic

34+import Servant.Client.Core.HasClient

32−import Servant.Client.Core.Internal.HasClient

33−import Servant.Client.Core.Internal.Request

35+import Servant.Client.Core.Response

36+import Servant.Client.Core.ClientError

servant-client-core/src/Servant/Client/Core/Request.hsnew file+193

@@ -0,0 +1,193 @@

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, urlEncodeBuilder)

55+import Servant.API

56+ (ToHttpApiData, toEncodedUrlPiece, toQueryParam, 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

169+ . urlEncodeBuilder True . encodeUtf8 . toQueryParam

170+

171+-- | Add header to the request being constructed.

172+--

173+addHeader :: ToHttpApiData a => HeaderName -> a -> Request -> Request

174+addHeader name val req

175+ = req { requestHeaders = requestHeaders req Seq.|> (name, toHeader val)}

176+

177+-- | Set body and media type of the request being constructed.

178+--

179+-- The body is set to the given bytestring using the 'RequestBodyLBS'

180+-- constructor.

181+--

182+-- @since 0.12

183+--

184+setRequestBodyLBS :: LBS.ByteString -> MediaType -> Request -> Request

185+setRequestBodyLBS b t req

186+ = req { requestBody = Just (RequestBodyLBS b, t) }

187+

188+-- | Set body and media type of the request being constructed.

189+--

190+-- @since 0.12

191+--

192+setRequestBody :: RequestBody -> MediaType -> Request -> Request

193+setRequestBody b t req = req { requestBody = Just (b, t) }

servant-client-core/src/Servant/Client/Core/Response.hsnew file+53

@@ -0,0 +1,53 @@

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.hsnew file+55

@@ -0,0 +1,55 @@

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

15import Servant.Client.Core.Reexport

14import 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+8−11

@@ -1,9 +1,10 @@

1−{-# LANGUAGE ConstraintKinds #-}

1+{-# OPTIONS_GHC -fno-warn-orphans #-}

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+

7module Servant.Client.Generic (

8module Servant.Client.Generic (

8 AsClientT,

9 AsClientT,

9 genericClient,

10 genericClient,

@@ -15,11 +16,7 @@ import Data.Proxy

15

16

16import Servant.API.Generic

17import Servant.API.Generic

17import Servant.Client.Core

18import Servant.Client.Core

18−

19+import Servant.Client.Core.HasClient (AsClientT)

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

23

20

24-- | Generate a record of client functions.

21-- | Generate a record of client functions.

25genericClient

22genericClient

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.Internal.BaseUrl

11+import Servant.Client.Core.BaseUrl

12

12

13spec :: Spec

13spec :: Spec

14spec = do

14spec = do

servant-client-core/test/Servant/Client/Core/RequestSpec.hsnew file+31

@@ -0,0 +1,31 @@

1+{-# OPTIONS_GHC -fno-warn-orphans #-}

2+{-# LANGUAGE OverloadedStrings #-}

3+module Servant.Client.Core.RequestSpec (spec) where

4+

5+

6+import Prelude ()

7+import Prelude.Compat

8+import Control.Monad

9+import Data.List (isInfixOf)

10+import Servant.Client.Core.Request

11+import Test.Hspec

12+

13+newtype DataWithRequest = DataWithRequest (RequestF RequestBody ())

14+ deriving Show

15+

16+spec :: Spec

17+spec = do

18+ describe "Request" $ do

19+ describe "show" $ do

20+ it "has parenthesis correctly positioned" $ do

21+ let d = DataWithRequest (void defaultRequest)

22+ show d `shouldBe` "DataWithRequest (Request {requestPath = ()\

23+ \, requestQueryString = fromList []\

24+ \, requestBody = Nothing\

25+ \, requestAccept = fromList []\

26+ \, requestHeaders = fromList []\

27+ \, requestHttpVersion = HTTP/1.1\

28+ \, requestMethod = \"GET\"})"

29+ it "redacts the authorization header" $ do

30+ let request = void $ defaultRequest { requestHeaders = pure ("authorization", "secret") }

31+ isInfixOf "secret" (show request) `shouldBe` False

servant-client-ghcjs/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://haskell-servant.readthedocs.io) is recommended if you're new to the subject.

7+This guide assumes knowledge of servant. Reading its [documentation](http://docs.servant.dev) 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://haskell-servant.readthedocs.io/en/stable/tutorial/Client.html) section in the servant documentation)

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)

13

13

14```haskell

14```haskell

15{-# LANGUAGE DataKinds #-}

15{-# LANGUAGE DataKinds #-}

servant-client-ghcjs/servant-client-ghcjs.cabal+38−38

@@ -1,64 +1,64 @@

1−cabal-version: >=1.10

1+cabal-version: 2.2

2−name: servant-client-ghcjs

2+name: servant-client-ghcjs

3−version: 0.14

3+version: 0.16

4+synopsis:

5+ Automatic derivation of querying functions for servant webservices for GHCJS

4

6

5−synopsis: Automatic derivation of querying functions for servant webservices for GHCJS

6−category: Servant, Web

7+category: Servant, Web

7description:

8description:

8 This library lets you automatically derive Haskell functions that

9 This library lets you automatically derive Haskell functions that

9 let you query each endpoint of a <http://hackage.haskell.org/package/servant servant> webservice.

10 let you query each endpoint of a <http://hackage.haskell.org/package/servant servant> webservice.

10 .

11 .

11− See <http://haskell-servant.readthedocs.org/en/stable/tutorial/Client.html the client section of the tutorial>.

12+ See <http://docs.servant.dev/en/stable/tutorial/Client.html the client section of the tutorial>.

12 .

13 .

13 <https://github.com/haskell-servant/servant/blob/master/servant-client/CHANGELOG.md CHANGELOG>

14 <https://github.com/haskell-servant/servant/blob/master/servant-client/CHANGELOG.md CHANGELOG>

14

15

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

16+homepage: http://docs.servant.dev/

16−bug-reports: http://github.com/haskell-servant/servant/issues

17+bug-reports: http://github.com/haskell-servant/servant/issues

17−license: BSD3

18+license: BSD-3-Clause

18−license-file: LICENSE

19+license-file: LICENSE

19−author: Servant Contributors

20+author: Servant Contributors

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

21+maintainer: haskell-servant-maintainers@googlegroups.com

22+copyright:

21−copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2018 Servant Contributors

23+ 2014-2016 Zalora South East Asia Pte Ltd, 2016-2018 Servant Contributors

22−build-type: Simple

23−tested-with:

24− GHC >= 7.8

25

24

25+build-type: Simple

26+tested-with: ghc >=7.8

26extra-source-files:

27extra-source-files:

27 CHANGELOG.md

28 CHANGELOG.md

28 README.md

29 README.md

29

30

30source-repository head

31source-repository head

31− type: git

32+ type: git

32 location: http://github.com/haskell-servant/servant.git

33 location: http://github.com/haskell-servant/servant.git

33

34

34library

35library

35 exposed-modules:

36 exposed-modules:

36 Servant.Client.Ghcjs

37 Servant.Client.Ghcjs

37 Servant.Client.Internal.XhrClient

38 Servant.Client.Internal.XhrClient

38− build-depends:

39− base >= 4.7 && < 4.12

40− , bytestring >= 0.10 && < 0.11

41− , case-insensitive >= 1.2.0.0 && < 1.3.0.0

42− , containers >= 0.5 && < 0.6

43− , exceptions >= 0.8 && < 0.11

44− , ghcjs-base >= 0.2.0.0 && < 0.3.0.0

45− , ghcjs-prim >= 0.1.0.0 && < 0.2.0.0

46− , http-media >= 0.6.2 && < 0.8

47− , http-types >= 0.12 && < 0.13

48− , monad-control >= 1.0.0.4 && < 1.1

49− , mtl >= 2.2.2 && < 2.3

50− , semigroupoids >= 4.3 && < 5.3

51− , string-conversions >= 0.3 && < 0.5

52− , transformers >= 0.3 && < 0.6

53− , transformers-base >= 0.4.4 && < 0.5

54

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

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

55

56

56 -- strict, as we re-export stuff

57 -- strict, as we re-export stuff

57 build-depends:

58 build-depends:

59+ servant >=0.16 && <0.20

58− servant-client-core == 0.15

60+ , servant-client-core >=0.16 && <0.20

59

61

60− hs-source-dirs: src

62+ hs-source-dirs: src

61 default-language: Haskell2010

63 default-language: Haskell2010

62− ghc-options: -Wall

63− if impl(ghc >= 8.0)

64− ghc-options: -Wno-redundant-constraints

64+ ghc-options: -Wall -Wno-redundant-constraints

servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs+52−47

@@ -18,35 +18,48 @@ 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 (MonadBase (..))

21+import Control.Monad.Base

22+ (MonadBase (..))

22−import Control.Monad.Catch (MonadCatch, MonadThrow)

23+import Control.Monad.Catch

24+ (MonadCatch, MonadThrow)

23−import Control.Monad.Error.Class (MonadError (..))

25+import Control.Monad.Error.Class

26+ (MonadError (..))

24import Control.Monad.Reader

27import Control.Monad.Reader

25−import Control.Monad.Trans.Control (MonadBaseControl (..))

28+import Control.Monad.Trans.Control

29+ (MonadBaseControl (..))

26import Control.Monad.Trans.Except

30import Control.Monad.Trans.Except

31+import Data.Bifunctor

32+ (bimap)

33+import Data.ByteString.Builder

27−import Data.ByteString.Builder (toLazyByteString)

34+ (toLazyByteString)

28−import qualified Data.ByteString.Char8 as BS

35+import qualified Data.ByteString.Char8 as BS

29−import qualified Data.ByteString.Lazy as BL

36+import qualified Data.ByteString.Lazy as BL

30import Data.CaseInsensitive

37import Data.CaseInsensitive

31import Data.Char

38import Data.Char

32−import Data.Foldable (toList)

39+import Data.Foldable

40+ (toList)

33−import Data.Functor.Alt (Alt (..))

41+import Data.Functor.Alt

34−import Data.IORef (modifyIORef, newIORef, readIORef)

42+ (Alt (..))

43+import Data.Proxy

35−import Data.Proxy (Proxy (..))

44+ (Proxy (..))

36−import qualified Data.Sequence as Seq

45+import qualified Data.Sequence as Seq

37import Data.String.Conversions

46import Data.String.Conversions

38−import Data.Typeable (Typeable)

47+import Data.Typeable

48+ (Typeable)

39import Foreign.StablePtr

49import Foreign.StablePtr

40import GHC.Generics

50import GHC.Generics

41−import qualified GHCJS.Buffer as Buffer

51+import qualified GHCJS.Buffer as Buffer

42import GHCJS.Foreign.Callback

52import GHCJS.Foreign.Callback

43import GHCJS.Prim

53import GHCJS.Prim

44import GHCJS.Types

54import GHCJS.Types

45−import JavaScript.TypedArray.ArrayBuffer ( ArrayBuffer )

55+import JavaScript.TypedArray.ArrayBuffer

56+ (ArrayBuffer)

46import JavaScript.Web.Location

57import JavaScript.Web.Location

47−import Network.HTTP.Media (renderHeader)

58+import Network.HTTP.Media

59+ (renderHeader)

48import Network.HTTP.Types

60import Network.HTTP.Types

49import Servant.Client.Core

61import Servant.Client.Core

62+import qualified Servant.Types.SourceT as S

50

63

51newtype JSXMLHttpRequest = JSXMLHttpRequest JSVal

64newtype JSXMLHttpRequest = JSXMLHttpRequest JSVal

52

65

@@ -81,16 +94,16 @@ client api = api `clientIn` (Proxy :: Proxy ClientM)

81--

94--

82-- NOTE: Does not support constant space streaming of the request body!

95-- NOTE: Does not support constant space streaming of the request body!

83newtype ClientM a = ClientM

96newtype ClientM a = ClientM

84− { runClientM' :: ReaderT ClientEnv (ExceptT ServantError IO) a }

97+ { runClientM' :: ReaderT ClientEnv (ExceptT ClientError IO) a }

85 deriving ( Functor, Applicative, Monad, MonadIO, Generic

98 deriving ( Functor, Applicative, Monad, MonadIO, Generic

86− , MonadReader ClientEnv, MonadError ServantError, MonadThrow

99+ , MonadReader ClientEnv, MonadError ClientError, MonadThrow

87 , MonadCatch)

100 , MonadCatch)

88

101

89instance MonadBase IO ClientM where

102instance MonadBase IO ClientM where

90 liftBase = ClientM . liftBase

103 liftBase = ClientM . liftBase

91

104

92instance MonadBaseControl IO ClientM where

105instance MonadBaseControl IO ClientM where

93− type StM ClientM a = Either ServantError a

106+ type StM ClientM a = Either ClientError a

94

107

95 liftBaseWith f = ClientM (liftBaseWith (\g -> f (g . runClientM')))

108 liftBaseWith f = ClientM (liftBaseWith (\g -> f (g . runClientM')))

96

109

@@ -107,16 +120,13 @@ instance Exception StreamingNotSupportedException where

107 displayException _ = "streamingRequest: streaming is not supported!"

120 displayException _ = "streamingRequest: streaming is not supported!"

108

121

109instance RunClient ClientM where

122instance RunClient ClientM where

110− runRequest = performRequest

123+ runRequestAcceptStatus = performRequest

111− throwServantError = throwError

124+ throwClientError = throwError

112

125

113−instance ClientLike (ClientM a) (ClientM a) where

114− mkClient = id

115−

116−runClientMOrigin :: ClientM a -> ClientEnv -> IO (Either ServantError a)

126+runClientMOrigin :: ClientM a -> ClientEnv -> IO (Either ClientError a)

117runClientMOrigin cm env = runExceptT $ flip runReaderT env $ runClientM' cm

127runClientMOrigin cm env = runExceptT $ flip runReaderT env $ runClientM' cm

118

128

119−runClientM :: ClientM a -> IO (Either ServantError a)

129+runClientM :: ClientM a -> IO (Either ClientError a)

120runClientM m = do

130runClientM m = do

121 curLoc <- getWindowLocation

131 curLoc <- getWindowLocation

122

132

@@ -142,16 +152,20 @@ runClientM m = do

142

152

143 runClientMOrigin m (ClientEnv (BaseUrl protocol hostname port ""))

153 runClientMOrigin m (ClientEnv (BaseUrl protocol hostname port ""))

144

154

145−performRequest :: Request -> ClientM Response

155+performRequest :: Maybe [Status] -> Request -> ClientM Response

146−performRequest req = do

156+performRequest acceptStatus req = do

147 xhr <- liftIO initXhr

157 xhr <- liftIO initXhr

148 burl <- asks baseUrl

158 burl <- asks baseUrl

149 liftIO $ performXhr xhr burl req

159 liftIO $ performXhr xhr burl req

150 resp <- toResponse xhr

160 resp <- toResponse xhr

151

161

152− let status = statusCode (responseStatusCode resp)

162+ let status = responseStatusCode resp

153− unless (status >= 200 && status < 300) $

163+ goodStatus = case acceptStatus of

164+ Nothing -> statusIsSuccessful status

165+ Just good -> status `elem` good

166+ unless goodStatus $ do

167+ let f b = (burl, BL.toStrict $ toLazyByteString b)

154− throwError $ FailureResponse resp

168+ throwError $ FailureResponse (bimap (const ()) f req) resp

155

169

156 pure resp

170 pure resp

157

171

@@ -270,38 +284,29 @@ toBody request = case requestBody request of

270 where

284 where

271 go :: RequestBody -> IO ArrayBuffer

285 go :: RequestBody -> IO ArrayBuffer

272 go x = case x of

286 go x = case x of

273− RequestBodyLBS x -> return $ mBody $ BL.toStrict x

287+ RequestBodyLBS x -> return $ mBody $ BL.toStrict x

274− RequestBodyBS x -> return $ mBody x

288+ RequestBodyBS x -> return $ mBody x

275− RequestBodyBuilder _ x -> return $ mBody $ BL.toStrict $ toLazyByteString x

289+ RequestBodySource xs -> runExceptT (S.runSourceT xs) >>= \e -> case e of

276− RequestBodyStream _ x -> mBody <$> readBody x

290+ Left err -> fail err

277− RequestBodyStreamChunked x -> mBody <$> readBody x

291+ Right bss -> return $ mBody $ BL.toStrict $ mconcat bss

278− RequestBodyIO x -> x >>= go

279

292

280 mBody :: BS.ByteString -> ArrayBuffer

293 mBody :: BS.ByteString -> ArrayBuffer

281 mBody bs = js_bufferSlice offset len $ Buffer.getArrayBuffer buffer

294 mBody bs = js_bufferSlice offset len $ Buffer.getArrayBuffer buffer

282 where

295 where

283 (buffer, offset, len) = Buffer.fromByteString bs

296 (buffer, offset, len) = Buffer.fromByteString bs

284

297

285− readBody :: ((IO BS.ByteString -> IO ()) -> IO a) -> IO BS.ByteString

286− readBody writer = do

287− m <- newIORef mempty

288− _ <- writer (\bsAct -> do

289− bs <- bsAct

290− modifyIORef m (<> bs))

291− readIORef m

292−

293foreign import javascript unsafe "$3.slice($1, $1 + $2)"

298foreign import javascript unsafe "$3.slice($1, $1 + $2)"

294 js_bufferSlice :: Int -> Int -> ArrayBuffer -> ArrayBuffer

299 js_bufferSlice :: Int -> Int -> ArrayBuffer -> ArrayBuffer

295

300

296-- * inspecting the xhr response

301-- * inspecting the xhr response

297

302

298-- This function is only supposed to handle 'ConnectionError's. Other

303-- This function is only supposed to handle 'ConnectionError's. Other

299−-- 'ServantError's are created in Servant.Client.Req.

304+-- 'ClientError's are created in Servant.Client.Req.

300toResponse :: JSXMLHttpRequest -> ClientM Response

305toResponse :: JSXMLHttpRequest -> ClientM Response

301toResponse xhr = do

306toResponse xhr = do

302 status <- liftIO $ getStatus xhr

307 status <- liftIO $ getStatus xhr

303 case status of

308 case status of

304− 0 -> throwError $ ConnectionError "connection error"

309+ 0 -> throwError $ ConnectionError (SomeException (userError "connection error"))

305 _ -> liftIO $ do

310 _ -> liftIO $ do

306 statusText <- cs <$> getStatusText xhr

311 statusText <- cs <$> getStatusText xhr

307 headers <- parseHeaders <$> getAllResponseHeaders xhr

312 headers <- parseHeaders <$> getAllResponseHeaders xhr

servant-client/CHANGELOG.md+172−2

@@ -1,6 +1,176 @@

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+

40.15

1740.15

5----

175----

6

176

@@ -97,9 +267,9 @@

97

267

98- *servant-client-core* Add `hoistClient` to `HasClient`.

268- *servant-client-core* Add `hoistClient` to `HasClient`.

99 Just like `hoistServer` allows us to change the monad in which request handlers

269 Just like `hoistServer` allows us to change the monad in which request handlers

100− of a web application live in, we also have `hoistClient` for changing the monad

270+ of a web application live, we also have `hoistClient` for changing the monad

101 in which *client functions* live.

271 in which *client functions* live.

102− 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).

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

103 ([#936](https://github.com/haskell-servant/servant/pull/936))

273 ([#936](https://github.com/haskell-servant/servant/pull/936))

104

274

105- *servant-client* Add more constructors to `RequestBody`, including

275- *servant-client* Add more constructors to `RequestBody`, including

servant-client/servant-client.cabal+44−31

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

1−cabal-version: >=1.10

1+cabal-version: 2.2

2name: servant-client

2name: servant-client

3−version: 0.15

3+version: 0.19

4−x-revision: 1

5

4

6synopsis: Automatic derivation of querying functions for servant

5synopsis: Automatic derivation of querying functions for servant

7category: Servant, Web

6category: Servant, Web

@@ -9,23 +8,20 @@ description:

9 This library lets you derive automatically Haskell functions that

8 This library lets you derive automatically Haskell functions that

10 let you query each endpoint of a <http://hackage.haskell.org/package/servant servant> webservice.

9 let you query each endpoint of a <http://hackage.haskell.org/package/servant servant> webservice.

11 .

10 .

12− See <http://haskell-servant.readthedocs.org/en/stable/tutorial/Client.html the client section of the tutorial>.

11+ See <http://docs.servant.dev/en/stable/tutorial/Client.html the client section of the tutorial>.

13 .

12 .

14 <https://github.com/haskell-servant/servant/blob/master/servant-client/CHANGELOG.md CHANGELOG>

13 <https://github.com/haskell-servant/servant/blob/master/servant-client/CHANGELOG.md CHANGELOG>

15

14

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

15+homepage: http://docs.servant.dev/

17bug-reports: http://github.com/haskell-servant/servant/issues

16bug-reports: http://github.com/haskell-servant/servant/issues

18−license: BSD3

17+license: BSD-3-Clause

19license-file: LICENSE

18license-file: LICENSE

20author: Servant Contributors

19author: Servant Contributors

21maintainer: haskell-servant-maintainers@googlegroups.com

20maintainer: haskell-servant-maintainers@googlegroups.com

22−copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2018 Servant Contributors

21+copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors

23build-type: Simple

22build-type: Simple

24−tested-with:

23+tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1

25− GHC ==8.0.2

24+ , GHCJS ==8.6.0.1

26− || ==8.2.2

27− || ==8.4.4

28− || ==8.6.2

29

25

30extra-source-files:

26extra-source-files:

31 CHANGELOG.md

27 CHANGELOG.md

@@ -45,35 +41,39 @@ library

45 -- Bundled with GHC: Lower bound to not force re-installs

41 -- Bundled with GHC: Lower bound to not force re-installs

46 -- text and mtl are bundled starting with GHC-8.4

42 -- text and mtl are bundled starting with GHC-8.4

47 build-depends:

43 build-depends:

48− base >= 4.9 && < 4.13

44+ base >= 4.9 && < 4.17

49− , bytestring >= 0.10.8.1 && < 0.11

45+ , bytestring >= 0.10.8.1 && < 0.12

50 , containers >= 0.5.7.1 && < 0.7

46 , containers >= 0.5.7.1 && < 0.7

51 , deepseq >= 1.4.2.0 && < 1.5

47 , deepseq >= 1.4.2.0 && < 1.5

52 , mtl >= 2.2.2 && < 2.3

48 , mtl >= 2.2.2 && < 2.3

53 , stm >= 2.4.5.1 && < 2.6

49 , stm >= 2.4.5.1 && < 2.6

54− , text >= 1.2.3.0 && < 1.3

50+ , text >= 1.2.3.0 && < 2.1

55− , time >= 1.6.0.1 && < 1.9

51+ , time >= 1.6.0.1 && < 1.12

56 , transformers >= 0.5.2.0 && < 0.6

52 , transformers >= 0.5.2.0 && < 0.6

57

53

54+ if !impl(ghc >= 8.2)

55+ build-depends:

56+ bifunctors >= 5.5.3 && < 5.6

57+

58 -- Servant dependencies.

58 -- Servant dependencies.

59 -- Strict dependency on `servant-client-core` as we re-export things.

59 -- Strict dependency on `servant-client-core` as we re-export things.

60 build-depends:

60 build-depends:

61− servant == 0.15.*

61+ servant >= 0.18 && < 0.20

62− , servant-client-core >= 0.15 && <0.15.1

62+ , servant-client-core >= 0.19 && < 0.19.1

63

63

64 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.

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

65 -- Here can be exceptions if we really need features from the newer versions.

66 build-depends:

66 build-depends:

67− base-compat >= 0.10.5 && < 0.11

67+ base-compat >= 0.10.5 && < 0.13

68− , http-client >= 0.5.13.1 && < 0.7

68+ , http-client >= 0.5.13.1 && < 0.8

69− , http-media >= 0.7.1.3 && < 0.8

69+ , http-media >= 0.7.1.3 && < 0.9

70 , http-types >= 0.12.2 && < 0.13

70 , http-types >= 0.12.2 && < 0.13

71 , exceptions >= 0.10.0 && < 0.11

71 , exceptions >= 0.10.0 && < 0.11

72 , kan-extensions >= 5.2 && < 5.3

72 , kan-extensions >= 5.2 && < 5.3

73 , monad-control >= 1.0.2.3 && < 1.1

73 , monad-control >= 1.0.2.3 && < 1.1

74 , semigroupoids >= 5.3.1 && < 5.4

74 , semigroupoids >= 5.3.1 && < 5.4

75 , transformers-base >= 0.4.5.2 && < 0.5

75 , transformers-base >= 0.4.5.2 && < 0.5

76− , transformers-compat >= 0.6.2 && < 0.7

76+ , transformers-compat >= 0.6.2 && < 0.8

77

77

78 hs-source-dirs: src

78 hs-source-dirs: src

79 default-language: Haskell2010

79 default-language: Haskell2010

@@ -83,11 +83,22 @@ test-suite spec

83 type: exitcode-stdio-1.0

83 type: exitcode-stdio-1.0

84 ghc-options: -Wall -rtsopts -threaded "-with-rtsopts=-T -N2"

84 ghc-options: -Wall -rtsopts -threaded "-with-rtsopts=-T -N2"

85 default-language: Haskell2010

85 default-language: Haskell2010

86+ if impl(ghcjs)

87+ buildable: False

86 hs-source-dirs: test

88 hs-source-dirs: test

87 main-is: Spec.hs

89 main-is: Spec.hs

88 other-modules:

90 other-modules:

89− Servant.ClientSpec

91+ Servant.BasicAuthSpec

92+ Servant.BrokenSpec

93+ Servant.ClientTestUtils

94+ Servant.ConnectionErrorSpec

95+ Servant.FailSpec

96+ Servant.GenAuthSpec

97+ Servant.GenericSpec

98+ Servant.HoistClientSpec

90 Servant.StreamSpec

99 Servant.StreamSpec

100+ Servant.SuccessSpec

101+ Servant.WrappedApiSpec

91

102

92 -- Dependencies inherited from the library. No need to specify bounds.

103 -- Dependencies inherited from the library. No need to specify bounds.

93 build-depends:

104 build-depends:

@@ -102,6 +113,7 @@ test-suite spec

102 , kan-extensions

113 , kan-extensions

103 , servant-client

114 , servant-client

104 , servant-client-core

115 , servant-client-core

116+ , sop-core

105 , stm

117 , stm

106 , text

118 , text

107 , transformers

119 , transformers

@@ -109,20 +121,19 @@ test-suite spec

109 , wai

121 , wai

110 , warp

122 , warp

111

123

112− -- Additonal dependencies

124+ -- Additional dependencies

113 build-depends:

125 build-depends:

114 entropy >= 0.4.1.3 && < 0.5

126 entropy >= 0.4.1.3 && < 0.5

115− , generics-sop >= 0.4.0.1 && < 0.5

116− , hspec >= 2.6.0 && < 2.7

127+ , hspec >= 2.6.0 && < 2.10

117 , HUnit >= 1.6.0.0 && < 1.7

128 , HUnit >= 1.6.0.0 && < 1.7

118− , network >= 2.8.0.0 && < 3.1

129+ , network >= 2.8.0.0 && < 3.2

119− , QuickCheck >= 2.12.6.1 && < 2.13

130+ , QuickCheck >= 2.12.6.1 && < 2.15

120− , servant == 0.15.*

131+ , servant == 0.19.*

121− , servant-server == 0.15.*

132+ , servant-server == 0.19.*

122 , tdigest >= 0.2 && < 0.3

133 , tdigest >= 0.2 && < 0.3

123

134

124 build-tool-depends:

135 build-tool-depends:

125− hspec-discover:hspec-discover >= 2.6.0 && < 2.7

136+ hspec-discover:hspec-discover >= 2.6.0 && < 2.10

126

137

127test-suite readme

138test-suite readme

128 type: exitcode-stdio-1.0

139 type: exitcode-stdio-1.0

@@ -131,3 +142,5 @@ test-suite readme

131 build-tool-depends: markdown-unlit:markdown-unlit

142 build-tool-depends: markdown-unlit:markdown-unlit

132 ghc-options: -pgmL markdown-unlit

143 ghc-options: -pgmL markdown-unlit

133 default-language: Haskell2010

144 default-language: Haskell2010

145+ if impl(ghcjs)

146+ buildable: False

servant-client/src/Servant/Client.hs+1

@@ -9,6 +9,7 @@ module Servant.Client

9 , runClientM

9 , runClientM

10 , ClientEnv(..)

10 , ClientEnv(..)

11 , mkClientEnv

11 , mkClientEnv

12+ , defaultMakeClientRequest

12 , hoistClient

13 , hoistClient

13 , module Servant.Client.Core.Reexport

14 , module Servant.Client.Core.Reexport

14 ) where

15 ) where

servant-client/src/Servant/Client/Internal/HttpClient.hs+113−62

@@ -14,65 +14,83 @@ 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)

17import Control.Concurrent.STM.TVar

19import Control.Concurrent.STM.TVar

18import Control.Exception

20import Control.Exception

21+ (SomeException (..), catch)

19import Control.Monad

22import Control.Monad

23+ (unless)

20import Control.Monad.Base

24import Control.Monad.Base

21 (MonadBase (..))

25 (MonadBase (..))

22import Control.Monad.Catch

26import Control.Monad.Catch

23− (MonadCatch, MonadThrow)

27+ (MonadCatch, MonadThrow, MonadMask)

24import Control.Monad.Error.Class

28import Control.Monad.Error.Class

25 (MonadError (..))

29 (MonadError (..))

26import Control.Monad.IO.Class

30import Control.Monad.IO.Class

27− (liftIO)

31+ (MonadIO (..))

28import Control.Monad.Reader

32import Control.Monad.Reader

33+ (MonadReader, ReaderT, ask, runReaderT)

29import Control.Monad.STM

34import Control.Monad.STM

30 (STM, atomically)

35 (STM, atomically)

31import Control.Monad.Trans.Control

36import Control.Monad.Trans.Control

32 (MonadBaseControl (..))

37 (MonadBaseControl (..))

33import Control.Monad.Trans.Except

38import Control.Monad.Trans.Except

39+ (ExceptT, runExceptT)

40+import Data.Bifunctor

41+ (bimap)

42+import qualified Data.ByteString as BS

34import Data.ByteString.Builder

43import Data.ByteString.Builder

35 (toLazyByteString)

44 (toLazyByteString)

36import qualified Data.ByteString.Lazy as BSL

45import qualified Data.ByteString.Lazy as BSL

37import Data.Either

46import Data.Either

38 (either)

47 (either)

39import Data.Foldable

48import Data.Foldable

40− (toList)

49+ (foldl',toList)

41import Data.Functor.Alt

50import Data.Functor.Alt

42 (Alt (..))

51 (Alt (..))

43import Data.Maybe

52import Data.Maybe

44 (maybe, maybeToList)

53 (maybe, maybeToList)

45import Data.Proxy

54import Data.Proxy

46 (Proxy (..))

55 (Proxy (..))

47−import Data.Semigroup

48− ((<>))

49import Data.Sequence

56import Data.Sequence

50 (fromList)

57 (fromList)

51import Data.String

58import Data.String

52 (fromString)

59 (fromString)

53−import qualified Data.Text as T

54import Data.Time.Clock

60import Data.Time.Clock

55 (UTCTime, getCurrentTime)

61 (UTCTime, getCurrentTime)

56import GHC.Generics

62import GHC.Generics

57import Network.HTTP.Media

63import Network.HTTP.Media

58 (renderHeader)

64 (renderHeader)

59import Network.HTTP.Types

65import Network.HTTP.Types

60− (hContentType, renderQuery, statusCode)

66+ (hContentType, renderQuery, statusIsSuccessful, urlEncode, Status)

61import Servant.Client.Core

67import Servant.Client.Core

62

68

63import qualified Network.HTTP.Client as Client

69import qualified Network.HTTP.Client as Client

70+import qualified Servant.Types.SourceT as S

64

71

65-- | The environment in which a request is run.

72-- | 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'

66data ClientEnv

78data ClientEnv

67 = ClientEnv

79 = ClientEnv

68 { manager :: Client.Manager

80 { manager :: Client.Manager

69 , baseUrl :: BaseUrl

81 , baseUrl :: BaseUrl

70 , cookieJar :: Maybe (TVar Client.CookieJar)

82 , 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.

71 }

89 }

72

90

73-- | 'ClientEnv' smart constructor.

91-- | 'ClientEnv' smart constructor.

74mkClientEnv :: Client.Manager -> BaseUrl -> ClientEnv

92mkClientEnv :: Client.Manager -> BaseUrl -> ClientEnv

75−mkClientEnv mgr burl = ClientEnv mgr burl Nothing

93+mkClientEnv mgr burl = ClientEnv mgr burl Nothing defaultMakeClientRequest

76

94

77-- | Generates a set of client functions for an API.

95-- | Generates a set of client functions for an API.

78--

96--

@@ -115,16 +133,16 @@ hoistClient = hoistClientMonad (Proxy :: Proxy ClientM)

115-- | @ClientM@ is the monad in which client functions run. Contains the

133-- | @ClientM@ is the monad in which client functions run. Contains the

116-- 'Client.Manager' and 'BaseUrl' used for requests in the reader environment.

134-- 'Client.Manager' and 'BaseUrl' used for requests in the reader environment.

117newtype ClientM a = ClientM

135newtype ClientM a = ClientM

118− { unClientM :: ReaderT ClientEnv (ExceptT ServantError IO) a }

136+ { unClientM :: ReaderT ClientEnv (ExceptT ClientError IO) a }

119 deriving ( Functor, Applicative, Monad, MonadIO, Generic

137 deriving ( Functor, Applicative, Monad, MonadIO, Generic

120− , MonadReader ClientEnv, MonadError ServantError, MonadThrow

138+ , MonadReader ClientEnv, MonadError ClientError, MonadThrow

121− , MonadCatch)

139+ , MonadCatch, MonadMask)

122

140

123instance MonadBase IO ClientM where

141instance MonadBase IO ClientM where

124 liftBase = ClientM . liftBase

142 liftBase = ClientM . liftBase

125

143

126instance MonadBaseControl IO ClientM where

144instance MonadBaseControl IO ClientM where

127− type StM ClientM a = Either ServantError a

145+ type StM ClientM a = Either ClientError a

128

146

129 liftBaseWith f = ClientM (liftBaseWith (\g -> f (g . unClientM)))

147 liftBaseWith f = ClientM (liftBaseWith (\g -> f (g . unClientM)))

130

148

@@ -135,19 +153,16 @@ instance Alt ClientM where

135 a <!> b = a `catchError` \_ -> b

153 a <!> b = a `catchError` \_ -> b

136

154

137instance RunClient ClientM where

155instance RunClient ClientM where

138− runRequest = performRequest

156+ runRequestAcceptStatus = performRequest

139− throwServantError = throwError

157+ throwClientError = throwError

140

158

141−instance ClientLike (ClientM a) (ClientM a) where

142− mkClient = id

143−

144−runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a)

159+runClientM :: ClientM a -> ClientEnv -> IO (Either ClientError a)

145runClientM cm env = runExceptT $ flip runReaderT env $ unClientM cm

160runClientM cm env = runExceptT $ flip runReaderT env $ unClientM cm

146

161

147−performRequest :: Request -> ClientM Response

162+performRequest :: Maybe [Status] -> Request -> ClientM Response

148−performRequest req = do

163+performRequest acceptStatus req = do

149− ClientEnv m burl cookieJar' <- ask

164+ ClientEnv m burl cookieJar' createClientRequest <- ask

150− let clientRequest = requestToClientRequest burl req

165+ clientRequest <- liftIO $ createClientRequest burl req

151 request <- case cookieJar' of

166 request <- case cookieJar' of

152 Nothing -> pure clientRequest

167 Nothing -> pure clientRequest

153 Just cj -> liftIO $ do

168 Just cj -> liftIO $ do

@@ -156,7 +171,7 @@ performRequest req = do

156 oldCookieJar <- readTVar cj

171 oldCookieJar <- readTVar cj

157 let (newRequest, newCookieJar) =

172 let (newRequest, newCookieJar) =

158 Client.insertCookiesIntoRequest

173 Client.insertCookiesIntoRequest

159− (requestToClientRequest burl req)

174+ clientRequest

160 oldCookieJar

175 oldCookieJar

161 now

176 now

162 writeTVar cj newCookieJar

177 writeTVar cj newCookieJar

@@ -164,10 +179,12 @@ performRequest req = do

164

179

165 response <- maybe (requestWithoutCookieJar m request) (requestWithCookieJar m request) cookieJar'

180 response <- maybe (requestWithoutCookieJar m request) (requestWithCookieJar m request) cookieJar'

166 let status = Client.responseStatus response

181 let status = Client.responseStatus response

167− status_code = statusCode status

168− ourResponse = clientResponseToResponse response

182+ ourResponse = clientResponseToResponse id response

169− unless (status_code >= 200 && status_code < 300) $

183+ goodStatus = case acceptStatus of

184+ Nothing -> statusIsSuccessful status

185+ Just good -> status `elem` good

186+ unless goodStatus $ do

170− throwError $ FailureResponse ourResponse

187+ throwError $ mkFailureResponse burl req ourResponse

171 return ourResponse

188 return ourResponse

172 where

189 where

173 requestWithoutCookieJar :: Client.Manager -> Client.Request -> ClientM (Client.Response BSL.ByteString)

190 requestWithoutCookieJar :: Client.Manager -> Client.Request -> ClientM (Client.Response BSL.ByteString)

@@ -195,32 +212,41 @@ performRequest req = do

195 fReq = Client.hrFinalRequest responses

212 fReq = Client.hrFinalRequest responses

196 fRes = Client.hrFinalResponse responses

213 fRes = Client.hrFinalResponse responses

197

214

198−clientResponseToResponse :: Client.Response a -> GenResponse a

215+mkFailureResponse :: BaseUrl -> Request -> ResponseF BSL.ByteString -> ClientError

199−clientResponseToResponse r = Response

216+mkFailureResponse burl request =

200− { responseStatusCode = Client.responseStatus r

217+ FailureResponse (bimap (const ()) f request)

201− , responseBody = Client.responseBody r

218+ where

202− , responseHeaders = fromList $ Client.responseHeaders r

219+ f b = (burl, BSL.toStrict $ toLazyByteString b)

203− , responseHttpVersion = Client.responseVersion r

204− }

205

220

221+clientResponseToResponse :: (a -> b) -> Client.Response a -> ResponseF b

222+clientResponseToResponse f r = Response

223+ { responseStatusCode = Client.responseStatus r

224+ , responseBody = f (Client.responseBody r)

225+ , responseHeaders = fromList $ Client.responseHeaders r

226+ , responseHttpVersion = Client.responseVersion r

227+ }

228+

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'

206−requestToClientRequest :: BaseUrl -> Request -> Client.Request

232+defaultMakeClientRequest :: BaseUrl -> Request -> IO Client.Request

207−requestToClientRequest burl r = Client.defaultRequest

233+defaultMakeClientRequest burl r = return Client.defaultRequest

208− { Client.method = requestMethod r

234+ { Client.method = requestMethod r

209− , Client.host = fromString $ baseUrlHost burl

235+ , Client.host = fromString $ baseUrlHost burl

210− , Client.port = baseUrlPort burl

236+ , Client.port = baseUrlPort burl

211− , Client.path = BSL.toStrict

237+ , Client.path = BSL.toStrict

212− $ fromString (baseUrlPath burl)

238+ $ fromString (baseUrlPath burl)

213− <> toLazyByteString (requestPath r)

239+ <> toLazyByteString (requestPath r)

214− , Client.queryString = renderQuery True . toList $ requestQueryString r

240+ , Client.queryString = buildQueryString . toList $ requestQueryString r

215− , Client.requestHeaders =

241+ , Client.requestHeaders =

216− maybeToList acceptHdr ++ maybeToList contentTypeHdr ++ headers

242+ maybeToList acceptHdr ++ maybeToList contentTypeHdr ++ headers

217− , Client.requestBody = body

243+ , Client.requestBody = body

218− , Client.secure = isSecure

244+ , Client.secure = isSecure

219− }

245+ }

220 where

246 where

221 -- Content-Type and Accept are specified by requestBody and requestAccept

247 -- Content-Type and Accept are specified by requestBody and requestAccept

222 headers = filter (\(h, _) -> h /= "Accept" && h /= "Content-Type") $

248 headers = filter (\(h, _) -> h /= "Accept" && h /= "Content-Type") $

223− toList $requestHeaders r

249+ toList $ requestHeaders r

224

250

225 acceptHdr

251 acceptHdr

226 | null hs = Nothing

252 | null hs = Nothing

@@ -229,23 +255,48 @@ requestToClientRequest burl r = Client.defaultRequest

229 hs = toList $ requestAccept r

255 hs = toList $ requestAccept r

230

256

231 convertBody bd = case bd of

257 convertBody bd = case bd of

232− RequestBodyLBS body' -> Client.RequestBodyLBS body'

258+ RequestBodyLBS body' -> Client.RequestBodyLBS body'

233− RequestBodyBS body' -> Client.RequestBodyBS body'

259+ RequestBodyBS body' -> Client.RequestBodyBS body'

234− RequestBodyBuilder size body' -> Client.RequestBodyBuilder size body'

260+ RequestBodySource sourceIO -> Client.RequestBodyStreamChunked givesPopper

235− RequestBodyStream size body' -> Client.RequestBodyStream size body'

261+ where

236− RequestBodyStreamChunked body' -> Client.RequestBodyStreamChunked body'

262+ givesPopper :: (IO BS.ByteString -> IO ()) -> IO ()

237− RequestBodyIO body' -> Client.RequestBodyIO (convertBody <$> body')

263+ givesPopper needsPopper = S.unSourceT sourceIO $ \step0 -> do

264+ ref <- newMVar step0

265+

266+ -- Note sure we need locking, but it's feels safer.

267+ let popper :: IO BS.ByteString

268+ popper = modifyMVar ref nextBs

269+

270+ needsPopper popper

271+

272+ nextBs S.Stop = return (S.Stop, BS.empty)

273+ nextBs (S.Error err) = fail err

274+ nextBs (S.Skip s) = nextBs s

275+ nextBs (S.Effect ms) = ms >>= nextBs

276+ nextBs (S.Yield lbs s) = case BSL.toChunks lbs of

277+ [] -> nextBs s

278+ (x:xs) | BS.null x -> nextBs step'

279+ | otherwise -> return (step', x)

280+ where

281+ step' = S.Yield (BSL.fromChunks xs) s

238

282

239 (body, contentTypeHdr) = case requestBody r of

283 (body, contentTypeHdr) = case requestBody r of

240− Nothing -> (Client.RequestBodyLBS "", Nothing)

284+ Nothing -> (Client.RequestBodyBS "", Nothing)

241− Just (body', typ)

242− -> (convertBody body', Just (hContentType, renderHeader typ))

285+ Just (body', typ) -> (convertBody body', Just (hContentType, renderHeader typ))

243

286

244 isSecure = case baseUrlScheme burl of

287 isSecure = case baseUrlScheme burl of

245− Http -> False

288+ Http -> False

246− Https -> True

289+ Https -> True

290+

291+ -- Query string builder which does not do any encoding

292+ buildQueryString [] = mempty

293+ buildQueryString qps = "?" <> foldl' addQueryParam mempty qps

294+

295+ addQueryParam qs (k, v) =

296+ qs <> (if BS.null qs then mempty else "&") <> urlEncode True k <> foldMap ("=" <>) v

297+

247

298

248−catchConnectionError :: IO a -> IO (Either ServantError a)

299+catchConnectionError :: IO a -> IO (Either ClientError a)

249catchConnectionError action =

300catchConnectionError action =

250 catch (Right <$> action) $ \e ->

301 catch (Right <$> action) $ \e ->

251− pure . Left . ConnectionError . T.pack $ show (e :: Client.HttpException)

302+ pure . Left . ConnectionError $ SomeException (e :: Client.HttpException)

servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs+30−27

@@ -12,7 +12,7 @@ module Servant.Client.Internal.HttpClient.Streaming (

12 ClientEnv (..),

12 ClientEnv (..),

13 mkClientEnv,

13 mkClientEnv,

14 clientResponseToResponse,

14 clientResponseToResponse,

15− requestToClientRequest,

15+ defaultMakeClientRequest,

16 catchConnectionError,

16 catchConnectionError,

17 ) where

17 ) where

18

18

@@ -35,6 +35,7 @@ import Control.Monad.Reader

35import Control.Monad.STM

35import Control.Monad.STM

36 (atomically)

36 (atomically)

37import Control.Monad.Trans.Except

37import Control.Monad.Trans.Except

38+import qualified Data.ByteString as BS

38import qualified Data.ByteString.Lazy as BSL

39import qualified Data.ByteString.Lazy as BSL

39import Data.Foldable

40import Data.Foldable

40 (for_)

41 (for_)

@@ -46,14 +47,16 @@ import Data.Time.Clock

46 (getCurrentTime)

47 (getCurrentTime)

47import GHC.Generics

48import GHC.Generics

48import Network.HTTP.Types

49import Network.HTTP.Types

49− (statusCode)

50+ (Status, statusIsSuccessful)

50

51

51import qualified Network.HTTP.Client as Client

52import qualified Network.HTTP.Client as Client

52

53

53import Servant.Client.Core

54import Servant.Client.Core

54import Servant.Client.Internal.HttpClient

55import Servant.Client.Internal.HttpClient

55 (ClientEnv (..), catchConnectionError,

56 (ClientEnv (..), catchConnectionError,

56− clientResponseToResponse, mkClientEnv, requestToClientRequest)

57+ clientResponseToResponse, mkClientEnv, mkFailureResponse,

58+ defaultMakeClientRequest)

59+import qualified Servant.Types.SourceT as S

57

60

58

61

59-- | Generates a set of client functions for an API.

62-- | Generates a set of client functions for an API.

@@ -97,9 +100,9 @@ hoistClient = hoistClientMonad (Proxy :: Proxy ClientM)

97-- | @ClientM@ is the monad in which client functions run. Contains the

100-- | @ClientM@ is the monad in which client functions run. Contains the

98-- 'Client.Manager' and 'BaseUrl' used for requests in the reader environment.

101-- 'Client.Manager' and 'BaseUrl' used for requests in the reader environment.

99newtype ClientM a = ClientM

102newtype ClientM a = ClientM

100− { unClientM :: ReaderT ClientEnv (ExceptT ServantError (Codensity IO)) a }

103+ { unClientM :: ReaderT ClientEnv (ExceptT ClientError (Codensity IO)) a }

101 deriving ( Functor, Applicative, Monad, MonadIO, Generic

104 deriving ( Functor, Applicative, Monad, MonadIO, Generic

102− , MonadReader ClientEnv, MonadError ServantError)

105+ , MonadReader ClientEnv, MonadError ClientError)

103

106

104instance MonadBase IO ClientM where

107instance MonadBase IO ClientM where

105 liftBase = ClientM . liftIO

108 liftBase = ClientM . liftIO

@@ -109,16 +112,13 @@ instance Alt ClientM where

109 a <!> b = a `catchError` \_ -> b

112 a <!> b = a `catchError` \_ -> b

110

113

111instance RunClient ClientM where

114instance RunClient ClientM where

112− runRequest = performRequest

115+ runRequestAcceptStatus = performRequest

113− throwServantError = throwError

116+ throwClientError = throwError

114

117

115instance RunStreamingClient ClientM where

118instance RunStreamingClient ClientM where

116 withStreamingRequest = performWithStreamingRequest

119 withStreamingRequest = performWithStreamingRequest

117

120

118−instance ClientLike (ClientM a) (ClientM a) where

119− mkClient = id

120−

121−withClientM :: ClientM a -> ClientEnv -> (Either ServantError a -> IO b) -> IO b

121+withClientM :: ClientM a -> ClientEnv -> (Either ClientError a -> IO b) -> IO b

122withClientM cm env k =

122withClientM cm env k =

123 let Codensity f = runExceptT $ flip runReaderT env $ unClientM cm

123 let Codensity f = runExceptT $ flip runReaderT env $ unClientM cm

124 in f k

124 in f k

@@ -130,17 +130,17 @@ withClientM cm env k =

130-- streaming response types ('SourceT', 'Conduit', pipes 'Proxy' or 'Machine').

130-- streaming response types ('SourceT', 'Conduit', pipes 'Proxy' or 'Machine').

131-- For those you have to use 'withClientM'.

131-- For those you have to use 'withClientM'.

132--

132--

133−-- /Note:/ we 'force' the result, so the likehood of accidentally leaking a

133+-- /Note:/ we 'force' the result, so the likelihood of accidentally leaking a

134-- connection is smaller. Use with care.

134-- connection is smaller. Use with care.

135--

135--

136−runClientM :: NFData a => ClientM a -> ClientEnv -> IO (Either ServantError a)

136+runClientM :: NFData a => ClientM a -> ClientEnv -> IO (Either ClientError a)

137runClientM cm env = withClientM cm env (evaluate . force)

137runClientM cm env = withClientM cm env (evaluate . force)

138

138

139−performRequest :: Request -> ClientM Response

139+performRequest :: Maybe [Status] -> Request -> ClientM Response

140−performRequest req = do

140+performRequest acceptStatus req = do

141 -- TODO: should use Client.withResponse here too

141 -- TODO: should use Client.withResponse here too

142− ClientEnv m burl cookieJar' <- ask

142+ ClientEnv m burl cookieJar' createClientRequest <- ask

143− let clientRequest = requestToClientRequest burl req

143+ clientRequest <- liftIO $ createClientRequest burl req

144 request <- case cookieJar' of

144 request <- case cookieJar' of

145 Nothing -> pure clientRequest

145 Nothing -> pure clientRequest

146 Just cj -> liftIO $ do

146 Just cj -> liftIO $ do

@@ -149,7 +149,7 @@ performRequest req = do

149 oldCookieJar <- readTVar cj

149 oldCookieJar <- readTVar cj

150 let (newRequest, newCookieJar) =

150 let (newRequest, newCookieJar) =

151 Client.insertCookiesIntoRequest

151 Client.insertCookiesIntoRequest

152− (requestToClientRequest burl req)

152+ clientRequest

153 oldCookieJar

153 oldCookieJar

154 now

154 now

155 writeTVar cj newCookieJar

155 writeTVar cj newCookieJar

@@ -163,26 +163,29 @@ performRequest req = do

163 now' <- getCurrentTime

163 now' <- getCurrentTime

164 atomically $ modifyTVar' cj (fst . Client.updateCookieJar response request now')

164 atomically $ modifyTVar' cj (fst . Client.updateCookieJar response request now')

165 let status = Client.responseStatus response

165 let status = Client.responseStatus response

166− status_code = statusCode status

167− ourResponse = clientResponseToResponse response

166+ ourResponse = clientResponseToResponse id response

168− unless (status_code >= 200 && status_code < 300) $

167+ goodStatus = case acceptStatus of

168+ Nothing -> statusIsSuccessful status

169+ Just good -> status `elem` good

170+ unless goodStatus $ do

169− throwError $ FailureResponse ourResponse

171+ throwError $ mkFailureResponse burl req ourResponse

170 return ourResponse

172 return ourResponse

171

173

174+-- | TODO: support UVerb ('acceptStatus' argument, like in 'performRequest' above).

172performWithStreamingRequest :: Request -> (StreamingResponse -> IO a) -> ClientM a

175performWithStreamingRequest :: Request -> (StreamingResponse -> IO a) -> ClientM a

173performWithStreamingRequest req k = do

176performWithStreamingRequest req k = do

174 m <- asks manager

177 m <- asks manager

175 burl <- asks baseUrl

178 burl <- asks baseUrl

176− let request = requestToClientRequest burl req

179+ createClientRequest <- asks makeClientRequest

180+ request <- liftIO $ createClientRequest burl req

177 ClientM $ lift $ lift $ Codensity $ \k1 ->

181 ClientM $ lift $ lift $ Codensity $ \k1 ->

178 Client.withResponse request m $ \res -> do

182 Client.withResponse request m $ \res -> do

179 let status = Client.responseStatus res

183 let status = Client.responseStatus res

180− status_code = statusCode status

181

184

182 -- we throw FailureResponse in IO :(

185 -- we throw FailureResponse in IO :(

183− unless (status_code >= 200 && status_code < 300) $ do

186+ unless (statusIsSuccessful status) $ do

184 b <- BSL.fromChunks <$> Client.brConsume (Client.responseBody res)

187 b <- BSL.fromChunks <$> Client.brConsume (Client.responseBody res)

185− throwIO $ FailureResponse $ clientResponseToResponse res { Client.responseBody = b }

188+ throwIO $ mkFailureResponse burl req (clientResponseToResponse (const b) res)

186

189

187− x <- k (clientResponseToResponse res)

190+ x <- k (clientResponseToResponse (S.fromAction BS.null) res)

188 k1 x

191 k1 x

servant-client/src/Servant/Client/Streaming.hs+1

@@ -10,6 +10,7 @@ module Servant.Client.Streaming

10 , runClientM

10 , runClientM

11 , ClientEnv(..)

11 , ClientEnv(..)

12 , mkClientEnv

12 , mkClientEnv

13+ , defaultMakeClientRequest

13 , hoistClient

14 , hoistClient

14 , module Servant.Client.Core.Reexport

15 , module Servant.Client.Core.Reexport

15 ) where

16 ) where

servant-client/test/Servant/BasicAuthSpec.hsnew file+53

@@ -0,0 +1,53 @@

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.hsnew file+71

@@ -0,0 +1,71 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE TypeOperators #-}

3+{-# OPTIONS_GHC -freduction-depth=100 #-}

4+{-# OPTIONS_GHC -fno-warn-orphans #-}

5+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

6+

7+module Servant.BrokenSpec (spec) where

8+

9+import Prelude ()

10+import Prelude.Compat

11+

12+import Data.Monoid ()

13+import Data.Proxy

14+import qualified Network.HTTP.Types as HTTP

15+import Test.Hspec

16+

17+import Servant.API

18+ ((:<|>) ((:<|>)), (:>), JSON, Verb, Get, StdMethod (GET))

19+import Servant.Client

20+import Servant.ClientTestUtils

21+import Servant.Server

22+

23+-- * api for testing inconsistencies between client and server

24+

25+type Get201 = Verb 'GET 201

26+type Get301 = Verb 'GET 301

27+

28+type BrokenAPI =

29+ -- the server should respond with 200, but returns 201

30+ "get200" :> Get201 '[JSON] ()

31+ -- the server should respond with 307, but returns 301

32+ :<|> "get307" :> Get301 '[JSON] ()

33+

34+brokenApi :: Proxy BrokenAPI

35+brokenApi = Proxy

36+

37+brokenServer :: Application

38+brokenServer = serve brokenApi (pure () :<|> pure ())

39+

40+type PublicAPI =

41+ -- the client expects 200

42+ "get200" :> Get '[JSON] ()

43+ -- the client expects 307

44+ :<|> "get307" :> Get307 '[JSON] ()

45+

46+publicApi :: Proxy PublicAPI

47+publicApi = Proxy

48+

49+get200Client :: ClientM ()

50+get307Client :: ClientM ()

51+get200Client :<|> get307Client = client publicApi

52+

53+

54+spec :: Spec

55+spec = describe "Servant.BrokenSpec" $ do

56+ brokenSpec

57+

58+brokenSpec :: Spec

59+brokenSpec = beforeAll (startWaiApp brokenServer) $ afterAll endWaiApp $ do

60+ context "client returns errors for inconsistencies between client and server api" $ do

61+ it "reports FailureResponse with wrong 2xx status code" $ \(_, baseUrl) -> do

62+ res <- runClient get200Client baseUrl

63+ case res of

64+ Left (FailureResponse _ r) | responseStatusCode r == HTTP.status201 -> return ()

65+ _ -> fail $ "expected 201 broken response, but got " <> show res

66+

67+ it "reports FailureResponse with wrong 3xx status code" $ \(_, baseUrl) -> do

68+ res <- runClient get307Client baseUrl

69+ case res of

70+ Left (FailureResponse _ r) | responseStatusCode r == HTTP.status301 -> return ()

71+ _ -> fail $ "expected 301 broken response, but got " <> show res

servant-client/test/Servant/ClientTestUtils.hsnew file+384

@@ -0,0 +1,384 @@

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.hsnew file+55

@@ -0,0 +1,55 @@

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.hsnew file+79

@@ -0,0 +1,79 @@

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.hsnew file+54

@@ -0,0 +1,54 @@

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.hsnew file+37

@@ -0,0 +1,37 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE ConstraintKinds #-}

3+{-# LANGUAGE DataKinds #-}

4+{-# LANGUAGE FlexibleContexts #-}

5+{-# LANGUAGE FlexibleInstances #-}

6+{-# LANGUAGE GADTs #-}

7+{-# LANGUAGE MultiParamTypeClasses #-}

8+{-# LANGUAGE OverloadedStrings #-}

9+{-# LANGUAGE PolyKinds #-}

10+{-# LANGUAGE ScopedTypeVariables #-}

11+{-# LANGUAGE TypeFamilies #-}

12+{-# LANGUAGE TypeOperators #-}

13+{-# LANGUAGE UndecidableInstances #-}

14+{-# OPTIONS_GHC -freduction-depth=100 #-}

15+{-# OPTIONS_GHC -fno-warn-orphans #-}

16+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

17+

18+module Servant.GenericSpec (spec) where

19+

20+import Test.Hspec

21+

22+import Servant.Client ((//), (/:))

23+import Servant.ClientTestUtils

24+

25+spec :: Spec

26+spec = describe "Servant.GenericSpec" $ do

27+ genericSpec

28+

29+genericSpec :: Spec

30+genericSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do

31+ context "Record clients work as expected" $ do

32+

33+ it "Client functions return expected values" $ \(_,baseUrl) -> do

34+ runClient (recordRoutes // version) baseUrl `shouldReturn` Right 42

35+ runClient (recordRoutes // echo /: "foo") baseUrl `shouldReturn` Right "foo"

36+ it "Clients can be nested" $ \(_,baseUrl) -> do

37+ runClient (recordRoutes // otherRoutes /: 42 // something) baseUrl `shouldReturn` Right ["foo", "bar", "pweet"]

servant-client/test/Servant/HoistClientSpec.hsnew file+58

@@ -0,0 +1,58 @@

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+18−9

@@ -35,12 +35,10 @@ import qualified Network.HTTP.Client as C

35import Prelude ()

35import Prelude ()

36import Prelude.Compat

36import Prelude.Compat

37import Servant.API

37import Servant.API

38− ((:<|>) ((:<|>)), (:>), JSON, NetstringFraming,

38+ ((:<|>) ((:<|>)), (:>), JSON, NetstringFraming, StreamBody,

39− NewlineFraming, NoFraming, OctetStream, SourceIO, StreamGet)

39+ NewlineFraming, NoFraming, OctetStream, SourceIO, StreamGet,

40+ )

40import Servant.Client.Streaming

41import Servant.Client.Streaming

41−import Servant.ClientSpec

42− (Person (..))

43−import qualified Servant.ClientSpec as CS

44import Servant.Server

42import Servant.Server

45import Servant.Test.ComprehensiveAPI

43import Servant.Test.ComprehensiveAPI

46import Servant.Types.SourceT

44import Servant.Types.SourceT

@@ -51,6 +49,8 @@ import System.IO.Unsafe

51import System.Mem

49import System.Mem

52 (performGC)

50 (performGC)

53import Test.Hspec

51import Test.Hspec

52+import Servant.ClientTestUtils (Person(..))

53+import qualified Servant.ClientTestUtils as CT

54

54

55#if MIN_VERSION_base(4,10,0)

55#if MIN_VERSION_base(4,10,0)

56import GHC.Stats

56import GHC.Stats

@@ -72,13 +72,15 @@ type StreamApi =

72 "streamGetNewline" :> StreamGet NewlineFraming JSON (SourceIO Person)

72 "streamGetNewline" :> StreamGet NewlineFraming JSON (SourceIO Person)

73 :<|> "streamGetNetstring" :> StreamGet NetstringFraming JSON (SourceIO Person)

73 :<|> "streamGetNetstring" :> StreamGet NetstringFraming JSON (SourceIO Person)

74 :<|> "streamALot" :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString)

74 :<|> "streamALot" :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString)

75+ :<|> "streamBody" :> StreamBody NoFraming OctetStream (SourceIO BS.ByteString) :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString)

75

76

76api :: Proxy StreamApi

77api :: Proxy StreamApi

77api = Proxy

78api = Proxy

78

79

79getGetNL, getGetNS :: ClientM (SourceIO Person)

80getGetNL, getGetNS :: ClientM (SourceIO Person)

80getGetALot :: ClientM (SourceIO BS.ByteString)

81getGetALot :: ClientM (SourceIO BS.ByteString)

82+getStreamBody :: SourceT IO BS.ByteString -> ClientM (SourceIO BS.ByteString)

81−getGetNL :<|> getGetNS :<|> getGetALot = client api

83+getGetNL :<|> getGetNS :<|> getGetALot :<|> getStreamBody = client api

82

84

83alice :: Person

85alice :: Person

84alice = Person "Alice" 42

86alice = Person "Alice" 42

@@ -90,9 +92,9 @@ server :: Application

90server = serve api

92server = serve api

91 $ return (source [alice, bob, alice])

93 $ return (source [alice, bob, alice])

92 :<|> return (source [alice, bob, alice])

94 :<|> return (source [alice, bob, alice])

93−

94 -- 2 ^ (18 + 10) = 256M

95 -- 2 ^ (18 + 10) = 256M

95 :<|> return (SourceT ($ lots (powerOfTwo 18)))

96 :<|> return (SourceT ($ lots (powerOfTwo 18)))

97+ :<|> return

96 where

98 where

97 lots n

99 lots n

98 | n < 0 = Stop

100 | n < 0 = Stop

@@ -109,7 +111,7 @@ powerOfTwo = (2 ^)

109manager' :: C.Manager

111manager' :: C.Manager

110manager' = unsafePerformIO $ C.newManager C.defaultManagerSettings

112manager' = unsafePerformIO $ C.newManager C.defaultManagerSettings

111

113

112−withClient :: ClientM a -> BaseUrl -> (Either ServantError a -> IO r) -> IO r

114+withClient :: ClientM a -> BaseUrl -> (Either ClientError a -> IO r) -> IO r

113withClient x baseUrl' = withClientM x (mkClientEnv manager' baseUrl')

115withClient x baseUrl' = withClientM x (mkClientEnv manager' baseUrl')

114

116

115testRunSourceIO :: SourceIO a

117testRunSourceIO :: SourceIO a

@@ -117,7 +119,7 @@ testRunSourceIO :: SourceIO a

117testRunSourceIO = runExceptT . runSourceT

119testRunSourceIO = runExceptT . runSourceT

118

120

119streamSpec :: Spec

121streamSpec :: Spec

120−streamSpec = beforeAll (CS.startWaiApp server) $ afterAll CS.endWaiApp $ do

122+streamSpec = beforeAll (CT.startWaiApp server) $ afterAll CT.endWaiApp $ do

121 it "works with Servant.API.StreamGet.Newline" $ \(_, baseUrl) -> do

123 it "works with Servant.API.StreamGet.Newline" $ \(_, baseUrl) -> do

122 withClient getGetNL baseUrl $ \(Right res) ->

124 withClient getGetNL baseUrl $ \(Right res) ->

123 testRunSourceIO res `shouldReturn` Right [alice, bob, alice]

125 testRunSourceIO res `shouldReturn` Right [alice, bob, alice]

@@ -126,6 +128,13 @@ streamSpec = beforeAll (CS.startWaiApp server) $ afterAll CS.endWaiApp $ do

126 withClient getGetNS baseUrl $ \(Right res) ->

128 withClient getGetNS baseUrl $ \(Right res) ->

127 testRunSourceIO res `shouldReturn` Right [alice, bob, alice]

129 testRunSourceIO res `shouldReturn` Right [alice, bob, alice]

128

130

131+ it "works with Servant.API.StreamBody" $ \(_, baseUrl) -> do

132+ withClient (getStreamBody (source input)) baseUrl $ \(Right res) ->

133+ testRunSourceIO res `shouldReturn` Right output

134+ where

135+ input = ["foo", "", "bar"]

136+ output = ["foo", "bar"]

137+

129{-

138{-

130 it "streams in constant memory" $ \(_, baseUrl) -> do

139 it "streams in constant memory" $ \(_, baseUrl) -> do

131 Right rs <- runClient getGetALot baseUrl

140 Right rs <- runClient getGetALot baseUrl

servant-client/test/Servant/SuccessSpec.hsnew file+208

@@ -0,0 +1,208 @@

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.hsnew file+63

@@ -0,0 +1,63 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE ConstraintKinds #-}

3+{-# LANGUAGE DataKinds #-}

4+{-# LANGUAGE FlexibleContexts #-}

5+{-# LANGUAGE FlexibleInstances #-}

6+{-# LANGUAGE GADTs #-}

7+{-# LANGUAGE 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-conduit/servant-conduit.cabal+13−17

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

1−cabal-version: >=1.10

1+cabal-version: 2.2

2name: servant-conduit

2name: servant-conduit

3−version: 0.15

3+version: 0.15.1

4

4

5synopsis: Servant Stream support for conduit.

5synopsis: Servant Stream support for conduit.

6category: Servant, Web, Enumerator

6category: Servant, Web, Enumerator

@@ -8,37 +8,33 @@ description: Servant Stream support for conduit.

8 .

8 .

9 Provides 'ToSourceIO' and 'FromSourceIO' instances for 'ConduitT'.

9 Provides 'ToSourceIO' and 'FromSourceIO' instances for 'ConduitT'.

10

10

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

11+homepage: http://docs.servant.dev/

12bug-reports: http://github.com/haskell-servant/servant/issues

12bug-reports: http://github.com/haskell-servant/servant/issues

13−license: BSD3

13+license: BSD-3-Clause

14license-file: LICENSE

14license-file: LICENSE

15author: Servant Contributors

15author: Servant Contributors

16maintainer: haskell-servant-maintainers@googlegroups.com

16maintainer: haskell-servant-maintainers@googlegroups.com

17−copyright: 2018 Servant Contributors

17+copyright: 2018-2019 Servant Contributors

18build-type: Simple

18build-type: Simple

19−tested-with:

19+tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2

20− GHC ==8.0.2

21− || ==8.2.2

22− || ==8.4.4

23− || ==8.6.2

24

20

25extra-source-files:

21extra-source-files:

26 CHANGELOG.md

22 CHANGELOG.md

27

23

28source-repository head

24source-repository head

29 type: git

25 type: git

30− location: http://github.com/haskell-servant/servant-conduit.git

26+ location: http://github.com/haskell-servant/servant.git

31

27

32library

28library

33 exposed-modules: Servant.Conduit

29 exposed-modules: Servant.Conduit

34 build-depends:

30 build-depends:

35 base >=4.9 && <5

31 base >=4.9 && <5

36− , bytestring >=0.10.8.1 && <0.11

32+ , bytestring >=0.10.8.1 && <0.12

37 , conduit >=1.3.1 && <1.4

33 , conduit >=1.3.1 && <1.4

38 , mtl >=2.2.2 && <2.3

34 , mtl >=2.2.2 && <2.3

39 , resourcet >=1.2.2 && <1.3

35 , resourcet >=1.2.2 && <1.3

40− , servant >=0.15 && <0.16

36+ , servant >=0.15 && <0.20

41− , unliftio-core >=0.1.2.0 && <0.2

37+ , unliftio-core >=0.1.2.0 && <0.3

42 hs-source-dirs: src

38 hs-source-dirs: src

43 default-language: Haskell2010

39 default-language: Haskell2010

44 ghc-options: -Wall

40 ghc-options: -Wall

@@ -58,9 +54,9 @@ test-suite example

58 , resourcet

54 , resourcet

59 , servant

55 , servant

60 , servant-conduit

56 , servant-conduit

61− , servant-server >=0.15 && <0.16

57+ , servant-server >=0.15 && <0.20

62− , servant-client >=0.15 && <0.16

58+ , servant-client >=0.15 && <0.20

63 , wai >=3.2.1.2 && <3.3

59 , wai >=3.2.1.2 && <3.3

64− , warp >=3.2.25 && <3.3

60+ , warp >=3.2.25 && <3.4

65 , http-client

61 , http-client

66 default-language: Haskell2010

62 default-language: Haskell2010

servant-docs/CHANGELOG.md+85

@@ -1,6 +1,91 @@

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+

40.11.3

890.11.3

5------

90------

6

91

servant-docs/README.md+44−11

@@ -2,24 +2,56 @@

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 PolyKinds #-}

14−{-# LANGUAGE TypeFamilies #-}

15{-# LANGUAGE DeriveGeneric #-}

13{-# LANGUAGE DeriveGeneric #-}

16−{-# LANGUAGE TypeOperators #-}

17{-# LANGUAGE FlexibleInstances #-}

14{-# LANGUAGE FlexibleInstances #-}

15+{-# LANGUAGE MultiParamTypeClasses #-}

18{-# LANGUAGE OverloadedStrings #-}

16{-# LANGUAGE OverloadedStrings #-}

17+{-# LANGUAGE PolyKinds #-}

18+{-# LANGUAGE TypeFamilies #-}

19+{-# LANGUAGE TypeOperators #-}

19

20

20−import Data.Proxy

21+import Data.Aeson (FromJSON, ToJSON)

22+import Data.Proxy (Proxy (..))

23+import Data.String.Conversions (cs)

21−import Data.Text

24+import Data.Text (Text)

25+import GHC.Generics (Generic)

26+import Servant.API

27+ ( (:<|>),

28+ (:>),

29+ Capture,

30+ Delete,

31+ Get,

32+ JSON,

33+ MimeRender,

34+ PlainText,

35+ Post,

36+ QueryParam,

37+ ReqBody,

38+ mimeRender,

39+ )

22import Servant.Docs

40import 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+ )

23

55

24-- our type for a Greeting message

56-- our type for a Greeting message

25data Greet = Greet { _msg :: Text }

57data Greet = Greet { _msg :: Text }

@@ -29,6 +61,7 @@ data Greet = Greet { _msg :: Text }

29-- 'MimeRender' instance for 'JSON'.

61-- 'MimeRender' instance for 'JSON'.

30instance FromJSON Greet

62instance FromJSON Greet

31instance ToJSON Greet

63instance ToJSON Greet

64+instance ToSample ()

32

65

33-- We can also implement 'MimeRender' explicitly for additional formats.

66-- We can also implement 'MimeRender' explicitly for additional formats.

34instance MimeRender PlainText Greet where

67instance MimeRender PlainText Greet where

@@ -36,8 +69,7 @@ instance MimeRender PlainText Greet where

36

69

37-- we provide a sample value for the 'Greet' type

70-- we provide a sample value for the 'Greet' type

38instance ToSample Greet where

71instance ToSample Greet where

39− toSample = Just g

72+ toSamples _ = singleSample g

40−

41 where g = Greet "Hello, haskeller!"

73 where g = Greet "Hello, haskeller!"

42

74

43instance ToParam (QueryParam "capital" Bool) where

75instance ToParam (QueryParam "capital" Bool) where

@@ -45,6 +77,7 @@ instance ToParam (QueryParam "capital" Bool) where

45 DocQueryParam "capital"

77 DocQueryParam "capital"

46 ["true", "false"]

78 ["true", "false"]

47 "Get the greeting message in uppercase (true) or not (false). Default is false."

79 "Get the greeting message in uppercase (true) or not (false). Default is false."

80+ Normal

48

81

49instance ToCapture (Capture "name" Text) where

82instance ToCapture (Capture "name" Text) where

50 toCapture _ = DocCapture "name" "name of the person to greet"

83 toCapture _ = DocCapture "name" "name of the person to greet"

@@ -55,8 +88,8 @@ instance ToCapture (Capture "greetid" Text) where

55-- API specification

88-- API specification

56type TestApi =

89type TestApi =

57 "hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get '[JSON,PlainText] Greet

90 "hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get '[JSON,PlainText] Greet

58− :<|> "greet" :> RQBody '[JSON] Greet :> Post '[JSON] Greet

91+ :<|> "greet" :> ReqBody '[JSON] Greet :> Post '[JSON] Greet

59− :<|> "delete" :> Capture "greetid" Text :> Delete '[] ()

92+ :<|> "delete" :> Capture "greetid" Text :> Delete '[JSON] ()

60

93

61testApi :: Proxy TestApi

94testApi :: Proxy TestApi

62testApi = Proxy

95testApi = 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 :> QueryParam "capital" Bool :> Get '[JSON, PlainText] Greet

78+ "hello" :> Capture "name" Text :> Header "X-Num-Fairies" Int :> 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 <>~ ["unicorns"]

96+ defAction & headers <>~ [("X-Num-Unicorns", "1")]

97 & notes <>~ [ DocNote "Title" ["This is some text"]

97 & notes <>~ [ DocNote "Title" ["This is some text"]

98− , DocNote "Second secton" ["And some more"]

98+ , DocNote "Second section" ["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 $ markdown docsGreet

112+main = putStrLn $ markdownWith (defRenderingOptions { _renderCurlBasePath = Just "http://localhost:80" }) docsGreet

servant-docs/example/greet.md+33−2

@@ -51,13 +51,22 @@ You'll also note that multiple intros are possible.

51"Hello, haskeller"

51"Hello, haskeller"

52```

52```

53

53

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+

54## DELETE /greet/:greetid

63## DELETE /greet/:greetid

55

64

56### Title

65### Title

57

66

58This is some text

67This is some text

59

68

60−### Second secton

69+### Second section

61

70

62And some more

71And some more

63

72

@@ -67,7 +76,7 @@ And some more

67

76

68### Headers:

77### Headers:

69

78

70−- This endpoint is sensitive to the value of the **unicorns** HTTP header.

79+- This endpoint is sensitive to the value of the **X-Num-Unicorns** HTTP header.

71

80

72### Response:

81### Response:

73

82

@@ -85,12 +94,24 @@ And some more

85

94

86```

95```

87

96

97+### Sample Request:

98+

99+```bash

100+curl -XDELETE \

101+ -H "X-Num-Unicorns: 1" \

102+ http://localhost:80/greet/:greetid

103+```

104+

88## GET /hello/:name

105## GET /hello/:name

89

106

90### Captures:

107### Captures:

91

108

92- *name*: name of the person to greet

109- *name*: name of the person to greet

93

110

111+### Headers:

112+

113+- This endpoint is sensitive to the value of the **X-Num-Fairies** HTTP header.

114+

94### GET Parameters:

115### GET Parameters:

95

116

96- capital

117- capital

@@ -120,3 +141,13 @@ And some more

120```javascript

141```javascript

121"Hello, haskeller"

142"Hello, haskeller"

122```

143```

144+

145+### Sample Request:

146+

147+```bash

148+curl -XGET \

149+ -H "X-Num-Fairies: 1729" \

150+ http://localhost:80/hello/:name

151+```

152+

153+

servant-docs/golden/comprehensive.md+47−12

@@ -52,11 +52,11 @@

52

52

53```

53```

54

54

55−## GET /capture/:foo

55+## GET /capture/:bar

56

56

57### Captures:

57### Captures:

58

58

59−- *foo*: Capture foo Int

59+- *bar*: example description

60

60

61### Response:

61### Response:

62

62

@@ -96,6 +96,28 @@

96

96

97```

97```

98

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+

99## GET /description

121## GET /description

100

122

101### foo

123### foo

@@ -160,6 +182,28 @@

160

182

161```

183```

162

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+

163## GET /get-int

207## GET /get-int

164

208

165### Response:

209### Response:

@@ -377,16 +421,7 @@

377- Status code 204

421- Status code 204

378- Headers: []

422- Headers: []

379

423

380−- Supported content types are:

424+- No response body

381−

382− - `application/json;charset=utf-8`

383− - `application/json`

384−

385−- Example (`application/json;charset=utf-8`, `application/json`):

386−

387−```javascript

388−

389−```

390

425

391## GET /raw

426## GET /raw

392

427

servant-docs/servant-docs.cabal+18−23

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

1−cabal-version: >=1.10

1+cabal-version: 2.2

2name: servant-docs

2name: servant-docs

3−version: 0.11.3

3+version: 0.12

4

4

5synopsis: generate API docs for your servant webservice

5synopsis: generate API docs for your servant webservice

6category: Servant, Web

6category: Servant, Web

@@ -11,19 +11,15 @@ description:

11 .

11 .

12 <https://github.com/haskell-servant/servant/blob/master/servant-docs/CHANGELOG.md CHANGELOG>

12 <https://github.com/haskell-servant/servant/blob/master/servant-docs/CHANGELOG.md CHANGELOG>

13

13

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

14+homepage: http://docs.servant.dev/

15bug-reports: http://github.com/haskell-servant/servant/issues

15bug-reports: http://github.com/haskell-servant/servant/issues

16−license: BSD3

16+license: BSD-3-Clause

17license-file: LICENSE

17license-file: LICENSE

18author: Servant Contributors

18author: Servant Contributors

19maintainer: haskell-servant-maintainers@googlegroups.com

19maintainer: haskell-servant-maintainers@googlegroups.com

20−copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2018 Servant Contributors

20+copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors

21build-type: Simple

21build-type: Simple

22−tested-with:

22+tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1

23− GHC ==8.0.2

24− || ==8.2.2

25− || ==8.4.4

26− || ==8.6.2

27

23

28extra-source-files:

24extra-source-files:

29 CHANGELOG.md

25 CHANGELOG.md

@@ -45,27 +41,27 @@ library

45 --

41 --

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

47 build-depends:

43 build-depends:

48− base >= 4.9 && < 4.13

44+ base >= 4.9 && < 4.17

49− , bytestring >= 0.10.8.1 && < 0.11

45+ , bytestring >= 0.10.8.1 && < 0.12

50− , text >= 1.2.3.0 && < 1.3

46+ , text >= 1.2.3.0 && < 2.1

51

47

52 -- Servant dependencies

48 -- Servant dependencies

53 build-depends:

49 build-depends:

54− servant == 0.15.*

50+ servant >= 0.18 && <0.20

55

51

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

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

58 build-depends:

54 build-depends:

59− aeson >= 1.4.1.0 && < 1.5

55+ aeson >= 1.4.1.0 && < 3

60 , aeson-pretty >= 0.8.5 && < 0.9

56 , aeson-pretty >= 0.8.5 && < 0.9

61− , base-compat >= 0.10.5 && < 0.11

57+ , base-compat >= 0.10.5 && < 0.13

62 , case-insensitive >= 1.2.0.11 && < 1.3

58 , case-insensitive >= 1.2.0.11 && < 1.3

63− , control-monad-omega >= 0.3.1 && < 0.4

64− , hashable >= 1.2.7.0 && < 1.3

59+ , hashable >= 1.2.7.0 && < 1.5

65− , http-media >= 0.7.1.3 && < 0.8

60+ , http-media >= 0.7.1.3 && < 0.9

66 , http-types >= 0.12.2 && < 0.13

61 , http-types >= 0.12.2 && < 0.13

67− , lens >= 4.17 && < 4.18

62+ , lens >= 4.17 && < 5.2

68 , string-conversions >= 0.4.0.1 && < 0.5

63 , string-conversions >= 0.4.0.1 && < 0.5

64+ , universe-base >= 1.1.1 && < 1.2

69 , unordered-containers >= 0.2.9.0 && < 0.3

65 , unordered-containers >= 0.2.9.0 && < 0.3

70

66

71 hs-source-dirs: src

67 hs-source-dirs: src

@@ -104,10 +100,9 @@ test-suite spec

104 , servant-docs

100 , servant-docs

105 , string-conversions

101 , string-conversions

106

102

107− -- Additonal dependencies

103+ -- Additional dependencies

108 build-depends:

104 build-depends:

109− tasty >= 1.1.0.4 && < 1.2,

105+ tasty >= 1.1.0.4 && < 1.5,

110 tasty-golden >= 2.3.2 && < 2.4,

106 tasty-golden >= 2.3.2 && < 2.4,

111 tasty-hunit >= 0.10.0.1 && < 0.11,

107 tasty-hunit >= 0.10.0.1 && < 0.11,

112 transformers >= 0.5.2.0 && < 0.6

108 transformers >= 0.5.2.0 && < 0.6

113−

servant-docs/src/Servant/Docs/Internal.hs+167−38

@@ -25,17 +25,14 @@ import Control.Applicative

25import Control.Arrow

25import Control.Arrow

26 (second)

26 (second)

27import Control.Lens

27import Control.Lens

28− (makeLenses, mapped, over, traversed, view, (%~), (&), (.~),

28+ (makeLenses, mapped, each, over, set, to, toListOf, traversed, view,

29− (<>~), (^.), (|>))

29+ _1, (%~), (&), (.~), (<>~), (^.), (|>))

30−import qualified Control.Monad.Omega as Omega

31import qualified Data.ByteString.Char8 as BSC

30import qualified Data.ByteString.Char8 as BSC

32import Data.ByteString.Lazy.Char8

31import Data.ByteString.Lazy.Char8

33 (ByteString)

32 (ByteString)

34import qualified Data.CaseInsensitive as CI

33import qualified Data.CaseInsensitive as CI

35import Data.Foldable

34import Data.Foldable

36− (toList)

35+ (fold, toList)

37−import Data.Foldable

38− (fold)

39import Data.Hashable

36import Data.Hashable

40 (Hashable)

37 (Hashable)

41import Data.HashMap.Strict

38import Data.HashMap.Strict

@@ -53,17 +50,21 @@ import Data.Ord

53 (comparing)

50 (comparing)

54import Data.Proxy

51import Data.Proxy

55 (Proxy (Proxy))

52 (Proxy (Proxy))

56−import Data.Semigroup

57− (Semigroup (..))

58import Data.String.Conversions

53import Data.String.Conversions

59 (cs)

54 (cs)

60import Data.Text

55import Data.Text

61 (Text, unpack)

56 (Text, unpack)

62import GHC.Generics

57import GHC.Generics

58+ (Generic, Rep, K1(K1), M1(M1), U1(U1), V1,

59+ (:*:)((:*:)), (:+:)(L1, R1))

60+import qualified GHC.Generics as G

63import GHC.TypeLits

61import GHC.TypeLits

64import Servant.API

62import Servant.API

65import Servant.API.ContentTypes

63import Servant.API.ContentTypes

66import Servant.API.TypeLevel

64import Servant.API.TypeLevel

65+import Servant.API.Generic

66+

67+import qualified Data.Universe.Helpers as U

67

68

68import qualified Data.HashMap.Strict as HM

69import qualified Data.HashMap.Strict as HM

69import qualified Data.Text as T

70import qualified Data.Text as T

@@ -130,7 +131,8 @@ instance Semigroup API where

130 (<>) = mappend

131 (<>) = mappend

131

132

132instance Monoid API where

133instance Monoid API where

133− API a1 b1 `mappend` API a2 b2 = API (a1 `mappend` a2) (b1 `mappend` b2)

134+ API a1 b1 `mappend` API a2 b2 = API (a1 `mappend` a2)

135+ (HM.unionWith combineAction b1 b2)

134 mempty = API mempty mempty

136 mempty = API mempty mempty

135

137

136-- | An empty 'API'

138-- | An empty 'API'

@@ -159,6 +161,20 @@ data DocQueryParam = DocQueryParam

159 , _paramKind :: ParamKind

161 , _paramKind :: ParamKind

160 } deriving (Eq, Ord, Show)

162 } deriving (Eq, Ord, Show)

161

163

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+

162-- | An introductory paragraph for your documentation. You can pass these to

178-- | An introductory paragraph for your documentation. You can pass these to

163-- 'docsWithIntros'.

179-- 'docsWithIntros'.

164data DocIntro = DocIntro

180data DocIntro = DocIntro

@@ -239,6 +255,15 @@ data Response = Response

239 , _respHeaders :: [HTTP.Header]

255 , _respHeaders :: [HTTP.Header]

240 } deriving (Eq, Ord, Show)

256 } deriving (Eq, Ord, Show)

241

257

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+

242-- | Default response: status code 200, no response body.

267-- | Default response: status code 200, no response body.

243--

268--

244-- Can be tweaked with four lenses.

269-- Can be tweaked with four lenses.

@@ -270,8 +295,9 @@ defResponse = Response

270data Action = Action

295data Action = Action

271 { _authInfo :: [DocAuthentication] -- user supplied info

296 { _authInfo :: [DocAuthentication] -- user supplied info

272 , _captures :: [DocCapture] -- type collected + user supplied info

297 , _captures :: [DocCapture] -- type collected + user supplied info

273− , _headers :: [Text] -- type collected

298+ , _headers :: [HTTP.Header] -- type collected

274 , _params :: [DocQueryParam] -- type collected + user supplied info

299 , _params :: [DocQueryParam] -- type collected + user supplied info

300+ , _fragment :: Maybe DocFragment -- type collected + user supplied info

275 , _notes :: [DocNote] -- user supplied

301 , _notes :: [DocNote] -- user supplied

276 , _mxParams :: [(String, [DocQueryParam])] -- type collected + user supplied info

302 , _mxParams :: [(String, [DocQueryParam])] -- type collected + user supplied info

277 , _rqtypes :: [M.MediaType] -- type collected

303 , _rqtypes :: [M.MediaType] -- type collected

@@ -283,11 +309,11 @@ data Action = Action

283-- laws.

309-- laws.

284--

310--

285-- As such, we invent a non-commutative, left associative operation

311-- As such, we invent a non-commutative, left associative operation

286−-- 'combineAction' to mush two together taking the response, body and content

312+-- 'combineAction' to mush two together taking the response from the very left.

287−-- types from the very left.

288combineAction :: Action -> Action -> Action

313combineAction :: Action -> Action -> Action

289−Action a c h p n m ts body resp `combineAction` Action a' c' h' p' n' m' _ _ _ =

314+Action a c h p f n m ts body resp

315+ `combineAction` Action a' c' h' p' f' n' m' ts' body' resp' =

290− Action (a <> a') (c <> c') (h <> h') (p <> p') (n <> n') (m <> 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')

291

317

292-- | Default 'Action'. Has no 'captures', no query 'params', expects

318-- | Default 'Action'. Has no 'captures', no query 'params', expects

293-- no request body ('rqbody') and the typical response is 'defResponse'.

319-- no request body ('rqbody') and the typical response is 'defResponse'.

@@ -295,10 +321,10 @@ Action a c h p n m ts body resp `combineAction` Action a' c' h' p' n' m' _ _ _ =

295-- Tweakable with lenses.

321-- Tweakable with lenses.

296--

322--

297-- >>> defAction

323-- >>> defAction

298−-- Action {_authInfo = [], _captures = [], _headers = [], _params = [], _notes = [], _mxParams = [], _rqtypes = [], _rqbody = [], _response = Response {_respStatus = 200, _respTypes = [], _respBody = [], _respHeaders = []}}

324+-- Action {_authInfo = [], _captures = [], _headers = [], _params = [], _fragment = Nothing, _notes = [], _mxParams = [], _rqtypes = [], _rqbody = [], _response = Response {_respStatus = 200, _respTypes = [], _respBody = [], _respHeaders = []}}

299--

325--

300-- >>> defAction & response.respStatus .~ 201

326-- >>> defAction & response.respStatus .~ 201

301−-- Action {_authInfo = [], _captures = [], _headers = [], _params = [], _notes = [], _mxParams = [], _rqtypes = [], _rqbody = [], _response = Response {_respStatus = 201, _respTypes = [], _respBody = [], _respHeaders = []}}

327+-- Action {_authInfo = [], _captures = [], _headers = [], _params = [], _fragment = Nothing, _notes = [], _mxParams = [], _rqtypes = [], _rqbody = [], _response = Response {_respStatus = 201, _respTypes = [], _respBody = [], _respHeaders = []}}

302--

328--

303defAction :: Action

329defAction :: Action

304defAction =

330defAction =

@@ -306,6 +332,7 @@ defAction =

306 []

332 []

307 []

333 []

308 []

334 []

335+ Nothing

309 []

336 []

310 []

337 []

311 []

338 []

@@ -329,12 +356,14 @@ data ShowContentTypes = AllContentTypes -- ^ For each example, show each conten

329--

356--

330-- @since 0.11.1

357-- @since 0.11.1

331data RenderingOptions = RenderingOptions

358data RenderingOptions = RenderingOptions

332− { _requestExamples :: !ShowContentTypes

359+ { _requestExamples :: !ShowContentTypes

333 -- ^ How many content types to display for request body examples?

360 -- ^ How many content types to display for request body examples?

334− , _responseExamples :: !ShowContentTypes

361+ , _responseExamples :: !ShowContentTypes

335 -- ^ How many content types to display for response body examples?

362 -- ^ How many content types to display for response body examples?

336− , _notesHeading :: !(Maybe String)

363+ , _notesHeading :: !(Maybe String)

337 -- ^ Optionally group all 'notes' together under a common heading.

364 -- ^ 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`).

338 } deriving (Show)

367 } deriving (Show)

339

368

340-- | Default API generation options.

369-- | Default API generation options.

@@ -346,9 +375,10 @@ data RenderingOptions = RenderingOptions

346-- @since 0.11.1

375-- @since 0.11.1

347defRenderingOptions :: RenderingOptions

376defRenderingOptions :: RenderingOptions

348defRenderingOptions = RenderingOptions

377defRenderingOptions = RenderingOptions

349− { _requestExamples = AllContentTypes

378+ { _requestExamples = AllContentTypes

350− , _responseExamples = AllContentTypes

379+ , _responseExamples = AllContentTypes

351− , _notesHeading = Nothing

380+ , _notesHeading = Nothing

381+ , _renderCurlBasePath = Nothing

352 }

382 }

353

383

354-- gimme some lenses

384-- gimme some lenses

@@ -358,6 +388,7 @@ makeLenses ''API

358makeLenses ''Endpoint

388makeLenses ''Endpoint

359makeLenses ''DocCapture

389makeLenses ''DocCapture

360makeLenses ''DocQueryParam

390makeLenses ''DocQueryParam

391+makeLenses ''DocFragment

361makeLenses ''DocIntro

392makeLenses ''DocIntro

362makeLenses ''DocNote

393makeLenses ''DocNote

363makeLenses ''Response

394makeLenses ''Response

@@ -384,9 +415,9 @@ docsWithOptions p = docsFor p (defEndpoint, defAction)

384-- > extra :: ExtraInfo TestApi

415-- > extra :: ExtraInfo TestApi

385-- > extra =

416-- > extra =

386-- > extraInfo (Proxy :: Proxy ("greet" :> Capture "greetid" Text :> Delete)) $

417-- > extraInfo (Proxy :: Proxy ("greet" :> Capture "greetid" Text :> Delete)) $

387−-- > defAction & headers <>~ ["unicorns"]

418+-- > defAction & headers <>~ [("X-Num-Unicorns", 1)]

388-- > & notes <>~ [ DocNote "Title" ["This is some text"]

419-- > & notes <>~ [ DocNote "Title" ["This is some text"]

389−-- > , DocNote "Second secton" ["And some more"]

420+-- > , DocNote "Second section" ["And some more"]

390-- > ]

421-- > ]

391

422

392extraInfo :: (IsIn endpoint api, HasLink endpoint, HasDocs endpoint)

423extraInfo :: (IsIn endpoint api, HasLink endpoint, HasDocs endpoint)

@@ -479,22 +510,22 @@ samples = map ("",)

479

510

480-- | Default sample Generic-based inputs/outputs.

511-- | Default sample Generic-based inputs/outputs.

481defaultSamples :: forall a. (Generic a, GToSample (Rep a)) => Proxy a -> [(Text, a)]

512defaultSamples :: forall a. (Generic a, GToSample (Rep a)) => Proxy a -> [(Text, a)]

482−defaultSamples _ = Omega.runOmega $ second to <$> gtoSamples (Proxy :: Proxy (Rep a))

513+defaultSamples _ = second G.to <$> gtoSamples (Proxy :: Proxy (Rep a))

483

514

484-- | @'ToSample'@ for Generics.

515-- | @'ToSample'@ for Generics.

485--

516--

486−-- The use of @'Omega'@ allows for more productive sample generation.

517+-- Note: we use combinators from "Universe.Data.Helpers" for more productive sample generation.

487class GToSample t where

518class GToSample t where

488− gtoSamples :: proxy t -> Omega.Omega (Text, t x)

519+ gtoSamples :: proxy t -> [(Text, t x)]

489

520

490instance GToSample U1 where

521instance GToSample U1 where

491− gtoSamples _ = Omega.each (singleSample U1)

522+ gtoSamples _ = singleSample U1

492

523

493instance GToSample V1 where

524instance GToSample V1 where

494 gtoSamples _ = empty

525 gtoSamples _ = empty

495

526

496instance (GToSample p, GToSample q) => GToSample (p :*: q) where

527instance (GToSample p, GToSample q) => GToSample (p :*: q) where

497− gtoSamples _ = render <$> ps <*> qs

528+ gtoSamples _ = U.cartesianProduct render ps qs

498 where

529 where

499 ps = gtoSamples (Proxy :: Proxy p)

530 ps = gtoSamples (Proxy :: Proxy p)

500 qs = gtoSamples (Proxy :: Proxy q)

531 qs = gtoSamples (Proxy :: Proxy q)

@@ -503,13 +534,13 @@ instance (GToSample p, GToSample q) => GToSample (p :*: q) where

503 | otherwise = (ta <> ", " <> tb, a :*: b)

534 | otherwise = (ta <> ", " <> tb, a :*: b)

504

535

505instance (GToSample p, GToSample q) => GToSample (p :+: q) where

536instance (GToSample p, GToSample q) => GToSample (p :+: q) where

506− gtoSamples _ = lefts <|> rights

537+ gtoSamples _ = lefts U.+++ rights

507 where

538 where

508 lefts = second L1 <$> gtoSamples (Proxy :: Proxy p)

539 lefts = second L1 <$> gtoSamples (Proxy :: Proxy p)

509 rights = second R1 <$> gtoSamples (Proxy :: Proxy q)

540 rights = second R1 <$> gtoSamples (Proxy :: Proxy q)

510

541

511instance ToSample a => GToSample (K1 i a) where

542instance ToSample a => GToSample (K1 i a) where

512− gtoSamples _ = second K1 <$> Omega.each (toSamples (Proxy :: Proxy a))

543+ gtoSamples _ = second K1 <$> toSamples (Proxy :: Proxy a)

513

544

514instance (GToSample f) => GToSample (M1 i a f) where

545instance (GToSample f) => GToSample (M1 i a f) where

515 gtoSamples _ = second M1 <$> gtoSamples (Proxy :: Proxy f)

546 gtoSamples _ = second M1 <$> gtoSamples (Proxy :: Proxy f)

@@ -577,6 +608,15 @@ class ToCapture c where

577class ToAuthInfo a where

608class ToAuthInfo a where

578 toAuthInfo :: Proxy a -> DocAuthentication

609 toAuthInfo :: Proxy a -> DocAuthentication

579

610

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+

580-- | Generate documentation in Markdown format for

620-- | Generate documentation in Markdown format for

581-- the given 'API'.

621-- the given 'API'.

582--

622--

@@ -606,7 +646,7 @@ markdown = markdownWith defRenderingOptions

606--

646--

607-- @since 0.11.1

647-- @since 0.11.1

608markdownWith :: RenderingOptions -> API -> String

648markdownWith :: RenderingOptions -> API -> String

609−markdownWith RenderingOptions{..} api = unlines $

649+markdownWith RenderingOptions{..} api = unlines $

610 introsStr (api ^. apiIntros)

650 introsStr (api ^. apiIntros)

611 ++ (concatMap (uncurry printEndpoint) . sort . HM.toList $ api ^. apiEndpoints)

651 ++ (concatMap (uncurry printEndpoint) . sort . HM.toList $ api ^. apiEndpoints)

612

652

@@ -617,10 +657,12 @@ markdownWith RenderingOptions{..} api = unlines $

617 notesStr (action ^. notes) ++

657 notesStr (action ^. notes) ++

618 authStr (action ^. authInfo) ++

658 authStr (action ^. authInfo) ++

619 capturesStr (action ^. captures) ++

659 capturesStr (action ^. captures) ++

620− headersStr (action ^. headers) ++

660+ headersStr (toListOf (headers . each . _1 . to (T.pack . BSC.unpack . CI.original)) action) ++

621 paramsStr meth (action ^. params) ++

661 paramsStr meth (action ^. params) ++

662+ fragmentStr (action ^. fragment) ++

622 rqbodyStr (action ^. rqtypes) (action ^. rqbody) ++

663 rqbodyStr (action ^. rqtypes) (action ^. rqbody) ++

623 responseStr (action ^. response) ++

664 responseStr (action ^. response) ++

665+ maybe [] (curlStr endpoint (action ^. headers) (action ^. rqbody)) _renderCurlBasePath ++

624 []

666 []

625

667

626 where str = "## " ++ BSC.unpack meth

668 where str = "## " ++ BSC.unpack meth

@@ -720,6 +762,14 @@ markdownWith RenderingOptions{..} api = unlines $

720

762

721 where values = param ^. paramValues

763 where values = param ^. paramValues

722

764

765+ fragmentStr :: Maybe DocFragment -> [String]

766+ fragmentStr Nothing = []

767+ fragmentStr (Just frag) =

768+ [ "### Fragment:", ""

769+ , "- *" ++ (frag ^. fragSymbol) ++ "*: " ++ (frag ^. fragDesc)

770+ , ""

771+ ]

772+

723 rqbodyStr :: [M.MediaType] -> [(Text, M.MediaType, ByteString)]-> [String]

773 rqbodyStr :: [M.MediaType] -> [(Text, M.MediaType, ByteString)]-> [String]

724 rqbodyStr [] [] = []

774 rqbodyStr [] [] = []

725 rqbodyStr types s =

775 rqbodyStr types s =

@@ -768,7 +818,6 @@ markdownWith RenderingOptions{..} api = unlines $

768 ("text", "css") -> "css"

818 ("text", "css") -> "css"

769 (_, _) -> ""

819 (_, _) -> ""

770

820

771−

772 contentStr mime_type body =

821 contentStr mime_type body =

773 "" :

822 "" :

774 "```" <> markdownForType mime_type :

823 "```" <> markdownForType mime_type :

@@ -793,6 +842,36 @@ markdownWith RenderingOptions{..} api = unlines $

793 xs ->

842 xs ->

794 formatBodies _responseExamples xs

843 formatBodies _responseExamples xs

795

844

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+

796-- * Instances

875-- * Instances

797

876

798-- | The generated docs for @a ':<|>' b@ just appends the docs

877-- | The generated docs for @a ':<|>' b@ just appends the docs

@@ -816,7 +895,7 @@ instance HasDocs EmptyAPI where

816-- | @"books" :> 'Capture' "isbn" Text@ will appear as

895-- | @"books" :> 'Capture' "isbn" Text@ will appear as

817-- @/books/:isbn@ in the docs.

896-- @/books/:isbn@ in the docs.

818instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs api)

897instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs api)

819− => HasDocs (Capture' mods sym a :> api) where

898+ => HasDocs (Capture' '[] sym a :> api) where

820

899

821 docsFor Proxy (endpoint, action) =

900 docsFor Proxy (endpoint, action) =

822 docsFor subApiP (endpoint', action')

901 docsFor subApiP (endpoint', action')

@@ -828,6 +907,28 @@ instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs api)

828 endpoint' = over path (\p -> p ++ [":" ++ symbolVal symP]) endpoint

907 endpoint' = over path (\p -> p ++ [":" ++ symbolVal symP]) endpoint

829 symP = Proxy :: Proxy sym

908 symP = Proxy :: Proxy sym

830

909

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+

831

932

832-- | @"books" :> 'CaptureAll' "isbn" Text@ will appear as

933-- | @"books" :> 'CaptureAll' "isbn" Text@ will appear as

833-- @/books/:isbn@ in the docs.

934-- @/books/:isbn@ in the docs.

@@ -861,6 +962,18 @@ instance {-# OVERLAPPABLE #-}

861 status = fromInteger $ natVal (Proxy :: Proxy status)

962 status = fromInteger $ natVal (Proxy :: Proxy status)

862 p = Proxy :: Proxy a

963 p = Proxy :: Proxy a

863

964

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+

864-- | TODO: mention the endpoint is streaming, its framing strategy

977-- | TODO: mention the endpoint is streaming, its framing strategy

865--

978--

866-- Also there are no samples.

979-- Also there are no samples.

@@ -897,14 +1010,17 @@ instance {-# OVERLAPPING #-}

897 status = fromInteger $ natVal (Proxy :: Proxy status)

1010 status = fromInteger $ natVal (Proxy :: Proxy status)

898 p = Proxy :: Proxy a

1011 p = Proxy :: Proxy a

899

1012

900−instance (KnownSymbol sym, HasDocs api)

1013+instance (ToHttpApiData a, ToSample a, KnownSymbol sym, HasDocs api)

901 => HasDocs (Header' mods sym a :> api) where

1014 => HasDocs (Header' mods sym a :> api) where

902 docsFor Proxy (endpoint, action) =

1015 docsFor Proxy (endpoint, action) =

903 docsFor subApiP (endpoint, action')

1016 docsFor subApiP (endpoint, action')

904

1017

905 where subApiP = Proxy :: Proxy api

1018 where subApiP = Proxy :: Proxy api

906− action' = over headers (|> headername) action

1019+ action' = over headers (|> (headerName, headerVal)) action

907− headername = T.pack $ symbolVal (Proxy :: Proxy sym)

1020+ headerName = CI.mk . cs $ symbolVal (Proxy :: Proxy sym)

1021+ headerVal = case toSample (Proxy :: Proxy a) of

1022+ Just x -> cs $ toHeader x

1023+ Nothing -> "<no header sample provided>"

908

1024

909instance (KnownSymbol sym, ToParam (QueryParam' mods sym a), HasDocs api)

1025instance (KnownSymbol sym, ToParam (QueryParam' mods sym a), HasDocs api)

910 => HasDocs (QueryParam' mods sym a :> api) where

1026 => HasDocs (QueryParam' mods sym a :> api) where

@@ -937,6 +1053,15 @@ instance (KnownSymbol sym, ToParam (QueryFlag sym), HasDocs api)

937 paramP = Proxy :: Proxy (QueryFlag sym)

1053 paramP = Proxy :: Proxy (QueryFlag sym)

938 action' = over params (|> toParam paramP) action

1054 action' = over params (|> toParam paramP) action

939

1055

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

940

1065

941instance HasDocs Raw where

1066instance HasDocs Raw where

942 docsFor _proxy (endpoint, action) _ =

1067 docsFor _proxy (endpoint, action) _ =

@@ -1026,6 +1151,9 @@ instance (ToAuthInfo (BasicAuth realm usr), HasDocs api) => HasDocs (BasicAuth r

1026 authProxy = Proxy :: Proxy (BasicAuth realm usr)

1151 authProxy = Proxy :: Proxy (BasicAuth realm usr)

1027 action' = over authInfo (|> toAuthInfo authProxy) action

1152 action' = over authInfo (|> toAuthInfo authProxy) action

1028

1153

1154+instance HasDocs (ToServantApi api) => HasDocs (NamedRoutes api) where

1155+ docsFor Proxy = docsFor (Proxy :: Proxy (ToServantApi api))

1156+

1029-- ToSample instances for simple types

1157-- ToSample instances for simple types

1030instance ToSample NoContent

1158instance ToSample NoContent

1031instance ToSample Bool

1159instance ToSample Bool

@@ -1042,6 +1170,7 @@ instance (ToSample a, ToSample b, ToSample c, ToSample d, ToSample e, ToSample f

1042instance ToSample a => ToSample (Maybe a)

1170instance ToSample a => ToSample (Maybe a)

1043instance (ToSample a, ToSample b) => ToSample (Either a b)

1171instance (ToSample a, ToSample b) => ToSample (Either a b)

1044instance ToSample a => ToSample [a]

1172instance ToSample a => ToSample [a]

1173+instance ToSample a => ToSample (NonEmpty a)

1045

1174

1046-- ToSample instances for Control.Applicative types

1175-- ToSample instances for Control.Applicative types

1047instance ToSample a => ToSample (Const a b)

1176instance ToSample a => ToSample (Const a b)

servant-docs/src/Servant/Docs/Internal/Pretty.hs+19

@@ -18,6 +18,7 @@ import Data.Proxy

18import Network.HTTP.Media

18import Network.HTTP.Media

19 ((//))

19 ((//))

20import Servant.API

20import Servant.API

21+import Servant.API.Verbs

21

22

22-- | PrettyJSON content type.

23-- | PrettyJSON content type.

23data PrettyJSON

24data PrettyJSON

@@ -46,6 +47,24 @@ type family Pretty (api :: k) :: k where

46 Pretty (Put cs r) = Put (Pretty cs) r

47 Pretty (Put cs r) = Put (Pretty cs) r

47 Pretty (Delete cs r) = Delete (Pretty cs) r

48 Pretty (Delete cs r) = Delete (Pretty cs) r

48 Pretty (Patch cs r) = Patch (Pretty cs) r

49 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

49 Pretty (ReqBody cs r) = ReqBody (Pretty cs) r

68 Pretty (ReqBody cs r) = ReqBody (Pretty cs) r

50 Pretty (JSON ': xs) = PrettyJSON ': xs

69 Pretty (JSON ': xs) = PrettyJSON ': xs

51 Pretty (x ': xs) = x ': Pretty xs

70 Pretty (x ': xs) = x ': Pretty xs

servant-docs/test/Servant/DocsSpec.hs+21−6

@@ -58,6 +58,8 @@ instance ToCapture (Capture "foo" Int) where

58 toCapture _ = DocCapture "foo" "Capture foo Int"

58 toCapture _ = DocCapture "foo" "Capture foo Int"

59instance ToCapture (CaptureAll "foo" Int) where

59instance ToCapture (CaptureAll "foo" Int) where

60 toCapture _ = DocCapture "foo" "Capture all foo Int"

60 toCapture _ = DocCapture "foo" "Capture all foo Int"

61+instance ToFragment (Fragment Int) where

62+ toFragment _ = DocFragment "foo" "Fragment Int"

61

63

62-- * specs

64-- * specs

63

65

@@ -66,8 +68,10 @@ spec = describe "Servant.Docs" $ do

66 golden "comprehensive API" "golden/comprehensive.md" (markdown comprehensiveDocs)

68 golden "comprehensive API" "golden/comprehensive.md" (markdown comprehensiveDocs)

67

69

68 describe "markdown" $ do

70 describe "markdown" $ do

69− let md = markdown (docs (Proxy :: Proxy TestApi1))

71+ let md1 = markdown (docs (Proxy :: Proxy TestApi1))

70− tests md

72+ tests1 md1

73+ let md2 = markdown (docs (Proxy :: Proxy TestApi2))

74+ tests2 md2

71

75

72 describe "markdown with extra info" $ do

76 describe "markdown with extra info" $ do

73 let

77 let

@@ -79,7 +83,7 @@ spec = describe "Servant.Docs" $ do

79 (Proxy :: Proxy (ReqBody '[JSON] String :> Post '[JSON] Datatype1))

83 (Proxy :: Proxy (ReqBody '[JSON] String :> Post '[JSON] Datatype1))

80 (defAction & notes <>~ [DocNote "Post data" ["Posts some Json data"]])

84 (defAction & notes <>~ [DocNote "Post data" ["Posts some Json data"]])

81 md = markdown (docsWith defaultDocOptions [] extra (Proxy :: Proxy TestApi1))

85 md = markdown (docsWith defaultDocOptions [] extra (Proxy :: Proxy TestApi1))

82− tests md

86+ tests1 md

83 it "contains the extra info provided" $ do

87 it "contains the extra info provided" $ do

84 md `shouldContain` "Get an Integer"

88 md `shouldContain` "Get an Integer"

85 md `shouldContain` "Post data"

89 md `shouldContain` "Post data"

@@ -107,7 +111,7 @@ spec = describe "Servant.Docs" $ do

107

111

108

112

109 where

113 where

110− tests md = do

114+ tests1 md = do

111 it "mentions supported content-types" $ do

115 it "mentions supported content-types" $ do

112 md `shouldContain` "application/json"

116 md `shouldContain` "application/json"

113 md `shouldContain` "text/plain;charset=utf-8"

117 md `shouldContain` "text/plain;charset=utf-8"

@@ -122,14 +126,21 @@ spec = describe "Servant.Docs" $ do

122 it "mentions headers" $ do

126 it "mentions headers" $ do

123 md `shouldContain` "- This endpoint is sensitive to the value of the **X-Test** HTTP header."

127 md `shouldContain` "- This endpoint is sensitive to the value of the **X-Test** HTTP header."

124

128

125− it "contains response samples" $

129+ it "contains response samples - dt1field1" $

126− md `shouldContain` "{\"dt1field1\":\"field 1\",\"dt1field2\":13}"

130+ md `shouldContain` "\"dt1field1\":\"field 1\""

131+ it "contains response samples - dt1field2" $

132+ md `shouldContain` "\"dt1field2\":13"

127 it "contains request body samples" $

133 it "contains request body samples" $

128 md `shouldContain` "17"

134 md `shouldContain` "17"

129

135

130 it "does not generate any docs mentioning the 'empty-api' path" $

136 it "does not generate any docs mentioning the 'empty-api' path" $

131 md `shouldNotContain` "empty-api"

137 md `shouldNotContain` "empty-api"

132

138

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+

133

144

134-- * APIs

145-- * APIs

135

146

@@ -156,6 +167,10 @@ type TestApi1 = Get '[JSON, PlainText] (Headers '[Header "Location" String] Int)

156 :<|> Header "X-Test" Int :> Put '[JSON] Int

167 :<|> Header "X-Test" Int :> Put '[JSON] Int

157 :<|> "empty-api" :> EmptyAPI

168 :<|> "empty-api" :> EmptyAPI

158

169

170+type TestApi2 = "duplicate-endpoint" :> Get '[JSON] Datatype1

171+ :<|> "duplicate-endpoint" :> Get '[PlainText] Int

172+

173+

159data TT = TT1 | TT2 deriving (Show, Eq)

174data TT = TT1 | TT2 deriving (Show, Eq)

160data UT = UT1 | UT2 deriving (Show, Eq)

175data UT = UT1 | UT2 deriving (Show, Eq)

161

176

servant-foreign/CHANGELOG.md+87

@@ -1,6 +1,93 @@

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

40.15

910.15

5----

92----

6

93

servant-foreign/servant-foreign.cabal+14−19

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

1−cabal-version: >=1.10

1+cabal-version: 2.2

2name: servant-foreign

2name: servant-foreign

3−version: 0.15

3+version: 0.15.4

4

4

5synopsis: Helpers for generating clients for servant APIs in any programming language

5synopsis: Helpers for generating clients for servant APIs in any programming language

6category: Servant, Web

6category: Servant, Web

@@ -13,19 +13,15 @@ description:

13 .

13 .

14 <https://github.com/haskell-servant/servant/blob/master/servant-foreign/CHANGELOG.md CHANGELOG>

14 <https://github.com/haskell-servant/servant/blob/master/servant-foreign/CHANGELOG.md CHANGELOG>

15

15

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

16+homepage: http://docs.servant.dev/

17bug-reports: http://github.com/haskell-servant/servant/issues

17bug-reports: http://github.com/haskell-servant/servant/issues

18−license: BSD3

18+license: BSD-3-Clause

19license-file: LICENSE

19license-file: LICENSE

20author: Servant Contributors

20author: Servant Contributors

21maintainer: haskell-servant-maintainers@googlegroups.com

21maintainer: haskell-servant-maintainers@googlegroups.com

22−copyright: 2015-2018 Servant Contributors

22+copyright: 2015-2019 Servant Contributors

23build-type: Simple

23build-type: Simple

24−tested-with:

24+tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1

25− GHC ==8.0.2

26− || ==8.2.2

27− || ==8.4.4

28− || ==8.6.2

29

25

30extra-source-files:

26extra-source-files:

31 CHANGELOG.md

27 CHANGELOG.md

@@ -45,18 +41,18 @@ library

45 --

41 --

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

47 build-depends:

43 build-depends:

48− base >= 4.9 && < 4.13

44+ base >= 4.9 && < 4.17

49− , text >= 1.2.3.0 && < 1.3

45+ , text >= 1.2.3.0 && < 2.1

50

46

51 -- Servant dependencies

47 -- Servant dependencies

52 build-depends:

48 build-depends:

53− servant == 0.15.*

49+ servant >=0.18 && <0.20

54

50

55 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.

51 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.

56 -- Here can be exceptions if we really need features from the newer versions.

52 -- Here can be exceptions if we really need features from the newer versions.

57 build-depends:

53 build-depends:

58− base-compat >= 0.10.5 && < 0.11

54+ base-compat >= 0.10.5 && < 0.13

59− , lens >= 4.17 && < 4.18

55+ , lens >= 4.17 && < 5.2

60 , http-types >= 0.12.2 && < 0.13

56 , http-types >= 0.12.2 && < 0.13

61

57

62 hs-source-dirs: src

58 hs-source-dirs: src

@@ -76,10 +72,9 @@ test-suite spec

76 , servant

72 , servant

77 , servant-foreign

73 , servant-foreign

78

74

79− -- Additonal dependencies

75+ -- Additional dependencies

80 build-depends:

76 build-depends:

81− hspec >= 2.6.0 && <2.8

77+ hspec >= 2.6.0 && <2.10

82−

83 build-tool-depends:

78 build-tool-depends:

84− hspec-discover:hspec-discover >=2.6.0 && <2.8

79+ hspec-discover:hspec-discover >=2.6.0 && <2.10

85 default-language: Haskell2010

80 default-language: Haskell2010

servant-foreign/src/Servant/Foreign.hs+22−19

@@ -1,20 +1,32 @@

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

3module Servant.Foreign

5module Servant.Foreign

4− ( ArgType(..)

6+ (

5− , HeaderArg(..)

7+ -- * Main API

6− , QueryArg(..)

8+ listFromAPI

7 , Req(..)

9 , Req(..)

8− , ReqBodyContentType(..)

10+ , defReq

9− , Segment(..)

11+ , HasForeignType(..)

10− , SegmentType(..)

12+ , GenerateList(..)

13+ , HasForeign(..)

14+ , NoTypes

15+ -- * Subtypes of 'Req'

11 , Url(..)

16 , Url(..)

12− -- aliases

13 , Path

17 , Path

18+ , Segment(..)

19+ , SegmentType(..)

20+ , isCapture

21+ , captureArg

22+ , QueryArg(..)

23+ , ArgType(..)

24+ , HeaderArg(..)

14 , Arg(..)

25 , Arg(..)

15 , FunctionName(..)

26 , FunctionName(..)

27+ , ReqBodyContentType(..)

16 , PathSegment(..)

28 , PathSegment(..)

17− -- lenses

29+ -- * Lenses

18 , argName

30 , argName

19 , argType

31 , argType

20 , argPath

32 , argPath

@@ -30,7 +42,7 @@ module Servant.Foreign

30 , queryArgName

42 , queryArgName

31 , queryArgType

43 , queryArgType

32 , headerArg

44 , headerArg

33− -- prisms

45+ -- * Prisms

34 , _PathSegment

46 , _PathSegment

35 , _HeaderArg

47 , _HeaderArg

36 , _ReplaceHeaderArg

48 , _ReplaceHeaderArg

@@ -39,16 +51,7 @@ module Servant.Foreign

39 , _Normal

51 , _Normal

40 , _Flag

52 , _Flag

41 , _List

53 , _List

42− -- rest of it

43− , HasForeign(..)

44− , HasForeignType(..)

45− , GenerateList(..)

46− , NoTypes

47− , captureArg

48− , isCapture

49− , defReq

50− , listFromAPI

51− -- re-exports

54+ -- * Re-exports

52 , module Servant.API

55 , module Servant.API

53 , module Servant.Foreign.Inflections

56 , module Servant.Foreign.Inflections

54 ) where

57 ) where

servant-foreign/src/Servant/Foreign/Inflections.hs+18−13

@@ -13,27 +13,37 @@ 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

17import Data.Text hiding

16import Data.Text hiding

18 (map)

17 (map)

19import Prelude hiding

18import Prelude hiding

20 (head, tail)

19 (head, tail)

21import Servant.Foreign.Internal

20import Servant.Foreign.Internal

22

21

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+

23concatCaseL :: Getter FunctionName Text

28concatCaseL :: Getter FunctionName Text

24concatCaseL = _FunctionName . to mconcat

29concatCaseL = _FunctionName . to mconcat

25

30

26−-- | Function name builder that simply concat each part together

31+-- | Use the snake_case convention.

32+-- Each part is separated by a single underscore character.

33+--

34+-- @[ "get", "documents", "by", "id" ] → "get_documents_by_id"@

27−concatCase :: FunctionName -> Text

35+snakeCase :: FunctionName -> Text

28−concatCase = view concatCaseL

36+snakeCase = view snakeCaseL

29

37

30snakeCaseL :: Getter FunctionName Text

38snakeCaseL :: Getter FunctionName Text

31snakeCaseL = _FunctionName . to (intercalate "_")

39snakeCaseL = _FunctionName . to (intercalate "_")

32

40

33−-- | Function name builder using the snake_case convention.

41+-- | Use the camelCase convention.

34−-- each part is separated by a single underscore character.

42+-- The first part is lower case, every other part starts with an upper case character.

43+--

44+-- @[ "get", "documents", "by", "id" ] → "getDocumentsById"@

35−snakeCase :: FunctionName -> Text

45+camelCase :: FunctionName -> Text

36−snakeCase = view snakeCaseL

46+camelCase = view camelCaseL

37

47

38camelCaseL :: Getter FunctionName Text

48camelCaseL :: Getter FunctionName Text

39camelCaseL = _FunctionName . to convert

49camelCaseL = _FunctionName . to convert

@@ -42,8 +52,3 @@ camelCaseL = _FunctionName . to convert

42 convert (p:ps) = mconcat $ p : map capitalize ps

52 convert (p:ps) = mconcat $ p : map capitalize ps

43 capitalize "" = ""

53 capitalize "" = ""

44 capitalize name = C.toUpper (head name) `cons` tail name

54 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+147−32

@@ -13,8 +13,6 @@

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.

18module Servant.Foreign.Internal where

16module Servant.Foreign.Internal where

19

17

20import Prelude ()

18import Prelude ()

@@ -25,8 +23,6 @@ import Control.Lens

25import Data.Data

23import Data.Data

26 (Data)

24 (Data)

27import Data.Proxy

25import Data.Proxy

28−import Data.Semigroup

29− (Semigroup)

30import Data.String

26import Data.String

31import Data.Text

27import Data.Text

32import Data.Text.Encoding

28import Data.Text.Encoding

@@ -40,50 +36,75 @@ import Servant.API.Modifiers

40 (RequiredArgument)

36 (RequiredArgument)

41import Servant.API.TypeLevel

37import Servant.API.TypeLevel

42

38

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

43newtype FunctionName = FunctionName { unFunctionName :: [Text] }

42newtype FunctionName = FunctionName { unFunctionName :: [Text] }

44 deriving (Data, Show, Eq, Semigroup, Monoid, Typeable)

43 deriving (Data, Show, Eq, Semigroup, Monoid, Typeable)

45

44

46makePrisms ''FunctionName

45makePrisms ''FunctionName

47

46

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.

53−data Arg f = Arg

56+data Arg ftype = Arg

54 { _argName :: PathSegment

57 { _argName :: PathSegment

58+ -- ^ The name to be captured.

59+ --

60+ -- Only for capture args it really denotes a path segment.

55− , _argType :: f }

61+ , _argType :: ftype

62+ -- ^ Foreign type the associated value will have

63+ }

56 deriving (Data, Eq, Show, Typeable)

64 deriving (Data, Eq, Show, Typeable)

57

65

58makeLenses ''Arg

66makeLenses ''Arg

59

67

60−argPath :: Getter (Arg f) Text

68+argPath :: Getter (Arg ftype) Text

61argPath = argName . _PathSegment

69argPath = argName . _PathSegment

62

70

63−data SegmentType f

71+data SegmentType ftype

64 = Static PathSegment

72 = Static PathSegment

65− -- ^ a static path segment. like "/foo"

73+ -- ^ Static path segment.

74+ --

75+ -- @"foo\/bar\/baz"@

76+ --

77+ -- contains the static segments @"foo"@, @"bar"@ and @"baz"@.

66− | Cap (Arg f)

78+ | Cap (Arg ftype)

67− -- ^ a capture. like "/:userid"

79+ -- ^ A capture.

80+ --

81+ -- @"user\/{userid}\/name"@

82+ --

83+ -- would capture the arg @userid@ with type @ftype@.

68 deriving (Data, Eq, Show, Typeable)

84 deriving (Data, Eq, Show, Typeable)

69

85

70makePrisms ''SegmentType

86makePrisms ''SegmentType

71

87

88+-- | A part of the Url’s path.

72−newtype Segment f = Segment { unSegment :: SegmentType f }

89+newtype Segment ftype = Segment { unSegment :: SegmentType ftype }

73 deriving (Data, Eq, Show, Typeable)

90 deriving (Data, Eq, Show, Typeable)

74

91

75makePrisms ''Segment

92makePrisms ''Segment

76

93

94+-- | Whether a segment is a 'Cap'.

77−isCapture :: Segment f -> Bool

95+isCapture :: Segment ftype -> Bool

78isCapture (Segment (Cap _)) = True

96isCapture (Segment (Cap _)) = True

79isCapture _ = False

97isCapture _ = False

80

98

99+-- | Crashing Arg extraction from segment, TODO: remove

81−captureArg :: Segment f -> Arg f

100+captureArg :: Segment ftype -> Arg ftype

82captureArg (Segment (Cap s)) = s

101captureArg (Segment (Cap s)) = s

83captureArg _ = error "captureArg called on non capture"

102captureArg _ = error "captureArg called on non capture"

84

103

104+-- TODO: remove, unnecessary indirection

85−type Path f = [Segment f]

105+type Path ftype = [Segment ftype]

86

106

107+-- | Type of a 'QueryArg'.

87data ArgType

108data ArgType

88 = Normal

109 = Normal

89 | Flag

110 | Flag

@@ -92,18 +113,41 @@ data ArgType

92

113

93makePrisms ''ArgType

114makePrisms ''ArgType

94

115

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.

95−data QueryArg f = QueryArg

132+data QueryArg ftype = QueryArg

96− { _queryArgName :: Arg f

133+ { _queryArgName :: Arg ftype

134+ -- ^ Name and foreign type of the argument. Will be wrapped in `Maybe` if the query is optional and in a `[]` if the query is a list

97 , _queryArgType :: ArgType

135 , _queryArgType :: ArgType

136+ -- ^ one of normal/plain, list or flag

98 }

137 }

99 deriving (Data, Eq, Show, Typeable)

138 deriving (Data, Eq, Show, Typeable)

100

139

101makeLenses ''QueryArg

140makeLenses ''QueryArg

102

141

103−data HeaderArg f = HeaderArg

142+data HeaderArg ftype =

143+ -- | The name of the header and the foreign type of its value.

144+ HeaderArg

104− { _headerArg :: Arg f }

145+ { _headerArg :: Arg ftype }

146+ -- | Unused, will never be set.

147+ --

148+ -- TODO: remove

105 | ReplaceHeaderArg

149 | ReplaceHeaderArg

106− { _headerArg :: Arg f

150+ { _headerArg :: Arg ftype

107 , _headerPattern :: Text

151 , _headerPattern :: Text

108 }

152 }

109 deriving (Data, Eq, Show, Typeable)

153 deriving (Data, Eq, Show, Typeable)

@@ -112,28 +156,71 @@ makeLenses ''HeaderArg

112

156

113makePrisms ''HeaderArg

157makePrisms ''HeaderArg

114

158

159+-- | Full endpoint url, with all captures and parameters

115−data Url f = Url

160+data Url ftype = Url

116− { _path :: Path f

161+ { _path :: Path ftype

162+ -- ^ Url path, list of either static segments or captures

163+ --

164+ -- @"foo\/{id}\/bar"@

117− , _queryStr :: [QueryArg f]

165+ , _queryStr :: [QueryArg ftype]

166+ -- ^ List of query args

167+ --

168+ -- @"?foo=bar&a=b"@

169+ , _frag :: Maybe ftype

170+ -- ^ Url fragment.

171+ --

172+ -- Not sent to the HTTP server, so only useful for frontend matters (e.g. inter-page linking).

173+ --

174+ -- @#fragmentText@

118 }

175 }

119 deriving (Data, Eq, Show, Typeable)

176 deriving (Data, Eq, Show, Typeable)

120

177

121−defUrl :: Url f

178+defUrl :: Url ftype

122−defUrl = Url [] []

179+defUrl = Url [] [] Nothing

123

180

124makeLenses ''Url

181makeLenses ''Url

125

182

183+-- | See documentation of '_reqBodyContentType'

126data ReqBodyContentType = ReqBodyJSON | ReqBodyMultipart

184data ReqBodyContentType = ReqBodyJSON | ReqBodyMultipart

127 deriving (Data, Eq, Show, Read)

185 deriving (Data, Eq, Show, Read)

128

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.

129−data Req f = Req

192+data Req ftype = Req

130− { _reqUrl :: Url f

193+ { _reqUrl :: Url ftype

194+ -- ^ Full list of URL segments, including captures

131 , _reqMethod :: HTTP.Method

195 , _reqMethod :: HTTP.Method

196+ -- ^ @\"GET\"@\/@\"POST\"@\/@\"PUT\"@\/…

132− , _reqHeaders :: [HeaderArg f]

197+ , _reqHeaders :: [HeaderArg ftype]

198+ -- ^ Headers required by this endpoint, with their type

133− , _reqBody :: Maybe f

199+ , _reqBody :: Maybe ftype

200+ -- ^ Foreign type of the expected request body ('ReqBody'), if any

134− , _reqReturnType :: Maybe f

201+ , _reqReturnType :: Maybe ftype

202+ -- ^ The foreign type of the response, if any

135 , _reqFuncName :: FunctionName

203 , _reqFuncName :: FunctionName

204+ -- ^ The URL segments rendered in a way that they can be easily concatenated into a canonical function name

136 , _reqBodyContentType :: ReqBodyContentType

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

137 }

224 }

138 deriving (Data, Eq, Show, Typeable)

225 deriving (Data, Eq, Show, Typeable)

139

226

@@ -157,7 +244,7 @@ defReq = Req defUrl "GET" [] Nothing Nothing (FunctionName []) ReqBodyJSON

157-- >

244-- >

158-- > -- Or for example in case of lists

245-- > -- Or for example in case of lists

159-- > instance HasForeignType LangX Text a => HasForeignType LangX Text [a] where

246-- > instance HasForeignType LangX Text a => HasForeignType LangX Text [a] where

160−-- > typeFor lang type _ = "listX of " <> typeFor lang ftype (Proxy :: Proxy a)

247+-- > typeFor lang ftype _ = "listX of " <> typeFor lang ftype (Proxy :: Proxy a)

161--

248--

162-- Finally to generate list of information about all the endpoints for

249-- Finally to generate list of information about all the endpoints for

163-- an API you create a function of a form:

250-- an API you create a function of a form:

@@ -177,11 +264,16 @@ defReq = Req defUrl "GET" [] Nothing Nothing (FunctionName []) ReqBodyJSON

177class HasForeignType lang ftype a where

264class HasForeignType lang ftype a where

178 typeFor :: Proxy lang -> Proxy ftype -> Proxy a -> ftype

265 typeFor :: Proxy lang -> Proxy ftype -> Proxy a -> ftype

179

266

267+-- | The language definition without any foreign types. It can be used for dynamic languages which do not /do/ type annotations.

180data NoTypes

268data NoTypes

181

269

270+-- | Use if the foreign language does not have any types.

182−instance HasForeignType NoTypes NoContent ftype where

271+instance HasForeignType NoTypes NoContent a where

183 typeFor _ _ _ = NoContent

272 typeFor _ _ _ = NoContent

184

273

274+-- | Implementation of the Servant framework types.

275+--

276+-- Relevant instances: Everything containing 'HasForeignType'.

185class HasForeign lang ftype (api :: *) where

277class HasForeign lang ftype (api :: *) where

186 type Foreign ftype api :: *

278 type Foreign ftype api :: *

187 foreignFor :: Proxy lang -> Proxy ftype -> Proxy api -> Req ftype -> Foreign ftype api

279 foreignFor :: Proxy lang -> Proxy ftype -> Proxy api -> Req ftype -> Foreign ftype api

@@ -244,6 +336,19 @@ instance (Elem JSON list, HasForeignType lang ftype a, ReflectMethod method)

244 method = reflectMethod (Proxy :: Proxy method)

336 method = reflectMethod (Proxy :: Proxy method)

245 methodLC = toLower $ decodeUtf8 method

337 methodLC = toLower $ decodeUtf8 method

246

338

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+

247-- | TODO: doesn't taking framing into account.

352-- | TODO: doesn't taking framing into account.

248instance (ct ~ JSON, HasForeignType lang ftype a, ReflectMethod method)

353instance (ct ~ JSON, HasForeignType lang ftype a, ReflectMethod method)

249 => HasForeign lang ftype (Stream method status framing ct a) where

354 => HasForeign lang ftype (Stream method status framing ct a) where

@@ -311,6 +416,16 @@ instance

311 { _argName = PathSegment str

416 { _argName = PathSegment str

312 , _argType = typeFor lang ftype (Proxy :: Proxy Bool) }

417 , _argType = typeFor lang ftype (Proxy :: Proxy Bool) }

313

418

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+

314instance HasForeign lang ftype Raw where

429instance HasForeign lang ftype Raw where

315 type Foreign ftype Raw = HTTP.Method -> Req ftype

430 type Foreign ftype Raw = HTTP.Method -> Req ftype

316

431

servant-foreign/test/Servant/ForeignSpec.hs+7−4

@@ -11,11 +11,9 @@

11

11

12module Servant.ForeignSpec where

12module Servant.ForeignSpec where

13

13

14−import Data.Monoid

15− ((<>))

16import Data.Proxy

14import Data.Proxy

17−import Servant.Test.ComprehensiveAPI

18import Servant.Foreign

15import Servant.Foreign

16+import Servant.Test.ComprehensiveAPI

19import Servant.Types.SourceT

17import Servant.Types.SourceT

20 (SourceT)

18 (SourceT)

21

19

@@ -91,6 +89,7 @@ listFromAPISpec = describe "listFromAPI" $ do

91 { _reqUrl = Url

89 { _reqUrl = Url

92 [ Segment $ Static "test" ]

90 [ Segment $ Static "test" ]

93 [ QueryArg (Arg "flag" "boolX") Flag ]

91 [ QueryArg (Arg "flag" "boolX") Flag ]

92+ Nothing

94 , _reqMethod = "GET"

93 , _reqMethod = "GET"

95 , _reqHeaders = [HeaderArg $ Arg "header" "maybe listX of stringX"]

94 , _reqHeaders = [HeaderArg $ Arg "header" "maybe listX of stringX"]

96 , _reqBody = Nothing

95 , _reqBody = Nothing

@@ -103,6 +102,7 @@ listFromAPISpec = describe "listFromAPI" $ do

103 { _reqUrl = Url

102 { _reqUrl = Url

104 [ Segment $ Static "test" ]

103 [ Segment $ Static "test" ]

105 [ QueryArg (Arg "param" "maybe intX") Normal ]

104 [ QueryArg (Arg "param" "maybe intX") Normal ]

105+ Nothing

106 , _reqMethod = "POST"

106 , _reqMethod = "POST"

107 , _reqHeaders = []

107 , _reqHeaders = []

108 , _reqBody = Just "listX of stringX"

108 , _reqBody = Just "listX of stringX"

@@ -114,8 +114,9 @@ listFromAPISpec = describe "listFromAPI" $ do

114 shouldBe putReq $ defReq

114 shouldBe putReq $ defReq

115 { _reqUrl = Url

115 { _reqUrl = Url

116 [ Segment $ Static "test" ]

116 [ Segment $ Static "test" ]

117− -- Shoud this be |intX| or |listX of intX| ?

117+ -- Should this be |intX| or |listX of intX| ?

118 [ QueryArg (Arg "params" "listX of intX") List ]

118 [ QueryArg (Arg "params" "listX of intX") List ]

119+ Nothing

119 , _reqMethod = "PUT"

120 , _reqMethod = "PUT"

120 , _reqHeaders = []

121 , _reqHeaders = []

121 , _reqBody = Just "stringX"

122 , _reqBody = Just "stringX"

@@ -129,6 +130,7 @@ listFromAPISpec = describe "listFromAPI" $ do

129 [ Segment $ Static "test"

130 [ Segment $ Static "test"

130 , Segment $ Cap (Arg "id" "intX") ]

131 , Segment $ Cap (Arg "id" "intX") ]

131 []

132 []

133+ Nothing

132 , _reqMethod = "DELETE"

134 , _reqMethod = "DELETE"

133 , _reqHeaders = []

135 , _reqHeaders = []

134 , _reqBody = Nothing

136 , _reqBody = Nothing

@@ -142,6 +144,7 @@ listFromAPISpec = describe "listFromAPI" $ do

142 [ Segment $ Static "test"

144 [ Segment $ Static "test"

143 , Segment $ Cap (Arg "ids" "listX of intX") ]

145 , Segment $ Cap (Arg "ids" "listX of intX") ]

144 []

146 []

147+ Nothing

145 , _reqMethod = "GET"

148 , _reqMethod = "GET"

146 , _reqHeaders = []

149 , _reqHeaders = []

147 , _reqBody = Nothing

150 , _reqBody = Nothing

servant-http-streams/CHANGELOG.mdnew file+98

@@ -0,0 +1,98 @@

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/LICENSEnew file+30

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

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.lhsnew file+1

@@ -0,0 +1 @@

1+README.md

servant-http-streams/README.mdnew file+44

@@ -0,0 +1,44 @@

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.hsnew file+2

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

1+import Distribution.Simple

2+main = defaultMain

servant-http-streams/servant-http-streams.cabalnew file+132

@@ -0,0 +1,132 @@

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

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

46+ , text >= 1.2.3.0 && < 2.1

47+ , time >= 1.6.0.1 && < 1.12

48+ , transformers >= 0.5.2.0 && < 0.6

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.hsnew file+19

@@ -0,0 +1,19 @@

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.hsnew file+258

@@ -0,0 +1,258 @@

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-client/test/Servant/ClientSpec.hs → servant-http-streams/test/Servant/ClientSpec.hsrenamed+62−113

@@ -12,6 +12,7 @@

12{-# LANGUAGE RecordWildCards #-}

12{-# LANGUAGE RecordWildCards #-}

13{-# LANGUAGE ScopedTypeVariables #-}

13{-# LANGUAGE ScopedTypeVariables #-}

14{-# LANGUAGE StandaloneDeriving #-}

14{-# LANGUAGE StandaloneDeriving #-}

15+{-# LANGUAGE TypeApplications #-}

15{-# LANGUAGE TypeFamilies #-}

16{-# LANGUAGE TypeFamilies #-}

16{-# LANGUAGE TypeOperators #-}

17{-# LANGUAGE TypeOperators #-}

17{-# LANGUAGE UndecidableInstances #-}

18{-# LANGUAGE UndecidableInstances #-}

@@ -28,35 +29,27 @@ import Control.Arrow

28 (left)

29 (left)

29import Control.Concurrent

30import Control.Concurrent

30 (ThreadId, forkIO, killThread)

31 (ThreadId, forkIO, killThread)

31−import Control.Concurrent.STM

32+import Control.DeepSeq

32− (atomically)

33+ (NFData (..))

33−import Control.Concurrent.STM.TVar

34− (newTVar, readTVar)

35import Control.Exception

34import Control.Exception

36− (bracket)

35+ (bracket, fromException, IOException)

37import Control.Monad.Error.Class

36import Control.Monad.Error.Class

38 (throwError)

37 (throwError)

39import Data.Aeson

38import Data.Aeson

40import Data.Char

39import Data.Char

41 (chr, isPrint)

40 (chr, isPrint)

42import Data.Foldable

41import Data.Foldable

43− (forM_)

42+ (forM_, toList)

44import Data.Maybe

43import Data.Maybe

45− (listToMaybe)

44+ (isJust)

46import Data.Monoid ()

45import Data.Monoid ()

47import Data.Proxy

46import Data.Proxy

48−import Data.Semigroup

49− ((<>))

50−import qualified Generics.SOP as SOP

51import GHC.Generics

47import GHC.Generics

52 (Generic)

48 (Generic)

53−import qualified Network.HTTP.Client as C

54import qualified Network.HTTP.Types as HTTP

49import qualified Network.HTTP.Types as HTTP

55import Network.Socket

50import Network.Socket

56import qualified Network.Wai as Wai

51import qualified Network.Wai as Wai

57import Network.Wai.Handler.Warp

52import Network.Wai.Handler.Warp

58−import System.IO.Unsafe

59− (unsafePerformIO)

60import Test.Hspec

53import Test.Hspec

61import Test.Hspec.QuickCheck

54import Test.Hspec.QuickCheck

62import Test.HUnit

55import Test.HUnit

@@ -70,9 +63,9 @@ import Servant.API

70 DeleteNoContent, EmptyAPI, FormUrlEncoded, Get, Header,

63 DeleteNoContent, EmptyAPI, FormUrlEncoded, Get, Header,

71 Headers, JSON, NoContent (NoContent), Post, Put, QueryFlag,

64 Headers, JSON, NoContent (NoContent), Post, Put, QueryFlag,

72 QueryParam, QueryParams, Raw, ReqBody, addHeader, getHeaders)

65 QueryParam, QueryParams, Raw, ReqBody, addHeader, getHeaders)

73−import Servant.Client

74−import qualified Servant.Client.Core.Internal.Auth as Auth

66+import qualified Servant.Client.Core.Auth as Auth

75−import qualified Servant.Client.Core.Internal.Request as Req

67+import qualified Servant.Client.Core.Request as Req

68+import Servant.HttpStreams

76import Servant.Server

69import Servant.Server

77import Servant.Server.Experimental.Auth

70import Servant.Server.Experimental.Auth

78import Servant.Test.ComprehensiveAPI

71import Servant.Test.ComprehensiveAPI

@@ -81,14 +74,14 @@ import Servant.Test.ComprehensiveAPI

81_ = client comprehensiveAPIWithoutStreaming

74_ = client comprehensiveAPIWithoutStreaming

82

75

83spec :: Spec

76spec :: Spec

84−spec = describe "Servant.Client" $ do

77+spec = describe "Servant.HttpStreams" $ do

85− sucessSpec

78+ successSpec

86 failSpec

79 failSpec

87 wrappedApiSpec

80 wrappedApiSpec

88 basicAuthSpec

81 basicAuthSpec

89 genAuthSpec

82 genAuthSpec

90− genericClientSpec

91 hoistClientSpec

83 hoistClientSpec

84+ connectionErrorSpec

92

85

93-- * test data types

86-- * test data types

94

87

@@ -97,6 +90,9 @@ data Person = Person

97 , _age :: Integer

90 , _age :: Integer

98 } deriving (Eq, Show, Generic)

91 } deriving (Eq, Show, Generic)

99

92

93+instance NFData Person where

94+ rnf (Person n a) = rnf n `seq` rnf a

95+

100instance ToJSON Person

96instance ToJSON Person

101instance FromJSON Person

97instance FromJSON Person

102

98

@@ -117,7 +113,7 @@ type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]

117type Api =

113type Api =

118 Get '[JSON] Person

114 Get '[JSON] Person

119 :<|> "get" :> Get '[JSON] Person

115 :<|> "get" :> Get '[JSON] Person

120− :<|> "deleteEmpty" :> DeleteNoContent '[JSON] NoContent

116+ :<|> "deleteEmpty" :> DeleteNoContent

121 :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person

117 :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person

122 :<|> "captureAll" :> CaptureAll "names" String :> Get '[JSON] [Person]

118 :<|> "captureAll" :> CaptureAll "names" String :> Get '[JSON] [Person]

123 :<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person

119 :<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person

@@ -133,7 +129,7 @@ type Api =

133 ReqBody '[JSON] [(String, [Rational])] :>

129 ReqBody '[JSON] [(String, [Rational])] :>

134 Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])])

130 Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])])

135 :<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool)

131 :<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool)

136− :<|> "deleteContentType" :> DeleteNoContent '[JSON] NoContent

132+ :<|> "deleteContentType" :> DeleteNoContent

137 :<|> "redirectWithCookie" :> Raw

133 :<|> "redirectWithCookie" :> Raw

138 :<|> "empty" :> EmptyAPI

134 :<|> "empty" :> EmptyAPI

139

135

@@ -155,7 +151,7 @@ getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]

155 -> ClientM (String, Maybe Int, Bool, [(String, [Rational])])

151 -> ClientM (String, Maybe Int, Bool, [(String, [Rational])])

156getRespHeaders :: ClientM (Headers TestHeaders Bool)

152getRespHeaders :: ClientM (Headers TestHeaders Bool)

157getDeleteContentType :: ClientM NoContent

153getDeleteContentType :: ClientM NoContent

158−getRedirectWithCookie :: HTTP.Method -> ClientM Response

154+_getRedirectWithCookie :: HTTP.Method -> ClientM Response

159

155

160getRoot

156getRoot

161 :<|> getGet

157 :<|> getGet

@@ -171,7 +167,7 @@ getRoot

171 :<|> getMultiple

167 :<|> getMultiple

172 :<|> getRespHeaders

168 :<|> getRespHeaders

173 :<|> getDeleteContentType

169 :<|> getDeleteContentType

174− :<|> getRedirectWithCookie

170+ :<|> _getRedirectWithCookie

175 :<|> EmptyClient = client api

171 :<|> EmptyClient = client api

176

172

177server :: Application

173server :: Application

@@ -184,8 +180,8 @@ server = serve api (

184 :<|> return

180 :<|> return

185 :<|> (\ name -> case name of

181 :<|> (\ name -> case name of

186 Just "alice" -> return alice

182 Just "alice" -> return alice

187− Just n -> throwError $ ServantErr 400 (n ++ " not found") "" []

183+ Just n -> throwError $ ServerError 400 (n ++ " not found") "" []

188− Nothing -> throwError $ ServantErr 400 "missing parameter" "" [])

184+ Nothing -> throwError $ ServerError 400 "missing parameter" "" [])

189 :<|> (\ names -> return (zipWith Person names [0..]))

185 :<|> (\ names -> return (zipWith Person names [0..]))

190 :<|> return

186 :<|> return

191 :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "rawSuccess")

187 :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "rawSuccess")

@@ -256,62 +252,16 @@ genAuthServerContext = genAuthHandler :. EmptyContext

256genAuthServer :: Application

252genAuthServer :: Application

257genAuthServer = serveWithContext genAuthAPI genAuthServerContext (const (return alice))

253genAuthServer = serveWithContext genAuthAPI genAuthServerContext (const (return alice))

258

254

259−-- * generic client stuff

255+runClient :: NFData a => ClientM a -> BaseUrl -> IO (Either ClientError a)

260−

256+runClient x burl = withClientEnvIO burl (runClientM x)

261−type GenericClientAPI

262− = QueryParam "sqr" Int :> Get '[JSON] Int

263− :<|> Capture "foo" String :> NestedAPI1

264−

265−data GenericClient = GenericClient

266− { getSqr :: Maybe Int -> ClientM Int

267− , mkNestedClient1 :: String -> NestedClient1

268− } deriving Generic

269−instance SOP.Generic GenericClient

270−instance (Client ClientM GenericClientAPI ~ client) => ClientLike client GenericClient

271−

272−type NestedAPI1

273− = QueryParam "int" Int :> NestedAPI2

274− :<|> QueryParam "id" Char :> Get '[JSON] Char

275−

276−data NestedClient1 = NestedClient1

277− { mkNestedClient2 :: Maybe Int -> NestedClient2

278− , idChar :: Maybe Char -> ClientM Char

279− } deriving Generic

280−instance SOP.Generic NestedClient1

281−instance (Client ClientM NestedAPI1 ~ client) => ClientLike client NestedClient1

282−

283−type NestedAPI2

284− = "sum" :> Capture "first" Int :> Capture "second" Int :> Get '[JSON] Int

285− :<|> "void" :> Post '[JSON] ()

286−

287−data NestedClient2 = NestedClient2

288− { getSum :: Int -> Int -> ClientM Int

289− , doNothing :: ClientM ()

290− } deriving Generic

291−instance SOP.Generic NestedClient2

292−instance (Client ClientM NestedAPI2 ~ client) => ClientLike client NestedClient2

293−

294−genericClientServer :: Application

295−genericClientServer = serve (Proxy :: Proxy GenericClientAPI) (

296− (\ mx -> case mx of

297− Just x -> return (x*x)

298− Nothing -> throwError $ ServantErr 400 "missing parameter" "" []

299− )

300− :<|> nestedServer1

301− )

302− where

303− nestedServer1 _str = nestedServer2 :<|> (maybe (throwError $ ServantErr 400 "missing parameter" "" []) return)

304− nestedServer2 _int = (\ x y -> return (x + y)) :<|> return ()

305−

306−{-# NOINLINE manager' #-}

307−manager' :: C.Manager

308−manager' = unsafePerformIO $ C.newManager C.defaultManagerSettings

309

257

310−runClient :: ClientM a -> BaseUrl -> IO (Either ServantError a)

258+runClientUnsafe :: ClientM a -> BaseUrl -> IO (Either ClientError a)

311−runClient x baseUrl' = runClientM x (mkClientEnv manager' baseUrl')

259+runClientUnsafe x burl = withClientEnvIO burl (runClientMUnsafe x)

260+ where

261+ runClientMUnsafe x env = withClientM x env return

312

262

313−sucessSpec :: Spec

263+successSpec :: Spec

314−sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do

264+successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do

315 it "Servant.API.Get root" $ \(_, baseUrl) -> do

265 it "Servant.API.Get root" $ \(_, baseUrl) -> do

316 left show <$> runClient getRoot baseUrl `shouldReturn` Right carol

266 left show <$> runClient getRoot baseUrl `shouldReturn` Right carol

317

267

@@ -336,9 +286,16 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do

336 let p = Person "Clara" 42

286 let p = Person "Clara" 42

337 left show <$> runClient (getBody p) baseUrl `shouldReturn` Right p

287 left show <$> runClient (getBody p) baseUrl `shouldReturn` Right p

338

288

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+

339 it "Servant.API.QueryParam" $ \(_, baseUrl) -> do

296 it "Servant.API.QueryParam" $ \(_, baseUrl) -> do

340 left show <$> runClient (getQueryParam (Just "alice")) baseUrl `shouldReturn` Right alice

297 left show <$> runClient (getQueryParam (Just "alice")) baseUrl `shouldReturn` Right alice

341− Left (FailureResponse r) <- runClient (getQueryParam (Just "bob")) baseUrl

298+ Left (FailureResponse _ r) <- runClient (getQueryParam (Just "bob")) baseUrl

342 responseStatusCode r `shouldBe` HTTP.Status 400 "bob not found"

299 responseStatusCode r `shouldBe` HTTP.Status 400 "bob not found"

343

300

344 it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do

301 it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do

@@ -362,7 +319,7 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do

362 res <- runClient (getRawFailure HTTP.methodGet) baseUrl

319 res <- runClient (getRawFailure HTTP.methodGet) baseUrl

363 case res of

320 case res of

364 Right _ -> assertFailure "expected Left, but got Right"

321 Right _ -> assertFailure "expected Left, but got Right"

365− Left (FailureResponse r) -> do

322+ Left (FailureResponse _ r) -> do

366 responseStatusCode r `shouldBe` HTTP.status400

323 responseStatusCode r `shouldBe` HTTP.status400

367 responseBody r `shouldBe` "rawFailure"

324 responseBody r `shouldBe` "rawFailure"

368 Left e -> assertFailure $ "expected FailureResponse, but got " ++ show e

325 Left e -> assertFailure $ "expected FailureResponse, but got " ++ show e

@@ -373,14 +330,6 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do

373 Left e -> assertFailure $ show e

330 Left e -> assertFailure $ show e

374 Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]

331 Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]

375

332

376− it "Stores Cookie in CookieJar after a redirect" $ \(_, baseUrl) -> do

377− mgr <- C.newManager C.defaultManagerSettings

378− cj <- atomically . newTVar $ C.createCookieJar []

379− _ <- runClientM (getRedirectWithCookie HTTP.methodGet) (ClientEnv mgr baseUrl (Just cj))

380− cookie <- listToMaybe . C.destroyCookieJar <$> atomically (readTVar cj)

381− C.cookie_name <$> cookie `shouldBe` Just "testcookie"

382− C.cookie_value <$> cookie `shouldBe` Just "test"

383−

384 modifyMaxSuccess (const 20) $ do

333 modifyMaxSuccess (const 20) $ do

385 it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \(_, baseUrl) ->

334 it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \(_, baseUrl) ->

386 property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->

335 property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->

@@ -392,14 +341,14 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do

392

341

393wrappedApiSpec :: Spec

342wrappedApiSpec :: Spec

394wrappedApiSpec = describe "error status codes" $ do

343wrappedApiSpec = describe "error status codes" $ do

395− let serveW api = serve api $ throwError $ ServantErr 500 "error message" "" []

344+ let serveW api = serve api $ throwError $ ServerError 500 "error message" "" []

396 context "are correctly handled by the client" $

345 context "are correctly handled by the client" $

397 let test :: (WrappedApi, String) -> Spec

346 let test :: (WrappedApi, String) -> Spec

398 test (WrappedApi api, desc) =

347 test (WrappedApi api, desc) =

399 it desc $ bracket (startWaiApp $ serveW api) endWaiApp $ \(_, baseUrl) -> do

348 it desc $ bracket (startWaiApp $ serveW api) endWaiApp $ \(_, baseUrl) -> do

400 let getResponse :: ClientM ()

349 let getResponse :: ClientM ()

401 getResponse = client api

350 getResponse = client api

402− Left (FailureResponse r) <- runClient getResponse baseUrl

351+ Left (FailureResponse _ r) <- runClient getResponse baseUrl

403 responseStatusCode r `shouldBe` (HTTP.Status 500 "error message")

352 responseStatusCode r `shouldBe` (HTTP.Status 500 "error message")

404 in mapM_ test $

353 in mapM_ test $

405 (WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") :

354 (WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") :

@@ -416,7 +365,7 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do

416 let (_ :<|> _ :<|> getDeleteEmpty :<|> _) = client api

365 let (_ :<|> _ :<|> getDeleteEmpty :<|> _) = client api

417 Left res <- runClient getDeleteEmpty baseUrl

366 Left res <- runClient getDeleteEmpty baseUrl

418 case res of

367 case res of

419− FailureResponse r | responseStatusCode r == HTTP.status404 -> return ()

368+ FailureResponse _ r | responseStatusCode r == HTTP.status404 -> return ()

420 _ -> fail $ "expected 404 response, but got " <> show res

369 _ -> fail $ "expected 404 response, but got " <> show res

421

370

422 it "reports DecodeFailure" $ \(_, baseUrl) -> do

371 it "reports DecodeFailure" $ \(_, baseUrl) -> do

@@ -426,7 +375,8 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do

426 DecodeFailure _ _ -> return ()

375 DecodeFailure _ _ -> return ()

427 _ -> fail $ "expected DecodeFailure, but got " <> show res

376 _ -> fail $ "expected DecodeFailure, but got " <> show res

428

377

378+ -- we don't catch IOException's

429− it "reports ConnectionError" $ \_ -> do

379+ xit "reports ConnectionError" $ \_ -> do

430 let (getGetWrongHost :<|> _) = client api

380 let (getGetWrongHost :<|> _) = client api

431 Left res <- runClient getGetWrongHost (BaseUrl Http "127.0.0.1" 19872 "")

381 Left res <- runClient getGetWrongHost (BaseUrl Http "127.0.0.1" 19872 "")

432 case res of

382 case res of

@@ -466,7 +416,7 @@ basicAuthSpec = beforeAll (startWaiApp basicAuthServer) $ afterAll endWaiApp $ d

466 it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do

416 it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do

467 let getBasic = client basicAuthAPI

417 let getBasic = client basicAuthAPI

468 let basicAuthData = BasicAuthData "not" "password"

418 let basicAuthData = BasicAuthData "not" "password"

469− Left (FailureResponse r) <- runClient (getBasic basicAuthData) baseUrl

419+ Left (FailureResponse _ r) <- runClient (getBasic basicAuthData) baseUrl

470 responseStatusCode r `shouldBe` HTTP.Status 403 "Forbidden"

420 responseStatusCode r `shouldBe` HTTP.Status 403 "Forbidden"

471

421

472genAuthSpec :: Spec

422genAuthSpec :: Spec

@@ -483,25 +433,9 @@ genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do

483 it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do

433 it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do

484 let getProtected = client genAuthAPI

434 let getProtected = client genAuthAPI

485 let authRequest = Auth.mkAuthenticatedRequest () (\_ req -> Req.addHeader "Wrong" ("header" :: String) req)

435 let authRequest = Auth.mkAuthenticatedRequest () (\_ req -> Req.addHeader "Wrong" ("header" :: String) req)

486− Left (FailureResponse r) <- runClient (getProtected authRequest) baseUrl

436+ Left (FailureResponse _ r) <- runClient (getProtected authRequest) baseUrl

487 responseStatusCode r `shouldBe` (HTTP.Status 401 "Unauthorized")

437 responseStatusCode r `shouldBe` (HTTP.Status 401 "Unauthorized")

488

438

489−genericClientSpec :: Spec

490−genericClientSpec = beforeAll (startWaiApp genericClientServer) $ afterAll endWaiApp $ do

491− describe "Servant.Client.Generic" $ do

492−

493− let GenericClient{..} = mkClient (client (Proxy :: Proxy GenericClientAPI))

494− NestedClient1{..} = mkNestedClient1 "example"

495− NestedClient2{..} = mkNestedClient2 (Just 42)

496−

497− it "works for top-level client inClientM function" $ \(_, baseUrl) -> do

498− left show <$> runClient (getSqr (Just 5)) baseUrl `shouldReturn` Right 25

499−

500− it "works for nested clients" $ \(_, baseUrl) -> do

501− left show <$> runClient (idChar (Just 'c')) baseUrl `shouldReturn` Right 'c'

502− left show <$> runClient (getSum 3 4) baseUrl `shouldReturn` Right 7

503− left show <$> runClient doNothing baseUrl `shouldReturn` Right ()

504−

505-- * hoistClient

439-- * hoistClient

506

440

507type HoistClientAPI = Get '[JSON] Int :<|> Capture "n" Int :> Post '[JSON] Int

441type HoistClientAPI = Get '[JSON] Int :<|> Capture "n" Int :> Post '[JSON] Int

@@ -518,12 +452,27 @@ hoistClientSpec = beforeAll (startWaiApp hoistClientServer) $ afterAll endWaiApp

518 it "allows us to GET/POST/... requests in IO instead of ClientM" $ \(_, baseUrl) -> do

452 it "allows us to GET/POST/... requests in IO instead of ClientM" $ \(_, baseUrl) -> do

519 let (getInt :<|> postInt)

453 let (getInt :<|> postInt)

520 = hoistClient hoistClientAPI

454 = hoistClient hoistClientAPI

521− (fmap (either (error . show) id) . flip runClient baseUrl)

455+ (fmap (either (error . show) id) . flip runClientUnsafe baseUrl)

522 (client hoistClientAPI)

456 (client hoistClientAPI)

523

457

524 getInt `shouldReturn` 5

458 getInt `shouldReturn` 5

525 postInt 5 `shouldReturn` 5

459 postInt 5 `shouldReturn` 5

526

460

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+

527-- * utils

476-- * utils

528

477

529startWaiApp :: Application -> IO (ThreadId, BaseUrl)

478startWaiApp :: Application -> IO (ThreadId, BaseUrl)

@@ -531,7 +480,7 @@ startWaiApp app = do

531 (port, socket) <- openTestSocket

480 (port, socket) <- openTestSocket

532 let settings = setPort port $ defaultSettings

481 let settings = setPort port $ defaultSettings

533 thread <- forkIO $ runSettingsSocket settings socket app

482 thread <- forkIO $ runSettingsSocket settings socket app

534− return (thread, BaseUrl Http "localhost" port "")

483+ return (thread, BaseUrl Http "127.0.0.1" port "")

535

484

536

485

537endWaiApp :: (ThreadId, BaseUrl) -> IO ()

486endWaiApp :: (ThreadId, BaseUrl) -> IO ()

servant-http-streams/test/Servant/StreamSpec.hsnew file+110

@@ -0,0 +1,110 @@

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.hsnew file+1

@@ -0,0 +1 @@

1+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

servant-machines/servant-machines.cabal+13−17

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

1−cabal-version: >=1.10

1+cabal-version: 2.2

2name: servant-machines

2name: servant-machines

3−version: 0.15

3+version: 0.15.1

4

4

5synopsis: Servant Stream support for machines

5synopsis: Servant Stream support for machines

6category: Servant, Web, Enumerator

6category: Servant, Web, Enumerator

@@ -8,35 +8,31 @@ description: Servant Stream support for machines.

8 .

8 .

9 Provides 'ToSourceIO' and 'FromSourceIO' instances for 'MachineT'.

9 Provides 'ToSourceIO' and 'FromSourceIO' instances for 'MachineT'.

10

10

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

11+homepage: http://docs.servant.dev/

12bug-reports: http://github.com/haskell-servant/servant/issues

12bug-reports: http://github.com/haskell-servant/servant/issues

13−license: BSD3

13+license: BSD-3-Clause

14license-file: LICENSE

14license-file: LICENSE

15author: Servant Contributors

15author: Servant Contributors

16maintainer: haskell-servant-maintainers@googlegroups.com

16maintainer: haskell-servant-maintainers@googlegroups.com

17−copyright: 2018 Servant Contributors

17+copyright: 2018-2019 Servant Contributors

18build-type: Simple

18build-type: Simple

19−tested-with:

19+tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2

20− GHC ==8.0.2

21− || ==8.2.2

22− || ==8.4.4

23− || ==8.6.2

24

20

25extra-source-files:

21extra-source-files:

26 CHANGELOG.md

22 CHANGELOG.md

27

23

28source-repository head

24source-repository head

29 type: git

25 type: git

30− location: http://github.com/haskell-servant/servant-machines.git

26+ location: http://github.com/haskell-servant/servant.git

31

27

32library

28library

33 exposed-modules: Servant.Machines

29 exposed-modules: Servant.Machines

34 build-depends:

30 build-depends:

35 base >=4.9 && <5

31 base >=4.9 && <5

36− , bytestring >=0.10.8.1 && <0.11

32+ , bytestring >=0.10.8.1 && <0.12

37− , machines >=0.6.4 && <0.7

33+ , machines >=0.6.4 && <0.8

38 , mtl >=2.2.2 && <2.3

34 , mtl >=2.2.2 && <2.3

39− , servant >=0.15 && <0.16

35+ , servant >=0.15 && <0.20

40 hs-source-dirs: src

36 hs-source-dirs: src

41 default-language: Haskell2010

37 default-language: Haskell2010

42 ghc-options: -Wall

38 ghc-options: -Wall

@@ -55,9 +51,9 @@ test-suite example

55 , servant

51 , servant

56 , machines

52 , machines

57 , servant-machines

53 , servant-machines

58− , servant-server >=0.15 && <0.16

54+ , servant-server >=0.15 && <0.20

59− , servant-client >=0.15 && <0.16

55+ , servant-client >=0.15 && <0.20

60 , wai >=3.2.1.2 && <3.3

56 , wai >=3.2.1.2 && <3.3

61− , warp >=3.2.25 && <3.3

57+ , warp >=3.2.25 && <3.4

62 , http-client

58 , http-client

63 default-language: Haskell2010

59 default-language: Haskell2010

servant-pipes/CHANGELOG.md+18

@@ -1,3 +1,21 @@

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+

10.15

190.15

2----

20----

3

21

servant-pipes/example/Main.hs+1−1

@@ -64,7 +64,7 @@ server = fast :<|> slow :<|> readme :<|> proxy

64

64

65 readme = liftIO $ do

65 readme = liftIO $ do

66 putStrLn "/readme"

66 putStrLn "/readme"

67− return $ P.withFile "README.md" ReadMode PBS.fromHandle

67+ return $ P.withFile "README.md" ReadMode $ \h -> PBS.fromHandle h

68

68

69 proxy c = liftIO $ do

69 proxy c = liftIO $ do

70 putStrLn "/proxy"

70 putStrLn "/proxy"

servant-pipes/servant-pipes.cabal+13−17

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

1+cabal-version: 2.2

1name: servant-pipes

2name: servant-pipes

2−version: 0.15

3+version: 0.15.3

3−cabal-version: >=1.10

4

4

5synopsis: Servant Stream support for pipes

5synopsis: Servant Stream support for pipes

6category: Servant, Web, Pipes

6category: Servant, Web, Pipes

@@ -8,37 +8,33 @@ description: Servant Stream support for pipes.

8 .

8 .

9 Provides 'ToSourceIO' and 'FromSourceIO' instances for 'Proxy' and 'SafeT'.

9 Provides 'ToSourceIO' and 'FromSourceIO' instances for 'Proxy' and 'SafeT'.

10

10

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

11+homepage: http://docs.servant.dev/

12bug-reports: http://github.com/haskell-servant/servant/issues

12bug-reports: http://github.com/haskell-servant/servant/issues

13−license: BSD3

13+license: BSD-3-Clause

14license-file: LICENSE

14license-file: LICENSE

15author: Servant Contributors

15author: Servant Contributors

16maintainer: haskell-servant-maintainers@googlegroups.com

16maintainer: haskell-servant-maintainers@googlegroups.com

17−copyright: 2018 Servant Contributors

17+copyright: 2018-2019 Servant Contributors

18build-type: Simple

18build-type: Simple

19−tested-with:

19+tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2

20− GHC ==8.0.2

21− || ==8.2.2

22− || ==8.4.4

23− || ==8.6.2

24

20

25extra-source-files:

21extra-source-files:

26 CHANGELOG.md

22 CHANGELOG.md

27

23

28source-repository head

24source-repository head

29 type: git

25 type: git

30− location: http://github.com/haskell-servant/servant-pipes.git

26+ location: http://github.com/haskell-servant/servant.git

31

27

32library

28library

33 exposed-modules: Servant.Pipes

29 exposed-modules: Servant.Pipes

34 build-depends:

30 build-depends:

35 base >=4.9 && <5

31 base >=4.9 && <5

36− , bytestring >=0.10.8.1 && <0.11

32+ , bytestring >=0.10.8.1 && <0.12

37 , pipes >=4.3.9 && <4.4

33 , pipes >=4.3.9 && <4.4

38 , pipes-safe >=2.3.1 && <2.4

34 , pipes-safe >=2.3.1 && <2.4

39 , mtl >=2.2.2 && <2.3

35 , mtl >=2.2.2 && <2.3

40 , monad-control >=1.0.2.3 && <1.1

36 , monad-control >=1.0.2.3 && <1.1

41− , servant >=0.15 && <0.16

37+ , servant >=0.15 && <0.20

42 hs-source-dirs: src

38 hs-source-dirs: src

43 default-language: Haskell2010

39 default-language: Haskell2010

44 ghc-options: -Wall

40 ghc-options: -Wall

@@ -55,13 +51,13 @@ test-suite example

55 , bytestring

51 , bytestring

56 , http-media

52 , http-media

57 , servant

53 , servant

58− , pipes

54+ , pipes

59 , pipes-safe

55 , pipes-safe

60 , servant-pipes

56 , servant-pipes

61 , pipes-bytestring >=2.1.6 && <2.2

57 , pipes-bytestring >=2.1.6 && <2.2

62− , servant-server >=0.15 && <0.16

58+ , servant-server >=0.15 && <0.20

63− , servant-client >=0.15 && <0.16

59+ , servant-client >=0.15 && <0.20

64 , wai >=3.2.1.2 && <3.3

60 , wai >=3.2.1.2 && <3.3

65− , warp >=3.2.25 && <3.3

61+ , warp >=3.2.25 && <3.4

66 , http-client

62 , http-client

67 default-language: Haskell2010

63 default-language: Haskell2010

servant-pipes/src/Servant/Pipes.hs+1−1

@@ -65,7 +65,7 @@ instance (MonadIO m, a' ~ X, a ~ (), b' ~ (), r ~ ())

65 fromSourceIO src = M $ liftIO $ S.unSourceT src (return . go) where

65 fromSourceIO src = M $ liftIO $ S.unSourceT src (return . go) where

66 go :: S.StepT IO b -> Proxy X () () b m ()

66 go :: S.StepT IO b -> Proxy X () () b m ()

67 go S.Stop = Pure ()

67 go S.Stop = Pure ()

68− go (S.Error err) = M (fail err)

68+ go (S.Error err) = M (liftIO (fail err))

69 go (S.Skip s) = go s -- drives

69 go (S.Skip s) = go s -- drives

70 go (S.Effect ms) = M (liftIO (fmap go ms))

70 go (S.Effect ms) = M (liftIO (fmap go ms))

71 go (S.Yield x s) = Respond x (const (go s))

71 go (S.Yield x s) = Respond x (const (go s))

servant-server/CHANGELOG.md+137

@@ -1,6 +1,143 @@

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

7+------

8+

9+- Add `MonadFail` instance for `Handler` wrt [#1545](https://github.com/haskell-servant/servant/issues/1545)

10+- Support GHC 9.2 [#1525](https://github.com/haskell-servant/servant/issues/1525)

11+

12+0.19

13+----

14+

15+### Significant changes

16+

17+- Drop support for GHC < 8.6.

18+- Support GHC 9.0 (GHC 9.2 should work as well, but isn't fully tested yet).

19+- Support Aeson 2 ([#1475](https://github.com/haskell-servant/servant/pull/1475)),

20+ which fixes a [DOS vulnerability](https://github.com/haskell/aeson/issues/864)

21+ related to hash collisions.

22+- Add `NamedRoutes` combinator, making support for records first-class in Servant

23+ ([#1388](https://github.com/haskell-servant/servant/pull/1388)).

24+- Add custom type errors for partially applied combinators

25+ ([#1289](https://github.com/haskell-servant/servant/pull/1289),

26+ [#1486](https://github.com/haskell-servant/servant/pull/1486)).

27+

28+0.18.3

29+------

30+

31+### Significant changes

32+

33+- Add response header support to UVerb (#1420)

34+

35+### Other changes

36+

37+- Support GHC-9.0.1.

38+- Bump `bytestring`, `hspec` and `base64-bytestring` dependencies.

39+

40+0.18.2

41+------

42+

43+### Significant changes

44+

45+- Support `Fragment` combinator.

46+

47+0.18.1

48+------

49+

50+### Significant changes

51+

52+- Union verbs

53+

54+### Other changes

55+

56+- Bump "tested-with" ghc versions

57+- Allow newer dependencies

58+

59+0.18

60+----

61+

62+### Significant changes

63+

64+- Support for ghc8.8 (#1318, #1326, #1327)

65+

66+- Configurable error messages for automatic errors thrown by servant,

67+ like "no route" or "could not parse json body" (#1312, #1326, #1327)

68+

69+

70+0.17

71+----

72+

73+### Significant changes

74+

75+- 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)

76+

77+ The `NoContent` API endpoints should now use `NoContentVerb` combinator.

78+ The API type changes are usually of the kind

79+

80+ ```diff

81+ - :<|> PostNoContent '[JSON] NoContent

82+ + :<|> PostNoContent

83+ ```

84+

85+ i.e. one doesn't need to specify the content-type anymore. There is no content.

86+

87+- `Capture` can be `Lenient` [#1155](https://github.com/haskell-servant/servant/issues/1155) [#1156](https://github.com/haskell-servant/servant/pull/1156)

88+

89+ You can specify a lenient capture as

90+

91+ ```haskell

92+ :<|> "capture-lenient" :> Capture' '[Lenient] "foo" Int :> GET

93+ ```

94+

95+ which will make the capture always succeed. Handlers will be of the

96+ type `Either String CapturedType`, where `Left err` represents

97+ the possible parse failure.

98+

99+- *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)

100+

101+ Some APIs need query parameters rewriting, e.g. in order to support

102+ for multiple casing (camel, snake, etc) or something to that effect.

103+

104+ This could be easily achieved by using WAI Middleware and modifying

105+ request's `Query`. But QueryParam, QueryParams and QueryFlag use

106+ `rawQueryString`. By using `queryString` rather then `rawQueryString`

107+ we can enable such rewritings.

108+

109+- *servant* *servant-server* Make packages `build-type: Simple` [#1263](https://github.com/haskell-servant/servant/pull/1263)

110+

111+ We used `build-type: Custom`, but it's problematic e.g.

112+ for cross-compiling. The benefit is small, as the doctests

113+ can be run other ways too (though not so conveniently).

114+

115+0.16.2

116+------

117+

118+* `singleton-bool-0.1.5` (`SBool` is re-exported)

119+ - Add `discreteBool :: Dec (a :~: b)` (GHC-7.8+)

120+ - Add `Show`, `Eq`, `Ord` `SBool b` instances.

121+* dependencies update

122+

123+0.16.1

124+------

125+

126+* Use `http-api-data-0.4.1` (a part of its API is re-exported)

127+ [#1181](https://github.com/haskell-servant/servant/pull/1181)

128+

129+0.16

130+----

131+

132+- Rename `ServantError` to `ClientError`, `ServantErr` to `ServerError`

133+ [#1131](https://github.com/haskell-servant/servant/pull/1131)

134+- *servant-server* Reorder HTTP failure code priorities

135+ [#1103](https://github.com/haskell-servant/servant/pull/1103)

136+- *servant-server* Re-organise internal modules

137+ [#1139](https://github.com/haskell-servant/servant/pull/1139)

138+- Allow `network-3.0`

139+ [#1107](https://github.com/haskell-servant/servant/pull/1107)

140+

40.15

1410.15

5----

142----

6

143

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://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.

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.

servant-server/Setup.hs+1−32

@@ -1,33 +1,2 @@

1−{-# LANGUAGE CPP #-}

2−{-# OPTIONS_GHC -Wall #-}

3−module Main (main) where

4−

5−#ifndef MIN_VERSION_cabal_doctest

6−#define MIN_VERSION_cabal_doctest(x,y,z) 0

7−#endif

8−

9−#if MIN_VERSION_cabal_doctest(1,0,0)

10−

11−import Distribution.Extra.Doctest ( defaultMainWithDoctests )

12−main :: IO ()

13−main = defaultMainWithDoctests "doctests"

14−

15−#else

16−

17−#ifdef MIN_VERSION_Cabal

18−-- If the macro is defined, we have new cabal-install,

19−-- but for some reason we don't have cabal-doctest in package-db

20−--

21−-- Probably we are running cabal sdist, when otherwise using new-build

22−-- workflow

23−#warning You are configuring this package without cabal-doctest installed. \

24− The doctests test-suite will not work as a result. \

25− To fix this, install cabal-doctest before configuring.

26−#endif

27−

28−import Distribution.Simple

1+import Distribution.Simple

29−

30−main :: IO ()

31main = defaultMain

2main = 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 aforementionned generated documentation.

2+- `greet.md` contains the aforementioned generated documentation.

servant-server/example/greet.hs+16−2

@@ -1,5 +1,6 @@

1{-# LANGUAGE DataKinds #-}

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DeriveGeneric #-}

2{-# LANGUAGE DeriveGeneric #-}

3+{-# LANGUAGE RecordWildCards #-}

3{-# LANGUAGE OverloadedStrings #-}

4{-# LANGUAGE OverloadedStrings #-}

4{-# LANGUAGE PolyKinds #-}

5{-# LANGUAGE PolyKinds #-}

5{-# LANGUAGE TypeFamilies #-}

6{-# LANGUAGE TypeFamilies #-}

@@ -16,6 +17,7 @@ import Network.Wai

16import Network.Wai.Handler.Warp

17import Network.Wai.Handler.Warp

17

18

18import Servant

19import Servant

20+import Servant.Server.Generic ()

19

21

20-- * Example

22-- * Example

21

23

@@ -38,6 +40,14 @@ type TestApi =

38 -- DELETE /greet/:greetid

40 -- DELETE /greet/:greetid

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

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

40

42

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+

41testApi :: Proxy TestApi

51testApi :: Proxy TestApi

42testApi = Proxy

52testApi = Proxy

43

53

@@ -48,9 +58,13 @@ testApi = Proxy

48--

58--

49-- Each handler runs in the 'Handler' monad.

59-- Each handler runs in the 'Handler' monad.

50server :: Server TestApi

60server :: Server TestApi

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

61+server = helloH :<|> postGreetH :<|> deleteGreetH :<|> otherRoutes

62+ where otherRoutes = OtherRoutes {..}

63+

64+ bye name = pure $ "Bye, " <> name <> " !"

65+ version = pure 42

52

66

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

67+ helloH name Nothing = helloH name (Just False)

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

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

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

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

56

70

servant-server/servant-server.cabal+36−50

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

1−cabal-version: >=1.10

1+cabal-version: 2.2

2name: servant-server

2name: servant-server

3−version: 0.15

3+version: 0.19.1

4

4

5synopsis: A family of combinators for defining webservices APIs and serving them

5synopsis: A family of combinators for defining webservices APIs and serving them

6category: Servant, Web

6category: Servant, Web

7description:

7description:

8 A family of combinators for defining webservices APIs and serving them

8 A family of combinators for defining webservices APIs and serving them

9 .

9 .

10− You can learn about the basics in the <http://haskell-servant.readthedocs.org/en/stable/tutorial/index.html tutorial>.

10+ You can learn about the basics in the <http://docs.servant.dev/en/stable/tutorial/index.html tutorial>.

11 .

11 .

12 <https://github.com/haskell-servant/servant/blob/master/servant-server/example/greet.hs Here>

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

13 is a runnable example, with comments, that defines a dummy API and implements

@@ -15,19 +15,15 @@ description:

15 .

15 .

16 <https://github.com/haskell-servant/servant/blob/master/servant-server/CHANGELOG.md CHANGELOG>

16 <https://github.com/haskell-servant/servant/blob/master/servant-server/CHANGELOG.md CHANGELOG>

17

17

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

18+homepage: http://docs.servant.dev/

19bug-reports: http://github.com/haskell-servant/servant/issues

19bug-reports: http://github.com/haskell-servant/servant/issues

20−license: BSD3

20+license: BSD-3-Clause

21license-file: LICENSE

21license-file: LICENSE

22author: Servant Contributors

22author: Servant Contributors

23maintainer: haskell-servant-maintainers@googlegroups.com

23maintainer: haskell-servant-maintainers@googlegroups.com

24−copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2018 Servant Contributors

24+copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors

25−build-type: Custom

25+build-type: Simple

26−tested-with:

26+tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1

27− GHC ==8.0.2

28− || ==8.2.2

29− || ==8.4.4

30− || ==8.6.2

31

27

32extra-source-files:

28extra-source-files:

33 CHANGELOG.md

29 CHANGELOG.md

@@ -37,12 +33,6 @@ source-repository head

37 type: git

33 type: git

38 location: http://github.com/haskell-servant/servant.git

34 location: http://github.com/haskell-servant/servant.git

39

35

40−custom-setup

41− setup-depends:

42− base >= 4 && <5,

43− Cabal,

44− cabal-doctest >= 1.0.6 && <1.1

45−

46library

36library

47 exposed-modules:

37 exposed-modules:

48 Servant

38 Servant

@@ -52,11 +42,16 @@ library

52 Servant.Server.Internal

42 Servant.Server.Internal

53 Servant.Server.Internal.BasicAuth

43 Servant.Server.Internal.BasicAuth

54 Servant.Server.Internal.Context

44 Servant.Server.Internal.Context

45+ Servant.Server.Internal.Delayed

46+ Servant.Server.Internal.DelayedIO

47+ Servant.Server.Internal.ErrorFormatter

55 Servant.Server.Internal.Handler

48 Servant.Server.Internal.Handler

49+ Servant.Server.Internal.RouteResult

56 Servant.Server.Internal.Router

50 Servant.Server.Internal.Router

57 Servant.Server.Internal.RoutingApplication

51 Servant.Server.Internal.RoutingApplication

58− Servant.Server.Internal.ServantErr

52+ Servant.Server.Internal.ServerError

59 Servant.Server.StaticFiles

53 Servant.Server.StaticFiles

54+ Servant.Server.UVerb

60

55

61 -- deprecated

56 -- deprecated

62 exposed-modules:

57 exposed-modules:

@@ -65,31 +60,33 @@ library

65 -- Bundled with GHC: Lower bound to not force re-installs

60 -- Bundled with GHC: Lower bound to not force re-installs

66 -- text and mtl are bundled starting with GHC-8.4

61 -- text and mtl are bundled starting with GHC-8.4

67 build-depends:

62 build-depends:

68− base >= 4.9 && < 4.13

63+ base >= 4.9 && < 4.17

69− , bytestring >= 0.10.8.1 && < 0.11

64+ , bytestring >= 0.10.8.1 && < 0.12

65+ , constraints >= 0.2 && < 0.14

70 , containers >= 0.5.7.1 && < 0.7

66 , containers >= 0.5.7.1 && < 0.7

71 , mtl >= 2.2.2 && < 2.3

67 , mtl >= 2.2.2 && < 2.3

72− , text >= 1.2.3.0 && < 1.3

68+ , text >= 1.2.3.0 && < 2.1

73 , transformers >= 0.5.2.0 && < 0.6

69 , transformers >= 0.5.2.0 && < 0.6

74 , filepath >= 1.4.1.1 && < 1.5

70 , filepath >= 1.4.1.1 && < 1.5

75

71

76 -- Servant dependencies

72 -- Servant dependencies

77 -- strict dependency as we re-export 'servant' things.

73 -- strict dependency as we re-export 'servant' things.

78 build-depends:

74 build-depends:

79− servant >= 0.15 && < 0.15.1

75+ servant >= 0.19 && < 0.20

80− , http-api-data >= 0.4 && < 0.4.1

76+ , http-api-data >= 0.4.1 && < 0.4.4

81

77

82 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.

78 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.

83 -- Here can be exceptions if we really need features from the newer versions.

79 -- Here can be exceptions if we really need features from the newer versions.

84 build-depends:

80 build-depends:

85− base-compat >= 0.10.5 && < 0.11

81+ base-compat >= 0.10.5 && < 0.13

86− , base64-bytestring >= 1.0.0.1 && < 1.1

82+ , base64-bytestring >= 1.0.0.1 && < 1.3

87 , exceptions >= 0.10.0 && < 0.11

83 , exceptions >= 0.10.0 && < 0.11

88− , http-media >= 0.7.1.3 && < 0.8

84+ , http-media >= 0.7.1.3 && < 0.9

89 , http-types >= 0.12.2 && < 0.13

85 , http-types >= 0.12.2 && < 0.13

90 , network-uri >= 2.6.1.0 && < 2.8

86 , network-uri >= 2.6.1.0 && < 2.8

91 , monad-control >= 1.0.2.3 && < 1.1

87 , monad-control >= 1.0.2.3 && < 1.1

92− , network >= 2.8 && < 3.1

88+ , network >= 2.8 && < 3.2

89+ , sop-core >= 0.4.0.0 && < 0.6

93 , string-conversions >= 0.4.0.1 && < 0.5

90 , string-conversions >= 0.4.0.1 && < 0.5

94 , resourcet >= 1.2.2 && < 1.3

91 , resourcet >= 1.2.2 && < 1.3

95 , tagged >= 0.8.6 && < 0.9

92 , tagged >= 0.8.6 && < 0.9

@@ -100,6 +97,7 @@ library

100

97

101 hs-source-dirs: src

98 hs-source-dirs: src

102 default-language: Haskell2010

99 default-language: Haskell2010

100+

103 ghc-options: -Wall -Wno-redundant-constraints

101 ghc-options: -Wall -Wno-redundant-constraints

104

102

105executable greet

103executable greet

@@ -116,8 +114,8 @@ executable greet

116 , text

114 , text

117

115

118 build-depends:

116 build-depends:

119− aeson >= 1.4.1.0 && < 1.5

117+ aeson >= 1.4.1.0 && < 3

120− , warp >= 3.2.25 && < 3.3

118+ , warp >= 3.2.25 && < 3.4

121

119

122test-suite spec

120test-suite spec

123 type: exitcode-stdio-1.0

121 type: exitcode-stdio-1.0

@@ -150,35 +148,23 @@ test-suite spec

150 , safe

148 , safe

151 , servant

149 , servant

152 , servant-server

150 , servant-server

151+ , sop-core

153 , string-conversions

152 , string-conversions

154 , text

153 , text

155 , transformers

154 , transformers

156 , transformers-compat

155 , transformers-compat

157 , wai

156 , wai

158

157

159− -- Additonal dependencies

158+ -- Additional dependencies

160 build-depends:

159 build-depends:

161− aeson >= 1.4.1.0 && < 1.5

160+ aeson >= 1.4.1.0 && < 3

162 , directory >= 1.3.0.0 && < 1.4

161 , directory >= 1.3.0.0 && < 1.4

163− , hspec >= 2.6.0 && < 2.8

162+ , hspec >= 2.6.0 && < 2.10

164− , hspec-wai >= 0.9.0 && < 0.10

163+ , hspec-wai >= 0.10.1 && < 0.12

165− , QuickCheck >= 2.12.6.1 && < 2.13

164+ , QuickCheck >= 2.12.6.1 && < 2.15

166 , should-not-typecheck >= 2.1.0 && < 2.2

165 , should-not-typecheck >= 2.1.0 && < 2.2

167 , temporary >= 1.3 && < 1.4

166 , temporary >= 1.3 && < 1.4

168− , wai-extra >= 3.0.24.3 && < 3.1

167+ , wai-extra >= 3.0.24.3 && < 3.2

169

168

170 build-tool-depends:

169 build-tool-depends:

171− hspec-discover:hspec-discover >= 2.6.0 && <2.8

170+ hspec-discover:hspec-discover >= 2.6.0 && <2.10

172−

173−test-suite doctests

174− build-depends:

175− base

176− , servant-server

177− , doctest >= 0.16.0 && <0.17

178− type: exitcode-stdio-1.0

179− main-is: test/doctests.hs

180− buildable: True

181− default-language: Haskell2010

182− ghc-options: -Wall -threaded

183− if impl(ghc >= 8.2)

184− x-doctest-options: -fdiagnostics-color=never

servant-server/src/Servant/Server.hs+65−12

@@ -1,8 +1,10 @@

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 TypeFamilies #-}

5+{-# LANGUAGE ScopedTypeVariables #-}

6+{-# LANGUAGE TypeFamilies #-}

7+{-# LANGUAGE TypeOperators #-}

6

8

7-- | This module lets you implement 'Server's for defined APIs. You'll

9-- | This module lets you implement 'Server's for defined APIs. You'll

8-- most likely just need 'serve'.

10-- most likely just need 'serve'.

@@ -10,6 +12,8 @@ module Servant.Server

10 ( -- * Run a wai application from an API

12 ( -- * Run a wai application from an API

11 serve

13 serve

12 , serveWithContext

14 , serveWithContext

15+ , serveWithContextT

16+ , ServerContext

13

17

14 , -- * Construct a wai Application from an API

18 , -- * Construct a wai Application from an API

15 toApplication

19 toApplication

@@ -35,6 +39,8 @@ module Servant.Server

35 -- * Context

39 -- * Context

36 , Context(..)

40 , Context(..)

37 , HasContextEntry(getContextEntry)

41 , HasContextEntry(getContextEntry)

42+ , type (.++)

43+ , (.++)

38 -- ** NamedContext

44 -- ** NamedContext

39 , NamedContext(..)

45 , NamedContext(..)

40 , descendIntoNamedContext

46 , descendIntoNamedContext

@@ -49,7 +55,7 @@ module Servant.Server

49 -- , mkAuthHandler

55 -- , mkAuthHandler

50

56

51 -- * Default error type

57 -- * Default error type

52− , ServantErr(..)

58+ , ServerError(..)

53 -- ** 3XX

59 -- ** 3XX

54 , err300

60 , err300

55 , err301

61 , err301

@@ -86,9 +92,28 @@ module Servant.Server

86 , err504

92 , err504

87 , err505

93 , err505

88

94

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+

89 -- * Re-exports

113 -- * Re-exports

90 , Application

114 , Application

91 , Tagged (..)

115 , Tagged (..)

116+ , module Servant.Server.UVerb

92

117

93 ) where

118 ) where

94

119

@@ -101,16 +126,26 @@ import Data.Text

101import Network.Wai

126import Network.Wai

102 (Application)

127 (Application)

103import Servant.Server.Internal

128import Servant.Server.Internal

129+import Servant.Server.UVerb

104

130

105

131

106-- * Implementing Servers

132-- * Implementing Servers

107

133

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+

108-- | 'serve' allows you to implement an API and produce a wai 'Application'.

143-- | 'serve' allows you to implement an API and produce a wai 'Application'.

109--

144--

110-- Example:

145-- Example:

111--

146--

112-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books

147-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books

113−-- > :<|> "books" :> ReqBody Book :> Post '[JSON] Book -- POST /books

148+-- > :<|> "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book -- POST /books

114-- >

149-- >

115-- > server :: Server MyApi

150-- > server :: Server MyApi

116-- > server = listAllBooks :<|> postBook

151-- > server = listAllBooks :<|> postBook

@@ -129,10 +164,27 @@ import Servant.Server.Internal

129serve :: (HasServer api '[]) => Proxy api -> Server api -> Application

164serve :: (HasServer api '[]) => Proxy api -> Server api -> Application

130serve p = serveWithContext p EmptyContext

165serve p = serveWithContext p EmptyContext

131

166

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.

132−serveWithContext :: (HasServer api context)

171+serveWithContext :: ( HasServer api context

172+ , ServerContext context

173+ )

133 => Proxy api -> Context context -> Server api -> Application

174 => Proxy api -> Context context -> Server api -> Application

134−serveWithContext p context server =

175+serveWithContext p context = serveWithContextT p context id

176+

177+-- | A general 'serve' function that allows you to pass a custom context and hoisting function to

178+-- apply on all routes.

179+serveWithContextT ::

180+ forall api context m.

181+ (HasServer api context, ServerContext context) =>

182+ Proxy api -> Context context -> (forall x. m x -> Handler x) -> ServerT api m -> Application

183+serveWithContextT p context toHandler server =

135− toApplication (runRouter (route p context (emptyDelayed (Route server))))

184+ toApplication (runRouter format404 (route p context (emptyDelayed router)))

185+ where

186+ router = Route $ hoistServerWithContext p (Proxy :: Proxy context) toHandler server

187+ format404 = notFoundErrorFormatter . getContextEntry . mkContextWithErrorFormatter $ context

136

188

137-- | Hoist server implementation.

189-- | Hoist server implementation.

138--

190--

@@ -183,7 +235,7 @@ hoistServer p = hoistServerWithContext p (Proxy :: Proxy '[])

183-- > │ └─ e/

235-- > │ └─ e/

184-- > │ └─•

236-- > │ └─•

185-- > ├─ b/

237-- > ├─ b/

186−-- > │ └─ <capture>/

238+-- > │ └─ <x::Int>/

187-- > │ ├─•

239-- > │ ├─•

188-- > │ ┆

240-- > │ ┆

189-- > │ └─•

241-- > │ └─•

@@ -200,7 +252,8 @@ hoistServer p = hoistServerWithContext p (Proxy :: Proxy '[])

200--

252--

201-- [@─•@] Leaves reflect endpoints.

253-- [@─•@] Leaves reflect endpoints.

202--

254--

203−-- [@\<capture\>/@] This is a delayed capture of a path component.

255+-- [@\<x::Int\>/@] This is a delayed capture of a single

256+-- path component named @x@, of expected type @Int@.

204--

257--

205-- [@\<raw\>@] This is a part of the API we do not know anything about.

258-- [@\<raw\>@] This is a part of the API we do not know anything about.

206--

259--

servant-server/src/Servant/Server/Experimental/Auth.hs+3−5

@@ -27,11 +27,9 @@ import Servant

27 ((:>))

27 ((:>))

28import Servant.API.Experimental.Auth

28import Servant.API.Experimental.Auth

29import Servant.Server.Internal

29import Servant.Server.Internal

30− (HasContextEntry, HasServer (..), getContextEntry)

30+ (DelayedIO, Handler, HasContextEntry, HasServer (..),

31−import Servant.Server.Internal.Handler

31+ addAuthCheck, delayedFailFatal, getContextEntry, runHandler,

32− (Handler, runHandler)

32+ withRequest)

33−import Servant.Server.Internal.RoutingApplication

34− (DelayedIO, addAuthCheck, delayedFailFatal, withRequest)

35

33

36-- * General Auth

34-- * General Auth

37

35

servant-server/src/Servant/Server/Generic.hs+18−20

@@ -1,12 +1,10 @@

1−{-# LANGUAGE ConstraintKinds #-}

2−{-# LANGUAGE DataKinds #-}

1+{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE FlexibleContexts #-}

2+{-# LANGUAGE FlexibleContexts #-}

4−{-# LANGUAGE KindSignatures #-}

5−{-# LANGUAGE RankNTypes #-}

3+{-# LANGUAGE RankNTypes #-}

6−{-# LANGUAGE ScopedTypeVariables #-}

4+{-# LANGUAGE ScopedTypeVariables #-}

7−{-# LANGUAGE TypeFamilies #-}

5+{-# LANGUAGE TypeFamilies #-}

8−{-# LANGUAGE TypeOperators #-}

6+{-# LANGUAGE TypeOperators #-}

9−{-# LANGUAGE UndecidableInstances #-}

7+

10-- | @since 0.14.1

8-- | @since 0.14.1

11module Servant.Server.Generic (

9module Servant.Server.Generic (

12 AsServerT,

10 AsServerT,

@@ -15,23 +13,17 @@ module Servant.Server.Generic (

15 genericServeT,

13 genericServeT,

16 genericServeTWithContext,

14 genericServeTWithContext,

17 genericServer,

15 genericServer,

18− genericServerT,

16+ genericServerT

19 ) where

17 ) where

20

18

21import Data.Proxy

19import Data.Proxy

22 (Proxy (..))

20 (Proxy (..))

23

21

24−import Servant.API.Generic

25import Servant.Server

22import Servant.Server

23+import Servant.API.Generic

24+import Servant.Server.Internal

26

25

27−-- | A type that specifies that an API record contains a server implementation.

28−data AsServerT (m :: * -> *)

29−instance GenericMode (AsServerT m) where

30− type AsServerT m :- api = ServerT api m

31−

32−type AsServer = AsServerT Handler

33−

34−-- | Transform record of routes into a WAI 'Application'.

26+-- | Transform a record of routes into a WAI 'Application'.

35genericServe

27genericServe

36 :: forall routes.

28 :: forall routes.

37 ( HasServer (ToServantApi routes) '[]

29 ( HasServer (ToServantApi routes) '[]

@@ -67,6 +59,7 @@ genericServeTWithContext

67 ( GenericServant routes (AsServerT m)

59 ( GenericServant routes (AsServerT m)

68 , GenericServant routes AsApi

60 , GenericServant routes AsApi

69 , HasServer (ToServantApi routes) ctx

61 , HasServer (ToServantApi routes) ctx

62+ , HasContextEntry (ctx .++ DefaultErrorFormatters) ErrorFormatters

70 , ServerT (ToServantApi routes) m ~ ToServant routes (AsServerT m)

63 , ServerT (ToServantApi routes) m ~ ToServant routes (AsServerT m)

71 )

64 )

72 => (forall a. m a -> Handler a) -- ^ 'hoistServer' argument to come back to 'Handler'

65 => (forall a. m a -> Handler a) -- ^ 'hoistServer' argument to come back to 'Handler'

@@ -80,15 +73,20 @@ genericServeTWithContext f server ctx =

80 p = genericApi (Proxy :: Proxy routes)

73 p = genericApi (Proxy :: Proxy routes)

81 pctx = Proxy :: Proxy ctx

74 pctx = Proxy :: Proxy ctx

82

75

83−-- | Transform record of endpoints into a 'Server'.

76+-- | Transform a record of endpoints into a 'Server'.

84genericServer

77genericServer

85 :: GenericServant routes AsServer

78 :: GenericServant routes AsServer

86 => routes AsServer

79 => routes AsServer

87 -> ToServant routes AsServer

80 -> ToServant routes AsServer

88genericServer = toServant

81genericServer = toServant

89

82

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

90genericServerT

87genericServerT

91 :: GenericServant routes (AsServerT m)

88 :: GenericServant routes (AsServerT m)

92 => routes (AsServerT m)

89 => routes (AsServerT m)

93 -> ToServant routes (AsServerT m)

90 -> ToServant routes (AsServerT m)

94genericServerT = toServant

91genericServerT = toServant

92+

servant-server/src/Servant/Server/Internal.hs+241−107

@@ -1,31 +1,34 @@

1−{-# LANGUAGE CPP #-}

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2{-# LANGUAGE ConstraintKinds #-}

2{-# LANGUAGE ConstraintKinds #-}

3{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE DataKinds #-}

4{-# LANGUAGE DeriveDataTypeable #-}

4{-# LANGUAGE DeriveDataTypeable #-}

5{-# LANGUAGE FlexibleContexts #-}

5{-# LANGUAGE FlexibleContexts #-}

6{-# LANGUAGE FlexibleInstances #-}

6{-# LANGUAGE FlexibleInstances #-}

7+{-# LANGUAGE InstanceSigs #-}

7{-# LANGUAGE MultiParamTypeClasses #-}

8{-# LANGUAGE MultiParamTypeClasses #-}

8{-# LANGUAGE OverloadedStrings #-}

9{-# LANGUAGE OverloadedStrings #-}

9{-# LANGUAGE PolyKinds #-}

10{-# LANGUAGE PolyKinds #-}

11+{-# LANGUAGE QuantifiedConstraints #-}

10{-# LANGUAGE RankNTypes #-}

12{-# LANGUAGE RankNTypes #-}

11{-# LANGUAGE ScopedTypeVariables #-}

13{-# LANGUAGE ScopedTypeVariables #-}

12{-# LANGUAGE TupleSections #-}

14{-# LANGUAGE TupleSections #-}

15+{-# LANGUAGE TypeApplications #-}

13{-# LANGUAGE TypeFamilies #-}

16{-# LANGUAGE TypeFamilies #-}

14{-# LANGUAGE TypeOperators #-}

17{-# LANGUAGE TypeOperators #-}

15{-# LANGUAGE UndecidableInstances #-}

18{-# LANGUAGE UndecidableInstances #-}

16

19

17−#if MIN_VERSION_base(4,9,0) && __GLASGOW_HASKELL__ >= 802

18−#define HAS_TYPE_ERROR

19−#endif

20−

21module Servant.Server.Internal

20module Servant.Server.Internal

22 ( module Servant.Server.Internal

21 ( module Servant.Server.Internal

23 , module Servant.Server.Internal.BasicAuth

22 , module Servant.Server.Internal.BasicAuth

24 , module Servant.Server.Internal.Context

23 , module Servant.Server.Internal.Context

24+ , module Servant.Server.Internal.Delayed

25+ , module Servant.Server.Internal.DelayedIO

26+ , module Servant.Server.Internal.ErrorFormatter

25 , module Servant.Server.Internal.Handler

27 , module Servant.Server.Internal.Handler

26 , module Servant.Server.Internal.Router

28 , module Servant.Server.Internal.Router

29+ , module Servant.Server.Internal.RouteResult

27 , module Servant.Server.Internal.RoutingApplication

30 , module Servant.Server.Internal.RoutingApplication

28− , module Servant.Server.Internal.ServantErr

31+ , module Servant.Server.Internal.ServerError

29 ) where

32 ) where

30

33

31import Control.Monad

34import Control.Monad

@@ -38,12 +41,11 @@ import qualified Data.ByteString as B

38import qualified Data.ByteString.Builder as BB

41import qualified Data.ByteString.Builder as BB

39import qualified Data.ByteString.Char8 as BC8

42import qualified Data.ByteString.Char8 as BC8

40import qualified Data.ByteString.Lazy as BL

43import qualified Data.ByteString.Lazy as BL

44+import Data.Constraint (Constraint, Dict(..))

41import Data.Either

45import Data.Either

42 (partitionEithers)

46 (partitionEithers)

43import Data.Maybe

47import Data.Maybe

44 (fromMaybe, isNothing, mapMaybe, maybeToList)

48 (fromMaybe, isNothing, mapMaybe, maybeToList)

45−import Data.Semigroup

46− ((<>))

47import Data.String

49import Data.String

48 (IsString (..))

50 (IsString (..))

49import Data.String.Conversions

51import Data.String.Conversions

@@ -52,8 +54,9 @@ import Data.Tagged

52 (Tagged (..), retag, untag)

54 (Tagged (..), retag, untag)

53import qualified Data.Text as T

55import qualified Data.Text as T

54import Data.Typeable

56import Data.Typeable

57+import GHC.Generics

55import GHC.TypeLits

58import GHC.TypeLits

56− (KnownNat, KnownSymbol, natVal, symbolVal)

59+ (KnownNat, KnownSymbol, TypeError, symbolVal)

57import qualified Network.HTTP.Media as NHM

60import qualified Network.HTTP.Media as NHM

58import Network.HTTP.Types hiding

61import Network.HTTP.Types hiding

59 (Header, ResponseHeaders)

62 (Header, ResponseHeaders)

@@ -61,42 +64,52 @@ import Network.Socket

61 (SockAddr)

64 (SockAddr)

62import Network.Wai

65import Network.Wai

63 (Application, Request, httpVersion, isSecure, lazyRequestBody,

66 (Application, Request, httpVersion, isSecure, lazyRequestBody,

64− rawQueryString, remoteHost, requestBody, requestHeaders,

67+ queryString, remoteHost, getRequestBodyChunk, requestHeaders,

65 requestMethod, responseLBS, responseStream, vault)

68 requestMethod, responseLBS, responseStream, vault)

66import Prelude ()

69import Prelude ()

67import Prelude.Compat

70import Prelude.Compat

68import Servant.API

71import Servant.API

69 ((:<|>) (..), (:>), Accept (..), BasicAuth, Capture',

72 ((:<|>) (..), (:>), Accept (..), BasicAuth, Capture',

70− CaptureAll, Description, EmptyAPI, FramingRender (..),

73+ CaptureAll, Description, EmptyAPI, Fragment,

71− FramingUnrender (..), FromSourceIO (..), Header', If,

74+ FramingRender (..), FramingUnrender (..), FromSourceIO (..),

72− IsSecure (..), QueryFlag, QueryParam', QueryParams, Raw,

75+ Header', If, IsSecure (..), NoContentVerb, QueryFlag,

73− ReflectMethod (reflectMethod), RemoteHost, ReqBody',

76+ QueryParam', QueryParams, Raw, ReflectMethod (reflectMethod),

74− SBool (..), SBoolI (..), SourceIO, Stream, StreamBody',

77+ RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO,

75− Summary, ToSourceIO (..), Vault, Verb, WithNamedContext)

78+ Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb,

79+ WithNamedContext, NamedRoutes)

80+import Servant.API.Generic (GenericMode(..), ToServant, ToServantApi, GServantProduct, toServant, fromServant)

76import Servant.API.ContentTypes

81import Servant.API.ContentTypes

77 (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),

82 (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),

78− AllMime, MimeRender (..), MimeUnrender (..), canHandleAcceptH)

83+ AllMime, MimeRender (..), MimeUnrender (..), NoContent,

84+ canHandleAcceptH)

79import Servant.API.Modifiers

85import Servant.API.Modifiers

80 (FoldLenient, FoldRequired, RequestArgument,

86 (FoldLenient, FoldRequired, RequestArgument,

81 unfoldRequestArgument)

87 unfoldRequestArgument)

82import Servant.API.ResponseHeaders

88import Servant.API.ResponseHeaders

83 (GetHeaders, Headers, getHeaders, getResponse)

89 (GetHeaders, Headers, getHeaders, getResponse)

90+import Servant.API.Status

91+ (statusFromNat)

84import qualified Servant.Types.SourceT as S

92import qualified Servant.Types.SourceT as S

93+import Servant.API.TypeErrors

85import Web.HttpApiData

94import Web.HttpApiData

86− (FromHttpApiData, parseHeader, parseQueryParam,

95+ (FromHttpApiData, parseHeader, parseQueryParam, parseUrlPiece,

87− parseUrlPieceMaybe, parseUrlPieces)

96+ parseUrlPieces)

88

97

89import Servant.Server.Internal.BasicAuth

98import Servant.Server.Internal.BasicAuth

90import Servant.Server.Internal.Context

99import Servant.Server.Internal.Context

100+import Servant.Server.Internal.Delayed

101+import Servant.Server.Internal.DelayedIO

102+import Servant.Server.Internal.ErrorFormatter

91import Servant.Server.Internal.Handler

103import Servant.Server.Internal.Handler

92import Servant.Server.Internal.Router

104import Servant.Server.Internal.Router

105+import Servant.Server.Internal.RouteResult

93import Servant.Server.Internal.RoutingApplication

106import Servant.Server.Internal.RoutingApplication

94−import Servant.Server.Internal.ServantErr

107+import Servant.Server.Internal.ServerError

95

108

96−#ifdef HAS_TYPE_ERROR

97import GHC.TypeLits

109import GHC.TypeLits

98 (ErrorMessage (..), TypeError)

110 (ErrorMessage (..), TypeError)

99−#endif

111+import Servant.API.TypeLevel

112+ (AtLeastOneFragment, FragmentUnique)

100

113

101class HasServer api context where

114class HasServer api context where

102 type ServerT api (m :: * -> *) :: *

115 type ServerT api (m :: * -> *) :: *

@@ -160,22 +173,31 @@ instance (HasServer a context, HasServer b context) => HasServer (a :<|> b) cont

160-- > server = getBook

173-- > server = getBook

161-- > where getBook :: Text -> Handler Book

174-- > where getBook :: Text -> Handler Book

162-- > getBook isbn = ...

175-- > getBook isbn = ...

163−instance (KnownSymbol capture, FromHttpApiData a, HasServer api context)

176+instance (KnownSymbol capture, FromHttpApiData a, Typeable a

177+ , HasServer api context, SBoolI (FoldLenient mods)

178+ , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters

179+ )

164 => HasServer (Capture' mods capture a :> api) context where

180 => HasServer (Capture' mods capture a :> api) context where

165

181

166 type ServerT (Capture' mods capture a :> api) m =

182 type ServerT (Capture' mods capture a :> api) m =

167− a -> ServerT api m

183+ If (FoldLenient mods) (Either String a) a -> ServerT api m

168

184

169 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s

185 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s

170

186

171 route Proxy context d =

187 route Proxy context d =

172− CaptureRouter $

188+ CaptureRouter [hint] $

173 route (Proxy :: Proxy api)

189 route (Proxy :: Proxy api)

174 context

190 context

175− (addCapture d $ \ txt -> case parseUrlPieceMaybe txt of

191+ (addCapture d $ \ txt -> withRequest $ \ request ->

176− Nothing -> delayedFail err400

192+ case ( sbool :: SBool (FoldLenient mods)

193+ , parseUrlPiece txt :: Either T.Text a) of

194+ (SFalse, Left e) -> delayedFail $ formatError rep request $ cs e

177− Just v -> return v

195+ (SFalse, Right v) -> return v

178− )

196+ (STrue, piece) -> return $ (either (Left . cs) Right) piece)

197+ where

198+ rep = typeRep (Proxy :: Proxy Capture')

199+ formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)

200+ hint = CaptureHint (T.pack $ symbolVal $ Proxy @capture) (typeRep (Proxy :: Proxy a))

179

201

180-- | If you use 'CaptureAll' in one of the endpoints for your API,

202-- | If you use 'CaptureAll' in one of the endpoints for your API,

181-- this automatically requires your server-side handler to be a

203-- this automatically requires your server-side handler to be a

@@ -194,7 +216,10 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer api context)

194-- > server = getSourceFile

216-- > server = getSourceFile

195-- > where getSourceFile :: [Text] -> Handler Book

217-- > where getSourceFile :: [Text] -> Handler Book

196-- > getSourceFile pathSegments = ...

218-- > getSourceFile pathSegments = ...

197−instance (KnownSymbol capture, FromHttpApiData a, HasServer api context)

219+instance (KnownSymbol capture, FromHttpApiData a, Typeable a

220+ , HasServer api context

221+ , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters

222+ )

198 => HasServer (CaptureAll capture a :> api) context where

223 => HasServer (CaptureAll capture a :> api) context where

199

224

200 type ServerT (CaptureAll capture a :> api) m =

225 type ServerT (CaptureAll capture a :> api) m =

@@ -203,14 +228,18 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer api context)

203 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s

228 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s

204

229

205 route Proxy context d =

230 route Proxy context d =

206− CaptureAllRouter $

231+ CaptureAllRouter [hint] $

207 route (Proxy :: Proxy api)

232 route (Proxy :: Proxy api)

208 context

233 context

234+ (addCapture d $ \ txts -> withRequest $ \ request ->

209− (addCapture d $ \ txts -> case parseUrlPieces txts of

235+ case parseUrlPieces txts of

210− Left _ -> delayedFail err400

236+ Left e -> delayedFail $ formatError rep request $ cs e

211− Right v -> return v

237+ Right v -> return v

212 )

238 )

213−

239+ where

240+ rep = typeRep (Proxy :: Proxy CaptureAll)

241+ formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)

242+ hint = CaptureHint (T.pack $ symbolVal $ Proxy @capture) (typeRep (Proxy :: Proxy [a]))

214

243

215allowedMethodHead :: Method -> Request -> Bool

244allowedMethodHead :: Method -> Request -> Bool

216allowedMethodHead method request = method == methodGet && requestMethod request == methodHead

245allowedMethodHead method request = method == methodGet && requestMethod request == methodHead

@@ -230,10 +259,10 @@ methodCheck method request

230-- body check is no longer an option. However, we now run the accept

259-- body check is no longer an option. However, we now run the accept

231-- check before the body check and can therefore afford to make it

260-- check before the body check and can therefore afford to make it

232-- recoverable.

261-- recoverable.

233−acceptCheck :: (AllMime list) => Proxy list -> B.ByteString -> DelayedIO ()

262+acceptCheck :: (AllMime list) => Proxy list -> AcceptHeader -> DelayedIO ()

234acceptCheck proxy accH

263acceptCheck proxy accH

235− | canHandleAcceptH proxy (AcceptHeader accH) = return ()

264+ | canHandleAcceptH proxy accH = return ()

236− | otherwise = delayedFail err406

265+ | otherwise = delayedFail err406

237

266

238methodRouter :: (AllCTRender ctypes a)

267methodRouter :: (AllCTRender ctypes a)

239 => (b -> ([(HeaderName, B.ByteString)], a))

268 => (b -> ([(HeaderName, B.ByteString)], a))

@@ -243,17 +272,28 @@ methodRouter :: (AllCTRender ctypes a)

243methodRouter splitHeaders method proxy status action = leafRouter route'

272methodRouter splitHeaders method proxy status action = leafRouter route'

244 where

273 where

245 route' env request respond =

274 route' env request respond =

246− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

275+ let accH = getAcceptHeader request

247 in runAction (action `addMethodCheck` methodCheck method request

276 in runAction (action `addMethodCheck` methodCheck method request

248 `addAcceptCheck` acceptCheck proxy accH

277 `addAcceptCheck` acceptCheck proxy accH

249 ) env request respond $ \ output -> do

278 ) env request respond $ \ output -> do

250 let (headers, b) = splitHeaders output

279 let (headers, b) = splitHeaders output

251− case handleAcceptH proxy (AcceptHeader accH) b of

280+ case handleAcceptH proxy accH b of

252 Nothing -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does

281 Nothing -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does

253 Just (contentT, body) ->

282 Just (contentT, body) ->

254 let bdy = if allowedMethodHead method request then "" else body

283 let bdy = if allowedMethodHead method request then "" else body

255 in Route $ responseLBS status ((hContentType, cs contentT) : headers) bdy

284 in Route $ responseLBS status ((hContentType, cs contentT) : headers) bdy

256

285

286+noContentRouter :: Method

287+ -> Status

288+ -> Delayed env (Handler b)

289+ -> Router env

290+noContentRouter method status action = leafRouter route'

291+ where

292+ route' env request respond =

293+ runAction (action `addMethodCheck` methodCheck method request)

294+ env request respond $ \ _output ->

295+ Route $ responseLBS status [] ""

296+

257instance {-# OVERLAPPABLE #-}

297instance {-# OVERLAPPABLE #-}

258 ( AllCTRender ctypes a, ReflectMethod method, KnownNat status

298 ( AllCTRender ctypes a, ReflectMethod method, KnownNat status

259 ) => HasServer (Verb method status ctypes a) context where

299 ) => HasServer (Verb method status ctypes a) context where

@@ -263,7 +303,7 @@ instance {-# OVERLAPPABLE #-}

263

303

264 route Proxy _ = methodRouter ([],) method (Proxy :: Proxy ctypes) status

304 route Proxy _ = methodRouter ([],) method (Proxy :: Proxy ctypes) status

265 where method = reflectMethod (Proxy :: Proxy method)

305 where method = reflectMethod (Proxy :: Proxy method)

266− status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)

306+ status = statusFromNat (Proxy :: Proxy status)

267

307

268instance {-# OVERLAPPING #-}

308instance {-# OVERLAPPING #-}

269 ( AllCTRender ctypes a, ReflectMethod method, KnownNat status

309 ( AllCTRender ctypes a, ReflectMethod method, KnownNat status

@@ -275,8 +315,16 @@ instance {-# OVERLAPPING #-}

275

315

276 route Proxy _ = methodRouter (\x -> (getHeaders x, getResponse x)) method (Proxy :: Proxy ctypes) status

316 route Proxy _ = methodRouter (\x -> (getHeaders x, getResponse x)) method (Proxy :: Proxy ctypes) status

277 where method = reflectMethod (Proxy :: Proxy method)

317 where method = reflectMethod (Proxy :: Proxy method)

278− status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)

318+ status = statusFromNat (Proxy :: Proxy status)

319+

320+instance (ReflectMethod method) =>

321+ HasServer (NoContentVerb method) context where

279

322

323+ type ServerT (NoContentVerb method) m = m NoContent

324+ hoistServerWithContext _ _ nt s = nt s

325+

326+ route Proxy _ = noContentRouter method status204

327+ where method = reflectMethod (Proxy :: Proxy method)

280

328

281instance {-# OVERLAPPABLE #-}

329instance {-# OVERLAPPABLE #-}

282 ( MimeRender ctype chunk, ReflectMethod method, KnownNat status,

330 ( MimeRender ctype chunk, ReflectMethod method, KnownNat status,

@@ -288,7 +336,7 @@ instance {-# OVERLAPPABLE #-}

288

336

289 route Proxy _ = streamRouter ([],) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)

337 route Proxy _ = streamRouter ([],) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)

290 where method = reflectMethod (Proxy :: Proxy method)

338 where method = reflectMethod (Proxy :: Proxy method)

291− status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)

339+ status = statusFromNat (Proxy :: Proxy status)

292

340

293

341

294instance {-# OVERLAPPING #-}

342instance {-# OVERLAPPING #-}

@@ -302,7 +350,7 @@ instance {-# OVERLAPPING #-}

302

350

303 route Proxy _ = streamRouter (\x -> (getHeaders x, getResponse x)) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)

351 route Proxy _ = streamRouter (\x -> (getHeaders x, getResponse x)) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)

304 where method = reflectMethod (Proxy :: Proxy method)

352 where method = reflectMethod (Proxy :: Proxy method)

305− status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)

353+ status = statusFromNat (Proxy :: Proxy status)

306

354

307

355

308streamRouter :: forall ctype a c chunk env framing. (MimeRender ctype chunk, FramingRender framing, ToSourceIO chunk a) =>

356streamRouter :: forall ctype a c chunk env framing. (MimeRender ctype chunk, FramingRender framing, ToSourceIO chunk a) =>

@@ -314,7 +362,7 @@ streamRouter :: forall ctype a c chunk env framing. (MimeRender ctype chunk, Fra

314 -> Delayed env (Handler c)

362 -> Delayed env (Handler c)

315 -> Router env

363 -> Router env

316streamRouter splitHeaders method status framingproxy ctypeproxy action = leafRouter $ \env request respond ->

364streamRouter splitHeaders method status framingproxy ctypeproxy action = leafRouter $ \env request respond ->

317− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

365+ let AcceptHeader accH = getAcceptHeader request

318 cmediatype = NHM.matchAccept [contentType ctypeproxy] accH

366 cmediatype = NHM.matchAccept [contentType ctypeproxy] accH

319 accCheck = when (isNothing cmediatype) $ delayedFail err406

367 accCheck = when (isNothing cmediatype) $ delayedFail err406

320 contentHeader = (hContentType, NHM.renderHeader . maybeToList $ cmediatype)

368 contentHeader = (hContentType, NHM.renderHeader . maybeToList $ cmediatype)

@@ -359,6 +407,7 @@ streamRouter splitHeaders method status framingproxy ctypeproxy action = leafRou

359instance

407instance

360 (KnownSymbol sym, FromHttpApiData a, HasServer api context

408 (KnownSymbol sym, FromHttpApiData a, HasServer api context

361 , SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)

409 , SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)

410+ , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters

362 )

411 )

363 => HasServer (Header' mods sym a :> api) context where

412 => HasServer (Header' mods sym a :> api) context where

364------

413------

@@ -370,6 +419,9 @@ instance

370 route Proxy context subserver = route (Proxy :: Proxy api) context $

419 route Proxy context subserver = route (Proxy :: Proxy api) context $

371 subserver `addHeaderCheck` withRequest headerCheck

420 subserver `addHeaderCheck` withRequest headerCheck

372 where

421 where

422+ rep = typeRep (Proxy :: Proxy Header')

423+ formatError = headerParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)

424+

373 headerName :: IsString n => n

425 headerName :: IsString n => n

374 headerName = fromString $ symbolVal (Proxy :: Proxy sym)

426 headerName = fromString $ symbolVal (Proxy :: Proxy sym)

375

427

@@ -380,15 +432,13 @@ instance

380 mev :: Maybe (Either T.Text a)

432 mev :: Maybe (Either T.Text a)

381 mev = fmap parseHeader $ lookup headerName (requestHeaders req)

433 mev = fmap parseHeader $ lookup headerName (requestHeaders req)

382

434

383− errReq = delayedFailFatal err400

435+ errReq = delayedFailFatal $ formatError rep req

384− { errBody = "Header " <> headerName <> " is required"

436+ $ "Header " <> headerName <> " is required"

385− }

386

437

387− errSt e = delayedFailFatal err400

438+ errSt e = delayedFailFatal $ formatError rep req

388− { errBody = cs $ "Error parsing header "

439+ $ cs $ "Error parsing header "

389− <> headerName

440+ <> headerName

390− <> " failed: " <> e

441+ <> " failed: " <> e

391− }

392

442

393-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,

443-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,

394-- this automatically requires your server-side handler to be a function

444-- this automatically requires your server-side handler to be a function

@@ -414,6 +464,7 @@ instance

414instance

464instance

415 ( KnownSymbol sym, FromHttpApiData a, HasServer api context

465 ( KnownSymbol sym, FromHttpApiData a, HasServer api context

416 , SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)

466 , SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)

467+ , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters

417 )

468 )

418 => HasServer (QueryParam' mods sym a :> api) context where

469 => HasServer (QueryParam' mods sym a :> api) context where

419------

470------

@@ -423,9 +474,12 @@ instance

423 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s

474 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s

424

475

425 route Proxy context subserver =

476 route Proxy context subserver =

426− let querytext req = parseQueryText $ rawQueryString req

477+ let querytext = queryToQueryText . queryString

427 paramname = cs $ symbolVal (Proxy :: Proxy sym)

478 paramname = cs $ symbolVal (Proxy :: Proxy sym)

428

479

480+ rep = typeRep (Proxy :: Proxy QueryParam')

481+ formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)

482+

429 parseParam :: Request -> DelayedIO (RequestArgument mods a)

483 parseParam :: Request -> DelayedIO (RequestArgument mods a)

430 parseParam req =

484 parseParam req =

431 unfoldRequestArgument (Proxy :: Proxy mods) errReq errSt mev

485 unfoldRequestArgument (Proxy :: Proxy mods) errReq errSt mev

@@ -433,14 +487,12 @@ instance

433 mev :: Maybe (Either T.Text a)

487 mev :: Maybe (Either T.Text a)

434 mev = fmap parseQueryParam $ join $ lookup paramname $ querytext req

488 mev = fmap parseQueryParam $ join $ lookup paramname $ querytext req

435

489

436− errReq = delayedFailFatal err400

490+ errReq = delayedFailFatal $ formatError rep req

437− { errBody = cs $ "Query parameter " <> paramname <> " is required"

491+ $ cs $ "Query parameter " <> paramname <> " is required"

438− }

439

492

440− errSt e = delayedFailFatal err400

493+ errSt e = delayedFailFatal $ formatError rep req

441− { errBody = cs $ "Error parsing query parameter "

494+ $ cs $ "Error parsing query parameter "

442− <> paramname <> " failed: " <> e

495+ <> paramname <> " failed: " <> e

443− }

444

496

445 delayed = addParameterCheck subserver . withRequest $ \req ->

497 delayed = addParameterCheck subserver . withRequest $ \req ->

446 parseParam req

498 parseParam req

@@ -466,7 +518,8 @@ instance

466-- > server = getBooksBy

518-- > server = getBooksBy

467-- > where getBooksBy :: [Text] -> Handler [Book]

519-- > where getBooksBy :: [Text] -> Handler [Book]

468-- > getBooksBy authors = ...return all books by these authors...

520-- > getBooksBy authors = ...return all books by these authors...

469−instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)

521+instance (KnownSymbol sym, FromHttpApiData a, HasServer api context

522+ , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters)

470 => HasServer (QueryParams sym a :> api) context where

523 => HasServer (QueryParams sym a :> api) context where

471

524

472 type ServerT (QueryParams sym a :> api) m =

525 type ServerT (QueryParams sym a :> api) m =

@@ -477,21 +530,23 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)

477 route Proxy context subserver = route (Proxy :: Proxy api) context $

530 route Proxy context subserver = route (Proxy :: Proxy api) context $

478 subserver `addParameterCheck` withRequest paramsCheck

531 subserver `addParameterCheck` withRequest paramsCheck

479 where

532 where

533+ rep = typeRep (Proxy :: Proxy QueryParams)

534+ formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)

535+

480 paramname = cs $ symbolVal (Proxy :: Proxy sym)

536 paramname = cs $ symbolVal (Proxy :: Proxy sym)

481 paramsCheck req =

537 paramsCheck req =

482 case partitionEithers $ fmap parseQueryParam params of

538 case partitionEithers $ fmap parseQueryParam params of

483 ([], parsed) -> return parsed

539 ([], parsed) -> return parsed

484− (errs, _) -> delayedFailFatal err400

540+ (errs, _) -> delayedFailFatal $ formatError rep req

485− { errBody = cs $ "Error parsing query parameter(s) "

541+ $ cs $ "Error parsing query parameter(s) "

486− <> paramname <> " failed: "

542+ <> paramname <> " failed: "

487− <> T.intercalate ", " errs

543+ <> T.intercalate ", " errs

488− }

489 where

544 where

490 params :: [T.Text]

545 params :: [T.Text]

491 params = mapMaybe snd

546 params = mapMaybe snd

492 . filter (looksLikeParam . fst)

547 . filter (looksLikeParam . fst)

493− . parseQueryText

548+ . queryToQueryText

494− . rawQueryString

549+ . queryString

495 $ req

550 $ req

496

551

497 looksLikeParam name = name == paramname || name == (paramname <> "[]")

552 looksLikeParam name = name == paramname || name == (paramname <> "[]")

@@ -517,7 +572,7 @@ instance (KnownSymbol sym, HasServer api context)

517 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s

572 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s

518

573

519 route Proxy context subserver =

574 route Proxy context subserver =

520− let querytext r = parseQueryText $ rawQueryString r

575+ let querytext = queryToQueryText . queryString

521 param r = case lookup paramname (querytext r) of

576 param r = case lookup paramname (querytext r) of

522 Just Nothing -> True -- param is there, with no value

577 Just Nothing -> True -- param is there, with no value

523 Just (Just v) -> examine v -- param with a value

578 Just (Just v) -> examine v -- param with a value

@@ -559,7 +614,7 @@ instance HasServer Raw context where

559-- The @Content-Type@ header is inspected, and the list provided is used to

614-- The @Content-Type@ header is inspected, and the list provided is used to

560-- attempt deserialization. If the request does not have a @Content-Type@

615-- attempt deserialization. If the request does not have a @Content-Type@

561-- header, it is treated as @application/octet-stream@ (as specified in

616-- header, it is treated as @application/octet-stream@ (as specified in

562−-- <http://tools.ietf.org/html/rfc7231#section-3.1.1.5 RFC7231>.

617+-- [RFC 7231 section 3.1.1.5](http://tools.ietf.org/html/rfc7231#section-3.1.1.5)).

563-- This lets servant worry about extracting it from the request and turning

618-- This lets servant worry about extracting it from the request and turning

564-- it into a value of the type you specify.

619-- it into a value of the type you specify.

565--

620--

@@ -575,6 +630,7 @@ instance HasServer Raw context where

575-- > where postBook :: Book -> Handler Book

630-- > where postBook :: Book -> Handler Book

576-- > postBook book = ...insert into your db...

631-- > postBook book = ...insert into your db...

577instance ( AllCTUnrender list a, HasServer api context, SBoolI (FoldLenient mods)

632instance ( AllCTUnrender list a, HasServer api context, SBoolI (FoldLenient mods)

633+ , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters

578 ) => HasServer (ReqBody' mods list a :> api) context where

634 ) => HasServer (ReqBody' mods list a :> api) context where

579

635

580 type ServerT (ReqBody' mods list a :> api) m =

636 type ServerT (ReqBody' mods list a :> api) m =

@@ -586,6 +642,9 @@ instance ( AllCTUnrender list a, HasServer api context, SBoolI (FoldLenient mods

586 = route (Proxy :: Proxy api) context $

642 = route (Proxy :: Proxy api) context $

587 addBodyCheck subserver ctCheck bodyCheck

643 addBodyCheck subserver ctCheck bodyCheck

588 where

644 where

645+ rep = typeRep (Proxy :: Proxy ReqBody')

646+ formatError = bodyParserErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)

647+

589 -- Content-Type check, we only lookup we can try to parse the request body

648 -- Content-Type check, we only lookup we can try to parse the request body

590 ctCheck = withRequest $ \ request -> do

649 ctCheck = withRequest $ \ request -> do

591 -- See HTTP RFC 2616, section 7.2.1

650 -- See HTTP RFC 2616, section 7.2.1

@@ -604,7 +663,7 @@ instance ( AllCTUnrender list a, HasServer api context, SBoolI (FoldLenient mods

604 case sbool :: SBool (FoldLenient mods) of

663 case sbool :: SBool (FoldLenient mods) of

605 STrue -> return mrqbody

664 STrue -> return mrqbody

606 SFalse -> case mrqbody of

665 SFalse -> case mrqbody of

607− Left e -> delayedFailFatal err400 { errBody = cs e }

666+ Left e -> delayedFailFatal $ formatError rep request e

608 Right v -> return v

667 Right v -> return v

609

668

610instance

669instance

@@ -627,7 +686,7 @@ instance

627 bodyCheck fromRS = withRequest $ \req -> do

686 bodyCheck fromRS = withRequest $ \req -> do

628 let mimeUnrender' = mimeUnrender (Proxy :: Proxy ctype) :: BL.ByteString -> Either String chunk

687 let mimeUnrender' = mimeUnrender (Proxy :: Proxy ctype) :: BL.ByteString -> Either String chunk

629 let framingUnrender' = framingUnrender (Proxy :: Proxy framing) mimeUnrender' :: SourceIO B.ByteString -> SourceIO chunk

688 let framingUnrender' = framingUnrender (Proxy :: Proxy framing) mimeUnrender' :: SourceIO B.ByteString -> SourceIO chunk

630− let body = requestBody req

689+ let body = getRequestBodyChunk req

631 let rs = S.fromAction B.null body

690 let rs = S.fromAction B.null body

632 let rs' = fromRS $ framingUnrender' rs

691 let rs' = fromRS $ framingUnrender' rs

633 return rs'

692 return rs'

@@ -696,12 +755,12 @@ data EmptyServer = EmptyServer deriving (Typeable, Eq, Show, Bounded, Enum)

696emptyServer :: ServerT EmptyAPI m

755emptyServer :: ServerT EmptyAPI m

697emptyServer = Tagged EmptyServer

756emptyServer = Tagged EmptyServer

698

757

699−-- | The server for an `EmptyAPI` is `emptyAPIServer`.

758+-- | The server for an `EmptyAPI` is `emptyServer`.

700--

759--

701-- > type MyApi = "nothing" :> EmptyApi

760-- > type MyApi = "nothing" :> EmptyApi

702-- >

761-- >

703-- > server :: Server MyApi

762-- > server :: Server MyApi

704−-- > server = emptyAPIServer

763+-- > server = emptyServer

705instance HasServer EmptyAPI context where

764instance HasServer EmptyAPI context where

706 type ServerT EmptyAPI m = Tagged m EmptyServer

765 type ServerT EmptyAPI m = Tagged m EmptyServer

707

766

@@ -730,7 +789,10 @@ instance ( KnownSymbol realm

730-- * helpers

789-- * helpers

731

790

732ct_wildcard :: B.ByteString

791ct_wildcard :: B.ByteString

733−ct_wildcard = "*" <> "/" <> "*" -- Because CPP

792+ct_wildcard = "*" <> "/" <> "*"

793+

794+getAcceptHeader :: Request -> AcceptHeader

795+getAcceptHeader = AcceptHeader . fromMaybe ct_wildcard . lookup hAccept . requestHeaders

734

796

735-- * General Authentication

797-- * General Authentication

736

798

@@ -755,39 +817,15 @@ instance (HasContextEntry context (NamedContext name subContext), HasServer subA

755 hoistServerWithContext _ _ nt s = hoistServerWithContext (Proxy :: Proxy subApi) (Proxy :: Proxy subContext) nt s

817 hoistServerWithContext _ _ nt s = hoistServerWithContext (Proxy :: Proxy subApi) (Proxy :: Proxy subContext) nt s

756

818

757-------------------------------------------------------------------------------

819-------------------------------------------------------------------------------

758−-- TypeError helpers

820+-- Custom type errors

759-------------------------------------------------------------------------------

821-------------------------------------------------------------------------------

760

822

761−#ifdef HAS_TYPE_ERROR

823+-- Erroring instance for 'HasServer' when a combinator is not fully applied

762−-- | This instance catches mistakes when there are non-saturated

763−-- type applications on LHS of ':>'.

764−--

765−-- >>> serve (Proxy :: Proxy (Capture "foo" :> Get '[JSON] Int)) (error "...")

766−-- ...

767−-- ...Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'.

768−-- ...Maybe you haven't applied enough arguments to

769−-- ...Capture' '[] "foo"

770−-- ...

771−--

772−-- >>> undefined :: Server (Capture "foo" :> Get '[JSON] Int)

773−-- ...

774−-- ...Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'.

775−-- ...Maybe you haven't applied enough arguments to

776−-- ...Capture' '[] "foo"

777−-- ...

778−--

779−instance TypeError (HasServerArrowKindError arr) => HasServer ((arr :: k -> l) :> api) context

824+instance TypeError (PartialApplication HasServer arr) => HasServer ((arr :: a -> b) :> sub) context

780 where

825 where

781− type ServerT (arr :> api) m = TypeError (HasServerArrowKindError arr)

826+ type ServerT (arr :> sub) _ = TypeError (PartialApplication (HasServer :: * -> [*] -> Constraint) arr)

782− -- it doens't really matter what sub route we peak

827+ route = error "unreachable"

783− route _ _ _ = error "servant-server panic: impossible happened in HasServer (arr :> api)"

784− hoistServerWithContext _ _ _ = id

828+ hoistServerWithContext _ _ _ _ = error "unreachable"

785−

786−-- Cannot have TypeError here, otherwise use of this symbol will error :)

787−type HasServerArrowKindError arr =

788− 'Text "Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'."

789− ':$$: 'Text "Maybe you haven't applied enough arguments to"

790− ':$$: 'ShowType arr

791

829

792-- | This instance prevents from accidentally using '->' instead of ':>'

830-- | This instance prevents from accidentally using '->' instead of ':>'

793--

831--

@@ -821,7 +859,103 @@ type HasServerArrowTypeError a b =

821 ':$$: 'ShowType a

859 ':$$: 'ShowType a

822 ':$$: 'Text "and"

860 ':$$: 'Text "and"

823 ':$$: 'ShowType b

861 ':$$: 'ShowType b

824−#endif

862+

863+-- Erroring instances for 'HasServer' for unknown API combinators

864+

865+-- XXX: This omits the @context@ parameter, e.g.:

866+--

867+-- "There is no instance for HasServer (Bool :> …)". Do we care ?

868+instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub HasServer ty) => HasServer (ty :> sub) context

869+

870+instance {-# OVERLAPPABLE #-} TypeError (NoInstanceFor (HasServer api context)) => HasServer api context

871+

872+-- | Ignore @'Fragment'@ in server handlers.

873+-- See <https://ietf.org/rfc/rfc2616.html#section-15.1.3> for more details.

874+--

875+-- Example:

876+--

877+-- > type MyApi = "books" :> Fragment Text :> Get '[JSON] [Book]

878+-- >

879+-- > server :: Server MyApi

880+-- > server = getBooks

881+-- > where getBooks :: Handler [Book]

882+-- > getBooks = ...return all books...

883+instance (AtLeastOneFragment api, FragmentUnique (Fragment a1 :> api), HasServer api context)

884+ => HasServer (Fragment a1 :> api) context where

885+ type ServerT (Fragment a1 :> api) m = ServerT api m

886+

887+ route _ = route (Proxy :: Proxy api)

888+

889+ hoistServerWithContext _ = hoistServerWithContext (Proxy :: Proxy api)

825

890

826-- $setup

891-- $setup

827-- >>> import Servant

892-- >>> import Servant

893+

894+-- | A type that specifies that an API record contains a server implementation.

895+data AsServerT (m :: * -> *)

896+instance GenericMode (AsServerT m) where

897+ type AsServerT m :- api = ServerT api m

898+

899+type AsServer = AsServerT Handler

900+

901+

902+-- | Set of constraints required to convert to / from vanilla server types.

903+type GServerConstraints api m =

904+ ( ToServant api (AsServerT m) ~ ServerT (ToServantApi api) m

905+ , GServantProduct (Rep (api (AsServerT m)))

906+ )

907+

908+-- | This class is a necessary evil: in the implementation of 'HasServer' for

909+-- @'NamedRoutes' api@, we essentially need the quantified constraint @forall

910+-- m. 'GServerConstraints' m@ to hold.

911+--

912+-- We cannot require do that directly as the definition of 'GServerConstraints'

913+-- contains type family applications ('Rep' and 'ServerT'). The trick is to hide

914+-- those type family applications behind a typeclass providing evidence for

915+-- @'GServerConstraints' api m@ in the form of a dictionary, and require that

916+-- @forall m. 'GServer' api m@ instead.

917+--

918+-- Users shouldn't have to worry about this class, as the only possible instance

919+-- is provided in this module for all record APIs.

920+

921+class GServer (api :: * -> *) (m :: * -> *) where

922+ gServerProof :: Dict (GServerConstraints api m)

923+

924+instance

925+ ( ToServant api (AsServerT m) ~ ServerT (ToServantApi api) m

926+ , GServantProduct (Rep (api (AsServerT m)))

927+ ) => GServer api m where

928+ gServerProof = Dict

929+

930+instance

931+ ( HasServer (ToServantApi api) context

932+ , forall m. Generic (api (AsServerT m))

933+ , forall m. GServer api m

934+ ) => HasServer (NamedRoutes api) context where

935+

936+ type ServerT (NamedRoutes api) m = api (AsServerT m)

937+

938+ route

939+ :: Proxy (NamedRoutes api)

940+ -> Context context

941+ -> Delayed env (api (AsServerT Handler))

942+ -> Router env

943+ route _ ctx delayed =

944+ case gServerProof @api @Handler of

945+ Dict -> route (Proxy @(ToServantApi api)) ctx (toServant <$> delayed)

946+

947+ hoistServerWithContext

948+ :: forall m n. Proxy (NamedRoutes api)

949+ -> Proxy context

950+ -> (forall x. m x -> n x)

951+ -> api (AsServerT m)

952+ -> api (AsServerT n)

953+ hoistServerWithContext _ pctx nat server =

954+ case (gServerProof @api @m, gServerProof @api @n) of

955+ (Dict, Dict) ->

956+ fromServant servantSrvN

957+ where

958+ servantSrvM :: ServerT (ToServantApi api) m =

959+ toServant server

960+ servantSrvN :: ServerT (ToServantApi api) n =

961+ hoistServerWithContext (Proxy @(ToServantApi api)) pctx nat servantSrvM

servant-server/src/Servant/Server/Internal/BasicAuth.hs+4−6

@@ -9,11 +9,9 @@ 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− ((<>))

17import Data.Typeable

15import Data.Typeable

18 (Typeable)

16 (Typeable)

19import Data.Word8

17import Data.Word8

@@ -26,13 +24,13 @@ import Network.Wai

26

24

27import Servant.API.BasicAuth

25import Servant.API.BasicAuth

28 (BasicAuthData (BasicAuthData))

26 (BasicAuthData (BasicAuthData))

29−import Servant.Server.Internal.RoutingApplication

27+import Servant.Server.Internal.DelayedIO

30−import Servant.Server.Internal.ServantErr

28+import Servant.Server.Internal.ServerError

31

29

32-- * Basic Auth

30-- * Basic Auth

33

31

34-- | servant-server's current implementation of basic authentication is not

32-- | servant-server's current implementation of basic authentication is not

35−-- immune to certian kinds of timing attacks. Decoding payloads does not take

33+-- immune to certain kinds of timing attacks. Decoding payloads does not take

36-- a fixed amount of time.

34-- a fixed amount of time.

37

35

38-- | The result of authentication/authorization

36-- | The result of authentication/authorization

servant-server/src/Servant/Server/Internal/Context.hs+24−9

@@ -1,11 +1,12 @@

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

8−{-# LANGUAGE TypeOperators #-}

9+{-# LANGUAGE TypeOperators #-}

9

10

10module Servant.Server.Internal.Context where

11module Servant.Server.Internal.Context where

11

12

@@ -20,7 +21,7 @@ import GHC.TypeLits

20--

21--

21-- If you are using combinators that require a non-empty 'Context' you have to

22-- If you are using combinators that require a non-empty 'Context' you have to

22-- use 'Servant.Server.serveWithContext' and pass it a 'Context' that contains all

23-- use 'Servant.Server.serveWithContext' and pass it a 'Context' that contains all

23−-- the values your combinators need. A 'Context' is essentially a heterogenous

24+-- the values your combinators need. A 'Context' is essentially a heterogeneous

24-- list and accessing the elements is being done by type (see 'getContextEntry').

25-- list and accessing the elements is being done by type (see 'getContextEntry').

25-- The parameter of the type 'Context' is a type-level list reflecting the types

26-- The parameter of the type 'Context' is a type-level list reflecting the types

26-- of the contained context entries. To create a 'Context' with entries, use the

27-- of the contained context entries. To create a 'Context' with entries, use the

@@ -45,6 +46,20 @@ instance Eq (Context '[]) where

45instance (Eq a, Eq (Context as)) => Eq (Context (a ': as)) where

46instance (Eq a, Eq (Context as)) => Eq (Context (a ': as)) where

46 x1 :. y1 == x2 :. y2 = x1 == x2 && y1 == y2

47 x1 :. y1 == x2 :. y2 = x1 == x2 && y1 == y2

47

48

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+

48-- | This class is used to access context entries in 'Context's. 'getContextEntry'

63-- | This class is used to access context entries in 'Context's. 'getContextEntry'

49-- returns the first value where the type matches:

64-- returns the first value where the type matches:

50--

65--

servant-server/src/Servant/Server/Internal/Delayed.hsnew file+272

@@ -0,0 +1,272 @@

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.hsnew file+71

@@ -0,0 +1,71 @@

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.hsnew file+87

@@ -0,0 +1,87 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE PolyKinds #-}

3+{-# LANGUAGE RankNTypes #-}

4+{-# LANGUAGE TypeOperators #-}

5+

6+module Servant.Server.Internal.ErrorFormatter

7+ ( ErrorFormatters(..)

8+ , ErrorFormatter

9+ , NotFoundErrorFormatter

10+

11+ , DefaultErrorFormatters

12+ , defaultErrorFormatters

13+

14+ , MkContextWithErrorFormatter

15+ , mkContextWithErrorFormatter

16+ ) where

17+

18+import Data.String.Conversions

19+ (cs)

20+import Data.Typeable

21+import Network.Wai.Internal

22+ (Request)

23+

24+import Servant.API

25+ (Capture, ReqBody)

26+import Servant.Server.Internal.Context

27+import Servant.Server.Internal.ServerError

28+

29+-- | 'Context' that contains default error formatters.

30+type DefaultErrorFormatters = '[ErrorFormatters]

31+

32+-- | A collection of error formatters for different situations.

33+--

34+-- If you need to override one of them, use 'defaultErrorFormatters' with record update syntax.

35+data ErrorFormatters = ErrorFormatters

36+ { -- | Format error from parsing the request body.

37+ bodyParserErrorFormatter :: ErrorFormatter

38+ -- | Format error from parsing url parts or query parameters.

39+ , urlParseErrorFormatter :: ErrorFormatter

40+ -- | Format error from parsing request headers.

41+ , headerParseErrorFormatter :: ErrorFormatter

42+ -- | Format error for not found URLs.

43+ , notFoundErrorFormatter :: NotFoundErrorFormatter

44+ }

45+

46+-- | Default formatters will just return HTTP 400 status code with error

47+-- message as response body.

48+defaultErrorFormatters :: ErrorFormatters

49+defaultErrorFormatters = ErrorFormatters

50+ { bodyParserErrorFormatter = err400Formatter

51+ , urlParseErrorFormatter = err400Formatter

52+ , headerParseErrorFormatter = err400Formatter

53+ , notFoundErrorFormatter = const err404

54+ }

55+

56+-- | A custom formatter for errors produced by parsing combinators like

57+-- 'ReqBody' or 'Capture'.

58+--

59+-- A 'TypeRep' argument described the concrete combinator that raised

60+-- the error, allowing formatter to customize the message for different

61+-- combinators.

62+--

63+-- A full 'Request' is also passed so that the formatter can react to @Accept@ header,

64+-- for example.

65+type ErrorFormatter = TypeRep -> Request -> String -> ServerError

66+

67+-- | This formatter does not get neither 'TypeRep' nor error message.

68+type NotFoundErrorFormatter = Request -> ServerError

69+

70+type MkContextWithErrorFormatter (ctx :: [*]) = ctx .++ DefaultErrorFormatters

71+

72+mkContextWithErrorFormatter :: forall (ctx :: [*]). Context ctx -> Context (MkContextWithErrorFormatter ctx)

73+mkContextWithErrorFormatter ctx = ctx .++ (defaultErrorFormatters :. EmptyContext)

74+

75+-- Internal

76+

77+err400Formatter :: ErrorFormatter

78+err400Formatter _ _ e = err400 { errBody = cs e }

79+

80+-- These definitions suppress "unused import" warning.

81+-- The imorts are needed for Haddock to correctly link to them.

82+_RB :: Proxy ReqBody

83+_RB = Proxy

84+_C :: Proxy Capture

85+_C = Proxy

86+_CT :: Proxy Context

87+_CT = Proxy

servant-server/src/Servant/Server/Internal/Handler.hs+12−7

@@ -13,30 +13,35 @@ import Control.Monad.Base

13import Control.Monad.Catch

13import Control.Monad.Catch

14 (MonadCatch, MonadMask, MonadThrow)

14 (MonadCatch, MonadMask, MonadThrow)

15import Control.Monad.Error.Class

15import Control.Monad.Error.Class

16− (MonadError)

16+ (MonadError, throwError)

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)

23import GHC.Generics

25import GHC.Generics

24 (Generic)

26 (Generic)

25−import Servant.Server.Internal.ServantErr

27+import Servant.Server.Internal.ServerError

26− (ServantErr)

28+ (ServerError, errBody, err500)

27

29

28−newtype Handler a = Handler { runHandler' :: ExceptT ServantErr IO a }

30+newtype Handler a = Handler { runHandler' :: ExceptT ServerError IO a }

29 deriving

31 deriving

30 ( Functor, Applicative, Monad, MonadIO, Generic

32 ( Functor, Applicative, Monad, MonadIO, Generic

31− , MonadError ServantErr

33+ , MonadError ServerError

32 , MonadThrow, MonadCatch, MonadMask

34 , MonadThrow, MonadCatch, MonadMask

33 )

35 )

34

36

37+instance MonadFail Handler where

38+ fail str = throwError err500 { errBody = fromString str }

39+

35instance MonadBase IO Handler where

40instance MonadBase IO Handler where

36 liftBase = Handler . liftBase

41 liftBase = Handler . liftBase

37

42

38instance MonadBaseControl IO Handler where

43instance MonadBaseControl IO Handler where

39− type StM Handler a = Either ServantErr a

44+ type StM Handler a = Either ServerError a

40

45

41 -- liftBaseWith :: (RunInBase Handler IO -> IO a) -> Handler a

46 -- liftBaseWith :: (RunInBase Handler IO -> IO a) -> Handler a

42 liftBaseWith f = Handler (liftBaseWith (\g -> f (g . runHandler')))

47 liftBaseWith f = Handler (liftBaseWith (\g -> f (g . runHandler')))

@@ -44,5 +49,5 @@ instance MonadBaseControl IO Handler where

44 -- restoreM :: StM Handler a -> Handler a

49 -- restoreM :: StM Handler a -> Handler a

45 restoreM st = Handler (restoreM st)

50 restoreM st = Handler (restoreM st)

46

51

47−runHandler :: Handler a -> IO (Either ServantErr a)

52+runHandler :: Handler a -> IO (Either ServerError a)

48runHandler = runExceptT . runHandler'

53runHandler = runExceptT . runHandler'

servant-server/src/Servant/Server/Internal/RouteResult.hsnew file+76

@@ -0,0 +1,76 @@

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+51−32

@@ -9,19 +9,37 @@ import Prelude.Compat

9

9

10import Data.Function

10import Data.Function

11 (on)

11 (on)

12+import Data.List

13+ (nub)

12import Data.Map

14import Data.Map

13 (Map)

15 (Map)

14import qualified Data.Map as M

16import qualified Data.Map as M

15import Data.Text

17import Data.Text

16 (Text)

18 (Text)

17import qualified Data.Text as T

19import qualified Data.Text as T

20+import Data.Typeable

21+ (TypeRep)

18import Network.Wai

22import Network.Wai

19 (Response, pathInfo)

23 (Response, pathInfo)

24+import Servant.Server.Internal.ErrorFormatter

25+import Servant.Server.Internal.RouteResult

20import Servant.Server.Internal.RoutingApplication

26import Servant.Server.Internal.RoutingApplication

21−import Servant.Server.Internal.ServantErr

27+import Servant.Server.Internal.ServerError

22

28

23type Router env = Router' env RoutingApplication

29type Router env = Router' env RoutingApplication

24

30

31+data CaptureHint = CaptureHint

32+ { captureName :: Text

33+ , captureType :: TypeRep

34+ }

35+ deriving (Show, Eq)

36+

37+toCaptureTag :: CaptureHint -> Text

38+toCaptureTag hint = captureName hint <> "::" <> (T.pack . show) (captureType hint)

39+

40+toCaptureTags :: [CaptureHint] -> Text

41+toCaptureTags hints = "<" <> T.intercalate "|" (map toCaptureTag hints) <> ">"

42+

25-- | Internal representation of a router.

43-- | Internal representation of a router.

26--

44--

27-- The first argument describes an environment type that is

45-- The first argument describes an environment type that is

@@ -34,10 +52,10 @@ data Router' env a =

34 -- ^ the map contains routers for subpaths (first path component used

52 -- ^ the map contains routers for subpaths (first path component used

35 -- for lookup and removed afterwards), the list contains handlers

53 -- for lookup and removed afterwards), the list contains handlers

36 -- for the empty path, to be tried in order

54 -- for the empty path, to be tried in order

37− | CaptureRouter (Router' (Text, env) a)

55+ | CaptureRouter [CaptureHint] (Router' (Text, env) a)

38 -- ^ first path component is passed to the child router in its

56 -- ^ first path component is passed to the child router in its

39 -- environment and removed afterwards

57 -- environment and removed afterwards

40− | CaptureAllRouter (Router' ([Text], env) a)

58+ | CaptureAllRouter [CaptureHint] (Router' ([Text], env) a)

41 -- ^ all path components are passed to the child router in its

59 -- ^ all path components are passed to the child router in its

42 -- environment and are removed afterwards

60 -- environment and are removed afterwards

43 | RawRouter (env -> a)

61 | RawRouter (env -> a)

@@ -67,8 +85,8 @@ leafRouter l = StaticRouter M.empty [l]

67choice :: Router' env a -> Router' env a -> Router' env a

85choice :: Router' env a -> Router' env a -> Router' env a

68choice (StaticRouter table1 ls1) (StaticRouter table2 ls2) =

86choice (StaticRouter table1 ls1) (StaticRouter table2 ls2) =

69 StaticRouter (M.unionWith choice table1 table2) (ls1 ++ ls2)

87 StaticRouter (M.unionWith choice table1 table2) (ls1 ++ ls2)

70−choice (CaptureRouter router1) (CaptureRouter router2) =

88+choice (CaptureRouter hints1 router1) (CaptureRouter hints2 router2) =

71− CaptureRouter (choice router1 router2)

89+ CaptureRouter (nub $ hints1 ++ hints2) (choice router1 router2)

72choice router1 (Choice router2 router3) = Choice (choice router1 router2) router3

90choice router1 (Choice router2 router3) = Choice (choice router1 router2) router3

73choice router1 router2 = Choice router1 router2

91choice router1 router2 = Choice router1 router2

74

92

@@ -82,7 +100,7 @@ choice router1 router2 = Choice router1 router2

82--

100--

83data RouterStructure =

101data RouterStructure =

84 StaticRouterStructure (Map Text RouterStructure) Int

102 StaticRouterStructure (Map Text RouterStructure) Int

85− | CaptureRouterStructure RouterStructure

103+ | CaptureRouterStructure [CaptureHint] RouterStructure

86 | RawRouterStructure

104 | RawRouterStructure

87 | ChoiceStructure RouterStructure RouterStructure

105 | ChoiceStructure RouterStructure RouterStructure

88 deriving (Eq, Show)

106 deriving (Eq, Show)

@@ -96,11 +114,11 @@ data RouterStructure =

96routerStructure :: Router' env a -> RouterStructure

114routerStructure :: Router' env a -> RouterStructure

97routerStructure (StaticRouter m ls) =

115routerStructure (StaticRouter m ls) =

98 StaticRouterStructure (fmap routerStructure m) (length ls)

116 StaticRouterStructure (fmap routerStructure m) (length ls)

99−routerStructure (CaptureRouter router) =

117+routerStructure (CaptureRouter hints router) =

100− CaptureRouterStructure $

118+ CaptureRouterStructure hints $

101 routerStructure router

119 routerStructure router

102−routerStructure (CaptureAllRouter router) =

120+routerStructure (CaptureAllRouter hints router) =

103− CaptureRouterStructure $

121+ CaptureRouterStructure hints $

104 routerStructure router

122 routerStructure router

105routerStructure (RawRouter _) =

123routerStructure (RawRouter _) =

106 RawRouterStructure

124 RawRouterStructure

@@ -112,8 +130,8 @@ routerStructure (Choice r1 r2) =

112-- | Compare the structure of two routers.

130-- | Compare the structure of two routers.

113--

131--

114sameStructure :: Router' env a -> Router' env b -> Bool

132sameStructure :: Router' env a -> Router' env b -> Bool

115−sameStructure r1 r2 =

133+sameStructure router1 router2 =

116− routerStructure r1 == routerStructure r2

134+ routerStructure router1 == routerStructure router2

117

135

118-- | Provide a textual representation of the

136-- | Provide a textual representation of the

119-- structure of a router.

137-- structure of a router.

@@ -124,7 +142,8 @@ routerLayout router =

124 where

142 where

125 mkRouterLayout :: Bool -> RouterStructure -> [Text]

143 mkRouterLayout :: Bool -> RouterStructure -> [Text]

126 mkRouterLayout c (StaticRouterStructure m n) = mkSubTrees c (M.toList m) n

144 mkRouterLayout c (StaticRouterStructure m n) = mkSubTrees c (M.toList m) n

127− mkRouterLayout c (CaptureRouterStructure r) = mkSubTree c "<capture>" (mkRouterLayout False r)

145+ mkRouterLayout c (CaptureRouterStructure hints r) =

146+ mkSubTree c (toCaptureTags hints) (mkRouterLayout False r)

128 mkRouterLayout c RawRouterStructure =

147 mkRouterLayout c RawRouterStructure =

129 if c then ["├─ <raw>"] else ["└─ <raw>"]

148 if c then ["├─ <raw>"] else ["└─ <raw>"]

130 mkRouterLayout c (ChoiceStructure r1 r2) =

149 mkRouterLayout c (ChoiceStructure r1 r2) =

@@ -152,52 +171,52 @@ tweakResponse :: (RouteResult Response -> RouteResult Response) -> Router env ->

152tweakResponse f = fmap (\a -> \req cont -> a req (cont . f))

171tweakResponse f = fmap (\a -> \req cont -> a req (cont . f))

153

172

154-- | Interpret a router as an application.

173-- | Interpret a router as an application.

155−runRouter :: Router () -> RoutingApplication

174+runRouter :: NotFoundErrorFormatter -> Router () -> RoutingApplication

156−runRouter r = runRouterEnv r ()

175+runRouter fmt r = runRouterEnv fmt r ()

157

176

158−runRouterEnv :: Router env -> env -> RoutingApplication

177+runRouterEnv :: NotFoundErrorFormatter -> Router env -> env -> RoutingApplication

159−runRouterEnv router env request respond =

178+runRouterEnv fmt router env request respond =

160 case router of

179 case router of

161 StaticRouter table ls ->

180 StaticRouter table ls ->

162 case pathInfo request of

181 case pathInfo request of

163− [] -> runChoice ls env request respond

182+ [] -> runChoice fmt ls env request respond

164 -- This case is to handle trailing slashes.

183 -- This case is to handle trailing slashes.

165− [""] -> runChoice ls env request respond

184+ [""] -> runChoice fmt ls env request respond

166 first : rest | Just router' <- M.lookup first table

185 first : rest | Just router' <- M.lookup first table

167 -> let request' = request { pathInfo = rest }

186 -> let request' = request { pathInfo = rest }

168− in runRouterEnv router' env request' respond

187+ in runRouterEnv fmt router' env request' respond

169− _ -> respond $ Fail err404

188+ _ -> respond $ Fail $ fmt request

170− CaptureRouter router' ->

189+ CaptureRouter _ router' ->

171 case pathInfo request of

190 case pathInfo request of

172− [] -> respond $ Fail err404

191+ [] -> respond $ Fail $ fmt request

173 -- This case is to handle trailing slashes.

192 -- This case is to handle trailing slashes.

174− [""] -> respond $ Fail err404

193+ [""] -> respond $ Fail $ fmt request

175 first : rest

194 first : rest

176 -> let request' = request { pathInfo = rest }

195 -> let request' = request { pathInfo = rest }

177− in runRouterEnv router' (first, env) request' respond

196+ in runRouterEnv fmt router' (first, env) request' respond

178− CaptureAllRouter router' ->

197+ CaptureAllRouter _ router' ->

179 let segments = pathInfo request

198 let segments = pathInfo request

180 request' = request { pathInfo = [] }

199 request' = request { pathInfo = [] }

181− in runRouterEnv router' (segments, env) request' respond

200+ in runRouterEnv fmt router' (segments, env) request' respond

182 RawRouter app ->

201 RawRouter app ->

183 app env request respond

202 app env request respond

184 Choice r1 r2 ->

203 Choice r1 r2 ->

185− runChoice [runRouterEnv r1, runRouterEnv r2] env request respond

204+ runChoice fmt [runRouterEnv fmt r1, runRouterEnv fmt r2] env request respond

186

205

187-- | Try a list of routing applications in order.

206-- | Try a list of routing applications in order.

188-- We stop as soon as one fails fatally or succeeds.

207-- We stop as soon as one fails fatally or succeeds.

189-- If all fail normally, we pick the "best" error.

208-- If all fail normally, we pick the "best" error.

190--

209--

191−runChoice :: [env -> RoutingApplication] -> env -> RoutingApplication

210+runChoice :: NotFoundErrorFormatter -> [env -> RoutingApplication] -> env -> RoutingApplication

192−runChoice ls =

211+runChoice fmt ls =

193 case ls of

212 case ls of

194− [] -> \ _ _ respond -> respond (Fail err404)

213+ [] -> \ _ request respond -> respond (Fail $ fmt request)

195 [r] -> r

214 [r] -> r

196 (r : rs) ->

215 (r : rs) ->

197 \ env request respond ->

216 \ env request respond ->

198 r env request $ \ response1 ->

217 r env request $ \ response1 ->

199 case response1 of

218 case response1 of

200− Fail _ -> runChoice rs env request $ \ response2 ->

219+ Fail _ -> runChoice fmt rs env request $ \ response2 ->

201 respond $ highestPri response1 response2

220 respond $ highestPri response1 response2

202 _ -> respond response1

221 _ -> respond response1

203 where

222 where

servant-server/src/Servant/Server/Internal/RoutingApplication.hs+4−383

@@ -1,399 +1,20 @@

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

11module Servant.Server.Internal.RoutingApplication where

1module Servant.Server.Internal.RoutingApplication where

12

2

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)

29import Network.Wai

3import Network.Wai

30 (Application, Request, Response, ResponseReceived)

4 (Application, Request, Response, ResponseReceived)

31import Prelude ()

5import Prelude ()

32import Prelude.Compat

6import Prelude.Compat

33−import Servant.Server.Internal.Handler

7+import Servant.Server.Internal.RouteResult

34−import Servant.Server.Internal.ServantErr

8+import Servant.Server.Internal.ServerError

35

9

36type RoutingApplication =

10type RoutingApplication =

37 Request -- ^ the request, the field 'pathInfo' may be modified by url routing

11 Request -- ^ the request, the field 'pathInfo' may be modified by url routing

38 -> (RouteResult Response -> IO ResponseReceived) -> IO ResponseReceived

12 -> (RouteResult Response -> IO ResponseReceived) -> IO ResponseReceived

39

13

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−

96toApplication :: RoutingApplication -> Application

14toApplication :: RoutingApplication -> Application

97toApplication ra request respond = ra request routingRespond

15toApplication ra request respond = ra request routingRespond

98 where

16 where

99 routingRespond :: RouteResult Response -> IO ResponseReceived

17 routingRespond :: RouteResult Response -> IO ResponseReceived

100− routingRespond (Fail err) = respond $ responseServantErr err

18+ routingRespond (Fail err) = respond $ responseServerError err

101− routingRespond (FailFatal err) = respond $ responseServantErr err

19+ routingRespond (FailFatal err) = respond $ responseServerError err

102 routingRespond (Route v) = respond v

20 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/ServantErr.hs → servant-server/src/Servant/Server/Internal/ServerError.hsrenamed+76−74

@@ -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.ServantErr where

4+module Servant.Server.Internal.ServerError where

5

5

6import Control.Exception

6import Control.Exception

7 (Exception)

7 (Exception)

@@ -13,16 +13,18 @@ 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

16−data ServantErr = ServantErr { errHTTPCode :: Int

17+ { errHTTPCode :: Int

17− , errReasonPhrase :: String

18+ , errReasonPhrase :: String

18− , errBody :: LBS.ByteString

19+ , errBody :: LBS.ByteString

19− , errHeaders :: [HTTP.Header]

20+ , errHeaders :: [HTTP.Header]

21+ }

20− } deriving (Show, Eq, Read, Typeable)

22+ deriving (Show, Eq, Read, Typeable)

21

23

22−instance Exception ServantErr

24+instance Exception ServerError

23

25

24−responseServantErr :: ServantErr -> Response

26+responseServerError :: ServerError -> Response

25−responseServantErr ServantErr{..} = responseLBS status errHeaders errBody

27+responseServerError ServerError{..} = responseLBS status errHeaders errBody

26 where

28 where

27 status = HTTP.mkStatus errHTTPCode (BS.pack errReasonPhrase)

29 status = HTTP.mkStatus errHTTPCode (BS.pack errReasonPhrase)

28

30

@@ -33,8 +35,8 @@ responseServantErr ServantErr{..} = responseLBS status errHeaders errBody

33-- > failingHandler :: Handler ()

35-- > failingHandler :: Handler ()

34-- > failingHandler = throwError $ err300 { errBody = "I can't choose." }

36-- > failingHandler = throwError $ err300 { errBody = "I can't choose." }

35--

37--

36−err300 :: ServantErr

38+err300 :: ServerError

37−err300 = ServantErr { errHTTPCode = 300

39+err300 = ServerError { errHTTPCode = 300

38 , errReasonPhrase = "Multiple Choices"

40 , errReasonPhrase = "Multiple Choices"

39 , errBody = ""

41 , errBody = ""

40 , errHeaders = []

42 , errHeaders = []

@@ -47,8 +49,8 @@ err300 = ServantErr { errHTTPCode = 300

47-- > failingHandler :: Handler ()

49-- > failingHandler :: Handler ()

48-- > failingHandler = throwError err301

50-- > failingHandler = throwError err301

49--

51--

50−err301 :: ServantErr

52+err301 :: ServerError

51−err301 = ServantErr { errHTTPCode = 301

53+err301 = ServerError { errHTTPCode = 301

52 , errReasonPhrase = "Moved Permanently"

54 , errReasonPhrase = "Moved Permanently"

53 , errBody = ""

55 , errBody = ""

54 , errHeaders = []

56 , errHeaders = []

@@ -61,8 +63,8 @@ err301 = ServantErr { errHTTPCode = 301

61-- > failingHandler :: Handler ()

63-- > failingHandler :: Handler ()

62-- > failingHandler = throwError err302

64-- > failingHandler = throwError err302

63--

65--

64−err302 :: ServantErr

66+err302 :: ServerError

65−err302 = ServantErr { errHTTPCode = 302

67+err302 = ServerError { errHTTPCode = 302

66 , errReasonPhrase = "Found"

68 , errReasonPhrase = "Found"

67 , errBody = ""

69 , errBody = ""

68 , errHeaders = []

70 , errHeaders = []

@@ -75,8 +77,8 @@ err302 = ServantErr { errHTTPCode = 302

75-- > failingHandler :: Handler ()

77-- > failingHandler :: Handler ()

76-- > failingHandler = throwError err303

78-- > failingHandler = throwError err303

77--

79--

78−err303 :: ServantErr

80+err303 :: ServerError

79−err303 = ServantErr { errHTTPCode = 303

81+err303 = ServerError { errHTTPCode = 303

80 , errReasonPhrase = "See Other"

82 , errReasonPhrase = "See Other"

81 , errBody = ""

83 , errBody = ""

82 , errHeaders = []

84 , errHeaders = []

@@ -89,8 +91,8 @@ err303 = ServantErr { errHTTPCode = 303

89-- > failingHandler :: Handler ()

91-- > failingHandler :: Handler ()

90-- > failingHandler = throwError err304

92-- > failingHandler = throwError err304

91--

93--

92−err304 :: ServantErr

94+err304 :: ServerError

93−err304 = ServantErr { errHTTPCode = 304

95+err304 = ServerError { errHTTPCode = 304

94 , errReasonPhrase = "Not Modified"

96 , errReasonPhrase = "Not Modified"

95 , errBody = ""

97 , errBody = ""

96 , errHeaders = []

98 , errHeaders = []

@@ -103,8 +105,8 @@ err304 = ServantErr { errHTTPCode = 304

103-- > failingHandler :: Handler ()

105-- > failingHandler :: Handler ()

104-- > failingHandler = throwError err305

106-- > failingHandler = throwError err305

105--

107--

106−err305 :: ServantErr

108+err305 :: ServerError

107−err305 = ServantErr { errHTTPCode = 305

109+err305 = ServerError { errHTTPCode = 305

108 , errReasonPhrase = "Use Proxy"

110 , errReasonPhrase = "Use Proxy"

109 , errBody = ""

111 , errBody = ""

110 , errHeaders = []

112 , errHeaders = []

@@ -117,8 +119,8 @@ err305 = ServantErr { errHTTPCode = 305

117-- > failingHandler :: Handler ()

119-- > failingHandler :: Handler ()

118-- > failingHandler = throwError err307

120-- > failingHandler = throwError err307

119--

121--

120−err307 :: ServantErr

122+err307 :: ServerError

121−err307 = ServantErr { errHTTPCode = 307

123+err307 = ServerError { errHTTPCode = 307

122 , errReasonPhrase = "Temporary Redirect"

124 , errReasonPhrase = "Temporary Redirect"

123 , errBody = ""

125 , errBody = ""

124 , errHeaders = []

126 , errHeaders = []

@@ -131,8 +133,8 @@ err307 = ServantErr { errHTTPCode = 307

131-- > failingHandler :: Handler ()

133-- > failingHandler :: Handler ()

132-- > failingHandler = throwError $ err400 { errBody = "Your request makes no sense to me." }

134-- > failingHandler = throwError $ err400 { errBody = "Your request makes no sense to me." }

133--

135--

134−err400 :: ServantErr

136+err400 :: ServerError

135−err400 = ServantErr { errHTTPCode = 400

137+err400 = ServerError { errHTTPCode = 400

136 , errReasonPhrase = "Bad Request"

138 , errReasonPhrase = "Bad Request"

137 , errBody = ""

139 , errBody = ""

138 , errHeaders = []

140 , errHeaders = []

@@ -145,8 +147,8 @@ err400 = ServantErr { errHTTPCode = 400

145-- > failingHandler :: Handler ()

147-- > failingHandler :: Handler ()

146-- > failingHandler = throwError $ err401 { errBody = "Your credentials are invalid." }

148-- > failingHandler = throwError $ err401 { errBody = "Your credentials are invalid." }

147--

149--

148−err401 :: ServantErr

150+err401 :: ServerError

149−err401 = ServantErr { errHTTPCode = 401

151+err401 = ServerError { errHTTPCode = 401

150 , errReasonPhrase = "Unauthorized"

152 , errReasonPhrase = "Unauthorized"

151 , errBody = ""

153 , errBody = ""

152 , errHeaders = []

154 , errHeaders = []

@@ -159,8 +161,8 @@ err401 = ServantErr { errHTTPCode = 401

159-- > failingHandler :: Handler ()

161-- > failingHandler :: Handler ()

160-- > failingHandler = throwError $ err402 { errBody = "You have 0 credits. Please give me $$$." }

162-- > failingHandler = throwError $ err402 { errBody = "You have 0 credits. Please give me $$$." }

161--

163--

162−err402 :: ServantErr

164+err402 :: ServerError

163−err402 = ServantErr { errHTTPCode = 402

165+err402 = ServerError { errHTTPCode = 402

164 , errReasonPhrase = "Payment Required"

166 , errReasonPhrase = "Payment Required"

165 , errBody = ""

167 , errBody = ""

166 , errHeaders = []

168 , errHeaders = []

@@ -173,8 +175,8 @@ err402 = ServantErr { errHTTPCode = 402

173-- > failingHandler :: Handler ()

175-- > failingHandler :: Handler ()

174-- > failingHandler = throwError $ err403 { errBody = "Please login first." }

176-- > failingHandler = throwError $ err403 { errBody = "Please login first." }

175--

177--

176−err403 :: ServantErr

178+err403 :: ServerError

177−err403 = ServantErr { errHTTPCode = 403

179+err403 = ServerError { errHTTPCode = 403

178 , errReasonPhrase = "Forbidden"

180 , errReasonPhrase = "Forbidden"

179 , errBody = ""

181 , errBody = ""

180 , errHeaders = []

182 , errHeaders = []

@@ -185,10 +187,10 @@ err403 = ServantErr { errHTTPCode = 403

185-- Example:

187-- Example:

186--

188--

187-- > failingHandler :: Handler ()

189-- > failingHandler :: Handler ()

188−-- > failingHandler = throwError $ err404 { errBody = "(╯°□°）╯︵ ┻━┻)." }

190+-- > failingHandler = throwError $ err404 { errBody = "Are you lost?" }

189--

191--

190−err404 :: ServantErr

192+err404 :: ServerError

191−err404 = ServantErr { errHTTPCode = 404

193+err404 = ServerError { errHTTPCode = 404

192 , errReasonPhrase = "Not Found"

194 , errReasonPhrase = "Not Found"

193 , errBody = ""

195 , errBody = ""

194 , errHeaders = []

196 , errHeaders = []

@@ -201,8 +203,8 @@ err404 = ServantErr { errHTTPCode = 404

201-- > failingHandler :: Handler ()

203-- > failingHandler :: Handler ()

202-- > failingHandler = throwError $ err405 { errBody = "Your account privileges does not allow for this. Please pay $$$." }

204-- > failingHandler = throwError $ err405 { errBody = "Your account privileges does not allow for this. Please pay $$$." }

203--

205--

204−err405 :: ServantErr

206+err405 :: ServerError

205−err405 = ServantErr { errHTTPCode = 405

207+err405 = ServerError { errHTTPCode = 405

206 , errReasonPhrase = "Method Not Allowed"

208 , errReasonPhrase = "Method Not Allowed"

207 , errBody = ""

209 , errBody = ""

208 , errHeaders = []

210 , errHeaders = []

@@ -215,8 +217,8 @@ err405 = ServantErr { errHTTPCode = 405

215-- > failingHandler :: Handler ()

217-- > failingHandler :: Handler ()

216-- > failingHandler = throwError err406

218-- > failingHandler = throwError err406

217--

219--

218−err406 :: ServantErr

220+err406 :: ServerError

219−err406 = ServantErr { errHTTPCode = 406

221+err406 = ServerError { errHTTPCode = 406

220 , errReasonPhrase = "Not Acceptable"

222 , errReasonPhrase = "Not Acceptable"

221 , errBody = ""

223 , errBody = ""

222 , errHeaders = []

224 , errHeaders = []

@@ -229,8 +231,8 @@ err406 = ServantErr { errHTTPCode = 406

229-- > failingHandler :: Handler ()

231-- > failingHandler :: Handler ()

230-- > failingHandler = throwError err407

232-- > failingHandler = throwError err407

231--

233--

232−err407 :: ServantErr

234+err407 :: ServerError

233−err407 = ServantErr { errHTTPCode = 407

235+err407 = ServerError { errHTTPCode = 407

234 , errReasonPhrase = "Proxy Authentication Required"

236 , errReasonPhrase = "Proxy Authentication Required"

235 , errBody = ""

237 , errBody = ""

236 , errHeaders = []

238 , errHeaders = []

@@ -243,8 +245,8 @@ err407 = ServantErr { errHTTPCode = 407

243-- > failingHandler :: Handler ()

245-- > failingHandler :: Handler ()

244-- > failingHandler = throwError $ err409 { errBody = "Transaction conflicts with 59879cb56c7c159231eeacdd503d755f7e835f74" }

246-- > failingHandler = throwError $ err409 { errBody = "Transaction conflicts with 59879cb56c7c159231eeacdd503d755f7e835f74" }

245--

247--

246−err409 :: ServantErr

248+err409 :: ServerError

247−err409 = ServantErr { errHTTPCode = 409

249+err409 = ServerError { errHTTPCode = 409

248 , errReasonPhrase = "Conflict"

250 , errReasonPhrase = "Conflict"

249 , errBody = ""

251 , errBody = ""

250 , errHeaders = []

252 , errHeaders = []

@@ -257,8 +259,8 @@ err409 = ServantErr { errHTTPCode = 409

257-- > failingHandler :: Handler ()

259-- > failingHandler :: Handler ()

258-- > failingHandler = throwError $ err410 { errBody = "I know it was here at some point, but.. I blame bad luck." }

260-- > failingHandler = throwError $ err410 { errBody = "I know it was here at some point, but.. I blame bad luck." }

259--

261--

260−err410 :: ServantErr

262+err410 :: ServerError

261−err410 = ServantErr { errHTTPCode = 410

263+err410 = ServerError { errHTTPCode = 410

262 , errReasonPhrase = "Gone"

264 , errReasonPhrase = "Gone"

263 , errBody = ""

265 , errBody = ""

264 , errHeaders = []

266 , errHeaders = []

@@ -271,8 +273,8 @@ err410 = ServantErr { errHTTPCode = 410

271-- > failingHandler :: Handler ()

273-- > failingHandler :: Handler ()

272-- > failingHandler = throwError err411

274-- > failingHandler = throwError err411

273--

275--

274−err411 :: ServantErr

276+err411 :: ServerError

275−err411 = ServantErr { errHTTPCode = 411

277+err411 = ServerError { errHTTPCode = 411

276 , errReasonPhrase = "Length Required"

278 , errReasonPhrase = "Length Required"

277 , errBody = ""

279 , errBody = ""

278 , errHeaders = []

280 , errHeaders = []

@@ -285,8 +287,8 @@ err411 = ServantErr { errHTTPCode = 411

285-- > failingHandler :: Handler ()

287-- > failingHandler :: Handler ()

286-- > failingHandler = throwError $ err412 { errBody = "Precondition fail: x < 42 && y > 57" }

288-- > failingHandler = throwError $ err412 { errBody = "Precondition fail: x < 42 && y > 57" }

287--

289--

288−err412 :: ServantErr

290+err412 :: ServerError

289−err412 = ServantErr { errHTTPCode = 412

291+err412 = ServerError { errHTTPCode = 412

290 , errReasonPhrase = "Precondition Failed"

292 , errReasonPhrase = "Precondition Failed"

291 , errBody = ""

293 , errBody = ""

292 , errHeaders = []

294 , errHeaders = []

@@ -299,8 +301,8 @@ err412 = ServantErr { errHTTPCode = 412

299-- > failingHandler :: Handler ()

301-- > failingHandler :: Handler ()

300-- > failingHandler = throwError $ err413 { errBody = "Request exceeded 64k." }

302-- > failingHandler = throwError $ err413 { errBody = "Request exceeded 64k." }

301--

303--

302−err413 :: ServantErr

304+err413 :: ServerError

303−err413 = ServantErr { errHTTPCode = 413

305+err413 = ServerError { errHTTPCode = 413

304 , errReasonPhrase = "Request Entity Too Large"

306 , errReasonPhrase = "Request Entity Too Large"

305 , errBody = ""

307 , errBody = ""

306 , errHeaders = []

308 , errHeaders = []

@@ -313,8 +315,8 @@ err413 = ServantErr { errHTTPCode = 413

313-- > failingHandler :: Handler ()

315-- > failingHandler :: Handler ()

314-- > failingHandler = throwError $ err414 { errBody = "Maximum length is 64." }

316-- > failingHandler = throwError $ err414 { errBody = "Maximum length is 64." }

315--

317--

316−err414 :: ServantErr

318+err414 :: ServerError

317−err414 = ServantErr { errHTTPCode = 414

319+err414 = ServerError { errHTTPCode = 414

318 , errReasonPhrase = "Request-URI Too Large"

320 , errReasonPhrase = "Request-URI Too Large"

319 , errBody = ""

321 , errBody = ""

320 , errHeaders = []

322 , errHeaders = []

@@ -327,8 +329,8 @@ err414 = ServantErr { errHTTPCode = 414

327-- > failingHandler :: Handler ()

329-- > failingHandler :: Handler ()

328-- > failingHandler = throwError $ err415 { errBody = "Supported media types: gif, png" }

330-- > failingHandler = throwError $ err415 { errBody = "Supported media types: gif, png" }

329--

331--

330−err415 :: ServantErr

332+err415 :: ServerError

331−err415 = ServantErr { errHTTPCode = 415

333+err415 = ServerError { errHTTPCode = 415

332 , errReasonPhrase = "Unsupported Media Type"

334 , errReasonPhrase = "Unsupported Media Type"

333 , errBody = ""

335 , errBody = ""

334 , errHeaders = []

336 , errHeaders = []

@@ -341,8 +343,8 @@ err415 = ServantErr { errHTTPCode = 415

341-- > failingHandler :: Handler ()

343-- > failingHandler :: Handler ()

342-- > failingHandler = throwError $ err416 { errBody = "Valid range is [0, 424242]." }

344-- > failingHandler = throwError $ err416 { errBody = "Valid range is [0, 424242]." }

343--

345--

344−err416 :: ServantErr

346+err416 :: ServerError

345−err416 = ServantErr { errHTTPCode = 416

347+err416 = ServerError { errHTTPCode = 416

346 , errReasonPhrase = "Request range not satisfiable"

348 , errReasonPhrase = "Request range not satisfiable"

347 , errBody = ""

349 , errBody = ""

348 , errHeaders = []

350 , errHeaders = []

@@ -355,8 +357,8 @@ err416 = ServantErr { errHTTPCode = 416

355-- > failingHandler :: Handler ()

357-- > failingHandler :: Handler ()

356-- > failingHandler = throwError $ err417 { errBody = "I found a quux in the request. This isn't going to work." }

358-- > failingHandler = throwError $ err417 { errBody = "I found a quux in the request. This isn't going to work." }

357--

359--

358−err417 :: ServantErr

360+err417 :: ServerError

359−err417 = ServantErr { errHTTPCode = 417

361+err417 = ServerError { errHTTPCode = 417

360 , errReasonPhrase = "Expectation Failed"

362 , errReasonPhrase = "Expectation Failed"

361 , errBody = ""

363 , errBody = ""

362 , errHeaders = []

364 , errHeaders = []

@@ -369,8 +371,8 @@ err417 = ServantErr { errHTTPCode = 417

369-- > failingHandler :: Handler ()

371-- > failingHandler :: Handler ()

370-- > failingHandler = throwError $ err418 { errBody = "Apologies, this is not a webserver but a teapot." }

372-- > failingHandler = throwError $ err418 { errBody = "Apologies, this is not a webserver but a teapot." }

371--

373--

372−err418 :: ServantErr

374+err418 :: ServerError

373−err418 = ServantErr { errHTTPCode = 418

375+err418 = ServerError { errHTTPCode = 418

374 , errReasonPhrase = "I'm a teapot"

376 , errReasonPhrase = "I'm a teapot"

375 , errBody = ""

377 , errBody = ""

376 , errHeaders = []

378 , errHeaders = []

@@ -383,8 +385,8 @@ err418 = ServantErr { errHTTPCode = 418

383-- > failingHandler :: Handler ()

385-- > failingHandler :: Handler ()

384-- > failingHandler = throwError $ err422 { errBody = "I understood your request, but can't process it." }

386-- > failingHandler = throwError $ err422 { errBody = "I understood your request, but can't process it." }

385--

387--

386−err422 :: ServantErr

388+err422 :: ServerError

387−err422 = ServantErr { errHTTPCode = 422

389+err422 = ServerError { errHTTPCode = 422

388 , errReasonPhrase = "Unprocessable Entity"

390 , errReasonPhrase = "Unprocessable Entity"

389 , errBody = ""

391 , errBody = ""

390 , errHeaders = []

392 , errHeaders = []

@@ -397,8 +399,8 @@ err422 = ServantErr { errHTTPCode = 422

397-- > failingHandler :: Handler ()

399-- > failingHandler :: Handler ()

398-- > failingHandler = throwError $ err500 { errBody = "Exception in module A.B.C:55. Have a great day!" }

400-- > failingHandler = throwError $ err500 { errBody = "Exception in module A.B.C:55. Have a great day!" }

399--

401--

400−err500 :: ServantErr

402+err500 :: ServerError

401−err500 = ServantErr { errHTTPCode = 500

403+err500 = ServerError { errHTTPCode = 500

402 , errReasonPhrase = "Internal Server Error"

404 , errReasonPhrase = "Internal Server Error"

403 , errBody = ""

405 , errBody = ""

404 , errHeaders = []

406 , errHeaders = []

@@ -411,8 +413,8 @@ err500 = ServantErr { errHTTPCode = 500

411-- > failingHandler :: Handler ()

413-- > failingHandler :: Handler ()

412-- > failingHandler = throwError $ err501 { errBody = "/v1/foo is not supported with quux in the request." }

414-- > failingHandler = throwError $ err501 { errBody = "/v1/foo is not supported with quux in the request." }

413--

415--

414−err501 :: ServantErr

416+err501 :: ServerError

415−err501 = ServantErr { errHTTPCode = 501

417+err501 = ServerError { errHTTPCode = 501

416 , errReasonPhrase = "Not Implemented"

418 , errReasonPhrase = "Not Implemented"

417 , errBody = ""

419 , errBody = ""

418 , errHeaders = []

420 , errHeaders = []

@@ -425,8 +427,8 @@ err501 = ServantErr { errHTTPCode = 501

425-- > failingHandler :: Handler ()

427-- > failingHandler :: Handler ()

426-- > failingHandler = throwError $ err502 { errBody = "Tried gateway foo, bar, and baz. None responded." }

428-- > failingHandler = throwError $ err502 { errBody = "Tried gateway foo, bar, and baz. None responded." }

427--

429--

428−err502 :: ServantErr

430+err502 :: ServerError

429−err502 = ServantErr { errHTTPCode = 502

431+err502 = ServerError { errHTTPCode = 502

430 , errReasonPhrase = "Bad Gateway"

432 , errReasonPhrase = "Bad Gateway"

431 , errBody = ""

433 , errBody = ""

432 , errHeaders = []

434 , errHeaders = []

@@ -439,8 +441,8 @@ err502 = ServantErr { errHTTPCode = 502

439-- > failingHandler :: Handler ()

441-- > failingHandler :: Handler ()

440-- > failingHandler = throwError $ err503 { errBody = "We're rewriting in PHP." }

442-- > failingHandler = throwError $ err503 { errBody = "We're rewriting in PHP." }

441--

443--

442−err503 :: ServantErr

444+err503 :: ServerError

443−err503 = ServantErr { errHTTPCode = 503

445+err503 = ServerError { errHTTPCode = 503

444 , errReasonPhrase = "Service Unavailable"

446 , errReasonPhrase = "Service Unavailable"

445 , errBody = ""

447 , errBody = ""

446 , errHeaders = []

448 , errHeaders = []

@@ -453,8 +455,8 @@ err503 = ServantErr { errHTTPCode = 503

453-- > failingHandler :: Handler ()

455-- > failingHandler :: Handler ()

454-- > failingHandler = throwError $ err504 { errBody = "Backend foobar did not respond in 5 seconds." }

456-- > failingHandler = throwError $ err504 { errBody = "Backend foobar did not respond in 5 seconds." }

455--

457--

456−err504 :: ServantErr

458+err504 :: ServerError

457−err504 = ServantErr { errHTTPCode = 504

459+err504 = ServerError { errHTTPCode = 504

458 , errReasonPhrase = "Gateway Time-out"

460 , errReasonPhrase = "Gateway Time-out"

459 , errBody = ""

461 , errBody = ""

460 , errHeaders = []

462 , errHeaders = []

@@ -467,8 +469,8 @@ err504 = ServantErr { errHTTPCode = 504

467-- > failingHandler :: Handler ()

469-- > failingHandler :: Handler ()

468-- > failingHandler = throwError $ err505 { errBody = "I support HTTP/4.0 only." }

470-- > failingHandler = throwError $ err505 { errBody = "I support HTTP/4.0 only." }

469--

471--

470−err505 :: ServantErr

472+err505 :: ServerError

471−err505 = ServantErr { errHTTPCode = 505

473+err505 = ServerError { errHTTPCode = 505

472 , errReasonPhrase = "HTTP Version not supported"

474 , errReasonPhrase = "HTTP Version not supported"

473 , errBody = ""

475 , errBody = ""

474 , errHeaders = []

476 , errHeaders = []

servant-server/src/Servant/Server/UVerb.hsnew file+116

@@ -0,0 +1,116 @@

1+{-# LANGUAGE ConstraintKinds #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE FlexibleContexts #-}

4+{-# LANGUAGE FlexibleInstances #-}

5+{-# LANGUAGE InstanceSigs #-}

6+{-# LANGUAGE KindSignatures #-}

7+{-# LANGUAGE MultiParamTypeClasses #-}

8+{-# LANGUAGE OverloadedStrings #-}

9+{-# LANGUAGE RankNTypes #-}

10+{-# LANGUAGE ScopedTypeVariables #-}

11+{-# LANGUAGE TypeApplications #-}

12+{-# LANGUAGE TypeFamilies #-}

13+{-# LANGUAGE TypeOperators #-}

14+{-# LANGUAGE UndecidableInstances #-}

15+

16+{-# OPTIONS_GHC -Wno-orphans #-}

17+{-# OPTIONS_GHC -Wno-redundant-constraints #-}

18+

19+module Servant.Server.UVerb

20+ ( respond,

21+ IsServerResource,

22+ )

23+where

24+

25+import qualified Data.ByteString as B

26+import Data.Proxy (Proxy (Proxy))

27+import Data.SOP (I (I))

28+import Data.SOP.Constraint (All, And)

29+import Data.String.Conversions (LBS, cs)

30+import Network.HTTP.Types (Status, HeaderName, hContentType)

31+import Network.Wai (responseLBS, Request)

32+import Servant.API (ReflectMethod, reflectMethod)

33+import Servant.API.ContentTypes (AllCTRender (handleAcceptH), AllMime)

34+import Servant.API.ResponseHeaders (GetHeaders (..), Headers (..))

35+import Servant.API.UVerb (HasStatus, IsMember, Statuses, UVerb, Union, Unique, WithStatus (..), foldMapUnion, inject, statusOf)

36+import Servant.Server.Internal (Context, Delayed, Handler, HasServer (..), RouteResult (FailFatal, Route), Router, Server, ServerT, acceptCheck, addAcceptCheck, addMethodCheck, allowedMethodHead, err406, getAcceptHeader, leafRouter, methodCheck, runAction)

37+

38+

39+-- | 'return' for 'UVerb' handlers. Takes a value of any of the members of the open union,

40+-- and will construct a union value in an 'Applicative' (eg. 'Server').

41+respond ::

42+ forall (x :: *) (xs :: [*]) (f :: * -> *).

43+ (Applicative f, HasStatus x, IsMember x xs) =>

44+ x ->

45+ f (Union xs)

46+respond = pure . inject . I

47+

48+class IsServerResource (cts :: [*]) a where

49+ resourceResponse :: Request -> Proxy cts -> a -> Maybe (LBS, LBS)

50+ resourceHeaders :: Proxy cts -> a -> [(HeaderName, B.ByteString)]

51+

52+instance {-# OVERLAPPABLE #-} AllCTRender cts a

53+ => IsServerResource cts a where

54+ resourceResponse request p res = handleAcceptH p (getAcceptHeader request) res

55+ resourceHeaders _ _ = []

56+

57+instance {-# OVERLAPPING #-} (IsServerResource cts a, GetHeaders (Headers h a))

58+ => IsServerResource cts (Headers h a) where

59+ resourceResponse request p res = resourceResponse request p (getResponse res)

60+ resourceHeaders cts res = getHeaders res ++ resourceHeaders cts (getResponse res)

61+

62+instance {-# OVERLAPPING #-} IsServerResource cts a

63+ => IsServerResource cts (WithStatus n a) where

64+ resourceResponse request p (WithStatus x) = resourceResponse request p x

65+ resourceHeaders cts (WithStatus x) = resourceHeaders cts x

66+

67+encodeResource :: forall a cts . (IsServerResource cts a, HasStatus a)

68+ => Request -> Proxy cts -> a

69+ -> (Status, Maybe (LBS, LBS), [(HeaderName, B.ByteString)])

70+encodeResource request cts res = (statusOf (Proxy @a),

71+ resourceResponse request cts res,

72+ resourceHeaders cts res)

73+

74+type IsServerResourceWithStatus cts = IsServerResource cts `And` HasStatus

75+

76+instance

77+ ( ReflectMethod method,

78+ AllMime contentTypes,

79+ All (IsServerResourceWithStatus contentTypes) as,

80+ Unique (Statuses as) -- for consistency with servant-swagger (server would work fine

81+ -- without; client is a bit of a corner case, because it dispatches

82+ -- the parser based on the status code. with this uniqueness

83+ -- constraint it won't have to run more than one parser in weird

84+ -- corner cases.

85+ ) =>

86+ HasServer (UVerb method contentTypes as) context

87+ where

88+ type ServerT (UVerb method contentTypes as) m = m (Union as)

89+

90+ hoistServerWithContext _ _ nt s = nt s

91+

92+ route ::

93+ forall env.

94+ Proxy (UVerb method contentTypes as) ->

95+ Context context ->

96+ Delayed env (Server (UVerb method contentTypes as)) ->

97+ Router env

98+ route _proxy _ctx action = leafRouter route'

99+ where

100+ method = reflectMethod (Proxy @method)

101+ route' env request cont = do

102+ let action' :: Delayed env (Handler (Union as))

103+ action' =

104+ action

105+ `addMethodCheck` methodCheck method request

106+ `addAcceptCheck` acceptCheck (Proxy @contentTypes) (getAcceptHeader request)

107+

108+ runAction action' env request cont $ \(output :: Union as) -> do

109+ let cts = Proxy @contentTypes

110+ pickResource :: Union as -> (Status, Maybe (LBS, LBS), [(HeaderName, B.ByteString)])

111+ pickResource = foldMapUnion (Proxy @(IsServerResourceWithStatus contentTypes)) (encodeResource request cts)

112+ case pickResource output of

113+ (_, Nothing, _) -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does

114+ (status, Just (contentT, body), headers) ->

115+ let bdy = if allowedMethodHead method request then "" else body

116+ in Route $ responseLBS status ((hContentType, cs contentT) : headers) bdy

servant-server/test/Servant/Server/ErrorSpec.hs+58−2

@@ -12,9 +12,9 @@ import Data.Aeson

12 (encode)

12 (encode)

13import qualified Data.ByteString.Char8 as BC

13import qualified Data.ByteString.Char8 as BC

14import qualified Data.ByteString.Lazy.Char8 as BCL

14import qualified Data.ByteString.Lazy.Char8 as BCL

15−import Data.Monoid

16− ((<>))

17import Data.Proxy

15import Data.Proxy

16+import Data.String.Conversions

17+ (cs)

18import Network.HTTP.Types

18import Network.HTTP.Types

19 (hAccept, hAuthorization, hContentType, methodGet, methodPost,

19 (hAccept, hAuthorization, hContentType, methodGet, methodPost,

20 methodPut)

20 methodPut)

@@ -31,6 +31,7 @@ spec = describe "HTTP Errors" $ do

31 prioErrorsSpec

31 prioErrorsSpec

32 errorRetrySpec

32 errorRetrySpec

33 errorChoiceSpec

33 errorChoiceSpec

34+ customFormattersSpec

34

35

35-- * Auth machinery (reused throughout)

36-- * Auth machinery (reused throughout)

36

37

@@ -293,6 +294,61 @@ errorChoiceSpec = describe "Multiple handlers return errors"

293 `shouldRespondWith` 415

294 `shouldRespondWith` 415

294

295

295

296

297+-- }}}

298+------------------------------------------------------------------------------

299+-- * Custom errors {{{

300+

301+customFormatter :: ErrorFormatter

302+customFormatter _ _ err = err400 { errBody = "CUSTOM! " <> cs err }

303+

304+customFormatters :: ErrorFormatters

305+customFormatters = defaultErrorFormatters

306+ { bodyParserErrorFormatter = customFormatter

307+ , urlParseErrorFormatter = customFormatter

308+ , notFoundErrorFormatter = const $ err404 { errBody = "CUSTOM! Not Found" }

309+ }

310+

311+type CustomFormatterAPI

312+ = "query" :> QueryParam' '[Required, Strict] "param" Int :> Get '[PlainText] String

313+ :<|> "capture" :> Capture "cap" Bool :> Get '[PlainText] String

314+ :<|> "body" :> ReqBody '[JSON] Int :> Post '[PlainText] String

315+

316+customFormatterAPI :: Proxy CustomFormatterAPI

317+customFormatterAPI = Proxy

318+

319+customFormatterServer :: Server CustomFormatterAPI

320+customFormatterServer = (\_ -> return "query")

321+ :<|> (\_ -> return "capture")

322+ :<|> (\_ -> return "body")

323+

324+customFormattersSpec :: Spec

325+customFormattersSpec = describe "Custom errors from combinators"

326+ $ with (return $ serveWithContext customFormatterAPI (customFormatters :. EmptyContext) customFormatterServer) $ do

327+

328+ let startsWithCustom = ResponseMatcher

329+ { matchStatus = 400

330+ , matchHeaders = []

331+ , matchBody = MatchBody $ \_ body -> if "CUSTOM!" `BCL.isPrefixOf` body

332+ then Nothing

333+ else Just $ show body <> " does not start with \"CUSTOM!\""

334+ }

335+

336+ it "formats query parse error" $ do

337+ request methodGet "query?param=false" [] ""

338+ `shouldRespondWith` startsWithCustom

339+

340+ it "formats query parse error with missing param" $ do

341+ request methodGet "query" [] ""

342+ `shouldRespondWith` startsWithCustom

343+

344+ it "formats capture parse error" $ do

345+ request methodGet "capture/42" [] ""

346+ `shouldRespondWith` startsWithCustom

347+

348+ it "formats body parse error" $ do

349+ request methodPost "body" [(hContentType, "application/json")] "foo"

350+ `shouldRespondWith` startsWithCustom

351+

296-- }}}

352-- }}}

297------------------------------------------------------------------------------

353------------------------------------------------------------------------------

298-- * Instances {{{

354-- * Instances {{{

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

@@ -1,5 +1,5 @@

1{-# LANGUAGE DataKinds #-}

1{-# LANGUAGE DataKinds #-}

2−{-# OPTIONS_GHC -fdefer-type-errors -Wwarn #-}

2+{-# OPTIONS_GHC -fdefer-type-errors -Wwarn -Wno-deferred-type-errors #-}

3module Servant.Server.Internal.ContextSpec (spec) where

3module Servant.Server.Internal.ContextSpec (spec) where

4

4

5import Data.Proxy

5import Data.Proxy

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

@@ -11,7 +11,7 @@ module Servant.Server.Internal.RoutingApplicationSpec (spec) where

11import Prelude ()

11import Prelude ()

12import Prelude.Compat

12import Prelude.Compat

13

13

14−import Control.Exception hiding

14+import Control.Exception hiding

15 (Handler)

15 (Handler)

16import Control.Monad.IO.Class

16import Control.Monad.IO.Class

17import Control.Monad.Trans.Resource

17import Control.Monad.Trans.Resource

@@ -23,12 +23,12 @@ import GHC.TypeLits

23import Network.Wai

23import Network.Wai

24 (defaultRequest)

24 (defaultRequest)

25import Servant

25import Servant

26−import Servant.Server.Internal.RoutingApplication

26+import Servant.Server.Internal

27import Test.Hspec

27import Test.Hspec

28import Test.Hspec.Wai

28import Test.Hspec.Wai

29 (request, shouldRespondWith, with)

29 (request, shouldRespondWith, with)

30

30

31−import qualified Data.Text as T

31+import qualified Data.Text as T

32

32

33import System.IO.Unsafe

33import System.IO.Unsafe

34 (unsafePerformIO)

34 (unsafePerformIO)

servant-server/test/Servant/Server/RouterSpec.hs+129−8

@@ -9,7 +9,9 @@ import Control.Monad

9import Data.Proxy

9import Data.Proxy

10 (Proxy (..))

10 (Proxy (..))

11import Data.Text

11import Data.Text

12− (unpack)

12+ (Text, unpack)

13+import Data.Typeable

14+ (typeRep)

13import Network.HTTP.Types

15import Network.HTTP.Types

14 (Status (..))

16 (Status (..))

15import Network.Wai

17import Network.Wai

@@ -27,12 +29,13 @@ spec :: Spec

27spec = describe "Servant.Server.Internal.Router" $ do

29spec = describe "Servant.Server.Internal.Router" $ do

28 routerSpec

30 routerSpec

29 distributivitySpec

31 distributivitySpec

32+ serverLayoutSpec

30

33

31routerSpec :: Spec

34routerSpec :: Spec

32routerSpec = do

35routerSpec = do

33 describe "tweakResponse" $ do

36 describe "tweakResponse" $ do

34 let app' :: Application

37 let app' :: Application

35− app' = toApplication $ runRouter router'

38+ app' = toApplication $ runRouter (const err404) router'

36

39

37 router', router :: Router ()

40 router', router :: Router ()

38 router' = tweakResponse (fmap twk) router

41 router' = tweakResponse (fmap twk) router

@@ -48,10 +51,10 @@ routerSpec = do

48

51

49 describe "runRouter" $ do

52 describe "runRouter" $ do

50 let toApp :: Router () -> Application

53 let toApp :: Router () -> Application

51− toApp = toApplication . runRouter

54+ toApp = toApplication . runRouter (const err404)

52

55

53 cap :: Router ()

56 cap :: Router ()

54− cap = CaptureRouter $

57+ cap = CaptureRouter [hint] $

55 let delayed = addCapture (emptyDelayed $ Route pure) (const $ delayedFail err400)

58 let delayed = addCapture (emptyDelayed $ Route pure) (const $ delayedFail err400)

56 in leafRouter

59 in leafRouter

57 $ \env req res ->

60 $ \env req res ->

@@ -59,6 +62,9 @@ routerSpec = do

59 . const

62 . const

60 $ Route success

63 $ Route success

61

64

65+ hint :: CaptureHint

66+ hint = CaptureHint "anything" $ typeRep (Proxy :: Proxy ())

67+

62 router :: Router ()

68 router :: Router ()

63 router = leafRouter (\_ _ res -> res $ Route success)

69 router = leafRouter (\_ _ res -> res $ Route success)

64 `Choice` cap

70 `Choice` cap

@@ -98,12 +104,30 @@ distributivitySpec =

98 it "properly handles mixing static paths at different levels" $ do

104 it "properly handles mixing static paths at different levels" $ do

99 level `shouldHaveSameStructureAs` levelRef

105 level `shouldHaveSameStructureAs` levelRef

100

106

107+serverLayoutSpec :: Spec

108+serverLayoutSpec =

109+ describe "serverLayout" $ do

110+ it "correctly represents the example API" $ do

111+ exampleLayout `shouldHaveLayout` expectedExampleLayout

112+ it "aggregates capture hints when different" $ do

113+ captureDifferentTypes `shouldHaveLayout` expectedCaptureDifferentTypes

114+ it "nubs capture hints when equal" $ do

115+ captureSameType `shouldHaveLayout` expectedCaptureSameType

116+ it "properly displays CaptureAll hints" $ do

117+ captureAllLayout `shouldHaveLayout` expectedCaptureAllLayout

118+

101shouldHaveSameStructureAs ::

119shouldHaveSameStructureAs ::

102 (HasServer api1 '[], HasServer api2 '[]) => Proxy api1 -> Proxy api2 -> Expectation

120 (HasServer api1 '[], HasServer api2 '[]) => Proxy api1 -> Proxy api2 -> Expectation

103shouldHaveSameStructureAs p1 p2 =

121shouldHaveSameStructureAs p1 p2 =

104 unless (sameStructure (makeTrivialRouter p1) (makeTrivialRouter p2)) $

122 unless (sameStructure (makeTrivialRouter p1) (makeTrivialRouter p2)) $

105 expectationFailure ("expected:\n" ++ unpack (layout p2) ++ "\nbut got:\n" ++ unpack (layout p1))

123 expectationFailure ("expected:\n" ++ unpack (layout p2) ++ "\nbut got:\n" ++ unpack (layout p1))

106

124

125+shouldHaveLayout ::

126+ (HasServer api '[]) => Proxy api -> Text -> Expectation

127+shouldHaveLayout p l =

128+ unless (routerLayout (makeTrivialRouter p) == l) $

129+ expectationFailure ("expected:\n" ++ unpack l ++ "\nbut got:\n" ++ unpack (layout p))

130+

107makeTrivialRouter :: (HasServer layout '[]) => Proxy layout -> Router ()

131makeTrivialRouter :: (HasServer layout '[]) => Proxy layout -> Router ()

108makeTrivialRouter p =

132makeTrivialRouter p =

109 route p EmptyContext (emptyDelayed (FailFatal err501))

133 route p EmptyContext (emptyDelayed (FailFatal err501))

@@ -144,12 +168,12 @@ staticRef = Proxy

144-- structure:

168-- structure:

145

169

146type Dynamic =

170type Dynamic =

147− "a" :> Capture "foo" Int :> "b" :> End

171+ "a" :> Capture "foo" Int :> "b" :> End

148− :<|> "a" :> Capture "bar" Bool :> "c" :> End

172+ :<|> "a" :> Capture "foo" Int :> "c" :> End

149− :<|> "a" :> Capture "baz" Char :> "d" :> End

173+ :<|> "a" :> Capture "foo" Int :> "d" :> End

150

174

151type DynamicRef =

175type DynamicRef =

152− "a" :> Capture "anything" () :>

176+ "a" :> Capture "foo" Int :>

153 ("b" :> End :<|> "c" :> End :<|> "d" :> End)

177 ("b" :> End :<|> "c" :> End :<|> "d" :> End)

154

178

155dynamic :: Proxy Dynamic

179dynamic :: Proxy Dynamic

@@ -339,3 +363,100 @@ level = Proxy

339

363

340levelRef :: Proxy LevelRef

364levelRef :: Proxy LevelRef

341levelRef = Proxy

365levelRef = Proxy

366+

367+-- The example API for the 'layout' function.

368+-- Should get factorized by the 'choice' smart constructor.

369+type ExampleLayout =

370+ "a" :> "d" :> Get '[JSON] NoContent

371+ :<|> "b" :> Capture "x" Int :> Get '[JSON] Bool

372+ :<|> "c" :> Put '[JSON] Bool

373+ :<|> "a" :> "e" :> Get '[JSON] Int

374+ :<|> "b" :> Capture "x" Int :> Put '[JSON] Bool

375+ :<|> Raw

376+

377+exampleLayout :: Proxy ExampleLayout

378+exampleLayout = Proxy

379+

380+-- The expected representation of the example API layout

381+--

382+expectedExampleLayout :: Text

383+expectedExampleLayout =

384+ "/\n\

385+ \├─ a/\n\

386+ \│ ├─ d/\n\

387+ \│ │ └─•\n\

388+ \│ └─ e/\n\

389+ \│ └─•\n\

390+ \├─ b/\n\

391+ \│ └─ <x::Int>/\n\

392+ \│ ├─•\n\

393+ \│ ┆\n\

394+ \│ └─•\n\

395+ \├─ c/\n\

396+ \│ └─•\n\

397+ \┆\n\

398+ \└─ <raw>\n"

399+

400+-- A capture API with all capture types being the same

401+--

402+type CaptureSameType =

403+ "a" :> Capture "foo" Int :> "b" :> End

404+ :<|> "a" :> Capture "foo" Int :> "c" :> End

405+ :<|> "a" :> Capture "foo" Int :> "d" :> End

406+

407+captureSameType :: Proxy CaptureSameType

408+captureSameType = Proxy

409+

410+-- The expected representation of the CaptureSameType API layout.

411+--

412+expectedCaptureSameType :: Text

413+expectedCaptureSameType =

414+ "/\n\

415+ \└─ a/\n\

416+ \ └─ <foo::Int>/\n\

417+ \ ├─ b/\n\

418+ \ │ └─•\n\

419+ \ ├─ c/\n\

420+ \ │ └─•\n\

421+ \ └─ d/\n\

422+ \ └─•\n"

423+

424+-- A capture API capturing different types

425+--

426+type CaptureDifferentTypes =

427+ "a" :> Capture "foo" Int :> "b" :> End

428+ :<|> "a" :> Capture "bar" Bool :> "c" :> End

429+ :<|> "a" :> Capture "baz" Char :> "d" :> End

430+

431+captureDifferentTypes :: Proxy CaptureDifferentTypes

432+captureDifferentTypes = Proxy

433+

434+-- The expected representation of the CaptureDifferentTypes API layout.

435+--

436+expectedCaptureDifferentTypes :: Text

437+expectedCaptureDifferentTypes =

438+ "/\n\

439+ \└─ a/\n\

440+ \ └─ <foo::Int|bar::Bool|baz::Char>/\n\

441+ \ ├─ b/\n\

442+ \ │ └─•\n\

443+ \ ├─ c/\n\

444+ \ │ └─•\n\

445+ \ └─ d/\n\

446+ \ └─•\n"

447+

448+-- An API with a CaptureAll part

449+

450+type CaptureAllLayout = "a" :> CaptureAll "foos" Int :> End

451+

452+captureAllLayout :: Proxy CaptureAllLayout

453+captureAllLayout = Proxy

454+

455+-- The expected representation of the CaptureAllLayout API.

456+--

457+expectedCaptureAllLayout :: Text

458+expectedCaptureAllLayout =

459+ "/\n\

460+ \└─ a/\n\

461+ \ └─ <foos::[Int]>/\n\

462+ \ └─•\n"

servant-server/test/Servant/ServerSpec.hs+292−127

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

1−{-# LANGUAGE DataKinds #-}

1+{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE DeriveGeneric #-}

2+{-# LANGUAGE DeriveGeneric #-}

3−{-# LANGUAGE FlexibleContexts #-}

3+{-# LANGUAGE FlexibleContexts #-}

4−{-# LANGUAGE FlexibleInstances #-}

4+{-# LANGUAGE FlexibleInstances #-}

5−{-# LANGUAGE OverloadedStrings #-}

5+{-# LANGUAGE OverloadedStrings #-}

6−{-# LANGUAGE PolyKinds #-}

6+{-# LANGUAGE PolyKinds #-}

7−{-# LANGUAGE ScopedTypeVariables #-}

7+{-# LANGUAGE ScopedTypeVariables #-}

8−{-# LANGUAGE TypeFamilies #-}

8+{-# LANGUAGE TypeFamilies #-}

9−{-# LANGUAGE TypeOperators #-}

9+{-# LANGUAGE TypeOperators #-}

10−{-# LANGUAGE TypeSynonymInstances #-}

10+{-# LANGUAGE TypeApplications #-}

11{-# OPTIONS_GHC -freduction-depth=100 #-}

11{-# OPTIONS_GHC -freduction-depth=100 #-}

12

12

13module Servant.ServerSpec where

13module Servant.ServerSpec where

@@ -25,6 +25,8 @@ import qualified Data.ByteString as BS

25import qualified Data.ByteString.Base64 as Base64

25import qualified Data.ByteString.Base64 as Base64

26import Data.Char

26import Data.Char

27 (toUpper)

27 (toUpper)

28+import Data.Maybe

29+ (fromMaybe)

28import Data.Proxy

30import Data.Proxy

29 (Proxy (Proxy))

31 (Proxy (Proxy))

30import Data.String

32import Data.String

@@ -35,26 +37,28 @@ import qualified Data.Text as T

35import GHC.Generics

37import GHC.Generics

36 (Generic)

38 (Generic)

37import Network.HTTP.Types

39import Network.HTTP.Types

38− (Status (..), hAccept, hContentType, imATeapot418,

40+ (QueryItem, Status (..), hAccept, hContentType, imATeapot418,

39 methodDelete, methodGet, methodHead, methodPatch, methodPost,

41 methodDelete, methodGet, methodHead, methodPatch, methodPost,

40 methodPut, ok200, parseQuery)

42 methodPut, ok200, parseQuery)

41import Network.Wai

43import Network.Wai

42− (Application, Request, pathInfo, queryString, rawQueryString,

44+ (Application, Middleware, Request, pathInfo, queryString,

43− requestHeaders, responseLBS)

45+ rawQueryString, requestHeaders, responseLBS)

44import Network.Wai.Test

46import Network.Wai.Test

45 (defaultRequest, request, runSession, simpleBody,

47 (defaultRequest, request, runSession, simpleBody,

46 simpleHeaders, simpleStatus)

48 simpleHeaders, simpleStatus)

47import Servant.API

49import Servant.API

48 ((:<|>) (..), (:>), AuthProtect, BasicAuth,

50 ((:<|>) (..), (:>), AuthProtect, BasicAuth,

49− BasicAuthData (BasicAuthData), Capture, CaptureAll, Delete,

51+ BasicAuthData (BasicAuthData), Capture, Capture', CaptureAll,

52+ Delete, EmptyAPI, Fragment, Get, HasStatus (StatusOf), Header,

50− EmptyAPI, Get, Header, Headers, HttpVersion, IsSecure (..),

53+ Headers, HttpVersion, IsSecure (..), JSON, Lenient,

51− JSON, NoContent (..), NoFraming, OctetStream, Patch,

54+ NoContent (..), NoContentVerb, NoFraming, OctetStream, Patch,

52 PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw,

55 PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw,

53− RemoteHost, ReqBody, SourceIO, StdMethod (..), Stream, Verb,

56+ RemoteHost, ReqBody, SourceIO, StdMethod (..), Stream, Strict,

54− addHeader)

57+ UVerb, Union, Verb, WithStatus (..), addHeader)

55import Servant.Server

58import Servant.Server

56 (Context ((:.), EmptyContext), Handler, Server, Tagged (..),

59 (Context ((:.), EmptyContext), Handler, Server, Tagged (..),

57− emptyServer, err401, err403, err404, serve, serveWithContext)

60+ emptyServer, err401, err403, err404, respond, serve,

61+ serveWithContext)

58import Servant.Test.ComprehensiveAPI

62import Servant.Test.ComprehensiveAPI

59import qualified Servant.Types.SourceT as S

63import qualified Servant.Types.SourceT as S

60import Test.Hspec

64import Test.Hspec

@@ -85,14 +89,17 @@ comprehensiveApiContext = NamedContext EmptyContext :. EmptyContext

85spec :: Spec

89spec :: Spec

86spec = do

90spec = do

87 verbSpec

91 verbSpec

92+ uverbSpec

88 captureSpec

93 captureSpec

89 captureAllSpec

94 captureAllSpec

90 queryParamSpec

95 queryParamSpec

96+ fragmentSpec

91 reqBodySpec

97 reqBodySpec

92 headerSpec

98 headerSpec

93 rawSpec

99 rawSpec

94 alternativeSpec

100 alternativeSpec

95 responseHeadersSpec

101 responseHeadersSpec

102+ uverbResponseHeadersSpec

96 miscCombinatorSpec

103 miscCombinatorSpec

97 basicAuthSpec

104 basicAuthSpec

98 genAuthSpec

105 genAuthSpec

@@ -103,7 +110,7 @@ spec = do

103

110

104type VerbApi method status

111type VerbApi method status

105 = Verb method status '[JSON] Person

112 = Verb method status '[JSON] Person

106− :<|> "noContent" :> Verb method status '[JSON] NoContent

113+ :<|> "noContent" :> NoContentVerb method

107 :<|> "header" :> Verb method status '[JSON] (Headers '[Header "H" Int] Person)

114 :<|> "header" :> Verb method status '[JSON] (Headers '[Header "H" Int] Person)

108 :<|> "headerNC" :> Verb method status '[JSON] (Headers '[Header "H" Int] NoContent)

115 :<|> "headerNC" :> Verb method status '[JSON] (Headers '[Header "H" Int] NoContent)

109 :<|> "accept" :> ( Verb method status '[JSON] Person

116 :<|> "accept" :> ( Verb method status '[JSON] Person

@@ -140,7 +147,7 @@ verbSpec = describe "Servant.API.Verb" $ do

140

147

141 it "returns no content on NoContent" $ do

148 it "returns no content on NoContent" $ do

142 response <- THW.request method "/noContent" [] ""

149 response <- THW.request method "/noContent" [] ""

143− liftIO $ statusCode (simpleStatus response) `shouldBe` status

150+ liftIO $ statusCode (simpleStatus response) `shouldBe` 204

144 liftIO $ simpleBody response `shouldBe` ""

151 liftIO $ simpleBody response `shouldBe` ""

145

152

146 -- HEAD should not return body

153 -- HEAD should not return body

@@ -204,13 +211,27 @@ verbSpec = describe "Servant.API.Verb" $ do

204------------------------------------------------------------------------------

211------------------------------------------------------------------------------

205

212

206type CaptureApi = Capture "legs" Integer :> Get '[JSON] Animal

213type CaptureApi = Capture "legs" Integer :> Get '[JSON] Animal

214+ :<|> "ears" :> Capture' '[Lenient] "ears" Integer :> Get '[JSON] Animal

215+ :<|> "eyes" :> Capture' '[Strict] "eyes" Integer :> Get '[JSON] Animal

207captureApi :: Proxy CaptureApi

216captureApi :: Proxy CaptureApi

208captureApi = Proxy

217captureApi = Proxy

218+

219+captureServer :: Server CaptureApi

220+captureServer = getLegs :<|> getEars :<|> getEyes

209−captureServer :: Integer -> Handler Animal

221+ where getLegs :: Integer -> Handler Animal

210−captureServer legs = case legs of

222+ getLegs legs = case legs of

211− 4 -> return jerry

223+ 4 -> return jerry

212− 2 -> return tweety

224+ 2 -> return tweety

225+ _ -> throwError err404

226+

227+ getEars :: Either String Integer -> Handler Animal

228+ getEars (Left _) = return chimera -- ignore integer parse error, return weird animal

229+ getEars (Right 2) = return jerry

230+ getEars (Right _) = throwError err404

231+

232+ getEyes :: Integer -> Handler Animal

233+ getEyes 2 = return jerry

213− _ -> throwError err404

234+ getEyes _ = throwError err404

214

235

215captureSpec :: Spec

236captureSpec :: Spec

216captureSpec = do

237captureSpec = do

@@ -224,10 +245,21 @@ captureSpec = do

224 it "returns 400 if the decoding fails" $ do

245 it "returns 400 if the decoding fails" $ do

225 get "/notAnInt" `shouldRespondWith` 400

246 get "/notAnInt" `shouldRespondWith` 400

226

247

248+ it "returns an animal if eyes or ears are 2" $ do

249+ get "/ears/2" `shouldRespondWith` 200

250+ get "/eyes/2" `shouldRespondWith` 200

251+

252+ it "returns a weird animal on Lenient Capture" $ do

253+ response <- get "/ears/bla"

254+ liftIO $ decode' (simpleBody response) `shouldBe` Just chimera

255+

256+ it "returns 400 if parsing integer fails on Strict Capture" $ do

257+ get "/eyes/bla" `shouldRespondWith` 400

258+

227 with (return (serve

259 with (return (serve

228 (Proxy :: Proxy (Capture "captured" String :> Raw))

260 (Proxy :: Proxy (Capture "captured" String :> Raw))

229− (\ "captured" -> Tagged $ \request_ respond ->

261+ (\ "captured" -> Tagged $ \request_ sendResponse ->

230− respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do

262+ sendResponse $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do

231 it "strips the captured path snippet from pathInfo" $ do

263 it "strips the captured path snippet from pathInfo" $ do

232 get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String]))

264 get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String]))

233

265

@@ -278,8 +310,8 @@ captureAllSpec = do

278

310

279 with (return (serve

311 with (return (serve

280 (Proxy :: Proxy (CaptureAll "segments" String :> Raw))

312 (Proxy :: Proxy (CaptureAll "segments" String :> Raw))

281− (\ _captured -> Tagged $ \request_ respond ->

313+ (\ _captured -> Tagged $ \request_ sendResponse ->

282− respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do

314+ sendResponse $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do

283 it "consumes everything from pathInfo" $ do

315 it "consumes everything from pathInfo" $ do

284 get "/captured/foo/bar/baz" `shouldRespondWith` (fromString (show ([] :: [Int])))

316 get "/captured/foo/bar/baz" `shouldRespondWith` (fromString (show ([] :: [Int])))

285

317

@@ -314,117 +346,154 @@ qpServer = queryParamServer :<|> qpNames :<|> qpCapitalize :<|> qpAge :<|> qpAge

314 queryParamServer (Just name_) = return alice{name = name_}

346 queryParamServer (Just name_) = return alice{name = name_}

315 queryParamServer Nothing = return alice

347 queryParamServer Nothing = return alice

316

348

349+

350+

317queryParamSpec :: Spec

351queryParamSpec :: Spec

318queryParamSpec = do

352queryParamSpec = do

353+ let mkRequest params pinfo = Network.Wai.Test.request defaultRequest

354+ { rawQueryString = params

355+ , queryString = parseQuery params

356+ , pathInfo = pinfo

357+ }

358+

319 describe "Servant.API.QueryParam" $ do

359 describe "Servant.API.QueryParam" $ do

320 it "allows retrieving simple GET parameters" $

360 it "allows retrieving simple GET parameters" $

321− (flip runSession) (serve queryParamApi qpServer) $ do

361+ flip runSession (serve queryParamApi qpServer) $ do

322− let params1 = "?name=bob"

362+ response1 <- mkRequest "?name=bob" []

323− response1 <- Network.Wai.Test.request defaultRequest{

324− rawQueryString = params1,

325− queryString = parseQuery params1

326− }

327− liftIO $ do

328− decode' (simpleBody response1) `shouldBe` Just alice{

363+ liftIO $ decode' (simpleBody response1) `shouldBe` Just alice

329− name = "bob"

364+ { name = "bob"

330− }

365+ }

331

366

332 it "allows retrieving lists in GET parameters" $

367 it "allows retrieving lists in GET parameters" $

333− (flip runSession) (serve queryParamApi qpServer) $ do

368+ flip runSession (serve queryParamApi qpServer) $ do

334− let params2 = "?names[]=bob&names[]=john"

369+ response2 <- mkRequest "?names[]=bob&names[]=john" ["a"]

335− response2 <- Network.Wai.Test.request defaultRequest{

336− rawQueryString = params2,

337− queryString = parseQuery params2,

338− pathInfo = ["a"]

339− }

340− liftIO $

341− decode' (simpleBody response2) `shouldBe` Just alice{

370+ liftIO $ decode' (simpleBody response2) `shouldBe` Just alice

342− name = "john"

371+ { name = "john"

343− }

372+ }

344

373

345 it "parses a query parameter" $

374 it "parses a query parameter" $

346− (flip runSession) (serve queryParamApi qpServer) $ do

375+ flip runSession (serve queryParamApi qpServer) $ do

347− let params = "?age=55"

376+ response <- mkRequest "?age=55" ["param"]

348− response <- Network.Wai.Test.request defaultRequest{

349− rawQueryString = params,

350− queryString = parseQuery params,

351− pathInfo = ["param"]

352− }

353− liftIO $

354− decode' (simpleBody response) `shouldBe` Just alice{

377+ liftIO $ decode' (simpleBody response) `shouldBe` Just alice

355− age = 55

378+ { age = 55

356− }

379+ }

357

380

358 it "generates an error on query parameter parse failure" $

381 it "generates an error on query parameter parse failure" $

359− (flip runSession) (serve queryParamApi qpServer) $ do

382+ flip runSession (serve queryParamApi qpServer) $ do

360− let params = "?age=foo"

383+ response <- mkRequest "?age=foo" ["param"]

361− response <- Network.Wai.Test.request defaultRequest{

362− rawQueryString = params,

363− queryString = parseQuery params,

364− pathInfo = ["param"]

365− }

366 liftIO $ statusCode (simpleStatus response) `shouldBe` 400

384 liftIO $ statusCode (simpleStatus response) `shouldBe` 400

367 return ()

385 return ()

368

386

369 it "parses multiple query parameters" $

387 it "parses multiple query parameters" $

370− (flip runSession) (serve queryParamApi qpServer) $ do

388+ flip runSession (serve queryParamApi qpServer) $ do

371− let params = "?ages=10&ages=22"

389+ response <- mkRequest "?ages=10&ages=22" ["multiparam"]

372− response <- Network.Wai.Test.request defaultRequest{

373− rawQueryString = params,

374− queryString = parseQuery params,

375− pathInfo = ["multiparam"]

376− }

377− liftIO $

378− decode' (simpleBody response) `shouldBe` Just alice{

390+ liftIO $ decode' (simpleBody response) `shouldBe` Just alice

379− age = 32

391+ { age = 32

380− }

392+ }

381

393

382 it "generates an error on parse failures of multiple parameters" $

394 it "generates an error on parse failures of multiple parameters" $

383− (flip runSession) (serve queryParamApi qpServer) $ do

395+ flip runSession (serve queryParamApi qpServer) $ do

384− let params = "?ages=2&ages=foo"

396+ response <- mkRequest "?ages=2&ages=foo" ["multiparam"]

385− response <- Network.Wai.Test.request defaultRequest{

386− rawQueryString = params,

387− queryString = parseQuery params,

388− pathInfo = ["multiparam"]

389− }

390 liftIO $ statusCode (simpleStatus response) `shouldBe` 400

397 liftIO $ statusCode (simpleStatus response) `shouldBe` 400

391 return ()

398 return ()

392

399

393−

394 it "allows retrieving value-less GET parameters" $

400 it "allows retrieving value-less GET parameters" $

395− (flip runSession) (serve queryParamApi qpServer) $ do

401+ flip runSession (serve queryParamApi qpServer) $ do

396− let params3 = "?capitalize"

402+ response3 <- mkRequest "?capitalize" ["b"]

397− response3 <- Network.Wai.Test.request defaultRequest{

398− rawQueryString = params3,

399− queryString = parseQuery params3,

400− pathInfo = ["b"]

401− }

402− liftIO $

403− decode' (simpleBody response3) `shouldBe` Just alice{

403+ liftIO $ decode' (simpleBody response3) `shouldBe` Just alice

404− name = "ALICE"

404+ { name = "ALICE"

405− }

405+ }

406−

406+

407− let params3' = "?capitalize="

407+ response3' <- mkRequest "?capitalize=" ["b"]

408− response3' <- Network.Wai.Test.request defaultRequest{

409− rawQueryString = params3',

410− queryString = parseQuery params3',

411− pathInfo = ["b"]

412− }

413− liftIO $

414− decode' (simpleBody response3') `shouldBe` Just alice{

408+ liftIO $ decode' (simpleBody response3') `shouldBe` Just alice

415− name = "ALICE"

409+ { name = "ALICE"

416− }

410+ }

417−

411+

418− let params3'' = "?unknown="

412+ response3'' <- mkRequest "?unknown=" ["b"]

419− response3'' <- Network.Wai.Test.request defaultRequest{

413+ liftIO $ decode' (simpleBody response3'') `shouldBe` Just alice

414+ { name = "Alice"

415+ }

416+

420− rawQueryString = params3'',

417+ describe "Uses queryString instead of rawQueryString" $ do

421− queryString = parseQuery params3'',

418+ -- test query parameters rewriter

422− pathInfo = ["b"]

419+ let queryRewriter :: Middleware

423− }

420+ queryRewriter app req = app req

424− liftIO $

421+ { queryString = fmap rewrite $ queryString req

422+ }

423+ where

424+ rewrite :: QueryItem -> QueryItem

425+ rewrite (k, v) = (fromMaybe k (BS.stripPrefix "person_" k), v)

426+

427+ let app = queryRewriter $ serve queryParamApi qpServer

428+

429+ it "allows rewriting for simple GET/query parameters" $

430+ flip runSession app $ do

431+ response1 <- mkRequest "?person_name=bob" []

425− decode' (simpleBody response3'') `shouldBe` Just alice{

432+ liftIO $ decode' (simpleBody response1) `shouldBe` Just alice

426− name = "Alice"

433+ { name = "bob"

427− }

434+ }

435+

436+ it "allows rewriting for lists in GET parameters" $

437+ flip runSession app $ do

438+ response2 <- mkRequest "?person_names[]=bob&person_names[]=john" ["a"]

439+ liftIO $ decode' (simpleBody response2) `shouldBe` Just alice

440+ { name = "john"

441+ }

442+

443+ it "allows rewriting when parsing multiple query parameters" $

444+ flip runSession app $ do

445+ response <- mkRequest "?person_ages=10&person_ages=22" ["multiparam"]

446+ liftIO $ decode' (simpleBody response) `shouldBe` Just alice

447+ { age = 32

448+ }

449+

450+ it "allows retrieving value-less GET parameters" $

451+ flip runSession app $ do

452+ response3 <- mkRequest "?person_capitalize" ["b"]

453+ liftIO $ decode' (simpleBody response3) `shouldBe` Just alice

454+ { name = "ALICE"

455+ }

456+

457+ response3' <- mkRequest "?person_capitalize=" ["b"]

458+ liftIO $ decode' (simpleBody response3') `shouldBe` Just alice

459+ { name = "ALICE"

460+ }

461+

462+ response3'' <- mkRequest "?person_unknown=" ["b"]

463+ liftIO $ decode' (simpleBody response3'') `shouldBe` Just alice

464+ { name = "Alice"

465+ }

466+

467+-- }}}

468+------------------------------------------------------------------------------

469+-- * fragmentSpec {{{

470+------------------------------------------------------------------------------

471+

472+type FragmentApi = "name" :> Fragment String :> Get '[JSON] Person

473+ :<|> "age" :> Fragment Integer :> Get '[JSON] Person

474+

475+fragmentApi :: Proxy FragmentApi

476+fragmentApi = Proxy

477+

478+fragServer :: Server FragmentApi

479+fragServer = fragmentServer :<|> fragAge

480+ where

481+ fragmentServer = return alice

482+ fragAge = return alice

483+

484+fragmentSpec :: Spec

485+fragmentSpec = do

486+ let mkRequest params pinfo = Network.Wai.Test.request defaultRequest

487+ { rawQueryString = params

488+ , queryString = parseQuery params

489+ , pathInfo = pinfo

490+ }

491+

492+ describe "Servant.API.Fragment" $ do

493+ it "ignores fragment even if it is present in query" $ do

494+ flip runSession (serve fragmentApi fragServer) $ do

495+ response1 <- mkRequest "#Alice" ["name"]

496+ liftIO $ decode' (simpleBody response1) `shouldBe` Just alice

428

497

429-- }}}

498-- }}}

430------------------------------------------------------------------------------

499------------------------------------------------------------------------------

@@ -511,15 +580,15 @@ rawApi :: Proxy RawApi

511rawApi = Proxy

580rawApi = Proxy

512

581

513rawApplication :: Show a => (Request -> a) -> Tagged m Application

582rawApplication :: Show a => (Request -> a) -> Tagged m Application

514−rawApplication f = Tagged $ \request_ respond ->

583+rawApplication f = Tagged $ \request_ sendResponse ->

515− respond $ responseLBS ok200 []

584+ sendResponse $ responseLBS ok200 []

516 (cs $ show $ f request_)

585 (cs $ show $ f request_)

517

586

518rawSpec :: Spec

587rawSpec :: Spec

519rawSpec = do

588rawSpec = do

520 describe "Servant.API.Raw" $ do

589 describe "Servant.API.Raw" $ do

521 it "runs applications" $ do

590 it "runs applications" $ do

522− (flip runSession) (serve rawApi (rawApplication (const (42 :: Integer)))) $ do

591+ flip runSession (serve rawApi (rawApplication (const (42 :: Integer)))) $ do

523 response <- Network.Wai.Test.request defaultRequest{

592 response <- Network.Wai.Test.request defaultRequest{

524 pathInfo = ["foo"]

593 pathInfo = ["foo"]

525 }

594 }

@@ -527,7 +596,7 @@ rawSpec = do

527 simpleBody response `shouldBe` "42"

596 simpleBody response `shouldBe` "42"

528

597

529 it "gets the pathInfo modified" $ do

598 it "gets the pathInfo modified" $ do

530− (flip runSession) (serve rawApi (rawApplication pathInfo)) $ do

599+ flip runSession (serve rawApi (rawApplication pathInfo)) $ do

531 response <- Network.Wai.Test.request defaultRequest{

600 response <- Network.Wai.Test.request defaultRequest{

532 pathInfo = ["foo", "bar"]

601 pathInfo = ["foo", "bar"]

533 }

602 }

@@ -617,6 +686,31 @@ responseHeadersSpec = describe "ResponseHeaders" $ do

617 THW.request method "" [(hAccept, "crazy/mime")] ""

686 THW.request method "" [(hAccept, "crazy/mime")] ""

618 `shouldRespondWith` 406

687 `shouldRespondWith` 406

619

688

689+-- }}}

690+------------------------------------------------------------------------------

691+-- * uverbResponseHeaderSpec {{{

692+------------------------------------------------------------------------------

693+type UVerbHeaderResponse = '[

694+ WithStatus 200 (Headers '[Header "H1" Int] String),

695+ WithStatus 404 String ]

696+

697+type UVerbResponseHeadersApi =

698+ Capture "ok" Bool :> UVerb 'GET '[JSON] UVerbHeaderResponse

699+

700+uverbResponseHeadersServer :: Server UVerbResponseHeadersApi

701+uverbResponseHeadersServer True = respond . WithStatus @200 . addHeader @"H1" (5 :: Int) $ ("foo" :: String)

702+uverbResponseHeadersServer False = respond . WithStatus @404 $ ("bar" :: String)

703+

704+uverbResponseHeadersSpec :: Spec

705+uverbResponseHeadersSpec = describe "UVerbResponseHeaders" $ do

706+ with (return $ serve (Proxy :: Proxy UVerbResponseHeadersApi) uverbResponseHeadersServer) $ do

707+

708+ it "includes the headers in the response" $

709+ THW.request methodGet "/true" [] ""

710+ `shouldRespondWith` "\"foo\"" { matchHeaders = ["H1" <:> "5"]

711+ , matchStatus = 200

712+ }

713+

620-- }}}

714-- }}}

621------------------------------------------------------------------------------

715------------------------------------------------------------------------------

622-- * miscCombinatorSpec {{{

716-- * miscCombinatorSpec {{{

@@ -673,7 +767,7 @@ basicAuthApi = Proxy

673basicAuthServer :: Server BasicAuthAPI

767basicAuthServer :: Server BasicAuthAPI

674basicAuthServer =

768basicAuthServer =

675 const (return jerry) :<|>

769 const (return jerry) :<|>

676− (Tagged $ \ _ respond -> respond $ responseLBS imATeapot418 [] "")

770+ (Tagged $ \ _ sendResponse -> sendResponse $ responseLBS imATeapot418 [] "")

677

771

678basicAuthContext :: Context '[ BasicAuthCheck () ]

772basicAuthContext :: Context '[ BasicAuthCheck () ]

679basicAuthContext =

773basicAuthContext =

@@ -718,7 +812,7 @@ genAuthApi = Proxy

718

812

719genAuthServer :: Server GenAuthAPI

813genAuthServer :: Server GenAuthAPI

720genAuthServer = const (return tweety)

814genAuthServer = const (return tweety)

721− :<|> (Tagged $ \ _ respond -> respond $ responseLBS imATeapot418 [] "")

815+ :<|> (Tagged $ \ _ sendResponse -> sendResponse $ responseLBS imATeapot418 [] "")

722

816

723type instance AuthServerData (AuthProtect "auth") = ()

817type instance AuthServerData (AuthProtect "auth") = ()

724

818

@@ -748,6 +842,73 @@ genAuthSpec = do

748 it "plays nice with subsequent Raw endpoints" $ do

842 it "plays nice with subsequent Raw endpoints" $ do

749 get "/foo" `shouldRespondWith` 418

843 get "/foo" `shouldRespondWith` 418

750

844

845+-- }}}

846+------------------------------------------------------------------------------

847+-- * UVerb {{{

848+------------------------------------------------------------------------------

849+

850+newtype PersonResponse = PersonResponse Person

851+ deriving Generic

852+instance ToJSON PersonResponse

853+instance HasStatus PersonResponse where

854+ type StatusOf PersonResponse = 200

855+

856+newtype RedirectResponse = RedirectResponse String

857+ deriving Generic

858+instance ToJSON RedirectResponse

859+instance HasStatus RedirectResponse where

860+ type StatusOf RedirectResponse = 301

861+

862+newtype AnimalResponse = AnimalResponse Animal

863+ deriving Generic

864+instance ToJSON AnimalResponse

865+instance HasStatus AnimalResponse where

866+ type StatusOf AnimalResponse = 203

867+

868+

869+type UVerbApi

870+ = "person" :> Capture "shouldRedirect" Bool :> UVerb 'GET '[JSON] '[PersonResponse, RedirectResponse]

871+ :<|> "animal" :> UVerb 'GET '[JSON] '[AnimalResponse]

872+

873+uverbSpec :: Spec

874+uverbSpec = describe "Servant.API.UVerb " $ do

875+ let

876+ joe = Person "joe" 42

877+ mouse = Animal "Mouse" 7

878+

879+ personHandler

880+ :: Bool

881+ -> Handler (Union '[PersonResponse

882+ ,RedirectResponse])

883+ personHandler True = respond $ RedirectResponse "over there!"

884+ personHandler False = respond $ PersonResponse joe

885+

886+ animalHandler = respond $ AnimalResponse mouse

887+

888+ server :: Server UVerbApi

889+ server = personHandler :<|> animalHandler

890+

891+ with (pure $ serve (Proxy :: Proxy UVerbApi) server) $ do

892+ context "A route returning either 301/String or 200/Person" $ do

893+ context "when requesting the person" $ do

894+ let theRequest = THW.get "/person/false"

895+ it "returns status 200" $

896+ theRequest `shouldRespondWith` 200

897+ it "returns a person" $ do

898+ response <- theRequest

899+ liftIO $ decode' (simpleBody response) `shouldBe` Just joe

900+ context "requesting the redirect" $

901+ it "returns a message and status 301" $

902+ THW.get "/person/true"

903+ `shouldRespondWith` "\"over there!\"" {matchStatus = 301}

904+ context "a route with a single response type" $ do

905+ let theRequest = THW.get "/animal"

906+ it "should return the defined status code" $

907+ theRequest `shouldRespondWith` 203

908+ it "should return the expected response" $ do

909+ response <- theRequest

910+ liftIO $ decode' (simpleBody response) `shouldBe` Just mouse

911+

751-- }}}

912-- }}}

752------------------------------------------------------------------------------

913------------------------------------------------------------------------------

753-- * Test data types {{{

914-- * Test data types {{{

@@ -780,6 +941,10 @@ jerry = Animal "Mouse" 4

780tweety :: Animal

941tweety :: Animal

781tweety = Animal "Bird" 2

942tweety = Animal "Bird" 2

782

943

944+-- weird animal with non-integer amount of ears

945+chimera :: Animal

946+chimera = Animal "Chimera" (-1)

947+

783beholder :: Animal

948beholder :: Animal

784beholder = Animal "Beholder" 0

949beholder = Animal "Beholder" 0

785-- }}}

950-- }}}

servant-server/test/doctests.hsdeleted−27

@@ -1,27 +0,0 @@

1−-----------------------------------------------------------------------------

2−-- |

3−-- Module : Main (doctests)

4−-- Copyright : (C) 2012-14 Edward Kmett

5−-- License : BSD-style (see the file LICENSE)

6−-- Maintainer : Edward Kmett <ekmett@gmail.com>

7−-- Stability : provisional

8−-- Portability : portable

9−--

10−-- This module provides doctests for a project based on the actual versions

11−-- of the packages it was built with. It requires a corresponding Setup.lhs

12−-- to be added to the project

13−-----------------------------------------------------------------------------

14−module Main where

15−

16−import Build_doctests

17− (flags, module_sources, pkgs)

18−import Data.Foldable

19− (traverse_)

20−import Test.DocTest

21−

22−main :: IO ()

23−main = do

24− traverse_ putStrLn args

25− doctest args

26− where

27− args = flags ++ pkgs ++ module_sources

servant-swagger/CHANGELOG.mdnew file+143

@@ -0,0 +1,143 @@

1+1.1.9

2+-------

3+

4+* Support `servant-0.18`

5+

6+1.1.8

7+-------

8+

9+* Support `servant-0.17`

10+

11+1.1.7.1

12+-------

13+

14+* Support `swagger2-2.4`

15+

16+1.1.7

17+-----

18+

19+* Support servant-0.15

20+ - support for 'Stream' and 'StreamBody' combinators

21+ - orphan 'ToSchema (SourceT m a)' instance

22+* Fix BodyTypes to work with generalized ReqBody'

23+ [#88](https://github.com/haskell-servant/servant-swagger/pull/88)

24+

25+1.1.6

26+-----

27+

28+* Fixes:

29+ * `validateEveryToJSON` now prints validation errors

30+

31+* Notes:

32+ * GHC-8.6 compatible release

33+

34+1.1.5

35+-----

36+

37+* Notes:

38+ * `servant-0.13` compatible release

39+ * Drops compatibility with previous `servant` versions.

40+

41+1.1.4

42+-----

43+

44+* Notes:

45+ * `servant-0.12` compatible release

46+

47+1.1.3.1

48+---

49+

50+* Notes:

51+ * GHC-8.2 compatible release

52+

53+1.1.3

54+---

55+

56+* Notes:

57+ * `servant-0.11` compatible release

58+

59+1.1.2.1

60+---

61+

62+* Notes:

63+ * `servant-0.10` compatible release

64+

65+1.1.2

66+---

67+

68+* Minor fixes:

69+ * Support for aeson-1, insert-ordered-containers-0.2

70+ * CaptureAll instance

71+

72+1.1.1

73+---

74+

75+* Minor fixes:

76+ * Fix `unused-imports` and `unused-foralls` warnings;

77+ * Fix tests to match `swagger2-2.1.1` (add `example` property for `UTCTime` schema).

78+

79+1.1

80+---

81+

82+* Breaking changes:

83+ * Requires `swagger2 >= 2.1`

84+ * Requires `servant >= 0.5`

85+

86+* Notes:

87+ * GHC-8.0 compatible release

88+

89+1.0.3

90+---

91+

92+* Fixes:

93+ * Improve compile-time performance of `BodyTypes` even further (see [18e0d95](https://github.com/haskell-servant/servant-swagger/commit/18e0d95ef6fe9076dd9621cb515d8d1a189f71d3))!

94+

95+1.0.2

96+---

97+

98+* Minor changes:

99+ * Add GHC 7.8 support (see [#26](https://github.com/haskell-servant/servant-swagger/pull/26)).

100+

101+* Fixes:

102+ * Improve compile-time performance of `BodyTypes` (see [#25](https://github.com/haskell-servant/servant-swagger/issues/25)).

103+

104+1.0.1

105+---

106+

107+* Fixes:

108+ * Stop using `Data.Swagger.Internal`;

109+ * Documentation fixes (links to examples).

110+

111+1.0

112+---

113+

114+* Major changes (see [#24](https://github.com/haskell-servant/servant-swagger/pull/24)):

115+ * Switch to `swagger2-2.*`;

116+ * Add automatic `ToJSON`/`ToSchema` validation tests;

117+ * Add great documentation;

118+ * Export some type-level functions for servant API.

119+

120+* Minor changes:

121+ * Rework Todo API example;

122+ * Stop exporting `ToResponseHeader`, `AllAccept` and `AllToResponseHeader` (see [bd50db4](https://github.com/haskell-servant/servant-swagger/commit/bd50db48ca6a106e4366560ded70932d409de1e2));

123+ * Change maintainer, update authors/copyrights (see [1a62681](https://github.com/haskell-servant/servant-swagger/commit/1a6268101dc826a92c42e832e402e251c0d32147));

124+ * Include changelog and example files into `extra-source-files`.

125+

126+0.1.2

127+---

128+

129+* Fixes:

130+ * Fix default spec for `ReqBody` param to be required (see [#22](https://github.com/haskell-servant/servant-swagger/issues/22));

131+ * Set version bounds for `swagger2`.

132+

133+0.1.1

134+---

135+

136+* Fixes:

137+ * Fix `subOperations` to filter endpoints also by method (see [#18](https://github.com/haskell-servant/servant-swagger/issues/18));

138+ * Fix response schema in `ToSwagger` instance for `Header` (see [b59e557](https://github.com/haskell-servant/servant-swagger/commit/b59e557a05bc2669332c52b397879e7598747b82)).

139+

140+0.1

141+---

142+* Major changes

143+ * Use `swagger2` for data model (see [#9](https://github.com/dmjio/servant-swagger/pull/9)); this changes almost everything.

servant-swagger/LICENSEnew file+28

@@ -0,0 +1,28 @@

1+Copyright (c) 2015-2016, Servant contributors

2+All rights reserved.

3+

4+Redistribution and use in source and binary forms, with or without

5+modification, are permitted provided that the following conditions are met:

6+

7+* Redistributions of source code must retain the above copyright notice, this

8+ list of conditions and the following disclaimer.

9+

10+* Redistributions in binary form must reproduce the above copyright notice,

11+ this list of conditions and the following disclaimer in the documentation

12+ and/or other materials provided with the distribution.

13+

14+* Neither the name of servant-swagger nor the names of its

15+ contributors may be used to endorse or promote products derived from

16+ this software without specific prior written permission.

17+

18+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"

19+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE

20+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE

21+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE

22+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL

23+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR

24+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER

25+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,

26+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE

27+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

28+

servant-swagger/README.mdnew file+46

@@ -0,0 +1,46 @@

1+# servant-swagger

2+

3+[](http://hackage.haskell.org/package/servant-swagger)

4+[](http://stackage.org/lts/package/servant-swagger)

5+[](http://stackage.org/nightly/package/servant-swagger)

6+

7+Swagger 2.0 conforming json for [servant](https://github.com/haskell-servant/servant) APIs.

8+

9+

10+

11+### Motivation

12+

13+Swagger is a project used to describe and document RESTful APIs.

14+Unlike Servant it is language-agnostic and thus is quite popular among developers

15+in different languages. It also exists for a longer time and has more tools to work with.

16+

17+This package provides means to generate Swagger specification for a Servant API

18+and also to partially test whether API conforms with its specification.

19+

20+Generated Swagger specification then can be used for many things such as

21+- displaying interactive documentation using [Swagger UI](http://swagger.io/swagger-ui/);

22+- generating clients and servers in many languages using [Swagger Codegen](http://swagger.io/swagger-codegen/);

23+- and [many others](http://swagger.io/open-source-integrations/).

24+

25+### Usage

26+

27+Please refer to [haddock documentation](http://hackage.haskell.org/package/servant/servant-swagger).

28+

29+Some examples can be found in [`example/` directory](/example).

30+

31+### Try it out

32+

33+All generated swagger specifications can be interactively viewed on [Swagger Editor](http://editor.swagger.io/).

34+

35+Ready-to-use specification can be served as JSON and interactive API documentation

36+can be displayed using [Swagger UI](https://github.com/swagger-api/swagger-ui).

37+

38+Many Swagger tools, including server and client code generation for many languages, can be found on

39+[Swagger's Tools and Integrations page](http://swagger.io/open-source-integrations/).

40+

41+### Contributing

42+

43+We are happy to receive bug reports, fixes, documentation enhancements, and other improvements.

44+

45+Please report bugs via the [github issue tracker](https://github.com/haskell-servant/servant/issues).

46+

servant-swagger/Setup.hsnew file+33

@@ -0,0 +1,33 @@

1+{-# LANGUAGE CPP #-}

2+{-# OPTIONS_GHC -Wall #-}

3+module Main (main) where

4+

5+#ifndef MIN_VERSION_cabal_doctest

6+#define MIN_VERSION_cabal_doctest(x,y,z) 0

7+#endif

8+

9+#if MIN_VERSION_cabal_doctest(1,0,0)

10+

11+import Distribution.Extra.Doctest ( defaultMainWithDoctests )

12+main :: IO ()

13+main = defaultMainWithDoctests "doctests"

14+

15+#else

16+

17+#ifdef MIN_VERSION_Cabal

18+-- If the macro is defined, we have new cabal-install,

19+-- but for some reason we don't have cabal-doctest in package-db

20+--

21+-- Probably we are running cabal sdist, when otherwise using new-build

22+-- workflow

23+#warning You are configuring this package without cabal-doctest installed. \

24+ The doctests test-suite will not work as a result. \

25+ To fix this, install cabal-doctest before configuring.

26+#endif

27+

28+import Distribution.Simple

29+

30+main :: IO ()

31+main = defaultMain

32+

33+#endif

servant-swagger/example/LICENSEnew file+28

@@ -0,0 +1,28 @@

1+Copyright (c) 2015-2016, Servant contributors

2+All rights reserved.

3+

4+Redistribution and use in source and binary forms, with or without

5+modification, are permitted provided that the following conditions are met:

6+

7+* Redistributions of source code must retain the above copyright notice, this

8+ list of conditions and the following disclaimer.

9+

10+* Redistributions in binary form must reproduce the above copyright notice,

11+ this list of conditions and the following disclaimer in the documentation

12+ and/or other materials provided with the distribution.

13+

14+* Neither the name of servant-swagger nor the names of its

15+ contributors may be used to endorse or promote products derived from

16+ this software without specific prior written permission.

17+

18+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"

19+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE

20+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE

21+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE

22+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL

23+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR

24+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER

25+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,

26+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE

27+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

28+

servant-swagger/example/example.cabalnew file+62

@@ -0,0 +1,62 @@

1+cabal-version: 2.2

2+name: example

3+version: 1.0

4+synopsis: servant-swagger demonstration

5+description: servant-swagger demonstration

6+license: BSD-3-Clause

7+license-file: LICENSE

8+author: David Johnson, Nickolay Kudasov

9+maintainer: nickolay.kudasov@gmail.com

10+copyright: (c) 2015-2016, Servant contributors

11+category: Web

12+build-type: Simple

13+data-files:

14+ swagger.json

15+

16+library

17+ ghc-options: -Wall

18+ hs-source-dirs: src/

19+ exposed-modules:

20+ Todo

21+ build-depends: base

22+ , aeson

23+ , aeson-pretty

24+ , bytestring

25+ , lens

26+ , servant

27+ , servant-server

28+ , servant-swagger

29+ , swagger2

30+ , text

31+ , time

32+ default-language: Haskell2010

33+

34+executable swagger-server

35+ ghc-options: -Wall

36+ hs-source-dirs: server/

37+ main-is: Main.hs

38+ build-depends: base

39+ , example

40+ , servant-server

41+ , warp

42+ default-language: Haskell2010

43+

44+test-suite swagger-server-spec

45+ ghc-options: -Wall

46+ type: exitcode-stdio-1.0

47+ hs-source-dirs: test

48+ main-is: Spec.hs

49+ other-modules:

50+ TodoSpec

51+ Paths_example

52+ build-depends: base == 4.*

53+ , base-compat >= 0.6.0

54+ , aeson >=0.11.2.0

55+ , bytestring

56+ , example

57+ , hspec

58+ , servant-swagger

59+ , QuickCheck

60+ , quickcheck-instances

61+ default-language: Haskell2010

62+

servant-swagger/example/server/Main.hsnew file+11

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

1+module Main where

2+

3+import Network.Wai.Handler.Warp

4+import Servant

5+import Todo

6+

7+main :: IO ()

8+main = do

9+ putStrLn "Running on port 8000"

10+ run 8000 $ serve (Proxy :: Proxy API) server

11+

servant-swagger/example/src/Todo.hsnew file+73

@@ -0,0 +1,73 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE DeriveDataTypeable #-}

3+{-# LANGUAGE DeriveGeneric #-}

4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5+{-# LANGUAGE OverloadedStrings #-}

6+{-# LANGUAGE TypeOperators #-}

7+module Todo where

8+

9+import Control.Lens

10+import Data.Aeson

11+import Data.Aeson.Encode.Pretty (encodePretty)

12+import qualified Data.ByteString.Lazy.Char8 as BL8

13+import Data.Proxy

14+import Data.Swagger

15+import Data.Text (Text)

16+import Data.Time (UTCTime (..), fromGregorian)

17+import Data.Typeable (Typeable)

18+import GHC.Generics

19+import Servant

20+import Servant.Swagger

21+

22+todoAPI :: Proxy TodoAPI

23+todoAPI = Proxy

24+

25+-- | The API of a Todo service.

26+type TodoAPI

27+ = "todo" :> Get '[JSON] [Todo]

28+ :<|> "todo" :> ReqBody '[JSON] Todo :> Post '[JSON] TodoId

29+ :<|> "todo" :> Capture "id" TodoId :> Get '[JSON] Todo

30+ :<|> "todo" :> Capture "id" TodoId :> ReqBody '[JSON] Todo :> Put '[JSON] TodoId

31+

32+-- | API for serving @swagger.json@.

33+type SwaggerAPI = "swagger.json" :> Get '[JSON] Swagger

34+

35+-- | Combined API of a Todo service with Swagger documentation.

36+type API = SwaggerAPI :<|> TodoAPI

37+

38+-- | A single Todo entry.

39+data Todo = Todo

40+ { created :: UTCTime -- ^ Creation datetime.

41+ , summary :: Text -- ^ Task summary.

42+ } deriving (Show, Generic, Typeable)

43+

44+-- | A unique Todo entry ID.

45+newtype TodoId = TodoId Int

46+ deriving (Show, Generic, Typeable, ToJSON, FromHttpApiData)

47+

48+instance ToJSON Todo

49+instance FromJSON Todo

50+

51+instance ToSchema Todo where

52+ declareNamedSchema proxy = genericDeclareNamedSchema defaultSchemaOptions proxy

53+ & mapped.schema.description ?~ "This is some real Todo right here"

54+ & mapped.schema.example ?~ toJSON (Todo (UTCTime (fromGregorian 2015 12 31) 0) "get milk")

55+

56+instance ToParamSchema TodoId

57+instance ToSchema TodoId

58+

59+-- | Swagger spec for Todo API.

60+todoSwagger :: Swagger

61+todoSwagger = toSwagger todoAPI

62+ & info.title .~ "Todo API"

63+ & info.version .~ "1.0"

64+ & info.description ?~ "This is an API that tests swagger integration"

65+ & info.license ?~ ("MIT" & url ?~ URL "http://mit.com")

66+

67+-- | Combined server of a Todo service with Swagger documentation.

68+server :: Server API

69+server = return todoSwagger :<|> error "not implemented"

70+

71+-- | Output generated @swagger.json@ file for the @'TodoAPI'@.

72+writeSwaggerJSON :: IO ()

73+writeSwaggerJSON = BL8.writeFile "example/swagger.json" (encodePretty todoSwagger)

servant-swagger/example/swagger.jsonnew file+158

@@ -0,0 +1,158 @@

1+{

2+ "swagger": "2.0",

3+ "info": {

4+ "version": "1.0",

5+ "title": "Todo API",

6+ "license": {

7+ "url": "http://mit.com",

8+ "name": "MIT"

9+ },

10+ "description": "This is an API that tests swagger integration"

11+ },

12+ "definitions": {

13+ "Todo": {

14+ "example": {

15+ "summary": "get milk",

16+ "created": "2015-12-31T00:00:00Z"

17+ },

18+ "required": [

19+ "created",

20+ "summary"

21+ ],

22+ "type": "object",

23+ "description": "This is some real Todo right here",

24+ "properties": {

25+ "summary": {

26+ "type": "string"

27+ },

28+ "created": {

29+ "$ref": "#/definitions/UTCTime"

30+ }

31+ }

32+ },

33+ "UTCTime": {

34+ "example": "2016-07-22T00:00:00Z",

35+ "format": "yyyy-mm-ddThh:MM:ssZ",

36+ "type": "string"

37+ },

38+ "TodoId": {

39+ "maximum": 9223372036854775807,

40+ "minimum": -9223372036854775808,

41+ "type": "integer"

42+ }

43+ },

44+ "paths": {

45+ "/todo/{id}": {

46+ "get": {

47+ "responses": {

48+ "400": {

49+ "description": "Invalid `id`"

50+ },

51+ "200": {

52+ "schema": {

53+ "$ref": "#/definitions/Todo"

54+ },

55+ "description": ""

56+ }

57+ },

58+ "produces": [

59+ "application/json;charset=utf-8"

60+ ],

61+ "parameters": [

62+ {

63+ "maximum": 9223372036854775807,

64+ "minimum": -9223372036854775808,

65+ "required": true,

66+ "in": "path",

67+ "name": "id",

68+ "type": "integer"

69+ }

70+ ]

71+ },

72+ "put": {

73+ "consumes": [

74+ "application/json;charset=utf-8"

75+ ],

76+ "responses": {

77+ "400": {

78+ "description": "Invalid `body` or `id`"

79+ },

80+ "200": {

81+ "schema": {

82+ "$ref": "#/definitions/TodoId"

83+ },

84+ "description": ""

85+ }

86+ },

87+ "produces": [

88+ "application/json;charset=utf-8"

89+ ],

90+ "parameters": [

91+ {

92+ "maximum": 9223372036854775807,

93+ "minimum": -9223372036854775808,

94+ "required": true,

95+ "in": "path",

96+ "name": "id",

97+ "type": "integer"

98+ },

99+ {

100+ "required": true,

101+ "schema": {

102+ "$ref": "#/definitions/Todo"

103+ },

104+ "in": "body",

105+ "name": "body"

106+ }

107+ ]

108+ }

109+ },

110+ "/todo": {

111+ "post": {

112+ "consumes": [

113+ "application/json;charset=utf-8"

114+ ],

115+ "responses": {

116+ "400": {

117+ "description": "Invalid `body`"

118+ },

119+ "200": {

120+ "schema": {

121+ "$ref": "#/definitions/TodoId"

122+ },

123+ "description": ""

124+ }

125+ },

126+ "produces": [

127+ "application/json;charset=utf-8"

128+ ],

129+ "parameters": [

130+ {

131+ "required": true,

132+ "schema": {

133+ "$ref": "#/definitions/Todo"

134+ },

135+ "in": "body",

136+ "name": "body"

137+ }

138+ ]

139+ },

140+ "get": {

141+ "responses": {

142+ "200": {

143+ "schema": {

144+ "items": {

145+ "$ref": "#/definitions/Todo"

146+ },

147+ "type": "array"

148+ },

149+ "description": ""

150+ }

151+ },

152+ "produces": [

153+ "application/json;charset=utf-8"

154+ ]

155+ }

156+ }

157+ }

158+}

servant-swagger/example/test/Spec.hsnew file+1

@@ -0,0 +1 @@

1+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

servant-swagger/example/test/TodoSpec.hsnew file+28

@@ -0,0 +1,28 @@

1+{-# OPTIONS_GHC -fno-warn-orphans #-}

2+module TodoSpec where

3+

4+import Prelude ()

5+import Prelude.Compat

6+

7+import Data.Aeson

8+import qualified Data.ByteString.Lazy.Char8 as BL8

9+import Paths_example

10+import Servant.Swagger.Test

11+import Test.Hspec

12+import Test.QuickCheck

13+import Test.QuickCheck.Instances ()

14+import Todo

15+

16+spec :: Spec

17+spec = describe "Swagger" $ do

18+ context "ToJSON matches ToSchema" $ validateEveryToJSON todoAPI

19+ it "swagger.json is up-to-date" $ do

20+ path <- getDataFileName "swagger.json"

21+ swag <- eitherDecode <$> BL8.readFile path

22+ swag `shouldBe` Right todoSwagger

23+

24+instance Arbitrary Todo where

25+ arbitrary = Todo <$> arbitrary <*> arbitrary

26+

27+instance Arbitrary TodoId where

28+ arbitrary = TodoId <$> arbitrary

servant-swagger/servant-swagger.cabalnew file+127

@@ -0,0 +1,127 @@

1+cabal-version: 2.2

2+name: servant-swagger

3+version: 1.1.11

4+synopsis: Generate a Swagger/OpenAPI/OAS 2.0 specification for your servant API.

5+description:

6+ Swagger is a project used to describe and document RESTful APIs. The core of the

7+ project is the [OpenAPI Specification (OAS)](https://swagger.io/docs/specification/about/).

8+ This library implements v2.0 of the spec. Unlike Servant it is language-agnostic and thus is

9+ quite popular among developers in different languages. It has also existed for a longer time

10+ and has more helpful tooling.

11+ .

12+ This package provides means to generate a Swagger/OAS specification for a Servant API

13+ and also to partially test whether an API conforms with its specification.

14+ .

15+ Generated Swagger specification then can be used for many things such as

16+ .

17+ * displaying interactive documentation using [Swagger UI](http://swagger.io/swagger-ui/);

18+ .

19+ * generating clients and servers in many languages using [Swagger Codegen](http://swagger.io/swagger-codegen/);

20+ .

21+ * and [many others](http://swagger.io/open-source-integrations/).

22+homepage: https://github.com/haskell-servant/servant/tree/master/servant-swagger#readme

23+bug-reports: https://github.com/haskell-servant/servant/issues

24+license: BSD-3-Clause

25+license-file: LICENSE

26+author: Servant Contributors

27+maintainer: haskell-servant-maintainers@googlegroups.com

28+copyright: (c) 2015-2018, Servant contributors

29+category: Web, Servant, Swagger

30+build-type: Custom

31+tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2

32+

33+extra-source-files:

34+ README.md

35+ , CHANGELOG.md

36+ , example/server/*.hs

37+ , example/src/*.hs

38+ , example/test/*.hs

39+ , example/*.cabal

40+ , example/swagger.json

41+ , example/LICENSE

42+extra-doc-files:

43+ example/src/*.hs

44+ , example/test/*.hs

45+

46+source-repository head

47+ type: git

48+ location: https://github.com/haskell-servant/servant.git

49+

50+custom-setup

51+ setup-depends:

52+ base >=4.9 && <5,

53+ Cabal >= 1.24,

54+ cabal-doctest >=1.0.6 && <1.1

55+

56+library

57+ ghc-options: -Wall

58+ exposed-modules:

59+ Servant.Swagger

60+ Servant.Swagger.Test

61+ Servant.Swagger.TypeLevel

62+

63+ -- Internal modules

64+ Servant.Swagger.Internal

65+ Servant.Swagger.Internal.Orphans

66+ Servant.Swagger.Internal.Test

67+ Servant.Swagger.Internal.TypeLevel

68+ Servant.Swagger.Internal.TypeLevel.API

69+ Servant.Swagger.Internal.TypeLevel.Every

70+ Servant.Swagger.Internal.TypeLevel.TMap

71+ hs-source-dirs: src

72+ build-depends: aeson >=1.4.2.0 && <3

73+ , aeson-pretty >=0.8.7 && <0.9

74+ , base >=4.9.1.0 && <5

75+ , base-compat >=0.10.5 && <0.13

76+ , bytestring >=0.10.8.1 && <0.12

77+ , http-media >=0.7.1.3 && <0.9

78+ , insert-ordered-containers >=0.2.1.0 && <0.3

79+ , lens >=4.17 && <6

80+ , servant >=0.18.2 && <0.20

81+ , singleton-bool >=0.1.4 && <0.2

82+ , swagger2 >=2.3.0.1 && <3

83+ , text >=1.2.3.0 && <2.1

84+ , unordered-containers >=0.2.9.0 && <0.3

85+

86+ , hspec

87+ , QuickCheck

88+ default-language: Haskell2010

89+

90+test-suite doctests

91+ ghc-options: -Wall

92+ build-depends:

93+ base,

94+ directory >= 1.0,

95+ doctest >= 0.17 && <0.21,

96+ servant,

97+ QuickCheck,

98+ filepath

99+ default-language: Haskell2010

100+ hs-source-dirs: test

101+ main-is: doctests.hs

102+ type: exitcode-stdio-1.0

103+

104+test-suite spec

105+ ghc-options: -Wall

106+ type: exitcode-stdio-1.0

107+ hs-source-dirs: test

108+ main-is: Spec.hs

109+ build-tool-depends: hspec-discover:hspec-discover >=2.6.0 && <2.10

110+ build-depends: base

111+ , base-compat

112+ , aeson >=1.4.2.0 && <3

113+ , hspec >=2.6.0 && <2.10

114+ , QuickCheck

115+ , lens

116+ , lens-aeson >=1.0.2 && <1.3

117+ , servant

118+ , servant-swagger

119+ , swagger2

120+ , text

121+ , template-haskell

122+ , utf8-string >=1.0.1.1 && <1.1

123+ , time

124+ , vector

125+ other-modules:

126+ Servant.SwaggerSpec

127+ default-language: Haskell2010

servant-swagger/src/Servant/Swagger.hsnew file+188

@@ -0,0 +1,188 @@

1+-- |

2+-- Module: Servant.Swagger

3+-- License: BSD3

4+-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>

5+-- Stability: experimental

6+--

7+-- This module provides means to generate and manipulate

8+-- Swagger specification for servant APIs.

9+--

10+-- Swagger is a project used to describe and document RESTful APIs.

11+--

12+-- The Swagger specification defines a set of files required to describe such an API.

13+-- These files can then be used by the Swagger-UI project to display the API

14+-- and Swagger-Codegen to generate clients in various languages.

15+-- Additional utilities can also take advantage of the resulting files, such as testing tools.

16+--

17+-- For more information see <http://swagger.io/ Swagger documentation>.

18+module Servant.Swagger (

19+ -- * How to use this library

20+ -- $howto

21+

22+ -- ** Generate @'Swagger'@

23+ -- $generate

24+

25+ -- ** Annotate

26+ -- $annotate

27+

28+ -- ** Test

29+ -- $test

30+

31+ -- ** Serve

32+ -- $serve

33+

34+ -- * @'HasSwagger'@ class

35+ HasSwagger(..),

36+

37+ -- * Manipulation

38+ subOperations,

39+

40+ -- * Testing

41+ validateEveryToJSON,

42+ validateEveryToJSONWithPatternChecker,

43+) where

44+

45+import Servant.Swagger.Internal

46+import Servant.Swagger.Test

47+import Servant.Swagger.Internal.Orphans ()

48+

49+-- $setup

50+-- >>> import Control.Applicative

51+-- >>> import Control.Lens

52+-- >>> import Data.Aeson

53+-- >>> import Data.Aeson.Encode.Pretty

54+-- >>> import Data.Swagger

55+-- >>> import Data.Typeable

56+-- >>> import GHC.Generics

57+-- >>> import Servant.API

58+-- >>> import System.Environment

59+-- >>> import Test.Hspec

60+-- >>> import Test.QuickCheck

61+-- >>> import qualified Data.ByteString.Lazy.Char8 as BSL8

62+-- >>> :set -XDataKinds

63+-- >>> :set -XDeriveDataTypeable

64+-- >>> :set -XDeriveGeneric

65+-- >>> :set -XGeneralizedNewtypeDeriving

66+-- >>> :set -XOverloadedStrings

67+-- >>> :set -XTypeOperators

68+-- >>> setEnv "HSPEC_COLOR" "no"

69+-- >>> data User = User { name :: String, age :: Int } deriving (Show, Generic, Typeable)

70+-- >>> newtype UserId = UserId Integer deriving (Show, Generic, Typeable, ToJSON)

71+-- >>> instance ToJSON User

72+-- >>> instance ToSchema User

73+-- >>> instance ToSchema UserId

74+-- >>> instance ToParamSchema UserId

75+-- >>> type GetUsers = Get '[JSON] [User]

76+-- >>> type GetUser = Capture "user_id" UserId :> Get '[JSON] User

77+-- >>> type PostUser = ReqBody '[JSON] User :> Post '[JSON] UserId

78+-- >>> type UserAPI = GetUsers :<|> GetUser :<|> PostUser

79+-- >>> orderedKeys = encodePretty' (defConfig { confCompare = compare, confIndent = Spaces 0 })

80+

81+-- $howto

82+--

83+-- This section explains how to use this library to generate Swagger specification,

84+-- modify it and run automatic tests for a servant API.

85+--

86+-- For the purposes of this section we will use this servant API:

87+--

88+-- >>> data User = User { name :: String, age :: Int } deriving (Show, Generic, Typeable)

89+-- >>> newtype UserId = UserId Integer deriving (Show, Generic, Typeable, ToJSON)

90+-- >>> instance ToJSON User

91+-- >>> instance ToSchema User

92+-- >>> instance ToSchema UserId

93+-- >>> instance ToParamSchema UserId

94+-- >>> type GetUsers = Get '[JSON] [User]

95+-- >>> type GetUser = Capture "user_id" UserId :> Get '[JSON] User

96+-- >>> type PostUser = ReqBody '[JSON] User :> Post '[JSON] UserId

97+-- >>> type UserAPI = GetUsers :<|> GetUser :<|> PostUser

98+--

99+-- Here we define a user API with three endpoints. @GetUsers@ endpoint returns a list of all users.

100+-- @GetUser@ returns a user given his\/her ID. @PostUser@ creates a new user and returns his\/her ID.

101+

102+-- $generate

103+-- In order to generate @'Swagger'@ specification for a servant API, just use @'toSwagger'@:

104+--

105+-- >>> BSL8.putStrLn . orderedKeys $ toSwagger (Proxy :: Proxy UserAPI)

106+-- {"definitions":{"User":{"properties":{"age":{"maximum":9223372036854775807,"minimum":-9223372036854775808,"type":"integer"},"name":{"type":"string"}},"required":["name","age"],"type":"object"},"UserId":{"type":"integer"}},"info":{"title":"","version":""},"paths":{"/":{"get":{"produces":["application/json;charset=utf-8"],"responses":{"200":{"description":"","schema":{"items":{"$ref":"#/definitions/User"},"type":"array"}}}},"post":{"consumes":["application/json;charset=utf-8"],"parameters":[{"in":"body","name":"body","required":true,"schema":{"$ref":"#/definitions/User"}}],"produces":["application/json;charset=utf-8"],"responses":{"200":{"description":"","schema":{"$ref":"#/definitions/UserId"}},"400":{"description":"Invalid `body`"}}}},"/{user_id}":{"get":{"parameters":[{"in":"path","name":"user_id","required":true,"type":"integer"}],"produces":["application/json;charset=utf-8"],"responses":{"200":{"description":"","schema":{"$ref":"#/definitions/User"}},"400":{"description":"Invalid `user_id`"}}}}},"swagger":"2.0"}

107+--

108+-- By default @'toSwagger'@ will generate specification for all API routes, parameters, headers, responses and data schemas.

109+--

110+-- For some parameters it will also add 400 responses with a description mentioning parameter name.

111+--

112+-- Data schemas come from @'ToParamSchema'@ and @'ToSchema'@ classes.

113+

114+-- $annotate

115+-- While initially generated @'Swagger'@ looks good, it lacks some information it can't get from a servant API.

116+--

117+-- We can add this information using field lenses from @"Data.Swagger"@:

118+--

119+-- >>> :{

120+-- BSL8.putStrLn $ orderedKeys $ toSwagger (Proxy :: Proxy UserAPI)

121+-- & info.title .~ "User API"

122+-- & info.version .~ "1.0"

123+-- & info.description ?~ "This is an API for the Users service"

124+-- & info.license ?~ "MIT"

125+-- & host ?~ "example.com"

126+-- :}

127+-- {"definitions":{"User":{"properties":{"age":{"maximum":9223372036854775807,"minimum":-9223372036854775808,"type":"integer"},"name":{"type":"string"}},"required":["name","age"],"type":"object"},"UserId":{"type":"integer"}},"host":"example.com","info":{"description":"This is an API for the Users service","license":{"name":"MIT"},"title":"User API","version":"1.0"},"paths":{"/":{"get":{"produces":["application/json;charset=utf-8"],"responses":{"200":{"description":"","schema":{"items":{"$ref":"#/definitions/User"},"type":"array"}}}},"post":{"consumes":["application/json;charset=utf-8"],"parameters":[{"in":"body","name":"body","required":true,"schema":{"$ref":"#/definitions/User"}}],"produces":["application/json;charset=utf-8"],"responses":{"200":{"description":"","schema":{"$ref":"#/definitions/UserId"}},"400":{"description":"Invalid `body`"}}}},"/{user_id}":{"get":{"parameters":[{"in":"path","name":"user_id","required":true,"type":"integer"}],"produces":["application/json;charset=utf-8"],"responses":{"200":{"description":"","schema":{"$ref":"#/definitions/User"}},"400":{"description":"Invalid `user_id`"}}}}},"swagger":"2.0"}

128+--

129+-- It is also useful to annotate or modify certain endpoints.

130+-- @'subOperations'@ provides a convenient way to zoom into a part of an API.

131+--

132+-- @'subOperations' sub api@ traverses all operations of the @api@ which are also present in @sub@.

133+-- Furthermore, @sub@ is required to be an exact sub API of @api. Otherwise it will not typecheck.

134+--

135+-- @"Data.Swagger.Operation"@ provides some useful helpers that can be used with @'subOperations'@.

136+-- One example is applying tags to certain endpoints:

137+--

138+-- >>> let getOps = subOperations (Proxy :: Proxy (GetUsers :<|> GetUser)) (Proxy :: Proxy UserAPI)

139+-- >>> let postOps = subOperations (Proxy :: Proxy PostUser) (Proxy :: Proxy UserAPI)

140+-- >>> :{

141+-- BSL8.putStrLn $ orderedKeys $ toSwagger (Proxy :: Proxy UserAPI)

142+-- & applyTagsFor getOps ["get" & description ?~ "GET operations"]

143+-- & applyTagsFor postOps ["post" & description ?~ "POST operations"]

144+-- :}

145+-- {"definitions":{"User":{"properties":{"age":{"maximum":9223372036854775807,"minimum":-9223372036854775808,"type":"integer"},"name":{"type":"string"}},"required":["name","age"],"type":"object"},"UserId":{"type":"integer"}},"info":{"title":"","version":""},"paths":{"/":{"get":{"produces":["application/json;charset=utf-8"],"responses":{"200":{"description":"","schema":{"items":{"$ref":"#/definitions/User"},"type":"array"}}},"tags":["get"]},"post":{"consumes":["application/json;charset=utf-8"],"parameters":[{"in":"body","name":"body","required":true,"schema":{"$ref":"#/definitions/User"}}],"produces":["application/json;charset=utf-8"],"responses":{"200":{"description":"","schema":{"$ref":"#/definitions/UserId"}},"400":{"description":"Invalid `body`"}},"tags":["post"]}},"/{user_id}":{"get":{"parameters":[{"in":"path","name":"user_id","required":true,"type":"integer"}],"produces":["application/json;charset=utf-8"],"responses":{"200":{"description":"","schema":{"$ref":"#/definitions/User"}},"400":{"description":"Invalid `user_id`"}},"tags":["get"]}}},"swagger":"2.0","tags":[{"description":"GET operations","name":"get"},{"description":"POST operations","name":"post"}]}

146+--

147+-- This applies @\"get\"@ tag to the @GET@ endpoints and @\"post\"@ tag to the @POST@ endpoint of the User API.

148+

149+-- $test

150+-- Automatic generation of data schemas uses @'ToSchema'@ instances for the types

151+-- used in a servant API. But to encode/decode actual data servant uses different classes.

152+-- For instance in @UserAPI@ @User@ is always encoded/decoded using @'ToJSON'@ and @'FromJSON'@ instances.

153+--

154+-- To be sure your Haskell server/client handles data properly you need to check

155+-- that @'ToJSON'@ instance always generates values that satisfy schema produced

156+-- by @'ToSchema'@ instance.

157+--

158+-- With @'validateEveryToJSON'@ it is possible to test all those instances automatically,

159+-- without having to write down every type:

160+--

161+-- >>> instance Arbitrary User where arbitrary = User <$> arbitrary <*> arbitrary

162+-- >>> instance Arbitrary UserId where arbitrary = UserId <$> arbitrary

163+-- >>> hspec $ validateEveryToJSON (Proxy :: Proxy UserAPI)

164+-- <BLANKLINE>

165+-- [User]...

166+-- ...

167+-- User...

168+-- ...

169+-- UserId...

170+-- ...

171+-- Finished in ... seconds

172+-- 3 examples, 0 failures

173+--

174+-- Although servant is great, chances are that your API clients don't use Haskell.

175+-- In many cases @swagger.json@ serves as a specification, not a Haskell type.

176+--

177+-- In this cases it is a good idea to store generated and annotated @'Swagger'@ in a @swagger.json@ file

178+-- under a version control system (such as Git, Subversion, Mercurial, etc.).

179+--

180+-- It is also recommended to version API based on changes to the @swagger.json@ rather than changes

181+-- to the Haskell API.

182+--

183+-- See <example/test/TodoSpec.hs TodoSpec.hs> for an example of a complete test suite for a swagger specification.

184+

185+-- $serve

186+-- If you're implementing a server for an API, you might also want to serve its @'Swagger'@ specification.

187+--

188+-- See <example/src/Todo.hs Todo.hs> for an example of a server.

servant-swagger/src/Servant/Swagger/Internal.hsnew file+488

@@ -0,0 +1,488 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE ConstraintKinds #-}

3+{-# LANGUAGE DataKinds #-}

4+{-# LANGUAGE FlexibleContexts #-}

5+{-# LANGUAGE FlexibleInstances #-}

6+{-# LANGUAGE OverloadedLists #-}

7+{-# LANGUAGE OverloadedStrings #-}

8+{-# LANGUAGE PolyKinds #-}

9+{-# LANGUAGE RankNTypes #-}

10+{-# LANGUAGE ScopedTypeVariables #-}

11+{-# LANGUAGE TypeOperators #-}

12+{-# LANGUAGE TypeFamilies #-}

13+#if __GLASGOW_HASKELL__ >= 806

14+{-# LANGUAGE UndecidableInstances #-}

15+#endif

16+module Servant.Swagger.Internal where

17+

18+import Prelude ()

19+import Prelude.Compat

20+

21+import Control.Applicative ((<|>))

22+import Control.Lens

23+import Data.Aeson

24+import Data.HashMap.Strict.InsOrd (InsOrdHashMap)

25+import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap

26+import Data.Foldable (toList)

27+import Data.Proxy

28+import Data.Typeable

29+import Data.Singletons.Bool

30+import Data.Swagger hiding (Header)

31+import qualified Data.Swagger as Swagger

32+import Data.Swagger.Declare

33+import Data.Text (Text)

34+import qualified Data.Text as Text

35+import GHC.Generics (D1, Meta(..), Rep)

36+import GHC.TypeLits

37+import Network.HTTP.Media (MediaType)

38+import Servant.API

39+import Servant.API.Description (FoldDescription,

40+ reflectDescription)

41+import Servant.API.Generic (ToServantApi, AsApi)

42+import Servant.API.Modifiers (FoldRequired)

43+

44+import Servant.Swagger.Internal.TypeLevel.API

45+

46+-- | Generate a Swagger specification for a servant API.

47+--

48+-- To generate Swagger specification, your data types need

49+-- @'ToParamSchema'@ and/or @'ToSchema'@ instances.

50+--

51+-- @'ToParamSchema'@ is used for @'Capture'@, @'QueryParam'@ and @'Header'@.

52+-- @'ToSchema'@ is used for @'ReqBody'@ and response data types.

53+--

54+-- You can easily derive those instances via @Generic@.

55+-- For more information, refer to <http://hackage.haskell.org/package/swagger2/docs/Data-Swagger.html swagger2 documentation>.

56+--

57+-- Example:

58+--

59+-- @

60+-- newtype Username = Username String deriving (Generic, ToText)

61+--

62+-- instance ToParamSchema Username

63+--

64+-- data User = User

65+-- { username :: Username

66+-- , fullname :: String

67+-- } deriving (Generic)

68+--

69+-- instance ToJSON User

70+-- instance ToSchema User

71+--

72+-- type MyAPI = QueryParam "username" Username :> Get '[JSON] User

73+--

74+-- mySwagger :: Swagger

75+-- mySwagger = toSwagger (Proxy :: Proxy MyAPI)

76+-- @

77+class HasSwagger api where

78+ -- | Generate a Swagger specification for a servant API.

79+ toSwagger :: Proxy api -> Swagger

80+

81+instance HasSwagger Raw where

82+ toSwagger _ = mempty & paths . at "/" ?~ mempty

83+

84+instance HasSwagger EmptyAPI where

85+ toSwagger _ = mempty

86+

87+-- | All operations of sub API.

88+-- This is similar to @'operationsOf'@ but ensures that operations

89+-- indeed belong to the API at compile time.

90+subOperations :: (IsSubAPI sub api, HasSwagger sub) =>

91+ Proxy sub -- ^ Part of a servant API.

92+ -> Proxy api -- ^ The whole servant API.

93+ -> Traversal' Swagger Operation

94+subOperations sub _ = operationsOf (toSwagger sub)

95+

96+-- | Make a singleton Swagger spec (with only one endpoint).

97+-- For endpoints with no content see 'mkEndpointNoContent'.

98+mkEndpoint :: forall a cs hs proxy method status.

99+ (ToSchema a, AllAccept cs, AllToResponseHeader hs, SwaggerMethod method, KnownNat status)

100+ => FilePath -- ^ Endpoint path.

101+ -> proxy (Verb method status cs (Headers hs a)) -- ^ Method, content-types, headers and response.

102+ -> Swagger

103+mkEndpoint path proxy

104+ = mkEndpointWithSchemaRef (Just ref) path proxy

105+ & definitions .~ defs

106+ where

107+ (defs, ref) = runDeclare (declareSchemaRef (Proxy :: Proxy a)) mempty

108+

109+-- | Make a singletone 'Swagger' spec (with only one endpoint) and with no content schema.

110+mkEndpointNoContent :: forall nocontent cs hs proxy method status.

111+ (AllAccept cs, AllToResponseHeader hs, SwaggerMethod method, KnownNat status)

112+ => FilePath -- ^ Endpoint path.

113+ -> proxy (Verb method status cs (Headers hs nocontent)) -- ^ Method, content-types, headers and response.

114+ -> Swagger

115+mkEndpointNoContent path proxy

116+ = mkEndpointWithSchemaRef Nothing path proxy

117+

118+-- | Like @'mkEndpoint'@ but with explicit schema reference.

119+-- Unlike @'mkEndpoint'@ this function does not update @'definitions'@.

120+mkEndpointWithSchemaRef :: forall cs hs proxy method status a.

121+ (AllAccept cs, AllToResponseHeader hs, SwaggerMethod method, KnownNat status)

122+ => Maybe (Referenced Schema)

123+ -> FilePath

124+ -> proxy (Verb method status cs (Headers hs a))

125+ -> Swagger

126+mkEndpointWithSchemaRef mref path _ = mempty

127+ & paths.at path ?~

128+ (mempty & method ?~ (mempty

129+ & produces ?~ MimeList responseContentTypes

130+ & at code ?~ Inline (mempty

131+ & schema .~ mref

132+ & headers .~ responseHeaders)))

133+ where

134+ method = swaggerMethod (Proxy :: Proxy method)

135+ code = fromIntegral (natVal (Proxy :: Proxy status))

136+ responseContentTypes = allContentType (Proxy :: Proxy cs)

137+ responseHeaders = toAllResponseHeaders (Proxy :: Proxy hs)

138+

139+mkEndpointNoContentVerb :: forall proxy method.

140+ (SwaggerMethod method)

141+ => FilePath -- ^ Endpoint path.

142+ -> proxy (NoContentVerb method) -- ^ Method

143+ -> Swagger

144+mkEndpointNoContentVerb path _ = mempty

145+ & paths.at path ?~

146+ (mempty & method ?~ (mempty

147+ & at code ?~ Inline mempty))

148+ where

149+ method = swaggerMethod (Proxy :: Proxy method)

150+ code = 204 -- hardcoded in servant-server

151+

152+-- | Add parameter to every operation in the spec.

153+addParam :: Param -> Swagger -> Swagger

154+addParam param = allOperations.parameters %~ (Inline param :)

155+

156+-- | Add a tag to every operation in the spec.

157+addTag :: Text -> Swagger -> Swagger

158+addTag tag = allOperations.tags %~ ([tag] <>)

159+

160+-- | Add accepted content types to every operation in the spec.

161+addConsumes :: [MediaType] -> Swagger -> Swagger

162+addConsumes cs = allOperations.consumes %~ (<> Just (MimeList cs))

163+

164+-- | Format given text as inline code in Markdown.

165+markdownCode :: Text -> Text

166+markdownCode s = "`" <> s <> "`"

167+

168+addDefaultResponse400 :: ParamName -> Swagger -> Swagger

169+addDefaultResponse400 pname = setResponseWith (\old _new -> alter400 old) 400 (return response400)

170+ where

171+ sname = markdownCode pname

172+ description400 = "Invalid " <> sname

173+ alter400 = description %~ (<> (" or " <> sname))

174+ response400 = mempty & description .~ description400

175+

176+-- | Methods, available for Swagger.

177+class SwaggerMethod method where

178+ swaggerMethod :: proxy method -> Lens' PathItem (Maybe Operation)

179+

180+instance SwaggerMethod 'GET where swaggerMethod _ = get

181+instance SwaggerMethod 'PUT where swaggerMethod _ = put

182+instance SwaggerMethod 'POST where swaggerMethod _ = post

183+instance SwaggerMethod 'DELETE where swaggerMethod _ = delete

184+instance SwaggerMethod 'OPTIONS where swaggerMethod _ = options

185+instance SwaggerMethod 'HEAD where swaggerMethod _ = head_

186+instance SwaggerMethod 'PATCH where swaggerMethod _ = patch

187+

188+instance HasSwagger (UVerb method cs '[]) where

189+ toSwagger _ = mempty

190+

191+-- | @since <TODO>

192+instance

193+ {-# OVERLAPPABLE #-}

194+ ( ToSchema a,

195+ HasStatus a,

196+ AllAccept cs,

197+ SwaggerMethod method,

198+ HasSwagger (UVerb method cs as)

199+ ) =>

200+ HasSwagger (UVerb method cs (a ': as))

201+ where

202+ toSwagger _ =

203+ toSwagger (Proxy :: Proxy (Verb method (StatusOf a) cs a))

204+ `combineSwagger` toSwagger (Proxy :: Proxy (UVerb method cs as))

205+

206+-- ATTENTION: do not remove this instance!

207+-- A similar instance above will always use the more general

208+-- polymorphic -- HasSwagger instance and will result in a type error

209+-- since 'NoContent' does not have a 'ToSchema' instance.

210+instance

211+ ( KnownNat status,

212+ AllAccept cs,

213+ SwaggerMethod method,

214+ HasSwagger (UVerb method cs as)

215+ ) =>

216+ HasSwagger (UVerb method cs (WithStatus status NoContent ': as))

217+ where

218+ toSwagger _ =

219+ toSwagger (Proxy :: Proxy (Verb method status cs NoContent))

220+ `combineSwagger` toSwagger (Proxy :: Proxy (UVerb method cs as))

221+

222+

223+-- workaround for https://github.com/GetShopTV/swagger2/issues/218

224+-- We'd like to juse use (<>) but the instances are wrong

225+combinePathItem :: PathItem -> PathItem -> PathItem

226+combinePathItem s t = PathItem

227+ { _pathItemGet = _pathItemGet s <> _pathItemGet t

228+ , _pathItemPut = _pathItemPut s <> _pathItemPut t

229+ , _pathItemPost = _pathItemPost s <> _pathItemPost t

230+ , _pathItemDelete = _pathItemDelete s <> _pathItemDelete t

231+ , _pathItemOptions = _pathItemOptions s <> _pathItemOptions t

232+ , _pathItemHead = _pathItemHead s <> _pathItemHead t

233+ , _pathItemPatch = _pathItemPatch s <> _pathItemPatch t

234+ , _pathItemParameters = _pathItemParameters s <> _pathItemParameters t

235+ }

236+

237+combineSwagger :: Swagger -> Swagger -> Swagger

238+combineSwagger s t = Swagger

239+ { _swaggerInfo = _swaggerInfo s <> _swaggerInfo t

240+ , _swaggerHost = _swaggerHost s <|> _swaggerHost t

241+ , _swaggerBasePath = _swaggerBasePath s <|> _swaggerBasePath t

242+ , _swaggerSchemes = _swaggerSchemes s <> _swaggerSchemes t

243+ , _swaggerConsumes = _swaggerConsumes s <> _swaggerConsumes t

244+ , _swaggerProduces = _swaggerProduces s <> _swaggerProduces t

245+ , _swaggerPaths = InsOrdHashMap.unionWith combinePathItem (_swaggerPaths s) (_swaggerPaths t)

246+ , _swaggerDefinitions = _swaggerDefinitions s <> _swaggerDefinitions t

247+ , _swaggerParameters = _swaggerParameters s <> _swaggerParameters t

248+ , _swaggerResponses = _swaggerResponses s <> _swaggerResponses t

249+ , _swaggerSecurityDefinitions = _swaggerSecurityDefinitions s <> _swaggerSecurityDefinitions t

250+ , _swaggerSecurity = _swaggerSecurity s <> _swaggerSecurity t

251+ , _swaggerTags = _swaggerTags s <> _swaggerTags t

252+ , _swaggerExternalDocs = _swaggerExternalDocs s <|> _swaggerExternalDocs t

253+ }

254+

255+instance {-# OVERLAPPABLE #-} (ToSchema a, AllAccept cs, KnownNat status, SwaggerMethod method) => HasSwagger (Verb method status cs a) where

256+ toSwagger _ = toSwagger (Proxy :: Proxy (Verb method status cs (Headers '[] a)))

257+

258+-- | @since 1.1.7

259+instance (ToSchema a, Accept ct, KnownNat status, SwaggerMethod method) => HasSwagger (Stream method status fr ct a) where

260+ toSwagger _ = toSwagger (Proxy :: Proxy (Verb method status '[ct] (Headers '[] a)))

261+

262+instance {-# OVERLAPPABLE #-} (ToSchema a, AllAccept cs, AllToResponseHeader hs, KnownNat status, SwaggerMethod method)

263+ => HasSwagger (Verb method status cs (Headers hs a)) where

264+ toSwagger = mkEndpoint "/"

265+

266+-- ATTENTION: do not remove this instance!

267+-- A similar instance above will always use the more general

268+-- polymorphic -- HasSwagger instance and will result in a type error

269+-- since 'NoContent' does not have a 'ToSchema' instance.

270+instance (AllAccept cs, KnownNat status, SwaggerMethod method) => HasSwagger (Verb method status cs NoContent) where

271+ toSwagger _ = toSwagger (Proxy :: Proxy (Verb method status cs (Headers '[] NoContent)))

272+

273+instance (AllAccept cs, AllToResponseHeader hs, KnownNat status, SwaggerMethod method)

274+ => HasSwagger (Verb method status cs (Headers hs NoContent)) where

275+ toSwagger = mkEndpointNoContent "/"

276+

277+instance (SwaggerMethod method) => HasSwagger (NoContentVerb method) where

278+ toSwagger = mkEndpointNoContentVerb "/"

279+

280+instance (HasSwagger a, HasSwagger b) => HasSwagger (a :<|> b) where

281+ toSwagger _ = toSwagger (Proxy :: Proxy a) <> toSwagger (Proxy :: Proxy b)

282+

283+-- | @'Vault'@ combinator does not change our specification at all.

284+instance (HasSwagger sub) => HasSwagger (Vault :> sub) where

285+ toSwagger _ = toSwagger (Proxy :: Proxy sub)

286+

287+-- | @'IsSecure'@ combinator does not change our specification at all.

288+instance (HasSwagger sub) => HasSwagger (IsSecure :> sub) where

289+ toSwagger _ = toSwagger (Proxy :: Proxy sub)

290+

291+-- | @'RemoteHost'@ combinator does not change our specification at all.

292+instance (HasSwagger sub) => HasSwagger (RemoteHost :> sub) where

293+ toSwagger _ = toSwagger (Proxy :: Proxy sub)

294+

295+-- | @'Fragment'@ combinator does not change our specification at all.

296+instance HasSwagger sub => HasSwagger (Fragment a :> sub) where

297+ toSwagger _ = toSwagger (Proxy :: Proxy sub)

298+

299+-- | @'HttpVersion'@ combinator does not change our specification at all.

300+instance (HasSwagger sub) => HasSwagger (HttpVersion :> sub) where

301+ toSwagger _ = toSwagger (Proxy :: Proxy sub)

302+

303+-- | @'WithNamedContext'@ combinator does not change our specification at all.

304+instance (HasSwagger sub) => HasSwagger (WithNamedContext x c sub) where

305+ toSwagger _ = toSwagger (Proxy :: Proxy sub)

306+

307+instance (KnownSymbol sym, HasSwagger sub) => HasSwagger (sym :> sub) where

308+ toSwagger _ = prependPath piece (toSwagger (Proxy :: Proxy sub))

309+ where

310+ piece = symbolVal (Proxy :: Proxy sym)

311+

312+instance (KnownSymbol sym, Typeable a, ToParamSchema a, HasSwagger sub, KnownSymbol (FoldDescription mods)) => HasSwagger (Capture' mods sym a :> sub) where

313+ toSwagger _ = toSwagger (Proxy :: Proxy sub)

314+ & addParam param

315+ & prependPath capture

316+ & addDefaultResponse400 tname

317+ where

318+ symbol = symbolVal (Proxy :: Proxy sym)

319+ pname = if symbol == ""

320+ then camelTo2 '-' . tyConName . typeRepTyCon $ typeRep (Proxy :: Proxy a)

321+ else symbol

322+ tname = Text.pack pname

323+ transDesc "" = Nothing

324+ transDesc desc = Just (Text.pack desc)

325+ capture = "{" <> pname <> "}"

326+ param = mempty

327+ & name .~ tname

328+ & description .~ transDesc (reflectDescription (Proxy :: Proxy mods))

329+ & required ?~ True

330+ & schema .~ ParamOther (mempty

331+ & in_ .~ ParamPath

332+ & paramSchema .~ toParamSchema (Proxy :: Proxy a))

333+

334+-- | Swagger Spec doesn't have a notion of CaptureAll, this instance is the best effort.

335+instance (KnownSymbol sym, Typeable a, ToParamSchema a, HasSwagger sub) => HasSwagger (CaptureAll sym a :> sub) where

336+ toSwagger _ = toSwagger (Proxy :: Proxy (Capture sym a :> sub))

337+

338+instance (KnownSymbol desc, HasSwagger api) => HasSwagger (Description desc :> api) where

339+ toSwagger _ = toSwagger (Proxy :: Proxy api)

340+ & allOperations.description %~ (Just (Text.pack (symbolVal (Proxy :: Proxy desc))) <>)

341+

342+instance (KnownSymbol desc, HasSwagger api) => HasSwagger (Summary desc :> api) where

343+ toSwagger _ = toSwagger (Proxy :: Proxy api)

344+ & allOperations.summary %~ (Just (Text.pack (symbolVal (Proxy :: Proxy desc))) <>)

345+

346+instance (KnownSymbol sym, ToParamSchema a, HasSwagger sub, SBoolI (FoldRequired mods), KnownSymbol (FoldDescription mods)) => HasSwagger (QueryParam' mods sym a :> sub) where

347+ toSwagger _ = toSwagger (Proxy :: Proxy sub)

348+ & addParam param

349+ & addDefaultResponse400 tname

350+ where

351+ tname = Text.pack (symbolVal (Proxy :: Proxy sym))

352+ transDesc "" = Nothing

353+ transDesc desc = Just (Text.pack desc)

354+ param = mempty

355+ & name .~ tname

356+ & description .~ transDesc (reflectDescription (Proxy :: Proxy mods))

357+ & required ?~ reflectBool (Proxy :: Proxy (FoldRequired mods))

358+ & schema .~ ParamOther sch

359+ sch = mempty

360+ & in_ .~ ParamQuery

361+ & paramSchema .~ toParamSchema (Proxy :: Proxy a)

362+

363+instance (KnownSymbol sym, ToParamSchema a, HasSwagger sub) => HasSwagger (QueryParams sym a :> sub) where

364+ toSwagger _ = toSwagger (Proxy :: Proxy sub)

365+ & addParam param

366+ & addDefaultResponse400 tname

367+ where

368+ tname = Text.pack (symbolVal (Proxy :: Proxy sym))

369+ param = mempty

370+ & name .~ tname

371+ & schema .~ ParamOther sch

372+ sch = mempty

373+ & in_ .~ ParamQuery

374+ & paramSchema .~ pschema

375+ pschema = mempty

376+#if MIN_VERSION_swagger2(2,4,0)

377+ & type_ ?~ SwaggerArray

378+#else

379+ & type_ .~ SwaggerArray

380+#endif

381+ & items ?~ SwaggerItemsPrimitive (Just CollectionMulti) (toParamSchema (Proxy :: Proxy a))

382+

383+instance (KnownSymbol sym, HasSwagger sub) => HasSwagger (QueryFlag sym :> sub) where

384+ toSwagger _ = toSwagger (Proxy :: Proxy sub)

385+ & addParam param

386+ & addDefaultResponse400 tname

387+ where

388+ tname = Text.pack (symbolVal (Proxy :: Proxy sym))

389+ param = mempty

390+ & name .~ tname

391+ & schema .~ ParamOther (mempty

392+ & in_ .~ ParamQuery

393+ & allowEmptyValue ?~ True

394+ & paramSchema .~ (toParamSchema (Proxy :: Proxy Bool)

395+ & default_ ?~ toJSON False))

396+

397+instance (KnownSymbol sym, ToParamSchema a, HasSwagger sub, SBoolI (FoldRequired mods), KnownSymbol (FoldDescription mods)) => HasSwagger (Header' mods sym a :> sub) where

398+ toSwagger _ = toSwagger (Proxy :: Proxy sub)

399+ & addParam param

400+ & addDefaultResponse400 tname

401+ where

402+ tname = Text.pack (symbolVal (Proxy :: Proxy sym))

403+ transDesc "" = Nothing

404+ transDesc desc = Just (Text.pack desc)

405+ param = mempty

406+ & name .~ tname

407+ & description .~ transDesc (reflectDescription (Proxy :: Proxy mods))

408+ & required ?~ reflectBool (Proxy :: Proxy (FoldRequired mods))

409+ & schema .~ ParamOther (mempty

410+ & in_ .~ ParamHeader

411+ & paramSchema .~ toParamSchema (Proxy :: Proxy a))

412+

413+instance (ToSchema a, AllAccept cs, HasSwagger sub, KnownSymbol (FoldDescription mods)) => HasSwagger (ReqBody' mods cs a :> sub) where

414+ toSwagger _ = toSwagger (Proxy :: Proxy sub)

415+ & addParam param

416+ & addConsumes (allContentType (Proxy :: Proxy cs))

417+ & addDefaultResponse400 tname

418+ & definitions %~ (<> defs)

419+ where

420+ tname = "body"

421+ transDesc "" = Nothing

422+ transDesc desc = Just (Text.pack desc)

423+ (defs, ref) = runDeclare (declareSchemaRef (Proxy :: Proxy a)) mempty

424+ param = mempty

425+ & name .~ tname

426+ & description .~ transDesc (reflectDescription (Proxy :: Proxy mods))

427+ & required ?~ True

428+ & schema .~ ParamBody ref

429+

430+-- | This instance is an approximation.

431+--

432+-- @since 1.1.7

433+instance (ToSchema a, Accept ct, HasSwagger sub, KnownSymbol (FoldDescription mods)) => HasSwagger (StreamBody' mods fr ct a :> sub) where

434+ toSwagger _ = toSwagger (Proxy :: Proxy sub)

435+ & addParam param

436+ & addConsumes (toList (contentTypes (Proxy :: Proxy ct)))

437+ & addDefaultResponse400 tname

438+ & definitions %~ (<> defs)

439+ where

440+ tname = "body"

441+ transDesc "" = Nothing

442+ transDesc desc = Just (Text.pack desc)

443+ (defs, ref) = runDeclare (declareSchemaRef (Proxy :: Proxy a)) mempty

444+ param = mempty

445+ & name .~ tname

446+ & description .~ transDesc (reflectDescription (Proxy :: Proxy mods))

447+ & required ?~ True

448+ & schema .~ ParamBody ref

449+

450+instance (HasSwagger (ToServantApi routes), KnownSymbol datatypeName, Rep (routes AsApi) ~ D1 ('MetaData datatypeName moduleName packageName isNewtype) f) => HasSwagger (NamedRoutes routes) where

451+ toSwagger _ = addTag (Text.pack $ symbolVal (Proxy :: Proxy datatypeName)) (toSwagger (Proxy :: Proxy (ToServantApi routes)))

452+

453+-- =======================================================================

454+-- Below are the definitions that should be in Servant.API.ContentTypes

455+-- =======================================================================

456+

457+class AllAccept cs where

458+ allContentType :: Proxy cs -> [MediaType]

459+

460+instance AllAccept '[] where

461+ allContentType _ = []

462+

463+instance (Accept c, AllAccept cs) => AllAccept (c ': cs) where

464+ allContentType _ = contentType (Proxy :: Proxy c) : allContentType (Proxy :: Proxy cs)

465+

466+class ToResponseHeader h where

467+ toResponseHeader :: Proxy h -> (HeaderName, Swagger.Header)

468+

469+instance (KnownSymbol sym, ToParamSchema a) => ToResponseHeader (Header sym a) where

470+ toResponseHeader _ = (hname, Swagger.Header Nothing hschema)

471+ where

472+ hname = Text.pack (symbolVal (Proxy :: Proxy sym))

473+ hschema = toParamSchema (Proxy :: Proxy a)

474+

475+class AllToResponseHeader hs where

476+ toAllResponseHeaders :: Proxy hs -> InsOrdHashMap HeaderName Swagger.Header

477+

478+instance AllToResponseHeader '[] where

479+ toAllResponseHeaders _ = mempty

480+

481+instance (ToResponseHeader h, AllToResponseHeader hs) => AllToResponseHeader (h ': hs) where

482+ toAllResponseHeaders _ = InsOrdHashMap.insert headerName headerBS hdrs

483+ where

484+ (headerName, headerBS) = toResponseHeader (Proxy :: Proxy h)

485+ hdrs = toAllResponseHeaders (Proxy :: Proxy hs)

486+

487+instance AllToResponseHeader hs => AllToResponseHeader (HList hs) where

488+ toAllResponseHeaders _ = toAllResponseHeaders (Proxy :: Proxy hs)

servant-swagger/src/Servant/Swagger/Internal/Orphans.hsnew file+27

@@ -0,0 +1,27 @@

1+{-# OPTIONS_GHC -fno-warn-orphans #-}

2+{-# LANGUAGE CPP #-}

3+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4+{-# LANGUAGE ScopedTypeVariables #-}

5+{-# LANGUAGE StandaloneDeriving #-}

6+module Servant.Swagger.Internal.Orphans where

7+

8+import Data.Proxy

9+ (Proxy (..))

10+import Data.Swagger

11+import Servant.Types.SourceT

12+ (SourceT)

13+#if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)

14+import Servant.API (WithStatus(..))

15+#endif

16+

17+-- | Pretend that 'SourceT m a' is '[a]'.

18+--

19+-- @since 1.1.7

20+--

21+instance ToSchema a => ToSchema (SourceT m a) where

22+ declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])

23+

24+#if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)

25+-- @since 1.1.11

26+deriving instance ToSchema a => ToSchema (WithStatus s a)

27+#endif

servant-swagger/src/Servant/Swagger/Internal/Test.hsnew file+207

@@ -0,0 +1,207 @@

1+{-# LANGUAGE ConstraintKinds #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE FlexibleContexts #-}

4+{-# LANGUAGE RankNTypes #-}

5+{-# LANGUAGE ScopedTypeVariables #-}

6+{-# LANGUAGE TypeOperators #-}

7+{-# LANGUAGE OverloadedStrings #-}

8+module Servant.Swagger.Internal.Test where

9+

10+import Data.Aeson (ToJSON (..))

11+import Data.Aeson.Encode.Pretty (encodePretty', defConfig,

12+ confCompare)

13+import Data.Swagger (Pattern, ToSchema,

14+ toSchema)

15+import Data.Swagger.Schema.Validation

16+import Data.Text (Text)

17+import qualified Data.Text.Lazy as TL

18+import qualified Data.Text.Lazy.Encoding as TL

19+import Data.Typeable

20+import Test.Hspec

21+import Test.Hspec.QuickCheck

22+import Test.QuickCheck (Arbitrary, Property,

23+ counterexample, property)

24+

25+import Servant.API

26+import Servant.Swagger.Internal.TypeLevel

27+

28+-- $setup

29+-- >>> import Control.Applicative

30+-- >>> import GHC.Generics

31+-- >>> import Test.QuickCheck

32+-- >>> import System.Environment (setEnv)

33+-- >>> :set -XDeriveGeneric

34+-- >>> :set -XGeneralizedNewtypeDeriving

35+-- >>> :set -XDataKinds

36+-- >>> :set -XTypeOperators

37+-- >>> setEnv "HSPEC_COLOR" "no"

38+

39+-- | Verify that every type used with @'JSON'@ content type in a servant API

40+-- has compatible @'ToJSON'@ and @'ToSchema'@ instances using @'validateToJSON'@.

41+--

42+-- /NOTE:/ @'validateEveryToJSON'@ does not perform string pattern validation.

43+-- See @'validateEveryToJSONWithPatternChecker'@.

44+--

45+-- @'validateEveryToJSON'@ will produce one @'prop'@ specification for every type in the API.

46+-- Each type only gets one test, even if it occurs multiple times in the API.

47+--

48+-- >>> data User = User { name :: String, age :: Maybe Int } deriving (Show, Generic, Typeable)

49+-- >>> newtype UserId = UserId String deriving (Show, Generic, Typeable, ToJSON, Arbitrary)

50+-- >>> instance ToJSON User

51+-- >>> instance ToSchema User

52+-- >>> instance ToSchema UserId

53+-- >>> instance Arbitrary User where arbitrary = User <$> arbitrary <*> arbitrary

54+-- >>> type UserAPI = (Capture "user_id" UserId :> Get '[JSON] User) :<|> (ReqBody '[JSON] User :> Post '[JSON] UserId)

55+--

56+-- >>> hspec $ context "ToJSON matches ToSchema" $ validateEveryToJSON (Proxy :: Proxy UserAPI)

57+-- <BLANKLINE>

58+-- ToJSON matches ToSchema...

59+-- User...

60+-- ...

61+-- UserId...

62+-- ...

63+-- Finished in ... seconds

64+-- 2 examples, 0 failures

65+--

66+-- For the test to compile all body types should have the following instances:

67+--

68+-- * @'ToJSON'@ and @'ToSchema'@ are used to perform the validation;

69+-- * @'Typeable'@ is used to name the test for each type;

70+-- * @'Show'@ is used to display value for which @'ToJSON'@ does not satisfy @'ToSchema'@.

71+-- * @'Arbitrary'@ is used to arbitrarily generate values.

72+--

73+-- If any of the instances is missing, you'll get a descriptive type error:

74+--

75+-- >>> data Contact = Contact { fullname :: String, phone :: Integer } deriving (Show, Generic)

76+-- >>> instance ToJSON Contact

77+-- >>> instance ToSchema Contact

78+-- >>> type ContactAPI = Get '[JSON] Contact

79+-- >>> hspec $ validateEveryToJSON (Proxy :: Proxy ContactAPI)

80+-- ...

81+-- ...No instance for (Arbitrary Contact)

82+-- ... arising from a use of ‘validateEveryToJSON’

83+-- ...

84+validateEveryToJSON

85+ :: forall proxy api .

86+ TMap (Every [Typeable, Show, Arbitrary, ToJSON, ToSchema])

87+ (BodyTypes JSON api)

88+ => proxy api -- ^ Servant API.

89+ -> Spec

90+validateEveryToJSON _ = props

91+ (Proxy :: Proxy [ToJSON, ToSchema])

92+ (maybeCounterExample . prettyValidateWith validateToJSON)

93+ (Proxy :: Proxy (BodyTypes JSON api))

94+

95+-- | Verify that every type used with @'JSON'@ content type in a servant API

96+-- has compatible @'ToJSON'@ and @'ToSchema'@ instances using @'validateToJSONWithPatternChecker'@.

97+--

98+-- For validation without patterns see @'validateEveryToJSON'@.

99+validateEveryToJSONWithPatternChecker :: forall proxy api. TMap (Every [Typeable, Show, Arbitrary, ToJSON, ToSchema]) (BodyTypes JSON api) =>

100+ (Pattern -> Text -> Bool) -- ^ @'Pattern'@ checker.

101+ -> proxy api -- ^ Servant API.

102+ -> Spec

103+validateEveryToJSONWithPatternChecker checker _ = props

104+ (Proxy :: Proxy [ToJSON, ToSchema])

105+ (maybeCounterExample . prettyValidateWith (validateToJSONWithPatternChecker checker))

106+ (Proxy :: Proxy (BodyTypes JSON api))

107+

108+-- * QuickCheck-related stuff

109+

110+-- | Construct property tests for each type in a list.

111+-- The name for each property is the name of the corresponding type.

112+--

113+-- >>> :{

114+-- hspec $

115+-- context "read . show == id" $

116+-- props

117+-- (Proxy :: Proxy [Eq, Show, Read])

118+-- (\x -> read (show x) === x)

119+-- (Proxy :: Proxy [Bool, Int, String])

120+-- :}

121+-- <BLANKLINE>

122+-- read . show == id

123+-- Bool...

124+-- ...

125+-- Int...

126+-- ...

127+-- [Char]...

128+-- ...

129+-- Finished in ... seconds

130+-- 3 examples, 0 failures

131+props :: forall p p'' cs xs. TMap (Every (Typeable ': Show ': Arbitrary ': cs)) xs =>

132+ p cs -- ^ A list of constraints.

133+ -> (forall x. EveryTF cs x => x -> Property) -- ^ Property predicate.

134+ -> p'' xs -- ^ A list of types.

135+ -> Spec

136+props _ f px = sequence_ specs

137+ where

138+ specs :: [Spec]

139+ specs = tmapEvery (Proxy :: Proxy (Typeable ': Show ': Arbitrary ': cs)) aprop px

140+

141+ aprop :: forall p' a. (EveryTF cs a, Typeable a, Show a, Arbitrary a) => p' a -> Spec

142+ aprop _ = prop (show (typeOf (undefined :: a))) (f :: a -> Property)

143+

144+-- | Pretty print validation errors

145+-- together with actual JSON and Swagger Schema

146+-- (using 'encodePretty').

147+--

148+-- >>> import Data.Aeson

149+-- >>> import Data.Foldable (traverse_)

150+-- >>> data Person = Person { name :: String, phone :: Integer } deriving (Generic)

151+-- >>> instance ToJSON Person where toJSON p = object [ "name" .= name p ]

152+-- >>> instance ToSchema Person

153+-- >>> let person = Person { name = "John", phone = 123456 }

154+-- >>> traverse_ putStrLn $ prettyValidateWith validateToJSON person

155+-- Validation against the schema fails:

156+-- * property "phone" is required, but not found in "{\"name\":\"John\"}"

157+-- <BLANKLINE>

158+-- JSON value:

159+-- {

160+-- "name": "John"

161+-- }

162+-- <BLANKLINE>

163+-- Swagger Schema:

164+-- {

165+-- "properties": {

166+-- "name": {

167+-- "type": "string"

168+-- },

169+-- "phone": {

170+-- "type": "integer"

171+-- }

172+-- },

173+-- "required": [

174+-- "name",

175+-- "phone"

176+-- ],

177+-- "type": "object"

178+-- }

179+-- <BLANKLINE>

180+--

181+-- FIXME: this belongs in "Data.Swagger.Schema.Validation" (in @swagger2@).

182+prettyValidateWith

183+ :: forall a. (ToJSON a, ToSchema a)

184+ => (a -> [ValidationError]) -> a -> Maybe String

185+prettyValidateWith f x =

186+ case f x of

187+ [] -> Nothing

188+ errors -> Just $ unlines

189+ [ "Validation against the schema fails:"

190+ , unlines (map (" * " ++) errors)

191+ , "JSON value:"

192+ , ppJSONString json

193+ , ""

194+ , "Swagger Schema:"

195+ , ppJSONString (toJSON schema)

196+ ]

197+ where

198+ ppJSONString = TL.unpack . TL.decodeUtf8 . encodePretty' ppCfg

199+ ppCfg = defConfig { confCompare = compare }

200+

201+ json = toJSON x

202+ schema = toSchema (Proxy :: Proxy a)

203+

204+-- | Provide a counterexample if there is any.

205+maybeCounterExample :: Maybe String -> Property

206+maybeCounterExample Nothing = property True

207+maybeCounterExample (Just s) = counterexample s (property False)

servant-swagger/src/Servant/Swagger/Internal/TypeLevel.hsnew file+9

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

1+module Servant.Swagger.Internal.TypeLevel (

2+ module Servant.Swagger.Internal.TypeLevel.API,

3+ module Servant.Swagger.Internal.TypeLevel.Every,

4+ module Servant.Swagger.Internal.TypeLevel.TMap,

5+) where

6+

7+import Servant.Swagger.Internal.TypeLevel.API

8+import Servant.Swagger.Internal.TypeLevel.Every

9+import Servant.Swagger.Internal.TypeLevel.TMap

servant-swagger/src/Servant/Swagger/Internal/TypeLevel/API.hsnew file+86

@@ -0,0 +1,86 @@

1+{-# LANGUAGE ConstraintKinds #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE KindSignatures #-}

4+{-# LANGUAGE PolyKinds #-}

5+{-# LANGUAGE TypeFamilies #-}

6+{-# LANGUAGE TypeOperators #-}

7+{-# LANGUAGE UndecidableInstances #-}

8+module Servant.Swagger.Internal.TypeLevel.API where

9+

10+import GHC.Exts (Constraint)

11+import Servant.API

12+

13+-- | Build a list of endpoints from an API.

14+type family EndpointsList api where

15+ EndpointsList (a :<|> b) = AppendList (EndpointsList a) (EndpointsList b)

16+ EndpointsList (e :> a) = MapSub e (EndpointsList a)

17+ EndpointsList a = '[a]

18+

19+-- | Check whether @sub@ is a sub API of @api@.

20+type family IsSubAPI sub api :: Constraint where

21+ IsSubAPI sub api = AllIsElem (EndpointsList sub) api

22+

23+-- | Check that every element of @xs@ is an endpoint of @api@.

24+type family AllIsElem xs api :: Constraint where

25+ AllIsElem '[] api = ()

26+ AllIsElem (x ': xs) api = (IsIn x api, AllIsElem xs api)

27+

28+-- | Apply @(e :>)@ to every API in @xs@.

29+type family MapSub e xs where

30+ MapSub e '[] = '[]

31+ MapSub e (x ': xs) = (e :> x) ': MapSub e xs

32+

33+-- | Append two type-level lists.

34+type family AppendList xs ys where

35+ AppendList '[] ys = ys

36+ AppendList (x ': xs) ys = x ': AppendList xs ys

37+

38+type family Or (a :: Constraint) (b :: Constraint) :: Constraint where

39+ Or () b = ()

40+ Or a () = ()

41+

42+type family IsIn sub api :: Constraint where

43+ IsIn e (a :<|> b) = Or (IsIn e a) (IsIn e b)

44+ IsIn (e :> a) (e :> b) = IsIn a b

45+ IsIn e e = ()

46+

47+-- | Check whether a type is a member of a list of types.

48+-- This is a type-level analogue of @'elem'@.

49+type family Elem x xs where

50+ Elem x '[] = 'False

51+ Elem x (x ': xs) = 'True

52+ Elem x (y ': xs) = Elem x xs

53+

54+-- | Remove duplicates from a type-level list.

55+type family Nub xs where

56+ Nub '[] = '[]

57+ Nub (x ': xs) = x ': Nub (Remove x xs)

58+

59+-- | Remove element from a type-level list.

60+type family Remove x xs where

61+ Remove x '[] = '[]

62+ Remove x (x ': ys) = Remove x ys

63+ Remove x (y ': ys) = y ': Remove x ys

64+

65+-- | Extract a list of unique "body" types for a specific content-type from a servant API.

66+type BodyTypes c api = Nub (BodyTypes' c api)

67+

68+-- | @'AddBodyType' c cs a as@ adds type @a@ to the list @as@

69+-- only if @c@ is in @cs@.

70+type AddBodyType c cs a as = If (Elem c cs) (a ': as) as

71+

72+-- | Extract a list of "body" types for a specific content-type from a servant API.

73+-- To extract unique types see @'BodyTypes'@.

74+--

75+-- @'NoContent'@ is removed from the list and not tested. (This allows for leaving the body

76+-- completely empty on responses to requests that only accept 'application/json', while

77+-- setting the content-type in the response accordingly.)

78+type family BodyTypes' c api :: [*] where

79+ BodyTypes' c (Verb verb b cs (Headers hdrs a)) = AddBodyType c cs a '[]

80+ BodyTypes' c (Verb verb b cs NoContent) = '[]

81+ BodyTypes' c (Verb verb b cs a) = AddBodyType c cs a '[]

82+ BodyTypes' c (ReqBody' mods cs a :> api) = AddBodyType c cs a (BodyTypes' c api)

83+ BodyTypes' c (e :> api) = BodyTypes' c api

84+ BodyTypes' c (a :<|> b) = AppendList (BodyTypes' c a) (BodyTypes' c b)

85+ BodyTypes' c api = '[]

86+

servant-swagger/src/Servant/Swagger/Internal/TypeLevel/Every.hsnew file+63

@@ -0,0 +1,63 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE ConstraintKinds #-}

3+{-# LANGUAGE DataKinds #-}

4+{-# LANGUAGE FlexibleContexts #-}

5+{-# LANGUAGE FlexibleInstances #-}

6+{-# LANGUAGE GADTs #-}

7+{-# LANGUAGE InstanceSigs #-}

8+{-# LANGUAGE KindSignatures #-}

9+{-# LANGUAGE MultiParamTypeClasses #-}

10+{-# LANGUAGE PolyKinds #-}

11+{-# LANGUAGE RankNTypes #-}

12+{-# LANGUAGE ScopedTypeVariables #-}

13+{-# LANGUAGE TypeFamilies #-}

14+{-# LANGUAGE TypeOperators #-}

15+{-# LANGUAGE UndecidableInstances #-}

16+#if __GLASGOW_HASKELL__ >= 800

17+{-# LANGUAGE UndecidableSuperClasses #-}

18+#endif

19+module Servant.Swagger.Internal.TypeLevel.Every where

20+

21+import Data.Proxy

22+import GHC.Exts (Constraint)

23+

24+import Servant.Swagger.Internal.TypeLevel.TMap

25+

26+-- $setup

27+-- >>> :set -XDataKinds

28+-- >>> :set -XFlexibleContexts

29+-- >>> :set -XGADTs

30+-- >>> :set -XRankNTypes

31+-- >>> :set -XScopedTypeVariables

32+-- >>> import GHC.TypeLits

33+-- >>> import Data.List

34+

35+-- | Apply multiple constraint constructors to a type.

36+--

37+-- @

38+-- EveryTF '[Show, Read] a ~ (Show a, Read a)

39+-- @

40+--

41+-- Note that since this is a type family, you have to alway fully apply @'EveryTF'@.

42+--

43+-- For partial application of multiple constraint constructors see @'Every'@.

44+type family EveryTF cs x :: Constraint where

45+ EveryTF '[] x = ()

46+ EveryTF (c ': cs) x = (c x, EveryTF cs x)

47+

48+-- | Apply multiple constraint constructors to a type as a class.

49+--

50+-- This is different from @'EveryTF'@ in that it allows partial application.

51+class EveryTF cs x => Every (cs :: [* -> Constraint]) (x :: *) where

52+

53+instance Every '[] x where

54+instance (c x, Every cs x) => Every (c ': cs) x where

55+

56+-- | Like @'tmap'@, but uses @'Every'@ for multiple constraints.

57+--

58+-- >>> let zero :: forall p a. (Show a, Num a) => p a -> String; zero _ = show (0 :: a)

59+-- >>> tmapEvery (Proxy :: Proxy [Show, Num]) zero (Proxy :: Proxy [Int, Float]) :: [String]

60+-- ["0","0.0"]

61+tmapEvery :: forall a cs p p'' xs. (TMap (Every cs) xs) =>

62+ p cs -> (forall x p'. Every cs x => p' x -> a) -> p'' xs -> [a]

63+tmapEvery _ = tmap (Proxy :: Proxy (Every cs))

servant-swagger/src/Servant/Swagger/Internal/TypeLevel/TMap.hsnew file+37

@@ -0,0 +1,37 @@

1+{-# LANGUAGE ConstraintKinds #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE FlexibleInstances #-}

4+{-# LANGUAGE KindSignatures #-}

5+{-# LANGUAGE MultiParamTypeClasses #-}

6+{-# LANGUAGE PolyKinds #-}

7+{-# LANGUAGE RankNTypes #-}

8+{-# LANGUAGE ScopedTypeVariables #-}

9+{-# LANGUAGE TypeOperators #-}

10+{-# LANGUAGE UndecidableInstances #-}

11+module Servant.Swagger.Internal.TypeLevel.TMap where

12+

13+import Data.Proxy

14+import GHC.Exts (Constraint)

15+

16+-- $setup

17+-- >>> :set -XDataKinds

18+-- >>> :set -XFlexibleContexts

19+-- >>> :set -XGADTs

20+-- >>> :set -XRankNTypes

21+-- >>> :set -XScopedTypeVariables

22+-- >>> import GHC.TypeLits

23+-- >>> import Data.List

24+

25+-- | Map a list of constrained types to a list of values.

26+--

27+-- >>> tmap (Proxy :: Proxy KnownSymbol) symbolVal (Proxy :: Proxy ["hello", "world"])

28+-- ["hello","world"]

29+class TMap (q :: k -> Constraint) (xs :: [k]) where

30+ tmap :: p q -> (forall x p'. q x => p' x -> a) -> p'' xs -> [a]

31+

32+instance TMap q '[] where

33+ tmap _ _ _ = []

34+

35+instance (q x, TMap q xs) => TMap q (x ': xs) where

36+ tmap q f _ = f (Proxy :: Proxy x) : tmap q f (Proxy :: Proxy xs)

37+

servant-swagger/src/Servant/Swagger/Test.hsnew file+13

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

1+-- |

2+-- Module: Servant.Swagger.Test

3+-- License: BSD3

4+-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>

5+-- Stability: experimental

6+--

7+-- Automatic tests for servant API against Swagger spec.

8+module Servant.Swagger.Test (

9+ validateEveryToJSON,

10+ validateEveryToJSONWithPatternChecker,

11+) where

12+

13+import Servant.Swagger.Internal.Test

servant-swagger/src/Servant/Swagger/TypeLevel.hsnew file+15

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

1+-- |

2+-- Module: Servant.Swagger.TypeLevel

3+-- License: BSD3

4+-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>

5+-- Stability: experimental

6+--

7+-- Useful type families for servant APIs.

8+module Servant.Swagger.TypeLevel (

9+ IsSubAPI,

10+ EndpointsList,

11+ BodyTypes,

12+) where

13+

14+import Servant.Swagger.Internal.TypeLevel

15+

servant-swagger/test/Servant/SwaggerSpec.hsnew file+489

This diff is too big to show here.

servant-swagger/test/Spec.hsnew file+1

This diff is too big to show here.

servant-swagger/test/doctests.hsnew file+12

This diff is too big to show here.

servant/CHANGELOG.md+374−18

This diff is too big to show here.

servant/Setup.hs+1−32

This diff is too big to show here.

servant/servant.cabal+41−64

This diff is too big to show here.

servant/src/Servant/API.hs+21−4

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

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.hsnew file+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.hsdeleted−6

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.hsnew file+10

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

servant/src/Servant/API/Status.hsnew file+160

This diff is too big to show here.

servant/src/Servant/API/Stream.hs−2

This diff is too big to show here.

servant/src/Servant/API/TypeErrors.hsnew file+40

This diff is too big to show here.

servant/src/Servant/API/TypeLevel.hs+60−10

This diff is too big to show here.

servant/src/Servant/API/UVerb.hsnew file+124

This diff is too big to show here.

servant/src/Servant/API/UVerb/Union.hsnew file+147

This diff is too big to show here.

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

This diff is too big to show here.

servant/src/Servant/Links.hs+94−13

This diff is too big to show here.

servant/src/Servant/Test/ComprehensiveAPI.hs+4−2

This diff is too big to show here.

servant/src/Servant/Types/SourceT.hs+33−1

This diff is too big to show here.

servant/src/Servant/Utils/Links.hsdeleted−6

This diff is too big to show here.

servant/test/Servant/API/ContentTypesSpec.hs+29−5

This diff is too big to show here.

servant/test/Servant/API/StreamSpec.hs+1−1

This diff is too big to show here.

servant/test/Servant/LinksSpec.hs+18−1

This diff is too big to show here.

servant/test/doctests.hsdeleted−27

This diff is too big to show here.

stack.yaml+5−18

This diff is too big to show here.

stack.yaml.locknew file+19

This diff is too big to show here.