master..e68cf28 · typeable/servant

git.iko.soy/typeable/servant

447 files changed+9296−31922

unifiedsplit

.github/FUNDING.ymldeleted−12

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

1−# These are supported funding model platforms

2−

3−github: [arianvp]

4−patreon: # Replace with a single Patreon username

5−open_collective: # Replace with a single Open Collective username

6−ko_fi: # Replace with a single Ko-fi username

7−tidelift: # Replace with a single Tidelift platform-name/package-name e.g., npm/babel

8−community_bridge: # Replace with a single Community Bridge project-name e.g., cloud-foundry

9−liberapay: # Replace with a single Liberapay username

10−issuehunt: # Replace with a single IssueHunt username

11−otechie: # Replace with a single Otechie username

12−custom: https://github.com/haskell-servant/haskell-servant.github.io/blob/hakyll/consultancies.md

.github/run-ghcjs-tests.shdeleted−14

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

1−#!/usr/bin/env bash

2−#

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

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

5−#

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

7−

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

9−do

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

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

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

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

14−done

.github/workflows/master.ymldeleted−147

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

1−name: CI

2−

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

4−on:

5− pull_request:

6− push:

7− branches: [master]

8−

9−jobs:

10− cabal:

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

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

13− strategy:

14− matrix:

15− os: [ubuntu-latest]

16− cabal: ["3.6"]

17− ghc:

18− - "8.6.5"

19− - "8.8.4"

20− - "8.10.7"

21− - "9.0.2"

22− - "9.2.2"

23−

24− steps:

25− - uses: actions/checkout@v2

26−

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

28− id: setup-haskell-cabal

29− name: Setup Haskell

30− with:

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

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

33−

34− - name: Freeze

35− run: |

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

37− cabal freeze

38−

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

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

41− with:

42− path: |

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

44− dist-newstyle

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

46− restore-keys: |

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

48−

49− - name: Configure

50− run: |

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

52−

53− - name: Build

54− run: |

55− cabal build all

56−

57− - name: Test

58− run: |

59− cabal test all

60−

61− - name: Run doctests

62− run: |

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

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

65−

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

67− (cd servant && eval $DOCTEST)

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

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

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

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

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

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

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

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

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

77−

78− stack:

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

80− runs-on: ubuntu-latest

81− strategy:

82− matrix:

83− stack: ["2.7.5"]

84− ghc: ["8.10.7"]

85−

86− steps:

87− - uses: actions/checkout@v2

88−

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

90− name: Setup Haskell Stack

91− with:

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

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

94−

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

96− name: Cache ~/.stack

97− with:

98− path: ~/.stack

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

100−

101− - name: Install dependencies

102− run: |

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

104−

105− - name: Build

106− run: |

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

108−

109− - name: Test

110− run: |

111− stack test --system-ghc

112−

113− ghcjs:

114− name: ubuntu-latest / ghcjs 8.6

115− runs-on: "ubuntu-latest"

116−

117− steps:

118− - uses: actions/checkout@v2

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

120− with:

121− extra_nix_config: |

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

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

124− - name: Setup

125− run: |

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

127− cp cabal.ghcjs.project cabal.project

128− cat cabal.project

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

130−

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

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

133− with:

134− path: |

135− ~/.cabal/store

136− dist-newstyle

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

138− restore-keys: |

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

140−

141− - name: Build

142− run: |

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

144−

145− - name: Tests

146− run: |

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

.gitignore+2−13

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

11**/*/dist

2−*~

3−dist-*

4−.ghc.environment.*

52/bin

63/lib

74/share

@@ -26,15 +23,7 @@ cabal.config

2623*.hp

2724Setup

2825.stack-work

26+shell.nix

27+default.nix

2928doc/_build

3029doc/venv

31−doc/tutorial/static/api.js

32−doc/tutorial/static/jq.js

33−shell.nix

34−.hspec-failures

35−

36−# nix

37−result*

38−

39−# local versions of things

40−servant-multipart

.stylish-haskell.yaml+5−118

@@ -15,14 +15,6 @@ steps:

1515 # # true.

1616 # add_language_pragma: true

1717

18− # Align the right hand side of some elements. This is quite conservative

19− # and only applies to statements where each element occupies a single

20− # line.

21− - simple_align:

22− cases: false

23− top_level_patterns: false

24− records: false

25−

2618 # Import cleanup

2719 - imports:

2820 # There are different ways we can align names and lists.

@@ -41,91 +33,6 @@ steps:

4133 # Default: global.

4234 align: global

4335

44− # Folowing options affect only import list alignment.

45− #

46− # List align has following options:

47− #

48− # - after_alias: Import list is aligned with end of import including

49− # 'as' and 'hiding' keywords.

50− #

51− # > import qualified Data.List as List (concat, foldl, foldr, head,

52− # > init, last, length)

53− #

54− # - with_alias: Import list is aligned with start of alias or hiding.

55− #

56− # > import qualified Data.List as List (concat, foldl, foldr, head,

57− # > init, last, length)

58− #

59− # - new_line: Import list starts always on new line.

60− #

61− # > import qualified Data.List as List

62− # > (concat, foldl, foldr, head, init, last, length)

63− #

64− # Default: after_alias

65− list_align: new_line

66−

67− # Long list align style takes effect when import is too long. This is

68− # determined by 'columns' setting.

69− #

70− # - inline: This option will put as much specs on same line as possible.

71− #

72− # - new_line: Import list will start on new line.

73− #

74− # - new_line_multiline: Import list will start on new line when it's

75− # short enough to fit to single line. Otherwise it'll be multiline.

76− #

77− # - multiline: One line per import list entry.

78− # Type with contructor list acts like single import.

79− #

80− # > import qualified Data.Map as M

81− # > ( empty

82− # > , singleton

83− # > , ...

84− # > , delete

85− # > )

86− #

87− # Default: inline

88− long_list_align: new_line

89−

90− # Align empty list (importing instances)

91− #

92− # Empty list align has following options

93− #

94− # - inherit: inherit list_align setting

95− #

96− # - right_after: () is right after the module name:

97− #

98− # > import Vector.Instances ()

99− #

100− # Default: inherit

101− empty_list_align: right_after

102−

103− # List padding determines indentation of import list on lines after import.

104− # This option affects 'long_list_align'.

105− #

106− # - <integer>: constant value

107− #

108− # - module_name: align under start of module name.

109− # Useful for 'file' and 'group' align settings.

110− list_padding: module_name

111−

112− # Separate lists option affects formating of import list for type

113− # or class. The only difference is single space between type and list

114− # of constructors, selectors and class functions.

115− #

116− # - true: There is single space between Foldable type and list of it's

117− # functions.

118− #

119− # > import Data.Foldable (Foldable (fold, foldl, foldMap))

120− #

121− # - false: There is no space between Foldable type and list of it's

122− # functions.

123− #

124− # > import Data.Foldable (Foldable(fold, foldl, foldMap))

125− #

126− # Default: true

127− separate_lists: true

128−

12936 # Language pragmas

13037 - language_pragmas:

13138 # We can generate different styles of language pragma lists.

@@ -140,20 +47,13 @@ steps:

14047 # Default: vertical.

14148 style: vertical

14249

143− # Align affects alignment of closing pragma brackets.

144− #

145− # - true: Brackets are aligned in same collumn.

146− #

147− # - false: Brackets are not aligned together. There is only one space

148− # between actual import and closing bracket.

149− #

150− # Default: true

151− align: true

152−

15350 # stylish-haskell can detect redundancy of some language pragmas. If this

15451 # is set to true, it will remove those redundant pragmas. Default: true.

15552 remove_redundant: true

15653

54+ # Align the types in record declarations

55+ - records: {}

56+

15757 # Replace tabs by spaces. This is disabled by default.

15858 # - tabs:

15959 # # Number of spaces to use for each tab. Default: 8, as specified by the

@@ -167,24 +67,11 @@ steps:

16767# to. Different steps take this into account. Default: 80.

16868columns: 80

16969

170−# By default, line endings are converted according to the OS. You can override

171−# preferred format here.

172−#

173−# - native: Native newline format. CRLF on Windows, LF on other OSes.

174−#

175−# - lf: Convert to LF ("\n").

176−#

177−# - crlf: Convert to CRLF ("\r\n").

178−#

179−# Default: native.

180−newline: lf

181−

18270# Sometimes, language extensions are specified in a cabal file or from the

18371# command line instead of using language pragmas in the file. stylish-haskell

18472# needs to be aware of these, so it can parse the file correctly.

18573#

18674# No language extensions are enabled by default.

18775language_extensions:

188− - FlexibleContexts

189− - TemplateHaskell

190− - QuasiQuotes

76+ - TemplateHaskell

77+ - QuasiQuotes

.travis.ymlnew file+32

@@ -0,0 +1,32 @@

1+sudo: false

3+language: c

5+env:

6+ - GHCVER=7.8.4

7+ - GHCVER=7.10.2

9+addons:

10+ apt:

11+ sources:

12+ - hvr-ghc

13+ packages:

14+ - ghc-7.8.4

15+ - ghc-7.10.2

16+ - cabal-install-1.22

17+ - libgmp-dev

18+

19+install:

20+ - (mkdir -p $HOME/.local/bin && cd $HOME/.local/bin && wget https://zalora-public.s3.amazonaws.com/tinc && chmod +x tinc)

21+ - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/1.22/bin:$PATH

22+ - ghc --version

23+ - cabal --version

24+ - travis_retry cabal update

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

26+

27+script:

28+ - for package in $(cat sources.txt); do (echo testing $package && cd $package && tinc && cabal configure --enable-tests --disable-optimization && cabal build && cabal test) || exit 1; done

29+

30+cache:

31+ directories:

32+ - $HOME/.tinc/cache

CONTRIBUTING.md+11−42

@@ -8,12 +8,11 @@ repository. You can use `cabal`:

88./scripts/test-all.sh # Run all the tests

99```

1010

11−Or `stack`:

11+`stack`:

1212

1313```shell

14−stack setup # Downloads and installs a proper GHC version if necessary

15−stack build --fast --pedantic # Install dependencies and build packages

16−stack test # Run all the tests

14+stack build # Install and build packages

15+stack test # Run all the tests

1716```

1817

1918Or `nix`:

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

2120./scripts/generate-nix-files.sh # Get up-to-date shell.nix files

2221```

2322

24−To build the docs, see `doc/README.md`.

2523

2624## General

2725

@@ -30,39 +28,13 @@ Some things we like:

3028- Explicit imports

3129- Upper and lower bounds for packages

3230- Few dependencies

33−- -Werror-compatible (7.8, 7.10 and 8.0)

31+- -Werror-compatible (for both 7.8 and 7.10)

3432

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

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

3735

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

36+Please include a description of the changes in your PR in the `CHANGELOG.md` of

37+the packages you've changed. And of course, write tests!

6638

6739## PR process

6840

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

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

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

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

82−know about it! Either hop on

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

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

85−read it).

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

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

8656

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

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

8959come along fairly frequently). We therefore have to be quite selective about

9060those that we accept. If you're considering writing a new combinator, open an

91−issue to discuss it first! Or contribute it to the

92−[servant-contrib](https://github.com/haskell-servant/servant-contrib) repository.

93−You could release your combinator as a separate package, of course.

61+issue to discuss it first! (You could release your combinator as a separate

62+package, of course.)

9463

9564

9665## New classes

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

10574

10675## Release policy

10776

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

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

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

11079releases it may take some time in between releases.

11180

HLint.hsnew file+6

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

1+import "hint" HLint.Default

3+ignore "Redundant do"

4+ignore "Parse error"

5+ignore "Use list comprehension"

6+ignore "Use liftM"

README.md+3−54

@@ -4,68 +4,17 @@

55## Getting Started

7−We have a [tutorial](http://docs.servant.dev/en/stable/tutorial/index.html) that

7+We have a [tutorial](http://haskell-servant.github.io/tutorial) that

88introduces the core features of servant. After this article, you should be able

99to write your first servant webservices, learning the rest from the haddocks'

1010examples.

1111

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

1312Other blog posts, videos and slides can be found on the

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

13+[website](http://haskell-servant.github.io/).

1514

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

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

1716list](https://groups.google.com/forum/#!forum/haskell-servant).

1817

1918## Contributing

2019

2120See `CONTRIBUTING.md`

22−

23−## Release process outline (by phadej)

24−

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)

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

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

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.

31− - `cabal new-build --enable-tests all` to verify that everything builds, and `cabal new-test all` to run tests

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`

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

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

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

38−- When ripples are cleared out:

39− - `git tag -s` the release

40− - `git push --tags`

41− - `cabal sdist` and `cabal upload`

42−

43−## TechEmpower framework benchmarks

44−

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

46−

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

48−

49−```sh

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

51−```

52−

53−To compare with `warp`

54−

55−```sh

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

57−```

58−

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

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.projectdeleted−14

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

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

2−

3−packages:

4− servant/

5− servant-client/

6− servant-client-core/

7−

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

9−compiler: ghcjs

10−tests: True

11−

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

13−constraints: attoparsec == 0.13.2.2

14−constraints: hashable == 1.3.0.0

cabal.projectdeleted−53

@@ -1,53 +0,0 @@

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−

9− servant-client/

10− servant-client-core/

11− servant-http-streams/

12− servant-docs/

13− servant-foreign/

14− servant-server/

15− servant-swagger/

16− doc/tutorial/

17−

18−-- servant streaming

19−packages:

20− servant-machines/

21− servant-conduit/

22− servant-pipes/

23−

24−-- servant GHCJS

25−-- packages:

26−-- servant-jsaddle/

27−

28−-- Cookbooks

29−packages:

30− doc/cookbook/basic-auth

31− doc/cookbook/curl-mock

32− doc/cookbook/custom-errors

33− doc/cookbook/basic-streaming

34− doc/cookbook/db-postgres-pool

35− doc/cookbook/db-sqlite-simple

36− doc/cookbook/file-upload

37− doc/cookbook/generic

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

39− doc/cookbook/https

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

41− doc/cookbook/pagination

42− -- doc/cookbook/sentry

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

44− -- doc/cookbook/testing

45− doc/cookbook/uverb

46− doc/cookbook/structuring-apis

47− doc/cookbook/using-custom-monad

48− doc/cookbook/using-free-client

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

50−

51−tests: True

52−optimization: False

53−-- reorder-goals: True

changelog.d/1432deleted−9

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

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

2−prs: #1432

3−issues: #1418

4−description: {

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

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

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

8−query parameters.

9−}

changelog.d/1469deleted−11

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

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

2−prs: #1469

3−description: {

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

5−`clientWithRoute` definitions.

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

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

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

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

10−the `Verb` status.

11−}

changelog.d/1477deleted−9

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

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

2−prs: #1477

3−

4−description: {

5−

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

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

8−

9−}

changelog.d/1529deleted−10

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

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

2−prs: #1529

3−

4−description: {

5−

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

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

8−functionality to match what servant-client provides.

9−

10−}

changelog.d/1556deleted−81

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

1−synopsis: Display capture hints in router layout

2−prs: #1556

3−

4−description: {

5−

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

7−

8−Example:

9−

10−For the following API

11−```haskell

12−type API =

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

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

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

16−```

17−

18−we previously got the following output:

19−

20−```

21−/

22−├─ a/

23−│ ├─ d/

24−│ │ └─•

25−│ └─ e/

26−│ └─•

27−└─ b/

28− └─ <capture>/

29− ├─•

30− ┆

31− └─•

32−```

33−

34−now we get:

35−

36−```

37−/

38−├─ a/

39−│ ├─ d/

40−│ │ └─•

41−│ └─ e/

42−│ └─•

43−└─ b/

44− └─ <x::Int>/

45− ├─•

46− ┆

47− └─•

48−```

49−

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

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

52−

53−N.B.:

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

55−

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

57−

58−Warning:

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

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

61−

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

63−```haskell

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

65−

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

67−myServer = const $ return ()

68−

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

70−myApi = Proxy

71−

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

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

74−```

75−

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

77−```haskell

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

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

80−```

81−}

changelog.d/1569deleted−13

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

1−synopsis: Encode captures using toEncodedUrlPiece

2−prs: #1569

3−issues: #1511

4−

5−description: {

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

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

8−URL-encoding however they need.

9−

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

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

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

13−}

changelog.d/1580deleted−12

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

1−synopsis: Allow IO in validationKeys

2−prs: #1580

3−issues: #1579

4−

5−description: {

6−

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

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

9−discover new and expired keys.

10−

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

12−}

changelog.d/1589deleted−2

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

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

2−prs: 1589

changelog.d/1595deleted−2

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

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

2−prs: #1595

changelog.d/configdeleted−2

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

1−organization: haskell-servant

2−repository: servant

changelog.d/servant-docs-curldeleted−16

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

1−synopsis: Add sample cURL requests to generated documentation

2−prs: #1401

3−

4−description: {

5−

6−Add sample cURL requests to generated documentation.

7−

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

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

10−

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

12−

13−becomes

14−

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

16−}

default.nixdeleted−38

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

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

2−{

3− pkgs ? import (builtins.fetchTarball {

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

5− inherit sha256;

6− }) {}

7−, compiler ? "ghc883"

8−}:

9−let

10− overrides = self: super: {

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

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

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

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

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

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

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

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

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

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

21− };

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

23−in

24− with hPkgs;

25− {

26− inherit

27− servant

28− servant-client

29− servant-client-core

30− servant-conduit

31− servant-docs

32− servant-foreign

33− servant-http-streams

34− servant-machines

35− servant-pipes

36− servant-server;

37− }

38−

doc/Makefile+206−12

@@ -1,22 +1,216 @@

1−# Minimal makefile for Sphinx documentation

1+# Makefile for Sphinx documentation

22#

44# You can set these variables from the command line.

55SPHINXOPTS =

66SPHINXBUILD = sphinx-build

7−SPHINXPROJ = Servant

8−SOURCEDIR = .

7+PAPER =

98BUILDDIR = _build

109

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

10+# User-friendly check for sphinx-build

11+ifeq ($(shell which $(SPHINXBUILD) >/dev/null 2>&1; echo $$?), 1)

12+$(error The '$(SPHINXBUILD)' command was not found. Make sure you have Sphinx installed, then set the SPHINXBUILD environment variable to point to the full path of the '$(SPHINXBUILD)' executable. Alternatively you can add the directory with the executable to your PATH. If you don't have Sphinx installed, grab it from http://sphinx-doc.org/)

13+endif

14+

15+# Internal variables.

16+PAPEROPT_a4 = -D latex_paper_size=a4

17+PAPEROPT_letter = -D latex_paper_size=letter

18+ALLSPHINXOPTS = -d $(BUILDDIR)/doctrees $(PAPEROPT_$(PAPER)) $(SPHINXOPTS) .

19+# the i18n builder cannot share the environment and doctrees with the others

20+I18NSPHINXOPTS = $(PAPEROPT_$(PAPER)) $(SPHINXOPTS) .

21+

22+.PHONY: help

1223help:

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

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

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

24+ @echo "Please use \`make <target>' where <target> is one of"

25+ @echo " html to make standalone HTML files"

26+ @echo " dirhtml to make HTML files named index.html in directories"

27+ @echo " singlehtml to make a single large HTML file"

28+ @echo " pickle to make pickle files"

29+ @echo " json to make JSON files"

30+ @echo " htmlhelp to make HTML files and a HTML help project"

31+ @echo " qthelp to make HTML files and a qthelp project"

32+ @echo " applehelp to make an Apple Help Book"

33+ @echo " devhelp to make HTML files and a Devhelp project"

34+ @echo " epub to make an epub"

35+ @echo " latex to make LaTeX files, you can set PAPER=a4 or PAPER=letter"

36+ @echo " latexpdf to make LaTeX files and run them through pdflatex"

37+ @echo " latexpdfja to make LaTeX files and run them through platex/dvipdfmx"

38+ @echo " text to make text files"

39+ @echo " man to make manual pages"

40+ @echo " texinfo to make Texinfo files"

41+ @echo " info to make Texinfo files and run them through makeinfo"

42+ @echo " gettext to make PO message catalogs"

43+ @echo " changes to make an overview of all changed/added/deprecated items"

44+ @echo " xml to make Docutils-native XML files"

45+ @echo " pseudoxml to make pseudoxml-XML files for display purposes"

46+ @echo " linkcheck to check all external links for integrity"

47+ @echo " doctest to run all doctests embedded in the documentation (if enabled)"

48+ @echo " coverage to run coverage check of the documentation (if enabled)"

49+

50+.PHONY: clean

51+clean:

52+ rm -rf $(BUILDDIR)/*

53+

54+.PHONY: html

55+html:

56+ $(SPHINXBUILD) -b html $(ALLSPHINXOPTS) $(BUILDDIR)/html

57+ @echo

58+ @echo "Build finished. The HTML pages are in $(BUILDDIR)/html."

59+

60+.PHONY: dirhtml

61+dirhtml:

62+ $(SPHINXBUILD) -b dirhtml $(ALLSPHINXOPTS) $(BUILDDIR)/dirhtml

63+ @echo

64+ @echo "Build finished. The HTML pages are in $(BUILDDIR)/dirhtml."

65+

66+.PHONY: singlehtml

67+singlehtml:

68+ $(SPHINXBUILD) -b singlehtml $(ALLSPHINXOPTS) $(BUILDDIR)/singlehtml

69+ @echo

70+ @echo "Build finished. The HTML page is in $(BUILDDIR)/singlehtml."

71+

72+.PHONY: pickle

73+pickle:

74+ $(SPHINXBUILD) -b pickle $(ALLSPHINXOPTS) $(BUILDDIR)/pickle

75+ @echo

76+ @echo "Build finished; now you can process the pickle files."

77+

78+.PHONY: json

79+json:

80+ $(SPHINXBUILD) -b json $(ALLSPHINXOPTS) $(BUILDDIR)/json

81+ @echo

82+ @echo "Build finished; now you can process the JSON files."

83+

84+.PHONY: htmlhelp

85+htmlhelp:

86+ $(SPHINXBUILD) -b htmlhelp $(ALLSPHINXOPTS) $(BUILDDIR)/htmlhelp

87+ @echo

88+ @echo "Build finished; now you can run HTML Help Workshop with the" \

89+ ".hhp project file in $(BUILDDIR)/htmlhelp."

90+

91+.PHONY: qthelp

92+qthelp:

93+ $(SPHINXBUILD) -b qthelp $(ALLSPHINXOPTS) $(BUILDDIR)/qthelp

94+ @echo

95+ @echo "Build finished; now you can run "qcollectiongenerator" with the" \

96+ ".qhcp project file in $(BUILDDIR)/qthelp, like this:"

97+ @echo "# qcollectiongenerator $(BUILDDIR)/qthelp/generics-eot.qhcp"

98+ @echo "To view the help file:"

99+ @echo "# assistant -collectionFile $(BUILDDIR)/qthelp/generics-eot.qhc"

100+

101+.PHONY: applehelp

102+applehelp:

103+ $(SPHINXBUILD) -b applehelp $(ALLSPHINXOPTS) $(BUILDDIR)/applehelp

104+ @echo

105+ @echo "Build finished. The help book is in $(BUILDDIR)/applehelp."

106+ @echo "N.B. You won't be able to view it unless you put it in" \

107+ "~/Library/Documentation/Help or install it in your application" \

108+ "bundle."

109+

110+.PHONY: devhelp

111+devhelp:

112+ $(SPHINXBUILD) -b devhelp $(ALLSPHINXOPTS) $(BUILDDIR)/devhelp

113+ @echo

114+ @echo "Build finished."

115+ @echo "To view the help file:"

116+ @echo "# mkdir -p $$HOME/.local/share/devhelp/generics-eot"

117+ @echo "# ln -s $(BUILDDIR)/devhelp $$HOME/.local/share/devhelp/generics-eot"

118+ @echo "# devhelp"

119+

120+.PHONY: epub

121+epub:

122+ $(SPHINXBUILD) -b epub $(ALLSPHINXOPTS) $(BUILDDIR)/epub

123+ @echo

124+ @echo "Build finished. The epub file is in $(BUILDDIR)/epub."

125+

126+.PHONY: latex

127+latex:

128+ $(SPHINXBUILD) -b latex $(ALLSPHINXOPTS) $(BUILDDIR)/latex

129+ @echo

130+ @echo "Build finished; the LaTeX files are in $(BUILDDIR)/latex."

131+ @echo "Run \`make' in that directory to run these through (pdf)latex" \

132+ "(use \`make latexpdf' here to do that automatically)."

133+

134+.PHONY: latexpdf

135+latexpdf:

136+ $(SPHINXBUILD) -b latex $(ALLSPHINXOPTS) $(BUILDDIR)/latex

137+ @echo "Running LaTeX files through pdflatex..."

138+ $(MAKE) -C $(BUILDDIR)/latex all-pdf

139+ @echo "pdflatex finished; the PDF files are in $(BUILDDIR)/latex."

140+

141+.PHONY: latexpdfja

142+latexpdfja:

143+ $(SPHINXBUILD) -b latex $(ALLSPHINXOPTS) $(BUILDDIR)/latex

144+ @echo "Running LaTeX files through platex and dvipdfmx..."

145+ $(MAKE) -C $(BUILDDIR)/latex all-pdf-ja

146+ @echo "pdflatex finished; the PDF files are in $(BUILDDIR)/latex."

147+

148+.PHONY: text

149+text:

150+ $(SPHINXBUILD) -b text $(ALLSPHINXOPTS) $(BUILDDIR)/text

151+ @echo

152+ @echo "Build finished. The text files are in $(BUILDDIR)/text."

153+

154+.PHONY: man

155+man:

156+ $(SPHINXBUILD) -b man $(ALLSPHINXOPTS) $(BUILDDIR)/man

157+ @echo

158+ @echo "Build finished. The manual pages are in $(BUILDDIR)/man."

159+

160+.PHONY: texinfo

161+texinfo:

162+ $(SPHINXBUILD) -b texinfo $(ALLSPHINXOPTS) $(BUILDDIR)/texinfo

163+ @echo

164+ @echo "Build finished. The Texinfo files are in $(BUILDDIR)/texinfo."

165+ @echo "Run \`make' in that directory to run these through makeinfo" \

166+ "(use \`make info' here to do that automatically)."

167+

168+.PHONY: info

169+info:

170+ $(SPHINXBUILD) -b texinfo $(ALLSPHINXOPTS) $(BUILDDIR)/texinfo

171+ @echo "Running Texinfo files through makeinfo..."

172+ make -C $(BUILDDIR)/texinfo info

173+ @echo "makeinfo finished; the Info files are in $(BUILDDIR)/texinfo."

174+

175+.PHONY: gettext

176+gettext:

177+ $(SPHINXBUILD) -b gettext $(I18NSPHINXOPTS) $(BUILDDIR)/locale

178+ @echo

179+ @echo "Build finished. The message catalogs are in $(BUILDDIR)/locale."

180+

181+.PHONY: changes

182+changes:

183+ $(SPHINXBUILD) -b changes $(ALLSPHINXOPTS) $(BUILDDIR)/changes

184+ @echo

185+ @echo "The overview file is in $(BUILDDIR)/changes."

186+

187+.PHONY: linkcheck

188+linkcheck:

189+ $(SPHINXBUILD) -b linkcheck $(ALLSPHINXOPTS) $(BUILDDIR)/linkcheck

190+ @echo

191+ @echo "Link check complete; look for any errors in the above output " \

192+ "or in $(BUILDDIR)/linkcheck/output.txt."

193+

194+.PHONY: doctest

195+doctest:

196+ $(SPHINXBUILD) -b doctest $(ALLSPHINXOPTS) $(BUILDDIR)/doctest

197+ @echo "Testing of doctests in the sources finished, look at the " \

198+ "results in $(BUILDDIR)/doctest/output.txt."

199+

200+.PHONY: coverage

201+coverage:

202+ $(SPHINXBUILD) -b coverage $(ALLSPHINXOPTS) $(BUILDDIR)/coverage

203+ @echo "Testing of coverage in the sources finished, look at the " \

204+ "results in $(BUILDDIR)/coverage/python.txt."

16205

17−.PHONY: help Makefile

206+.PHONY: xml

207+xml:

208+ $(SPHINXBUILD) -b xml $(ALLSPHINXOPTS) $(BUILDDIR)/xml

209+ @echo

210+ @echo "Build finished. The XML files are in $(BUILDDIR)/xml."

18211

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

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

21−%: Makefile

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

212+.PHONY: pseudoxml

213+pseudoxml:

214+ $(SPHINXBUILD) -b pseudoxml $(ALLSPHINXOPTS) $(BUILDDIR)/pseudoxml

215+ @echo

216+ @echo "Build finished. The pseudo-XML files are in $(BUILDDIR)/pseudoxml."

doc/README.mddeleted−8

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

1−To build the docs locally:

2−

3− $ virtualenv venv

4− $ . ./venv/bin/activate

5− $ pip install -r requirements.txt

6− $ make html

7−

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

doc/building-the-docsnew file+8

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

1+To build the docs locally:

3+$ virtualenv venv

4+$ . ./venv/bin/activate

5+$ pip install -r requirements.txt

6+$ make html

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

doc/conf.py+176−53

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

11# -*- coding: utf-8 -*-

22#

3−# Servant documentation build configuration file, created by

4−# sphinx-quickstart on Fri Jul 6 11:38:51 2018.

3+# servant documentation build configuration file, created by

4+# sphinx-quickstart on Mon Nov 23 13:24:36 2015.

55#

66# This file is execfile()d with the current directory set to its

77# containing dir.

@@ -12,21 +12,20 @@

1212# All configuration values have a default; values that are commented out

1313# serve to show the default.

1414

15+import sys

16+import os

17+import shlex

18+from recommonmark.parser import CommonMarkParser

19+

1520# If extensions (or modules to document with autodoc) are in another directory,

1621# add these directories to sys.path here. If the directory is relative to the

1722# documentation root, use os.path.abspath to make it absolute, like shown here.

18−#

19−# import os

20−# import sys

21−# sys.path.insert(0, os.path.abspath('.'))

22−from recommonmark.parser import CommonMarkParser

23−

23+#sys.path.insert(0, os.path.abspath('.'))

2424

2525# -- General configuration ------------------------------------------------

2626

2727# If your documentation needs a minimal Sphinx version, state it here.

28−#

29−# needs_sphinx = '1.0'

28+#needs_sphinx = '1.0'

3029

3130# Add any Sphinx extension module names here, as strings. They can be

3231# extensions coming with Sphinx (named 'sphinx.ext.*') or your custom

@@ -38,15 +37,17 @@ templates_path = ['_templates']

3837

3938# The suffix(es) of source filenames.

4039# You can specify multiple suffix as a list of string:

41−#

42−source_suffix = ['.rst', '.md', '.lhs']

40+source_suffix = ['.md', '.rst', '.lhs']

41+

42+# The encoding of source files.

43+#source_encoding = 'utf-8-sig'

4344

4445# The master toctree document.

4546master_doc = 'index'

4647

4748# General information about the project.

48−project = u'Servant'

49−copyright = u'2022, Servant Contributors'

49+project = u'servant'

50+copyright = u'2016, Servant Contributors'

5051author = u'Servant Contributors'

5152

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

@@ -54,9 +55,9 @@ author = u'Servant Contributors'

5455# built documents.

5556#

5657# The short X.Y version.

57−# version = u'0.14'

58+# version = 'latest'

5859# The full version, including alpha/beta/rc tags.

59−# release = u'0.14'

60+# release = 'latest'

6061

6162# The language for content autogenerated by Sphinx. Refer to documentation

6263# for a list of supported languages.

@@ -65,14 +66,45 @@ author = u'Servant Contributors'

6566# Usually you set "language" from the command line for these cases.

6667language = None

6768

69+# There are two options for replacing |today|: either, you set today to some

70+# non-false value, then it is used:

71+#today = ''

72+# Else, today_fmt is used as the format for a strftime call.

73+#today_fmt = '%B %d, %Y'

74+

6875# List of patterns, relative to source directory, that match files and

6976# directories to ignore when looking for source files.

70−# This patterns also effect to html_static_path and html_extra_path

71−exclude_patterns = ['_build', 'Thumbs.db', '.DS_Store']

77+exclude_patterns = ['_build', 'venv']

78+

79+# The reST default role (used for this markup: `text`) to use for all

80+# documents.

81+#default_role = None

82+

83+# If true, '()' will be appended to :func: etc. cross-reference text.

84+#add_function_parentheses = True

85+

86+# If true, the current module name will be prepended to all description

87+# unit titles (such as .. function::).

88+#add_module_names = True

89+

90+# If true, sectionauthor and moduleauthor directives will be shown in the

91+# output. They are ignored by default.

92+#show_authors = False

7293

7394# The name of the Pygments (syntax highlighting) style to use.

7495pygments_style = 'sphinx'

7596

97+def setup(app):

98+ from sphinx.highlighting import lexers

99+ from pygments.lexers import HaskellLexer

100+ lexers['haskell ignore'] = HaskellLexer(stripnl=False)

101+

102+# A list of ignored prefixes for module index sorting.

103+#modindex_common_prefix = []

104+

105+# If true, keep warnings as "system message" paragraphs in the built documents.

106+#keep_warnings = False

107+

76108# If true, `todo` and `todoList` produce output, else they produce nothing.

77109todo_include_todos = False

78110

@@ -81,77 +113,157 @@ todo_include_todos = False

81113

82114# The theme to use for HTML and HTML Help pages. See the documentation for

83115# a list of builtin themes.

84−#

85116html_theme = 'sphinx_rtd_theme'

86117

87118# Theme options are theme-specific and customize the look and feel of a theme

88119# further. For a list of options available for each theme, see the

89120# documentation.

90−#

91−# html_theme_options = {}

121+#html_theme_options = {}

122+

123+# Add any paths that contain custom themes here, relative to this directory.

124+#html_theme_path = []

125+

126+# The name for this set of Sphinx documents. If None, it defaults to

127+# "<project> v<release> documentation".

128+#html_title = None

129+

130+# A shorter title for the navigation bar. Default is the same as html_title.

131+#html_short_title = None

132+

133+# The name of an image file (relative to this directory) to place at the top

134+# of the sidebar.

135+#html_logo = None

136+

137+# The name of an image file (within the static path) to use as favicon of the

138+# docs. This file should be a Windows icon file (.ico) being 16x16 or 32x32

139+# pixels large.

140+#html_favicon = None

92141

93142# Add any paths that contain custom static files (such as style sheets) here,

94143# relative to this directory. They are copied after the builtin static files,

95144# so a file named "default.css" will overwrite the builtin "default.css".

96145html_static_path = ['_static']

97146

98−# Custom sidebar templates, must be a dictionary that maps document names

99−# to template names.

100−#

101−# This is required for the alabaster theme

102−# refs: http://alabaster.readthedocs.io/en/latest/installation.html#sidebars

103−html_sidebars = {

104− '**': [

105− 'relations.html', # needs 'show_related': True theme option to display

106− 'searchbox.html',

107− ]

108−}

147+# Add any extra paths that contain custom files (such as robots.txt or

148+# .htaccess) here, relative to this directory. These files are copied

149+# directly to the root of the documentation.

150+#html_extra_path = []

109151

152+# If not '', a 'Last updated on:' timestamp is inserted at every page bottom,

153+# using the given strftime format.

154+#html_last_updated_fmt = '%b %d, %Y'

110155

111−# -- Options for HTMLHelp output ------------------------------------------

156+# If true, SmartyPants will be used to convert quotes and dashes to

157+# typographically correct entities.

158+#html_use_smartypants = True

112159

113−# Output file base name for HTML help builder.

114−htmlhelp_basename = 'Servantdoc'

160+# Custom sidebar templates, maps document names to template names.

161+#html_sidebars = {}

162+

163+# Additional templates that should be rendered to pages, maps page names to

164+# template names.

165+#html_additional_pages = {}

166+

167+# If false, no module index is generated.

168+#html_domain_indices = True

169+

170+# If false, no index is generated.

171+#html_use_index = True

172+

173+# If true, the index is split into individual pages for each letter.

174+#html_split_index = False

175+

176+# If true, links to the reST sources are added to the pages.

177+#html_show_sourcelink = True

178+

179+# If true, "Created using Sphinx" is shown in the HTML footer. Default is True.

180+#html_show_sphinx = True

181+

182+# If true, "(C) Copyright ..." is shown in the HTML footer. Default is True.

183+#html_show_copyright = True

184+

185+# If true, an OpenSearch description file will be output, and all pages will

186+# contain a <link> tag referring to it. The value of this option must be the

187+# base URL from which the finished HTML is served.

188+#html_use_opensearch = ''

189+

190+# This is the file name suffix for HTML files (e.g. ".xhtml").

191+#html_file_suffix = None

192+

193+# Language to be used for generating the HTML full-text search index.

194+# Sphinx supports the following languages:

195+# 'da', 'de', 'en', 'es', 'fi', 'fr', 'hu', 'it', 'ja'

196+# 'nl', 'no', 'pt', 'ro', 'ru', 'sv', 'tr'

197+#html_search_language = 'en'

198+

199+# A dictionary with options for the search language support, empty by default.

200+# Now only 'ja' uses this config value

201+#html_search_options = {'type': 'default'}

115202

203+# The name of a javascript file (relative to the configuration directory) that

204+# implements a search results scorer. If empty, the default will be used.

205+#html_search_scorer = 'scorer.js'

206+

207+# Output file base name for HTML help builder.

208+htmlhelp_basename = 'servantdoc'

116209

117210# -- Options for LaTeX output ---------------------------------------------

118211

119212latex_elements = {

120− # The paper size ('letterpaper' or 'a4paper').

121− #

122− # 'papersize': 'letterpaper',

213+# The paper size ('letterpaper' or 'a4paper').

214+#'papersize': 'letterpaper',

123215

124− # The font size ('10pt', '11pt' or '12pt').

125− #

126− # 'pointsize': '10pt',

216+# The font size ('10pt', '11pt' or '12pt').

217+#'pointsize': '10pt',

127218

128− # Additional stuff for the LaTeX preamble.

129− #

130− # 'preamble': '',

219+# Additional stuff for the LaTeX preamble.

220+#'preamble': '',

131221

132− # Latex figure (float) alignment

133− #

134− # 'figure_align': 'htbp',

222+# Latex figure (float) alignment

223+#'figure_align': 'htbp',

135224}

136225

137226# Grouping the document tree into LaTeX files. List of tuples

138227# (source start file, target name, title,

139228# author, documentclass [howto, manual, or own class]).

140229latex_documents = [

141− (master_doc, 'Servant.tex', u'Servant Documentation',

230+ (master_doc, 'servant.tex', u'servant Documentation',

142231 u'Servant Contributors', 'manual'),

143232]

144233

234+# The name of an image file (relative to this directory) to place at the top of

235+# the title page.

236+#latex_logo = None

237+

238+# For "manual" documents, if this is true, then toplevel headings are parts,

239+# not chapters.

240+#latex_use_parts = False

241+

242+# If true, show page references after internal links.

243+#latex_show_pagerefs = False

244+

245+# If true, show URL addresses after external links.

246+#latex_show_urls = False

247+

248+# Documents to append as an appendix to all manuals.

249+#latex_appendices = []

250+

251+# If false, no module index is generated.

252+#latex_domain_indices = True

253+

145254

146255# -- Options for manual page output ---------------------------------------

147256

148257# One entry per manual page. List of tuples

149258# (source start file, name, description, authors, manual section).

150259man_pages = [

151− (master_doc, 'servant', u'Servant Documentation',

260+ (master_doc, 'servant', u'servant Documentation',

152261 [author], 1)

153262]

154263

264+# If true, show URL addresses after external links.

265+#man_show_urls = False

266+

155267

156268# -- Options for Texinfo output -------------------------------------------

157269

@@ -159,13 +271,24 @@ man_pages = [

159271# (source start file, target name, title, author,

160272# dir menu entry, description, category)

161273texinfo_documents = [

162− (master_doc, 'Servant', u'Servant Documentation',

163− author, 'Servant', 'One line description of project.',

164− 'Miscellaneous'),

274+ (master_doc, 'servant', u'servant Documentation',

275+ author, 'servant', 'One line description of project.',

276+ 'Miscellaneous'),

165277]

166278

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

279+# Documents to append as an appendix to all manuals.

280+#texinfo_appendices = []

281+

282+# If false, no module index is generated.

283+#texinfo_domain_indices = True

284+

285+# How to display URL addresses: 'footnote', 'no', or 'inline'.

286+#texinfo_show_urls = 'footnote'

287+

288+# If true, do not generate a @detailmenu in the "Top" node's menu.

289+#texinfo_no_detailmenu = False

168290

169291source_parsers = {

292+ '.md': CommonMarkParser,

170293 '.lhs': CommonMarkParser,

171294}

doc/cookbook/basic-auth/BasicAuth.lhsdeleted−179

@@ -1,179 +0,0 @@

1−# Basic Authentication

2−

3−Let's see a simple example of a web application with a

4−single endpoint, protected by

5−[Basic Authentication](https://en.wikipedia.org/wiki/Basic_access_authentication).

6−

7−First, some throat clearing.

8−

9−``` haskell

10−{-# LANGUAGE DataKinds #-}

11−{-# LANGUAGE OverloadedStrings #-}

12−{-# LANGUAGE TypeOperators #-}

13−import Control.Concurrent

14−import Control.Exception

15−import qualified Data.Map as Map

16−import qualified Data.Text as T

17−import Data.Text.Encoding (decodeUtf8)

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

19−import Network.Wai.Handler.Warp

20−import Servant

21−import Servant.Client

22−```

23−

24−We will be dealing with a very simple model of users, as shown below.

25−Our "user database" will just be a map from usernames to full user details.

26−For the sake of simplicity, it will just be read only but the same code could

27−be used with mutable references, database connections, files and more in place

28−of our `Map`.

29−

30−``` haskell

31−type Username = T.Text

32−type Password = T.Text

33−type Website = T.Text

34−

35−data User = User

36− { user :: Username

37− , pass :: Password

38− , site :: Website

39− } deriving (Eq, Show)

40−

41−-- could be a postgres connection, a file, anything.

42−type UserDB = Map.Map Username User

43−

44−-- create a "database" from a list of users

45−createUserDB :: [User] -> UserDB

46−createUserDB users = Map.fromList [ (user u, u) | u <- users ]

47−

48−-- our test database

49−userDB :: UserDB

50−userDB = createUserDB

51− [ User "john" "shhhh" "john.com"

52− , User "foo" "bar" "foobar.net"

53− ]

54−```

55−

56−Our API will contain a single endpoint, returning the authenticated

57−user's own website.

58−

59−``` haskell

60−-- a 'GET /mysite' endpoint, protected by basic authentication

61−type API = BasicAuth "People's websites" User :> "mysite" :> Get '[JSON] Website

62−

63−{- if there were more endpoints to be protected, one could write:

64−type API = BasicAuth "People's websites" User :>

65− ( "foo" :> Get '[JSON] Foo

66− :<|> "bar" :> Get '[JSON] Bar

67− )

68−-}

69−

70−api :: Proxy API

71−api = Proxy

72−

73−server :: Server API

74−server usr = return (site usr)

75−```

76−

77−In order to protect our endpoint (`"mysite" :> Get '[JSON] Website`), we simply

78−drop the `BasicAuth` combinator in front of it. Its first parameter,

79−`"People's websites"` in our example, is the realm, which is an arbitrary string

80−identifying the protected resources. The second parameter, `User` in our example,

81−corresponds to the type we want to use to represent authenticated users. It could

82−be anything.

83−

84−When using `BasicAuth` in an API, the server implementation "gets" an argument

85−of the authenticated user type used with `BasicAuth`, `User` in our case, in the

86−"corresponding spot". In this example, the server implementation simply returns

87−the `site` field of the authenticated user. More realistic applications would

88−have endpoints that take other arguments and where a lot more logic would

89−be implemented. But in a sense, `BasicAuth` adds an argument just like `Capture`,

90−`QueryParam`, `ReqBody` and friends. But instead of performing some form of

91−decoding logic behind the scenes, servant runs some "basic auth check" that the

92−user provides.

93−

94−In our case, we need access to our user database, so we simply

95−take it as an argument. A more serious implementation would probably take

96−a database connection or even a connection pool.

97−

98−``` haskell

99−-- provided we are given a user database, we can supply

100−-- a function that checks the basic auth credentials

101−-- against our database.

102−checkBasicAuth :: UserDB -> BasicAuthCheck User

103−checkBasicAuth db = BasicAuthCheck $ \basicAuthData ->

104− let username = decodeUtf8 (basicAuthUsername basicAuthData)

105− password = decodeUtf8 (basicAuthPassword basicAuthData)

106− in

107− case Map.lookup username db of

108− Nothing -> return NoSuchUser

109− Just u -> if pass u == password

110− then return (Authorized u)

111− else return BadPassword

112−```

113−

114−This check simply looks up the user in the "database" and makes sure the

115−right password was used. For reference, here are the definitions of

116−`BasicAuthResult` and `BasicAuthCheck`:

117−

118−```

119−-- | The result of authentication/authorization

120−data BasicAuthResult usr

121− = Unauthorized

122− | BadPassword

123− | NoSuchUser

124− | Authorized usr

125− deriving (Eq, Show, Read, Generic, Typeable, Functor)

126−

127−-- | Datatype wrapping a function used to check authentication.

128−newtype BasicAuthCheck usr = BasicAuthCheck

129− { unBasicAuthCheck :: BasicAuthData

130− -> IO (BasicAuthResult usr)

131− }

132− deriving (Generic, Typeable, Functor)

133−```

134−

135−This is all great, but how is our `BasicAuth` combinator supposed to know

136−that it should use our `checkBasicAuth` from above? The answer is that it

137−simply expects to find a `BasicAuthCheck` value for the right user type in

138−the `Context` with which we serve the application, where `Context` is just

139−servant's way to allow users to communicate some configuration of sorts to

140−combinators. It is nothing more than an heterogeneous list and we can create

141−a context with our auth check and run our application with it with the following

142−code:

143−

144−``` haskell

145−runApp :: UserDB -> IO ()

146−runApp db = run 8080 (serveWithContext api ctx server)

147−

148− where ctx = checkBasicAuth db :. EmptyContext

149−```

150−

151−`ctx` above is just a context with one element, `checkBasicAuth db`,

152−whose type is `BasicAuthCheck User`. In order to say that we want to serve our

153−application using the supplied context, we just have to use `serveWithContext`

154−in place of `serve`.

155−

156−Finally, let's derive a client to this endpoint as well in order to see our

157−server in action!

158−

159−``` haskell

160−getSite :: BasicAuthData -> ClientM Website

161−getSite = client api

162−

163−main :: IO ()

164−main = do

165− mgr <- newManager defaultManagerSettings

166− bracket (forkIO $ runApp userDB) killThread $ \_ ->

167− runClientM (getSite u) (mkClientEnv mgr (BaseUrl Http "localhost" 8080 ""))

168− >>= print

169−

170− where u = BasicAuthData "foo" "bar"

171−```

172−

173−This program prints `Right "foobar.net"`, as expected. Feel free to change this

174−code and see what happens when you specify credentials that are not in the

175−database.

176−

177−The entire program covered here is available as a literate Haskell file

178−[here](https://github.com/haskell-servant/servant/tree/master/doc/cookbook/basic-auth),

179−along with a `cabal` project.

doc/cookbook/basic-auth/basic-auth.cabaldeleted−29

@@ -1,29 +0,0 @@

1−cabal-version: 2.2

2−name: cookbook-basic-auth

3−version: 0.1

4−synopsis: Basic Authentication cookbook example

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

6−license: BSD-3-Clause

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

8−author: Servant Contributors

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

10−build-type: Simple

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

12−

13−executable cookbook-basic-auth

14− main-is: BasicAuth.lhs

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

16− , text >= 1.2

17− , aeson >= 1.2

18− , containers >= 0.5

19− , servant

20− , servant-client

21− , servant-server

22− , warp >= 3.2

23− , wai >= 3.2

24− , http-types >= 0.12

25− , markdown-unlit >= 0.4

26− , http-client >= 0.5

27− default-language: Haskell2010

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

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

doc/cookbook/basic-streaming/Streaming.lhsdeleted−129

@@ -1,129 +0,0 @@

1−# Streaming out-of-the-box

2−

3−In other words, without streaming libraries.

4−

5−## Introduction

6−

7−- Servant supports streaming

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

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

10− We have bindings for them though.

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

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

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

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

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

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

17−

18−## Code

19−

20−```haskell

21−{-# LANGUAGE BangPatterns #-}

22−{-# LANGUAGE DataKinds #-}

23−{-# LANGUAGE DeriveGeneric #-}

24−{-# LANGUAGE TypeOperators #-}

25−module Main (main) where

26−

27−import Control.Concurrent

28− (threadDelay)

29−import Control.Monad.IO.Class

30− (MonadIO (..))

31−import qualified Data.ByteString as BS

32−import Data.Maybe

33− (fromMaybe)

34−import Network.HTTP.Client

35− (defaultManagerSettings, newManager)

36−import Network.Wai

37− (Application)

38−import System.Environment

39− (getArgs, lookupEnv)

40−import Text.Read

41− (readMaybe)

42−

43−import Servant

44−import Servant.Client.Streaming

45−import qualified Servant.Types.SourceT as S

46−

47−import qualified Network.Wai.Handler.Warp as Warp

48−

49−type FastAPI = "get" :> Capture "num" Int :> StreamGet NewlineFraming JSON (SourceIO Int)

50−

51−type API = FastAPI

52− :<|> "slow" :> Capture "num" Int :> StreamGet NewlineFraming JSON (SourceIO Int)

53− -- monad can be ResourceT IO too.

54− :<|> "readme" :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString)

55− -- we can have streaming request body

56− :<|> "proxy"

57− :> StreamBody NoFraming OctetStream (SourceIO BS.ByteString)

58− :> StreamPost NoFraming OctetStream (SourceIO BS.ByteString)

59−

60−api :: Proxy API

61−api = Proxy

62−

63−server :: Server API

64−server = fast :<|> slow :<|> readme :<|> proxy where

65− fast n = liftIO $ do

66− putStrLn $ "/get/" ++ show n

67− return $ fastSource n

68−

69− slow n = liftIO $ do

70− putStrLn $ "/slow/" ++ show n

71− return $ slowSource n

72−

73− readme = liftIO $ do

74− putStrLn "/proxy"

75− return (S.readFile "README.md")

76−

77− proxy c = liftIO $ do

78− putStrLn "/proxy"

79− return c

80−

81− -- for some reason unfold leaks?

82− fastSource = S.fromStepT . mk where

83− mk m

84− | m < 0 = S.Stop

85− | otherwise = S.Yield m (mk (m - 1))

86−

87− slowSource m = S.mapStepT delay (fastSource m) where

88− delay S.Stop = S.Stop

89− delay (S.Error err) = S.Error err

90− delay (S.Skip s) = S.Skip (delay s)

91− delay (S.Effect ms) = S.Effect (fmap delay ms)

92− delay (S.Yield x s) = S.Effect $

93− S.Yield x (delay s) <$ threadDelay 1000000

94−

95−app :: Application

96−app = serve api server

97−

98−cli :: Client ClientM FastAPI

99−cli :<|> _ :<|> _ :<|> _ = client api

100−

101−main :: IO ()

102−main = do

103− args <- getArgs

104− case args of

105− ("server":_) -> do

106− putStrLn "Starting cookbook-basic-streaming at http://localhost:8000"

107− port <- fromMaybe 8000 . (>>= readMaybe) <$> lookupEnv "PORT"

108− Warp.run port app

109− ("client":ns:_) -> do

110− n <- maybe (fail $ "not a number: " ++ ns) pure $ readMaybe ns

111− mgr <- newManager defaultManagerSettings

112− burl <- parseBaseUrl "http://localhost:8000/"

113− withClientM (cli n) (mkClientEnv mgr burl) $ \me -> case me of

114− Left err -> print err

115− Right src -> do

116− x <- S.unSourceT src (go (0 :: Int))

117− print x

118− where

119− go !acc S.Stop = return acc

120− go !acc (S.Error err) = print err >> return acc

121− go !acc (S.Skip s) = go acc s

122− go !acc (S.Effect ms) = ms >>= go acc

123− go !acc (S.Yield _ s) = go (acc + 1) s

124− _ -> do

125− putStrLn "Try:"

126− putStrLn "cabal new-run cookbook-basic-streaming server"

127− putStrLn "cabal new-run cookbook-basic-streaming client 10"

128− putStrLn "time curl -H 'Accept: application/json' localhost:8000/slow/5"

129−```

doc/cookbook/basic-streaming/basic-streaming.cabaldeleted−28

@@ -1,28 +0,0 @@

1−cabal-version: 2.2

2−name: cookbook-basic-streaming

3−version: 2.1

4−synopsis: Streaming in servant without streaming libs

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

6−license: BSD-3-Clause

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

8−author: Servant Contributors

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

10−build-type: Simple

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

12−

13−executable cookbook-basic-streaming

14− main-is: Streaming.lhs

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

16− default-language: Haskell2010

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

18−

19− hs-source-dirs: .

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

21− , aeson

22− , bytestring

23− , servant

24− , servant-server

25− , servant-client

26− , http-client

27− , wai

28− , warp

doc/cookbook/cabal.projectdeleted−22

@@ -1,22 +0,0 @@

1−packages:

2− basic-auth/

3− curl-mock/

4− db-mysql-basics/

5− db-sqlite-simple/

6− db-postgres-pool/

7− using-custom-monad/

8− jwt-and-basic-auth/

9− hoist-server-with-context/

10− file-upload/

11− structuring-apis/

12− https/

13− pagination/

14− sentry/

15− testing/

16− open-id-connect/

17− ../../servant

18− ../../servant-server

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

20− ../../servant-client

21− ../../servant-docs

22− ../../servant-foreign

doc/cookbook/cabal.project.localdeleted

No changes to the content.

doc/cookbook/curl-mock/CurlMock.lhsdeleted−205

@@ -1,205 +0,0 @@

1−# Generating mock curl calls

2−

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

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

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

6−

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

8−

9−

10−Language extensions and imports:

11−``` haskell

12−{-# LANGUAGE DataKinds #-}

13−{-# LANGUAGE DeriveGeneric #-}

14−{-# LANGUAGE FlexibleContexts #-}

15−{-# LANGUAGE FlexibleInstances #-}

16−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

17−{-# LANGUAGE MultiParamTypeClasses #-}

18−{-# LANGUAGE OverloadedStrings #-}

19−{-# LANGUAGE RankNTypes #-}

20−{-# LANGUAGE RecordWildCards #-}

21−{-# LANGUAGE ScopedTypeVariables #-}

22−{-# LANGUAGE TypeOperators #-}

23−

24−import Control.Lens ((^.))

25−import Data.Aeson

26−import Data.Aeson.Text

27−import Data.Proxy (Proxy (Proxy))

28−import Data.Text (Text)

29−import Data.Text.Encoding (decodeUtf8)

30−import qualified Data.Text.IO as T.IO

31−import qualified Data.Text.Lazy as LazyT

32−import GHC.Generics

33−import Servant ((:<|>), (:>), Get, JSON,

34− Post, ReqBody)

35−import Servant.Foreign (Foreign, GenerateList,

36− HasForeign, HasForeignType, Req,

37− Segment, SegmentType (Cap, Static),

38− argName, listFromAPI, path,

39− reqBody, reqMethod, reqUrl, typeFor,

40− unPathSegment, unSegment,)

41−import Test.QuickCheck.Arbitrary

42−import Test.QuickCheck.Arbitrary.Generic

43−import Test.QuickCheck.Gen (generate)

44−import qualified Data.Text as T

45−

46−```

47−

48−

49−Let's define our API:

50−

51−``` haskell

52−type UserAPI = "users" :> Get '[JSON] [User]

53− :<|> "new" :> "user" :> ReqBody '[JSON] User :> Post '[JSON] ()

54−

55−data User = User

56− { name :: String

57− , age :: Int

58− , email :: String

59− } deriving (Eq, Show, Generic)

60−

61−instance Arbitrary User where

62− arbitrary = genericArbitrary

63− shrink = genericShrink

64−instance ToJSON User

65−instance FromJSON User

66−```

67−

68−Notice the `Arbitrary User` instance which we will later need to create mock data.

69−

70−Also, the obligatory servant boilerplate:

71−

72−``` haskell

73−api :: Proxy UserAPI

74−api = Proxy

75−```

76−

77−

78−## servant-foreign and the HasForeignType Class

79−

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

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

82−

83−``` haskell ignore

84−listFromAPI :: (HasForeign lang ftype api, GenerateList ftype (Foreign ftype api)) => Proxy lang -> Proxy ftype -> Proxy api -> [Req ftype]

85−```

86−

87−This looks a bit confusing...

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

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

90−

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

92−

93−We create a new datatype that holds our mocked value. Well, not the mocked value itself. To mock it we need IO (random). So the promise of a mocked value after some IO is performed:

94−

95−``` haskell

96−data NoLang

97−

98−data Mocked = Mocked (IO Text)

99−```

100−

101−Now, we create an instance of `HasForeignType` for `NoLang` and `Mocked` for every `a` that implements `ToJSON` and `Arbitrary`:

102−``` haskell

103−instance (ToJSON a, Arbitrary a) => HasForeignType NoLang Mocked a where

104− typeFor _ _ _ =

105− Mocked (genText (Proxy :: Proxy a))

106−```

107−

108−What does `genText` do? It generates an arbitrary value of type `a` and encodes it as text. (And does some lazy to non-lazy text transformation we do not care about):

109−

110−``` haskell

111−genText :: (ToJSON a, Arbitrary a) => Proxy a -> IO Text

112−genText p =

113− fmap (\v -> LazyT.toStrict $ encodeToLazyText v) (genArb p)

114−

115−genArb :: Arbitrary a => Proxy a -> IO a

116−genArb _ =

117− generate arbitrary

118−```

119−

120−### Generating curl calls for every endpoint

121−

122−Everything is prepared now and we can start generating some curl calls.

123−

124−``` haskell

125−generateCurl :: (GenerateList Mocked (Foreign Mocked api), HasForeign NoLang Mocked api)

126− => Proxy api

127− -> Text

128− -> IO Text

129−generateCurl p host =

130− fmap T.unlines body

131− where

132− body = mapM (generateEndpoint host)

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

134−```

135−

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

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

138−

139−``` haskell

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

141−generateEndpoint host req =

142− case maybeBody of

143− Just body ->

144− body >>= \b -> return $ T.intercalate " " [ "curl", "-X", method, "-d", "'" <> b <> "'"

145− , "-H 'Content-Type: application/json'", host <> "/" <> url ]

146− Nothing ->

147− return $ T.intercalate " " [ "curl", "-X", method, host <> "/" <> url ]

148− where

149− method = decodeUtf8 $ req ^. reqMethod

150−

151− url = T.intercalate "/" $ map segment (req ^. reqUrl . path)

152−

153− maybeBody = fmap (\(Mocked io) -> io) (req ^. reqBody)

154−

155−```

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

157−

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

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

160−

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

162−

163−``` haskell ignore

164−maybeBody = fmap (\(Mocked io) -> io) (req ^. reqBody)

165−```

166−

167−But it is that simple!

168−The docs say `reqBody` gives us a `Maybe f`. What is `f`, you ask? As defined in `generateCurl`, `f` is `Mocked` and contains a `IO Text`. How is this `Mocked` value created? The `HasForeignType::typeFor` does it!

169−

170−Of course only if the endpoint has a request body.

171−

172−

173−Some (incomplete) code for url segments:

174−``` haskell

175−segment :: Segment Mocked -> Text

176−segment seg =

177− case unSegment seg of

178− Static p ->

179− unPathSegment p

180−

181− Cap arg ->

182− -- Left as exercise for the reader: Mock args in the url

183− unPathSegment $ arg ^. argName

184−```

185−

186−And now, lets hook it all up in our main function:

187−

188−``` haskell

189−main :: IO ()

190−main =

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

192−```

193−

194−Done:

195−

196−``` curl

197−curl -X GET localhost:8081/users

198−curl -X POST -d '{"email":"wV򝣀_b򆎘:z񁊞򲙲!(3DM V","age":10,"name":"=|W"}' -H 'Content-Type: application/json' localhost:8081/new/user

199−

200−```

201−

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

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

204−

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

doc/cookbook/curl-mock/curl-mock.cabaldeleted−29

@@ -1,29 +0,0 @@

1−cabal-version: 2.2

2−name: cookbook-curl-mock

3−version: 0.1

4−synopsis: Generate curl mock requests cookbook example

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

6−license: BSD-3-Clause

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

8−author: Servant Contributors

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

10−build-type: Simple

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

12−

13−executable cookbock-curl-mock

14− if impl(ghc >= 9.2)

15− -- generic-arbitrary is incompatible

16− buildable: False

17− main-is: CurlMock.lhs

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

19− , aeson

20− , lens

21− , text

22− , servant

23− , servant-server

24− , servant-foreign

25− , QuickCheck

26− , generic-arbitrary

27− default-language: Haskell2010

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

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

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

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

1−# Customizing errors from Servant

2−

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

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

5−

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

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

8−

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

10−

11−Extensions and imports:

12−```haskell

13−{-# LANGUAGE DataKinds #-}

14−{-# LANGUAGE DeriveGeneric #-}

15−{-# LANGUAGE OverloadedStrings #-}

16−{-# LANGUAGE PolyKinds #-}

17−{-# LANGUAGE TypeFamilies #-}

18−{-# LANGUAGE TypeOperators #-}

19−

20−import Data.Aeson

21−import Data.Proxy

22−import Data.Text

23−import GHC.Generics

24−import Network.Wai

25−import Network.Wai.Handler.Warp

26−

27−import Servant

28−

29−import Data.String.Conversions

30− (cs)

31−import Servant.API.ContentTypes

32−```

33−

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

35−

36−```haskell

37−-- | A greet message data type

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

39− deriving (Generic, Show)

40−

41−instance FromJSON Greet

42−instance ToJSON Greet

43−

44−-- API specification

45−type TestApi =

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

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

48−

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

50− -- returns a Greet as JSON

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

52−

53− -- DELETE /greet/:greetid

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

55−

56−testApi :: Proxy TestApi

57−testApi = Proxy

58−

59−-- Server-side handlers.

60−--

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

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

63−--

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

65−server :: Server TestApi

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

67−

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

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

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

71−

72− postGreetH greet = return greet

73−

74− deleteGreetH _ = return NoContent

75−```

76−

77−## Error formatters

78−

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

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

81−

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

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

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

85− `Type.Reflection` modules.

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

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

88−

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

90−

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

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

93−

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

95−

96−```json

97−{

98− "error": "ERROR MESSAGE",

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

100−}

101−```

102−

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

104−message only if client can accept it.

105−

106−```haskell

107−customFormatter :: ErrorFormatter

108−customFormatter tr req err =

109− let

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

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

112− -- Accept header of the request

113− accH = getAcceptHeader req

114− in

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

116− -- certain message type.

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

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

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

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

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

122− Just (ctypeH, body) -> err400

123− { errBody = body

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

125− }

126−

127−notFoundFormatter :: NotFoundErrorFormatter

128−notFoundFormatter req =

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

130−```

131−

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

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

134−

135−```

136−err400

137− { errBody = encode body

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

139− }

140−```

141−

142−## Passing formatters to Servant

143−

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

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

146−

147−- `bodyParserErrorFormatter :: ErrorFormatter`

148−- `urlParseErrorFormatter :: ErrorFormatter`

149−- `headerParseErrorFormatter :: ErrorFormatter`

150−- `notFoundErrorFormatter :: NotFoundErrorFormatter`

151−

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

153−set the only ones you need:

154−

155−```haskell

156−customFormatters :: ErrorFormatters

157−customFormatters = defaultErrorFormatters

158− { bodyParserErrorFormatter = customFormatter

159− , notFoundErrorFormatter = notFoundFormatter

160− }

161−```

162−

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

164−

165−```haskell

166−app :: Application

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

168−

169−main :: IO ()

170−main = run 8000 app

171−```

172−

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

174−

175−```

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

177−HTTP/1.1 400 Bad Request

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

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

180−Server: Warp/3.3.12

181−Transfer-Encoding: chunked

182−

183−{

184− "combinator": "ReqBody'",

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

186−}

187−```

188−

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

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

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

1−cabal-version: 2.2

2−name: cookbook-custom-errors

3−version: 0.1

4−synopsis: Return custom error messages from combinators

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

6−license: BSD-3-Clause

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

8−author: Servant Contributors

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

10−build-type: Simple

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

12−

13−executable cookbook-custom-errors

14− main-is: CustomErrors.lhs

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

16− , aeson

17− , servant

18− , servant-server

19− , string-conversions

20− , text

21− , wai

22− , warp

23− default-language: Haskell2010

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

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

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

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

1−# Overview

2−

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

4−

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

6−

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

8−

9−## Setup

10−

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

12−

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

14−

15−## REST actions available

16−

17−*Get all people*

18−

19−```

20−/people GET

21−```

22−

23−*Get person by ID*

24−

25−```

26−/people/:id GET

27−```

28−

29−*Insert a new person*

30−

31−```

32−/people POST

33−

34−{

35− "name": "NewName",

36− "age": 24

37−}

38−```

39−

40−*Delete a person*

41−

42−```

43−/people/:id DELETE

44−```

45−

46−## Other notes

47−

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

49−

50−```

51−setup: Missing dependencies on foreign libraries:

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

53−```

54−

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

56−

57−```

58−extra-include-dirs:

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

60−extra-lib-dirs:

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

62−```

63−

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

65−

66−## Implementation: Main.hs

67−

68−Let's jump in:

69−

70−```haskell

71−{-# LANGUAGE DataKinds #-}

72−{-# LANGUAGE DeriveGeneric #-}

73−{-# LANGUAGE FlexibleInstances #-}

74−{-# LANGUAGE GADTs #-}

75−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

76−{-# LANGUAGE MultiParamTypeClasses #-}

77−{-# LANGUAGE QuasiQuotes #-}

78−{-# LANGUAGE TemplateHaskell #-}

79−{-# LANGUAGE TypeFamilies #-}

80−{-# LANGUAGE TypeOperators #-}

81−module Lib where

82−

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

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

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

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

87−import Data.Aeson as JSON

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

89−import Data.Text (Text)

90−import qualified Data.Text as T

91−import qualified Data.Text.IO as T

92−import Database.Persist

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

94− SqlBackend (..),

95− defaultConnectInfo, fromSqlKey, runMigration,

96− runSqlPool, toSqlKey, withMySQLConn)

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

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

99− persistLowerCase, share,

100− sqlSettings)

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

102−import Servant (Handler, throwError)

103−

104−import GHC.Generics

105−import Network.Wai

106−import Network.Wai.Handler.Warp

107−import Servant

108−import Servant.API

109−import System.Environment (getArgs)

110−

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

112−Person json

113− Id Int Primary Unique

114− name Text

115− age Text

116− deriving Eq Show Generic

117−|]

118−

119−type Api =

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

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

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

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

124−

125−apiProxy :: Proxy Api

126−apiProxy = Proxy

127−

128−app :: Application

129−app = serve apiProxy server

130−

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

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

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

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

135−

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

137−connInfo :: ConnectInfo

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

139−

140−doMigration :: IO ()

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

142−

143−server :: Server Api

144−server =

145− personGET :<|>

146− personGETById :<|>

147− personDELETE :<|>

148− personPOST

149− where

150− personGET = selectPersons

151− personGETById id = selectPersonById id

152− personDELETE id = deletePerson id

153− personPOST personJson = createPerson personJson

154−

155−selectPersons :: Handler [Person]

156−selectPersons = do

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

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

159−

160−selectPersonById :: Int -> Handler Person

161−selectPersonById id = do

162− sqlResult <- runDB $ get $ PersonKey id

163− case sqlResult of

164− Just person -> return person

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

166−

167−createPerson :: Person -> Handler Person

168−createPerson person = do

169− attemptCreate <- runDB $ insert person

170− case attemptCreate of

171− PersonKey k -> return person

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

173−

174−deletePerson :: Int -> Handler ()

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

176−

177−startApp :: IO ()

178−startApp = do

179− args <- getArgs

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

181− case arg1 of

182− Just "migrate" -> doMigration

183− _ -> run 8080 app

184−```

185−

186−## Sample requests

187−

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

189−

190−*Create a person*

191−

192−```bash

193−curl -X POST \

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

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

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

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

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

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

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

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

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

203− -d '{

204− "name": "Jake",

205− "age": "25"

206−}'

207−```

208−

209−*Get all persons*

210−

211−```bash

212−curl -X GET \

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

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

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

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

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

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

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

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

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

222−```

223−

224−*Get person by ID*

225−

226−```bash

227−curl -X GET \

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

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

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

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

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

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

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

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

236−```

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

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

1−cabal-version: 2.2

2−name: mysql-basics

3−version: 0.1.0.0

4−synopsis: Simple MySQL API cookbook example

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

6−license: BSD-3-Clause

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

8−author: Servant Contributors

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

10−build-type: Simple

11−

12−executable run

13− hs-source-dirs: .

14− main-is: MysqlBasics.hs

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

16− build-depends: aeson

17− , base

18− , bytestring

19− , http-client

20− , monad-logger

21− , mysql-simple

22− , persistent

23− , persistent-mysql

24− , persistent-template

25− , resource-pool

26− , resourcet

27− , servant

28− , servant-client

29− , servant-server

30− , text

31− , transformers

32− , wai

33− , warp

34− default-language: Haskell2010

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

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

37−

38−source-repository head

39− type: git

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

doc/cookbook/db-postgres-pool/PostgresPool.lhsdeleted−143

@@ -1,143 +0,0 @@

1−# PostgreSQL connection pool

2−

3−Let's see how we can write a simple web application that uses a

4−[PostgreSQL](https://www.postgresql.org/) database to store simple textual

5−messages, just like in the SQLite cookbook recipe. The main difference,

6−besides the database technology, is that in this example we will be using

7−a pool of connections to talk to the database server. The pool abstraction

8−will be provided by the

9−[resource-pool](https://hackage.haskell.org/package/resource-pool) library.

10−

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

12−

13−``` haskell

14−{-# LANGUAGE DataKinds #-}

15−{-# LANGUAGE OverloadedStrings #-}

16−{-# LANGUAGE TypeOperators #-}

17−import Data.ByteString (ByteString)

18−import Control.Concurrent

19−import Control.Exception (bracket)

20−import Control.Monad.IO.Class

21−import Data.Pool

22−import Database.PostgreSQL.Simple

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

24−import Network.Wai.Handler.Warp

25−import Servant

26−import Servant.Client

27−

28−type DBConnectionString = ByteString

29−```

30−

31−We will only care about a single type here, the messages. We want to

32−be able to add a new one and retrieve them all, using two different

33−endpoints.

34−

35−``` haskell

36−type Message = String

37−

38−type API = ReqBody '[PlainText] Message :> Post '[JSON] NoContent

39− :<|> Get '[JSON] [Message]

40−

41−api :: Proxy API

42−api = Proxy

43−```

44−

45−We proceed with a simple function for creating a table

46−for holding our messages if it doesn't already exist, given

47−a PostgreSQL connection string.

48−

49−``` haskell

50−initDB :: DBConnectionString -> IO ()

51−initDB connstr = bracket (connectPostgreSQL connstr) close $ \conn -> do

52− execute_ conn

53− "CREATE TABLE IF NOT EXISTS messages (msg text not null)"

54− return ()

55−```

56−

57−Next, our server implementation. It will be parametrised (take as

58−argument) by the pool of database connections that handlers can use to

59−talk to the PostgreSQL database. The resource pool abstraction allows us

60−to flexibly set up a whole bunch of PostgreSQL connections tailored to our

61−needs and then to forget about it all by simply asking for a connection

62−using `withResource`.

63−

64−The handlers are straightforward. One takes care of inserting a new

65−value in the database while the other fetches all messages and returns

66−them. We also provide a function for serving our web app given a PostgreSQL

67−connection pool, which simply calls servant-server's `serve` function.

68−

69−``` haskell

70−server :: Pool Connection -> Server API

71−server conns = postMessage :<|> getMessages

72−

73− where postMessage :: Message -> Handler NoContent

74− postMessage msg = do

75− liftIO . withResource conns $ \conn ->

76− execute conn

77− "INSERT INTO messages VALUES (?)"

78− (Only msg)

79− return NoContent

80−

81− getMessages :: Handler [Message]

82− getMessages = fmap (map fromOnly) . liftIO $

83− withResource conns $ \conn ->

84− query_ conn "SELECT msg FROM messages"

85−

86−runApp :: Pool Connection -> IO ()

87−runApp conns = run 8080 (serve api $ server conns)

88−```

89−

90−We will also need a function for initialising our connection pool.

91−`resource-pool` is quite configurable, feel free to wander in

92−[its documentation](https://hackage.haskell.org/package/resource-pool)

93−to gain a better understanding of how it works and what the configuration

94−knobs are. I will be using some dummy values in this example.

95−

96−``` haskell

97−initConnectionPool :: DBConnectionString -> IO (Pool Connection)

98−initConnectionPool connStr =

99− createPool (connectPostgreSQL connStr)

100− close

101− 2 -- stripes

102− 60 -- unused connections are kept open for a minute

103− 10 -- max. 10 connections open per stripe

104−```

105−

106−Let's finally derive some clients for our API and use them to

107−insert two messages and retrieve them in `main`, after setting up

108−our pool of database connections.

109−

110−``` haskell

111−postMsg :: Message -> ClientM NoContent

112−getMsgs :: ClientM [Message]

113−postMsg :<|> getMsgs = client api

114−

115−main :: IO ()

116−main = do

117− -- you could read this from some configuration file,

118− -- environment variable or somewhere else instead.

119− -- you will need to either change this connection string OR

120− -- set some environment variables (see

121− -- https://www.postgresql.org/docs/9.5/static/libpq-envars.html)

122− -- to point to a running PostgreSQL server for this example to work.

123− let connStr = ""

124− pool <- initConnectionPool connStr

125− initDB connStr

126− mgr <- newManager defaultManagerSettings

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

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

129− postMsg "hello"

130− postMsg "world"

131− getMsgs

132− print ms

133−```

134−

135−This program prints `Right ["hello","world"]` the first time it is executed,

136−`Right ["hello","world","hello","world"]` the second time and so on.

137−

138−You could alternatively have the handlers live in `ReaderT (Pool Connection)`

139−and access the pool using e.g `ask`, but this would be more complicated

140−than simply taking the pool as argument.

141−

142−The entire source for this example is available as a cabal project

143−[here](https://github.com/haskell-servant/servant/tree/master/doc/cookbook/db-postgres-pool).

doc/cookbook/db-postgres-pool/db-postgres-pool.cabaldeleted−32

@@ -1,32 +0,0 @@

1−cabal-version: 2.2

2−name: cookbook-db-postgres-pool

3−version: 0.1

4−synopsis: Simple PostgreSQL connection pool cookbook example

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

6−license: BSD-3-Clause

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

8−author: Servant Contributors

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

10−build-type: Simple

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

12−

13−executable cookbook-db-postgres-pool

14− main-is: PostgresPool.lhs

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

16− , bytestring >= 0.10

17− , text >= 1.2

18− , aeson >= 1.2

19− , servant

20− , servant-client

21− , servant-server

22− , warp >= 3.2

23− , wai >= 3.2

24− , http-types >= 0.12

25− , markdown-unlit >= 0.4

26− , http-client >= 0.5

27− , postgresql-simple >= 0.5

28− , resource-pool >= 0.2

29− , transformers

30− default-language: Haskell2010

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

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

doc/cookbook/db-sqlite-simple/DBConnection.lhsdeleted−100

@@ -1,100 +0,0 @@

1−# SQLite database

2−

3−Let's see how we can write a simple web application that uses an

4−[SQLite](https://www.sqlite.org/) database to store simple textual

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

6−

7−``` haskell

8−{-# LANGUAGE DataKinds #-}

9−{-# LANGUAGE OverloadedStrings #-}

10−{-# LANGUAGE TypeOperators #-}

11−import Control.Concurrent

12−import Control.Exception (bracket)

13−import Control.Monad.IO.Class

14−import Database.SQLite.Simple

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

16−import Network.Wai.Handler.Warp

17−import Servant

18−import Servant.Client

19−```

20−

21−We will only care about a single type here, the messages. We want to

22−be able to add a new one and retrieve them all, using two different

23−endpoints.

24−

25−``` haskell

26−type Message = String

27−

28−type API = ReqBody '[PlainText] Message :> Post '[JSON] NoContent

29− :<|> Get '[JSON] [Message]

30−

31−api :: Proxy API

32−api = Proxy

33−```

34−

35−We proceed with a simple function for creating a table

36−for holding our messages if it doesn't already exist.

37−

38−``` haskell

39−initDB :: FilePath -> IO ()

40−initDB dbfile = withConnection dbfile $ \conn ->

41− execute_ conn

42− "CREATE TABLE IF NOT EXISTS messages (msg text not null)"

43−```

44−

45−Next, our server implementation. It will be parametrised (take as an

46−argument) by the name of the file that contains our SQLite database.

47−The handlers are straightforward. One takes care of inserting a new

48−value in the database while the other fetches all messages and returns

49−them. We also provide a function for serving our web app given an

50−SQLite database file, which simply calls servant-server's `serve` function.

51−

52−``` haskell

53−server :: FilePath -> Server API

54−server dbfile = postMessage :<|> getMessages

55−

56− where postMessage :: Message -> Handler NoContent

57− postMessage msg = do

58− liftIO . withConnection dbfile $ \conn ->

59− execute conn

60− "INSERT INTO messages VALUES (?)"

61− (Only msg)

62− return NoContent

63−

64− getMessages :: Handler [Message]

65− getMessages = fmap (map fromOnly) . liftIO $

66− withConnection dbfile $ \conn ->

67− query_ conn "SELECT msg FROM messages"

68−

69−runApp :: FilePath -> IO ()

70−runApp dbfile = run 8080 (serve api $ server dbfile)

71−```

72−

73−Let's also derive some clients for our API and use them to

74−insert two messages and retrieve them in `main`.

75−

76−``` haskell

77−postMsg :: Message -> ClientM NoContent

78−getMsgs :: ClientM [Message]

79−postMsg :<|> getMsgs = client api

80−

81−main :: IO ()

82−main = do

83− -- you could read this from some configuration file,

84− -- environment variable or somewhere else instead.

85− let dbfile = "test.db"

86− initDB dbfile

87− mgr <- newManager defaultManagerSettings

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

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

90− postMsg "hello"

91− postMsg "world"

92− getMsgs

93− print ms

94−```

95−

96−This program prints `Right ["hello","world"]` the first time it is executed,

97−`Right ["hello","world","hello","world"]` the second time and so on.

98−

99−The entire source for this example is available as a cabal project

100−[here](https://github.com/haskell-servant/servant/tree/master/doc/cookbook/db-sqlite-simple).

doc/cookbook/db-sqlite-simple/db-sqlite-simple.cabaldeleted−30

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

1−cabal-version: 2.2

2−name: cookbook-db-sqlite-simple

3−version: 0.1

4−synopsis: Simple SQLite DB cookbook example

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

6−license: BSD-3-Clause

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

8−author: Servant Contributors

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

10−build-type: Simple

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

12−

13−executable cookbook-db-sqlite-simple

14− main-is: DBConnection.lhs

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

16− , text >= 1.2

17− , aeson >= 1.2

18− , servant

19− , servant-client

20− , servant-server

21− , warp >= 3.2

22− , wai >= 3.2

23− , http-types >= 0.12

24− , markdown-unlit >= 0.4

25− , http-client >= 0.5

26− , sqlite-simple >= 0.4.5.0

27− , transformers

28− default-language: Haskell2010

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

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

doc/cookbook/file-upload/FileUpload.lhsdeleted−140

@@ -1,140 +0,0 @@

1−# File Upload (`multipart/form-data`)

2−

3−In this recipe, we will implement a web application

4−with a single endpoint that can process

5−`multipart/form-data` request bodies, which most

6−commonly come from HTML forms that allow file upload.

7−

8−As usual, a bit of throat clearing.

9−

10−``` haskell

11−{-# LANGUAGE DataKinds #-}

12−{-# LANGUAGE TypeOperators #-}

13−{-# LANGUAGE OverloadedStrings #-}

14−

15−import Control.Concurrent

16−import Control.Exception

17−import Control.Monad

18−import Control.Monad.IO.Class

19−import Data.Text.Encoding (encodeUtf8)

20−import Network.Socket (withSocketsDo)

21−import Network.HTTP.Client hiding (Proxy)

22−import Network.HTTP.Client.MultipartFormData

23−import Network.Wai.Handler.Warp

24−import Servant

25−import Servant.Multipart

26−

27−import qualified Data.ByteString.Lazy as LBS

28−```

29−

30−Our API consists in a single `POST` endpoint at `/`

31−that takes a `multipart/form-data` request body and

32−pretty-prints the data it got to stdout before returning `0`

33−(because why not).

34−

35−``` haskell

36−type API = MultipartForm Mem (MultipartData Mem) :> Post '[JSON] Integer

37−

38−api :: Proxy API

39−api = Proxy

40−```

41−

42−Because of some technicalities, multipart form data is not

43−represented as a good old content type like `JSON` in servant,

44−that one could use with `ReqBody`, but instead is its own

45−dedicated `ReqBody`-like combinator named

46−[`MultiPartForm`](https://hackage.haskell.org/package/servant-multipart-0.11/docs/Servant-Multipart.html#t:MultipartForm).

47−

48−This combinator takes two parameters. The first one is the

49−"backend" to use. Currently, you only have the choice between

50−`Mem` and `Tmp`. The former loads the entire input in memory,

51−even the uploaded files, while `Tmp` will stream uploaded

52−files to some temporary directory.

53−

54−The second parameter is the type you want the multipart data

55−to be decoded to. Indeed there is a `FromMultipart` class that

56−allows you to specify how to decode multipart form data from

57−`MultipartData` to a custom type of yours. Here we use the

58−trivial "decoding" to `MultipartData` itself, and simply

59−will get our hands on the raw input. If you want to use

60−a type of yours, see the documentation for

61−[`FromMultipart`](https://hackage.haskell.org/package/servant-multipart-0.11/docs/Servant-Multipart.html#t:FromMultipart).

62−

63−Our only request handler has type `MultipartData Mem -> Handler Integer`.

64−All it does is list the textual and file inputs that

65−were sent in the multipart request body. The textual

66−inputs are in the `inputs` field while the file inputs

67−are in the `files` field of `multipartData`.

68−

69−``` haskell

70−-- MultipartData consists in textual inputs,

71−-- accessible through its "inputs" field, as well

72−-- as files, accessible through its "files" field.

73−upload :: Server API

74−upload multipartData = do

75− liftIO $ do

76− putStrLn "Inputs:"

77− forM_ (inputs multipartData) $ \input ->

78− putStrLn $ " " ++ show (iName input)

79− ++ " -> " ++ show (iValue input)

80−

81− forM_ (files multipartData) $ \file -> do

82− let content = fdPayload file

83− putStrLn $ "Content of " ++ show (fdFileName file)

84− LBS.putStr content

85− return 0

86−

87−startServer :: IO ()

88−startServer = run 8080 (serve api upload)

89−```

90−

91−Finally, a main function that brings up our server and

92−sends some test request with `http-client` (and not

93−servant-client this time, as servant-multipart does not

94−yet have support for client generation).

95−

96−``` haskell

97−main :: IO ()

98−main = withSocketsDo . bracket (forkIO startServer) killThread $ \_threadid -> do

99− -- we fork the server in a separate thread and send a test

100− -- request to it from the main thread.

101− manager <- newManager defaultManagerSettings

102− req <- parseRequest "http://localhost:8080/"

103− resp <- flip httpLbs manager =<< formDataBody form req

104− print resp

105−

106− where form =

107− [ partBS "title" "World"

108− , partBS "text" $ encodeUtf8 "Hello"

109− , partFileSource "file" "./README.md"

110− ]

111−```

112−

113−If you run this, you should get:

114−

115−``` bash

116−$ cabal new-build cookbook-file-upload

117−[...]

118−$ dist-newstyle/build/x86_64-linux/ghc-8.2.1/cookbook-file-upload-0.1/x/cookbook-file-upload/build/cookbook-file-upload/cookbook-file-upload

119−Inputs:

120− "title" -> "World"

121− "text" -> "Hello"

122−Content of "README.md"

123−# servant - A Type-Level Web DSL

124−

125−![servant](https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png)

126−

127−## Getting Started

128−

129−We have a [tutorial](http://docs.servant.dev/en/stable/tutorial/index.html) that

130−introduces the core features of servant. After this article, you should be able

131−to write your first servant webservices, learning the rest from the haddocks'

132−examples.

133−

134−[...]

135−

136−Response {responseStatus = Status {statusCode = 200, statusMessage = "OK"}, responseVersion = HTTP/1.1, responseHeaders = [("Transfer-Encoding","chunked"),("Date","Fri, 08 Dec 2017 16:50:14 GMT"),("Server","Warp/3.2.13"),("Content-Type","application/json;charset=utf-8")], responseBody = "0", responseCookieJar = CJ {expose = []}, responseClose' = ResponseClose}

137−```

138−

139−As usual, the code for this recipe is available in a cabal project

140−[here](https://github.com/haskell-servant/servant/tree/master/doc/cookbook/file-upload).

doc/cookbook/file-upload/file-upload.cabaldeleted−30

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

1−cabal-version: 2.2

2−name: cookbook-file-upload

3−version: 0.1

4−synopsis: File upload cookbook example

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

6−license: BSD-3-Clause

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

8−author: Servant Contributors

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

10−build-type: Simple

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

12−

13−executable cookbook-file-upload

14− main-is: FileUpload.lhs

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

16− , text >= 1.2

17− , mtl >= 2.1

18− , network >= 2.6

19− , bytestring >= 0.10

20− , servant

21− , servant-server

22− , servant-multipart

23− , transformers

24− , warp >= 3.2

25− , wai >= 3.2

26− , markdown-unlit >= 0.4

27− , http-client >= 0.5

28− default-language: Haskell2010

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

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

doc/cookbook/generic/Generic.lhsdeleted−141

@@ -1,141 +0,0 @@

1−# Using generics

2−

3−```haskell

4−{-# LANGUAGE DataKinds #-}

5−{-# LANGUAGE DeriveGeneric #-}

6−{-# LANGUAGE RankNTypes #-}

7−{-# LANGUAGE TypeOperators #-}

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

9−

10−import Control.Exception (throwIO)

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

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

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

14−import System.Environment (getArgs)

15−

16−import Servant

17−import Servant.Client

18−

19−import Servant.API.Generic

20−import Servant.Client.Generic

21−import Servant.Server.Generic

22−```

23−

24−The usage is simple, if you only need a collection of routes.

25−First you define a record with field types prefixed by a parameter `route`:

26−

27−```haskell

28−data Routes route = Routes

29− { _get :: route :- Capture "id" Int :> Get '[JSON] String

30− , _put :: route :- ReqBody '[JSON] Int :> Put '[JSON] Bool

31− }

32− deriving (Generic)

33−```

34−

35−Then we'll use this data type to define API, links, server and client.

36−

37−## API

38−

39−You can get a `Proxy` of the API using `genericApi`:

40−

41−```haskell

42−api :: Proxy (ToServantApi Routes)

43−api = genericApi (Proxy :: Proxy Routes)

44−```

45−

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

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

48−

49−## Links

50−

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

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

53−as field accessors work as proxies:

54−

55−```haskell

56−getLink :: Int -> Link

57−getLink = fieldLink _get

58−```

59−

60−We can also get all links at once, as a record:

61−

62−```haskell

63−routesLinks :: Routes (AsLink Link)

64−routesLinks = allFieldLinks

65−```

66−

67−## Client

68−

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

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

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

72−

73−```haskell

74−cliRoutes :: Routes (AsClientT IO)

75−cliRoutes = genericClientHoist

76− (\x -> runClientM x env >>= either throwIO return)

77− where

78− env = error "undefined environment"

79−

80−cliGet :: Int -> IO String

81−cliGet = _get cliRoutes

82−```

83−

84−## Server

85−

86−Finally, probably the most handy usage: we can convert record of handlers into

87−the server implementation:

88−

89−```haskell

90−record :: Routes AsServer

91−record = Routes

92− { _get = return . show

93− , _put = return . odd

94− }

95−

96−app :: Application

97−app = genericServe record

98−

99−main :: IO ()

100−main = do

101− args <- getArgs

102− case args of

103− ("run":_) -> do

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

105− run 8000 app

106− -- see this cookbook below for custom-monad explanation

107− ("run-custom-monad":_) -> do

108− putStrLn "Starting cookbook-generic with a custom monad at http://localhost:8000"

109− run 8000 (appMyMonad AppCustomState)

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

111−```

112−

113−## Using generics together with a custom monad

114−

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

116−generics.

117−

118−```haskell

119−data AppCustomState =

120− AppCustomState

121−

122−type AppM = ReaderT AppCustomState Handler

123−

124−apiMyMonad :: Proxy (ToServantApi Routes)

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

126−

127−getRouteMyMonad :: Int -> AppM String

128−getRouteMyMonad = return . show

129−

130−putRouteMyMonad :: Int -> AppM Bool

131−putRouteMyMonad = return . odd

132−

133−recordMyMonad :: Routes (AsServerT AppM)

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

135−

136−-- natural transformation

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

138−nt s x = runReaderT x s

139−

140−appMyMonad :: AppCustomState -> Application

141−appMyMonad state = genericServeT (nt state) recordMyMonad

doc/cookbook/generic/generic.cabaldeleted−25

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

1−cabal-version: 2.2

2−name: cookbook-generic

3−version: 0.1

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

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

6−license: BSD-3-Clause

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

8−author: Servant Contributors

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

10−build-type: Simple

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

12−

13−executable cookbook-using-custom-monad

14− main-is: Generic.lhs

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

16− , servant

17− , servant-client

18− , servant-client-core

19− , servant-server

20− , base-compat

21− , warp >= 3.2

22− , transformers >= 0.3

23− default-language: Haskell2010

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

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

doc/cookbook/hoist-server-with-context/HoistServerWithContext.lhsdeleted−413

@@ -1,413 +0,0 @@

1−# Hoist Server With Context for Custom Monads

2−

3−In this example we'll combine some of the patterns we've seen in other examples

4−in order to demonstrate using a custom monad with Servant's `Context` and the function

5−`hoistServerWithContext`.

6−

7−`hoistServerWithContext` is a pattern you may encounter if you are trying to use a library such as

8−[servant-auth-server](https://hackage.haskell.org/package/servant-auth-server) along

9−with your own custom monad.

10−

11−In this example, our custom monad will be based on the commonly used `ReaderT env IO a` stack.

12−We'll create an `AppCtx` to represent our `env` and include some logging utilities as well as

13−other variables we'd like to have available.

14−

15−In addition, in order to demonstrate a custom `Context`, we'll also include authentication in

16−our example. As noted previously (in [jwt-and-basic-auth](../jwt-and-basic-auth/JWTAndBasicAuth.lhs)),

17−while basic authentication comes with Servant itself,

18−[servant-auth](https://hackage.haskell.org/package/servant-auth) and

19−[servant-auth-server](https://hackage.haskell.org/package/servant-auth-server)

20−packages are needed for JWT-based authentication.

21−

22−Finally, we're going to use [fast-logger](http://hackage.haskell.org/package/fast-logger)

23−for our logging example below.

24−

25−This recipe uses the following ingredients:

26−

27−```haskell

28−{-# LANGUAGE DataKinds #-}

29−{-# LANGUAGE DeriveGeneric #-}

30−{-# LANGUAGE OverloadedStrings #-}

31−{-# LANGUAGE TypeFamilies #-}

32−{-# LANGUAGE TypeOperators #-}

33−

34−import Prelude ()

35−import Prelude.Compat

36−

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

38−import Control.Monad.Reader

39−import Data.Aeson

40−import Data.Default

41−import Data.Proxy

42−import Data.Text

43−import Data.Time.Clock ( UTCTime, getCurrentTime )

44−import GHC.Generics

45−import Network.Wai (Middleware)

46−import Network.Wai.Handler.Warp as Warp

47−import Network.Wai.Middleware.RequestLogger

48−import Network.Wai.Middleware.RequestLogger.JSON

49−import Servant as S

50−import Servant.Auth as SA

51−import Servant.Auth.Server as SAS

52−import System.Log.FastLogger ( ToLogStr(..)

53− , LoggerSet

54− , defaultBufSize

55− , newStdoutLoggerSet

56− , flushLogStr

57− , pushLogStrLn )

58−

59−

60−port :: Int

61−port = 3001

62−```

63−

64−## Custom Monad

65−

66−Let's say we'd like to create a custom monad based on `ReaderT env` in order to hold

67−access to a config object as well as some logging utilities.

68−

69−With that, we could define an `AppCtx` and `AppM` like this:

70−

71−```haskell

72−type AppM = ReaderT AppCtx Handler

73−

74−data AppCtx = AppCtx {

75− _getConfig :: SiteConfig

76− , _getLogger :: LoggerSet

77− }

78−

79−data SiteConfig = SiteConfig {

80− environment :: !Text

81− , version :: !Text

82− , adminUsername :: !Text

83− , adminPasswd :: !Text

84−} deriving (Generic, Show)

85−```

86−

87−This `SiteConfig` is a simple example: it refers to our deployment environment as well as an

88−application version. For instance, we may do something different based on the environment our app is

89−deployed into. When emitting log messages, we may want to include information about

90−the deployed version of our application.

91−

92−In addition, we're going to identify a single admin user in our config and use

93−that definition to authenticate requests inside our handlers. This is not too

94−flexible (and probably not too secure...), but it works as a simple example.

95−

96−## Logging

97−

98−A common contemporary pattern is to emit log messages as JSON for later ingestion

99−into a database like Elasticsearch.

100−

101−To emit JSON log messages, we'll create a `LogMessage` object and make it so we can turn it

102−into a JSON-encoded `LogStr` (a type from `fast-logger`).

103−

104−```haskell

105−data LogMessage = LogMessage {

106− message :: !Text

107− , timestamp :: !UTCTime

108− , level :: !Text

109− , lversion :: !Text

110− , lenvironment :: !Text

111−} deriving (Eq, Show, Generic)

112−

113−instance FromJSON LogMessage

114−instance ToJSON LogMessage where

115− toEncoding = genericToEncoding defaultOptions

116−

117−instance ToLogStr LogMessage where

118− toLogStr = toLogStr . encode

119−```

120−

121−Eventually, when we'd like to emit a log message inside one of our Handlers, it'll look like this:

122−

123−```haskell

124−sampleHandler :: AppM LogMessage

125−sampleHandler = do

126− config <- asks _getConfig

127− logset <- asks _getLogger

128−

129− tstamp <- liftIO getCurrentTime

130− let logMsg = LogMessage { message = "let's do some logging!"

131− , timestamp = tstamp

132− , level = "info"

133− , lversion = version config

134− , lenvironment = environment config

135− }

136− -- emit log message

137− liftIO $ pushLogStrLn logset $ toLogStr logMsg

138− -- return handler result (for simplicity, result is also a LogMessage)

139− pure logMsg

140−```

141−

142−## Authentication

143−

144−To demonstrate the other part of this recipe, we are going to use a simple

145−representation of a user, someone who may have access to an admin section of our site:

146−

147−```haskell

148−data AdminUser = AdminUser { name :: Text }

149− deriving (Eq, Show, Read, Generic)

150−```

151−

152−The following instances are needed for JWT:

153−

154−```haskell

155−instance ToJSON AdminUser

156−instance FromJSON AdminUser

157−instance SAS.ToJWT AdminUser

158−instance SAS.FromJWT AdminUser

159−```

160−

161−## API

162−

163−Now we can define our API.

164−

165−We'll have an `admin` endpoint and a `login` endpoint that takes a `LoginForm`:

166−

167−```haskell

168−type AdminApi =

169− "admin" :> Get '[JSON] LogMessage

170−

171−type LoginApi =

172− "login"

173− :> ReqBody '[JSON] LoginForm

174− :> Post '[JSON] (Headers '[ Header "Set-Cookie" SetCookie, Header "Set-Cookie" SetCookie] LogMessage)

175−

176−data LoginForm = LoginForm {

177− username :: Text

178− , password :: Text

179−} deriving (Eq, Show, Generic)

180−

181−instance ToJSON LoginForm

182−instance FromJSON LoginForm

183−```

184−

185−We can combine both APIs into one like so:

186−

187−```haskell

188−type AdminAndLogin auths = (SAS.Auth auths AdminUser :> AdminApi) :<|> LoginApi

189−```

190−

191−## Server

192−

193−When we define our server, we'll have to define handlers for the `AdminApi` and the `LoginApi` and

194−we'll have to supply `JWTSettings` and `CookieSettings` so our `login` handler can authenticate users:

195−

196−```haskell

197−adminServer :: SAS.CookieSettings -> SAS.JWTSettings -> ServerT (AdminAndLogin auths) AppM

198−adminServer cs jwts = adminHandler :<|> loginHandler cs jwts

199−```

200−

201−The `admin` route should receive an authenticated `AdminUser` as an argument

202−or it should return a `401`:

203−

204−```haskell

205−adminHandler :: AuthResult AdminUser -> AppM LogMessage

206−adminHandler (SAS.Authenticated adminUser) = do

207− config <- asks _getConfig

208− logset <- asks _getLogger

209−

210− tstamp <- liftIO getCurrentTime

211− let logMsg = LogMessage { message = "Admin User accessing admin: " <> name adminUser

212− , timestamp = tstamp

213− , level = "info"

214− , lversion = version config

215− , lenvironment = environment config

216− }

217− -- emit log message

218− liftIO $ pushLogStrLn logset $ toLogStr logMsg

219− -- return handler result (for simplicity, result is a LogMessage)

220− pure logMsg

221−adminHandler _ = throwError err401

222−```

223−

224−By contrast, the `login` handler is waiting for a `POST` with a login form.

225−

226−If login is successful, it will set session cookies and return a value.

227−

228−Here we're going to include lots of log messages:

229−

230−```haskell

231−loginHandler :: CookieSettings

232− -> JWTSettings

233− -> LoginForm

234− -> AppM (Headers '[ Header "Set-Cookie" SetCookie, Header "Set-Cookie" SetCookie] LogMessage)

235−loginHandler cookieSettings jwtSettings form = do

236− config <- asks _getConfig

237− logset <- asks _getLogger

238−

239− tstamp <- liftIO getCurrentTime

240− let logMsg = LogMessage { message = "AdminUser login attempt failed!"

241− , timestamp = tstamp

242− , level = "info"

243− , lversion = version config

244− , lenvironment = environment config

245− }

246− case validateLogin config form of

247− Nothing -> do

248− liftIO $ pushLogStrLn logset $ toLogStr logMsg

249− throwError err401

250− Just usr -> do

251− mApplyCookies <- liftIO $ SAS.acceptLogin cookieSettings jwtSettings usr

252− case mApplyCookies of

253− Nothing -> do

254− liftIO $ pushLogStrLn logset $ toLogStr logMsg

255− throwError err401

256− Just applyCookies -> do

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

258− liftIO $ pushLogStrLn logset $ toLogStr successMsg

259− pure $ applyCookies successMsg

260−loginHandler _ _ _ = throwError err401

261−

262−validateLogin :: SiteConfig -> LoginForm -> Maybe AdminUser

263−validateLogin config (LoginForm uname passwd ) =

264− if (uname == adminUsername config) && (passwd == adminPasswd config)

265− then Just $ AdminUser uname

266− else Nothing

267−```

268−

269−## `serveWithContext` and `hoistServerWithContext`

270−

271−In order to build a working server, we'll need to `hoist` our custom monad

272−into Servant's Handler monad. We'll also need to pass in the proper context to ensure

273−authentication will work.

274−

275−This will require both `serveWithContext` and `hoistServerWithContext`.

276−

277−Let's define the function which will create our `Application`:

278−

279−```haskell

280−adminLoginApi :: Proxy (AdminAndLogin '[JWT])

281−adminLoginApi = Proxy

282−

283−mkApp :: Context '[SAS.CookieSettings, SAS.JWTSettings] -> CookieSettings -> JWTSettings -> AppCtx -> Application

284−mkApp cfg cs jwts ctx =

285− serveWithContext adminLoginApi cfg $

286− hoistServerWithContext adminLoginApi (Proxy :: Proxy '[SAS.CookieSettings, SAS.JWTSettings])

287− (flip runReaderT ctx) (adminServer cs jwts)

288−```

289−

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

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

292−

293−```haskell

294−jsonRequestLogger :: IO Middleware

295−jsonRequestLogger =

296− mkRequestLogger $ def { outputFormat = CustomOutputFormatWithDetails formatAsJSON }

297−```

298−

299−We now have all the pieces we need to serve our application inside a `main` function:

300−

301−```haskell

302−main :: IO ()

303−main = do

304− -- typically, we'd create our config from environment variables

305− -- but we're going to just make one here

306− let config = SiteConfig "dev" "1.0.0" "admin" "secretPassword"

307−

308− warpLogger <- jsonRequestLogger

309− appLogger <- newStdoutLoggerSet defaultBufSize

310−

311− tstamp <- getCurrentTime

312− myKey <- generateKey

313−

314− let lgmsg = LogMessage {

315− message = "My app starting up!"

316− , timestamp = tstamp

317− , level = "info"

318− , lversion = version config

319− , lenvironment = environment config

320− }

321− pushLogStrLn appLogger (toLogStr lgmsg) >> flushLogStr appLogger

322−

323− let ctx = AppCtx config appLogger

324−

325− warpSettings = Warp.defaultSettings

326− portSettings = Warp.setPort port warpSettings

327− settings = Warp.setTimeout 55 portSettings

328− jwtCfg = defaultJWTSettings myKey

329− cookieCfg = if environment config == "dev"

330− then defaultCookieSettings{cookieIsSecure=SAS.NotSecure}

331− else defaultCookieSettings

332− cfg = cookieCfg :. jwtCfg :. EmptyContext

333−

334− Warp.runSettings settings $ warpLogger $ mkApp cfg cookieCfg jwtCfg ctx

335−```

336−

337−

338−## Usage

339−

340−Now we can run it and try it out with `curl`. In one terminal, let's run our application

341−and see what our log output looks like:

342−

343−```$ ./cookbook-hoist-server-with-context

344−{"message":"My app starting up!","timestamp":"2018-10-04T00:33:12.482568Z","level":"info","lversion":"1.0.0","lenvironment":"dev"}

345−```

346−

347−In another terminal, let's ensure that it fails with `err401` if

348−we're not authenticated:

349−

350−```

351−$ curl -v 'http://localhost:3001/admin'

352−…

353−< HTTP/1.1 401 Unauthorized

354−```

355−

356−```

357−$ curl -v -XPOST 'http://localhost:3001/login' \

358− -H "Content-Type:application/json" \

359− -d '{"username": "bad", "password": "wrong"}'

360−…

361−< HTTP/1.1 401 Unauthorized

362−```

363−

364−And in the other terminal with our log messages (from our JSON `Middleware`):

365−

366−```

367−{"time":"03/Oct/2018:17:35:56 -0700","response":{"status":401,"size":null,"body":""},"request":{"httpVersion":"1.1","path":"/admin","size":0,"body":"","durationMs":0.22,"remoteHost":{"hostAddress":"127.0.0.1","port":51029},"headers":[["Host","localhost:3001"],["User-Agent","curl/7.60.0"],["Accept","*/*"]],"queryString":[],"method":"GET"}}

368−```

369−

370−Now let's see that authentication works, and that we get JWTs:

371−

372−```

373−$ curl -v -XPOST 'http://localhost:3001/login' \

374− -H "Content-Type:application/json" \

375− -d '{"username": "admin", "password": "secretPassword"}'

376−…

377−< HTTP/1.1 200 OK

378−...

379−< Server: Warp/3.2.25

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

381−< Set-Cookie: JWT-Cookie=eyJhbGciOiJIUzUxMiJ9.eyJkYXQiOnsibmFtZSI6ImFkbWluIn19.SIoRcABKSO4mXnRifzqPWlHJUhVwuy32Qon7s1E_c3vHOsLXdXyX4V4eXOw9tMFoeIqgsXMZucqoFb36vAdKwQ; Path=/; HttpOnly; SameSite=Lax

382−< Set-Cookie: XSRF-TOKEN=y5PmrYHX3ywFUCwGRQqHh1TDheTLiQpwRQB3FFRd8N4=; Path=/

383−...

384−{"message":"AdminUser succesfully authenticated!","timestamp":"2018-10-04T00:37:44.455441Z","level":"info","lversion":"1.0.0","lenvironment":"dev"}

385−```

386−

387−And in the other terminal with our log messages (note that logging out passwords is insecure...):

388−

389−```

390−{"message":"AdminUser succesfully authenticated!","timestamp":"2018-10-04T00:37:44.455441Z","level":"info","lversion":"1.0.0","lenvironment":"dev"}

391−{"time":"03/Oct/2018:17:37:44 -0700","response":{"status":200,"size":null,"body":null},"request":{"httpVersion":"1.1","path":"/login","size":51,"body":"{\"username\": \"admin\", \"password\": \"secretPassword\"}","durationMs":0.23,"remoteHost":{"hostAddress":"127.0.0.1","port":51044},"headers":[["Host","localhost:3001"],["User-Agent","curl/7.60.0"],["Accept","*/*"],["Content-Type","application/json"],["Content-Length","51"]],"queryString":[],"method":"POST"}}

392−```

393−

394−Finally, let's make sure we can access a protected resource with our tokens:

395−

396−```

397−$ export jwt=eyJhbGciOiJIUzUxMiJ9.eyJkYXQiOnsibmFtZSI6ImFkbWluIn19.SIoRcABKSO4mXnRifzqPWlHJUhVwuy32Qon7s1E_c3vHOsLXdXyX4V4eXOw9tMFoeIqgsXMZucqoFb36vAdKwQ

398−$ curl -v \

399− -H "Authorization: Bearer $jwt" \

400− 'http://localhost:3001/admin'

401−…

402−< HTTP/1.1 200 OK

403−{"message":"Admin User accessing admin: admin","timestamp":"2018-10-04T00:58:07.216605Z","level":"info","lversion":"1.0.0","lenvironment":"dev"}

404−```

405−

406−And we should see this message logged-out as well:

407−

408−```

409−{"message":"Admin User accessing admin: admin","timestamp":"2018-10-04T00:58:07.216605Z","level":"info","lversion":"1.0.0","lenvironment":"dev"}

410−```

411−

412−This program is available as a cabal project

413−[here](https://github.com/haskell-servant/servant/tree/master/doc/cookbook/hoist-server-with-context).

doc/cookbook/hoist-server-with-context/hoist-server-with-context.cabaldeleted−37

@@ -1,37 +0,0 @@

1−cabal-version: 2.2

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

3−version: 0.0.1

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

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

6− authentication.

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

8−license: BSD-3-Clause

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

10−author: Servant Contributors

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

12−category: Servant

13−build-type: Simple

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

15−

16−executable cookbook-hoist-server-with-context

17− main-is: HoistServerWithContext.lhs

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

19− , base-compat

20− , text >= 1.2

21− , aeson >= 1.2

22− , data-default

23− , fast-logger

24− , servant

25− , servant-server

26− , servant-auth >= 0.3.2

27− , servant-auth-server >= 0.4.4.0

28− , time

29− , warp >= 3.2

30− , wai >= 3.2

31− , wai-extra

32− , http-types >= 0.12

33− , bytestring >= 0.10.4

34− , mtl

35− default-language: Haskell2010

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

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

doc/cookbook/https/Https.lhsdeleted−62

@@ -1,62 +0,0 @@

1−# Serving web applications over HTTPS

2−

3−This short recipe shows how one can serve a servant application

4−over HTTPS, by simply using `warp-tls` instead of `warp` to provide

5−us a `run` function for running the `Application` that we get by

6−calling `serve`.

7−

8−As usual, we start by clearing our throat of a few language extensions

9−and imports.

10−

11−``` haskell

12−{-# LANGUAGE DataKinds #-}

13−{-# LANGUAGE TypeOperators #-}

14−import Network.Wai

15−import Network.Wai.Handler.Warp

16−import Network.Wai.Handler.WarpTLS

17−import Servant

18−```

19−

20−No need to work with a complicated API here, let's

21−make it as simple as it gets:

22−

23−``` haskell

24−type API = Get '[JSON] Int

25−

26−api :: Proxy API

27−api = Proxy

28−

29−server :: Server API

30−server = return 10

31−

32−app :: Application

33−app = serve api server

34−```

35−

36−It's now time to actually run the `Application`.

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

38−package provides two functions for running an `Application`, called

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

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

41−We will be using the first one.

42−

43−It takes two arguments,

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

45−(certificates, keys, ciphers, etc)

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

47−(port, logger, etc).

48−

49−We will be using very simple settings for this example but you are of

50−course invited to read the documentation for those types to find out

51−about all the knobs that you can play with.

52−

53−``` haskell

54−main :: IO ()

55−main = runTLS tlsOpts warpOpts app

56−

57− where tlsOpts = tlsSettings "cert.pem" "secret-key.pem"

58− warpOpts = setPort 8080 defaultSettings

59−```

60−

61−This program is available as a cabal project

62−[here](https://github.com/haskell-servant/servant/tree/master/doc/cookbook/https).

doc/cookbook/https/https.cabaldeleted−24

@@ -1,24 +0,0 @@

1−cabal-version: 2.2

2−name: cookbook-https

3−version: 0.1

4−synopsis: HTTPS cookbook example

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

6−license: BSD-3-Clause

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

8−author: Servant Contributors

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

10−build-type: Simple

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

12−

13−executable cookbook-https

14− main-is: Https.lhs

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

16− , servant

17− , servant-server

18− , wai >= 3.2

19− , warp >= 3.2

20− , warp-tls >= 3.2.9

21− , markdown-unlit >= 0.4

22− default-language: Haskell2010

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

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

doc/cookbook/index.rstdeleted−39

@@ -1,39 +0,0 @@

1−Cookbook

2−========

3−

4−This page is a *collective effort* whose goal is to show

5−how to solve many common problems with servant. If you're

6−interested in contributing examples of your own, feel free

7−to open an issue or a pull request on

8−`our github repository <https://github.com/haskell-servant/servant>`_

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

10−on libera.chat <https://web.libera.chat/#haskell-servant>_ or on

11−`the mailing list <https://groups.google.com/forum/#!forum/haskell-servant>`_.

12−

13−The scope is very wide. Simple and fancy authentication schemes,

14−file upload, type-safe links, working with CSV, .zip archives,

15−you name it!

16−

17−.. toctree::

18− :maxdepth: 1

19−

20− structuring-apis/StructuringApis.lhs

21− generic/Generic.lhs

22− https/Https.lhs

23− db-mysql-basics/MysqlBasics.lhs

24− db-sqlite-simple/DBConnection.lhs

25− db-postgres-pool/PostgresPool.lhs

26− using-custom-monad/UsingCustomMonad.lhs

27− using-free-client/UsingFreeClient.lhs

28− custom-errors/CustomErrors.lhs

29− uverb/UVerb.lhs

30− basic-auth/BasicAuth.lhs

31− basic-streaming/Streaming.lhs

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

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

34− file-upload/FileUpload.lhs

35− pagination/Pagination.lhs

36− curl-mock/CurlMock.lhs

37− sentry/Sentry.lhs

38− testing/Testing.lhs

39− open-id-connect/OpenIdConnect.lhs

doc/cookbook/jwt-and-basic-auth/JWTAndBasicAuth.lhsdeleted−252

@@ -1,252 +0,0 @@

1−# Combining JWT-based authentication with basic access authentication

2−

3−In this example we will make a service with

4−[basic HTTP authentication](https://en.wikipedia.org/wiki/Basic_access_authentication)

5−for Haskell clients and other programs, as well as

6−with [JWT](https://en.wikipedia.org/wiki/JSON_Web_Token)-based

7−authentication for web browsers. Web browsers will still use basic

8−HTTP authentication to retrieve JWTs though.

9−

10−**Warning**: this is insecure when done over plain HTTP,

11−so [TLS](https://en.wikipedia.org/wiki/Transport_Layer_Security)

12−should be used.

13−See [warp-tls](https://hackage.haskell.org/package/warp-tls) for that.

14−

15−While basic authentication comes with Servant itself,

16−[servant-auth](https://hackage.haskell.org/package/servant-auth) and

17−[servant-auth-server](https://hackage.haskell.org/package/servant-auth-server)

18−packages are needed for the JWT-based one.

19−

20−This recipe uses the following ingredients:

21−

22−```haskell

23−{-# LANGUAGE OverloadedStrings, TypeFamilies, DataKinds,

24− DeriveGeneric, TypeOperators #-}

25−import Data.Aeson

26−import GHC.Generics

27−import Data.Proxy

28−import System.IO

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

30−import Network.Wai.Handler.Warp

31−import Servant as S

32−import Servant.Client

33−import Servant.Auth as SA

34−import Servant.Auth.Server as SAS

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

36−import Data.Map as M

37−import Data.ByteString (ByteString)

38−

39−port :: Int

40−port = 3001

41−```

42−

43−

44−## Authentication

45−

46−Below is how we'll represent a user: usually user identifier is handy

47−to keep around, along with their role if

48−[role-based access control](https://en.wikipedia.org/wiki/Role-based_access_control)

49−is used, and other commonly needed information, such as an

50−organization identifier:

51−

52−```haskell

53−data AuthenticatedUser = AUser { auID :: Int

54− , auOrgID :: Int

55− } deriving (Show, Generic)

56−```

57−

58−The following instances are needed for JWT:

59−

60−```haskell

61−instance ToJSON AuthenticatedUser

62−instance FromJSON AuthenticatedUser

63−instance ToJWT AuthenticatedUser

64−instance FromJWT AuthenticatedUser

65−```

66−

67−We'll have to use a bit of imagination to pretend that the following

68−`Map` is a database connection pool:

69−

70−```haskell

71−type Login = ByteString

72−type Password = ByteString

73−type DB = Map (Login, Password) AuthenticatedUser

74−type Connection = DB

75−type Pool a = a

76−

77−initConnPool :: IO (Pool Connection)

78−initConnPool = pure $ fromList [ (("user", "pass"), AUser 1 1)

79− , (("user2", "pass2"), AUser 2 1) ]

80−```

81−

82−See the "PostgreSQL connection pool" recipe for actual connection

83−pooling, and we proceed to an authentication function that would use

84−our improvised DB connection pool and credentials provided by a user:

85−

86−```haskell

87−authCheck :: Pool Connection

88− -> BasicAuthData

89− -> IO (AuthResult AuthenticatedUser)

90−authCheck connPool (BasicAuthData login password) = pure $

91− maybe SAS.Indefinite Authenticated $ M.lookup (login, password) connPool

92−```

93−

94−**Warning**: make sure to use a proper password hashing function in

95−functions like this: see [bcrypt](https://en.wikipedia.org/wiki/Bcrypt),

96−[scrypt](https://en.wikipedia.org/wiki/Scrypt),

97−[pgcrypto](https://www.postgresql.org/docs/current/static/pgcrypto.html).

98−

99−Unlike `Servant.BasicAuth`, `Servant.Auth` uses `FromBasicAuthData`

100−type class for the authentication process itself. But since our

101−connection pool will be initialized elsewhere, we'll have to pass it

102−somehow: it can be done via a context entry and `BasicAuthCfg` type

103−family. We can actually pass a function at once, to make it a bit more

104−generic:

105−

106−

107−```haskell

108−type instance BasicAuthCfg = BasicAuthData -> IO (AuthResult AuthenticatedUser)

109−

110−instance FromBasicAuthData AuthenticatedUser where

111− fromBasicAuthData authData authCheckFunction = authCheckFunction authData

112−```

113−

114−

115−## API

116−

117−Test API with a couple of endpoints:

118−

119−```haskell

120−type TestAPI = "foo" :> Capture "i" Int :> Get '[JSON] ()

121− :<|> "bar" :> Get '[JSON] ()

122−```

123−

124−We'll use this for server-side functions, listing the allowed

125−authentication methods using the `Auth` combinator:

126−

127−```haskell

128−type TestAPIServer =

129− Auth '[SA.JWT, SA.BasicAuth] AuthenticatedUser :> TestAPI

130−```

131−

132−But `Servant.Auth.Client` only supports JWT-based authentication, so

133−we'll have to use regular `Servant.BasicAuth` to derive client

134−functions that use basic access authentication:

135−

136−```haskell

137−type TestAPIClient = S.BasicAuth "test" AuthenticatedUser :> TestAPI

138−```

139−

140−

141−## Client

142−

143−Client code in this setting is the same as it would be with just

144−`Servant.BasicAuth`, using

145−[servant-client](https://hackage.haskell.org/package/servant-client):

146−

147−```haskell

148−testClient :: IO ()

149−testClient = do

150− mgr <- newManager defaultManagerSettings

151− let (foo :<|> _) = client (Proxy :: Proxy TestAPIClient)

152− (BasicAuthData "name" "pass")

153− res <- runClientM (foo 42)

154− (mkClientEnv mgr (BaseUrl Http "localhost" port ""))

155− hPutStrLn stderr $ case res of

156− Left err -> "Error: " ++ show err

157− Right r -> "Success: " ++ show r

158−```

159−

160−

161−## Server

162−

163−Server code is slightly different -- we're getting `AuthResult` here:

164−

165−```haskell

166−server :: Server TestAPIServer

167−server (Authenticated user) = handleFoo :<|> handleBar

168− where

169− handleFoo :: Int -> Handler ()

170− handleFoo n = liftIO $ hPutStrLn stderr $

171− concat ["foo: ", show user, " / ", show n]

172− handleBar :: Handler ()

173− handleBar = liftIO testClient

174−```

175−

176−Catch-all for `BadPassword`, `NoSuchUser`, and `Indefinite`:

177−

178−```haskell

179−server _ = throwAll err401

180−```

181−

182−With `Servant.Auth`, we'll have to put both `CookieSettings` and

183−`JWTSettings` into context even if we're not using those, and we'll

184−put a partially applied `authCheck` function there as well, so that

185−`FromBasicAuthData` will be able to use it, while it will use our

186−connection pool. Otherwise it is similar to the usual way:

187−

188−```haskell

189−mkApp :: Pool Connection -> IO Application

190−mkApp connPool = do

191− myKey <- generateKey

192− let jwtCfg = defaultJWTSettings myKey

193− authCfg = authCheck connPool

194− cfg = jwtCfg :. defaultCookieSettings :. authCfg :. EmptyContext

195− api = Proxy :: Proxy TestAPIServer

196− pure $ serveWithContext api cfg server

197−```

198−

199−Finally, the main function:

200−

201−```haskell

202−main :: IO ()

203−main = do

204− connPool <- initConnPool

205− let settings =

206− setPort port $

207− setBeforeMainLoop (hPutStrLn stderr

208− ("listening on port " ++ show port)) $

209− defaultSettings

210− runSettings settings =<< mkApp connPool

211−```

212−

213−

214−## Usage

215−

216−Now we can try it out with `curl`. First of all, let's ensure that it

217−fails with `err401` if we're not authenticated:

218−

219−```

220−$ curl -v 'http://localhost:3001/bar'

221−…

222−< HTTP/1.1 401 Unauthorized

223−```

224−

225−```

226−$ curl -v 'http://user:wrong_password@localhost:3001/bar'

227−…

228−< HTTP/1.1 401 Unauthorized

229−```

230−

231−Now let's see that basic HTTP authentication works, and that we get

232−JWTs:

233−

234−```

235−$ curl -v 'http://user:pass@localhost:3001/bar'

236−…

237−< HTTP/1.1 200 OK

238−…

239−< Set-Cookie: XSRF-TOKEN=lQE/sb1fW4rZ/FYUQZskI6RVRllG0CWZrQ0d3fXU4X0=; Path=/; Secure

240−< Set-Cookie: JWT-Cookie=eyJhbGciOiJIUzUxMiJ9.eyJkYXQiOnsiYXVPcmdJRCI6MSwiYXVJRCI6MX19.6ZQba-Co5Ul4wpmU34zXlI75wmasxDfaGRmO3BsOx-ONupX93OBfyYBCIJ3tbWMXKBVVqMDt0Pz-5CakyF2wng; Path=/; HttpOnly; Secure

241−```

242−

243−And authenticate using JWTs alone, using the token from `JWT-Cookie`:

244−

245−```

246−curl -v -H 'Authorization: Bearer eyJhbGciOiJIUzUxMiJ9.eyJkYXQiOnsiYXVPcmdJRCI6MSwiYXVJRCI6MX19.6ZQba-Co5Ul4wpmU34zXlI75wmasxDfaGRmO3BsOx-ONupX93OBfyYBCIJ3tbWMXKBVVqMDt0Pz-5CakyF2wng' 'http://localhost:3001/bar'

247−…

248−< HTTP/1.1 200 OK

249−```

250−

251−This program is available as a cabal project

252−[here](https://github.com/haskell-servant/servant/tree/master/doc/cookbook/jwt-and-basic-auth).

doc/cookbook/jwt-and-basic-auth/jwt-and-basic-auth.cabaldeleted−36

@@ -1,36 +0,0 @@

1−cabal-version: 2.2

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

3−version: 0.0.1

4−synopsis: JWT and basic access authentication cookbook example

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

6− authentication.

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

8−license: BSD-3-Clause

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

10−author: Servant Contributors

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

12−category: Servant

13−build-type: Simple

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

15−

16−executable cookbook-jwt-and-basic-auth

17− main-is: JWTAndBasicAuth.lhs

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

19− , text >= 1.2

20− , aeson >= 1.2

21− , containers >= 0.5

22− , servant

23− , servant-client

24− , servant-server

25− , servant-auth == 0.4.*

26− , servant-auth-server >= 0.3.1.0

27− , warp >= 3.2

28− , wai >= 3.2

29− , http-types >= 0.12

30− , markdown-unlit >= 0.4

31− , http-client >= 0.5

32− , bytestring >= 0.10.4

33− , transformers

34− default-language: Haskell2010

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

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

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

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

1−cabal-version: 2.2

2−name: open-id-connect

3−version: 0.1

4−synopsis: OpenId Connect with Servant example

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

6−license: BSD-3-Clause

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

8−author: Servant Contributors

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

10−build-type: Simple

11−tested-with: GHC==8.6.5

12−

13−executable cookbook-openidconnect

14− main-is: OpenIdConnect.lhs

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

16− , aeson

17− , aeson-pretty

18− , binary

19− , blaze-html

20− , blaze-markup

21− , bytestring

22− , case-insensitive

23− , cereal

24− , containers

25− , generic-lens

26− , http-client

27− , http-client-tls

28− , http-types

29− , jose-jwt

30− , lens

31− , lens-aeson

32− , oidc-client

33− , protolude

34− , random

35− , servant

36− , servant-blaze

37− , servant-server

38− , text

39− , time

40− , vector

41− , wai

42− , warp >= 3.2

43− default-language: Haskell2010

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

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

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

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

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

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

3−

4−Use OpenID Connect to authenticate your users.

5−This example use google OIDC provider.

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

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

8−

9−Workflow:

10−

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

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

13− provider,

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

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

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

17− and will get back authentication infos,

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

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

20− /.

21−

22−Let's put the imports behind us:

23−

24−``` haskell

25−{-# LANGUAGE DataKinds #-}

26−{-# LANGUAGE DeriveGeneric #-}

27−{-# LANGUAGE DuplicateRecordFields #-}

28−{-# LANGUAGE FlexibleContexts #-}

29−{-# LANGUAGE FlexibleInstances #-}

30−{-# LANGUAGE MultiParamTypeClasses #-}

31−{-# LANGUAGE NoImplicitPrelude #-}

32−{-# LANGUAGE OverloadedLists #-}

33−{-# LANGUAGE OverloadedStrings #-}

34−{-# LANGUAGE PartialTypeSignatures #-}

35−{-# LANGUAGE PolyKinds #-}

36−{-# LANGUAGE RankNTypes #-}

37−{-# LANGUAGE RecordWildCards #-}

38−{-# LANGUAGE ScopedTypeVariables #-}

39−{-# LANGUAGE TypeFamilies #-}

40−{-# LANGUAGE TypeOperators #-}

41−{-# LANGUAGE TypeSynonymInstances #-}

42−

43−module Main where

44−

45−import Protolude

46−

47−import Data.Aeson

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

49−import qualified Data.Aeson as JSON

50−import qualified Data.Aeson.Types as AeT

51−import qualified Data.ByteString.Lazy as LBS

52−import qualified Data.List as List

53−import qualified Data.Text as Text

54−import Jose.Jwt

55− (Jwt (..), decodeClaims)

56−import Network.HTTP.Client

57− (Manager, newManager)

58−import Network.HTTP.Client.TLS

59− (tlsManagerSettings)

60−import Network.Wai.Handler.Warp

61− (run)

62−import Servant

63−import Servant.HTML.Blaze

64− (HTML)

65−import qualified System.Random as Random

66−import Text.Blaze

67− (ToMarkup (..))

68−import qualified Text.Blaze.Html as H

69−import Text.Blaze.Html5

70− ((!))

71−import qualified Text.Blaze.Html5 as H

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

73−import Text.Blaze.Renderer.Utf8

74− (renderMarkup)

75−import qualified Web.OIDC.Client as O

76−```

77−

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

79−This example was tested with Google.

80−

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

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

83−

84−I copied some here:

85−

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

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

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

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

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

91−

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

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

94−after a successful login into the OpenID provider.

95−

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

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

98−

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

100−Fill those values in here:

101−

102−``` haskell

103−oidcConf :: OIDCConf

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

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

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

107−```

108−

109−Then we declare our main server:

110−

111−``` haskell

112−main :: IO ()

113−main = do

114− oidcEnv <- initOIDC oidcConf

115− run 3000 (app oidcEnv)

116−

117−type API = IdentityRoutes Customer

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

119−

120−api :: Proxy API

121−api = Proxy

122−

123−server :: OIDCEnv -> Server API

124−server oidcEnv = serveOIDC oidcEnv handleOIDCLogin

125− :<|> return Homepage

126−

127−-- | Then main app

128−app :: OIDCEnv -> Application

129−app oidcEnv = serve api (server oidcEnv)

130−```

131−

132−OIDC

133−----

134−

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

136−application that should be in its distinct module.

137−

138−``` haskell

139−-- * OIDC

140−

141−data OIDCConf =

142− OIDCConf { redirectUri :: ByteString

143− , clientId :: ByteString

144− , clientPassword :: ByteString

145− } deriving (Show, Eq)

146−```

147−

148−First we need to initialize OIDC.

149−A short explanation about it:

150−

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

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

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

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

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

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

157−

158−``` haskell

159−initOIDC :: OIDCConf -> IO OIDCEnv

160−initOIDC OIDCConf{..} = do

161− mgr <- newManager tlsManagerSettings

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

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

164− return OIDCEnv { oidc = oidc

165− , mgr = mgr

166− , genState = genRandomBS

167− , prov = prov

168− , redirectUri = redirectUri

169− , clientId = clientId

170− , clientPassword = clientPassword

171− }

172−

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

174− , mgr :: Manager

175− , genState :: IO ByteString

176− , prov :: O.Provider

177− , redirectUri :: ByteString

178− , clientId :: ByteString

179− , clientPassword :: ByteString

180− }

181−```

182−

183−The `IdentityRoutes` are two endpoints:

184−

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

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

187−

188−``` haskell

189−type IdentityRoutes a =

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

191− Get '[JSON] NoContent

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

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

194− :> QueryParam "code" Text

195− :> Get '[HTML] User)

196−

197−-- | gen a 302 redirect helper

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

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

200−```

201−

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

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

204−

205−``` haskell

206−genOIDCURL :: OIDCEnv -> IO ByteString

207−genOIDCURL OIDCEnv{..} = do

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

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

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

211− return (show loc)

212−

213−handleLogin :: OIDCEnv -> Handler NoContent

214−handleLogin oidcenv = do

215− loc <- liftIO (genOIDCURL oidcenv)

216− redirects loc

217− return NoContent

218−```

219−

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

221−

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

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

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

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

226−asked we might get more information.

227−

228−``` haskell

229−-- | @AuthInfo@

230−data AuthInfo = AuthInfo { email :: Text

231− , emailVerified :: Bool

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

233−

234−instance FromJSON AuthInfo where

235− parseJSON (JSON.Object v) = do

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

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

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

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

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

241−instance JSON.ToJSON AuthInfo where

242− toJSON (AuthInfo e ev n) =

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

244− , "email_verified" JSON..= ev

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

246− ]

247−

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

249−```

250−

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

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

253−

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

255−parameter then it means something went wrong.

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

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

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

259−as well as the client id and secret.

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

261−

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

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

264−

265−``` haskell

266−data User = User { userId :: Text

267− , userSecret :: Text

268− , localStorageKey :: Text

269− , redirectUrl :: Maybe Text

270− } deriving (Show,Eq,Ord)

271−

272−handleLoggedIn :: OIDCEnv

273− -> LoginHandler -- ^ handle successful id

274− -> Maybe Text -- ^ error

275− -> Maybe Text -- ^ code

276− -> Handler User

277−handleLoggedIn oidcenv handleSuccessfulId err mcode =

278− case err of

279− Just errorMsg -> forbidden errorMsg

280− Nothing -> case mcode of

281− Just oauthCode -> do

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

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

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

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

286− case eAuthInfo of

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

288− Right (_,authInfo) ->

289− if emailVerified authInfo

290− then do

291− user <- liftIO $ handleSuccessfulId authInfo

292− either forbidden return user

293− else forbidden "Please verify your email"

294− Nothing -> do

295− liftIO $ putText "No code param"

296− forbidden "no code parameter given"

297−```

298−

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

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

301−redirect the user to /.

302−

303−``` haskell

304−instance ToMarkup User where

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

306− H.head $

307− H.title "Logged In"

308− H.body $ do

309− H.h1 "Logged In"

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

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

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

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

314− ));

315−

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

317−serveOIDC oidcenv loginHandler =

318− handleLogin oidcenv :<|> handleLoggedIn oidcenv loginHandler

319−

320−-- * Auth

321−type APIKey = ByteString

322−type Account = Text.Text

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

324−data Customer = Customer {

325− account :: Account

326− , apiKey :: APIKey

327− , mail :: Maybe Text

328− , fullname :: Maybe Text

329− }

330−```

331−

332−Here is the code that displays the homepage.

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

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

335−with some generated information.

336−

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

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

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

340−`/login/cb`.

341−

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

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

344−

345−``` haskell

346−data Homepage = Homepage

347−

348−instance ToMarkup Homepage where

349− toMarkup Homepage = H.docTypeHtml $ do

350− H.head $ do

351− H.title "OpenID Connect Servant Example"

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

353− H.body $ do

354− H.h1 "OpenID Connect Servant Example"

355− H.div $

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

357− H.ul $ do

358− H.li $ do

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

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

361− H.li $ do

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

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

364−```

365−

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

367−

368−``` haskell

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

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

371−genRandomBS :: IO ByteString

372−genRandomBS = do

373− g <- Random.newStdGen

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

375− where

376− n = length letters - 1

377− toChar i = letters List.!! i

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

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

380− readable _ [] = []

381− readable i str =

382− let blocksize = case n of

383− 0 -> 8

384− 1 -> 4

385− 2 -> 4

386− 3 -> 4

387− _ -> 12

388− block = take blocksize str

389− rest = drop blocksize str

390− in if List.null rest

391− then str

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

393−

394−customerFromAuthInfo :: AuthInfo -> IO Customer

395−customerFromAuthInfo authinfo = do

396− apikey <- genRandomBS

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

398− , apiKey = apikey

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

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

401− }

402−

403−handleOIDCLogin :: LoginHandler

404−handleOIDCLogin authInfo = do

405− custInfo <- customerFromAuthInfo authInfo

406− if emailVerified authInfo

407− then return . Right . customerToUser $ custInfo

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

409− where

410− customerToUser :: Customer -> User

411− customerToUser c =

412− User { userId = toS (account c)

413− , userSecret = toS (apiKey c)

414− , redirectUrl = Nothing

415− , localStorageKey = "api-key"

416− }

417−```

418−

419−`Error` helpers

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

421−

422−``` haskell

423−data Err = Err { errTitle :: Text

424− , errMsg :: Text }

425−

426−instance ToMarkup Err where

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

428− H.head $ do

429− H.title "Error"

430− H.body $ do

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

432− H.h2 (H.toHtml errTitle)

433− H.p (H.toHtml errMsg)

434−

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

436−format err = toMarkup err & renderMarkup

437−

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

439−appToErr x msg = x

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

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

442−

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

444−unauthorized = throwError . unauthorizedErr

445−

446−unauthorizedErr :: Text -> ServerError

447−unauthorizedErr = appToErr err401

448−

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

450−forbidden = throwError . forbiddenErr

451−

452−forbiddenErr :: Text -> ServerError

453−forbiddenErr = appToErr err403

454−

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

456−notFound = throwError . notFoundErr

457−

458−notFoundErr :: Text -> ServerError

459−notFoundErr = appToErr err404

460−

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

462−preconditionFailed = throwError . preconditionFailedErr

463−

464−preconditionFailedErr :: Text -> ServerError

465−preconditionFailedErr = appToErr err412

466−

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

468−serverError = throwError . serverErrorErr

469−

470−serverErrorErr :: Text -> ServerError

471−serverErrorErr = appToErr err500

472−```

doc/cookbook/pagination/Pagination.lhsdeleted−250

@@ -1,250 +0,0 @@

1−# Pagination

2−

3−## Overview

4−

5−Let's see an approach to typed pagination with *Servant* using [servant-pagination](https://hackage.haskell.org/package/servant-pagination).

6−

7−This module offers opinionated helpers to declare a type-safe and a flexible pagination

8−mechanism for Servant APIs. This design, inspired by [Heroku's API](https://devcenter.heroku.com/articles/platform-api-reference#ranges),

9−provides a small framework to communicate about a possible pagination feature of an endpoint,

10−enabling a client to consume the API in different fashions (pagination with offset / limit,

11−endless scroll using last referenced resources, ascending and descending ordering, etc.)

12−

13−Therefore, client can provide a `Range` header with their request with the following format:

14−

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

16−

17−For example: `Range: createdAt 2017-01-15T23:14:67.000Z; offset 5; order desc` indicates that

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

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

20−

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

22−response with 3 headers:

23−

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

25−- `Content-Range`: Actual range corresponding to the content being returned

26−- `Next-Range`: Indicate what should be the next `Range` header in order to retrieve the next range

27−

28−For example:

29−

30−- `Accept-Ranges: createdAt, modifiedAt`

31−- `Content-Range: createdAt 2017-01-15T23:14:51.000Z..2017-02-18T06:10:23.000Z`

32−- `Next-Range: createdAt 2017-02-19T12:56:28.000Z; offset 0; limit 100; order desc`

33−

34−

35−## Getting Started

36−

37−Code-wise the integration is quite seamless and unobtrusive. `servant-pagination` provides a

38−`Ranges (fields :: [Symbol]) (resource :: *) -> *` data-type for declaring available ranges

39−on a group of _fields_ and a target _resource_. To each combination (resource + field) is

40−associated a given type `RangeType (resource :: *) (field :: Symbol) -> *` as described by

41−the type-family in the `HasPagination` type-class.

42−

43−So, let's start with some imports and extensions to get this out of the way:

44−

45−``` haskell

46−{-# LANGUAGE DataKinds #-}

47−{-# LANGUAGE DeriveGeneric #-}

48−{-# LANGUAGE FlexibleInstances #-}

49−{-# LANGUAGE MultiParamTypeClasses #-}

50−{-# LANGUAGE TypeApplications #-}

51−{-# LANGUAGE TypeFamilies #-}

52−{-# LANGUAGE TypeOperators #-}

53−

54−import Data.Aeson

55− (ToJSON, genericToJSON)

56−import Data.Maybe

57− (fromMaybe)

58−import Data.Proxy

59− (Proxy (..))

60−import GHC.Generics

61− (Generic)

62−import Servant

63− ((:>), GetPartialContent, Handler, Header, Headers, JSON, Server, addHeader)

64−import Servant.Pagination

65− (HasPagination (..), PageHeaders, Range (..), Ranges, RangeOptions(..),

66− applyRange, extractRange, returnRange)

67−

68−import qualified Data.Aeson as Aeson

69−import qualified Network.Wai.Handler.Warp as Warp

70−import qualified Servant

71−import qualified Servant.Pagination as Pagination

72−```

73−

74−

75−#### Declaring the Resource

76−

77−Servant APIs are rather resource-oriented, and so is `servant-pagination`. This

78−guide shows a basic example working with `JSON` (as you could tell from the

79−import list already). To make the world a <span style='text-decoration:

80−line-through'>better</span> colored place, let's create an API to retrieve

81−colors -- with pagination.

82−

83−``` haskell

84−data Color = Color

85− { name :: String

86− , rgb :: [Int]

87− , hex :: String

88− } deriving (Eq, Show, Generic)

89−

90−instance ToJSON Color where

91− toJSON =

92− genericToJSON Aeson.defaultOptions

93−

94−colors :: [Color]

95−colors =

96− [ Color "Black" [0, 0, 0] "#000000"

97− , Color "Blue" [0, 0, 255] "#0000ff"

98− , Color "Green" [0, 128, 0] "#008000"

99− , Color "Grey" [128, 128, 128] "#808080"

100− , Color "Purple" [128, 0, 128] "#800080"

101− , Color "Red" [255, 0, 0] "#ff0000"

102− , Color "Yellow" [255, 255, 0] "#ffff00"

103− ]

104−```

105−

106−#### Declaring the Ranges

107−

108−Now that we have defined our _resource_ (a.k.a `Color`), we are ready to declare a new `Range`

109−that will operate on a "name" field (genuinely named after the `name` fields from the `Color`

110−record).

111−For that, we need to tell `servant-pagination` two things:

112−

113−- What is the type of the corresponding `Range` values

114−- How do we get one of these values from our resource

115−

116−This is done via defining an instance of `HasPagination` as follows:

117−

118−``` haskell

119−instance HasPagination Color "name" where

120− type RangeType Color "name" = String

121− getFieldValue _ = name

122− -- getRangeOptions :: Proxy "name" -> Proxy Color -> RangeOptions

123− -- getDefaultRange :: Proxy Color -> Range "name" String

124−

125−defaultRange :: Range "name" String

126−defaultRange =

127− getDefaultRange (Proxy @Color)

128−```

129−

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

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

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

133−come in handy when defining our handler.

134−

135−#### API

136−

137−Good, we have a resource, we have a `Range` working on that resource, we can now declare our

138−API using other Servant combinators we already know:

139−

140−``` haskell

141−type API =

142− "colors"

143− :> Header "Range" (Ranges '["name"] Color)

144− :> GetPartialContent '[JSON] (Headers MyHeaders [Color])

145−

146−type MyHeaders =

147− Header "Total-Count" Int ': PageHeaders '["name"] Color

148−```

149−

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

151−we mentioned in introduction. Expanding the alias boils down to the following:

152−

153−``` haskell

154−-- type MyHeaders =

155−-- '[ Header "Total-Count" Int

156−-- , Header "Accept-Ranges" (AcceptRanges '["name"])

157−-- , Header "Content-Range" (ContentRange '["name"] Color)

158−-- , Header "Next-Range" (Ranges '["name"] Color)

159−-- ]

160−```

161−

162−As a result, we will need to provide all those headers with the response in our handler. Worry

163−not, _servant-pagination_ provides an easy way to lift a collection of resources into such handler.

164−

165−#### Server

166−

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

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

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

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

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

172−

173−``` haskell

174−server :: Server API

175−server = handler

176− where

177− handler :: Maybe (Ranges '["name"] Color) -> Handler (Headers MyHeaders [Color])

178− handler mrange = do

179− let range =

180− fromMaybe defaultRange (mrange >>= extractRange)

181−

182− addHeader (length colors) <$> returnRange range (applyRange range colors)

183−

184−main :: IO ()

185−main =

186− Warp.run 1442 $ Servant.serve (Proxy @API) server

187−```

188−

189−Let's try it out using different ranges to observe the server's behavior. As a reminder, here's

190−the format we defined, where `<field>` here can only be `name` and `<value>` must parse to a `String`:

191−

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

193−

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

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

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

197−

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

199−- 2 - `curl http://localhost:1442/colors -vH 'Range: name; limit 2'`

200−- 3 - `curl http://localhost:1442/colors -vH 'Range: name Green; order asc; offset 1'`

201−

202−Considering the following default options:

203−

204−- `defaultRangeLimit: 100`

205−- `defaultRangeOffset: 0`

206−- `defaultRangeOrder: RangeDesc`

207−

208−The previous ranges reads as follows:

209−

210−- 1 - The first 100 colors, ordered by descending names

211−- 2 - The first 2 colors, ordered by descending names

212−- 3 - The 100 colors after `Green` (not included), ordered by ascending names.

213−

214−

215−## Going Forward

216−

217−#### Multiple Ranges

218−

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

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

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

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

223−highly likely to be needed.

224−

225−

226−``` haskell

227−instance HasPagination Color "hex" where

228− type RangeType Color "hex" = String

229− getFieldValue _ = hex

230−

231−-- to then define: Ranges '["name", "hex"] Color

232−```

233−

234−

235−#### Parsing Options

236−

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

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

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

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

241−

242−For instance, let's say we wanted to change the default limit to `5` in a new range on

243−`"rgb"`, we could tweak the corresponding `HasPagination` instance as follows:

244−

245−``` haskell

246−instance HasPagination Color "rgb" where

247− type RangeType Color "rgb" = Int

248− getFieldValue _ = sum . rgb

249− getRangeOptions _ _ = Pagination.defaultOptions { defaultRangeLimit = 5 }

250−```

doc/cookbook/pagination/pagination.cabaldeleted−23

@@ -1,23 +0,0 @@

1−cabal-version: 2.2

2−name: cookbook-pagination

3−version: 2.1

4−synopsis: Pagination with Servant example

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

6−license: BSD-3-Clause

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

8−author: Servant Contributors

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

10−build-type: Simple

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

12−

13−executable cookbook-pagination

14− main-is: Pagination.lhs

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

16− default-language: Haskell2010

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

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

19− , aeson

20− , servant

21− , servant-server

22− , servant-pagination >= 2.1.0 && < 3.0.0

23− , warp

doc/cookbook/sentry/Sentry.lhsdeleted−116

@@ -1,116 +0,0 @@

1−# Error logging with Sentry

2−

3−In this recipe we will use [Sentry](https://sentry.io) to collect the runtime exceptions generated by our application. We will use the [raven-haskell](https://hackage.haskell.org/package/raven-haskell) package, which is a client for a Sentry event server. Mind that this package is not present on [Stackage](https://www.stackage.org/), so if we are using [Stack](https://docs.haskellstack.org) we’ll need to add it to our `extra-deps` section in the `stack.yaml` file.

4−

5−To exemplify this we will need the following imports

6−

7−```haskell

8−{-# LANGUAGE DataKinds #-}

9−{-# LANGUAGE TypeOperators #-}

10−

11−import Control.Exception (Exception,

12− SomeException, throw)

13−import Data.ByteString.Char8 (unpack)

14−import Network.Wai (Request, rawPathInfo,

15− requestHeaderHost)

16−import Network.Wai.Handler.Warp (defaultOnException,

17− defaultSettings,

18− runSettings,

19− setOnException,

20− setPort)

21−import Servant

22−import System.Log.Raven (initRaven, register,

23− silentFallback)

24−import System.Log.Raven.Transport.HttpConduit (sendRecord)

25−import System.Log.Raven.Types (SentryLevel (Error),

26− SentryRecord (..))

27−```

28−

29−Just for the sake of the example we will use the following API which will throw an exception

30−

31−```haskell

32−type API = "break" :> Get '[JSON] ()

33−

34−data MyException = MyException deriving (Show)

35−

36−instance Exception MyException

37−

38−server = breakHandler

39− where breakHandler :: Handler ()

40− breakHandler = do

41− throw MyException

42− return ()

43−```

44−

45−First thing we need to do if we want to intercept and log this exception, we need to look in the section of our code where we run the `warp` application, and instead of using the simple `run` function from `warp`, we use the `runSettings` functions which allows to customise the handling of requests

46−

47−```haskell

48−main :: IO ()

49−main =

50− let

51− settings =

52− setPort 8080 $

53− setOnException sentryOnException $

54− defaultSettings

55− in

56− runSettings settings $ serve (Proxy :: Proxy API) server

57−```

58−

59−The definition of the `sentryOnException` function could look as follows

60−

61−```haskell

62−sentryOnException :: Maybe Request -> SomeException -> IO ()

63−sentryOnException mRequest exception = do

64− sentryService <- initRaven

65− "https://username:password@senty.host/id"

66− id

67− sendRecord

68− silentFallback

69− register

70− sentryService

71− "myLogger"

72− Error

73− (formatMessage mRequest exception)

74− (recordUpdate mRequest exception)

75− defaultOnException mRequest exception

76−```

77−

78−It does three things. First it initializes the service which will communicate with Sentry. The parameters it receives are:

79−

80−- the Sentry `DSN`, which is obtained when creating a new project on Sentry

81−- a default way to update sentry fields, where we use the identity function

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

83−- a fallback handler, which we choose to be `silentFallback` since later we are logging to the console anyway.

84−

85−In the second step it actually sends our message to Sentry with the `register` function. Its arguments are:

86−

87−- the configured Sentry service which we just created

88−- the name of the logger

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

90−- the message we want to send

91−- an update function to handle the specific `SentryRecord`

92−

93−Eventually it just delegates the error handling to the default warp mechanism.

94−

95−The function `formatMessage` simply uses the request and the exception to return a string with the error message.

96−

97−```haskell

98−formatMessage :: Maybe Request -> SomeException -> String

99−formatMessage Nothing exception = "Exception before request could be parsed: " ++ show exception

100−formatMessage (Just request) exception = "Exception " ++ show exception ++ " while handling request " ++ show request

101−```

102−

103−The only piece left now is the `recordUpdate` function which allows to decorate with other [attributes](https://docs.sentry.io/clientdev/attributes/) the default `SentryRecord`.

104−

105−```haskell

106−recordUpdate :: Maybe Request -> SomeException -> SentryRecord -> SentryRecord

107−recordUpdate Nothing exception record = record

108−recordUpdate (Just request) exception record = record

109− { srCulprit = Just $ unpack $ rawPathInfo request

110− , srServerName = fmap unpack $ requestHeaderHost request

111− }

112−```

113−

114−In this examples we set the raw path as the culprit and we use the `Host` header to populate the server name field.

115−

116−You can try to run this code using the `cookbook-sentry` executable. You should obtain a `MyException` error in the console and, if you provided a valid Sentry DSN, you should also find your error in the Sentry interface.

doc/cookbook/sentry/sentry.cabaldeleted−24

@@ -1,24 +0,0 @@

1−cabal-version: 2.2

2−name: cookbook-sentry

3−version: 0.1

4−synopsis: Collecting runtime exceptions using Sentry

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

6−license: BSD-3-Clause

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

8−author: Servant Contributors

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

10−build-type: Simple

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

12−

13−executable cookbook-sentry

14− main-is: Sentry.lhs

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

16− , bytestring

17− , markdown-unlit >= 0.4

18− , raven-haskell >= 0.1.2

19− , servant-server

20− , warp >= 3.2

21− , wai >= 3.2

22− default-language: Haskell2010

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

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

doc/cookbook/structuring-apis/StructuringApis.lhsdeleted−205

@@ -1,205 +0,0 @@

1−# Structuring APIs

2−

3−In this recipe, we will see a few simple ways to

4−structure your APIs by splitting them up into smaller

5−"sub-APIs" or by sharing common structure between

6−different parts. Let's start with the usual throat

7−clearing.

8−

9−``` haskell

10−{-# LANGUAGE DataKinds #-}

11−{-# LANGUAGE DeriveGeneric #-}

12−{-# LANGUAGE TypeOperators #-}

13−{-# LANGUAGE KindSignatures #-}

14−import Data.Aeson

15−import GHC.Generics

16−import GHC.TypeLits

17−import Network.Wai.Handler.Warp

18−import Servant

19−```

20−

21−Our application will consist of three different

22−"sub-APIs", with a few endpoints in each of them.

23−Our global API is defined as follows.

24−

25−``` haskell

26−type API = FactoringAPI

27− :<|> SimpleAPI "users" User UserId

28− :<|> SimpleAPI "products" Product ProductId

29−```

30−

31−We simply join the three different parts with `:<|>`,

32−as if each sub-API was just a simple endpoint.

33−The first part, `FactoringAPI`, shows how we can

34−"factor out" combinators that are common to several

35−endpoints, just like we turn `a * b + a * c` into

36−`a * (b + c)` in algebra.

37−

38−``` haskell

39−-- Two endpoints:

40−-- - GET /x/<some 'Int'>[?y=<some 'Int'>]

41−-- - POST /x/<some 'Int'>

42−type FactoringAPI =

43− "x" :> Capture "x" Int :>

44− ( QueryParam "y" Int :> Get '[JSON] Int

45− :<|> Post '[JSON] Int

46− )

47−

48−{- this is equivalent to:

49−

50−type FactoringAPI' =

51− "x" :> Capture "x" Int :> QueryParam "y" Int :> Get '[JSON] Int :<|>

52− "x" :> Capture "x" Int :> Post '[JSON] Int

53−-}

54−```

55−

56−You can see that both endpoints start with a static

57−path fragment, `/"x"`, then capture some arbitrary

58−`Int` until they finally differ. Now, this also has

59−an effect on the server for such an API, and its type

60−in particular. While the server for `FactoringAPI'` would

61−be made of a function of type `Int -> Maybe Int -> Handler Int`

62−and a function of type `Int -> Handler Int` glued with `:<|>`,

63−a server for `FactoringAPI` (without the `'`) reflects the

64−"factorisation" and therefore, `Server FactoringAPI` is

65−`Int -> (Maybe Int -> Handler Int :<|> Handler Int)`. That is, the

66−server must be a function that takes an `Int` (the `Capture`) and

67−returns two values glued with `:<|>`, one of type `Maybe Int -> Handler Int`

68−and the other of type `Handler Int`. Let's provide such a server

69−implementation, with those "nested types".

70−

71−**Tip**: you can load this module in ghci and ask for the concrete

72−type that `Server FactoringAPI` "resolves to" by typing

73−`:kind! Server FactoringAPI`.

74−

75−``` haskell

76−factoringServer :: Server FactoringAPI

77−factoringServer x = getXY :<|> postX

78−

79− where getXY Nothing = return x

80− getXY (Just y) = return (x + y)

81−

82− postX = return (x - 1)

83−```

84−

85−If you want to avoid the "nested types" and the need to manually

86−dispatch the arguments (like `x` above) to the different request

87−handlers, and would just like to be able to declare the API type

88−as above but pretending that the `Capture` is not factored out,

89−that every combinator is "distributed" (i.e that all endpoints

90−are specified like `FactoringAPI'` above), then you should

91−look at `flatten` from the

92−[servant-flatten](https://hackage.haskell.org/package/servant-flatten)

93−package.

94−

95−Next come the two sub-APIs defined in terms of this `SimpleAPI`

96−type, but with different parameters. That type is just a good old

97−Haskell type synonym that abstracts away a pretty common structure in

98−web services, where you have:

99−

100− - one endpoint for listing a bunch of entities of some type

101− - one endpoint for accessing the entity with a given identifier

102− - one endpoint for creating a new entity

103−

104−There are many variants on this theme (endpoints for deleting,

105−paginated listings, etc). The simple definition below reproduces

106−such a structure, but instead of picking concrete types for

107−the entities and their identifiers, we simply let the user

108−of the type decide, by making those types parameters of

109−`SimpleAPI`. While we're at it, we'll put all our endpoints

110−under a common prefix that we also take as a parameter.

111−

112−``` haskell

113−-- Three endpoints:

114−-- - GET /<name>

115−-- - GET /<name>/<some 'i'>

116−-- - POST /<name>

117−type SimpleAPI (name :: Symbol) a i = name :>

118− ( Get '[JSON] [a]

119− :<|> Capture "id" i :> Get '[JSON] a

120− :<|> ReqBody '[JSON] a :> Post '[JSON] NoContent

121− )

122−```

123−

124−`Symbol` is the [kind](https://wiki.haskell.org/Kind)

125−of type-level strings, which is what servant uses for

126−representing static path fragments. We can even provide

127−a little helper function for creating a server for that API

128−given one handler for each endpoint as arguments.

129−

130−``` haskell

131−simpleServer

132− :: Handler [a]

133− -> (i -> Handler a)

134− -> (a -> Handler NoContent)

135− -> Server (SimpleAPI name a i)

136−simpleServer listAs getA postA =

137− listAs :<|> getA :<|> postA

138−

139−{- you could alternatively provide such a definition

140− but with the handlers running in another monad,

141− or even an arbitrary one!

142−

143−simpleAPIServer

144− :: m [a]

145− -> (i -> m a)

146− -> (a -> m NoContent)

147− -> ServerT (SimpleAPI name a i) m

148−simpleAPIServer listAs getA postA =

149− listAs :<|> getA :<|> postA

150−

151− and use 'hoistServer' on the result of `simpleAPIServer`

152− applied to your handlers right before you call `serve`.

153−-}

154−```

155−

156−We can use this to define servers for the user and product

157−related sections of the API.

158−

159−``` haskell

160−userServer :: Server (SimpleAPI "users" User UserId)

161−userServer = simpleServer

162− (return [])

163− (\userid -> return $

164− if userid == 0

165− then User "john" 64

166− else User "everybody else" 10

167− )

168− (\_user -> return NoContent)

169−

170−productServer :: Server (SimpleAPI "products" Product ProductId)

171−productServer = simpleServer

172− (return [])

173− (\_productid -> return $ Product "Great stuff")

174− (\_product -> return NoContent)

175−```

176−

177−Finally, some dummy types and the serving part.

178−

179−``` haskell

180−type UserId = Int

181−

182−data User = User { username :: String, age :: Int }

183− deriving Generic

184−

185−instance FromJSON User

186−instance ToJSON User

187−

188−type ProductId = Int

189−

190−data Product = Product { productname :: String }

191− deriving Generic

192−

193−instance FromJSON Product

194−instance ToJSON Product

195−

196−api :: Proxy API

197−api = Proxy

198−

199−main :: IO ()

200−main = run 8080 . serve api $

201− factoringServer :<|> userServer :<|> productServer

202−```

203−

204−This program is available as a cabal project

205−[here](https://github.com/haskell-servant/servant/tree/master/doc/cookbook/structuring-apis).

doc/cookbook/structuring-apis/structuring-apis.cabaldeleted−23

@@ -1,23 +0,0 @@

1−cabal-version: 2.2

2−name: cookbook-structuring-apis

3−version: 0.1

4−synopsis: Example that shows how APIs can be structured

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-structuring-apis

14− main-is: StructuringApis.lhs

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

16− , aeson >= 1.2

17− , servant

18− , servant-server

19− , warp >= 3.2

20− , markdown-unlit >= 0.4

21− default-language: Haskell2010

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

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

doc/cookbook/testing/Testing.lhsdeleted−506

@@ -1,506 +0,0 @@

1−# How To Test Servant Applications

2−

3−Even with a nicely structured API that passes Haskell's strict type checker,

4−it's a good idea to write some tests for your application.

5−

6−In this recipe we'll work through some common testing strategies and provide

7−examples of utlizing these testing strategies in order to test Servant

8−applications.

9−

10−## Testing strategies

11−

12−There are many testing strategies you may wish to employ when testing your

13−Servant application, but included below are three common testing patterns:

14−

15−- We'll use `servant-client` to derive client functions and then send valid

16−requests to our API, running in another thread. This is great for testing

17−that our **business logic** is correctly implemented with only valid HTTP

18−requests.

19−

20−- We'll also use `hspec-wai` to make **arbitrary HTTP requests**, in order to

21−test how our application may respond to invalid or otherwise unexpected

22−requests.

23−

24−- Finally, we can also use `servant-quickcheck` for **whole-API tests**, in order

25−to assert that our entire application conforms to **best practices**.

26−

27−## Useful Libraries

28−

29−The following libraries will often come in handy when we decide to test our

30−Servant applications:

31−

32−- [hspec](https://hspec.github.io/)

33−- [hspec-wai](http://hackage.haskell.org/package/hspec-wai)

34−- [QuickCheck](http://hackage.haskell.org/package/QuickCheck)

35−- [servant-quickcheck](https://hackage.haskell.org/package/servant-quickcheck)

36−

37−## Imports and Our Testing Module

38−

39−This recipe starts with the following ingredients:

40−

41−```haskell

42−{-# LANGUAGE OverloadedStrings, TypeFamilies, DataKinds,

43− DeriveGeneric, TypeOperators #-}

44−import Prelude ()

45−import Prelude.Compat

46−

47−import qualified Control.Concurrent as C

48−import Control.Concurrent.MVar

49−import Control.Exception (bracket)

50−import Control.Lens hiding (Context)

51−import Data.Aeson

52−import Data.Aeson.Lens

53−import qualified Data.HashMap.Strict as HM

54−import Data.Text (Text, unpack)

55−import GHC.Generics

56−import Network.HTTP.Client hiding (Proxy)

57−import Network.HTTP.Types

58−import Network.Wai

59−import qualified Network.Wai.Handler.Warp as Warp

60−

61−import Servant

62−import Servant.Client

63−import Servant.Server

64−import Servant.QuickCheck

65−import Servant.QuickCheck.Internal (serverDoesntSatisfy)

66−

67−import Test.Hspec

68−import Test.Hspec.Wai

69−import Test.Hspec.Wai.Matcher

70−```

71−

72−We're going to produce different `Spec`s that represent different

73−aspects of our application, and we'll ask `hspec` to run all of our different

74−`Spec`s. This is a common organizational method for testing modules:

75−

76−```haskell

77−spec :: Spec

78−spec = do

79− businessLogicSpec

80− thirdPartyResourcesSpec

81− servantQuickcheckSpec

82−```

83−

84−Often, codebases will use `hspec`'s

85−[autodiscover pragma](http://hspec.github.io/hspec-discover.html)

86−to find all testing modules and `Spec`s inside, but we're going to

87−explicitly make a `main` function to run our tests because we have only one

88−`spec` defined above:

89−

90−```haskell

91−main :: IO ()

92−main = hspec spec

93−```

94−

95−## Testing Your Business Logic

96−

97−Let's say we have an API that looks something like this:

98−

99−```haskell

100−data User = User {

101− name :: Text

102− , user_id :: Integer

103− } deriving (Eq, Show, Generic)

104−

105−instance FromJSON User

106−instance ToJSON User

107−

108−type UserApi =

109− -- One endpoint: create a user

110− "user" :> Capture "userId" Integer :> Post '[JSON] User

111−```

112−

113−A real server would likely use a database to store, retrieve, and validate

114−users, but we're going to do something really simple merely to have something

115−to test. With that said, here's a sample handler, server, and `Application`

116−for the endpoint described above:

117−

118−```haskell

119−userApp :: Application

120−userApp = serve (Proxy :: Proxy UserApi) userServer

121−

122−userServer :: Server UserApi

123−userServer = createUser

124−

125−createUser :: Integer -> Handler User

126−createUser userId = do

127− if userId > 5000

128− then pure $ User { name = "some user", user_id = userId }

129− else throwError $ err400 { errBody = "userId is too small" }

130−```

131−

132−### Strategy 1: Spin Up a Server, Create a Client, Make Some Requests

133−

134−One of the benefits of Servant's type-level DSL for describing APIs is that

135−once you have provided a type-level description of your API, you can create

136−clients, documentation, or other tools for it somewhat magically.

137−

138−In this case, we'd like to *test* our server, so we can use `servant-client`

139−to create a client, after which we'll run our server, and then make requests

140−of it and see how it responds.

141−

142−Let's write some tests:

143−

144−```haskell

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

146−withUserApp action =

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

148− -- started and is being properly shutdown.

149− Warp.testWithApplication (pure userApp) action

150−

151−

152−businessLogicSpec :: Spec

153−businessLogicSpec =

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

155− around withUserApp $ do

156− -- create a test client function

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

158− -- create a servant-client ClientEnv

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

160− manager <- runIO $ newManager defaultManagerSettings

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

162−

163− -- testing scenarios start here

164− describe "POST /user" $ do

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

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

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

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

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

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

171−```

172−

173−### Running These Tests

174−

175−Let's run our tests and see what happens:

176−

177−```

178−$ cabal new-test all

179−POST /user

180− should create a user with a high enough ID

181− should fail with a too-small ID FAILED [1]

182−

183− Failures:

184−

185− Testing.lhs:129:7:

186− 1) POST /user should fail with a too-small ID

187− expected: Right (User {name = "some user", user_id = 50001})

188− but got: Left (FailureResponse (Response {responseStatusCode = Status {statusCode = 400, statusMessage = "Bad Request"}, responseHeaders = fromList [("Transfer-Encoding","chunked"),("Date","Fri, 12 Oct 2018 04:36:22 GMT"),("Server","Warp/3.2.25")], responseHttpVersion = HTTP/1.1, responseBody = "userId is too small"}))

189−

190− To rerun use: --match "/POST /user/should fail with a too-small ID/"

191−```

192−

193−Hmm. One passed and one failed! It looks like I *was* expecting a success

194−response in the second test, but I actually got a failure. We should fix that,

195−but first I'd like to introduce `hspec-wai`, which will give us different

196−mechanisms for making requests of our application and validating the responses

197−we get. We're also going to spin up a fake Elasticsearch server, so that our

198−server can think it's talking to a real database.

199−

200−

201−## *Mocking* 3rd Party Resources

202−

203−Often our web applications will need to make their own web

204−requests to other 3rd-party applications. These requests provide a lot

205−of opportunity for failure and so we'd like to test that the right

206−messages and failure values (in addition to success values) are returned

207−from our application.

208−

209−### Define the 3rd-Party Resource

210−

211−With Servant's type-level API definitions, assuming you've already defined the

212−API you want to mock, it's relatively trivial to create a simple server for

213−the purposes of running tests. For instance, consider an API server that needs

214−to get data out of Elasticsearch. Let's first define the Elasticsearch server

215−and client using Servant API descriptions:

216−

217−```haskell

218−type SearchAPI =

219− -- We're using Aeson's Generic JSON `Value` to make things easier on

220− -- ourselves. We're also representing only one Elasticsearch endpoint:

221− -- get item by id

222− "myIndex" :> "myDocType" :> Capture "docId" Integer :> Get '[JSON] Value

223−

224−-- Here's our Servant Client function

225−getDocument = client (Proxy :: Proxy SearchAPI)

226−

227−-- We can use these helpers when we want to make requests

228−-- using our client function

229−clientEnv :: Text -> Text -> IO ClientEnv

230−clientEnv esHost esPort = do

231− baseUrl <- parseBaseUrl $ unpack $ esHost <> ":" <> esPort

232− manager <- newManager defaultManagerSettings

233− pure $ mkClientEnv manager baseUrl

234−

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

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

237−```

238−

239−### Servant Server Example Using this 3rd-Party Resource

240−

241−So we've got an Elasticsearch server and a client to talk to it. Let's now

242−build a simple app server that uses this client to retrieve documents. This

243−is somewhat contrived, but hopefully it illustrates the typical three-tier

244−application architecture.

245−

246−One note: we're also going to take advantage of `lens-aeson` here, which may

247−look a bit foreign. The gist of it is that we're going to traverse a JSON

248−`Value` from Elasticsearch and try to extract some kind of document to

249−return.

250−

251−Imagine, then, that this is our real server implementation:

252−

253−```haskell

254−type DocApi =

255− "docs" :> Capture "docId" Integer :> Get '[JSON] Value

256−

257−docsApp :: Text -> Text -> Application

258−docsApp esHost esPort = serve (Proxy :: Proxy DocApi) $ docServer esHost esPort

259−

260−docServer :: Text -> Text -> Server DocApi

261−docServer esHost esPort = getDocById esHost esPort

262−

263−-- Our Handler tries to get a doc from Elasticsearch and then tries to parse

264−-- it. Unfortunately, there's a lot of opportunity for failure in these

265−-- actions

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

267−getDocById esHost esPort docId = do

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

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

270− case docRes of

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

272− Right value -> do

273− -- we'll either fail to parse our document or we'll return it

274− case value ^? _Object . ix "_source" of

275− Nothing -> throwError $ err400 { errBody = "Failed parsing content" }

276− Just obj -> pure obj

277−```

278−

279−### Testing Our Backend

280−

281−So the above represents our application and is close to a server we may

282−actually deploy. How then shall we test this application?

283−

284−Ideally, we'd like it to make requests of a *real* Elasticsearch server, but

285−we certainly don't want our tests to trigger requests to a live, production

286−database. In addition, we don't want to depend on our real Elasticsearch

287−server having specific, consistent results for us to test against, because

288−that would make our tests flaky (and flaky tests are sometimes described as

289−worse than not having tests at all).

290−

291−One solution to this is to create a trivial Elasticsearch server as part of

292−our testing code. We can do this relatively easily because we already have

293−an API definition for it above. With a *real* server, we can then let our own

294−application make requests of it and we'll simulate different scenarios in

295−order to make sure our application responds the way we expect it to.

296−

297−Let's start with some helpers which will allow us to run a testing version

298−of our Elasticsearch server in another thread:

299−

300−```haskell

301−-- | We'll run the Elasticsearch server so we can test behaviors

302−withElasticsearch :: IO () -> IO ()

303−withElasticsearch action =

304− bracket (liftIO $ C.forkIO $ Warp.run 9999 esTestApp)

305− C.killThread

306− (const action)

307−

308−esTestApp :: Application

309−esTestApp = serve (Proxy :: Proxy SearchAPI) esTestServer

310−

311−esTestServer :: Server SearchAPI

312−esTestServer = getESDocument

313−

314−-- This is the *mock* handler we're going to use. We create it

315−-- here specifically to trigger different behavior in our tests.

316−getESDocument :: Integer -> Handler Value

317−getESDocument docId

318− -- arbitrary things we can use in our tests to simulate failure:

319− -- we want to trigger different code paths.

320− | docId > 1000 = throwError err500

321− | docId > 500 = pure . Object $ HM.fromList [("bad", String "data")]

322− | otherwise = pure $ Object $ HM.fromList [("_source", Object $ HM.fromList [("a", String "b")])]

323−```

324−

325−Now, we should be ready to write some tests.

326−

327−In this case, we're going to use `hspec-wai`, which will give us a simple way

328−to run our application, make requests, and make assertions against the

329−responses we receive.

330−

331−Hopefully, this will simplify our testing code:

332−

333−```haskell

334−thirdPartyResourcesSpec :: Spec

335−thirdPartyResourcesSpec = around_ withElasticsearch $ do

336− -- we call `with` from `hspec-wai` and pass *real* `Application`

337− with (pure $ docsApp "localhost" "9999") $ do

338− describe "GET /docs" $ do

339− it "should be able to get a document" $

340− -- `get` is a function from hspec-wai`.

341− get "/docs/1" `shouldRespondWith` 200

342− it "should be able to handle connection failures" $

343− get "/docs/1001" `shouldRespondWith` 404

344− it "should be able to handle parsing failures" $

345− get "/docs/501" `shouldRespondWith` 400

346− it "should be able to handle odd HTTP requests" $

347− -- we can also make all kinds of arbitrary custom requests to see how

348− -- our server responds using the `request` function:

349− -- request :: Method -> ByteString -> [Header]

350− -- -> LB.ByteString -> WaiSession SResponse

351− request methodPost "/docs/501" [] "{" `shouldRespondWith` 405

352− it "we can also do more with the Response using hspec-wai's matchers" $

353− -- see also `MatchHeader` and JSON-matching tools as well...

354− get "/docs/1" `shouldRespondWith` 200 { matchBody = MatchBody bodyMatcher }

355−

356−bodyMatcher :: [Network.HTTP.Types.Header] -> Body -> Maybe String

357−bodyMatcher _ body = case (decode body :: Maybe Value) of

358− -- success in this case means we return `Nothing`

359− Just val | val == (Object $ HM.fromList [("a", String "b")]) -> Nothing

360− _ -> Just "This is how we represent failure: this message will be printed"

361−```

362−

363−Out of the box, `hspec-wai` provides a lot of useful tools for us to run tests

364−against our application. What happens when we run these tests?

365−

366−```

367−$ cabal new-test all

368−...

369−

370−GET /docs

371− should be able to get a document

372− should be able to handle connection failures

373− should be able to handle parsing failures

374− should be able to handle odd HTTP requests

375− we can also do more with the Response using hspec-wai's matchers

376−```

377−

378−Fortunately, they all passed! Let's move to another strategy: whole-API

379−testing.

380−

381−## Servant Quickcheck

382−

383−[`servant-quickcheck`](https://github.com/haskell-servant/servant-quickcheck)

384−is a project that allows users to write tests for whole Servant APIs using

385−quickcheck-style property-checking mechanisms.

386−

387−`servant-quickcheck` is great for asserting API-wide rules, such as "no

388−endpoint throws a 500" or "all 301 status codes also come with a Location

389−header". The project even comes with a number of predicates that reference

390−the [RFCs they originate from](https://github.com/haskell-servant/servant-quickcheck/blob/master/src/Servant/QuickCheck/Internal/Predicates.hs).

391−

392−In other words, it's one way to assert that your APIs conform to specs and

393−best practices.

394−

395−### Quickcheckable API

396−

397−Let's make an API and a server to demonstrate how to use `servant-quickcheck`:

398−

399−```haskell

400−type API = ReqBody '[JSON] String :> Post '[JSON] String

401− :<|> Get '[JSON] Int

402− :<|> BasicAuth "some-realm" () :> Get '[JSON] ()

403−

404−api :: Proxy API

405−api = Proxy

406−

407−server :: IO (Server API)

408−server = do

409− mvar <- newMVar ""

410− return $ (\x -> liftIO $ swapMVar mvar x)

411− :<|> (liftIO $ readMVar mvar >>= return . length)

412− :<|> (const $ return ())

413−```

414−

415−### Using `servant-quickcheck`

416−

417−Let's build some tests for our API using `servant-quickcheck`.

418−

419−Similar to the above examples, we're going to create `Spec`s, but in this

420−case, we'll rely on a number of predicates available from `servant-quickcheck`

421−to see if our API server conforms to best practices:

422−

423−```haskell

424−-- Let's set some QuickCheck values

425−args :: Args

426−args = defaultArgs { maxSuccess = 500 }

427−

428−-- Here's a Servant Context object we'll use

429−ctx :: Context '[BasicAuthCheck ()]

430−ctx = BasicAuthCheck (const . return $ NoSuchUser) :. EmptyContext

431−

432−

433−servantQuickcheckSpec :: Spec

434−servantQuickcheckSpec = describe "" $ do

435− it "API demonstrates best practices" $

436− -- `withServerServer` and `withServantServerAndContext` come from `servant-quickcheck`

437− withServantServerAndContext api ctx server $ \burl ->

438− -- `serverSatisfies` and the predicates also come from `servant-quickcheck`

439− serverSatisfies api burl args (unauthorizedContainsWWWAuthenticate

440− <%> not500

441− <%> onlyJsonObjects -- this one isn't true!

442− <%> mempty)

443−

444− it "API doesn't have these things implemented yet" $

445− withServantServerAndContext api ctx server $ \burl -> do

446− serverDoesntSatisfy api burl args (getsHaveCacheControlHeader

447− <%> notAllowedContainsAllowHeader

448− <%> mempty)

449−```

450−

451−Let's see what happens when we run these tests:

452−

453−

454−```

455− API demonstrates best practices FAILED [2]

456−+++ OK, passed 500 tests.

457− API doesn't have these things implemented yet

458−

459− src/Servant/QuickCheck/Internal/QuickCheck.hs:143:11:

460− 2) Main[339:25] API demonstrates best practices

461− Failed:

462− Just Predicate failed

463− Predicate: onlyJsonObjects

464−

465− Response:

466− Status code: 200

467− Headers: "Transfer-Encoding": "chunked"

468− "Date": "Fri, 12 Oct 2018 04:36:22 GMT"

469− "Server": "Warp/3.2.25"

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

471− Body: ""

472−

473− To rerun use: --match "/Main[339:25]/API demonstrates best practices/"

474−

475−Randomized with seed 1046277487

476−

477−Finished in 0.4306 seconds

478−```

479−

480−Hmm. It looks like we *thought* our API only returned JSON objects, which is a

481−best practice, but in fact, we *did* have an endpoint that returned an empty

482−body, which you can see in the printed response above: `Body: ""`. We should

483−consider revising our API to only return top-level JSON Objects in the future!

484−

485−### Other Cool Things

486−

487−`servant-quickcheck` also has a cool mechanism where you can compare two API

488−servers to demonstrate that they respond identically to requests. This may be

489−useful if you are planning to rewrite one API in another language or with

490−another web framework. You have to specify whether you're looking for

491−`jsonEquality` vs regular `ByteString` equality, though.

492−

493−## Conclusion

494−

495−There are lots of techniques for testing and we only covered a few here.

496−

497−Useful libraries such as `hspec-wai` have ways of running Wai `Application`s

498−and sending requests to them, while Servant's type-level DSL for defining APIs

499−allows us to more easily mock out servers and to derive clients, which will

500−only craft valid requests.

501−

502−Lastly, if you want a broad overview of where your application fits in with

503−regard to best practices, consider using `servant-quickcheck`.

504−

505−This program is available as a cabal project

506−[here](https://github.com/haskell-servant/servant/tree/master/doc/cookbook/testing).

doc/cookbook/testing/testing.cabaldeleted−38

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

1−cabal-version: 2.2

2−name: cookbook-testing

3−version: 0.0.1

4−synopsis: Common testing patterns in Servant apps

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

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

7−license: BSD-3-Clause

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

9−author: Servant Contributors

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

11−category: Servant

12−build-type: Simple

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

14−

15−executable cookbook-testing

16− main-is: Testing.lhs

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

18− , base-compat

19− , text >= 1.2

20− , aeson >= 1.2

21− , lens-aeson

22− , lens

23− , servant

24− , servant-client

25− , servant-server

26− , servant-quickcheck >= 0.0.10

27− , http-client

28− , http-types >= 0.12

29− , hspec

30− , hspec-wai

31− , QuickCheck

32− , unordered-containers

33− , warp >= 3.2

34− , wai >= 3.2

35− , wai-extra

36− default-language: Haskell2010

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

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

doc/cookbook/using-custom-monad/UsingCustomMonad.lhsdeleted−120

@@ -1,120 +0,0 @@

1−# Using a custom monad

2−

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

4−We will keep state in memory and share it between requests using `Reader` monad and `STM`.

5−

6−We start with a pretty standard set of imports and definition of the model:

7−

8−``` haskell

9−{-# LANGUAGE DataKinds #-}

10−{-# LANGUAGE DeriveGeneric #-}

11−{-# LANGUAGE TypeOperators #-}

12−

13−import Control.Concurrent (forkIO, killThread)

14−import Control.Concurrent.STM.TVar (TVar, newTVar, readTVar,

15− writeTVar)

16−import Control.Exception (bracket)

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

18−import Control.Monad.STM (atomically)

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

20−import Data.Aeson (FromJSON, ToJSON)

21−import GHC.Generics (Generic)

22−import Network.HTTP.Client (defaultManagerSettings,

23− newManager)

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

25−

26−import Servant

27−import Servant.Client

28−

29−newtype Book = Book String deriving (Show, Generic)

30−instance ToJSON Book

31−instance FromJSON Book

32−```

33−

34−Now, let's define the API for book storage.

35−For the sake of simplicity we'll only have methods for getting all books and adding a new one.

36−

37−``` haskell

38−type GetBooks = Get '[JSON] [Book]

39−type AddBook = ReqBody '[JSON] Book :> PostCreated '[JSON] Book

40−type BooksAPI = "books" :> (GetBooks :<|> AddBook)

41−

42−api :: Proxy BooksAPI

43−api = Proxy

44−```

45−

46−Next, we define the state and the monad to run our handlers

47−

48−``` haskell

49−data State = State

50− { books :: TVar [Book]

51− }

52−

53−type AppM = ReaderT State Handler

54−```

55−

56−Note that we can't use `State` monad here, because state will not be shared between requests.

57−

58−We can now define handlers in terms of `AppM`...

59−

60−```haskell

61−server :: ServerT BooksAPI AppM

62−server = getBooks :<|> addBook

63− where getBooks :: AppM [Book]

64− getBooks = do

65− State{books = p} <- ask

66− liftIO $ atomically $ readTVar p

67−

68− addBook :: Book -> AppM Book

69− addBook book = do

70− State{books = p} <- ask

71− liftIO $ atomically $ readTVar p >>= writeTVar p . (book :)

72− return book

73−

74−```

75−

76−...and transform `AppM` to `Handler` by simply using `runReaderT`

77−

78−``` haskell

79−nt :: State -> AppM a -> Handler a

80−nt s x = runReaderT x s

81−

82−app :: State -> Application

83−app s = serve api $ hoistServer api (nt s) server

84−```

85−

86−Finally, we end up with the following program

87−

88−``` haskell

89−main :: IO ()

90−main = do

91− let port = 8080

92− mgr <- newManager defaultManagerSettings

93− initialBooks <- atomically $ newTVar []

94− let runApp = run port $ app $ State initialBooks

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

96− let getBooksClient :<|> addBookClient = client api

97− let printBooks = getBooksClient >>= liftIO . print

98− _ <- flip runClientM (mkClientEnv mgr (BaseUrl Http "localhost" port "")) $ do

99− _ <- printBooks

100− _ <- addBookClient $ Book "Harry Potter and the Order of the Phoenix"

101− _ <- printBooks

102− _ <- addBookClient $ Book "To Kill a Mockingbird"

103− _ <- printBooks

104− _ <- addBookClient $ Book "The Picture of Dorian Gray"

105− printBooks

106− return ()

107−```

108−

109−When run, it outputs the following:

110−

111−```

112−Running cookbook-using-custom-monad...

113−[]

114−[Book "Harry Potter and the Order of the Phoenix"]

115−[Book "To Kill a Mockingbird",Book "Harry Potter and the Order of the Phoenix"]

116−[Book "The Picture of Dorian Gray",Book "To Kill a Mockingbird",Book "Harry Potter and the Order of the Phoenix"]

117−```

118−

119−To use `Raw` endpoints, look at the

120−[servant-rawm](http://hackage.haskell.org/package/servant-rawm) package.

doc/cookbook/using-custom-monad/using-custom-monad.cabaldeleted−28

@@ -1,28 +0,0 @@

1−cabal-version: 2.2

2−name: cookbook-using-custom-monad

3−version: 0.1

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

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

6−license: BSD-3-Clause

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

8−author: Servant Contributors

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

10−build-type: Simple

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

12−

13−executable cookbook-using-custom-monad

14− main-is: UsingCustomMonad.lhs

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

16− , aeson >= 1.2

17− , servant

18− , servant-client

19− , servant-server

20− , warp >= 3.2

21− , wai >= 3.2

22− , http-client >= 0.5

23− , markdown-unlit >= 0.4

24− , stm >= 2.4

25− , transformers >= 0.3

26− default-language: Haskell2010

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

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

doc/cookbook/using-free-client/UsingFreeClient.lhsdeleted−192

@@ -1,192 +0,0 @@

1−# Inspecting, debugging, simulating clients and more

2−

3−or simply put: _a practical introduction to `Servant.Client.Free`_.

4−

5−Someone asked on IRC how one could access the intermediate Requests (resp. Responses)

6−produced (resp. received) by client functions derived using servant-client.

7−My response to such inquiries is: to extend `servant-client` in an ad-hoc way (e.g for testing or debugging

8−purposes), use `Servant.Client.Free`. This recipe shows how.

9−

10−First the module header, but this time We'll comment the imports.

11−

12−```haskell

13−{-# LANGUAGE DataKinds #-}

14−{-# LANGUAGE TypeOperators #-}

15−module Main (main) where

16−```

17−

18−We will primarily use `Servant.Client.Free`, it doesn't re-export anything

19−from `free` package, so we need to import it as well.

20−

21−```haskell

22−import Control.Monad.Free

23−import Servant.Client.Free

24−```

25−

26−Also we'll use `servant-client` internals, which uses `http-client`,

27−so let's import them *qualified*

28−

29−```haskell

30−import qualified Servant.Client.Internal.HttpClient as I

31−import qualified Network.HTTP.Client as HTTP

32−```

33−

34−The rest of the imports are for a server we implement here for completeness.

35−

36−```haskell

37−import Servant

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

39−import System.Environment (getArgs)

40−```

41−

42−## API & Main

43−

44−We'll work with a very simple API:

45−

46−```haskell

47−type API = "square" :> Capture "n" Int :> Get '[JSON] Int

48−

49−api :: Proxy API

50−api = Proxy

51−```

52−

53−Next we implement a `main`. If passed `"server"` it will run `server`, if passed

54−`"client"` it will run a `test` function (to be defined next). This should be

55−pretty straightforward:

56−

57−```haskell

58−main :: IO ()

59−main = do

60− args <- getArgs

61− case args of

62− ("server":_) -> do

63− putStrLn "Starting cookbook-using-free-client at http://localhost:8000"

64− run 8000 $ serve api $ \n -> return (n * n)

65− ("client":_) ->

66− test

67− _ -> do

68− putStrLn "Try:"

69− putStrLn "cabal new-run cookbook-using-free-client server"

70− putStrLn "cabal new-run cookbook-using-free-client client"

71−```

72−

73−## Test

74−

75−In the client part, we will use a `Servant.Client.Free` client.

76−Because we have a single endpoint API, we'll get a single client function,

77−running in the `Free ClientF` (free) monad:

78−

79−```haskell

80−getSquare :: Int -> Free ClientF Int

81−getSquare = client api

82−```

83−

84−Such clients are "client functions without a backend", so to speak,

85−or where the backend has been abstracted out. To be more precise, `ClientF` is a functor that

86−precisely represents the operations servant-client-core needs from an http client backend.

87−So if we are to emulate one or augment what such a backend does, it will be by interpreting

88−all those operations, the way we want to. This also means we get access to the requests and

89−responses and can do anything we want with them, right when they are produced or consumed,

90−respectively.

91−

92−Next, we can write our small test. We'll pass a value to `getSquare` and inspect

93−the `Free` structure. The first three possibilities are self-explanatory:

94−

95−```haskell

96−test :: IO ()

97−test = case getSquare 42 of

98− Pure n ->

99− putStrLn $ "ERROR: got pure result: " ++ show n

100− Free (Throw err) ->

101− putStrLn $ "ERROR: got error right away: " ++ show err

102−```

103−

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

105−

106−```haskell

107− Free (RunRequest req k) -> do

108−```

109−

110−Then we need to prepare the context, get HTTP (connection) `Manager`

111−and `BaseUrl`:

112−

113−```haskell

114− burl <- parseBaseUrl "http://localhost:8000"

115− mgr <- HTTP.newManager HTTP.defaultManagerSettings

116−```

117−

118−Now we can use `servant-client`'s internals to convert servant's `Request`

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

120−

121−```haskell

122− req' <- I.defaultMakeClientRequest burl req

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

124−```

125−

126−`servant-client`'s request does a little more, but this is good enough for

127−our demo. We get back an http-client `Response` which we can also inspect.

128−

129−```haskell

130− res' <- HTTP.httpLbs req' mgr

131− putStrLn $ "Got response: " ++ show res'

132−```

133−

134−And we continue by turning http-client's `Response` into servant's `Response`,

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

136−

137−```haskell

138− let res = I.clientResponseToResponse id res'

139−

140− case k res of

141− Pure n ->

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

143− _ ->

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

145−```

146−

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

148−validate that the client functions or the HTTP client backend does what we expect

149−(e.g by printing requests/responses on the fly). In fact, using `Servant.Client.Free`

150−is a little simpler than defining a custom `RunClient` instance, especially

151−for those cases where it is handy to have the full sequence of client calls

152−and responses available for us to inspect, since `RunClient` only gives us

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

154−

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

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

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

158−

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

160−

161−```

162−Making request: Request {

163− host = "localhost"

164− port = 8000

165− secure = False

166− requestHeaders = [("Accept","application/json;charset=utf-8,application/json")]

167− path = "/square/42"

168− queryString = ""

169− method = "GET"

170− proxy = Nothing

171− rawBody = False

172− redirectCount = 10

173− responseTimeout = ResponseTimeoutDefault

174− requestVersion = HTTP/1.1

175−}

176−

177−Got response: Response

178− { responseStatus = Status {statusCode = 200, statusMessage = "OK"}

179− , responseVersion = HTTP/1.1

180− , responseHeaders =

181− [ ("Transfer-Encoding","chunked")

182− , ("Date","Thu, 05 Jul 2018 21:12:41 GMT")

183− , ("Server","Warp/3.2.22")

184− , ("Content-Type","application/json;charset=utf-8")

185− ]

186− , responseBody = "1764"

187− , responseCookieJar = CJ {expose = []}

188− , responseClose' = ResponseClose

189− }

190−

191−Expected 1764, got 1764

192−```

doc/cookbook/using-free-client/using-free-client.cabaldeleted−26

@@ -1,26 +0,0 @@

1−cabal-version: 2.2

2−name: cookbook-using-free-client

3−version: 0.1

4−synopsis: Using Free client

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

6−license: BSD-3-Clause

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

8−author: Servant Contributors

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

10−build-type: Simple

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

12−

13−executable cookbook-using-free-client

14− main-is: UsingFreeClient.lhs

15− build-depends: base >= 4.9 && <5

16− , free

17− , servant

18− , servant-client

19− , http-client

20− , servant-client-core

21− , base-compat

22− , servant-server

23− , warp >= 3.2

24− default-language: Haskell2010

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

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

doc/cookbook/uverb/UVerb.lhsdeleted−223

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

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

2−

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

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

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

6−

7−## Compatibility

8−

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

10−

11−## Preliminaries

12−

13−```haskell

14−{-# LANGUAGE ConstraintKinds #-}

15−{-# LANGUAGE DataKinds #-}

16−{-# LANGUAGE DeriveGeneric #-}

17−{-# LANGUAGE DerivingStrategies #-}

18−{-# LANGUAGE DeriveAnyClass #-}

19−{-# LANGUAGE DerivingVia #-}

20−{-# LANGUAGE FlexibleContexts #-}

21−{-# LANGUAGE FlexibleInstances #-}

22−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

23−{-# LANGUAGE InstanceSigs #-}

24−{-# LANGUAGE MultiParamTypeClasses #-}

25−{-# LANGUAGE OverloadedStrings #-}

26−{-# LANGUAGE ScopedTypeVariables #-}

27−{-# LANGUAGE StandaloneDeriving #-}

28−{-# LANGUAGE TypeApplications #-}

29−{-# LANGUAGE TypeFamilies #-}

30−{-# LANGUAGE TypeOperators #-}

31−{-# LANGUAGE UndecidableInstances #-}

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

33−

34−import Control.Concurrent (threadDelay)

35−import Control.Concurrent.Async (async)

36−import Control.Monad (when)

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

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

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

40−import Data.String.Conversions (cs)

41−import Data.Swagger (ToSchema)

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

43−import qualified GHC.Generics as GHC

44−import qualified Network.HTTP.Client as Client

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

46−import Servant.API

47−import Servant.Client

48−import Servant.Server

49−import Servant.Swagger

50−```

51−

52−## The API

53−

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

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

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

57−

58−```haskell

59−type API =

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

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

62− :<|> "arian"

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

64−```

65−

66−Here are the details:

67−

68−```haskell

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

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

71−

72−instance ToJSON FisxUser

73−instance FromJSON FisxUser

74−instance ToSchema FisxUser

75−

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

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

78−--

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

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

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

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

83−-- @Resource That@.)

84−instance HasStatus FisxUser where

85− type StatusOf FisxUser = 203

86−

87−data ArianUser = ArianUser

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

89−

90−instance ToJSON ArianUser

91−instance FromJSON ArianUser

92−instance ToSchema ArianUser

93−```

94−

95−## Server, Client, Swagger

96−

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

98−

99−```haskell

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

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

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

103−

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

105−arian = respond (WithStatus @201 ArianUser)

106−```

107−

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

109−

110−```

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

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

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

114−```

115−

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

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

118−result unions in clients:

119−

120−```

121−main :: IO ()

122−main = do

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

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

125− threadDelay 50000

126− mgr <- Client.newManager Client.defaultManagerSettings

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

128− result <- runClientM (fisxClient True) cenv

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

130− print $ matchUnion @FisxUser <$> result

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

132− pure ()

133−```

134−

135−## Idiomatic exceptions

136−

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

138−

139−```haskell

140−newtype UVerbT xs m a = UVerbT { unUVerbT :: ExceptT (Union xs) m a }

141− deriving (Functor, Applicative, Monad, MonadTrans)

142−

143−-- | Deliberately hide 'ExceptT's 'MonadError' instance to be able to use

144−-- underlying monad's instance.

145−instance MonadError e m => MonadError e (UVerbT xs m) where

146− throwError = lift . throwError

147− catchError (UVerbT act) h = UVerbT $ ExceptT $

148− runExceptT act `catchError` (runExceptT . unUVerbT . h)

149−

150−-- | This combinator runs 'UVerbT'. It applies 'respond' internally, so the handler

151−-- may use the usual 'return'.

152−runUVerbT :: (Monad m, HasStatus x, IsMember x xs) => UVerbT xs m x -> m (Union xs)

153−runUVerbT (UVerbT act) = either id id <$> runExceptT (act >>= respond)

154−

155−-- | Short-circuit 'UVerbT' computation returning one of the response types.

156−throwUVerb :: (Monad m, HasStatus x, IsMember x xs) => x -> UVerbT xs m a

157−throwUVerb = UVerbT . ExceptT . fmap Left . respond

158−```

159−

160−Example usage:

161−

162−```haskell

163−data Foo = Foo Int Int Int

164− deriving (Show, Eq, GHC.Generic, ToJSON)

165− deriving HasStatus via WithStatus 200 Foo

166−

167−data Bar = Bar

168− deriving (Show, Eq, GHC.Generic)

169−

170−instance ToJSON Bar

171−

172−h :: Handler (Union '[Foo, WithStatus 400 Bar])

173−h = runUVerbT $ do

174− when ({- something bad -} True) $

175− throwUVerb $ WithStatus @400 Bar

176−

177− when ({- really bad -} False) $

178− throwError $ err500

179−

180− -- a lot of code here...

181−

182− return $ Foo 1 2 3

183−```

184−

185−## Related Work

186−

187−There is the [issue from

188−2017](https://github.com/haskell-servant/servant/issues/841) that was

189−resolved by the introduction of `UVerb`, with a long discussion on

190−alternative designs.

191−

192−[servant-checked-exceptions](https://hackage.haskell.org/package/servant-checked-exceptions)

193−is a good solution to the problem, but it restricts the user to JSON

194−and a very specific envelop encoding for the union type, which is

195−often not acceptable. (One good reason for this design choice is that

196−it makes writing clients easier, where you need to get to the union

197−type from one representative, and you don't want to run several

198−parsers in the hope that the ones that should will always error out so

199−you can try until the right one returns a value.)

200−

201−[servant-exceptions](https://github.com/ch1bo/servant-exceptions) is

202−another shot at at the problem. It is inspired by

203−servant-checked-exceptions, so it may be worth taking a closer look.

204−The README claims that

205−[cardano-sl](https://github.com/input-output-hk/cardano-sl) also has

206−some code for generalized error handling.

207−

208−In an earier version of the `UVerb` implementation, we have used some

209−code from

210−[world-peace](https://hackage.haskell.org/package/world-peace), but

211−that package itself wasn't flexible enough, and we had to use

212−[sop-core](https://hackage.haskell.org/package/sop-core) to implement

213−the `HasServer` instance.

214−

215−Here is a blog post we found on the subject:

216−https://lukwagoallan.com/posts/unifying-servant-server-error-responses

217−

218−(If you have anything else, please add it here or let us know.)

219−

220−```haskell

221−main :: IO ()

222−main = return ()

223−```

doc/cookbook/uverb/uverb.cabaldeleted−35

@@ -1,35 +0,0 @@

1−cabal-version: 2.2

2−name: cookbook-uverb

3−version: 0.0.1

4−synopsis: How to use the 'UVerb' type.

5−description: Listing alternative responses and exceptions in your API types.

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

7−license: BSD-3-Clause

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

9−author: Servant Contributors

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

11−category: Servant

12−build-type: Simple

13−tested-with: GHC==8.6.5, GHC==8.8.4, GHC==8.10.7

14−

15−executable cookbook-uverb

16− main-is: UVerb.lhs

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

18− , aeson >= 1.2

19− , aeson-pretty >= 0.8.8

20− , async

21− , http-client

22− , mtl

23− , servant

24− , servant-client

25− , servant-server

26− , servant-swagger

27− , string-conversions

28− , swagger2

29− , wai

30− , warp

31− if impl(ghc >= 9)

32− buildable: False

33− default-language: Haskell2010

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

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

doc/examples.mddeleted−60

@@ -1,60 +0,0 @@

1−# Example Projects

2−

3−- **[example-servant-minimal](https://github.com/haskell-servant/example-servant-minimal)**:

4−

5− A minimal example for a web server written using **servant-server**,

6− including a test-suite using [**hspec**](http://hspec.github.io/) and

7− **servant-client**.

8−

9−- **[servant-examples](https://github.com/sras/servant-examples)**:

10−

11− Similar to [the cookbook](https://docs.servant.dev/en/latest/cookbook/index.html) but

12− with no explanations, for developers who just want to look at code examples to find out how to do X or Y

13− with servant.

14−

15−- **[stack-templates](https://github.com/commercialhaskell/stack-templates)**

16−

17− Repository for templates for haskell projects, including some templates using

18− **servant**. These templates can be used with `stack new`.

19−

20−- **[custom-monad](https://github.com/themoritz/diener)**:

21−

22− A custom monad that can replace `IO` in servant applications. It adds among

23− other things logging functionality and a reader monad (for database connections).

24− A full usage example of servant/diener is also provided.

25−

26−- **[example-servant-elm](https://github.com/haskell-servant/example-servant-elm)**:

27−

28− An example for a project consisting of

29−

30− - a backend web server written using **servant-server**,

31− - a frontend written in [elm](http://elm-lang.org/) using

32− [servant-elm](https://github.com/mattjbray/servant-elm) to generate client

33− functions in elm for the API,

34− - test-suites for both the backend and the frontend.

35−

36−- **[servant-purescript](https://github.com/eskimor/servant-purescript/tree/master/examples/central-counter)**:

37−

38− An example consisting of

39−

40− - a backend that uses `servant`

41− - a frontend written in [PureScript](http://www.purescript.org/) using

42− [servant-purescript](https://github.com/eskimor/servant-purescript) to generate

43− an API wrapper in PureScript to interface the web API with

44−

45−

46−- **[example-servant-persistent](https://github.com/haskell-servant/example-servant-persistent)**:

47−

48− An example for a web server written with **servant-server** and

49− [persistent](https://www.stackage.org/package/persistent) for writing data

50− into a database.

51−

52−- **[full-example-servant-elm-auth-yeshql-postgresql](https://github.com/aRkadeFR/FlashCard)**:

53−

54− A full open source website written with **servant-server**, yeshql, postgresql and elm 0.19.

55−

56−

57−- [`import Servant` github search](https://github.com/search?q=%22import+Servant%22+language%3AHaskell&type=Code)

58−

59− It has thousands of results and can be a good way to see how people use servant in their projects or even to discover

60− servant-related libraries.

doc/index.rst+9−13

@@ -3,24 +3,20 @@ servant – A Type-Level Web DSL

44.. image:: https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png

6−**servant** is a set of Haskell libraries for writing *type-safe* web

7−applications but also *deriving* clients (in Haskell and other languages) or

8−generating documentation for them, and more.

6+**servant** is a set of packages for declaring web APIs at the type-level and

7+then using those API specifications to:

10−This is achieved by taking as input a description of the web API

11−as a Haskell type. Servant is then able to check that your server-side request

12−handlers indeed implement your web API faithfully, or to automatically derive

13−Haskell functions that can hit a web application that implements this API,

14−generate a Swagger description or code for client functions in some other

15−languages directly.

9+- write servers (this part of **servant** can be considered a web framework),

10+- obtain client functions (in haskell),

11+- generate client functions for other programming languages,

12+- generate documentation for your web applications

13+- and more...

1614

17−If you would like to learn more, click the tutorial link below.

15+All in a type-safe manner.

1816

1917.. toctree::

2018 :maxdepth: 2

2119

20+ introduction.rst

2221 tutorial/index.rst

23− cookbook/index.rst

24− examples.md

2522 links.rst

26− principles.rst

doc/principles.rst → doc/introduction.rstrenamed+3−3

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

1−Principles

2−----------

1+Introduction

2+------------

44**servant** has the following guiding principles:

@@ -22,7 +22,7 @@ Principles

2222

2323- separation of concerns

2424

25− Your handlers and your HTTP logic should be separate. True to the philosophy

25+ Your handlers and your HTTP logic should be separate. True to the philosphy

2626 at the core of HTTP and REST, with **servant** your handlers return normal

2727 Haskell datatypes - that's the resource. And then from a description of your

2828 API, **servant** handles the *presentation* (i.e., the Content-Types). But

doc/links.rst+3−3

@@ -3,7 +3,7 @@ Helpful Links

33-------------

55- the central documentation (this site):

6− `docs.servant.dev <http://docs.servant.dev/>`_

6+ `haskell-servant.readthedocs.org <http://haskell-servant.readthedocs.org/>`_

88- the github repo:

99 `github.com/haskell-servant/servant <https://github.com/haskell-servant/servant>`_

@@ -12,13 +12,13 @@ Helpful Links

1212 `https://github.com/haskell-servant/servant/issues <https://github.com/haskell-servant/servant/issues>`_

1313

1414- the irc channel:

15− `#haskell-servant on libera.chat <https://web.libera.chat/#haskell-servant>`_

15+ ``#servant`` on freenode

1616

1717- the mailing list:

1818 `groups.google.com/forum/#!forum/haskell-servant <https://groups.google.com/forum/#!forum/haskell-servant>`_

1919

2020- blog posts and videos and slides of some talks on servant:

21− `www.servant.dev <http://www.servant.dev>`_

21+ `haskell-servant.github.io <http://haskell-servant.github.io>`_

2222

2323- the servant packages on hackage:

2424

doc/requirements.txt+25−3

@@ -1,3 +1,25 @@

1−recommonmark==0.5.0

2−Sphinx==1.8.4

3−sphinx_rtd_theme>=0.4.2

1+alabaster==0.7.7

2+argh==0.26.1

3+Babel==2.2.0

4+backports-abc==0.4

5+backports.ssl-match-hostname==3.5.0.1

6+certifi==2015.11.20.1

7+CommonMark==0.5.4

8+docutils==0.12

9+Jinja2==2.8

10+livereload==2.4.1

11+MarkupSafe==0.23

12+pathtools==0.1.2

13+Pygments==2.1.1

14+pytz==2015.7

15+PyYAML==3.11

16+recommonmark==0.4.0

17+singledispatch==3.4.0.3

18+six==1.10.0

19+snowballstemmer==1.2.1

20+Sphinx==1.3.4

21+sphinx-autobuild==0.5.2

22+sphinx-rtd-theme==0.1.9

23+tornado==4.3

24+watchdog==0.8.3

25+wheel==0.26.0

doc/tutorial/.ghci+1−1

@@ -1 +1 @@

1−:set -pgmL markdown-unlit -Wall -Werror -fno-warn-missing-methods -fno-warn-name-shadowing -itest

1+:set -pgmL markdown-unlit -Wall -Werror -fno-warn-missing-methods -fno-warn-name-shadowing

doc/tutorial/ApiType.lhs+12−119

@@ -10,7 +10,6 @@ need to have some language extensions and imports:

1010module ApiType where

1111

1212import Data.Text

13−import Data.Time (UTCTime)

1413import Servant.API

1514```

1615

@@ -35,9 +34,7 @@ data SortBy = Age | Name

3534

3635data User = User {

3736 name :: String,

38− age :: Int,

39− email :: String,

40− registration_date :: UTCTime

37+ age :: Int

4138}

4239```

4340

@@ -61,14 +58,6 @@ Let's break that down:

6158 is equivalent to `/list-all/users`. This means that sometimes `:>` is somehow

6259 equivalent to `/`, but sometimes it just lets you chain another combinator.

6360

64−Tip: If your endpoint responds to `/` (the root path), just omit any combinators

65−that introduce path segments. E.g. the following api has only one endpoint on `/`:

66−

67−``` haskell

68−type RootEndpoint =

69− Get '[JSON] User

70−```

71−

7261We can also describe APIs with multiple endpoints by using the `:<|>`

7362combinators. Here's an example:

7463

@@ -79,7 +68,7 @@ type UserAPI2 = "users" :> "list-all" :> Get '[JSON] [User]

7968

8069**servant** provides a fair amount of combinators out-of-the-box, but you can

8170always write your own when you need it. Here's a quick overview of the most

82−often needed combinators that **servant** comes with.

71+often needed the combinators that **servant** comes with.

8372

8473## Combinators

8574

@@ -106,10 +95,10 @@ type Get = Verb 'GET 200

10695There are other predefined type synonyms for other common HTTP methods,

10796such as e.g.:

10897``` haskell ignore

109−type Delete = Verb 'DELETE 200

110−type Patch = Verb 'PATCH 200

111−type Post = Verb 'POST 200

112−type Put = Verb 'PUT 200

98+data Delete = Verb 'DELETE 200

99+data Patch = Verb 'PATCH 200

100+data Post = Verb 'POST 200

101+data Put = Verb 'PUT 200

113102```

114103

115104There are also variants that do not return a 200 status code, such

@@ -127,26 +116,6 @@ type UserAPI4 = "users" :> Get '[JSON] [User]

127116 :<|> "admins" :> Get '[JSON] [User]

128117```

129118

130−### `StreamGet` and `StreamPost`

131−

132−*Note*: Streaming has changed considerably in `servant-0.15`.

133−

134−The `StreamGet` and `StreamPost` combinators are defined in terms of the more general `Stream`

135−

136−``` haskell ignore

137−data Stream (method :: k1) (status :: Nat) (framing :: *) (contentType :: *) (a :: *)

138−

139−type StreamGet = Stream 'GET 200

140−type StreamPost = Stream 'POST 200

141−```

142−

143−These describe endpoints that return a stream of values rather than just a

144−single value. They not only take a single content type as a parameter, but also

145−a framing strategy -- this specifies how the individual results are delineated

146−from one another in the stream. The three standard strategies given with

147−Servant are `NewlineFraming`, `NetstringFraming` and `NoFraming`, but others

148−can be written to match other protocols.

149−

150119### `Capture`

151120

152121URL captures are segments of the path of a URL that are variable and whose actual value is

@@ -166,7 +135,7 @@ data Capture (s :: Symbol) a

166135```

167136

168137In some web frameworks, you use regexes for captures. We use a

169−[`FromHttpApiData`](https://hackage.haskell.org/package/http-api-data/docs/Web-HttpApiData.html#t:FromHttpApiData)

138+[`FromText`](https://hackage.haskell.org/package/servant/docs/Servant-Common-Text.html#t:FromText)

170139class, which the captured value must be an instance of.

171140

172141Examples:

@@ -177,12 +146,13 @@ type UserAPI5 = "user" :> Capture "userid" Integer :> Get '[JSON] User

177146 -- except that we explicitly say that "userid"

178147 -- must be an integer

179148

180− :<|> "user" :> Capture "userid" Integer :> DeleteNoContent

149+ :<|> "user" :> Capture "userid" Integer :> DeleteNoContent '[JSON] NoContent

181150 -- equivalent to 'DELETE /user/:userid'

182151```

183152

184−In the second case, `DeleteNoContent` specifies a 204 response code

185−and that the response will always be empty.

153+In the second case, `DeleteNoContent` specifies a 204 response code,

154+`JSON` specifies the content types on which the handler will match,

155+and `NoContent` says that the response will always be empty.

186156

187157### `QueryParam`, `QueryParams`, `QueryFlag`

188158

@@ -317,56 +287,6 @@ response, you could write it as below:

317287type UserAPI10 = "users" :> Get '[JSON] (Headers '[Header "User-Count" Integer] [User])

318288```

319289

320−### Basic Authentication

321−

322−Once you've established the basic routes and semantics of your API, it's time

323−to consider protecting parts of it. Authentication and authorization are broad

324−and nuanced topics; as servant began to explore this space we started small

325−with one of HTTP's earliest authentication schemes: [Basic

326−Authentication](https://en.wikipedia.org/wiki/Basic_access_authentication).

327−

328−When protecting endpoints with basic authentication, we need to specify two items:

329−

330−1. The **realm** of authentication as per the Basic Authentication spec.

331−2. The datatype returned by the server after authentication is verified. This

332− is usually a `User` or `Customer` type datatype.

333−

334−With those two items in mind, *servant* provides the following combinator:

335−

336−``` haskell ignore

337−data BasicAuth (realm :: Symbol) (userData :: *)

338−```

339−

340−Which is used like so:

341−

342−``` haskell

343−type ProtectedAPI11

344− = UserAPI -- this is public

345− :<|> BasicAuth "my-realm" User :> UserAPI2 -- this is protected by auth

346−```

347−

348−### Empty APIs

349−

350−Sometimes it is useful to be able to generalise an API over the type of some

351−part of it:

352−

353−``` haskell

354−type UserAPI12 innerAPI

355− = UserAPI -- this is the fixed bit of the API

356− :<|> "inner" :> innerAPI -- this lets us put various other APIs under /inner

357−```

358−

359−If there is a case where you do not have anything extra to serve, you can use

360−the `EmptyAPI` combinator to indicate this:

361−

362−``` haskell

363−type UserAPI12Alone = UserAPI12 EmptyAPI

364−```

365−

366−This also works well as a placeholder for unfinished parts of an API while it

367−is under development, for when you know that there should be _something_ there

368−but you don't yet know what. Think of it as similar to the unit type `()`.

369−

370290### Interoperability with `wai`: `Raw`

371291

372292Finally, we also include a combinator named `Raw` that provides an escape hatch

@@ -375,7 +295,7 @@ you want to plug a [wai `Application`](http://hackage.haskell.org/package/wai)

375295into your webservice:

376296

377297``` haskell

378−type UserAPI13 = "users" :> Get '[JSON] [User]

298+type UserAPI11 = "users" :> Get '[JSON] [User]

379299 -- a /users endpoint

380300

381301 :<|> Raw

@@ -389,30 +309,3 @@ One example for this is if you want to serve a directory of static files along

389309with the rest of your API. But you can plug in everything that is an

390310`Application`, e.g. a whole web application written in any of the web

391311frameworks 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.lhsdeleted−439

@@ -1,439 +0,0 @@

1−# Authentication in Servant

2−

3−Once you've established the basic routes and semantics of your API, it's time

4−to consider protecting parts of it. Authentication and authorization are broad

5−and nuanced topics; as servant began to explore this space we started small

6−with one of HTTP's earliest authentication schemes: [Basic Authentication](https://en.wikipedia.org/wiki/Basic_access_authentication).

7−

8−Servant `0.5` shipped with out-of-the-box support for Basic Authentication.

9−However, we recognize that every web application is its own beautiful snowflake

10−and are offering experimental support for generalized or ad-hoc authentication.

11−

12−In this tutorial we'll build two APIs. One protecting certain routes with Basic

13−Authentication and another protecting the same routes with a custom, in-house

14−authentication scheme.

15−

16−## Basic Authentication

17−

18−When protecting endpoints with basic authentication, we need to specify two

19−items:

20−

21−1. The **realm** of authentication as per the Basic Authentication spec.

22−2. The datatype returned by the server after authentication is verified. This

23−is usually a `User` or `Customer` datatype.

24−

25−With those two items in mind, *servant* provides the following combinator:

26−

27−``` haskell ignore

28−data BasicAuth (realm :: Symbol) (userData :: *)

29−```

30−

31−You can use this combinator to protect an API as follows:

32−

33−```haskell

34−{-# LANGUAGE DataKinds #-}

35−{-# LANGUAGE DeriveGeneric #-}

36−{-# LANGUAGE FlexibleContexts #-}

37−{-# LANGUAGE FlexibleInstances #-}

38−{-# LANGUAGE MultiParamTypeClasses #-}

39−{-# LANGUAGE OverloadedStrings #-}

40−{-# LANGUAGE ScopedTypeVariables #-}

41−{-# LANGUAGE TypeFamilies #-}

42−{-# LANGUAGE TypeOperators #-}

43−{-# LANGUAGE UndecidableInstances #-}

44−

45−module Authentication where

46−

47−import Data.Aeson (ToJSON)

48−import Data.ByteString (ByteString)

49−import Data.Map (Map, fromList)

50−import qualified Data.Map as Map

51−import Data.Proxy (Proxy (Proxy))

52−import Data.Text (Text)

53−import GHC.Generics (Generic)

54−import Network.Wai (Request, requestHeaders)

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

56−import Servant.API ((:<|>) ((:<|>)), (:>), BasicAuth,

57− Get, JSON)

58−import Servant.API.BasicAuth (BasicAuthData (BasicAuthData))

59−import Servant.API.Experimental.Auth (AuthProtect)

60−import Servant (throwError)

61−import Servant.Server (BasicAuthCheck (BasicAuthCheck),

62− BasicAuthResult( Authorized

63− , Unauthorized

64− ),

65− Context ((:.), EmptyContext),

66− err401, err403, errBody, Server,

67− serveWithContext, Handler)

68−import Servant.Server.Experimental.Auth (AuthHandler, AuthServerData,

69− mkAuthHandler)

70−import Servant.Server.Experimental.Auth()

71−import Web.Cookie (parseCookies)

72−

73−-- | private data that needs protection

74−newtype PrivateData = PrivateData { ssshhh :: Text }

75− deriving (Eq, Show, Generic)

76−

77−instance ToJSON PrivateData

78−

79−-- | public data that anyone can use.

80−newtype PublicData = PublicData { somedata :: Text }

81− deriving (Eq, Show, Generic)

82−

83−instance ToJSON PublicData

84−

85−-- | A user we'll grab from the database when we authenticate someone

86−newtype User = User { userName :: Text }

87− deriving (Eq, Show)

88−

89−-- | a type to wrap our public api

90−type PublicAPI = Get '[JSON] [PublicData]

91−

92−-- | a type to wrap our private api

93−type PrivateAPI = Get '[JSON] PrivateData

94−

95−-- | our API

96−type BasicAPI = "public" :> PublicAPI

97− :<|> "private" :> BasicAuth "foo-realm" User :> PrivateAPI

98−

99−-- | a value holding a proxy of our API type

100−basicAuthApi :: Proxy BasicAPI

101−basicAuthApi = Proxy

102−```

103−

104−You can see that we've prefixed our public API with "public" and our private

105−API with "private." Additionally, the private parts of our API use the

106−`BasicAuth` combinator to protect them under a Basic Authentication scheme (the

107−realm for this authentication is `"foo-realm"`).

108−

109−Unfortunately we're not done. When someone makes a request to our `"private"`

110−API, we're going to need to provide to servant the logic for validating

111−usernames and passwords. This adds a certain conceptual wrinkle in servant's

112−design that we'll briefly discuss. If you want the **TL;DR**: we supply a lookup

113−function to servant's new `Context` primitive.

114−

115−Until now, all of servant's API combinators extracted information from a request

116−or dictated the structure of a response (e.g. a `Capture` param is pulled from

117−the request path). Now consider an API resource protected by basic

118−authentication. Once the required `WWW-Authenticate` header is checked, we need

119−to verify the username and password. But how? One solution would be to force an

120−API author to provide a function of type `BasicAuthData -> Handler User`

121−and servant should use this function to authenticate a request. Unfortunately

122−this didn't work prior to `0.5` because all of servant's machinery was

123−engineered around the idea that each combinator can extract information from

124−only the request. We cannot extract the function

125−`BasicAuthData -> Handler User` from a request! Are we doomed?

126−

127−Servant `0.5` introduced `Context` to handle this. The type machinery is beyond

128−the scope of this tutorial, but the idea is simple: provide some data to the

129−`serve` function, and that data is propagated to the functions that handle each

130−combinator. Using `Context`, we can supply a function of type

131−`BasicAuthData -> Handler User` to the `BasicAuth` combinator

132−handler. This will allow the handler to check authentication and return a `User`

133−to downstream handlers if successful.

134−

135−In practice we wrap `BasicAuthData -> Handler User` into a slightly

136−different function to better capture the semantics of basic authentication:

137−

138−``` haskell ignore

139−-- | The result of authentication/authorization

140−data BasicAuthResult usr

141− = Unauthorized

142− | BadPassword

143− | NoSuchUser

144− | Authorized usr

145− deriving (Eq, Show, Read, Generic, Typeable, Functor)

146−

147−-- | Datatype wrapping a function used to check authentication.

148−newtype BasicAuthCheck usr = BasicAuthCheck

149− { unBasicAuthCheck :: BasicAuthData

150− -> IO (BasicAuthResult usr)

151− }

152− deriving (Generic, Typeable, Functor)

153−```

154−

155−We now use this datatype to supply servant with a method to authenticate

156−requests. In this simple example the only valid username and password is

157−`"servant"` and `"server"`, respectively, but in a real, production application

158−you might do some database lookup here.

159−

160−```haskell

161−-- | 'BasicAuthCheck' holds the handler we'll use to verify a username and password.

162−authCheck :: BasicAuthCheck User

163−authCheck =

164− let check (BasicAuthData username password) =

165− if username == "servant" && password == "server"

166− then return (Authorized (User "servant"))

167− else return Unauthorized

168− in BasicAuthCheck check

169−```

170−

171−And now we create the `Context` used by servant to find `BasicAuthCheck`:

172−

173−```haskell

174−-- | We need to supply our handlers with the right Context. In this case,

175−-- Basic Authentication requires a Context Entry with the 'BasicAuthCheck' value

176−-- tagged with "foo-tag" This context is then supplied to 'server' and threaded

177−-- to the BasicAuth HasServer handlers.

178−basicAuthServerContext :: Context (BasicAuthCheck User ': '[])

179−basicAuthServerContext = authCheck :. EmptyContext

180−```

181−

182−We're now ready to write our `server` method that will tie everything together:

183−

184−```haskell

185−-- | an implementation of our server. Here is where we pass all the handlers to our endpoints.

186−-- In particular, for the BasicAuth protected handler, we need to supply a function

187−-- that takes 'User' as an argument.

188−basicAuthServer :: Server BasicAPI

189−basicAuthServer =

190− let publicAPIHandler = return [PublicData "foo", PublicData "bar"]

191− privateAPIHandler (user :: User) = return (PrivateData (userName user))

192− in publicAPIHandler :<|> privateAPIHandler

193−```

194−

195−Finally, our main method and a sample session working with our server:

196−

197−```haskell

198−-- | hello, server!

199−basicAuthMain :: IO ()

200−basicAuthMain = run 8080 (serveWithContext basicAuthApi

201− basicAuthServerContext

202− basicAuthServer

203− )

204−

205−{- Sample session

206−

207−$ curl -XGET localhost:8080/public

208−[{"somedata":"foo"},{"somedata":"bar"}

209−

210−$ curl -iXGET localhost:8080/private

211−HTTP/1.1 401 Unauthorized

212−transfer-encoding: chunked

213−Date: Thu, 07 Jan 2016 22:36:38 GMT

214−Server: Warp/3.1.8

215−WWW-Authenticate: Basic realm="foo-realm"

216−

217−$ curl -iXGET localhost:8080/private -H "Authorization: Basic c2VydmFudDpzZXJ2ZXI="

218−HTTP/1.1 200 OK

219−transfer-encoding: chunked

220−Date: Thu, 07 Jan 2016 22:37:58 GMT

221−Server: Warp/3.1.8

222−Content-Type: application/json

223−{"ssshhh":"servant"}

224−-}

225−```

226−

227−## Generalized Authentication

228−

229−Sometimes your server's authentication scheme doesn't quite fit with the

230−standards (or perhaps servant hasn't rolled-out support for that new, fancy

231−authentication scheme). For such a scenario, servant `0.5` provides easy and

232−simple experimental support to roll your own authentication.

233−

234−Why experimental? We worked on the design for authentication for a long time. We

235−really struggled to find a nice, type-safe niche in the design space. In fact,

236−`Context` came out of this work, and while it really fit for schemes like Basic

237−and JWT, it wasn't enough to fully support something like OAuth or HMAC, which

238−have flows, roles, and other fancy ceremonies. Further, we weren't sure *how*

239−people will use auth.

240−

241−So, in typical startup fashion, we developed an MVP of 'generalized auth' and

242−released it in an experimental module, with the hope of getting feedback from you!

243−So, if you're reading this or using generalized auth support, please give us

244−your feedback!

245−

246−### What is Generalized Authentication?

247−

248−**TL;DR**: you throw a tagged `AuthProtect` combinator in front of the

249−endpoints you want protected and then supply a function `Request -> Handler a`,

250−where `a` is the type of your choice representing the data returned by

251−successful authentication - e.g., a `User` or, in our example below, `Account`.

252−This function is run anytime a request matches a protected endpoint. It

253−precisely solves the "I just need to protect these endpoints with a function

254−that does some complicated business logic" and nothing more. Behind the scenes

255−we use a type family instance (`AuthServerData`) and `Context` to accomplish

256−this.

257−

258−### Generalized Authentication in Action

259−

260−Let's implement a trivial authentication scheme. We will protect our API by

261−looking for a cookie named `"servant-auth-cookie"`. This cookie's value will

262−contain a key from which we can lookup an `Account`.

263−

264−```haskell

265−-- | An account type that we "fetch from the database" after

266−-- performing authentication

267−newtype Account = Account { unAccount :: Text }

268−

269−-- | A (pure) database mapping keys to accounts.

270−database :: Map ByteString Account

271−database = fromList [ ("key1", Account "Anne Briggs")

272− , ("key2", Account "Bruce Cockburn")

273− , ("key3", Account "Ghédalia Tazartès")

274− ]

275−

276−-- | A method that, when given a password, will return an Account.

277−-- This is our bespoke (and bad) authentication logic.

278−lookupAccount :: ByteString -> Handler Account

279−lookupAccount key = case Map.lookup key database of

280− Nothing -> throwError (err403 { errBody = "Invalid Cookie" })

281− Just usr -> return usr

282−```

283−

284−For generalized authentication, servant exposes the `AuthHandler` type,

285−which is used to wrap the `Request -> Handler Account` logic. Let's

286−create a value of type `AuthHandler Request Account` using the above `lookupAccount`

287−method (note: we depend upon [`cookie`](https://hackage.haskell.org/package/cookie)'s

288−`parseCookies` for this):

289−

290−```haskell

291−

292−--- | The auth handler wraps a function from Request -> Handler Account.

293−--- We look for a token in the request headers that we expect to be in the cookie.

294−--- The token is then passed to our `lookupAccount` function.

295−authHandler :: AuthHandler Request Account

296−authHandler = mkAuthHandler handler

297− where

298− maybeToEither e = maybe (Left e) Right

299− throw401 msg = throwError $ err401 { errBody = msg }

300− handler req = either throw401 lookupAccount $ do

301− cookie <- maybeToEither "Missing cookie header" $ lookup "cookie" $ requestHeaders req

302− maybeToEither "Missing token in cookie" $ lookup "servant-auth-cookie" $ parseCookies cookie

303−```

304−

305−Let's now protect our API with our new, bespoke authentication scheme. We'll

306−re-use the endpoints from our Basic Authentication example.

307−

308−```haskell

309−-- | Our API, with auth-protection

310−type AuthGenAPI = "private" :> AuthProtect "cookie-auth" :> PrivateAPI

311− :<|> "public" :> PublicAPI

312−

313−-- | A value holding our type-level API

314−genAuthAPI :: Proxy AuthGenAPI

315−genAuthAPI = Proxy

316−```

317−

318−Now we need to bring everything together for the server. We have the

319−`AuthHandler Request Account` value and an `AuthProtected` endpoint. To bind these

320−together, we need to provide a [Type Family](https://downloads.haskell.org/~ghc/8.8.1/docs/html/users_guide/glasgow_exts.html#type-families)

321−instance that tells the `HasServer` instance that our `Context` will supply a

322−`Account` (via `AuthHandler Request Account`) and that downstream combinators will

323−have access to this `Account` value (or an error will be thrown if authentication

324−fails).

325−

326−```haskell

327−

328−-- | We need to specify the data returned after authentication

329−type instance AuthServerData (AuthProtect "cookie-auth") = Account

330−```

331−

332−Note that we specify the type-level tag `"cookie-auth"` when defining the type

333−family instance. This allows us to have multiple authentication schemes

334−protecting a single API.

335−

336−We now construct the `Context` for our server, allowing us to instantiate a

337−value of type `Server AuthGenAPI`, in addition to the server value:

338−

339−```haskell

340−-- | The context that will be made available to request handlers. We supply the

341−-- "cookie-auth"-tagged request handler defined above, so that the 'HasServer' instance

342−-- of 'AuthProtect' can extract the handler and run it on the request.

343−genAuthServerContext :: Context (AuthHandler Request Account ': '[])

344−genAuthServerContext = authHandler :. EmptyContext

345−

346−-- | Our API, where we provide all the author-supplied handlers for each end

347−-- point. Note that 'privateDataFunc' is a function that takes 'Account' as an

348−-- argument. We don't worry about the authentication instrumentation here,

349−-- that is taken care of by supplying context

350−genAuthServer :: Server AuthGenAPI

351−genAuthServer =

352− let privateDataFunc (Account name) =

353− return (PrivateData ("this is a secret: " <> name))

354− publicData = return [PublicData "this is a public piece of data"]

355− in privateDataFunc :<|> publicData

356−```

357−

358−We're now ready to start our server (and provide a sample session)!

359−

360−```haskell

361−-- | run our server

362−genAuthMain :: IO ()

363−genAuthMain = run 8080 (serveWithContext genAuthAPI genAuthServerContext genAuthServer)

364−

365−{- Sample Session:

366−

367−$ curl -XGET localhost:8080/private

368−Missing auth header

369−

370−$ curl -XGET localhost:8080/private -H "Cookie: servant-auth-cookie=key3"

371−[{"ssshhh":"this is a secret: Ghédalia Tazartès"}]

372−

373−$ curl -XGET localhost:8080/private -H "Cookie: servant-auth-cookie=bad-key"

374−Invalid Cookie

375−

376−$ curl -XGET localhost:8080/public

377−[{"somedata":"this is a public piece of data"}]

378−-}

379−```

380−

381−### Recap

382−

383−Creating a generalized, ad-hoc authentication scheme was fairly straight

384−forward:

385−

386−1. use the `AuthProtect` combinator to protect your API.

387−2. choose an application-specific data type used by your server when

388−authentication is successful (in our case this was `Account`).

389−3. Create a value of `AuthHandler Request Account` which encapsulates the

390−authentication logic (`Request -> Handler Account`). This function

391−will be executed every time a request matches a protected route.

392−4. Provide an instance of the `AuthServerData` type family, specifying your

393−application-specific data type returned when authentication is successful (in

394−our case this was `Account`).

395−

396−Caveats:

397−

398−1. The module `Servant.Server.Experimental.Auth` contains an orphan `HasServer`

399−instance for the `AuthProtect` combinator. You may be get orphan instance

400−warnings when using this.

401−2. Generalized authentication requires the `UndecidableInstances` extension.

402−

403−## Client-side Authentication

404−

405−### Basic Authentication

406−

407−As of `0.5`, *servant-client* comes with support for basic authentication!

408−Endpoints protected by Basic Authentication will require a value of type

409−`BasicAuthData` to complete the request.

410−

411−You can find more comprehensive Basic Authentication example in the [Cookbook](../cookbook/basic-auth/BasicAuth.html).

412−

413−### Generalized Authentication

414−

415−Servant `0.5` also shipped with support for generalized authentication. Similar

416−to the server-side support, clients need to supply an instance of the

417−`AuthClientData` type family specifying the datatype the client will use to

418−marshal an unauthenticated request into an authenticated request. Generally,

419−this will look like:

420−

421−```haskell ignore

422−import Servant.Common.Req (Req, addHeader)

423−

424−-- | The datatype we'll use to authenticate a request. If we were wrapping

425−-- something like OAuth, this might be a Bearer token.

426−type instance AuthClientData (AuthProtect "cookie-auth") = String

427−

428−-- | A method to authenticate a request

429−authenticateReq :: String -> Req -> Req

430−authenticateReq s req = addHeader "my-bespoke-header" s req

431−```

432−

433−Now, if the client method for our protected endpoint was `getProtected`, then

434−we could perform authenticated requests as follows:

435−

436−```haskell ignore

437−-- | one could curry this to make it simpler to work with.

438−result = runExceptT (getProtected (mkAuthenticateReq "secret" authenticateReq))

439−```

doc/tutorial/Client.lhs+34−142

@@ -1,11 +1,12 @@

11# Querying an API

3−While defining handlers that [serve an API](Server.html) has a lot to it, querying an API is simpler: we do not care about what happens inside the webserver, we just need to know how to talk to it and get a response back. That said, we usually have to write the querying functions by hand because the structure of the API isn't a first class citizen and can't be inspected to generate the client-side functions.

3+While defining handlers that serve an API 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. Except that 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 a bunch of client-side functions.

5−**servant** however has a way to inspect APIs, because APIs are just Haskell types and (GHC) Haskell lets us do quite a few things with types. In the same way that we look at an API type to deduce the types the handlers should have, we can inspect the structure of the API to *derive* Haskell functions that take one argument for each occurrence of `Capture`, `ReqBody`, `QueryParam`

6−and friends (see [the tutorial introduction](ApiType.html) for an overview). By *derive*, we mean that there's no code generation involved - the functions are defined just by the structure of the API type.

5+*servant* however has a way to inspect API, 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 occurence of `Capture`, `ReqBody`, `QueryParam`

6+and friends. By *derive*, we mean that there's no code generation involved, the functions are defined just by the structure of the API type.

8−The source for this tutorial section is a literate Haskell file, so first we need to have some language extensions and imports:

8+The source for this tutorial section is a literate haskell file, so first we

9+need to have some language extensions and imports:

910

1011``` haskell

1112{-# LANGUAGE DataKinds #-}

@@ -14,23 +15,22 @@ The source for this tutorial section is a literate Haskell file, so first we nee

1415

1516module Client where

1617

18+import Control.Monad.Trans.Except

1719import Data.Aeson

1820import Data.Proxy

1921import GHC.Generics

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

22+import Network.HTTP.Client (Manager, newManager, defaultManagerSettings)

2123import Servant.API

2224import Servant.Client

23−import Servant.Types.SourceT (foreach)

24−

25−import qualified Servant.Client.Streaming as S

25+import System.IO.Unsafe

2626```

2727

2828Also, we need examples for some domain specific data types:

2929

3030``` haskell

3131data Position = Position

32− { xCoord :: Int

33− , yCoord :: Int

32+ { x :: Int

33+ , y :: Int

3434 } deriving (Show, Generic)

3535

3636instance FromJSON Position

@@ -67,48 +67,36 @@ type API = "position" :> Capture "x" Int :> Capture "y" Int :> Get '[JSON] Posit

6767 :<|> "marketing" :> ReqBody '[JSON] ClientInfo :> Post '[JSON] Email

6868```

6969

70−What we are going to get with **servant-client** here is three functions, one to query each endpoint:

70+What we are going to get with *servant-client* here is 3 functions, one to query each endpoint:

7171

7272``` haskell

7373position :: Int -- ^ value for "x"

7474 -> Int -- ^ value for "y"

75− -> ClientM Position

75+ -> ExceptT ServantError IO Position

7676

7777hello :: Maybe String -- ^ an optional value for "name"

78− -> ClientM HelloMessage

78+ -> ExceptT ServantError IO HelloMessage

7979

8080marketing :: ClientInfo -- ^ value for the request body

81− -> ClientM Email

81+ -> ExceptT ServantError IO Email

8282```

8383

84−Each function makes available as an argument any value that the response may

85−depend on, as evidenced in the API type. How do we get these functions? By calling

86−the function `client`. It takes one argument:

87−

88−- a `Proxy` to your API,

84+Each function makes available as an argument any value that the response may depend on, as evidenced in the API type. How do we get these functions? Just give a `Proxy` to your API and a host to make the requests to:

8985

9086``` haskell

9187api :: Proxy API

9288api = Proxy

9389

94−position :<|> hello :<|> marketing = client api

95−```

96−

97−`client api` returns client functions for our _entire_ API, combined with `:<|>`, which we can pattern match on as above. You could say `client` "calculates" the correct type and number of client functions for the API type it is given (via a `Proxy`), as well as their implementations.

98−

99−If you have an `EmptyAPI` in your API, servant-client will hand you a value of

100−type `EmptyClient` in the corresponding slot, where `data EmptyClient =

101−EmptyClient`, as a way to indicate that you can't do anything useful with it.

102−

103−``` haskell ignore

104−type API' = API :<|> EmptyAPI

105−

106−api' :: Proxy API'

107−api' = Proxy

90+{-# NOINLINE __manager #-}

91+__manager :: Manager

92+__manager = unsafePerformIO $ newManager defaultManagerSettings

10893

109−(position' :<|> hello' :<|> marketing') :<|> EmptyClient = client api'

94+position :<|> hello :<|> marketing =

95+ client api (BaseUrl Http "localhost" 8081 "") __manager

11096```

11197

98+As you can see in the code above, we just "pattern match our way" to these functions. If we try to derive less or more functions than there are endpoints in the API, we obviously get an error. The `BaseUrl` value there is just:

99+

112100``` haskell ignore

113101-- | URI scheme to use

114102data Scheme =

@@ -122,14 +110,13 @@ data BaseUrl = BaseUrl

122110 { baseUrlScheme :: Scheme -- ^ URI scheme to use

123111 , baseUrlHost :: String -- ^ host (eg "haskell.org")

124112 , baseUrlPort :: Int -- ^ port (eg 80)

125− , baseUrlPath :: String -- ^ path (eg "/a/b/c")

126113 }

127114```

128115

129116That's it. Let's now write some code that uses our client functions.

130117

131118``` haskell

132−queries :: ClientM (Position, HelloMessage, Email)

119+queries :: ExceptT ServantError IO (Position, HelloMessage, Email)

133120queries = do

134121 pos <- position 10 10

135122 message <- hello (Just "servant")

@@ -138,8 +125,7 @@ queries = do

138125

139126run :: IO ()

140127run = do

141− manager' <- newManager defaultManagerSettings

142− res <- runClientM queries (mkClientEnv manager' (BaseUrl Http "localhost" 8081 ""))

128+ res <- runExceptT queries

143129 case res of

144130 Left err -> putStrLn $ "Error: " ++ show err

145131 Right (pos, message, em) -> do

@@ -148,110 +134,16 @@ run = do

148134 print em

149135```

150136

151−Here's the output of the above code running against the appropriate server:

152−

153−```

154−Position {xCoord = 10, yCoord = 10}

155−HelloMessage {msg = "Hello, servant"}

156−Email {from = "great@company.com", to = "alp@foo.com", subject = "Hey Alp, we miss you!", body = "Hi Alp,\n\nSince you've recently turned 26, have you checked out our latest haskell, mathematics products? Give us a visit!"}

157−```

158−

159−The types of the arguments for the functions are the same as for (server-side) request handlers.

160−

161−## Changing the monad the client functions live in

162−

163−Just like `hoistServer` allows us to change the monad in which request handlers

164−of a web application live, we also have `hoistClient` for changing the monad

165−in which _client functions_ live. Consider the following trivial API:

166−

167−``` haskell

168−type HoistClientAPI = Get '[JSON] Int :<|> Capture "n" Int :> Post '[JSON] Int

169−

170−hoistClientAPI :: Proxy HoistClientAPI

171−hoistClientAPI = Proxy

172−```

173−

174−We already know how to derive client functions for this API, and as we have

175−seen above they all return results in the `ClientM` monad when using `servant-client`.

176−However, `ClientM` is rarely (or never) the actual monad we need to use the client

177−functions in. Sometimes we need to run them in IO, sometimes in a custom monad

178−stack. `hoistClient` is a very simple solution to the problem of "changing" the monad

179−the clients run in.

180−

181−``` haskell ignore

182−hoistClient

183− :: HasClient ClientM api -- we need a valid API

184− => Proxy api -- a Proxy to the API type

185− -> (forall a. m a -> n a) -- a "monad conversion function" (natural transformation)

186− -> Client m api -- clients in the source monad

187− -> Client n api -- result: clients in the target monad

188−```

189−

190−The "conversion function" argument above, just like the ones given to `hoistServer`, must

191−be able to turn an `m a` into an `n a` for any choice of type `a`.

192−

193−Let's see this in action on our example. We first derive our client functions as usual,

194−with all of them returning a result in `ClientM`.

195−

196−``` haskell

197−getIntClientM :: ClientM Int

198−postIntClientM :: Int -> ClientM Int

199−getIntClientM :<|> postIntClientM = client hoistClientAPI

200−```

201−

202−And we finally decide that we want the handlers to run in IO instead, by

203−"post-applying" `runClientM` to a fixed client environment.

137+You can now run `dist/build/tutorial/tutorial 8` (the server) and

138+`dist/build/t8-main/t8-main` (the client) to see them both in action.

204139

205−``` haskell

206−-- our conversion function has type: forall a. ClientM a -> IO a

207−-- the result has type:

208−-- Client IO HoistClientAPI = IO Int :<|> (Int -> IO Int)

209−getClients :: ClientEnv -> Client IO HoistClientAPI

210−getClients clientEnv

211− = hoistClient hoistClientAPI

212− ( fmap (either (error . show) id)

213− . flip runClientM clientEnv

214− )

215− (client hoistClientAPI)

216−```

217−

218−## Querying Streaming APIs.

219−

220−Consider the following streaming API type:

221−

222−``` haskell

223−type StreamAPI = "positionStream" :> StreamGet NewlineFraming JSON (SourceIO Position)

140+``` bash

141+ $ dist/build/tutorial/tutorial 8

142+ # and in another terminal:

143+ $ dist/build/t8-main/t8-main

144+ Position {x = 10, y = 10}

145+ HelloMessage {msg = "Hello, servant"}

146+ Email {from = "great@company.com", to = "alp@foo.com", subject = "Hey Alp, we miss you!", body = "Hi Alp,\n\nSince you've recently turned 26, have you checked out our latest haskell, mathematics products? Give us a visit!"}

224147```

225148

226−Note that we use the same `SourceIO` type as on the server-side

227−(this is different from `servant-0.14`).

228−However, we have to use different client, `Servant.Client.Streaming`,

229−which can stream (but has different API).

230−

231−In any case, here's how we write a function to query our API:

232−

233−```haskell

234−streamAPI :: Proxy StreamAPI

235−streamAPI = Proxy

236−

237−posStream :: S.ClientM (SourceIO Position)

238−posStream = S.client streamAPI

239−```

240−

241−We'll get back a `SourceIO Position`. Instead of `runClientM`, the streaming

242−client provides `withClientM`: the underlying HTTP connection is open only

243−until the inner functions exits. Inside the block we can e.g just print out

244−all elements from a `SourceIO`, to give some idea of how to work with them.

245−

246−``` haskell

247−printSourceIO :: Show a => ClientEnv -> S.ClientM (SourceIO a) -> IO ()

248−printSourceIO env c = S.withClientM c env $ \e -> case e of

249− Left err -> putStrLn $ "Error: " ++ show err

250− Right rs -> foreach fail print rs

251−```

252−

253−The stream is parsed and provided incrementally. So the above loop prints out

254−each result as soon as it is received on the stream, rather than waiting until

255−they are all available to print them at once.

256−

257−You now know how to use **servant-client**!

149+The types of the arguments for the functions are the same as for (server-side) request handlers. You now know how to use *servant-client*!

doc/tutorial/Docs.lhs+72−114

@@ -23,11 +23,10 @@ import Network.Wai

2323import Servant.API

2424import Servant.Docs

2525import Servant.Server

26−import Web.FormUrlEncoded(FromForm(..), ToForm(..))

2726```

2827

2928And we'll import some things from one of our earlier modules

30−([Serving an API](Server.html)):

29+([Serving an API](/tutorial/server.html)):

3130

3231``` haskell

3332import Server (Email(..), ClientInfo(..), Position(..), HelloMessage(..),

@@ -36,7 +35,7 @@ import Server (Email(..), ClientInfo(..), Position(..), HelloMessage(..),

3635

3736Like client function generation, documentation generation amounts to inspecting the API type and extracting all the data we need to then present it in some format to users of your API.

3837

39−This time however, we have to assist **servant**. While it is able to deduce a lot of things about our API, it can't magically come up with descriptions of the various pieces of our APIs that are human-friendly and explain what's going on "at the business-logic level". A good example to study for documentation generation is our webservice with the `/position`, `/hello` and `/marketing` endpoints from earlier:

38+This time however, we have to assist *servant*. While it is able to deduce a lot of things about our API, it can't magically come up with descriptions of the various pieces of our APIs that are human-friendly and explain what's going on "at the business-logic level". A good example to study for documentation generation is our webservice with the `/position`, `/hello` and `/marketing` endpoints from earlier:

4039

4140``` haskell

4241type ExampleAPI = "position" :> Capture "x" Int :> Capture "y" Int :> Get '[JSON] Position

@@ -47,7 +46,7 @@ exampleAPI :: Proxy ExampleAPI

4746exampleAPI = Proxy

4847```

4948

50−While **servant** can see e.g. that there are 3 endpoints and that the response bodies will be in JSON, it doesn't know what influence the captures, parameters, request bodies and other combinators have on the webservice. This is where some manual work is required.

49+While *servant* can see e.g. that there are 3 endpoints and that the response bodies will be in JSON, it doesn't know what influence the captures, parameters, request bodies and other combinators have on the webservice. This is where some manual work is required.

5150

5251For every capture, request body, response body, query param, we have to give some explanations about how it influences the response, what values are possible and the likes. Here's how it looks like for the parameters we have above.

5352

@@ -77,7 +76,7 @@ instance ToSample HelloMessage where

7776 [ ("When a value is provided for 'name'", HelloMessage "Hello, Alp")

7877 , ("When 'name' is not specified", HelloMessage "Hello, anonymous coward")

7978 ]

80− -- multiple examples to display this time

79+ -- mutliple examples to display this time

8180

8281ci :: ClientInfo

8382ci = ClientInfo "Alp" "alp@foo.com" 26 ["haskell", "mathematics"]

@@ -90,8 +89,6 @@ instance ToSample Email where

9089```

9190

9291Types that are used as request or response bodies have to instantiate the `ToSample` typeclass which lets you specify one or more examples of values. `Capture`s and `QueryParam`s have to instantiate their respective `ToCapture` and `ToParam` classes and provide a name and some information about the concrete meaning of that argument, as illustrated in the code above.

93−The `EmptyAPI` combinator needs no special treatment as it generates no

94−documentation: an empty API has no endpoints to document.

9592

9693With all of this, we can derive docs for our API.

9794

@@ -100,105 +97,107 @@ apiDocs :: API

10097apiDocs = docs exampleAPI

10198```

10299

103−`API` is a type provided by **servant-docs** that stores all the information one needs about a web API in order to generate documentation in some format. Out of the box, **servant-docs** only provides a pretty documentation printer that outputs [Markdown](http://en.wikipedia.org/wiki/Markdown), but the [**servant-pandoc**](http://hackage.haskell.org/package/servant-pandoc) package can be used to target many useful formats.

100+`API` is a type provided by *servant-docs* that stores all the information one needs about a web API in order to generate documentation in some format. Out of the box, *servant-docs* only provides a pretty documentation printer that outputs [Markdown](http://en.wikipedia.org/wiki/Markdown), but the [servant-pandoc](http://hackage.haskell.org/package/servant-pandoc) package can be used to target many useful formats.

104101

105−**servant**'s markdown pretty printer is a function named `markdown`.

102+*servant*'s markdown pretty printer is a function named `markdown`.

106103

107104``` haskell ignore

108105markdown :: API -> String

109106```

110107

111−That lets us see what our API docs look like in markdown, by looking at `markdown apiDocs`.

108+That lets us see what our API docs look down in markdown, by looking at `markdown apiDocs`.

112109

113−````````` text

114−## GET /hello

110+``` text

111+ ## Welcome

115112

116−#### GET Parameters:

113+ This is our super webservice's API.

117114

118−- name

119− - **Values**: *Alp, John Doe, ...*

120− - **Description**: Name of the person to say hello to.

115+ Enjoy!

121116

117+ ## GET /hello

122118

123−#### Response:

119+ #### GET Parameters:

124120

125−- Status code 200

126−- Headers: []

121+ - name

122+ - **Values**: *Alp, John Doe, ...*

123+ - **Description**: Name of the person to say hello to.

127124

128−- Supported content types are:

129125

130− - `application/json;charset=utf-8`

131− - `application/json`

126+ #### Response:

132127

133−- When a value is provided for 'name' (`application/json;charset=utf-8`, `application/json`):

128+ - Status code 200

129+ - Headers: []

134130

135− ```javascript

136−{"msg":"Hello, Alp"}

137− ```

131+ - Supported content types are:

138132

139−- When 'name' is not specified (`application/json;charset=utf-8`, `application/json`):

133+ - `application/json`

140134

141− ```javascript

142−{"msg":"Hello, anonymous coward"}

143− ```

135+ - When a value is provided for 'name'

144136

145−## POST /marketing

137+ ```javascript

138+ {"msg":"Hello, Alp"}

139+ ```

146140

147−#### Request:

141+ - When 'name' is not specified

148142

149−- Supported content types are:

143+ ```javascript

144+ {"msg":"Hello, anonymous coward"}

145+ ```

150146

151− - `application/json;charset=utf-8`

152− - `application/json`

147+ ## POST /marketing

153148

154−- Example (`application/json;charset=utf-8`, `application/json`):

149+ #### Request:

155150

156− ```javascript

157−{"clientAge":26,"clientEmail":"alp@foo.com","clientName":"Alp","clientInterestedIn":["haskell","mathematics"]}

158− ```

151+ - Supported content types are:

159152

160−#### Response:

153+ - `application/json`

161154

162−- Status code 200

163−- Headers: []

155+ - Example: `application/json`

164156

165−- Supported content types are:

157+ ```javascript

158+ {"email":"alp@foo.com","interested_in":["haskell","mathematics"],"age":26,"name":"Alp"}

159+ ```

166160

167− - `application/json;charset=utf-8`

168− - `application/json`

161+ #### Response:

169162

170−- Example (`application/json;charset=utf-8`, `application/json`):

163+ - Status code 201

164+ - Headers: []

171165

172− ```javascript

173−{"subject":"Hey Alp, we miss you!","body":"Hi Alp,\n\nSince you've recently turned 26, have you checked out our latest haskell, mathematics products? Give us a visit!","to":"alp@foo.com","from":"great@company.com"}

174− ```

166+ - Supported content types are:

175167

176−## GET /position/:x/:y

168+ - `application/json`

177169

178−#### Captures:

170+ - Response body as below.

179171

180−- *x*: (integer) position on the x axis

181−- *y*: (integer) position on the y axis

172+ ```javascript

173+ {"subject":"Hey Alp, we miss you!","body":"Hi Alp,\n\nSince you've recently turned 26, have you checked out our latest haskell, mathematics products? Give us a visit!","to":"alp@foo.com","from":"great@company.com"}

174+ ```

182175

183−#### Response:

176+ ## GET /position/:x/:y

184177

185−- Status code 200

186−- Headers: []

178+ #### Captures:

187179

188−- Supported content types are:

180+ - *x*: (integer) position on the x axis

181+ - *y*: (integer) position on the y axis

189182

190− - `application/json;charset=utf-8`

191− - `application/json`

183+ #### Response:

192184

193−- Example (`application/json;charset=utf-8`, `application/json`):

185+ - Status code 200

186+ - Headers: []

194187

195− ```javascript

196−{"yCoord":14,"xCoord":3}

197− ````

188+ - Supported content types are:

198189

199−`````````

190+ - `application/json`

200191

201−However, we can also add one or more introduction sections to the document. We just need to tweak the way we generate `apiDocs`. We will also convert the content to a lazy `ByteString` since this is what **wai** expects for `Raw` endpoints.

192+ - Response body as below.

193+

194+ ```javascript

195+ {"x":3,"y":14}

196+ ```

197+

198+```

199+

200+However, we can also add one or more introduction sections to the document. We just need to tweak the way we generate `apiDocs`. We will also convert the content to a lazy `ByteString` since this is what *wai* expects for `Raw` endpoints.

202201

203202``` haskell

204203docsBS :: ByteString

@@ -212,49 +211,6 @@ docsBS = encodeUtf8

212211

213212`docsWithIntros` just takes an additional parameter, a list of `DocIntro`s that must be displayed before any endpoint docs.

214213

215−More customisation can be done with the `markdownWith` function, which allows customising some of the parameters used when generating Markdown. The most obvious of these is how to handle when a request or response body has multiple content types. For example, if we make a slight change to the `/marketing` endpoint of our API so that the request body can also be encoded as a form:

216−

217−``` haskell

218−type ExampleAPI2 = "position" :> Capture "x" Int :> Capture "y" Int :> Get '[JSON] Position

219− :<|> "hello" :> QueryParam "name" String :> Get '[JSON] HelloMessage

220− :<|> "marketing" :> ReqBody '[JSON, FormUrlEncoded] ClientInfo :> Post '[JSON] Email

221−

222−instance ToForm ClientInfo

223−instance FromForm ClientInfo

224−

225−exampleAPI2 :: Proxy ExampleAPI2

226−exampleAPI2 = Proxy

227−

228−api2Docs :: API

229−api2Docs = docs exampleAPI2

230−```

231−

232−The relevant output of `markdown api2Docs` is now:

233−

234−```````` text

235−#### Request:

236−

237−- Supported content types are:

238−

239− - `application/json;charset=utf-8`

240− - `application/json`

241− - `application/x-www-form-urlencoded`

242−

243−- Example (`application/json;charset=utf-8`, `application/json`):

244−

245− ```javascript

246−{"clientAge":26,"clientEmail":"alp@foo.com","clientName":"Alp","clientInterestedIn":["haskell","mathematics"]}

247− ```

248−

249−- Example (`application/x-www-form-urlencoded`):

250−

251− ```

252−clientAge=26&clientEmail=alp%40foo.com&clientName=Alp&clientInterestedIn=haskell&clientInterestedIn=mathematics

253− ```

254−````````

255−

256−If, however, you don't want the extra example encoding shown, then you can use `markdownWith (defRenderingOptions & requestExamples .~ FirstContentType)` to get behaviour identical to `markdown apiDocs`.

257−

258214We can now serve the API *and* the API docs with a simple server.

259215

260216``` haskell

@@ -264,13 +220,15 @@ api :: Proxy DocsAPI

264220api = Proxy

265221

266222server :: Server DocsAPI

267−server = Server.server3 :<|> Tagged serveDocs where

268− serveDocs _ respond =

269− respond $ responseLBS ok200 [plain] docsBS

270− plain = ("Content-Type", "text/plain")

223+server = Server.server3 :<|> serveDocs

224+

225+ where serveDocs _ respond =

226+ respond $ responseLBS ok200 [plain] docsBS

227+

228+ plain = ("Content-Type", "text/plain")

271229

272230app :: Application

273−app = serve api server

231+app = serve api EmptyConfig server

274232```

275233

276−And if you spin up this server and request anything else than `/position`, `/hello` and `/marketing`, you will see the API docs in markdown. This is because `serveDocs` is attempted if the 3 other endpoints don't match and systematically succeeds since its definition is to just return some fixed bytestring with the `text/plain` content type.

234+And if you spin up this server with `dist/build/tutorial/tutorial 10` and go to anywhere else than `/position`, `/hello` and `/marketing`, you will see the API docs in markdown. This is because `serveDocs` is attempted if the 3 other endpoints don't match and systematically succeeds since its definition is to just return some fixed bytestring with the `text/plain` content type.

doc/tutorial/Javascript.lhs+23−359

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

11# Generating Javascript functions to query an API

3−We will now see how **servant** lets you turn an API type into javascript

4−functions that you can call to query a webservice.

3+We will now see how *servant* lets you turn an API type into javascript

4+functions that you can call to query a webservice. The derived code assumes you

5+use *jQuery* but you could very easily adapt the code to generate ajax requests

6+based on vanilla javascript or another library than *jQuery*.

68For this, we will consider a simple page divided in two parts. At the top, we

79will have a search box that lets us search in a list of Haskell books by

@@ -30,11 +32,10 @@ import Data.Aeson

3032import Data.Proxy

3133import Data.Text as T (Text)

3234import Data.Text.IO as T (writeFile, readFile)

35+import qualified Data.Text as T

3336import GHC.Generics

3437import Language.Javascript.JQuery

3538import Network.Wai

36−import Network.Wai.Handler.Warp

37−import qualified Data.Text as T

3839import Servant

3940import Servant.JS

4041import System.Random

@@ -77,8 +78,7 @@ book :: Text -> Text -> Int -> Book

7778book = Book

7879```

7980

80−We need a "book database". For the purpose of this guide, let's restrict

81−ourselves to the following books.

81+We need a "book database". For the purpose of this guide, let's restrict ourselves to the following books.

8282

8383``` haskell

8484books :: [Book]

@@ -92,10 +92,7 @@ books =

9292 ]

9393```

9494

95−Now, given an optional search string `q`, we want to perform a case insensitive

96−search in that list of books. We're obviously not going to try and implement

97−the best possible algorithm, this is out of scope for this tutorial. The

98−following simple linear scan will do, given how small our list is.

95+Now, given an optional search string `q`, we want to perform a case insensitive search in that list of books. We're obviously not going to try and implement the best possible algorithm, this is out of scope for this tutorial. The following simple linear scan will do, given how small our list is.

9996

10097``` haskell

10198searchBook :: Monad m => Maybe Text -> m (Search Book)

@@ -109,9 +106,7 @@ searchBook (Just q) = return (mkSearch q books')

109106 q' = T.toLower q

110107```

111108

112−We also need an endpoint that generates random points `(x, y)` with `-1 <= x,y

113−<= 1`. The code below uses

114−[random](http://hackage.haskell.org/package/random)'s `System.Random`.

109+We also need an endpoint that generates random points `(x, y)` with `-1 <= x,y <= 1`. The code below uses [random](http://hackage.haskell.org/package/random)'s `System.Random`.

115110

116111``` haskell

117112randomPoint :: MonadIO m => m Point

@@ -136,385 +131,54 @@ server = randomPoint

136131

137132server' :: Server API'

138133server' = server

139− :<|> serveDirectoryFileServer "static"

134+ :<|> serveDirectory "tutorial/t9"

140135

141136app :: Application

142−app = serve api' server'

143−

144−main :: IO ()

145−main = run 8000 app

137+app = serve api' EmptyConfig server'

146138```

147139

148−Why two different API types, proxies and servers though? Simply because we

149−don't want to generate javascript functions for the `Raw` part of our API type,

150−so we need a `Proxy` for our API type `API'` without its `Raw` endpoint.

140+Why two different API types, proxies and servers though? Simply because we don't want to generate javascript functions for the `Raw` part of our API type, so we need a `Proxy` for our API type `API'` without its `Raw` endpoint.

151141

152−The `EmptyAPI` combinator needs no special treatment as it generates no

153−Javascript functions: an empty API has no endpoints to access.

154−

155−Very similarly to how one can derive haskell functions, we can derive the

156−javascript with just a simple function call to `jsForAPI` from

157−`Servant.JS`.

142+Very similarly to how one can derive haskell functions, we can derive the javascript with just a simple function call to `jsForAPI` from `Servant.JQuery`.

158143

159144``` haskell

160−apiJS1 :: Text

161−apiJS1 = jsForAPI api jquery

145+apiJS :: Text

146+apiJS = jsForAPI api vanillaJS

162147```

163148

164−This `Text` contains 2 Javascript functions, 'getPoint' and 'getBooks':

149+This `String` contains 2 Javascript functions:

165150

166151``` javascript

167152

168−var getPoint = function(onSuccess, onError)

153+function getpoint(onSuccess, onError)

169154{

170155 $.ajax(

171156 { url: '/point'

172157 , success: onSuccess

173158 , error: onError

174− , type: 'GET'

159+ , method: 'GET'

175160 });

176161}

177162

178−var getBooks = function(q, onSuccess, onError)

163+function getbooks(q, onSuccess, onError)

179164{

180165 $.ajax(

181166 { url: '/books' + '?q=' + encodeURIComponent(q)

182167 , success: onSuccess

183168 , error: onError

184− , type: 'GET'

169+ , method: 'GET'

185170 });

186171}

187172```

188173

189−We created a directory `static` that contains two static files: `index.html`,

190−which is the entrypoint to our little web application; and `ui.js`, which

191−contains some hand-written javascript. This javascript code assumes the two

192−generated functions `getPoint` and `getBooks` in scope. Therefore we need to

193−write the generated javascript into a file:

174+Right before starting up our server, we will need to write this `String` to a file, say `api.js`, along with a copy of the *jQuery* library, as provided by the [js-jquery](http://hackage.haskell.org/package/js-jquery) package.

194175

195176``` haskell

196177writeJSFiles :: IO ()

197178writeJSFiles = do

198− T.writeFile "static/api.js" apiJS1

179+ T.writeFile "getting-started/gs9/api.js" apiJS

199180 jq <- T.readFile =<< Language.Javascript.JQuery.file

200− T.writeFile "static/jq.js" jq

201−```

202−

203−(We're also writing the jquery library into a file, as it's also used by

204−`ui.js`.) `static/api.js` will be included in `index.html` and the two

205−generated functions will therefore be available in `ui.js`.

206−

207−And we're good to go. You can start the `main` function of this file and go to

208−`http://localhost:8000/`. Start typing in the name of one of the authors in our

209−database or part of a book title, and check out how long it takes to

210−approximate pi using the method mentioned above.

211−

212−## Customizations

213−

214−Instead of calling `jquery`, you can call its variant `jqueryWith`.

215−Here are the type definitions

216−

217−```haskell ignore

218−jquery :: JavaScriptGenerator

219−jqueryWith :: CommonGeneratorOptions -> JavaScriptGenerator

220−```

221−

222−The `CommonGeneratorOptions` will let you define different behaviors to

223−change how functions are generated. Here is the definition of currently

224−available options:

225−

226−```haskell ignore

227−data CommonGeneratorOptions = CommonGeneratorOptions

228− {

229− -- | function generating function names

230− functionNameBuilder :: FunctionName -> Text

231− -- | name used when a user wants to send the request body (to let you redefine it)

232− , requestBody :: Text

233− -- | name of the callback parameter when the request was successful

234− , successCallback :: Text

235− -- | name of the callback parameter when the request reported an error

236− , errorCallback :: Text

237− -- | namespace on which we define the js function (empty means local var)

238− , moduleName :: Text

239− -- | a prefix that should be prepended to the URL in the generated JS

240− , urlPrefix :: Text

241− }

242−```

243−

244−This pattern is available with all supported backends, and default values are provided.

245−

246−## Vanilla support

247−

248−If you don't use JQuery for your application, you can reduce your

249−dependencies to simply use the `XMLHttpRequest` object from the standard API.

250−

251−Use the same code as before but simply replace the previous `apiJS` with

252−the following one:

253−

254−``` haskell

255−apiJS2 :: Text

256−apiJS2 = jsForAPI api vanillaJS

257−```

258−

259−The rest is *completely* unchanged.

260−

261−The output file is a bit different, but it has the same parameters,

262−

263−``` javascript

264−

265−

266−var getPoint = function(onSuccess, onError)

267−{

268− var xhr = new XMLHttpRequest();

269− xhr.open('GET', '/point', true);

270− xhr.setRequestHeader(\"Accept\",\"application/json\");

271− xhr.onreadystatechange = function (e) {

272− if (xhr.readyState == 4) {

273− if (xhr.status == 204 || xhr.status == 205) {

274− onSuccess();

275− } else if (xhr.status >= 200 && xhr.status < 300) {

276− var value = JSON.parse(xhr.responseText);

277− onSuccess(value);

278− } else {

279− var value = JSON.parse(xhr.responseText);

280− onError(value);

281− }

282− }

283− }

284− xhr.send(null);

285−}

286−

287−var getBooks = function(q, onSuccess, onError)

288−{

289− var xhr = new XMLHttpRequest();

290− xhr.open('GET', '/books' + '?q=' + encodeURIComponent(q), true);

291− xhr.setRequestHeader(\"Accept\",\"application/json\");

292− xhr.onreadystatechange = function (e) {

293− if (xhr.readyState == 4) {

294− if (xhr.status == 204 || xhr.status == 205) {

295− onSuccess();

296− } else if (xhr.status >= 200 && xhr.status < 300) {

297− var value = JSON.parse(xhr.responseText);

298− onSuccess(value);

299− } else {

300− var value = JSON.parse(xhr.responseText);

301− onError(value);

302− }

303− }

304− }

305− xhr.send(null);

306−}

307−

308−

309−```

310−

311−And that's all, your web service can of course be accessible from those

312−two clients at the same time!

313−

314−## Axios support

315−

316−### Simple usage

317−

318−If you use Axios library for your application, we support that too!

319−

320−Use the same code as before but simply replace the previous `apiJS` with

321−the following one:

322−

323−``` haskell

324−apiJS3 :: Text

325−apiJS3 = jsForAPI api $ axios defAxiosOptions

326−```

327−

328−The rest is *completely* unchanged.

329−

330−The output file is a bit different,

331−

332−``` javascript

333−

334−

335−var getPoint = function()

336−{

337− return axios({ url: '/point'

338− , method: 'get'

339− });

340−}

341−

342−

343−

344−var getBooks = function(q)

345−{

346− return axios({ url: '/books' + '?q=' + encodeURIComponent(q)

347− , method: 'get'

348− });

349−}

350−

351−```

352−

353−**Caution:** In order to support the promise style of the API, there are no onSuccess

354−nor onError callback functions.

355−

356−### Defining Axios configuration

357−

358−Axios lets you define a 'configuration' to determine the behavior of the

359−program when the AJAX request is sent.

360−

361−We mapped this into a configuration

362−

363−``` haskell

364−data AxiosOptions = AxiosOptions

365− { -- | indicates whether or not cross-site Access-Control requests

366− -- should be made using credentials

367− withCredentials :: !Bool

368− -- | the name of the cookie to use as a value for xsrf token

369− , xsrfCookieName :: !(Maybe Text)

370− -- | the name of the header to use as a value for xsrf token

371− , xsrfHeaderName :: !(Maybe Text)

372− }

373−```

374−

375−## Angular support

376−

377−### Simple usage

378−

379−You can apply the same procedure as with `vanillaJS` and `jquery`, and

380−generate top level functions.

381−

382−The difference is that `angular` Generator always takes an argument.

383−

384−``` haskell

385−apiJS4 :: Text

386−apiJS4 = jsForAPI api $ angular defAngularOptions

387−```

388−

389−The generated code will be a bit different than previous generators. An extra

390−argument `$http` will be added to let Angular magical Dependency Injector

391−operate.

392−

393−**Caution:** In order to support the promise style of the API, there are no onSuccess

394−nor onError callback functions.

395−

396−``` javascript

397−

398−

399−var getPoint = function($http)

400−{

401− return $http(

402− { url: '/point'

403− , method: 'GET'

404− });

405−}

406−

407−

408−

409−var getBooks = function($http, q)

410−{

411− return $http(

412− { url: '/books' + '?q=' + encodeURIComponent(q)

413− , method: 'GET'

414− });

415−}

416−

417−```

418−

419−You can then build your controllers easily

420−

421−``` javascript

422−

423−app.controller("MyController", function($http) {

424− this.getPoint = getPoint($http)

425− .success(/* Do something */)

426− .error(/* Report error */);

427−

428− this.getPoint = getBooks($http, q)

429− .success(/* Do something */)

430− .error(/* Report error */);

431−});

181+ T.writeFile "getting-started/gs9/jq.js" jq

432182```

433183

434−### Service generator

435−

436−You can also generate automatically a service to wrap the whole API as

437−a single Angular service:

438−

439−``` javascript

440−app.service('MyService', function($http) {

441− return ({

442− postCounter: function()

443− {

444− return $http(

445− { url: '/counter'

446− , method: 'POST'

447− });

448− },

449− getCounter: function()

450− {

451− return $http(

452− { url: '/books' + '?q=' + encodeURIComponent(q), true);

453− , method: 'GET'

454− });

455− }

456− });

457−});

458−```

459−

460−To do so, you just have to use an alternate generator.

461−

462−``` haskell

463−apiJS5 :: Text

464−apiJS5 = jsForAPI api $ angularService defAngularOptions

465−```

466−

467−Again, it is possible to customize some portions with the options.

468−

469−``` haskell

470−data AngularOptions = AngularOptions

471− { -- | When generating code with wrapInService, name of the service to generate, default is 'app'

472− serviceName :: Text

473− , -- | beginning of the service definition

474− prologue :: Text -> Text -> Text

475− , -- | end of the service definition

476− epilogue :: Text

477− }

478−```

479−

480−## Custom function name builder

481−

482−Servant comes with three name builders included:

483−

484−- camelCase (the default)

485−- concatCase

486−- snakeCase

487−

488−Keeping the JQuery as an example, let's see the impact:

489−

490−``` haskell

491−apiJS6 :: Text

492−apiJS6 = jsForAPI api $ jqueryWith defCommonGeneratorOptions { functionNameBuilder= snakeCase }

493−```

494−

495−This `Text` contains 2 Javascript functions:

496−

497−``` javascript

498−

499−

500−var get_point = function(onSuccess, onError)

501−{

502− $.ajax(

503− { url: '/point'

504− , success: onSuccess

505− , error: onError

506− , type: 'GET'

507− });

508−}

509−

510−var get_books = function(q, onSuccess, onError)

511−{

512− $.ajax(

513− { url: '/books' + '?q=' + encodeURIComponent(q)

514− , success: onSuccess

515− , error: onError

516− , type: 'GET'

517− });

518−}

519−

520−```

184+And we're good to go. Start the server with `dist/build/tutorial/tutorial 9` and go to `http://localhost:8081/`. Start typing in the name of one of the authors in our database or part of a book title, and check out how long it takes to approximate π using the method mentioned above.

doc/tutorial/Server.lhs+348−320

@@ -5,7 +5,7 @@ type. Can we have a webservice already?

66## A first example

8−Equipped with some basic knowledge about the way we represent APIs, let's now

8+Equipped with some basic knowledge about the way we represent API, let's now

99write our first webservice.

1010

1111The source for this tutorial section is a literate haskell file, so first we

@@ -18,7 +18,6 @@ need to have some language extensions and imports:

1818{-# LANGUAGE GeneralizedNewtypeDeriving #-}

1919{-# LANGUAGE MultiParamTypeClasses #-}

2020{-# LANGUAGE OverloadedStrings #-}

21−{-# LANGUAGE RankNTypes #-}

2221{-# LANGUAGE ScopedTypeVariables #-}

2322{-# LANGUAGE TypeOperators #-}

2423

@@ -27,14 +26,14 @@ module Server where

2726import Prelude ()

2827import Prelude.Compat

2928

30−import Control.Monad.Except

29+import Control.Monad.IO.Class

3130import Control.Monad.Reader

32−import Data.Aeson

31+import Control.Monad.Trans.Except

32+import Data.Aeson.Compat

3333import Data.Aeson.Types

3434import Data.Attoparsec.ByteString

3535import Data.ByteString (ByteString)

3636import Data.List

37−import Data.Maybe

3837import Data.String.Conversions

3938import Data.Time.Calendar

4039import GHC.Generics

@@ -46,17 +45,20 @@ import Servant

4645import System.Directory

4746import Text.Blaze

4847import Text.Blaze.Html.Renderer.Utf8

49−import Servant.Types.SourceT (source)

5048import qualified Data.Aeson.Parser

5149import qualified Text.Blaze.Html

5250```

5351

54−**Important**: the `Servant` module comes from the **servant-server** package,

52+``` haskell ignore

53+{-# LANGUAGE TypeFamilies #-}

54+```

55+

56+**Important**: the `Servant` module comes from the *servant-server* package,

5557the one that lets us run webservers that implement a particular API type. It

56−reexports all the types from the **servant** package that let you declare API

58+reexports all the types from the *servant* package that let you declare API

5759types as well as everything you need to turn your request handlers into a

5860fully-fledged webserver. This means that in your applications, you can just add

59−**servant-server** as a dependency, import `Servant` and not worry about anything

61+*servant-server* as a dependency, import `Servant` and not worry about anything

6062else.

6163

6264We will write a server that will serve the following API.

@@ -96,6 +98,12 @@ users1 =

9698 ]

9799```

98100

101+Let's also write our API type.

102+

103+``` haskell ignore

104+type UserAPI1 = "users" :> Get '[JSON] [User]

105+```

106+

99107We can now take care of writing the actual webservice that will handle requests

100108to such an API. This one will be very simple, being reduced to just a single

101109endpoint. The type of the web application is determined by the API type,

@@ -107,11 +115,11 @@ corresponding API type.

107115The first thing to know about the `Server` type family is that behind the

108116scenes it will drive the routing, letting you focus only on the business

109117logic. The second thing to know is that for each endpoint, your handlers will

110−by default run in the `Handler` monad. This is overridable very

118+by default run in the `ExceptT ServantErr IO` monad. This is overridable very

111119easily, as explained near the end of this guide. Third thing, the type of the

112120value returned in that monad must be the same as the second argument of the

113121HTTP method combinator used for the corresponding endpoint. In our case, it

114−means we must provide a handler of type `Handler [User]`. Well,

122+means we must provide a handler of type `ExceptT ServantErr IO [User]`. Well,

115123we have a monad, let's just `return` our list:

116124

117125``` haskell

@@ -146,8 +154,9 @@ main = run 8081 app1

146154

147155You can put this all into a file or just grab [servant's

148156repo](http://github.com/haskell-servant/servant) and look at the

149−*doc/tutorial* directory. This code (the source of this web page) is in

150−*doc/tutorial/Server.lhs*.

157+*servant-examples* directory. The code we have just explored is in

158+*tutorial/T1.hs*, runnable with

159+`dist/build/tutorial/tutorial 1`.

151160

152161If you run it, you can go to `http://localhost:8081/users` in your browser or

153162query it with curl and you see:

@@ -183,7 +192,7 @@ users2 = [isaac, albert]

183192

184193Now, just like we separate the various endpoints in `UserAPI` with `:<|>`, we

185194are going to separate the handlers with `:<|>` too! They must be provided in

186−the same order as in the API type.

195+the same order as the one they appear in in the API type.

187196

188197``` haskell

189198server2 :: Server UserAPI2

@@ -192,14 +201,15 @@ server2 = return users2

192201 :<|> return isaac

193202```

194203

195−And that's it! You can run this example in the same way that we showed for

196−`server1` and check out the data available at `/users`, `/albert` and `/isaac`.

204+And that's it! You can run this example with

205+`dist/build/tutorial/tutorial 2` and check out the data available

206+at `/users`, `/albert` and `/isaac`.

197207

198208## From combinators to handler arguments

199209

200210Fine, we can write trivial webservices easily, but none of the two above use

201211any "fancy" combinator from servant. Let's address this and use `QueryParam`,

202−`Capture` and `ReqBody` right away. You'll see how each occurrence of these

212+`Capture` and `ReqBody` right away. You'll see how each occurence of these

203213combinators in an endpoint makes the corresponding handler receive an

204214argument of the appropriate type automatically. You don't have to worry about

205215manually looking up URL captures or query string parameters, or

@@ -265,15 +275,15 @@ server3 = position

265275 :<|> hello

266276 :<|> marketing

267277

268− where position :: Int -> Int -> Handler Position

278+ where position :: Int -> Int -> ExceptT ServantErr IO Position

269279 position x y = return (Position x y)

270280

271− hello :: Maybe String -> Handler HelloMessage

281+ hello :: Maybe String -> ExceptT ServantErr IO HelloMessage

272282 hello mname = return . HelloMessage $ case mname of

273283 Nothing -> "Hello, anonymous coward"

274284 Just n -> "Hello, " ++ n

275285

276− marketing :: ClientInfo -> Handler Email

286+ marketing :: ClientInfo -> ExceptT ServantErr IO Email

277287 marketing clientinfo = return (emailForClient clientinfo)

278288```

279289

@@ -288,40 +298,42 @@ parameter might not always be there);

288298

289299 - a `ReqBody contentTypeList a` becomes an argument of type `a`;

290300

291−And that's it. Here's the example in action:

301+And that's it. You can see this example in action by running

302+`dist/build/tutorial/tutorial 3`.

292303

293304``` bash

294305$ curl http://localhost:8081/position/1/2

295−{"xCoord":1,"yCoord":2}

306+{"x":1,"y":2}

296307$ curl http://localhost:8081/hello

297308{"msg":"Hello, anonymous coward"}

298309$ curl http://localhost:8081/hello?name=Alp

299310{"msg":"Hello, Alp"}

300−$ curl -X POST -d '{"clientName":"Alp Mestanogullari", "clientEmail" : "alp@foo.com", "clientAge": 25, "clientInterestedIn": ["haskell", "mathematics"]}' -H 'Accept: application/json' -H 'Content-type: application/json' http://localhost:8081/marketing

311+$ curl -X POST -d '{"name":"Alp Mestanogullari", "email" : "alp@foo.com", "age": 25, "interested_in": ["haskell", "mathematics"]}' -H 'Accept: application/json' -H 'Content-type: application/json' http://localhost:8081/marketing

301312{"subject":"Hey Alp Mestanogullari, we miss you!","body":"Hi Alp Mestanogullari,\n\nSince you've recently turned 25, have you checked out our latest haskell, mathematics products? Give us a visit!","to":"alp@foo.com","from":"great@company.com"}

302313```

303314

304−For reference, here's a list of some combinators from **servant**:

315+For reference, here's a list of some combinators from *servant* and for those

316+that get turned into arguments to the handlers, the type of the argument.

305317

306− > - `Delete`, `Get`, `Patch`, `Post`, `Put`: these do not become arguments. They provide the return type of handlers, which usually is `Handler <something>`.

318+ > - `Delete`, `Get`, `Patch`, `Post`, `Put`: these do not become arguments. They provide the return type of handlers, which usually is `ExceptT ServantErr IO <something>`.

307319 > - `Capture "something" a` becomes an argument of type `a`.

308− > - `QueryParam "something" a`, `Header "something" a` all become arguments of type `Maybe a`, because there might be no value at all specified by the client for these.

309− > - `QueryFlag "something"` gets turned into an argument of type `Bool`.

310− > - `QueryParams "something" a` gets turned into an argument of type `[a]`.

320+ > - `QueryParam "something" a`, `MatrixParam "something" a`, `Header "something" a` all become arguments of type `Maybe a`, because there might be no value at all specified by the client for these.

321+ > - `QueryFlag "something"` and `MatrixFlag "something"` get turned into arguments of type `Bool`.

322+ > - `QueryParams "something" a` and `MatrixParams "something" a` get turned into arguments of type `[a]`.

311323 > - `ReqBody contentTypes a` gets turned into an argument of type `a`.

312324

313325## The `FromHttpApiData`/`ToHttpApiData` classes

314326

315−Wait... How does **servant** know how to decode the `Int`s from the URL? Or how

316−to decode a `ClientInfo` value from the request body? The following three sections will

317−help us answer these questions.

327+Wait... How does *servant* know how to decode the `Int`s from the URL? Or how

328+to decode a `ClientInfo` value from the request body? This is what this and the

329+following two sections address.

318330

319331`Capture`s and `QueryParam`s are represented by some textual value in URLs.

320332`Header`s are similarly represented by a pair of a header name and a

321333corresponding (textual) value in the request's "metadata". How types are

322334decoded from headers, captures, and query params is expressed in a class

323335`FromHttpApiData` (from the package

324−[**http-api-data**](http://hackage.haskell.org/package/http-api-data)):

336+[*http-api-data*](http://hackage.haskell.org/package/http-api-data)):

325337

326338``` haskell ignore

327339class FromHttpApiData a where

@@ -343,15 +355,15 @@ As you can see, as long as you provide either `parseUrlPiece` (for `Capture`s)

343355or `parseQueryParam` (for `QueryParam`s), the other methods will be defined in

344356terms of this.

345357

346−**http-api-data** provides a decent number of instances, helpers for defining new

358+*http-api-data* provides a decent number of instances, helpers for defining new

347359ones, and wonderful documentation.

348360

349361There's not much else to say about these classes. You will need instances for

350362them when using `Capture`, `QueryParam`, `QueryParams`, and `Header` with your

351363types. You will need `FromHttpApiData` instances for server-side request

352364handlers and `ToHttpApiData` instances only when using

353−**servant-client**, as described in the [section about deriving haskell

354−functions to query an API](Client.html).

365+*servant-client*, as described in the [section about deriving haskell

366+functions to query an API](/tutorial/client.html).

355367

356368## Using content-types with your data types

357369

@@ -359,15 +371,14 @@ The same principle was operating when decoding request bodies from JSON, and

359371responses *into* JSON. (JSON is just the running example - you can do this with

360372any content-type.)

361373

362−This section introduces a couple of typeclasses provided by **servant** that make

374+This section introduces a couple of typeclasses provided by *servant* that make

363375all of this work.

364376

365377### The truth behind `JSON`

366378

367379

368−What exactly is `JSON` (the type as used in `Get '[JSON] User`)? Like the 3

369−other content-types provided out of the box by **servant**, it's a really dumb

370−data type.

380+What exactly is `JSON`? Like the 3 other content types provided out of the box

381+by *servant*, it's a really dumb data type.

371382

372383``` haskell ignore

373384data JSON

@@ -377,15 +388,14 @@ data OctetStream

377388```

378389

379390Obviously, this is not all there is to `JSON`, otherwise it would be quite

380−pointless. Like most of the data types in **servant**, `JSON` is mostly there as

391+pointless. Like most of the data types in *servant*, `JSON` is mostly there as

381392a special *symbol* that's associated with encoding (resp. decoding) to (resp.

382393from) the *JSON* format. The way this association is performed can be

383394decomposed into two steps.

384395

385396The first step is to provide a proper

386−`MediaType` (from

387−[**http-media**](https://hackage.haskell.org/package/http-media-0.6.2/docs/Network-HTTP-Media.html))

388−representation for `JSON`, or for your own content-types. If you look at the

397+[`MediaType`](https://hackage.haskell.org/package/http-media-0.6.2/docs/Network-HTTP-Media.html)

398+representation for `JSON`, or for your own content types. If you look at the

389399haddocks from this link, you can see that we just have to specify

390400`application/json` using the appropriate functions. In our case, we can just

391401use `(//) :: ByteString -> ByteString -> MediaType`. The precise way to specify

@@ -401,14 +411,14 @@ instance Accept JSON where

401411```

402412

403413The second step is centered around the `MimeRender` and `MimeUnrender` classes.

404−These classes just let you specify a way to encode and decode

405−values into or from your content-type's representation.

414+These classes just let you specify a way to respectively encode and decode

415+values respectively into or from your content-type's representation.

406416

407417``` haskell ignore

408418class Accept ctype => MimeRender ctype a where

409− mimeRender :: Proxy ctype -> a -> ByteString

419+ mimeRender :: Proxy ctype -> a -> ByteString

410420 -- alternatively readable as:

411− mimeRender :: Proxy ctype -> (a -> ByteString)

421+ mimeRender :: Proxy ctype -> (a -> ByteString)

412422```

413423

414424Given a content-type and some user type, `MimeRender` provides a function that

@@ -434,7 +444,7 @@ class Accept ctype => MimeUnrender ctype a where

434444We don't have much work to do there either, `Data.Aeson.eitherDecode` is

435445precisely what we need. However, it only allows arrays and objects as toplevel

436446JSON values and this has proven to get in our way more than help us so we wrote

437−our own little function around **aeson** and **attoparsec** that allows any type of

447+our own little function around *aeson* and *attoparsec* that allows any type of

438448JSON value at the toplevel of a "JSON document". Here's the definition in case

439449you are curious.

440450

@@ -452,20 +462,20 @@ instance FromJSON a => MimeUnrender JSON a where

452462 mimeUnrender _ = eitherDecodeLenient

453463```

454464

455−And this is all the code that lets you use `JSON` with `ReqBody`, `Get`,

465+And this is all the code that lets you use `JSON` for with `ReqBody`, `Get`,

456466`Post` and friends. We can check our understanding by implementing support

457−for an `HTML` content-type, so that users of your webservice can access an

467+for an `HTML` content type, so that users of your webservice can access an

458468HTML representation of the data they want, ready to be included in any HTML

459469document, e.g. using [jQuery's `load` function](https://api.jquery.com/load/),

460470simply by adding `Accept: text/html` to their request headers.

461471

462−### Case-studies: **servant-blaze** and **servant-lucid**

472+### Case-studies: *servant-blaze* and *servant-lucid*

463473

464474These days, most of the haskellers who write their HTML UIs directly from

465−Haskell use either [**blaze-html**](http://hackage.haskell.org/package/blaze-html)

466−or [**lucid**](http://hackage.haskell.org/package/lucid). The best option for

467−**servant** is obviously to support both (and hopefully other templating

468−solutions!). We're first going to look at **lucid**:

475+Haskell use either [blaze-html](http://hackage.haskell.org/package/blaze-html)

476+or [lucid](http://hackage.haskell.org/package/lucid). The best option for

477+*servant* is obviously to support both (and hopefully other templating

478+solutions!).

469479

470480``` haskell

471481data HTMLLucid

@@ -473,20 +483,24 @@ data HTMLLucid

473483

474484Once again, the data type is just there as a symbol for the encoding/decoding

475485functions, except that this time we will only worry about encoding since

476−**lucid** doesn't provide a way to extract data from HTML.

486+*blaze-html* and *lucid* don't provide a way to extract data from HTML.

487+

488+Both packages also have the same `Accept` instance for their `HTMLLucid` type.

477489

478490``` haskell

479491instance Accept HTMLLucid where

480492 contentType _ = "text" // "html" /: ("charset", "utf-8")

481493```

482494

483−Note that this instance uses the `(/:)` operator from **http-media** which lets

495+Note that this instance uses the `(/:)` operator from *http-media* which lets

484496us specify additional information about a content-type, like the charset here.

485497

486−The rendering instances call similar functions that take

498+The rendering instances for both packages both call similar functions that take

487499types with an appropriate instance to an "abstract" HTML representation and

488500then write that to a `ByteString`.

489501

502+For *lucid*:

503+

490504``` haskell

491505instance ToHtml a => MimeRender HTMLLucid a where

492506 mimeRender _ = renderBS . toHtml

@@ -497,7 +511,7 @@ instance MimeRender HTMLLucid (Html a) where

497511 mimeRender _ = renderBS

498512```

499513

500−For **blaze-html** everything works very similarly:

514+For *blaze-html*:

501515

502516``` haskell

503517-- For this tutorial to compile 'HTMLLucid' and 'HTMLBlaze' have to be

@@ -517,13 +531,15 @@ instance MimeRender HTMLBlaze Text.Blaze.Html.Html where

517531 mimeRender _ = renderHtml

518532```

519533

520−Both [**servant-blaze**](http://hackage.haskell.org/package/servant-blaze) and

521−[**servant-lucid**](http://hackage.haskell.org/package/servant-lucid) let you use

522−`HTMLLucid` and `HTMLBlaze` in any content-type list as long as you provide an instance of the

523−appropriate class (`ToMarkup` for **blaze-html**, `ToHtml` for **lucid**).

534+Both [servant-blaze](http://hackage.haskell.org/package/servant-blaze) and

535+[servant-lucid](http://hackage.haskell.org/package/servant-lucid) let you use

536+`HTMLLucid` in any content type list as long as you provide an instance of the

537+appropriate class (`ToMarkup` for *blaze-html*, `ToHtml` for *lucid*).

538+

539+We can now write webservice that uses *servant-lucid* to show the `HTMLLucid`

540+content type in action. First off, imports and pragmas as usual.

524541

525−We can now write a webservice that uses **servant-lucid** to show the `HTMLLucid`

526−content-type in action. We will be serving the following API:

542+We will be serving the following API:

527543

528544``` haskell

529545type PersonAPI = "persons" :> Get '[JSON, HTMLLucid] [Person]

@@ -540,7 +556,7 @@ data Person = Person

540556instance ToJSON Person

541557```

542558

543−Now, let's teach **lucid** how to render a `Person` as a row in a table, and then

559+Now, let's teach *lucid* how to render a `Person` as a row in a table, and then

544560a list of `Person`s as a table with a row per person.

545561

546562``` haskell

@@ -584,45 +600,48 @@ server4 :: Server PersonAPI

584600server4 = return people

585601

586602app2 :: Application

587−app2 = serve personAPI server4

603+app2 = serve personAPI EmptyConfig server4

588604```

589605

590−And we're good to go:

606+And we're good to go. You can run this example with `dist/build/tutorial/tutorial 4`.

591607

592608``` bash

593−$ curl http://localhost:8081/persons

594−[{"lastName":"Newton","firstName":"Isaac"},{"lastName":"Einstein","firstName":"Albert"}]

595−$ curl -H 'Accept: text/html' http://localhost:8081/persons

596−<table><tr><td>first name</td><td>last name</td></tr><tr><td>Isaac</td><td>Newton</td></tr><tr><td>Albert</td><td>Einstein</td></tr></table>

597−# or just point your browser to http://localhost:8081/persons

609+ $ curl http://localhost:8081/persons

610+ [{"lastName":"Newton","firstName":"Isaac"},{"lastName":"Einstein","firstName":"Albert"}]

611+ $ curl -H 'Accept: text/html' http://localhost:8081/persons

612+ <table><tr><td>first name</td><td>last name</td></tr><tr><td>Isaac</td><td>Newton</td></tr><tr><td>Albert</td><td>Einstein</td></tr></table>

613+ # or just point your browser to http://localhost:8081/persons

598614```

599615

600−## The `Handler` monad

616+## The `ExceptT ServantErr IO` monad

601617

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

604−One might wonder: why this monad? The answer is that it is the

618+At the heart of the handlers is the monad they run in, namely `ExceptT

619+ServantErr IO`. One might wonder: why this monad? The answer is that it is the

605620simplest monad with the following properties:

606621

607−- it lets us both return a successful result (using `return`)

608−or "fail" with a descriptive error (using `throwError`);

622+- it lets us both return a successful result (with the `Right` branch of

623+`Either`) or "fail" with a descriptive error (with the `Left` branch of

624+`Either`);

609625- it lets us perform IO, which is absolutely vital since most webservices exist

610−as interfaces to databases that we interact with in `IO`.

626+as interfaces to databases that we interact with in `IO`;

611627

612628Let's recall some definitions.

613629

614630``` haskell ignore

631+-- from the Prelude

632+data Either e a = Left e | Right a

633+

615634-- from the 'mtl' package at

616−newtype ExceptT e m a = ExceptT (m (Either e a))

635+newtype ExceptT e m a = ExceptT ( m (Either e a) )

617636```

618637

619−In short, this means that a handler of type `Handler a` is simply

620−equivalent to a computation of type `IO (Either ServerError a)`, that is, an IO

638+In short, this means that a handler of type `ExceptT ServantErr IO a` is simply

639+equivalent to a computation of type `IO (Either ServantErr a)`, that is, an IO

621640action that either returns an error or a result.

622641

623−The module [`Control.Monad.Except`](https://hackage.haskell.org/package/mtl/docs/Control-Monad-Except.html#t:ExceptT)

642+The module [`Control.Monad.Except`](https://hackage.haskell.org/package/mtl-2.2.1/docs/Control-Monad-Except.html#t:ExceptT)

624643from which `ExceptT` comes is worth looking at.

625−Perhaps most importantly, `ExceptT` and `Handler` are instances of `MonadError`, so

644+Perhaps most importantly, `ExceptT` is an instance of `MonadError`, so

626645`throwError` can be used to return an error from your handler (whereas `return`

627646 is enough to return a success).

628647

@@ -632,17 +651,18 @@ kind and abort early. The next two sections cover how to do just that.

632651

633652### Performing IO

634653

635−Other important instances from the list above are `MonadIO m => MonadIO

636−(ExceptT e m)`, and therefore also `MonadIO Handler` as there is a `MonadIO IO` instance.

637−[`MonadIO`](http://hackage.haskell.org/package/base/docs/Control-Monad-IO-Class.html#t:MonadIO)

638−is a class from the **transformers** package defined as:

654+Another important instance from the list above is `MonadIO m => MonadIO

655+(ExceptT e m)`.

656+[`MonadIO`](http://hackage.haskell.org/package/transformers-0.4.3.0/docs/Control-Monad-IO-Class.html)

657+is a class from the *transformers* package defined as:

639658

640659``` haskell ignore

641660class Monad m => MonadIO m where

642661 liftIO :: IO a -> m a

643662```

644663

645−So if you want to run any kind of

664+Obviously, the `IO` monad provides a `MonadIO` instance. Hence for any type

665+`e`, `ExceptT e IO` has a `MonadIO` instance. So if you want to run any kind of

646666IO computation in your handlers, just use `liftIO`:

647667

648668``` haskell

@@ -660,16 +680,16 @@ server5 = do

660680 return (FileContent filecontent)

661681```

662682

663−### Failing, through `ServerError`

683+### Failing, through `ServantErr`

664684

665685If you want to explicitly fail at providing the result promised by an endpoint

666686using the appropriate HTTP status code (not found, unauthorized, etc) and some

667−error message, all you have to do is use the `throwError` function mentioned above

668−and provide it with the appropriate value of type `ServerError`, which is

687+error message, all you have to do is use the `left` function mentioned above

688+and provide it with the appropriate value of type `ServantErr`, which is

669689defined as:

670690

671691``` haskell ignore

672−data ServerError = ServerError

692+data ServantErr = ServantErr

673693 { errHTTPCode :: Int

674694 , errReasonPhrase :: String

675695 , errBody :: ByteString -- lazy bytestring

@@ -682,10 +702,10 @@ module. If you want to use these values but add a body or some headers, just

682702use record update syntax:

683703

684704``` haskell

685−failingHandler :: Handler ()

686−failingHandler = throwError myerr

705+failingHandler :: ExceptT ServantErr IO ()

706+failingHandler = throwE myerr

687707

688− where myerr :: ServerError

708+ where myerr :: ServantErr

689709 myerr = err503 { errBody = "Sorry dear user." }

690710```

691711

@@ -698,41 +718,42 @@ server6 = do

698718 exists <- liftIO (doesFileExist "myfile.txt")

699719 if exists

700720 then liftIO (readFile "myfile.txt") >>= return . FileContent

701− else throwError custom404Err

721+ else throwE custom404Err

702722

703723 where custom404Err = err404 { errBody = "myfile.txt just isn't there, please leave this server alone." }

704724```

705725

706−Here's how that server looks in action:

726+Let's run this server (`dist/build/tutorial/tutorial 5`) and

727+query it, first without the file and then with the file.

707728

708729``` bash

709−$ curl --verbose http://localhost:8081/myfile.txt

710−[snip]

711−* Connected to localhost (127.0.0.1) port 8081 (#0)

712−> GET /myfile.txt HTTP/1.1

713−> User-Agent: curl/7.30.0

714−> Host: localhost:8081

715−> Accept: */*

716−>

717−< HTTP/1.1 404 Not Found

718−[snip]

719−myfile.txt just isn't there, please leave this server alone.

720−

721−$ echo Hello > myfile.txt

722−

723−$ curl --verbose http://localhost:8081/myfile.txt

724−[snip]

725−* Connected to localhost (127.0.0.1) port 8081 (#0)

726−> GET /myfile.txt HTTP/1.1

727−> User-Agent: curl/7.30.0

728−> Host: localhost:8081

729−> Accept: */*

730−>

731−< HTTP/1.1 200 OK

732−[snip]

733−< Content-Type: application/json

734−[snip]

735−{"content":"Hello\n"}

730+ $ curl --verbose http://localhost:8081/myfile.txt

731+ [snip]

732+ * Connected to localhost (127.0.0.1) port 8081 (#0)

733+ > GET /myfile.txt HTTP/1.1

734+ > User-Agent: curl/7.30.0

735+ > Host: localhost:8081

736+ > Accept: */*

737+ >

738+ < HTTP/1.1 404 Not Found

739+ [snip]

740+ myfile.txt just isnt there, please leave this server alone.

741+

742+ $ echo Hello > myfile.txt

743+

744+ $ curl --verbose http://localhost:8081/myfile.txt

745+ [snip]

746+ * Connected to localhost (127.0.0.1) port 8081 (#0)

747+ > GET /myfile.txt HTTP/1.1

748+ > User-Agent: curl/7.30.0

749+ > Host: localhost:8081

750+ > Accept: */*

751+ >

752+ < HTTP/1.1 200 OK

753+ [snip]

754+ < Content-Type: application/json

755+ [snip]

756+ {"content":"Hello\n"}

736757```

737758

738759## Response headers

@@ -748,77 +769,151 @@ myHandler :: Server MyHandler

748769myHandler = return $ addHeader 1797 albert

749770```

750771

751−Note that the type of `addHeader header x` is different than the type of `x`!

752−And if you add more headers, more headers will appear in the header list:

753−

754−``` haskell

755−type MyHeadfulHandler = Get '[JSON] (Headers '[Header "X-A-Bool" Bool, Header "X-An-Int" Int] User)

756−

757−myHeadfulHandler :: Server MyHeadfulHandler

758−myHeadfulHandler = return $ addHeader True $ addHeader 1797 albert

759−```

760−

761−But what if your handler only *sometimes* adds a header? If you declare that

762−your handler adds headers, and you don't add one, the return type of your

763−handler will be different than expected. To solve this, you have to explicitly

764−*not* add a header by using `noHeader`:

765−

766−``` haskell

767−type MyMaybeHeaderHandler

768− = Capture "withHeader" Bool :> Get '[JSON] (Headers '[Header "X-An-Int" Int] User)

769−

770−myMaybeHeaderHandler :: Server MyMaybeHeaderHandler

771−myMaybeHeaderHandler x = return $ if x then addHeader 1797 albert

772− else noHeader albert

773−```

772+Note that the type of `addHeader x` is different than the type of `x`!

774773

775774## Serving static files

776775

777−**servant-server** also provides a way to just serve the content of a directory

776+*servant-server* also provides a way to just serve the content of a directory

778777under some path in your web API. As mentioned earlier in this document, the

779778`Raw` combinator can be used in your APIs to mean "plug here any WAI

780−application". Well, **servant-server** provides a function to get a file and

779+application". Well, servant-server provides a function to get a file and

781780directory serving WAI application, namely:

782781

783782``` haskell ignore

784783-- exported by Servant and Servant.Server

785−serveDirectoryWebApp :: FilePath -> Server Raw

784+serveDirectory :: FilePath -> Server Raw

786785```

787786

788−`serveDirectoryWebApp`'s argument must be a path to a valid directory.

787+`serveDirectory`'s argument must be a path to a valid directory. You can see an

788+example below, runnable with `dist/build/tutorial/tutorial 6`

789+(you **must** run it from within the *servant-examples/* directory!), which is

790+a webserver that serves the various bits of code covered in this

791+getting-started.

789792

790−Here's an example API that will serve some static files:

793+The API type will be the following.

791794

792795``` haskell

793−type StaticAPI = "static" :> Raw

796+type CodeAPI = "code" :> Raw

794797```

795798

796799And the server:

797800

798801``` haskell

799−staticAPI :: Proxy StaticAPI

800−staticAPI = Proxy

802+codeAPI :: Proxy CodeAPI

803+codeAPI = Proxy

801804```

802805

803806``` haskell

804−server7 :: Server StaticAPI

805−server7 = serveDirectoryWebApp "static-files"

807+server7 :: Server CodeAPI

808+server7 = serveDirectory "tutorial"

806809

807810app3 :: Application

808−app3 = serve staticAPI server7

811+app3 = serve codeAPI EmptyConfig server7

809812```

810813

811−This server will match any request whose path starts with `/static` and will look

814+This server will match any request whose path starts with `/code` and will look

812815for a file at the path described by the rest of the request path, inside the

813− *static-files/* directory of the path you run the program from.

816+ *tutorial/* directory of the path you run the program from.

817+

818+In other words:

819+

820+- If a client requests `/code/foo.txt`, the server will look for a file at

821+ `./tutorial/foo.txt` (and fail)

822+- If a client requests `/code/T1.hs`, the server will look for a file at

823+ `./tutorial/T1.hs` (and succeed)

824+- If a client requests `/code/foo/bar/baz/movie.mp4`, the server will look for

825+ a file at `./tutorial/foo/bar/baz/movie.mp4` (and fail)

826+

827+Here is our little server in action.

828+

829+``` haskell ignore

830+$ curl http://localhost:8081/code/T1.hs

831+{-# LANGUAGE DataKinds #-}

832+{-# LANGUAGE TypeFamilies #-}

833+{-# LANGUAGE DeriveGeneric #-}

834+{-# LANGUAGE TypeOperators #-}

835+module T1 where

836+

837+import Data.Aeson

838+import Data.Time.Calendar

839+import GHC.Generics

840+import Network.Wai

841+import Servant

842+

843+data User = User

844+ { name :: String

845+ , age :: Int

846+ , email :: String

847+ , registration_date :: Day

848+ } deriving (Eq, Show, Generic)

849+

850+-- orphan ToJSON instance for Day. necessary to derive one for User

851+instance ToJSON Day where

852+ -- display a day in YYYY-mm-dd format

853+ toJSON d = toJSON (showGregorian d)

854+

855+instance ToJSON User

856+

857+type UserAPI = "users" :> Get '[JSON] [User]

858+

859+users :: [User]

860+users =

861+ [ User "Isaac Newton" 372 "isaac@newton.co.uk" (fromGregorian 1683 3 1)

862+ , User "Albert Einstein" 136 "ae@mc2.org" (fromGregorian 1905 12 1)

863+ ]

814864

815−In other words: If a client requests `/static/foo.txt`, the server will look for a file at

816−`./static-files/foo.txt`. If that file exists it'll succeed and serve the file.

817−If it doesn't exist, the handler will fail with a `404` status code.

865+userAPI :: Proxy UserAPI

866+userAPI = Proxy

867+

868+server :: Server UserAPI

869+server = return users

870+

871+app :: Application

872+app = serve userAPI server

873+$ curl http://localhost:8081/code/tutorial.hs

874+import Network.Wai

875+import Network.Wai.Handler.Warp

876+import System.Environment

877+

878+import qualified T1

879+import qualified T2

880+import qualified T3

881+import qualified T4

882+import qualified T5

883+import qualified T6

884+import qualified T7

885+import qualified T9

886+import qualified T10

887+

888+app :: String -> (Application -> IO ()) -> IO ()

889+app n f = case n of

890+ "1" -> f T1.app

891+ "2" -> f T2.app

892+ "3" -> f T3.app

893+ "4" -> f T4.app

894+ "5" -> f T5.app

895+ "6" -> f T6.app

896+ "7" -> f T7.app

897+ "8" -> f T3.app

898+ "9" -> T9.writeJSFiles >> f T9.app

899+ "10" -> f T10.app

900+ _ -> usage

818901

819−`serveDirectoryWebApp` uses some standard settings that fit the use case of

820−serving static files for most web apps. You can find out about the other

821−options in the documentation of the `Servant.Server.StaticFiles` module.

902+main :: IO ()

903+main = do

904+ args <- getArgs

905+ case args of

906+ [n] -> app n (run 8081)

907+ _ -> usage

908+

909+usage :: IO ()

910+usage = do

911+ putStrLn "Usage:\t tutorial N"

912+ putStrLn "\t\twhere N is the number of the example you want to run."

913+

914+$ curl http://localhost:8081/foo

915+not found

916+```

822917

823918## Nested APIs

824919

@@ -830,7 +925,7 @@ type UserAPI3 = -- view the user with given userid, in JSON

830925 Capture "userid" Int :> Get '[JSON] User

831926

832927 :<|> -- delete the user with given userid. empty response

833− Capture "userid" Int :> DeleteNoContent

928+ Capture "userid" Int :> Delete '[] ()

834929```

835930

836931We can instead factor out the `userid`:

@@ -838,7 +933,7 @@ We can instead factor out the `userid`:

838933``` haskell

839934type UserAPI4 = Capture "userid" Int :>

840935 ( Get '[JSON] User

841− :<|> DeleteNoContent

936+ :<|> Delete '[] ()

842937 )

843938```

844939

@@ -846,26 +941,26 @@ However, you have to be aware that this has an effect on the type of the

846941corresponding `Server`:

847942

848943``` haskell ignore

849−Server UserAPI3 = (Int -> Handler User)

850− :<|> (Int -> Handler NoContent)

944+Server UserAPI3 = (Int -> ExceptT ServantErr IO User)

945+ :<|> (Int -> ExceptT ServantErr IO ())

851946

852−Server UserAPI4 = Int -> ( Handler User

853− :<|> Handler NoContent

947+Server UserAPI4 = Int -> ( ExceptT ServantErr IO User

948+ :<|> ExceptT ServantErr IO ()

854949 )

855950```

856951

857952In the first case, each handler receives the *userid* argument. In the latter,

858953the whole `Server` takes the *userid* and has handlers that are just

859−computations in `Handler`, with no arguments. In other words:

954+computations in `ExceptT`, with no arguments. In other words:

860955

861956``` haskell

862957server8 :: Server UserAPI3

863958server8 = getUser :<|> deleteUser

864959

865− where getUser :: Int -> Handler User

960+ where getUser :: Int -> ExceptT ServantErr IO User

866961 getUser _userid = error "..."

867962

868− deleteUser :: Int -> Handler NoContent

963+ deleteUser :: Int -> ExceptT ServantErr IO ()

869964 deleteUser _userid = error "..."

870965

871966-- notice how getUser and deleteUser

@@ -874,10 +969,10 @@ server8 = getUser :<|> deleteUser

874969server9 :: Server UserAPI4

875970server9 userid = getUser userid :<|> deleteUser userid

876971

877− where getUser :: Int -> Handler User

972+ where getUser :: Int -> ExceptT ServantErr IO User

878973 getUser = error "..."

879974

880− deleteUser :: Int -> Handler NoContent

975+ deleteUser :: Int -> ExceptT ServantErr IO ()

881976 deleteUser = error "..."

882977```

883978

@@ -896,13 +991,13 @@ type API1 = "users" :>

896991-- we factor out the Request Body

897992type API2 = ReqBody '[JSON] User :>

898993 ( Get '[JSON] User -- just display the same user back, don't register it

899− :<|> PostNoContent -- register the user. empty response

994+ :<|> Post '[JSON] () -- register the user. empty response

900995 )

901996

902997-- we factor out a Header

903998type API3 = Header "Authorization" Token :>

904999 ( Get '[JSON] SecretData -- get some secret data, if authorized

905− :<|> ReqBody '[JSON] SecretData :> PostNoContent -- add some secret data, if authorized

1000+ :<|> ReqBody '[JSON] SecretData :> Post '[] () -- add some secret data, if authorized

9061001 )

9071002

9081003newtype Token = Token ByteString

@@ -915,44 +1010,44 @@ API type only at the end.

9151010``` haskell

9161011type UsersAPI =

9171012 Get '[JSON] [User] -- list users

918− :<|> ReqBody '[JSON] User :> PostNoContent -- add a user

1013+ :<|> ReqBody '[JSON] User :> Post '[] () -- add a user

9191014 :<|> Capture "userid" Int :>

9201015 ( Get '[JSON] User -- view a user

921− :<|> ReqBody '[JSON] User :> PutNoContent -- update a user

922− :<|> DeleteNoContent -- delete a user

1016+ :<|> ReqBody '[JSON] User :> Put '[] () -- update a user

1017+ :<|> Delete '[] () -- delete a user

9231018 )

9241019

9251020usersServer :: Server UsersAPI

9261021usersServer = getUsers :<|> newUser :<|> userOperations

9271022

928− where getUsers :: Handler [User]

1023+ where getUsers :: ExceptT ServantErr IO [User]

9291024 getUsers = error "..."

9301025

931− newUser :: User -> Handler NoContent

1026+ newUser :: User -> ExceptT ServantErr IO ()

9321027 newUser = error "..."

9331028

9341029 userOperations userid =

9351030 viewUser userid :<|> updateUser userid :<|> deleteUser userid

9361031

9371032 where

938− viewUser :: Int -> Handler User

1033+ viewUser :: Int -> ExceptT ServantErr IO User

9391034 viewUser = error "..."

9401035

941− updateUser :: Int -> User -> Handler NoContent

1036+ updateUser :: Int -> User -> ExceptT ServantErr IO ()

9421037 updateUser = error "..."

9431038

944− deleteUser :: Int -> Handler NoContent

1039+ deleteUser :: Int -> ExceptT ServantErr IO ()

9451040 deleteUser = error "..."

9461041```

9471042

9481043``` haskell

9491044type ProductsAPI =

9501045 Get '[JSON] [Product] -- list products

951− :<|> ReqBody '[JSON] Product :> PostNoContent -- add a product

1046+ :<|> ReqBody '[JSON] Product :> Post '[] () -- add a product

9521047 :<|> Capture "productid" Int :>

9531048 ( Get '[JSON] Product -- view a product

954− :<|> ReqBody '[JSON] Product :> PutNoContent -- update a product

955− :<|> DeleteNoContent -- delete a product

1049+ :<|> ReqBody '[JSON] Product :> Put '[] () -- update a product

1050+ :<|> Delete '[] () -- delete a product

9561051 )

9571052

9581053data Product = Product { productId :: Int }

@@ -960,23 +1055,23 @@ data Product = Product { productId :: Int }

9601055productsServer :: Server ProductsAPI

9611056productsServer = getProducts :<|> newProduct :<|> productOperations

9621057

963− where getProducts :: Handler [Product]

1058+ where getProducts :: ExceptT ServantErr IO [Product]

9641059 getProducts = error "..."

9651060

966− newProduct :: Product -> Handler NoContent

1061+ newProduct :: Product -> ExceptT ServantErr IO ()

9671062 newProduct = error "..."

9681063

9691064 productOperations productid =

9701065 viewProduct productid :<|> updateProduct productid :<|> deleteProduct productid

9711066

9721067 where

973− viewProduct :: Int -> Handler Product

1068+ viewProduct :: Int -> ExceptT ServantErr IO Product

9741069 viewProduct = error "..."

9751070

976− updateProduct :: Int -> Product -> Handler NoContent

1071+ updateProduct :: Int -> Product -> ExceptT ServantErr IO ()

9771072 updateProduct = error "..."

9781073

979− deleteProduct :: Int -> Handler NoContent

1074+ deleteProduct :: Int -> ExceptT ServantErr IO ()

9801075 deleteProduct = error "..."

9811076```

9821077

@@ -996,49 +1091,39 @@ abstract that away:

9961091-- indexed by values of type 'i'

9971092type APIFor a i =

9981093 Get '[JSON] [a] -- list 'a's

999− :<|> ReqBody '[JSON] a :> PostNoContent -- add an 'a'

1094+ :<|> ReqBody '[JSON] a :> Post '[] () -- add an 'a'

10001095 :<|> Capture "id" i :>

10011096 ( Get '[JSON] a -- view an 'a' given its "identifier" of type 'i'

1002− :<|> ReqBody '[JSON] a :> PutNoContent -- update an 'a'

1003− :<|> DeleteNoContent -- delete an 'a'

1097+ :<|> ReqBody '[JSON] a :> Put '[] () -- update an 'a'

1098+ :<|> Delete '[] () -- delete an 'a'

10041099 )

10051100

10061101-- Build the appropriate 'Server'

10071102-- given the handlers of the right type.

1008−serverFor :: Handler [a] -- handler for listing of 'a's

1009− -> (a -> Handler NoContent) -- handler for adding an 'a'

1010− -> (i -> Handler a) -- handler for viewing an 'a' given its identifier of type 'i'

1011− -> (i -> a -> Handler NoContent) -- updating an 'a' with given id

1012− -> (i -> Handler NoContent) -- deleting an 'a' given its id

1103+serverFor :: ExceptT ServantErr IO [a] -- handler for listing of 'a's

1104+ -> (a -> ExceptT ServantErr IO ()) -- handler for adding an 'a'

1105+ -> (i -> ExceptT ServantErr IO a) -- handler for viewing an 'a' given its identifier of type 'i'

1106+ -> (i -> a -> ExceptT ServantErr IO ()) -- updating an 'a' with given id

1107+ -> (i -> ExceptT ServantErr IO ()) -- deleting an 'a' given its id

10131108 -> Server (APIFor a i)

10141109serverFor = error "..."

10151110-- implementation left as an exercise. contact us on IRC

10161111-- or the mailing list if you get stuck!

10171112```

10181113

1019−When your API contains the `EmptyAPI` combinator, you'll want to use

1020−`emptyServer` in the corresponding slot for your server, which will simply fail

1021−with 404 whenever a request reaches it:

1022−

1023−``` haskell

1024−type CombinedAPI2 = API :<|> "empty" :> EmptyAPI

1025−

1026−server11 :: Server CombinedAPI2

1027−server11 = server3 :<|> emptyServer

1028−```

1029−

10301114## Using another monad for your handlers

10311115

1032−Remember how `Server` turns combinators for HTTP methods into `Handler`? Well, actually, there's more to that. `Server` is actually a

1116+Remember how `Server` turns combinators for HTTP methods into `ExceptT

1117+ServantErr IO`? Well, actually, there's more to that. `Server` is actually a

10331118simple type synonym.

10341119

10351120``` haskell ignore

1036−type Server api = ServerT api Handler

1121+type Server api = ServerT api (ExceptT ServantErr IO)

10371122```

10381123

10391124`ServerT` is the actual type family that computes the required types for the

10401125handlers that's part of the `HasServer` class. It's like `Server` except that

1041−it takes another parameter which is the monad you want your handlers to run in,

1126+it takes a third parameter which is the monad you want your handlers to run in,

10421127or more generally the return types of your handlers. This third parameter is

10431128used for specifying the return type of the handler for an endpoint, e.g when

10441129computing `ServerT (Get '[JSON] Person) SomeMonad`. The result would be

@@ -1046,155 +1131,98 @@ computing `ServerT (Get '[JSON] Person) SomeMonad`. The result would be

10461131

10471132The first and main question one might have then is: how do we write handlers

10481133that run in another monad? How can we "bring back" the value from a given monad

1049−into something **servant** can understand?

1134+into something *servant* can understand?

10501135

10511136### Natural transformations

10521137

10531138If we have a function that gets us from an `m a` to an `n a`, for any `a`, what

10541139do we have?

10551140

1056−``` haskell

1057−type (~>) m n = forall a. m a -> n a

1058−```

1059−

1060−For example:

1141+``` haskell ignore

1142+newtype m :~> n = Nat { unNat :: forall a. m a -> n a}

10611143

1062−``` haskell

1063−listToMaybe' :: [] ~> Maybe

1064−listToMaybe' = listToMaybe -- from Data.Maybe

1144+-- For example

1145+-- listToMaybeNat ::`[] :~> Maybe`

1146+-- listToMaybeNat = Nat listToMaybe -- from Data.Maybe

10651147```

1148+(`Nat` comes from "natural transformation", in case you're wondering.)

10661149

1067−Note that `servant` doesn't declare the `~>` type-alias, as the unfolded

1068−variant isn't much longer to write, as we'll see shortly.

1069−

1070−So if you want to write handlers using another monad/type than `Handler`, say the `Reader String` monad, the first thing you have to

1150+So if you want to write handlers using another monad/type than `ExceptT

1151+ServantErr IO`, say the `Reader String` monad, the first thing you have to

10711152prepare is a function:

10721153

10731154``` haskell ignore

1074−readerToHandler :: Reader String a -> Handler a

1155+readerToEither :: Reader String :~> ExceptT ServantErr IO

10751156```

10761157

1077−We obviously have to run the `Reader` computation by supplying it with a

1078−`String`, like `"hi"`. We get an `a` out from that and can then just `return`

1079−it into `Handler`.

1158+Let's start with `readerToEither'`. We obviously have to run the `Reader`

1159+computation by supplying it with a `String`, like `"hi"`. We get an `a` out

1160+from that and can then just `return` it into `ExceptT`. We can then just wrap

1161+that function with the `Nat` constructor to make it have the fancier type.

10801162

10811163``` haskell

1082−readerToHandler :: Reader String a -> Handler a

1083−readerToHandler r = return (runReader r "hi")

1164+readerToEither' :: forall a. Reader String a -> ExceptT ServantErr IO a

1165+readerToEither' r = return (runReader r "hi")

1166+

1167+readerToEither :: Reader String :~> ExceptT ServantErr IO

1168+readerToEither = Nat readerToEither'

10841169```

10851170

10861171We can write some simple webservice with the handlers running in `Reader String`.

10871172

10881173``` haskell

10891174type ReaderAPI = "a" :> Get '[JSON] Int

1090− :<|> "b" :> ReqBody '[JSON] Double :> Get '[JSON] Bool

1175+ :<|> "b" :> Get '[JSON] String

10911176

10921177readerAPI :: Proxy ReaderAPI

10931178readerAPI = Proxy

10941179

10951180readerServerT :: ServerT ReaderAPI (Reader String)

1096−readerServerT = a :<|> b where

1097− a :: Reader String Int

1098− a = return 1797

1181+readerServerT = a :<|> b

1182+

1183+ where a :: Reader String Int

1184+ a = return 1797

10991185

1100− b :: Double -> Reader String Bool

1101− b _ = asks (== "hi")

1186+ b :: Reader String String

1187+ b = ask

11021188```

11031189

11041190We unfortunately can't use `readerServerT` as an argument of `serve`, because

1105−`serve` wants a `Server ReaderAPI`, i.e., with handlers running in `Handler`. But there's a simple solution to this.

1191+`serve` wants a `Server ReaderAPI`, i.e., with handlers running in `ExceptT

1192+ServantErr IO`. But there's a simple solution to this.

11061193

1107−### Welcome `hoistServer`

1194+### Enter `enter`

11081195

1109−That's right. We have just written `readerToHandler`, which is exactly what we

1110−would need to apply to all handlers to make the handlers have the

1196+That's right. We have just written `readerToEither`, which is exactly what we

1197+would need to apply to the results of all handlers to make the handlers have the

11111198right type for `serve`. Being cumbersome to do by hand, we provide a function

1112−`hoistServer` which takes a natural transformation between two parameterized types `m`

1199+`enter` which takes a natural transformation between two parametrized types `m`

11131200and `n` and a `ServerT someapi m`, and returns a `ServerT someapi n`.

11141201

1115−In our case, we can wrap up our little webservice by using

1116−`hoistServer readerAPI readerToHandler` on our handlers.

1202+In our case, we can wrap up our little webservice by using `enter

1203+readerToEither` on our handlers.

11171204

11181205``` haskell

11191206readerServer :: Server ReaderAPI

1120−readerServer = hoistServer readerAPI readerToHandler readerServerT

1207+readerServer = enter readerToEither readerServerT

11211208

11221209app4 :: Application

1123−app4 = serve readerAPI readerServer

1210+app4 = serve readerAPI EmptyConfig readerServer

11241211```

11251212

1126−This is the webservice in action:

1213+And we can indeed see this webservice in action by running

1214+`dist/build/tutorial/tutorial 7`.

11271215

11281216``` bash

11291217$ curl http://localhost:8081/a

113012181797

1131−$ curl http://localhost:8081/b -X GET -d '42.0' -H 'Content-Type: application/json'

1132−true

1133−```

1134−

1135−### An arrow is a reader too.

1136−

1137−In previous versions of `servant` we had an `enter` to do what `hoistServer`

1138−does now. `enter` had an ambitious design goals, but was problematic in practice.

1139−

1140−One problematic situation was when the source monad was `(->) r`, yet it's

1141−handy in practice, because `(->) r` is isomorphic to `Reader r`.

1142−

1143−We can rewrite the previous example without `Reader`:

1144−

1145−```haskell

1146−funServerT :: ServerT ReaderAPI ((->) String)

1147−funServerT = a :<|> b where

1148− a :: String -> Int

1149− a _ = 1797

1150−

1151− -- unfortunately, we cannot make `String` the first argument.

1152− b :: Double -> String -> Bool

1153− b _ s = s == "hi"

1154−

1155−funToHandler :: (String -> a) -> Handler a

1156−funToHandler f = return (f "hi")

1157−

1158−app5 :: Application

1159−app5 = serve readerAPI (hoistServer readerAPI funToHandler funServerT)

1219+$ curl http://localhost:8081/b

1220+"hi"

11601221```

11611222

1162−## Streaming endpoints

1163−

1164−We can create endpoints that don't just give back a single result, but give

1165−back a *stream* of results, served one at a time. Stream endpoints only provide

1166−a single content type, and also specify what framing strategy is used to

1167−delineate the results. To serve these results, we need to give back a stream

1168−producer. Adapters can be written to *Pipes*, *Conduit* and the like, or

1169−written directly as `SourceIO`s. SourceIO builds upon servant's own `SourceT`

1170−stream type (it's simpler than *Pipes* or *Conduit*).

1171−The API of a streaming endpoint needs to explicitly specify which sort of

1172−generator it produces. Note that the generator itself is returned by a

1173−`Handler` action, so that additional IO may be done in the creation of one.

1174−

1175−``` haskell

1176−type StreamAPI = "userStream" :> StreamGet NewlineFraming JSON (SourceIO User)

1177−streamAPI :: Proxy StreamAPI

1178−streamAPI = Proxy

1179−

1180−streamUsers :: SourceIO User

1181−streamUsers = source [isaac, albert, albert]

1182−

1183−app6 :: Application

1184−app6 = serve streamAPI (return streamUsers)

1185−```

1186−

1187−This simple application returns a stream of `User` values encoded in JSON

1188−format, with each value separated by a newline. In this case, the stream will

1189−consist of the value of `isaac`, followed by the value of `albert`, then the

1190−value of `albert` a second time. Importantly, the stream is written back as

1191−results are produced, rather than all at once. This means first that results

1192−are delivered when they are available, and second, that if an exception

1193−interrupts production of the full stream, nonetheless partial results have

1194−already been written back.

1195−

11961223## Conclusion

11971224

1198−You're now equipped to write webservices/web-applications using

1199−**servant**. The rest of this document focuses on **servant-client**,

1200−**servant-js** and **servant-docs**.

1225+You're now equipped to write any kind of webservice/web-application using

1226+*servant*. One thing not covered here is how to incorporate your own

1227+combinators and will be the topic of a page on the website. The rest of this

1228+document focuses on *servant-client*, *servant-jquery* and *servant-docs*.

doc/tutorial/index.rst+5−5

@@ -1,18 +1,18 @@

11Tutorial

22========

4−This is an introductory tutorial to **servant**. Whilst browsing is fine, it makes more sense if you read the sections in order, or at least read the first section before anything else.

4+This is an introductory tutorial to **servant**.

6+(Any comments, issues or feedback about the tutorial can be handled

7+through

8+`servant's issue tracker <http://github.com/haskell-servant/servant/issues>`_.)

6−Any comments, issues or feedback about the tutorial can be submitted

7−to `servant's issue tracker <http://github.com/haskell-servant/servant/issues>`_.

810

911.. toctree::

1012 :maxdepth: 1

1113

12− install.rst

1314 ApiType.lhs

1415 Server.lhs

1516 Client.lhs

1617 Javascript.lhs

1718 Docs.lhs

18− Authentication.lhs

doc/tutorial/install.rstdeleted−68

@@ -1,68 +0,0 @@

1−Install

2−========

3−

4−cabal-install

5−--------

6−

7−The whole tutorial is a `cabal <https://cabal.readthedocs.io/en/latest/>`_

8−project and can be built locally as follows:

9−

10−.. code-block:: bash

11−

12− $ git clone https://github.com/haskell-servant/servant.git

13− $ cd servant

14− # build

15− $ cabal new-build tutorial

16− # load in ghci to play with it

17− $ cabal new-repl tutorial

18−

19−stack

20−--------

21−

22−The servant `stack <https://docs.haskellstack.org/en/stable/README/>`_ template includes the working tutorial. To initialize this template, run:

23−

24−.. code-block:: bash

25−

26− $ stack new myproj servant

27− $ cd myproj

28− # build

29− $ stack build

30− # start server

31− $ stack exec myproj-exe

32−

33−The code can be found in the `*.lhs` files under `doc/tutorial/` in the

34−repository. Feel free to edit it while you're reading this documentation and

35−see the effect of your changes.

36−

37−nix

38−--------

39−

40−`Nix <https://nixos.org/nix/>`_ users should feel free to take a look at

41−the `nix/shell.nix` file in the repository and use it to provision a suitable

42−environment to build and run the examples.

43−

44−Note for Ubuntu users

45−--------

46−

47−Ubuntu's packages for `ghc`, `cabal`, and `stack` are years out of date.

48−If the instructions above fail for you,

49−try replacing the Ubuntu packages with up-to-date versions.

50−First remove the installed versions:

51−

52−.. code-block:: bash

53−

54− # remove the obsolete versions

55− $ sudo apt remove ghc haskell-stack cabal-install

56−

57−Then install fresh versions of the Haskell toolchain

58−using the `ghcup <https://www.haskell.org/ghcup/install/>`_ installer.

59−

60−As of February 2022, one easy way to do this is by running a bootstrap script:

61−

62−.. code-block:: bash

63−

64− $ curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh

65−

66−The script is interactive and will prompt you for details about what

67−you want installed and where. To install manually,

68−see `the detailed instructions <https://www.haskell.org/ghcup/install/#manual-install>`_.

doc/tutorial/static/index.htmldeleted−26

@@ -1,26 +0,0 @@

1−<!DOCTYPE html>

2−<html lang="en">

3− <head>

4− <meta name="viewport" content="width=device-width, initial-scale=1">

5− <meta http-equiv="Content-Type" content="text/html; charset=UTF-8" />

6− <title>servant-js Example</title>

7− </head>

8− <body>

9− <h1>Books</h1>

10− <input type="search" name="q" id="q" placeholder="Search author or book title..." autocomplete="off"/>

11− <div>

12− <p>Results for <strong id="query">""</strong></p>

13− <ul id="results">

14− </ul>

15− </div>

16− <hr />

17− <h1>Approximating π</h1>

18− <p>Count: <span id="count">0</span></p>

19− <p>Successes: <span id="successes">0</span></p>

20− <p id="pi"></p>

21−

22− <script type="text/javascript" src="/jq.js"></script>

23− <script type="text/javascript" src="/api.js"></script>

24− <script type="text/javascript" src="/ui.js"></script>

25−

26− </body>

doc/tutorial/static/ui.jsdeleted−60

@@ -1,60 +0,0 @@

1−/* book search */

2−function updateResults(data)

3−{

4− console.log(data);

5− $('#results').html("");

6− $('#query').text("\"" + data.query + "\"");

7− for(var i = 0; i < data.results.length; i++)

8− {

9− $('#results').append(renderBook(data.results[i]));

10− }

11−}

12−

13−function renderBook(book)

14−{

15− var li = '<li><strong>' + book.title + '</strong>, <i>'

16− + book.author + '</i> - ' + book.year + '</li>';

17− return li;

18−}

19−

20−function searchBooks()

21−{

22− var q = $('#q').val();

23− getBooks(q, updateResults, console.log)

24−}

25−

26−searchBooks();

27−$('#q').keyup(function() {

28− searchBooks();

29−});

30−

31−/* approximating pi */

32−var count = 0;

33−var successes = 0;

34−

35−function f(data)

36−{

37− var x = data.x, y = data.y;

38− if(x*x + y*y <= 1)

39− {

40− successes++;

41− }

42−

43− count++;

44−

45− update('#count', count);

46− update('#successes', successes);

47− update('#pi', 4*successes/count);

48−}

49−

50−function update(id, val)

51−{

52− $(id).text(val);

53−}

54−

55−function refresh()

56−{

57− getPoint(f, console.log);

58−}

59−

60−window.setInterval(refresh, 200);

doc/tutorial/test/JavascriptSpec.hsdeleted−35

@@ -1,35 +0,0 @@

1−{-# LANGUAGE OverloadedStrings #-}

2−

3−module JavascriptSpec where

4−

5−import Data.List

6−import Data.String

7−import Data.String.Conversions

8−import Test.Hspec

9−import Test.Hspec.Wai

10−

11−import Javascript

12−

13−spec :: Spec

14−spec = do

15− describe "apiJS" $ do

16− it "is contained verbatim in Javascript.lhs" $ do

17− code <- readFile "Javascript.lhs"

18− cs apiJS1 `shouldSatisfy` (`isInfixOf` code)

19− cs apiJS3 `shouldSatisfy` (`isInfixOf` code)

20− cs apiJS4 `shouldSatisfy` (`isInfixOf` code)

21− cs apiJS6 `shouldSatisfy` (`isInfixOf` code)

22−

23− describe "writeJSFiles" $ do

24− it "[not a test] write apiJS to static/api.js" $ do

25− writeJSFiles

26−

27− describe "app" $ with (return app) $ do

28− context "/api.js" $ do

29− it "delivers apiJS" $ do

30− get "/api.js" `shouldRespondWith` (fromString (cs apiJS1))

31−

32− context "/" $ do

33− it "delivers something" $ do

34− get "" `shouldRespondWith` 200

35− get "/" `shouldRespondWith` 200

doc/tutorial/test/Spec.hsdeleted−11

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

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/tinc.yamlnew file+13

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

1+dependencies:

2+ - name: servant

3+ path: ../../servant

4+ - name: servant-server

5+ path: ../../servant-server

6+ - name: servant-client

7+ path: ../../servant-client

8+ - name: servant-js

9+ path: ../../servant-js

10+ - name: servant-docs

11+ path: ../../servant-docs

12+ - name: servant-foreign

13+ path: ../../servant-foreign

doc/tutorial/tutorial.cabal+43−74

@@ -1,87 +1,56 @@

1−cabal-version: 2.2

21name: tutorial

3−version: 0.10

2+version: 0.5

43synopsis: The servant tutorial

5−description:

6− The servant tutorial can be found at

7− <http://docs.servant.dev/>

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

9−category: Servant, Documentation

10−license: BSD-3-Clause

4+-- description:

5+homepage: http://haskell-servant.github.io/

6+license: BSD3

117license-file: LICENSE

128author: Servant Contributors

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

10+-- copyright:

11+-- category:

1412build-type: Simple

15−tested-with:

16− GHC==8.6.5

17− GHC==8.8.3, GHC ==8.10.7

18−extra-source-files:

19− static/index.html

20− static/ui.js

13+-- extra-source-files:

14+cabal-version: >=1.10

2115

2216library

23− default-language: Haskell2010

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

2517 exposed-modules: ApiType

26− , Authentication

2718 , Client

2819 , Docs

2920 , Javascript

3021 , Server

31−

32− -- Packages `servant` depends on.

33− -- We don't need to specify bounds here as this package is never released.

34− build-depends:

35− base >= 4.7 && <5

36− , aeson

37− , attoparsec

38− , base-compat

39− , bytestring

40− , containers

41− , directory

42− , http-api-data

43− , http-client

44− , http-media

45− , http-types

46− , mtl

47− , string-conversions

48− , text

49− , transformers

50− , wai

51− , warp

52−

53− -- Servant dependencies

54− build-depends:

55− servant

56− , servant-server

57− , servant-client

58− , servant-docs

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− blaze-html >= 0.9.0.1 && < 0.10

64− , blaze-markup >= 0.8.0.0 && < 0.9

65− , cookie >= 0.4.3 && < 0.5

66− , js-jquery >= 3.3.1 && < 3.4

67− , lucid >= 2.9.11 && < 2.12

68− , random >= 1.1 && < 1.3

69− , servant-js >= 0.9 && < 0.10

70− , time >= 1.6.0.1 && < 1.13

71−

72− -- For legacy tools, we need to specify build-depends too

73− build-depends: markdown-unlit >= 0.5.0 && <0.6

74− build-tool-depends: markdown-unlit:markdown-unlit >= 0.5.0 && <0.6

75−

76−test-suite spec

77− type: exitcode-stdio-1.0

78− ghc-options: -Wall

79− default-language: Haskell2010

80− hs-source-dirs: test

81− main-is: Spec.hs

82− other-modules: JavascriptSpec

83− build-depends: base

84− , tutorial

85− , hspec

86− , hspec-wai

87− , string-conversions

22+ -- other-modules:

23+ -- other-extensions:

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

25+ , base-compat

26+ , text

27+ , aeson >= 0.11

28+ , blaze-html

29+ , directory

30+ , blaze-markup

31+ , servant == 0.5.*

32+ , servant-server == 0.5.*

33+ , servant-client == 0.5.*

34+ , servant-docs == 0.5.*

35+ , servant-js == 0.5.*

36+ , warp

37+ , http-media

38+ , lucid

39+ , time

40+ , string-conversions

41+ , bytestring

42+ , attoparsec

43+ , mtl

44+ , random

45+ , js-jquery

46+ , wai

47+ , http-types

48+ , transformers

49+ , markdown-unlit >= 0.4

50+ , http-client

51+ -- hs-source-dirs:

52+ default-language: Haskell2010

53+ ghc-options: -Wall -Werror -pgmL markdown-unlit

54+ -- to silence aeson-0.10 warnings:

55+ ghc-options: -fno-warn-missing-methods

56+ ghc-options: -fno-warn-name-shadowing

ghcjs.nixdeleted−22

@@ -1,22 +0,0 @@

1−let reflex-platform = import (builtins.fetchTarball

2− { name = "reflex-platform";

3− url = "https://github.com/reflex-frp/reflex-platform/archive/1aba6f367982bd6dd78ec2fda75ab246a62d32c5.tar.gz";

4− }) {};

5− pkgs = import ./nix/nixpkgs.nix; in

6−

7−pkgs.stdenv.mkDerivation {

8− name = "ghcjs-shell";

9− buildInputs =

10− [ (reflex-platform.ghcjs.ghcWithPackages (p: with p; [

11− attoparsec

12− hashable

13− ]))

14− pkgs.cabal-install

15− pkgs.gmp

16− pkgs.haskellPackages.cabal-plan

17− pkgs.haskellPackages.hspec-discover

18− pkgs.nodejs

19− pkgs.perl

20− pkgs.zlib

21− ];

22−}

hlint.yamldeleted−65

@@ -1,65 +0,0 @@

1−# HLint configuration file

2−# https://github.com/ndmitchell/hlint

3−##########################

4−

5−# This file contains a template configuration file, which is typically

6−# placed as .hlint.yaml in the root of your project

7−

8−

9−# Specify additional command line arguments

10−#

11−# - arguments: [--color, --cpp-simple, -XQuasiQuotes]

12−

13−

14−# Control which extensions/flags/modules/functions can be used

15−#

16−# - extensions:

17−# - default: false # all extension are banned by default

18−# - name: [PatternGuards, ViewPatterns] # only these listed extensions can be used

19−# - {name: CPP, within: CrossPlatform} # CPP can only be used in a given module

20−#

21−# - flags:

22−# - {name: -w, within: []} # -w is allowed nowhere

23−#

24−# - modules:

25−# - {name: [Data.Set, Data.HashSet], as: Set} # if you import Data.Set qualified, it must be as 'Set'

26−# - {name: Control.Arrow, within: []} # Certain modules are banned entirely

27−#

28−# - functions:

29−# - {name: unsafePerformIO, within: []} # unsafePerformIO can only appear in no modules

30−

31−

32−# Add custom hints for this project

33−#

34−# Will suggest replacing "wibbleMany [myvar]" with "wibbleOne myvar"

35−# - error: {lhs: "wibbleMany [x]", rhs: wibbleOne x}

36−

37−

38−# Turn on hints that are off by default

39−#

40−# Ban "module X(module X) where", to require a real export list

41−# - warn: {name: Use explicit module export list}

42−#

43−# Replace a $ b $ c with a . b $ c

44−# - group: {name: dollar, enabled: true}

45−#

46−# Generalise map to fmap, ++ to <>

47−# - group: {name: generalise, enabled: true}

48−

49−

50−# Ignore some builtin hints

51−- ignore: {name: Redundant do}

52−- ignore: {name: Parse error}

53−- ignore: {name: Use fmap}

54−- ignore: {name: Use list comprehension}

55−- ignore: {name: Use lambda-case}

56−- ignore: {name: Eta reduce}

57−# - ignore: {name: Use const, within: SpecialModule} # Only within certain modules

58−

59−

60−# Define some custom infix operators

61−# - fixity: infixr 3 ~^#^~

62−

63−

64−# To generate a suitable file for HLint do:

65−# $ hlint --default > .hlint.yaml

nix/README.mddeleted−41

@@ -1,41 +0,0 @@

1−You can use the `shell.nix` from this directory

2−to build the servant packages or even the tutorial

3−or cookbook if you want to, optionally.

4−

5−Just the servant packages:

6−

7−``` sh

8−$ nix-shell nix/shell.nix

9−```

10−

11−Everything needed for the tutorial and the

12−cookbook too:

13−

14−``` sh

15−$ nix-shell nix/shell.nix --arg tutorial true

16−```

17−

18−The `shell.nix` file also supports specifying

19−a particular ghc version, e.g:

20−

21−``` sh

22−$ nix-shell nix/shell.nix --argstr compiler ghcHEAD

23−```

24−

25−**Possible GHC versions**

26−- `ghc865Binary`

27−- `ghc884`

28−- `ghc8104` - default

29−- `ghc901`

30−

31−### Cabal users

32−

33−GHC version can be chosen via the nix-shell parameter

34−

35−`cabal build all`

36−

37−### Stack version

38−

39−Since the ghc version is set by the LTS version, it is preferable to use the `ghc8104` version parameter for the nix-shell.

40−

41−`stack --no-nix --system-ghc <command>`

nix/nixpkgs.jsondeleted−4

@@ -1,4 +0,0 @@

1−{

2− "rev" : "05f0934825c2a0750d4888c4735f9420c906b388",

3− "sha256" : "1g8c2w0661qn89ajp44znmwfmghbbiygvdzq0rzlvlpdiz28v6gy"

4−}

nix/nixpkgs.nixdeleted−4

@@ -1,4 +0,0 @@

1−import (builtins.fetchTarball {

2− url = "https://github.com/NixOS/nixpkgs/archive/refs/tags/21.05.tar.gz";

3− sha256 = "sha256:1ckzhh24mgz6jd1xhfgx0i9mijk6xjqxwsshnvq789xsavrmsc36";

4−}) {}

nix/shell.nixdeleted−20

@@ -1,20 +0,0 @@

1−{ compiler ? "ghc8104"

2−, tutorial ? false

3−, pkgs ? import ./nixpkgs.nix

4−}:

5−

6− with pkgs;

7−

8− let

9− ghc = haskell.packages.${compiler}.ghcWithPackages (_: []);

10− docstuffs = python3.withPackages (ps: with ps; [ recommonmark sphinx sphinx_rtd_theme ]);

11− in

12− stdenv.mkDerivation {

13− name = "servant-dev";

14− buildInputs = [ ghc zlib python3 wget cabal-install postgresql openssl stack haskellPackages.hspec-discover ]

15− ++ (if tutorial then [docstuffs postgresql] else []);

16− shellHook = ''

17− eval $(grep export ${ghc}/bin/ghc)

18− export LD_LIBRARY_PATH=$LD_LIBRARY_PATH:"${zlib}/lib";

19− '';

20− }

scripts/README.mdnew file+8

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

1+The release process works roughly like this:

3+``` bash

4+./scripts/bump-versions.sh <type-of-bump>

5+git commit

6+./scripts/upload.sh <hackage-usr> <hackage-pwd>

7+git tag <version> && git push --tags

8+```

scripts/bump-versions.shnew file+65

@@ -0,0 +1,65 @@

1+#!/usr/bin/env bash

2+#===============================================================================

3+#

4+# FILE: bump-versions.sh

5+#

6+# USAGE: ./bump-versions.sh

7+#

8+# DESCRIPTION: Bump the versions for all servant packages

9+#

10+# OPTIONS: See usage

11+# REQUIREMENTS: bumper, bash >= 4

12+# CREATED: 11.05.2015 21:36

13+# REVISION: ---

14+#===============================================================================

15+

16+set -o nounset

17+set -o errexit

18+

19+DIR=$( dirname $( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd ))

20+. "${DIR}/scripts/lib/common.sh"

21+

22+usage () {

23+ echo " bump-versions.sh <POSITION> [-d|--dry-run]"

24+ echo " | [-h|--help]"

25+ echo " Bumps the specified positional version of all servant packages."

26+ echo " POSITION is a number between 0 and 3, inclusive."

27+ exit 0

28+}

29+

30+if [ $# -eq 0 ] ; then

31+ echo "expecting one or more arguments. Got 0"

32+ usage

33+elif [ $# -gt 2 ] ; then

34+ echo "expecting one or more arguments"

35+ usage

36+fi

37+

38+versions_equal

39+

40+while [ "${1:-unset}" != "unset" ] ; do

41+ case "$1" in

42+ -h | --help) usage ;;

43+ -d | --dry-run) DRY_RUN=true

44+ shift ;;

45+ 0) if POSITION="none" ; then POSITION=0 ; else usage ; fi

46+ shift ;;

47+ 1) if POSITION="none" ; then POSITION=1 ; else usage ; fi

48+ shift ;;

49+ 2) if POSITION="none" ; then POSITION=2 ; else usage ; fi

50+ shift ;;

51+ 3) if POSITION="none" ; then POSITION=3 ; else usage ; fi

52+ shift ;;

53+ *) usage ;;

54+ esac

55+done

56+

57+if $DRY_RUN ; then

58+ echo "Would have bumped position ${POSITION} on these packages:"

59+ ( cd "$ROOT" && bumper --dry-run -"$POSITION" $(join , "${SOURCES[@]}") )

60+else

61+ ( cd "$ROOT" && bumper -"$POSITION" $(join , "${SOURCES[@]}") )

62+fi

63+

64+# Trailing newline, bumper does not ship with its own.

65+echo

scripts/clear-sandbox.shnew file+26

@@ -0,0 +1,26 @@

1+#!/usr/bin/env bash

2+#===============================================================================

3+#

4+# FILE: clear-sandbox.sh

5+#

6+# USAGE: ./clear-sandbox.sh

7+#

8+# DESCRIPTION: Clear sandbox at top-level and at all packages

9+#

10+# REQUIREMENTS: bash >= 4

11+#===============================================================================

12+

13+set -o nounset

14+set -o errexit

15+

16+DIR=$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )

17+. "$DIR"/lib/common.sh

18+

19+clear_sandbox () {

20+ rm -rf .cabal-sandbox cabal.sandbox.config

21+ for s in ${SOURCES[@]} ; do

22+ (cd "$s" && rm -rf cabal.sandbox.config dist)

23+ done

24+}

25+

26+clear_sandbox

scripts/generate-nix-files.shnew file+48

@@ -0,0 +1,48 @@

1+#!/usr/bin/env bash

2+#===============================================================================

3+#

4+# FILE: generate-nix-files.sh

5+#

6+# USAGE: ./generate-nix-files.sh

7+#

8+# DESCRIPTION: Update nix files at top-level and add all packages

9+#

10+# REQUIREMENTS: bash >= 4, cabal2nix(nix tool)

11+#===============================================================================

12+

13+set -o nounset

14+set -o errexit

15+

16+DIR=$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )

17+. "$DIR"/lib/common.sh

18+SHELLNIX="shell.nix"

19+

20+write-package-shell-nix () {

21+ rm -rf $SHELLNIX

22+ echo -e "let" >> $SHELLNIX

23+ echo -e " pkgs = import <nixpkgs> {};" >> $SHELLNIX

24+ echo -e "" >> $SHELLNIX

25+ echo -e " haskellPackages = pkgs.haskellPackages.override {" >> $SHELLNIX

26+ echo -e " overrides = self: super: {" >> $SHELLNIX

27+ for n in ${SOURCES[@]} ; do

28+ if [[ $1 != $n ]]; then

29+ echo -e " $n = pkgs.haskell.lib.dontCheck (pkgs.haskell.lib.appendConfigureFlag (self.callPackage ../$n {}) \"--ghc-options=-Werror\");" >> $SHELLNIX

30+ fi

31+ done

32+ echo -e " $1 = pkgs.haskell.lib.appendConfigureFlag (self.callPackage ./. {}) \"--ghc-options=-Werror\";" >> $SHELLNIX

33+ echo -e " };" >> $SHELLNIX

34+ echo -e " };" >> $SHELLNIX

35+ echo -e "" >> $SHELLNIX

36+ echo -e "in haskellPackages.$s.env" >> $SHELLNIX

37+}

38+

39+update-nix-files () {

40+ for s in ${SOURCES[@]} ; do

41+ pushd "$s" > /dev/null

42+ cabal2nix . > default.nix

43+ write-package-shell-nix $s

44+ popd > /dev/null

45+ done

46+}

47+

48+update-nix-files

scripts/lib/common.shnew file+56

@@ -0,0 +1,56 @@

1+#!/bin/bash -

2+#===============================================================================

3+#

4+# FILE: lib/common.sh

5+#

6+# DESCRIPTION: Common functions for servant's shell scripts

7+# Meant to be sourced rather than run.

8+#

9+# REQUIREMENTS: bash >= 4

10+#===============================================================================

11+

12+

13+DIR=$( dirname $( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd ))

14+ROOT=$( dirname $DIR )

15+DRY_RUN=false

16+POSITION="none"

17+SOURCES_TXT="$( dirname $DIR)/sources.txt"

18+CABAL=${CABAL:-cabal}

19+TRAVIS=${TRAVIS:-false}

20+

21+declare -a SOURCES

22+SOURCES=$(awk -F= '{print $1}' "$SOURCES_TXT")

23+

24+join () { local IFS="$1"; shift; echo "$*"; }

25+

26+versions_equal () {

27+ local NUM=$(cd "$ROOT" && find . -name 'servant*.cabal' | xargs grep "^version:" | awk '{ print $2 }' | uniq -c | wc -l)

28+ if [ 1 -eq $NUM ] ; then

29+ return 0

30+ else

31+ echo "versions of packages are not all the same!" && exit 1

32+ fi

33+}

34+

35+travis_retry() {

36+ # From

37+ # https://github.com/travis-ci/travis-build/blob/18bd04e965b9bfaa49cd6bdcd8dcb1513b8d2fcd/lib/travis/build/templates/header.sh

38+ local result=0

39+ local count=1

40+ while [ $count -le 3 ]; do

41+ [ $result -ne 0 ] && {

42+ echo -e "\n${ANSI_RED}The command \"$@\" failed. Retrying, $count of 3.${ANSI_RESET}\n" >&2

43+ }

44+ "$@"

45+ result=$?

46+ [ $result -eq 0 ] && break

47+ count=$(($count + 1))

48+ sleep 1

49+ done

50+

51+ [ $count -gt 3 ] && {

52+ echo -e "\n${ANSI_RED}The command \"$@\" failed 3 times.${ANSI_RESET}\n" >&2

53+ }

54+

55+ return $result

56+}

scripts/start-sandbox.shnew file+26

@@ -0,0 +1,26 @@

1+#!/usr/bin/env bash

2+#===============================================================================

3+#

4+# FILE: start-sandbox.sh

5+#

6+# USAGE: ./start-sandbox.sh

7+#

8+# DESCRIPTION: Create sandbox at top-level and add all packages as add-source

9+#

10+# REQUIREMENTS: bash >= 4

11+#===============================================================================

12+

13+set -o nounset

14+set -o errexit

15+

16+DIR=$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )

17+. "$DIR"/lib/common.sh

18+

19+prepare_sandbox () {

20+ $CABAL sandbox init

21+ for s in ${SOURCES[@]} ; do

22+ (cd "$s" && $CABAL sandbox init --sandbox=../.cabal-sandbox && $CABAL sandbox add-source .)

23+ done

24+}

25+

26+prepare_sandbox

scripts/test-all.shnew file+46

@@ -0,0 +1,46 @@

1+#!/usr/bin/env bash

2+#===============================================================================

3+#

4+# FILE: test-all.sh

5+#

6+# USAGE: ./test-all.sh

7+#

8+# DESCRIPTION: Run tests for all source directories listed in $SOURCES.

9+# Uses local versions of those sources.

10+#

11+# REQUIREMENTS: bash >= 4

12+#===============================================================================

13+

14+set -o nounset

15+set -o errexit

16+

17+DIR=$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )

18+. "$DIR"/lib/common.sh

19+

20+GHC_FLAGS="-Werror"

21+

22+prepare_sandbox () {

23+ $CABAL sandbox init

24+ for s in ${SOURCES[@]} ; do

25+ (cd "$s" && $CABAL sandbox init --sandbox=../.cabal-sandbox/ && $CABAL sandbox add-source .)

26+ done

27+ if $TRAVIS ; then

28+ travis_retry $CABAL install --enable-tests ${SOURCES[@]}

29+ else

30+ $CABAL install --max-backjumps -1 --reorder-goals --enable-tests ${SOURCES[@]}

31+ fi

32+}

33+

34+test_each () {

35+ for s in ${SOURCES[@]} ; do

36+ echo "Testing $s..."

37+ pushd "$s"

38+ $CABAL configure --enable-tests --ghc-options="$GHC_FLAGS"

39+ $CABAL build

40+ $CABAL test

41+ popd

42+ done

43+}

44+

45+prepare_sandbox

46+test_each

scripts/upload.shnew file+52

@@ -0,0 +1,52 @@

1+#!/usr/bin/env bash

2+#===============================================================================

3+#

4+# FILE: upload.sh

5+#

6+# USAGE: ./upload.sh <USER> <PASSWORD>

7+#

8+# DESCRIPTION: Uploads all servant packages to Hackage

9+#

10+# REQUIREMENTS: cabal, bash >= 4

11+# AUTHOR: Julian K. Arni

12+# CREATED: 05.06.2015 13:05

13+#===============================================================================

14+

15+set -o nounset

16+set -o errexit

17+

18+DIR=$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )

19+. "$DIR"/lib/common.sh

20+

21+usage () {

22+ echo " upload.sh <USER> <PASSWORD>"

23+ echo " Uploads all servant packages to Hackage"

24+ exit 0

25+}

26+

27+

28+upload_package () {

29+ local package="$1"

30+ local user="$2"

31+ local pass="$3"

32+ local cabalFile="$package.cabal"

33+ pushd "$package"

34+ local version=$(grep -i '^version:' $cabalFile | awk '{ print $2 }')

35+ local sdist="dist/${package}-${version}.tar.gz"

36+ cabal sdist

37+ echo "User is: $user"

38+ cabal upload --user="$user" --password="$pass" "$sdist"

39+ popd

40+}

41+

42+

43+if [ $# -ne 2 ] ; then

44+ echo "expecting two arguments."

45+ usage

46+fi

47+

48+versions_equal

49+

50+for s in ${SOURCES[@]} ; do

51+ upload_package "$s" "$1" "$2"

52+done

servant-auth/README.mddeleted−1

@@ -1 +0,0 @@

1−servant-auth-server/README.lhs

servant-auth/servant-auth-client/.ghcideleted−1

@@ -1 +0,0 @@

1−:set -isrc -itest -idoctest/ghci-wrapper/src

servant-auth/servant-auth-client/CHANGELOG.mddeleted−26

@@ -1,26 +0,0 @@

1−# Changelog

2−

3−All notable changes to this project will be documented in this file.

4−

5−The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/)

6−and this project adheres to [PVP Versioning](https://pvp.haskell.org/).

7−

8−## [Unreleased]

9−

10−## [0.4.1.0] - 2020-10-06

11−

12−- Support generic Bearer token auth

13−

14−## [0.4.0.0] - 2019-03-08

15−

16−## Changed

17−

18−- #145 Support servant-0.16 in tests @domenkozar

19−- #145 Drop GHC 7.10 support @domenkozar

20−

21−## [0.3.3.0] - 2018-06-18

22−

23−### Added

24−- Support for GHC 8.4 by @phadej

25−- Support for servant-0.14 by @phadej

26−- Changelog by @domenkozar

servant-auth/servant-auth-client/servant-auth-client.cabaldeleted−80

@@ -1,80 +0,0 @@

1−cabal-version: 2.2

2−name: servant-auth-client

3−version: 0.4.1.0

4−synopsis: servant-client/servant-auth compatibility

5−description: This package provides instances that allow generating clients from

6− <https://hackage.haskell.org/package/servant servant>

7− APIs that use

8− <https://hackage.haskell.org/package/servant-auth servant-auth's> @Auth@ combinator.

9− .

10− For a quick overview of the usage, see the <https://github.com/haskell-servant/servant/tree/master/servant-auth#readme README>.

11−category: Web, Servant, Authentication

12−homepage: https://github.com/haskell-servant/servant/tree/master/servant-auth#readme

13−bug-reports: https://github.com/haskell-servant/servant/issues

14−author: Julian K. Arni

15−maintainer: jkarni@gmail.com

16−copyright: (c) Julian K. Arni

17−license: BSD-3-Clause

18−license-file: LICENSE

19−tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1

20−build-type: Simple

21−extra-source-files:

22− CHANGELOG.md

23−

24−source-repository head

25− type: git

26− location: https://github.com/haskell-servant/servant

27−

28−library

29− hs-source-dirs:

30− src

31− default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators

32− ghc-options: -Wall

33− build-depends:

34− base >= 4.10 && < 4.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.hsdeleted−3

@@ -1,3 +0,0 @@

1−module Servant.Auth.Client (Token(..), Bearer) where

2−

3−import Servant.Auth.Client.Internal (Bearer, Token(..))

servant-auth/servant-auth-client/src/Servant/Auth/Client/Internal.hsdeleted−64

@@ -1,64 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

3−{-# LANGUAGE UndecidableInstances #-}

4−{-# OPTIONS_GHC -fno-warn-orphans #-}

5−#if __GLASGOW_HASKELL__ == 800

6−{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}

7−#endif

8−module Servant.Auth.Client.Internal where

9−

10−import qualified Data.ByteString as BS

11−import Data.Monoid

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

13−import Data.String (IsString)

14−import GHC.Exts (Constraint)

15−import GHC.Generics (Generic)

16−import Servant.API ((:>))

17−import Servant.Auth

18−

19−import Servant.Client.Core

20−import Data.Sequence ((<|))

21−

22−-- | A simple bearer token.

23−newtype Token = Token { getToken :: BS.ByteString }

24− deriving (Eq, Show, Read, Generic, IsString)

25−

26−type family HasBearer xs :: Constraint where

27− HasBearer (Bearer ': xs) = ()

28− HasBearer (JWT ': xs) = ()

29− HasBearer (x ': xs) = HasBearer xs

30− HasBearer '[] = BearerAuthNotEnabled

31−

32−class BearerAuthNotEnabled

33−

34−-- | @'HasBearer' auths@ is nominally a redundant constraint, but ensures we're not

35−-- trying to send a token to an API that doesn't accept them.

36−instance (HasBearer auths, HasClient m api) => HasClient m (Auth auths a :> api) where

37− type Client m (Auth auths a :> api) = Token -> Client m api

38−

39− clientWithRoute m _ req (Token token)

40− = clientWithRoute m (Proxy :: Proxy api)

41− $ req { requestHeaders = ("Authorization", headerVal) <| requestHeaders req }

42− where

43− headerVal = "Bearer " <> token

44−

45−#if MIN_VERSION_servant_client_core(0,14,0)

46− hoistClientMonad pm _ nt cl = hoistClientMonad pm (Proxy :: Proxy api) nt . cl

47−#endif

48−

49−

50−-- * Authentication combinators

51−

52−-- | A Bearer token in the Authorization header:

53−--

54−-- @Authorization: Bearer <token>@

55−--

56−-- This can be any token recognized by the server, for example,

57−-- a JSON Web Token (JWT).

58−--

59−-- Note that, since the exact way the token is validated is not specified,

60−-- this combinator can only be used in the client. The server would not know

61−-- how to validate it, while the client does not care.

62−-- If you want to implement Bearer authentication in your server, you have to

63−-- choose a specific combinator, such as 'JWT'.

64−data Bearer

servant-auth/servant-auth-client/test/Servant/Auth/ClientSpec.hsdeleted−161

@@ -1,161 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE DeriveAnyClass #-}

3−module Servant.Auth.ClientSpec (spec) where

4−

5−import Crypto.JOSE (JWK,

6− KeyMaterialGenParam (OctGenParam),

7− genJWK)

8−import Data.Aeson (FromJSON (..), ToJSON (..))

9−import qualified Data.ByteString.Lazy as BSL

10−import Data.Time (UTCTime, defaultTimeLocale,

11− parseTimeOrError)

12−import GHC.Generics (Generic)

13−import Network.HTTP.Client (Manager, defaultManagerSettings,

14− newManager)

15−import Network.HTTP.Types (status401)

16−import Network.Wai.Handler.Warp (testWithApplication)

17−import Servant

18−import Servant.Client (BaseUrl (..), Scheme (Http),

19− ClientError (FailureResponse),

20−#if MIN_VERSION_servant_client(0,16,0)

21− ResponseF(..),

22−#elif MIN_VERSION_servant_client(0,13,0)

23− GenResponse(..),

24−#elif MIN_VERSION_servant_client(0,12,0)

25− Response(..),

26−#endif

27− client)

28−import System.IO.Unsafe (unsafePerformIO)

29−import Test.Hspec

30−import Test.QuickCheck

31−

32−#if MIN_VERSION_servant_client(0,13,0)

33−import Servant.Client (mkClientEnv, runClientM)

34−#elif MIN_VERSION_servant_client(0,9,0)

35−import Servant.Client (ClientEnv (..), runClientM)

36−#else

37−import Control.Monad.Trans.Except (runExceptT)

38−#endif

39−#if !MIN_VERSION_servant_server(0,16,0)

40−#define ClientError ServantError

41−#endif

42−

43−import Servant.Auth.Client

44−import Servant.Auth.Server

45−import Servant.Auth.Server.SetCookieOrphan ()

46−

47−spec :: Spec

48−spec = describe "The JWT combinator" $ do

49− hasClientSpec

50−

51−

52−------------------------------------------------------------------------------

53−-- * HasClient {{{

54−

55−hasClientSpec :: Spec

56−hasClientSpec = describe "HasClient" $ around (testWithApplication $ return app) $ do

57−

58− let mkTok :: User -> Maybe UTCTime -> IO Token

59− mkTok user mexp = do

60− Right tok <- makeJWT user jwtCfg mexp

61− return $ Token $ BSL.toStrict tok

62−

63− it "succeeds when the token does not have expiry" $ \port -> property $ \user -> do

64− tok <- mkTok user Nothing

65− v <- getIntClient tok mgr (BaseUrl Http "localhost" port "")

66− v `shouldBe` Right (length $ name user)

67−

68− it "succeeds when the token is not expired" $ \port -> property $ \user -> do

69− tok <- mkTok user (Just future)

70− v <- getIntClient tok mgr (BaseUrl Http "localhost" port "")

71− v `shouldBe` Right (length $ name user)

72−

73− it "fails when token is expired" $ \port -> property $ \user -> do

74− tok <- mkTok user (Just past)

75−#if MIN_VERSION_servant_client(0,16,0)

76− Left (FailureResponse _ (Response stat _ _ _))

77−#elif MIN_VERSION_servant_client(0,12,0)

78− Left (FailureResponse (Response stat _ _ _))

79−#elif MIN_VERSION_servant_client(0,11,0)

80− Left (FailureResponse _ stat _ _)

81−#else

82− Left (FailureResponse stat _ _)

83−#endif

84− <- getIntClient tok mgr (BaseUrl Http "localhost" port "")

85− stat `shouldBe` status401

86−

87−

88−getIntClient :: Token -> Manager -> BaseUrl -> IO (Either ClientError Int)

89−#if MIN_VERSION_servant(0,13,0)

90−getIntClient tok m burl = runClientM (client api tok) (mkClientEnv m burl)

91−#elif MIN_VERSION_servant(0,9,0)

92−getIntClient tok m burl = runClientM (client api tok) (ClientEnv m burl)

93−#else

94−getIntClient tok m burl = runExceptT $ client api tok m burl

95−#endif

96−-- }}}

97−------------------------------------------------------------------------------

98−-- * API and Server {{{

99−

100−type API = Auth '[JWT] User :> Get '[JSON] Int

101−

102−api :: Proxy API

103−api = Proxy

104−

105−theKey :: JWK

106−theKey = unsafePerformIO . genJWK $ OctGenParam 256

107−{-# NOINLINE theKey #-}

108−

109−mgr :: Manager

110−mgr = unsafePerformIO $ newManager defaultManagerSettings

111−{-# NOINLINE mgr #-}

112−

113−app :: Application

114−app = serveWithContext api ctx server

115− where

116− ctx = cookieCfg :. jwtCfg :. EmptyContext

117−

118−jwtCfg :: JWTSettings

119−jwtCfg = defaultJWTSettings theKey

120−

121−cookieCfg :: CookieSettings

122−cookieCfg = defaultCookieSettings

123−

124−

125−server :: Server API

126−server = getInt

127− where

128− getInt :: AuthResult User -> Handler Int

129− getInt (Authenticated u) = return . length $ name u

130− getInt _ = throwAll err401

131−

132−

133−-- }}}

134−------------------------------------------------------------------------------

135−-- * Utils {{{

136−

137−past :: UTCTime

138−past = parseTimeOrError True defaultTimeLocale "%Y-%m-%d" "1970-01-01"

139−

140−future :: UTCTime

141−future = parseTimeOrError True defaultTimeLocale "%Y-%m-%d" "2070-01-01"

142−

143−

144−-- }}}

145−------------------------------------------------------------------------------

146−-- * Types {{{

147−

148−data User = User

149− { name :: String

150− , _id :: String

151− } deriving (Eq, Show, Read, Generic)

152−

153−instance FromJWT User

154−instance ToJWT User

155−instance FromJSON User

156−instance ToJSON User

157−

158−instance Arbitrary User where

159− arbitrary = User <$> arbitrary <*> arbitrary

160−

161−-- }}}

servant-auth/servant-auth-docs/.ghcideleted−1

@@ -1 +0,0 @@

1−:set -isrc -itest -idoctest/ghci-wrapper/src

servant-auth/servant-auth-docs/CHANGELOG.mddeleted−14

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

1−# Changelog

2−

3−All notable changes to this project will be documented in this file.

4−

5−The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/)

6−and this project adheres to [PVP Versioning](https://pvp.haskell.org/).

7−

8−## [Unreleased]

9−

10−## [0.2.10.0] - 2018-06-18

11−

12−### Added

13−- Support for GHC 8.4 by @phadej

14−- Changelog by @domenkozar

servant-auth/servant-auth-docs/Setup.hsdeleted−33

@@ -1,33 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# OPTIONS_GHC -Wall #-}

3−module Main (main) where

4−

5−#ifndef MIN_VERSION_cabal_doctest

6−#define MIN_VERSION_cabal_doctest(x,y,z) 0

7−#endif

8−

9−#if MIN_VERSION_cabal_doctest(1,0,0)

10−

11−import Distribution.Extra.Doctest ( defaultMainWithDoctests )

12−main :: IO ()

13−main = defaultMainWithDoctests "doctests"

14−

15−#else

16−

17−#ifdef MIN_VERSION_Cabal

18−-- If the macro is defined, we have new cabal-install,

19−-- but for some reason we don't have cabal-doctest in package-db

20−--

21−-- Probably we are running cabal sdist, when otherwise using new-build

22−-- workflow

23−#warning You are configuring this package without cabal-doctest installed. \

24− The doctests test-suite will not work as a result. \

25− To fix this, install cabal-doctest before configuring.

26−#endif

27−

28−import Distribution.Simple

29−

30−main :: IO ()

31−main = defaultMain

32−

33−#endif

servant-auth/servant-auth-docs/servant-auth-docs.cabaldeleted−84

@@ -1,84 +0,0 @@

1−cabal-version: 2.2

2−name: servant-auth-docs

3−version: 0.2.10.0

4−synopsis: servant-docs/servant-auth compatibility

5−description: This package provides instances that allow generating docs from

6− <https://hackage.haskell.org/package/servant servant>

7− APIs that use

8− <https://hackage.haskell.org/package/servant-auth servant-auth's> @Auth@ combinator.

9− .

10− For a quick overview of the usage, see the <https://github.com/haskell-servant/servant/tree/master/servant-auth#readme README>.

11−category: Web, Servant, Authentication

12−homepage: https://github.com/haskell-servant/servant/tree/master/servant-auth#readme

13−bug-reports: https://github.com/haskell-servant/servant/issues

14−author: Julian K. Arni

15−maintainer: jkarni@gmail.com

16−copyright: (c) Julian K. Arni

17−license: BSD-3-Clause

18−license-file: LICENSE

19−tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1

20−build-type: Custom

21−extra-source-files:

22− CHANGELOG.md

23−

24−custom-setup

25− setup-depends:

26− base, Cabal, cabal-doctest >=1.0.6 && <1.1

27−

28−source-repository head

29− type: git

30− location: https://github.com/haskell-servant/servant

31−

32−library

33− hs-source-dirs:

34− src

35− default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators

36− ghc-options: -Wall

37− build-depends:

38− base >= 4.10 && < 4.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.hsdeleted−96

@@ -1,96 +0,0 @@

1−{-# OPTIONS_GHC -fno-warn-orphans #-}

2−module Servant.Auth.Docs

3− (

4− -- | The purpose of this package is provide the instance for 'servant-auth'

5− -- combinators needed for 'servant-docs' documentation generation.

6− --

7− -- >>> type API = Auth '[JWT, Cookie, BasicAuth] Int :> Get '[JSON] Int

8− -- >>> putStr $ markdown $ docs (Proxy :: Proxy API)

9− -- ## GET /

10− -- ...

11− -- ... Authentication

12− -- ...

13− -- This part of the API is protected by the following authentication mechanisms:

14− -- ...

15− -- * JSON Web Tokens ([JWTs](https://en.wikipedia.org/wiki/JSON_Web_Token))

16− -- * [Cookies](https://en.wikipedia.org/wiki/HTTP_cookie)

17− -- * [Basic Authentication](https://en.wikipedia.org/wiki/Basic_access_authentication)

18− -- ...

19− -- Clients must supply the following data

20− -- ...

21− -- One of the following:

22− -- ...

23− -- * A JWT Token signed with this server's key

24− -- * Cookies automatically set by browsers, plus a header

25− -- * Cookies automatically set by browsers, plus a header

26− -- ...

27−

28− -- * Re-export

29− JWT

30− , BasicAuth

31− , Cookie

32− , Auth

33− ) where

34−

35−import Control.Lens ((%~), (&), (|>))

36−import Data.List (intercalate)

37−import Data.Monoid

38−import Data.Proxy (Proxy (Proxy))

39−import Servant.API hiding (BasicAuth)

40−import Servant.Auth

41−import Servant.Docs hiding (pretty)

42−import Servant.Docs.Internal (DocAuthentication (..), authInfo)

43−

44−instance (AllDocs auths, HasDocs api) => HasDocs (Auth auths r :> api) where

45− docsFor _ (endpoint, action) =

46− docsFor (Proxy :: Proxy api) (endpoint, action & authInfo %~ (|> info))

47− where

48− (intro, reqData) = pretty $ allDocs (Proxy :: Proxy auths)

49− info = DocAuthentication intro reqData

50−

51−

52−pretty :: [(String, String)] -> (String, String)

53−pretty [] = error "shouldn't happen"

54−pretty [(i, d)] =

55− ( "This part of the API is protected by " <> i

56− , d

57− )

58−pretty rs =

59− ( "This part of the API is protected by the following authentication mechanisms:\n\n"

60− ++ " * " <> intercalate "\n * " (fst <$> rs)

61− , "\nOne of the following:\n\n"

62− ++ " * " <> intercalate "\n * " (snd <$> rs)

63− )

64−

65−

66−class AllDocs (x :: [*]) where

67− allDocs :: proxy x

68− -- intro, req

69− -> [(String, String)]

70−

71−instance (OneDoc a, AllDocs as) => AllDocs (a ': as) where

72− allDocs _ = oneDoc (Proxy :: Proxy a) : allDocs (Proxy :: Proxy as)

73−

74−instance AllDocs '[] where

75− allDocs _ = []

76−

77−class OneDoc a where

78− oneDoc :: proxy a -> (String, String)

79−

80−instance OneDoc JWT where

81− oneDoc _ =

82− ("JSON Web Tokens ([JWTs](https://en.wikipedia.org/wiki/JSON_Web_Token))"

83− , "A JWT Token signed with this server's key")

84−

85−instance OneDoc Cookie where

86− oneDoc _ =

87− ("[Cookies](https://en.wikipedia.org/wiki/HTTP_cookie)"

88− , "Cookies automatically set by browsers, plus a header")

89−

90−instance OneDoc BasicAuth where

91− oneDoc _ =

92− ( "[Basic Authentication](https://en.wikipedia.org/wiki/Basic_access_authentication)"

93− , "Cookies automatically set by browsers, plus a header")

94−

95−-- $setup

96−-- >>> instance ToSample Int where toSamples _ = singleSample 1729

servant-auth/servant-auth-docs/test/Spec.hsdeleted−1

@@ -1 +0,0 @@

1−{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

servant-auth/servant-auth-docs/test/doctests.hsdeleted−12

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

1−module Main where

2−

3−import Build_doctests (flags, pkgs, module_sources)

4−import Data.Foldable (traverse_)

5−import Test.DocTest

6−

7−main :: IO ()

8−main = do

9− traverse_ putStrLn args

10− doctest args

11− where

12− args = flags ++ pkgs ++ module_sources

servant-auth/servant-auth-server/.ghcideleted−1

@@ -1 +0,0 @@

1−:set -isrc -itest -idoctest/ghci-wrapper/src

servant-auth/servant-auth-server/CHANGELOG.mddeleted−130

@@ -1,130 +0,0 @@

1−# Changelog

2−

3−All notable changes to this project will be documented in this file.

4−

5−The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/)

6−and this project adheres to [PVP Versioning](https://pvp.haskell.org/).

7−

8−## [Unreleased]

9−

10−## [0.4.6.0] - 2020-10-06

11−

12−## Changed

13−

14−- expose verifyJWT and use it in two places [@domenkozar]

15−- support GHC 8.10 [@domenkozar]

16−- move ToJWT/FromJWT to servant-auth [@erewok]

17−- #165 fix AnySite with Cookie 3.5.0 [@odr]

18−

19−## [0.4.5.1] - 2020-02-06

20−

21−## Changed

22−

23−- #158 servant 0.17 support [@phadej]

24−

25−## [0.4.5.0] - 2019-12-28

26−

27−## Changed

28−- #144 servant 0.16 support and drop GHC 7.10 support [@domenkozar]

29−- #148 removed unused constaint in HasServer instance for Auth

30−- #154 GHC 8.8 support [@phadej]

31−

32−### Added

33−- #141 Support Stream combinator [@domenkozar]

34−- #143 Allow servant-0.16 [@phadej]

35−

36−## [0.4.4.0] - 2019-03-02

37−

38−### Added

39−- #141 Support Stream combinator [@domenkozar]

40−- #143 Allow servant-0.16 [@phadej]

41−

42−## [0.4.3.0] - 2019-01-17

43−

44−## Changed

45−- #117 Avoid running auth checks unnecessarily [@sopvop]

46−- #110 Get rid of crypto-api dependency [@domenkozar]

47−- #130 clearSession: improve cross-browser compatibility [@domenkozar]

48−- #136 weed out bytestring-conversion [@stephenirl]

49−

50−## [0.4.2.0] - 2018-11-05

51−

52−### Added

53−- `Headers hs a` instance for AddSetCookieApi [@domenkozar]

54−- GHC 8.6.x support [@domenkozar]

55−

56−## [0.4.1.0] - 2018-10-05

57−

58−### Added

59−- #125 Allow setting domain name for a cookie [@domenkozar]

60−

61−## Changed

62−- bump http-api-data to 0.3.10 that includes Cookie orphan instances previously located in servant-auth-server [@phadej]

63−- #114 Export `HasSecurity` typeclass [@rockbmb]

64−

65−## [0.4.0.1] - 2018-09-23

66−

67−### Security

68−- #123 Session cookie did not apply SameSite attribute [@domenkozar]

69−

70−### Added

71−- #112 HasLink instance for Auth combinator [@adetokunbo]

72−- #111 Documentation for using hoistServer [@mschristiansen]

73−- #107 Add utility functions for reading and writing a key to a file [@mschristiansen]

74−

75−## [0.4.0.0] - 2018-06-17

76−

77−### Added

78−- Support GHC 8.4 by @phadej and @domenkozar

79−- Support for servant-0.14 by @phadej

80−- #96 Support for jose-0.7 by @xaviershay

81−- #92 add `clearSession` for logout by @plredmond and @3noch

82−- #95 makeJWT: allow setting Alg via defaultJWTSettings by @domenkozar

83−- #89 Validate JWT against a JWKSet instead of JWK by @sopvop

84−

85−### Changed

86−- #92 Rename CSRF to XSRF by @plredmond and @3noch

87−- #92 extract 'XsrfCookieSettings' from 'CookieSettings' and make XSRF checking optional

88− by @plredmond and @3noch

89−- #69 export SameSite by @domenkozar

90−- #102 Reuse Servant.Api.IsSecure instead of duplicating ADT by @domenkozar

91−

92−### Deprecated

93−- #92 Renamed 'makeCsrfCookie' to 'makeXsrfCookie' and marked the former as deprecated

94− by @plredmond and @3noc

95−- #92 Made several changes to the structure of 'CookieSettings' which will require

96− attention by users who have modified the XSRF settings by @plredmond and @3noch

97−

98−### Security

99−- #94 Force cookie expiration on serverside by @karshan

100−

101−## [0.3.2.0] - 2018-02-21

102−

103−### Added

104−- #76 Export wwwAuthenticatedErr and elaborate its annotation by @defanor

105−- Support for servant-0.14 by @phadej

106−

107−### Changed

108−- Disable the readme executable for ghcjs builds by @hamishmack

109−- #84 Make AddSetCookieApi type family open by @qnikst

110−- #79 Make CSRF checks optional for GET requests by @harendra-kumar

111−

112−## [0.3.1.0] - 2017-11-08

113−

114−### Added

115−- Support for servant-0.12 by @phadej

116−

117−## [0.3.0.0] - 2017-11-07

118−

119−### Changed

120−- #47 'cookiePath' and 'xsrfCookiePath' added to 'CookieSettings' by @mchaver

121−

122−## [0.2.8.0] - 2017-05-26

123−

124−### Added

125−- #45 Support for servant-0.11 by @phadej

126−

127−## [0.2.7.0] - 2017-02-11

128−

129−### Changed

130−- #27 #41 'acceptLogin' and 'makeCsrfCookie' functions by @bts

servant-auth/servant-auth-server/README.lhsdeleted−291

@@ -1,291 +0,0 @@

1−# servant-auth

2−

3−These packages provides safe and easy-to-use authentication options for

4−`servant`. The same API can be protected via:

5−- basicauth

6−- cookies

7−- JWT tokens

8−

9−

10−| Package | Hackage |

11−| -------------------- | ----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- |

12−| servant-auth | [![servant-auth](https://img.shields.io/hackage/v/servant-auth?style=flat-square&logo=haskell&label&labelColor=5D4F85)](https://hackage.haskell.org/package/servant-auth) |

13−| servant-auth-server | [![servant-auth-server](https://img.shields.io/hackage/v/servant-auth-server.svg?style=flat-square&logo=haskell&label&labelColor=5D4F85)](https://hackage.haskell.org/package/servant-auth-server) |

14−| servant-auth-client | [![servant-auth-client](https://img.shields.io/hackage/v/servant-auth-client.svg?style=flat-square&logo=haskell&label&labelColor=5D4F85)](https://hackage.haskell.org/package/servant-auth-client) |

15−| servant-auth-swagger | [![servant-auth-swagger](https://img.shields.io/hackage/v/servant-auth-swagger.svg?style=flat-square&logo=haskell&label&labelColor=5D4F85)](https://hackage.haskell.org/package/servant-auth-swagger) |

16−| servant-auth-docs | [![servant-auth-docs](https://img.shields.io/hackage/v/servant-auth-docs.svg?style=flat-square&logo=haskell&label&labelColor=5D4F85)](https://hackage.haskell.org/package/servant-auth-docs) |

17−

18−## How it works

19−

20−First some imports:

21−

22−~~~ haskell

23−{-# OPTIONS_GHC -fno-warn-unused-binds #-}

24−{-# OPTIONS_GHC -fno-warn-deprecations #-}

25−import Control.Concurrent (forkIO)

26−import Control.Monad (forever)

27−import Control.Monad.Trans (liftIO)

28−import Data.Aeson (FromJSON, ToJSON)

29−import GHC.Generics (Generic)

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

31−import System.Environment (getArgs)

32−import Servant

33−import Servant.Auth.Server

34−import Servant.Auth.Server.SetCookieOrphan ()

35−~~~

36−

37−`servant-auth` library introduces a combinator `Auth`:

38−

39−~~~ haskell

40−data Auth (auths :: [*]) val

41−~~~

42−

43−What `Auth [Auth1, Auth2] Something :> API` means is that `API` is protected by

44−*either* `Auth1` *or* `Auth2`, and the result of authentication will be of type

45−`AuthResult Something`, where :

46−

47−~~~ haskell

48−data AuthResult val

49− = BadPassword

50− | NoSuchUser

51− | Authenticated val

52− | Indefinite

53−~~~

54−

55−Your handlers will get a value of type `AuthResult Something`, and can decide

56−what to do with it.

57−

58−~~~ haskell

59−

60−data User = User { name :: String, email :: String }

61− deriving (Eq, Show, Read, Generic)

62−

63−instance ToJSON User

64−instance ToJWT User

65−instance FromJSON User

66−instance FromJWT User

67−

68−data Login = Login { username :: String, password :: String }

69− deriving (Eq, Show, Read, Generic)

70−

71−instance ToJSON Login

72−instance FromJSON Login

73−

74−type Protected

75− = "name" :> Get '[JSON] String

76− :<|> "email" :> Get '[JSON] String

77−

78−

79−-- | 'Protected' will be protected by 'auths', which we still have to specify.

80−protected :: Servant.Auth.Server.AuthResult User -> Server Protected

81−-- If we get an "Authenticated v", we can trust the information in v, since

82−-- it was signed by a key we trust.

83−protected (Servant.Auth.Server.Authenticated user) = return (name user) :<|> return (email user)

84−-- Otherwise, we return a 401.

85−protected _ = throwAll err401

86−

87−type Unprotected =

88− "login"

89− :> ReqBody '[JSON] Login

90− :> Verb 'POST 204 '[JSON] (Headers '[ Header "Set-Cookie" SetCookie

91− , Header "Set-Cookie" SetCookie]

92− NoContent)

93− :<|> Raw

94−

95−unprotected :: CookieSettings -> JWTSettings -> Server Unprotected

96−unprotected cs jwts = checkCreds cs jwts :<|> serveDirectory "example/static"

97−

98−type API auths = (Servant.Auth.Server.Auth auths User :> Protected) :<|> Unprotected

99−

100−server :: CookieSettings -> JWTSettings -> Server (API auths)

101−server cs jwts = protected :<|> unprotected cs jwts

102−

103−~~~

104−

105−The code is common to all authentications. In order to pick one or more specific

106−authentication methods, all we need to do is provide the expect configuration

107−parameters.

108−

109−## API tokens

110−

111−The following example illustrates how to protect an API with tokens.

112−

113−

114−~~~ haskell

115−-- In main, we fork the server, and allow new tokens to be created in the

116−-- command line for the specified user name and email.

117−mainWithJWT :: IO ()

118−mainWithJWT = do

119− -- We generate the key for signing tokens. This would generally be persisted,

120− -- and kept safely

121− myKey <- generateKey

122− -- Adding some configurations. All authentications require CookieSettings to

123− -- be in the context.

124− let jwtCfg = defaultJWTSettings myKey

125− cfg = defaultCookieSettings :. jwtCfg :. EmptyContext

126− --- Here we actually make concrete

127− api = Proxy :: Proxy (API '[JWT])

128− _ <- forkIO $ run 7249 $ serveWithContext api cfg (server defaultCookieSettings jwtCfg)

129−

130− putStrLn "Started server on localhost:7249"

131− putStrLn "Enter name and email separated by a space for a new token"

132−

133− forever $ do

134− xs <- words <$> getLine

135− case xs of

136− [name', email'] -> do

137− etoken <- makeJWT (User name' email') jwtCfg Nothing

138− case etoken of

139− Left e -> putStrLn $ "Error generating token:t" ++ show e

140− Right v -> putStrLn $ "New token:\t" ++ show v

141− _ -> putStrLn "Expecting a name and email separated by spaces"

142−

143−~~~

144−

145−And indeed:

146−

147−~~~ bash

148−

149−./readme JWT

150−

151− Started server on localhost:7249

152− Enter name and email separated by a space for a new token

153− alice alice@gmail.com

154− New token: "eyJhbGciOiJIUzI1NiJ9.eyJkYXQiOnsiZW1haWwiOiJhbGljZUBnbWFpbC5jb20iLCJuYW1lIjoiYWxpY2UifX0.xzOIrx_A9VOKzVO-R1c1JYKBqK9risF625HOxpBzpzE"

155−

156−curl localhost:7249/name -v

157−

158− * Hostname was NOT found in DNS cache

159− * Trying 127.0.0.1...

160− * Connected to localhost (127.0.0.1) port 7249 (#0)

161− > GET /name HTTP/1.1

162− > User-Agent: curl/7.35.0

163− > Host: localhost:7249

164− > Accept: */*

165− >

166− < HTTP/1.1 401 Unauthorized

167− < Transfer-Encoding: chunked

168− < Date: Wed, 07 Sep 2016 20:17:17 GMT

169− * Server Warp/3.2.7 is not blacklisted

170− < Server: Warp/3.2.7

171− <

172− * Connection #0 to host localhost left intact

173−

174−curl -H "Authorization: Bearer eyJhbGciOiJIUzI1NiJ9.eyJkYXQiOnsiZW1haWwiOiJhbGljZUBnbWFpbC5jb20iLCJuYW1lIjoiYWxpY2UifX0.xzOIrx_A9VOKzVO-R1c1JYKBqK9risF625HOxpBzpzE" \

175− localhost:7249/name -v

176−

177− * Hostname was NOT found in DNS cache

178− * Trying 127.0.0.1...

179− * Connected to localhost (127.0.0.1) port 7249 (#0)

180− > GET /name HTTP/1.1

181− > User-Agent: curl/7.35.0

182− > Host: localhost:7249

183− > Accept: */*

184− > Authorization: Bearer eyJhbGciOiJIUzI1NiJ9.eyJkYXQiOnsiZW1haWwiOiJhbGljZUBnbWFpbC5jb20iLCJuYW1lIjoiYWxpY2UifX0.xzOIrx_A9VOKzVO-R1c1JYKBqK9risF625HOxpBzpzE

185− >

186− < HTTP/1.1 200 OK

187− < Transfer-Encoding: chunked

188− < Date: Wed, 07 Sep 2016 20:16:11 GMT

189− * Server Warp/3.2.7 is not blacklisted

190− < Server: Warp/3.2.7

191− < Content-Type: application/json

192− < Set-Cookie: JWT-Cookie=eyJhbGciOiJIUzI1NiJ9.eyJkYXQiOnsiZW1haWwiOiJhbGljZUBnbWFpbC5jb20iLCJuYW1lIjoiYWxpY2UifX0.xzOIrx_A9VOKzVO-R1c1JYKBqK9risF625HOxpBzpzE; HttpOnly; Secure

193− < Set-Cookie: XSRF-TOKEN=TWcdPnHr2QHcVyTw/TTBLQ==; Secure

194− <

195− * Connection #0 to host localhost left intact

196− "alice"%

197−

198−

199−~~~

200−

201−## Cookies

202−

203−What if, in addition to API tokens, we want to expose our API to browsers? All

204−we need to do is say so!

205−

206−~~~ haskell

207−mainWithCookies :: IO ()

208−mainWithCookies = do

209− -- We *also* need a key to sign the cookies

210− myKey <- generateKey

211− -- Adding some configurations. 'Cookie' requires, in addition to

212− -- CookieSettings, JWTSettings (for signing), so everything is just as before

213− let jwtCfg = defaultJWTSettings myKey

214− cfg = defaultCookieSettings :. jwtCfg :. EmptyContext

215− --- Here is the actual change

216− api = Proxy :: Proxy (API '[Cookie])

217− run 7249 $ serveWithContext api cfg (server defaultCookieSettings jwtCfg)

218−

219−-- Here is the login handler

220−checkCreds :: CookieSettings

221− -> JWTSettings

222− -> Login

223− -> Handler (Headers '[ Header "Set-Cookie" SetCookie

224− , Header "Set-Cookie" SetCookie]

225− NoContent)

226−checkCreds cookieSettings jwtSettings (Login "Ali Baba" "Open Sesame") = do

227− -- Usually you would ask a database for the user info. This is just a

228− -- regular servant handler, so you can follow your normal database access

229− -- patterns (including using 'enter').

230− let usr = User "Ali Baba" "ali@email.com"

231− mApplyCookies <- liftIO $ acceptLogin cookieSettings jwtSettings usr

232− case mApplyCookies of

233− Nothing -> throwError err401

234− Just applyCookies -> return $ applyCookies NoContent

235−checkCreds _ _ _ = throwError err401

236−~~~

237−

238−### XSRF and the frontend

239−

240−XSRF protection works by requiring that there be a header of the same value as

241−a distinguished cookie that is set by the server on each request. What the

242−cookie and header name are can be configured (see `xsrfCookieName` and

243−`xsrfHeaderName` in `CookieSettings`), but by default they are "XSRF-TOKEN" and

244−"X-XSRF-TOKEN". This means that, if your client is a browser and you're using

245−cookies, Javascript on the client must set the header of each request by

246−reading the cookie. For jQuery, and with the default values, that might be:

247−

248−~~~ javascript

249−

250−var token = (function() {

251− r = document.cookie.match(new RegExp('XSRF-TOKEN=([^;]+)'))

252− if (r) return r[1];

253−})();

254−

255−

256−$.ajaxPrefilter(function(opts, origOpts, xhr) {

257− xhr.setRequestHeader('X-XSRF-TOKEN', token);

258− }

259−

260−~~~

261−

262−I *believe* nothing at all needs to be done if you're using Angular's `$http`

263−directive, but I haven't tested this.

264−

265−XSRF protection can be disabled just for `GET` requests by setting

266−`xsrfExcludeGet = False`. You might want this if you're relying on the browser

267−to navigate between pages that require cookie authentication.

268−

269−XSRF protection can be completely disabled by setting `cookieXsrfSetting =

270−Nothing` in `CookieSettings`. This is not recommended! If your cookie

271−authenticated web application runs any javascript, it's recommended to send the

272−XSRF header. However, if your web application runs no javascript, disabling

273−XSRF entirely may be required.

274−

275−# Note on this README

276−

277−This README is a literate haskell file. Here is 'main', allowing you to pick

278−between the examples above.

279−

280−~~~ haskell

281−

282−main :: IO ()

283−main = do

284− args <- getArgs

285− let usage = "Usage: readme (JWT|Cookie)"

286− case args of

287− ["JWT"] -> mainWithJWT

288− ["Cookie"] -> mainWithCookies

289− e -> putStrLn $ "Arguments: \"" ++ unwords e ++ "\" not understood\n" ++ usage

290−

291−~~~

servant-auth/servant-auth-server/README.mddeleted−1

@@ -1 +0,0 @@

1−README.lhs

servant-auth/servant-auth-server/Setup.hsdeleted−2

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

1−import Distribution.Simple

2−main = defaultMain

servant-auth/servant-auth-server/servant-auth-server.cabaldeleted−134

@@ -1,134 +0,0 @@

1−cabal-version: 2.2

2−name: servant-auth-server

3−version: 0.4.7.0

4−synopsis: servant-server/servant-auth compatibility

5−description: This package provides the required instances for using the @Auth@ combinator

6− in your 'servant' server.

7− .

8− Both cookie- and token- (REST API) based authentication is provided.

9− .

10− For a quick overview of the usage, see the <https://github.com/haskell-servant/servant/tree/master/servant-auth#readme README>.

11−category: Web, Servant, Authentication

12−homepage: https://github.com/haskell-servant/servant/tree/master/servant-auth#readme

13−bug-reports: https://github.com/haskell-servant/servant/issues

14−author: Julian K. Arni

15−maintainer: jkarni@gmail.com

16−copyright: (c) Julian K. Arni

17−license: BSD-3-Clause

18−license-file: LICENSE

19−tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1

20−build-type: Simple

21−extra-source-files:

22− CHANGELOG.md

23−

24−source-repository head

25− type: git

26− location: https://github.com/haskell-servant/servant

27−

28−library

29− hs-source-dirs:

30− src

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

@@ -1,180 +0,0 @@

1−module Servant.Auth.Server

2− (

3− -- | This package provides implementations for some common authentication

4− -- methods. Authentication yields a trustworthy (because generated by the

5− -- server) value of an some arbitrary type:

6− --

7− -- > type MyApi = Protected

8− -- >

9− -- > type Protected = Auth '[JWT, Cookie] User :> Get '[JSON] UserAccountDetails

10− -- >

11− -- > server :: Server Protected

12− -- > server (Authenticated usr) = ... -- here we know the client really is

13− -- > -- who she claims to be

14− -- > server _ = throwAll err401

15− --

16− -- Additional configuration happens via 'Context'.

17− --

18− -- == Example for Custom Handler

19− -- To use a custom 'Servant.Server.Handler' it is necessary to use

20− -- 'Servant.Server.hoistServerWithContext' instead of

21− -- 'Servant.Server.hoistServer' and specify the 'Context'.

22− --

23− -- Below is an example of passing 'CookieSettings' and 'JWTSettings' in the

24− -- 'Context' to create a specialized function equivalent to

25− -- 'Servant.Server.hoistServer' for an API that includes cookie

26− -- authentication.

27− --

28− -- > hoistServerWithAuth

29− -- > :: HasServer api '[CookieSettings, JWTSettings]

30− -- > => Proxy api

31− -- > -> (forall x. m x -> n x)

32− -- > -> ServerT api m

33− -- > -> ServerT api n

34− -- > hoistServerWithAuth api =

35− -- > hoistServerWithContext api (Proxy :: Proxy '[CookieSettings, JWTSettings])

36−

37− ----------------------------------------------------------------------------

38− -- * Auth

39− -- | Basic types

40− Auth

41− , AuthResult(..)

42− , AuthCheck(..)

43−

44− ----------------------------------------------------------------------------

45− -- * JWT

46− -- | JSON Web Tokens (JWT) are a compact and secure way of transferring

47− -- information between parties. In this library, they are signed by the

48− -- server (or by some other party posessing the relevant key), and used to

49− -- indicate the bearer's identity or authorization.

50− --

51− -- Arbitrary information can be encoded - just declare instances for the

52− -- 'FromJWT' and 'ToJWT' classes. Don't go overboard though - be aware that

53− -- usually you'll be trasmitting this information on each request (and

54− -- response!).

55− --

56− -- Note that, while the tokens are signed, they are not encrypted. Do not put

57− -- any information you do not wish the client to know in them!

58−

59− -- ** Combinator

60− -- | Re-exported from 'servant-auth'

61− , JWT

62−

63− -- ** Classes

64− , FromJWT(..)

65− , ToJWT(..)

66−

67− -- ** Related types

68− , IsMatch(..)

69−

70− -- ** Settings

71− , JWTSettings(..)

72− , defaultJWTSettings

73−

74− -- ** Create check

75− , jwtAuthCheck

76−

77−

78− ----------------------------------------------------------------------------

79− -- * Cookie

80− -- | Cookies are also a method of identifying and authenticating a user. They

81− -- are particular common when the client is a browser

82−

83− -- ** Combinator

84− -- | Re-exported from 'servant-auth'

85− , Cookie

86−

87− -- ** Settings

88− , CookieSettings(..)

89− , XsrfCookieSettings(..)

90− , defaultCookieSettings

91− , defaultXsrfCookieSettings

92− , makeSessionCookie

93− , makeSessionCookieBS

94− , makeXsrfCookie

95− , makeCsrfCookie

96− , makeCookie

97− , makeCookieBS

98− , acceptLogin

99− , clearSession

100−

101−

102− -- ** Related types

103− , IsSecure(..)

104− , SameSite(..)

105− , AreAuths

106−

107− ----------------------------------------------------------------------------

108− -- * BasicAuth

109− -- ** Combinator

110− -- | Re-exported from 'servant-auth'

111− , BasicAuth

112−

113− -- ** Classes

114− , FromBasicAuthData(..)

115−

116− -- ** Settings

117− , BasicAuthCfg

118−

119− -- ** Related types

120− , BasicAuthData(..)

121− , IsPasswordCorrect(..)

122−

123− -- ** Authentication request

124− , wwwAuthenticatedErr

125−

126− ----------------------------------------------------------------------------

127− -- * Utilies

128− , ThrowAll(throwAll)

129− , generateKey

130− , generateSecret

131− , fromSecret

132− , writeKey

133− , readKey

134− , makeJWT

135− , verifyJWT

136−

137− -- ** Re-exports

138− , Default(def)

139− , SetCookie

140− ) where

141−

142−import Prelude hiding (readFile, writeFile)

143−import Data.ByteString (ByteString, writeFile, readFile)

144−import Data.Default.Class (Default (def))

145−import Servant.Auth

146−import Servant.Auth.JWT

147−import Servant.Auth.Server.Internal ()

148−import Servant.Auth.Server.Internal.BasicAuth

149−import Servant.Auth.Server.Internal.Class

150−import Servant.Auth.Server.Internal.ConfigTypes

151−import Servant.Auth.Server.Internal.Cookie

152−import Servant.Auth.Server.Internal.JWT

153−import Servant.Auth.Server.Internal.ThrowAll

154−import Servant.Auth.Server.Internal.Types

155−

156−import Crypto.JOSE as Jose

157−import Servant (BasicAuthData (..))

158−import Web.Cookie (SetCookie)

159−

160−-- | Generate a key suitable for use with 'defaultConfig'.

161−generateKey :: IO Jose.JWK

162−generateKey = Jose.genJWK $ Jose.OctGenParam 256

163−

164−-- | Generate a bytestring suitable for use with 'fromSecret'.

165−generateSecret :: MonadRandom m => m ByteString

166−generateSecret = Jose.getRandomBytes 256

167−

168−-- | Restores a key from a bytestring.

169−fromSecret :: ByteString -> Jose.JWK

170−fromSecret = Jose.fromOctets

171−

172−-- | Writes a secret to a file. Can for instance be used from the REPL

173−-- to persist a key to a file, which can then be included with the

174−-- application. Restore the key using 'readKey'.

175−writeKey :: FilePath -> IO ()

176−writeKey fp = writeFile fp =<< generateSecret

177−

178−-- | Reads a key from a file.

179−readKey :: FilePath -> IO Jose.JWK

180−readKey fp = fromSecret <$> readFile fp

servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal.hsdeleted−70

@@ -1,70 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE UndecidableInstances #-}

3−{-# OPTIONS_GHC -fno-warn-orphans #-}

4−

5−module Servant.Auth.Server.Internal where

6−

7−import Control.Monad.Trans (liftIO)

8−import Servant ((:>), Handler, HasServer (..),

9− Proxy (..),

10− HasContextEntry(getContextEntry))

11−import Servant.Auth

12−import Servant.Auth.JWT (ToJWT)

13−

14−import Servant.Auth.Server.Internal.AddSetCookie

15−import Servant.Auth.Server.Internal.Class

16−import Servant.Auth.Server.Internal.Cookie

17−import Servant.Auth.Server.Internal.ConfigTypes

18−import Servant.Auth.Server.Internal.JWT

19−import Servant.Auth.Server.Internal.Types

20−

21−import Servant.Server.Internal (DelayedIO, addAuthCheck, withRequest)

22−

23−instance ( n ~ 'S ('S 'Z)

24− , HasServer (AddSetCookiesApi n api) ctxs, AreAuths auths ctxs v

25− , HasServer api ctxs -- this constraint is needed to implement hoistServer

26− , AddSetCookies n (ServerT api Handler) (ServerT (AddSetCookiesApi n api) Handler)

27− , ToJWT v

28− , HasContextEntry ctxs CookieSettings

29− , HasContextEntry ctxs JWTSettings

30− ) => HasServer (Auth auths v :> api) ctxs where

31− type ServerT (Auth auths v :> api) m = AuthResult v -> ServerT api m

32−

33−#if MIN_VERSION_servant_server(0,12,0)

34− hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s

35−#endif

36−

37− route _ context subserver =

38− route (Proxy :: Proxy (AddSetCookiesApi n api))

39− context

40− (fmap go subserver `addAuthCheck` authCheck)

41−

42− where

43− authCheck :: DelayedIO (AuthResult v, SetCookieList ('S ('S 'Z)))

44− authCheck = withRequest $ \req -> liftIO $ do

45− authResult <- runAuthCheck (runAuths (Proxy :: Proxy auths) context) req

46− cookies <- makeCookies authResult

47− return (authResult, cookies)

48−

49− jwtSettings :: JWTSettings

50− jwtSettings = getContextEntry context

51−

52− cookieSettings :: CookieSettings

53− cookieSettings = getContextEntry context

54−

55− makeCookies :: AuthResult v -> IO (SetCookieList ('S ('S 'Z)))

56− makeCookies authResult = do

57− 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.hsdeleted−106

@@ -1,106 +0,0 @@

1−{-# LANGUAGE PolyKinds #-}

2−{-# LANGUAGE TupleSections #-}

3−{-# LANGUAGE UndecidableInstances #-}

4−{-# LANGUAGE CPP #-}

5−

6−module Servant.Auth.Server.Internal.AddSetCookie where

7−

8−import Blaze.ByteString.Builder (toByteString)

9−import qualified Data.ByteString as BS

10−import Data.Tagged (Tagged (..))

11−import qualified Network.HTTP.Types as HTTP

12−import Network.Wai (mapResponseHeaders)

13−import Servant

14−import Servant.API.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.hsdeleted−59

@@ -1,59 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−module Servant.Auth.Server.Internal.BasicAuth where

3−

4−#if !MIN_VERSION_servant_server(0,16,0)

5−#define ServerError ServantErr

6−#endif

7−

8−import qualified Data.ByteString as BS

9−import Servant (BasicAuthData (..),

10− ServerError (..), err401)

11−import Servant.Server.Internal.BasicAuth (decodeBAHdr,

12− mkBAChallengerHdr)

13−

14−import Servant.Auth.Server.Internal.Types

15−

16−-- | A 'ServerError' that asks the client to authenticate via Basic

17−-- Authentication, should be invoked by an application whenever

18−-- appropriate. The argument is the realm.

19−wwwAuthenticatedErr :: BS.ByteString -> ServerError

20−wwwAuthenticatedErr realm = err401 { errHeaders = [mkBAChallengerHdr realm] }

21−

22−-- | A type holding the configuration for Basic Authentication.

23−-- It is defined as a type family with no arguments, so that

24−-- it can be instantiated to whatever type you need to

25−-- authenticate your users (use @type instance BasicAuthCfg = ...@).

26−--

27−-- Note that the instantiation is application-wide,

28−-- i.e. there can be only one instance.

29−-- As a consequence, it should not be instantiated in a library.

30−--

31−-- Basic Authentication expects an element of type 'BasicAuthCfg'

32−-- to be in the 'Context'; that element is then passed automatically

33−-- to the instance of 'FromBasicAuthData' together with the

34−-- authentication data obtained from the client.

35−--

36−-- If you do not need a configuration for Basic Authentication,

37−-- you can use just @BasicAuthCfg = ()@, and recall to also

38−-- add @()@ to the 'Context'.

39−-- A basic but more interesting example is to take as 'BasicAuthCfg'

40−-- a list of authorised username/password pairs:

41−--

42−-- > deriving instance Eq BasicAuthData

43−-- > type instance BasicAuthCfg = [BasicAuthData]

44−-- > instance FromBasicAuthData User where

45−-- > fromBasicAuthData authData authCfg =

46−-- > if elem authData authCfg then ...

47−type family BasicAuthCfg

48−

49−class FromBasicAuthData a where

50− -- | Whether the username exists and the password is correct.

51− -- Note that, rather than passing a 'Pass' to the function, we pass a

52− -- function that checks an 'EncryptedPass'. This is to make sure you don't

53− -- accidentally do something untoward with the password, like store it.

54− fromBasicAuthData :: BasicAuthData -> BasicAuthCfg -> IO (AuthResult a)

55−

56−basicAuthCheck :: FromBasicAuthData usr => BasicAuthCfg -> AuthCheck usr

57−basicAuthCheck cfg = AuthCheck $ \req -> case decodeBAHdr req of

58− Nothing -> return Indefinite

59− Just baData -> fromBasicAuthData baData cfg

servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/Class.hsdeleted−72

@@ -1,72 +0,0 @@

1−{-# LANGUAGE UndecidableInstances #-}

2−module Servant.Auth.Server.Internal.Class where

3−

4−import Servant.Auth

5−import Data.Monoid

6−import Servant hiding (BasicAuth)

7−

8−import Servant.Auth.JWT

9−import Servant.Auth.Server.Internal.Types

10−import Servant.Auth.Server.Internal.ConfigTypes

11−import Servant.Auth.Server.Internal.BasicAuth

12−import Servant.Auth.Server.Internal.Cookie

13−import Servant.Auth.Server.Internal.JWT (jwtAuthCheck)

14−

15−-- | @IsAuth a ctx v@ indicates that @a@ is an auth type that expects all

16−-- elements of @ctx@ to be the in the Context and whose authentication check

17−-- returns an @AuthCheck v@.

18−class IsAuth a v where

19− type family AuthArgs a :: [*]

20− runAuth :: proxy a -> proxy v -> Unapp (AuthArgs a) (AuthCheck v)

21−

22−instance FromJWT usr => IsAuth Cookie usr where

23− type AuthArgs Cookie = '[CookieSettings, JWTSettings]

24− runAuth _ _ = cookieAuthCheck

25−

26−instance FromJWT usr => IsAuth JWT usr where

27− type AuthArgs JWT = '[JWTSettings]

28− runAuth _ _ = jwtAuthCheck

29−

30−instance FromBasicAuthData usr => IsAuth BasicAuth usr where

31− type AuthArgs BasicAuth = '[BasicAuthCfg]

32− runAuth _ _ = basicAuthCheck

33−

34−-- * Helper

35−

36−class AreAuths (as :: [*]) (ctxs :: [*]) v where

37− runAuths :: proxy as -> Context ctxs -> AuthCheck v

38−

39−instance AreAuths '[] ctxs v where

40− runAuths _ _ = mempty

41−

42−instance ( AuthCheck v ~ App (AuthArgs a) (Unapp (AuthArgs a) (AuthCheck v))

43− , IsAuth a v

44− , AreAuths as ctxs v

45− , AppCtx ctxs (AuthArgs a) (Unapp (AuthArgs a) (AuthCheck v))

46− ) => AreAuths (a ': as) ctxs v where

47− runAuths _ ctxs = go <> runAuths (Proxy :: Proxy as) ctxs

48− where

49− go = appCtx (Proxy :: Proxy (AuthArgs a))

50− ctxs

51− (runAuth (Proxy :: Proxy a) (Proxy :: Proxy v))

52−

53−type family Unapp ls res where

54− Unapp '[] res = res

55− Unapp (arg1 ': rest) res = arg1 -> Unapp rest res

56−

57−type family App ls res where

58− App '[] res = res

59− App (arg1 ': rest) (arg1 -> res) = App rest res

60−

61−-- | @AppCtx@ applies the function @res@ to the arguments in @ls@ by taking the

62−-- values from the Context provided.

63−class AppCtx ctx ls res where

64− appCtx :: proxy ls -> Context ctx -> res -> App ls res

65−

66−instance ( HasContextEntry ctxs ctx

67− , AppCtx ctxs rest res

68− ) => AppCtx ctxs (ctx ': rest) (ctx -> res) where

69− appCtx _ ctx fn = appCtx (Proxy :: Proxy rest) ctx $ fn $ getContextEntry ctx

70−

71−instance AppCtx ctx '[] res where

72− appCtx _ _ r = r

servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/ConfigTypes.hsdeleted−127

@@ -1,127 +0,0 @@

1−module Servant.Auth.Server.Internal.ConfigTypes

2− ( module Servant.Auth.Server.Internal.ConfigTypes

3− , Servant.API.IsSecure(..)

4− ) where

5−

6−import Crypto.JOSE as Jose

7−import Crypto.JWT as Jose

8−import qualified Data.ByteString as BS

9−import Data.Default.Class

10−import Data.Time

11−import GHC.Generics (Generic)

12−import Servant.API (IsSecure(..))

13−

14−data IsMatch = Matches | DoesNotMatch

15− deriving (Eq, Show, Read, Generic, Ord)

16−

17−data IsPasswordCorrect = PasswordCorrect | PasswordIncorrect

18− deriving (Eq, Show, Read, Generic, Ord)

19−

20−-- The @SameSite@ attribute of cookies determines whether cookies will be sent

21−-- on cross-origin requests.

22−--

23−-- See <https://tools.ietf.org/html/draft-west-first-party-cookies-07 this document>

24−-- for more information.

25−data SameSite = AnySite | SameSiteStrict | SameSiteLax

26− deriving (Eq, Show, Read, Generic, Ord)

27−

28−-- | @JWTSettings@ are used to generate cookies, and to verify JWTs.

29−data JWTSettings = JWTSettings

30− {

31− -- | Key used to sign JWT.

32− signingKey :: Jose.JWK

33− -- | Algorithm used to sign JWT.

34− , jwtAlg :: Maybe Jose.Alg

35− -- | Keys used to validate JWT.

36− , validationKeys :: IO Jose.JWKSet

37− -- | An @aud@ predicate. The @aud@ is a string or URI that identifies the

38− -- intended recipient of the JWT.

39− , audienceMatches :: Jose.StringOrURI -> IsMatch

40− } deriving (Generic)

41−

42−-- | A @JWTSettings@ where the audience always matches.

43−defaultJWTSettings :: Jose.JWK -> JWTSettings

44−defaultJWTSettings k = JWTSettings

45− { signingKey = k

46− , jwtAlg = Nothing

47− , validationKeys = pure $ Jose.JWKSet [k]

48− , audienceMatches = const Matches }

49−

50−-- | The policies to use when generating cookies.

51−--

52−-- If *both* 'cookieMaxAge' and 'cookieExpires' are @Nothing@, browsers will

53−-- treat the cookie as a *session cookie*. These will be deleted when the

54−-- browser is closed.

55−--

56−-- Note that having the setting @Secure@ may cause testing failures if you are

57−-- not testing over HTTPS.

58−data CookieSettings = CookieSettings

59− {

60− -- | 'Secure' means browsers will only send cookies over HTTPS. Default:

61− -- @Secure@.

62− cookieIsSecure :: !IsSecure

63− -- | How long from now until the cookie expires. Default: @Nothing@.

64− , cookieMaxAge :: !(Maybe DiffTime)

65− -- | At what time the cookie expires. Default: @Nothing@.

66− , cookieExpires :: !(Maybe UTCTime)

67− -- | The URL path and sub-paths for which this cookie is used. Default: @Just "/"@.

68− , cookiePath :: !(Maybe BS.ByteString)

69− -- | Domain name, if set cookie also allows subdomains. Default: @Nothing@.

70− , cookieDomain :: !(Maybe BS.ByteString)

71− -- | 'SameSite' settings. Default: @SameSiteLax@.

72− , cookieSameSite :: !SameSite

73− -- | What name to use for the cookie used for the session.

74− , sessionCookieName :: !BS.ByteString

75− -- | The optional settings to use for XSRF protection. Default: @Just def@.

76− , cookieXsrfSetting :: !(Maybe XsrfCookieSettings)

77− } deriving (Eq, Show, Generic)

78−

79−instance Default CookieSettings where

80− def = defaultCookieSettings

81−

82−defaultCookieSettings :: CookieSettings

83−defaultCookieSettings = CookieSettings

84− { cookieIsSecure = Secure

85− , cookieMaxAge = Nothing

86− , cookieExpires = Nothing

87− , cookiePath = Just "/"

88− , cookieDomain = Nothing

89− , cookieSameSite = SameSiteLax

90− , sessionCookieName = "JWT-Cookie"

91− , cookieXsrfSetting = Just def

92− }

93−

94−-- | The policies to use when generating and verifying XSRF cookies

95−data XsrfCookieSettings = XsrfCookieSettings

96− {

97− -- | What name to use for the cookie used for XSRF protection.

98− xsrfCookieName :: !BS.ByteString

99− -- | What path to use for the cookie used for XSRF protection. Default @Just "/"@.

100− , xsrfCookiePath :: !(Maybe BS.ByteString)

101− -- | What name to use for the header used for XSRF protection.

102− , xsrfHeaderName :: !BS.ByteString

103− -- | Exclude GET request method from XSRF protection.

104− , xsrfExcludeGet :: !Bool

105− } deriving (Eq, Show, Generic)

106−

107−instance Default XsrfCookieSettings where

108− def = defaultXsrfCookieSettings

109−

110−defaultXsrfCookieSettings :: XsrfCookieSettings

111−defaultXsrfCookieSettings = XsrfCookieSettings

112− { xsrfCookieName = "XSRF-TOKEN"

113− , xsrfCookiePath = Just "/"

114− , xsrfHeaderName = "X-XSRF-TOKEN"

115− , xsrfExcludeGet = False

116− }

117−

118−------------------------------------------------------------------------------

119−-- Internal {{{

120−

121−jwtSettingsToJwtValidationSettings :: JWTSettings -> Jose.JWTValidationSettings

122−jwtSettingsToJwtValidationSettings s

123− = defaultJWTValidationSettings (toBool <$> audienceMatches s)

124− where

125− toBool Matches = True

126− toBool DoesNotMatch = False

127−-- }}}

servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/Cookie.hsdeleted−182

@@ -1,182 +0,0 @@

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

@@ -1,3 +0,0 @@

1−module Servant.Auth.Server.Internal.FormLogin where

2−

3−

servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/JWT.hsdeleted−72

@@ -1,72 +0,0 @@

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

@@ -1,58 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE UndecidableInstances #-}

3−module Servant.Auth.Server.Internal.ThrowAll where

4−

5−#if !MIN_VERSION_servant_server(0,16,0)

6−#define ServerError ServantErr

7−#endif

8−

9−import Control.Monad.Error.Class

10−import Data.Tagged (Tagged (..))

11−import Servant ((:<|>) (..), ServerError(..), NamedRoutes(..))

12−import Servant.API.Generic

13−import Servant.Server.Generic

14−import Servant.Server

15−import Network.HTTP.Types

16−import Network.Wai

17−

18−import qualified Data.ByteString.Char8 as BS

19−

20−class ThrowAll a where

21− -- | 'throwAll' is a convenience function to throw errors across an entire

22− -- sub-API

23− --

24− --

25− -- > throwAll err400 :: Handler a :<|> Handler b :<|> Handler c

26− -- > == throwError err400 :<|> throwError err400 :<|> err400

27− throwAll :: ServerError -> a

28−

29−instance (ThrowAll a, ThrowAll b) => ThrowAll (a :<|> b) where

30− throwAll e = throwAll e :<|> throwAll e

31−

32−instance

33− ( ThrowAll (ToServant api (AsServerT m)) , GenericServant api (AsServerT m)) =>

34− ThrowAll (api (AsServerT m)) where

35−

36− throwAll = fromServant . throwAll

37−

38−-- Really this shouldn't be necessary - ((->) a) should be an instance of

39−-- MonadError, no?

40−instance {-# OVERLAPPING #-} ThrowAll b => ThrowAll (a -> b) where

41− throwAll e = const $ throwAll e

42−

43−instance {-# OVERLAPPABLE #-} (MonadError ServerError m) => ThrowAll (m a) where

44− throwAll = throwError

45−

46−-- | for @servant <0.11@

47−instance {-# OVERLAPPING #-} ThrowAll Application where

48− throwAll e _req respond

49− = respond $ responseLBS (mkStatus (errHTTPCode e) (BS.pack $ errReasonPhrase e))

50− (errHeaders e)

51− (errBody e)

52−

53−-- | for @servant >=0.11@

54−instance {-# OVERLAPPING #-} MonadError ServerError m => ThrowAll (Tagged m Application) where

55− throwAll e = Tagged $ \_req respond ->

56− respond $ responseLBS (mkStatus (errHTTPCode e) (BS.pack $ errReasonPhrase e))

57− (errHeaders e)

58− (errBody e)

servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/Types.hsdeleted−112

@@ -1,112 +0,0 @@

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

@@ -1,3 +0,0 @@

1−module Servant.Auth.Server.SetCookieOrphan

2− {-# DEPRECATED "instance exists in http-api-data-0.3.9. This module will be removed in next major release." #-}

3− () where

servant-auth/servant-auth-server/test/Servant/Auth/ServerSpec.hsdeleted−607

@@ -1,607 +0,0 @@

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

@@ -1 +0,0 @@

1−{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

servant-auth/servant-auth-swagger/.ghcideleted−1

@@ -1 +0,0 @@

1−:set -isrc -itest -idoctest/ghci-wrapper/src

servant-auth/servant-auth-swagger/CHANGELOG.mddeleted−24

@@ -1,24 +0,0 @@

1−# Changelog

2−

3−All notable changes to this project will be documented in this file.

4−

5−The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/)

6−and this project adheres to [PVP Versioning](https://pvp.haskell.org/).

7−

8−## [Unreleased]

9−

10−## [0.2.10.1] - 2020-10-06

11−

12−### Changed

13−

14−- Support GHC 8.10 @domenkozar

15−- Fix build with swagger 2.5.x @domenkozar

16−

17−## [0.2.10.0] - 2018-06-18

18−

19−### Added

20−

21−- Support for GHC 8.4 by @phadej

22−- Changelog by @domenkozar

23−- #93: Add Cookie in SwaggerSpec API by @domenkozar

24−- #42: Add dummy AllHasSecurity Cookie instance by @sordina

servant-auth/servant-auth-swagger/Setup.hsdeleted−2

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

1−import Distribution.Simple

2−main = defaultMain

servant-auth/servant-auth-swagger/servant-auth-swagger.cabaldeleted−70

@@ -1,70 +0,0 @@

1−cabal-version: 2.2

2−name: servant-auth-swagger

3−version: 0.2.10.1

4−synopsis: servant-swagger/servant-auth compatibility

5−description: This package provides instances that allow generating swagger2 schemas from

6− <https://hackage.haskell.org/package/servant servant>

7− APIs that use

8− <https://hackage.haskell.org/package/servant-auth servant-auth's> @Auth@ combinator.

9− .

10− For a quick overview of the usage, see the <https://github.com/haskell-servant/servant/tree/master/servant-auth#readme README>.

11−category: Web, Servant, Authentication

12−homepage: https://github.com/haskell-servant/servant/tree/master/servant-auth#readme

13−bug-reports: https://github.com/haskell-servant/servant/issues

14−author: Julian K. Arni

15−maintainer: jkarni@gmail.com

16−copyright: (c) Julian K. Arni

17−license: BSD-3-Clause

18−license-file: LICENSE

19−tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4

20−build-type: Simple

21−extra-source-files:

22− CHANGELOG.md

23−

24−source-repository head

25− type: git

26− location: https://github.com/haskell-servant/servant

27−

28−library

29− hs-source-dirs:

30− src

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

@@ -1,87 +0,0 @@

1−{-# OPTIONS_GHC -fno-warn-orphans #-}

2−{-# LANGUAGE CPP #-}

3−module Servant.Auth.Swagger

4− (

5− -- | The purpose of this package is provide the instance for 'servant-auth'

6− -- combinators needed for 'servant-swagger' documentation generation.

7− --

8− -- Currently only JWT and BasicAuth are supported.

9−

10− -- * Re-export

11− JWT

12− , BasicAuth

13− , Auth

14−

15− -- * Needed to define instances of @HasSwagger@

16− , HasSecurity (..)

17− ) where

18−

19−import Control.Lens ((&), (<>~))

20−import Data.Proxy (Proxy (Proxy))

21−import Data.Swagger (ApiKeyLocation (..), ApiKeyParams (..),

22− SecurityRequirement (..), SecurityScheme (..),

23−#if MIN_VERSION_swagger2(2,6,0)

24− SecurityDefinitions(..),

25−#endif

26− SecuritySchemeType (..), allOperations, security,

27− securityDefinitions)

28−import GHC.Exts (fromList)

29−import Servant.API hiding (BasicAuth)

30−import Servant.Auth

31−import Servant.Swagger

32−

33−import qualified Data.Text as T

34−

35−instance (AllHasSecurity xs, HasSwagger api) => HasSwagger (Auth xs r :> api) where

36− toSwagger _

37− = toSwagger (Proxy :: Proxy api)

38− & securityDefinitions <>~ mkSec (fromList secs)

39− & allOperations.security <>~ secReqs

40− where

41− secs = securities (Proxy :: Proxy xs)

42− secReqs = [ SecurityRequirement (fromList [(s,[])]) | (s,_) <- secs]

43− mkSec =

44−#if MIN_VERSION_swagger2(2,6,0)

45− SecurityDefinitions

46−#else

47− id

48−#endif

49−

50−

51−class HasSecurity x where

52− securityName :: Proxy x -> T.Text

53− securityScheme :: Proxy x -> SecurityScheme

54−

55−instance HasSecurity BasicAuth where

56− securityName _ = "BasicAuth"

57− securityScheme _ = SecurityScheme type_ (Just desc)

58− where

59− type_ = SecuritySchemeBasic

60− desc = "Basic access authentication"

61−

62−instance HasSecurity JWT where

63− securityName _ = "JwtSecurity"

64− securityScheme _ = SecurityScheme type_ (Just desc)

65− where

66− type_ = SecuritySchemeApiKey (ApiKeyParams "Authorization" ApiKeyHeader)

67− desc = "JSON Web Token-based API key"

68−

69−class AllHasSecurity (x :: [*]) where

70− securities :: Proxy x -> [(T.Text,SecurityScheme)]

71−

72−instance {-# OVERLAPPABLE #-} (HasSecurity x, AllHasSecurity xs) => AllHasSecurity (x ': xs) where

73− securities _ = (securityName px, securityScheme px) : securities pxs

74− where

75− px :: Proxy x

76− px = Proxy

77− pxs :: Proxy xs

78− pxs = Proxy

79−

80−instance {-# OVERLAPPING #-} AllHasSecurity xs => AllHasSecurity (Cookie ': xs) where

81− securities _ = securities pxs

82− where

83− pxs :: Proxy xs

84− pxs = Proxy

85−

86−instance AllHasSecurity '[] where

87− securities _ = []

servant-auth/servant-auth-swagger/test/Servant/Auth/SwaggerSpec.hsdeleted−38

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

1−{-# LANGUAGE CPP #-}

2−module Servant.Auth.SwaggerSpec (spec) where

3−

4−import Control.Lens

5−import Data.Proxy

6−import Servant.API

7−import Servant.Auth

8−import Servant.Auth.Swagger

9−import Data.Swagger

10−import Servant.Swagger

11−import Test.Hspec

12−

13−spec :: Spec

14−spec = describe "HasSwagger instance" $ do

15−

16− let swag = toSwagger (Proxy :: Proxy API)

17−

18− it "adds security definitions at the top level" $ do

19−#if MIN_VERSION_swagger2(2,6,0)

20− let (SecurityDefinitions secDefs) = swag ^. securityDefinitions

21−#else

22− let secDefs = swag ^. securityDefinitions

23−#endif

24− length secDefs `shouldSatisfy` (> 0)

25−

26− it "adds security at sub-apis" $ do

27− swag ^. security `shouldBe` []

28− show (swag ^. paths . at "/secure") `shouldContain` "JwtSecurity"

29− show (swag ^. paths . at "/insecure") `shouldNotContain` "JwtSecurity"

30−

31−-- * API

32−

33−type API = "secure" :> Auth '[JWT, Cookie] Int :> SecureAPI

34− :<|> "insecure" :> InsecureAPI

35−

36−type SecureAPI = Get '[JSON] Int :<|> ReqBody '[JSON] Int :> Post '[JSON] Int

37−

38−type InsecureAPI = SecureAPI

servant-auth/servant-auth/.ghcideleted−1

@@ -1 +0,0 @@

1−:set -isrc -itest -idoctest/ghci-wrapper/src

servant-auth/servant-auth/CHANGELOG.mddeleted−20

@@ -1,20 +0,0 @@

1−# Changelog

2−

3−All notable changes to this project will be documented in this file.

4−

5−The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/)

6−and this project adheres to [PVP Versioning](https://pvp.haskell.org/).

7−

8−## [Unreleased]

9−

10−## [0.4.0.0] - 2020-10-06

11−

12−- Support for GHC 8.10 by @domenkozar

13−- Support servant 0.18 by @domenkozar

14−- Move `ToJWT/FromJWT` from servant-auth-server

15−

16−## [0.3.2.0] - 2018-06-18

17−

18−### Added

19−- Support for GHC 8.4 by @phadej

20−- Changelog by @domenkozar

servant-auth/servant-auth/LICENSEdeleted−31

@@ -1,31 +0,0 @@

2−

4−

5−Redistribution and use in source and binary forms, with or without

6−modification, are permitted provided that the following conditions are met:

7−

8− * Redistributions of source code must retain the above copyright

9− notice, this list of conditions and the following disclaimer.

10−

11− * Redistributions in binary form must reproduce the above

12− copyright notice, this list of conditions and the following

13− disclaimer in the documentation and/or other materials provided

14− with the distribution.

15−

16− * Neither the name of Julian K. Arni nor the names of other

17− contributors may be used to endorse or promote products derived

18− from this software without specific prior written permission.

19−

20−THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS

21−"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT

22−LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR

23−A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT

24−OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,

25−SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT

26−LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,

27−DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY

28−THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT

29−(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE

30−OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

31−

servant-auth/servant-auth/Setup.hsdeleted−2

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

1−import Distribution.Simple

2−main = defaultMain

servant-auth/servant-auth/servant-auth.cabaldeleted−47

@@ -1,47 +0,0 @@

1−cabal-version: 2.2

2−name: servant-auth

3−version: 0.4.1.0

4−synopsis: Authentication combinators for servant

5−description: This package provides an @Auth@ combinator for 'servant'. This combinator

6− allows using different authentication schemes in a straightforward way,

7− and possibly in conjunction with one another.

8− .

9− 'servant-auth' additionally provides concrete authentication schemes, such

10− as Basic Access Authentication, JSON Web Tokens, and Cookies.

11− .

12− For more details on how to use this, see the <https://github.com/haskell-servant/servant/tree/master/servant-auth#readme README>.

13−category: Web, Servant, Authentication

14−homepage: https://github.com/haskell-servant/servant/tree/master/servant-auth#readme

15−bug-reports: https://github.com/haskell-servant/servant/issues

16−author: Julian K. Arni

17−maintainer: jkarni@gmail.com

18−copyright: (c) Julian K. Arni

19−license: BSD-3-Clause

20−license-file: LICENSE

21−tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1

22−build-type: Simple

23−extra-source-files:

24− CHANGELOG.md

25−

26−source-repository head

27− type: git

28− location: https://github.com/haskell-servant/servant

29−

30−library

31− hs-source-dirs:

32− src

33− default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators

34− ghc-options: -Wall

35− build-depends:

36− base >= 4.10 && < 4.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.hsdeleted−54

@@ -1,54 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4−{-# LANGUAGE TypeFamilies #-}

5−{-# LANGUAGE TypeOperators #-}

6−module Servant.Auth where

7−

8−import Data.Proxy (Proxy(..))

9−import Servant.API ((:>))

10−import Servant.Links (HasLink (..))

11−

12−-- * Authentication

13−

14−-- | @Auth [auth1, auth2] val :> api@ represents an API protected *either* by

15−-- @auth1@ or @auth2@

16−data Auth (auths :: [*]) val

17−

18−-- | A @HasLink@ instance for @Auth@

19−instance HasLink sub => HasLink (Auth (tag :: [*]) value :> sub) where

20−#if MIN_VERSION_servant(0,14,0)

21− type MkLink (Auth (tag :: [*]) value :> sub) a = MkLink sub a

22− toLink toA _ = toLink toA (Proxy :: Proxy sub)

23−#else

24− type MkLink (Auth (tag :: [*]) value :> sub) = MkLink sub

25− toLink _ = toLink (Proxy :: Proxy sub)

26−#endif

27−

28−-- ** Combinators

29−

30−-- | A JSON Web Token (JWT) in the the Authorization header:

31−--

32−-- @Authorization: Bearer \<token\>@

33−--

34−-- Note that while the token is signed, it is not encrypted. Therefore do not

35−-- keep in it any information you would not like the client to know.

36−--

37−-- JWTs are described in IETF's <https://tools.ietf.org/html/rfc7519 RFC 7519>

38−data JWT

39−

40−-- | A cookie. The content cookie itself is a JWT. Another cookie is also used,

41−-- the contents of which are expected to be send back to the server in a

42−-- header, for XSRF protection.

43−data Cookie

44−

45−

46−-- We could use 'servant''s BasicAuth, but then we don't get control over the

47−-- documentation, and we'd have to polykind everything. (Also, we don't

48−-- currently depend on servant!)

49−--

50−-- | Basic Auth.

51−data BasicAuth

52−

53−-- | Login via a form.

54−data FormLogin form

servant-auth/servant-auth/src/Servant/Auth/JWT.hsdeleted−40

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

1−{-# LANGUAGE CPP #-}

2−

3−module Servant.Auth.JWT where

4−

5−import Control.Lens ((^.))

6−import qualified Crypto.JWT as Jose

7−import Data.Aeson (FromJSON, Result (..), ToJSON, fromJSON,

8− toJSON)

9−#if MIN_VERSION_aeson(2,0,0)

10−import qualified Data.Map as KM

11−#else

12−import qualified Data.HashMap.Strict as KM

13−#endif

14−

15−import qualified Data.Text as T

16−

17−

18−-- This should probably also be from ClaimSet

19−--

20−-- | How to decode data from a JWT.

21−--

22−-- The default implementation assumes the data is stored in the unregistered

23−-- @dat@ claim, and uses the @FromJSON@ instance to decode value from there.

24−class FromJWT a where

25− decodeJWT :: Jose.ClaimsSet -> Either T.Text a

26− default decodeJWT :: FromJSON a => Jose.ClaimsSet -> Either T.Text a

27− decodeJWT m = case KM.lookup "dat" (m ^. Jose.unregisteredClaims) of

28− Nothing -> Left "Missing 'dat' claim"

29− Just v -> case fromJSON v of

30− Error e -> Left $ T.pack e

31− Success a -> Right a

32−

33−-- | How to encode data from a JWT.

34−--

35−-- The default implementation stores data in the unregistered @dat@ claim, and

36−-- uses the type's @ToJSON@ instance to encode the data.

37−class ToJWT a where

38− encodeJWT :: a -> Jose.ClaimsSet

39− default encodeJWT :: ToJSON a => a -> Jose.ClaimsSet

40− encodeJWT a = Jose.addClaim "dat" (toJSON a) Jose.emptyClaimsSet

servant-auth/servant-auth/test/Spec.hsdeleted−1

@@ -1 +0,0 @@

1−{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

servant-auth/servant-auth-docs/LICENSE → servant-blaze/LICENSErenamed+1−2

@@ -1,4 +1,4 @@

33All rights reserved.

@@ -28,4 +28,3 @@ DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY

2828THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT

2929(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE

3030OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

31−

servant-client-core/Setup.hs → servant-blaze/Setup.hsrenamed

The content is the same.

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

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

1+#if __GLASGOW_HASKELL__ >= 710

2+#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}

3+#define OVERLAPPING_ {-# OVERLAPPING #-}

4+#else

5+{-# LANGUAGE OverlappingInstances #-}

6+#define OVERLAPPABLE_

7+#define OVERLAPPING_

8+#endif

servant-blaze/servant-blaze.cabalnew file+33

@@ -0,0 +1,33 @@

1+-- Initial servant-blaze.cabal generated by cabal init. For further

2+-- documentation, see http://haskell.org/cabal/users-guide/

4+name: servant-blaze

5+version: 0.5

6+synopsis: Blaze-html support for servant

7+-- description:

8+homepage: http://haskell-servant.github.io/

9+license: BSD3

10+license-file: LICENSE

11+author: Servant Contributors

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

13+copyright: 2015-2016 Servant Contributors

14+category: Web

15+build-type: Simple

16+extra-source-files: include/*.h

17+cabal-version: >=1.10

18+bug-reports: http://github.com/haskell-servant/servant/issues

19+source-repository head

20+ type: git

21+ location: http://github.com/haskell-servant/servant.git

22+

23+library

24+ exposed-modules: Servant.HTML.Blaze

25+ -- other-modules:

26+ -- other-extensions:

27+ build-depends: base >=4.7 && <5

28+ , servant == 0.5.*

29+ , http-media

30+ , blaze-html

31+ hs-source-dirs: src

32+ default-language: Haskell2010

33+ include-dirs: include

servant-blaze/src/Servant/HTML/Blaze.hsnew file+35

@@ -0,0 +1,35 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE DeriveDataTypeable #-}

3+{-# LANGUAGE FlexibleInstances #-}

4+{-# LANGUAGE MultiParamTypeClasses #-}

5+{-# LANGUAGE OverloadedStrings #-}

7+#include "overlapping-compat.h"

8+-- | An @HTML@ empty data type with `MimeRender` instances for @blaze-html@'s

9+-- `ToMarkup` class and `Html` datatype.

10+-- You should only need to import this module for it's instances and the

11+-- `HTML` datatype.:

12+--

13+-- >>> type Eg = Get '[HTML] a

14+--

15+-- Will then check that @a@ has a `ToMarkup` instance, or is `Html`.

16+module Servant.HTML.Blaze where

17+

18+import Data.Typeable (Typeable)

19+import qualified Network.HTTP.Media as M

20+import Servant.API (Accept (..), MimeRender (..))

21+import Text.Blaze.Html (Html, ToMarkup, toHtml)

22+import Text.Blaze.Html.Renderer.Utf8 (renderHtml)

23+

24+data HTML deriving Typeable

25+

26+-- | @text/html;charset=utf-8@

27+instance Accept HTML where

28+ contentType _ = "text" M.// "html" M./: ("charset", "utf-8")

29+

30+instance OVERLAPPABLE_ ToMarkup a => MimeRender HTML a where

31+ mimeRender _ = renderHtml . toHtml

32+

33+instance OVERLAPPING_ MimeRender HTML Html where

34+ mimeRender _ = renderHtml

35+

servant-blaze/tinc.yamlnew file+3

@@ -0,0 +1,3 @@

1+dependencies:

2+ - name: servant

3+ path: ../servant

servant-auth/servant-auth-client/LICENSE → servant-cassava/LICENSErenamed+1−2

@@ -1,4 +1,4 @@

33All rights reserved.

@@ -28,4 +28,3 @@ DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY

2828THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT

2929(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE

3030OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

31−

servant-auth/servant-auth-client/Setup.hs → servant-cassava/Setup.hsrenamed

The content is the same.

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

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

1+#if __GLASGOW_HASKELL__ >= 710

2+#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}

3+#define OVERLAPPING_ {-# OVERLAPPING #-}

4+#else

5+{-# LANGUAGE OverlappingInstances #-}

6+#define OVERLAPPABLE_

7+#define OVERLAPPING_

8+#endif

servant-cassava/servant-cassava.cabalnew file+30

@@ -0,0 +1,30 @@

1+-- Initial servant-cassava.cabal generated by cabal init. For further

2+-- documentation, see http://haskell.org/cabal/users-guide/

4+name: servant-cassava

5+version: 0.4.4.2

6+synopsis: Servant CSV content-type for cassava

7+-- description:

8+homepage: http://haskell-servant.github.io/

9+license: BSD3

10+license-file: LICENSE

11+author: Servant Contributors

12+maintainer: haskell-servant-maintainers@googlegroups.com

13+copyright: 2015-2016 Servant Contributors

14+-- category:

15+build-type: Simple

16+extra-source-files: include/*.h

17+cabal-version: >=1.10

18+

19+library

20+ exposed-modules: Servant.CSV.Cassava

21+ -- other-modules:

22+ -- other-extensions:

23+ build-depends: base >=4.6 && <5

24+ , cassava >0.4 && <0.5

25+ , servant ==0.5.*

26+ , http-media

27+ , vector

28+ hs-source-dirs: src

29+ default-language: Haskell2010

30+ include-dirs: include

servant-cassava/src/Servant/CSV/Cassava.hsnew file+115

@@ -0,0 +1,115 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE DeriveDataTypeable #-}

3+{-# LANGUAGE DeriveGeneric #-}

4+{-# LANGUAGE FlexibleInstances #-}

5+{-# LANGUAGE MultiParamTypeClasses #-}

6+{-# LANGUAGE OverloadedStrings #-}

7+{-# LANGUAGE ScopedTypeVariables #-}

9+-- | A @CSV@ empty datatype with `MimeRender` and `MimeUnrender` instances for

10+-- @cassava@'s encoding and decoding classes.

11+--

12+-- >>> type Eg = Get '[(CSV', MyEncodeOptions)] [(Int, String)]

13+--

14+-- Default encoding and decoding options are also provided, along with the

15+-- @CSV@ type synonym that uses them.

16+--

17+-- >>> type EgDefault = Get '[CSV] [(Int, String)]

18+module Servant.CSV.Cassava where

19+

20+#if !MIN_VERSION_base(4,8,0)

21+import Control.Applicative ((<$>))

22+#endif

23+import Data.Csv

24+import Data.Proxy (Proxy (..))

25+import Data.Typeable (Typeable)

26+import Data.Vector (Vector, toList)

27+import GHC.Generics (Generic)

28+import qualified Network.HTTP.Media as M

29+import Servant.API (Accept (..), MimeRender (..),

30+ MimeUnrender (..))

31+

32+data CSV' deriving (Typeable, Generic)

33+

34+type CSV = (CSV', DefaultDecodeOpts)

35+

36+-- | @text/csv;charset=utf-8@

37+instance Accept (CSV', a) where

38+ contentType _ = "text" M.// "csv" M./: ("charset", "utf-8")

39+

40+-- * Encoding

41+

42+-- ** Instances

43+

44+-- | Encode with 'encodeByNameWith'. The 'Header' param is used for determining

45+-- the order of headers and fields.

46+instance ( ToNamedRecord a, EncodeOpts opt

47+ ) => MimeRender (CSV', opt) (Header, [a]) where

48+ mimeRender _ (hdr, vals) = encodeByNameWith (encodeOpts p) hdr vals

49+ where p = Proxy :: Proxy opt

50+

51+-- | Encode with 'encodeDefaultOrderedByNameWith'

52+instance ( DefaultOrdered a, ToNamedRecord a, EncodeOpts opt

53+ ) => MimeRender (CSV', opt) [a] where

54+ mimeRender _ = encodeDefaultOrderedByNameWith (encodeOpts p)

55+ where p = Proxy :: Proxy opt

56+

57+-- | Encode with 'encodeByNameWith'. The 'Header' param is used for determining

58+-- the order of headers and fields.

59+instance ( ToNamedRecord a, EncodeOpts opt

60+ ) => MimeRender (CSV', opt) (Header, Vector a) where

61+ mimeRender _ (hdr, vals) = encodeByNameWith (encodeOpts p) hdr (toList vals)

62+ where p = Proxy :: Proxy opt

63+

64+-- | Encode with 'encodeDefaultOrderedByNameWith'

65+instance ( DefaultOrdered a, ToNamedRecord a, EncodeOpts opt

66+ ) => MimeRender (CSV', opt) (Vector a) where

67+ mimeRender _ = encodeDefaultOrderedByNameWith (encodeOpts p) . toList

68+ where p = Proxy :: Proxy opt

69+

70+-- ** Encode Options

71+

72+class EncodeOpts a where

73+ encodeOpts :: Proxy a -> EncodeOptions

74+

75+data DefaultEncodeOpts deriving (Typeable, Generic)

76+

77+instance EncodeOpts DefaultEncodeOpts where

78+ encodeOpts _ = defaultEncodeOptions

79+

80+-- * Decoding

81+

82+-- ** Instances

83+

84+-- | Decode with 'decodeByNameWith'

85+instance ( FromNamedRecord a, DecodeOpts opt

86+ ) => MimeUnrender (CSV', opt) (Header, [a]) where

87+ mimeUnrender _ bs = fmap toList <$> decodeByNameWith (decodeOpts p) bs

88+ where p = Proxy :: Proxy opt

89+

90+-- | Decode with 'decodeWith'. Assumes data has headers, which are stripped.

91+instance ( FromRecord a, DecodeOpts opt

92+ ) => MimeUnrender (CSV', opt) [a] where

93+ mimeUnrender _ bs = toList <$> decodeWith (decodeOpts p) HasHeader bs

94+ where p = Proxy :: Proxy opt

95+

96+instance ( FromNamedRecord a, DecodeOpts opt

97+ ) => MimeUnrender (CSV', opt) (Header, Vector a) where

98+ mimeUnrender _ = decodeByNameWith (decodeOpts p)

99+ where p = Proxy :: Proxy opt

100+

101+-- | Decode with 'decodeWith'. Assumes data has headers, which are stripped.

102+instance ( FromRecord a, DecodeOpts opt

103+ ) => MimeUnrender (CSV', opt) (Vector a) where

104+ mimeUnrender _ = decodeWith (decodeOpts p) HasHeader

105+ where p = Proxy :: Proxy opt

106+

107+-- ** Decode Options

108+

109+class DecodeOpts a where

110+ decodeOpts :: Proxy a -> DecodeOptions

111+

112+data DefaultDecodeOpts deriving (Typeable, Generic)

113+

114+instance DecodeOpts DefaultDecodeOpts where

115+ decodeOpts _ = defaultDecodeOptions

servant-cassava/tinc.yamlnew file+3

@@ -0,0 +1,3 @@

1+dependencies:

2+ - name: servant

3+ path: ../servant

servant-client-core/CHANGELOG.mddeleted−308

@@ -1,308 +0,0 @@

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)

3−

4−Package versions follow the [Package Versioning Policy](https://pvp.haskell.org/): in A.B.C, bumps to either A or B represent major versions.

5−

6−0.19

7−----

8−

9−### Significant changes

10−

11−- Drop support for GHC < 8.6.

12−- Support GHC 9.0 (GHC 9.2 should work as well, but isn't fully tested yet).

13−- Support Aeson 2 ([#1475](https://github.com/haskell-servant/servant/pull/1475)),

14− which fixes a [DOS vulnerability](https://github.com/haskell/aeson/issues/864)

15− related to hash collisions.

16−- Add `NamedRoutes` combinator, making support for records first-class in Servant

17− ([#1388](https://github.com/haskell-servant/servant/pull/1388)).

18−- Add custom type errors for partially applied combinators

19− ([#1289](https://github.com/haskell-servant/servant/pull/1289),

20− [#1486](https://github.com/haskell-servant/servant/pull/1486)).

21−- *servant-client* / *servant-client-core* / *servant-http-streams*: Fix

22− erroneous behavior, where only 2XX status codes would be considered

23− successful, irrelevant of the status parameter specified by the verb

24− combinator. ([#1469](https://github.com/haskell-servant/servant/pull/1469))

25−- *servant-client* / *servant-client-core*: Fix `Show` instance for

26− `Servant.Client.Core.Request`.

27−- *servant-client* / *servant-client-core*: Allow passing arbitrary binary data

28− in Query parameters.

29− ([#1432](https://github.com/haskell-servant/servant/pull/1432)).

30−

31−### Other changes

32−

33−- Various version bumps.

34−

35−0.18.3

36−------

37−

38−### Significant changes

39−

40−- Add response header support to UVerb (#1420)

41−

42−### Other changes

43−

44−- Support GHC-9.0.1.

45−- Bump `bytestring`, `hspec`, `base64-bytestring` and `QuickCheck` dependencies.

46−

47−0.18.2

48−------

49−

50−### Significant changes

51−

52−- Support `Fragment` combinator.

53−

54−0.18.1

55−------

56−

57−### Significant changes

58−

59−- Union verbs

60−

61−### Other changes

62−

63−- Bump "tested-with" ghc versions

64−- Loosen bound on base16-bytestring

65−

66−0.18

67−----

68−

69−### Significant changes

70−

71−- Support for ghc8.8 (#1318, #1326, #1327)

72−

73−

74−0.17

75−----

76−

77−### Significant changes

78−

79−- Add NoContentVerb [#1028](https://github.com/haskell-servant/servant/issues/1028) [#1219](https://github.com/haskell-servant/servant/pull/1219) [#1228](https://github.com/haskell-servant/servant/pull/1228)

80−

81− The `NoContent` API endpoints should now use `NoContentVerb` combinator.

82− The API type changes are usually of the kind

83−

84− ```diff

85− - :<|> PostNoContent '[JSON] NoContent

86− + :<|> PostNoContent

87− ```

88−

89− i.e. one doesn't need to specify the content-type anymore. There is no content.

90−

91−- `Capture` can be `Lenient` [#1155](https://github.com/haskell-servant/servant/issues/1155) [#1156](https://github.com/haskell-servant/servant/pull/1156)

92−

93− You can specify a lenient capture as

94−

95− ```haskell

96− :<|> "capture-lenient" :> Capture' '[Lenient] "foo" Int :> GET

97− ```

98−

99− which will make the capture always succeed. Handlers will be of the

100− type `Either String CapturedType`, where `Left err` represents

101− the possible parse failure.

102−

103−### Other changes

104−

105−- *servant-client* *servant-client-core* *servant-http-streams* Fix Verb with headers checking content type differently [#1200](https://github.com/haskell-servant/servant/issues/1200) [#1204](https://github.com/haskell-servant/servant/pull/1204)

106−

107− For `Verb`s with response `Headers`, the implementation didn't check

108− for the content-type of the response. Now it does.

109−

110−- *servant-client* *servant-http-streams* `HasClient` instance for `Stream` with `Headers` [#1170](https://github.com/haskell-servant/servant/issues/1170) [#1197](https://github.com/haskell-servant/servant/pull/1197)

111−- *servant-client* Redact the authorization header in Show and exceptions [#1238](https://github.com/haskell-servant/servant/pull/1238)

112−

113−0.16

114−----

115−

116−- Rename `ServantError` to `ClientError`, `ServantErr` to `ServerError`

117− [#1131](https://github.com/haskell-servant/servant/pull/1131)

118−

119−- *servant-client-core* Rearrange modules. No more `Internal` modules, whole

120− API is versioned.

121− [#1130](https://github.com/haskell-servant/servant/pull/1130)

122−

123−- *servant-client-core* `RequestBody` is now

124−

125− ```haskell

126− = RequestBodyLBS LBS.ByteString

127− | RequestBodyBS BS.ByteString

128− | RequestBodySource (SourceIO LBS.ByteString)

129− ```

130−

131− i.e. no more replicates `http-client`s API.

132− [#1117](https://github.com/haskell-servant/servant/pull/1117)

133−

134−- *servant-client-core* Keep structured exceptions in `ConnectionError`

135− constructor of `ClientError`

136− [#1115](https://github.com/haskell-servant/servant/pull/1115)

137−

138− ```diff

139− -| ConnectionError Text

140− +| ConnectionError SomeException

141− ```

142−

143−- *servant-client-core* Preserve failing request in `FailureResponse`

144− constructor of `ClientError`

145− [#1114](https://github.com/haskell-servant/servant/pull/1114)

146−

147− ```diff

148− -FailureResponse Response

149− +-- | The server returned an error response including the

150− +-- failing request. 'requestPath' includes the 'BaseUrl' and the

151− +-- path of the request.

152− +FailureResponse (RequestF () (BaseUrl, BS.ByteString)) Response

153− ```

154−

155−- *servant-client* Fix (implement) `StreamBody` instance

156− [#1110](https://github.com/haskell-servant/servant/pull/1110)

157−

158−- *servant-client* Update CookieJar with intermediate request/responses (redirects)

159− [#1104](https://github.com/haskell-servant/servant/pull/1104)

160−

161−0.15

162−----

163−

164−- Streaming refactoring.

165− [#991](https://github.com/haskell-servant/servant/pull/991)

166− [#1076](https://github.com/haskell-servant/servant/pull/1076)

167− [#1077](https://github.com/haskell-servant/servant/pull/1077)

168−

169− The streaming functionality (`Servant.API.Stream`) is refactored to use

170− `servant`'s own `SourceIO` type (see `Servant.Types.SourceT` documentation),

171− which replaces both `StreamGenerator` and `ResultStream` types.

172−

173− New conversion type-classes are `ToSourceIO` and `FromSourceIO`

174− (replacing `ToStreamGenerator` and `BuildFromStream`).

175− There are instances for *conduit*, *pipes* and *machines* in new packages:

176− [servant-conduit](https://hackage.haskell.org/package/servant-conduit)

177− [servant-pipes](https://hackage.haskell.org/package/servant-pipes) and

178− [servant-machines](https://hackage.haskell.org/package/servant-machines)

179− respectively.

180−

181− Writing new framing strategies is simpler. Check existing strategies for examples.

182−

183− This change shouldn't affect you, if you don't use streaming endpoints.

184−

185−- *servant-client* Separate streaming client.

186− [#1066](https://github.com/haskell-servant/servant/pull/1066)

187−

188− We now have two `http-client` based clients,

189− in `Servant.Client` and `Servant.Client.Streaming`.

190−

191− Their API is the same, except for

192− - `Servant.Client` **cannot** request `Stream` endpoints.

193− - `Servant.Client` is *run* by direct

194− `runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a)`

195− - `Servant.Client.Streaming` **can** request `Stream` endpoints.

196− - `Servant.Client.Streaming` is *used* by CPSised

197− `withClientM :: ClientM a -> ClientEnv -> (Either ServantError a -> IO b) -> IO b`

198−

199− To access `Stream` endpoints use `Servant.Client.Streaming` with

200− `withClientM`; otherwise you can continue using `Servant.Client` with `runClientM`.

201− You can use both too, `ClientEnv` and `BaseUrl` types are same for both.

202−

203− **Note:** `Servant.Client.Streaming` doesn't *stream* non-`Stream` endpoints.

204− Requesting ordinary `Verb` endpoints (e.g. `Get`) will block until

205− the whole response is received.

206−

207− There is `Servant.Client.Streaming.runClientM` function, but it has

208− restricted type. `NFData a` constraint prevents using it with

209− `SourceT`, `Conduit` etc. response types.

210−

211− ```haskell

212− runClientM :: NFData a => ClientM a -> ClientEnv -> IO (Either ServantError a)

213− ```

214−

215− This change shouldn't affect you, if you don't use streaming endpoints.

216−

217−- *servant-client-core* Related to the previous:

218− `streamingResponse` is removed from `RunClient`.

219− We have a new type-class:

220−

221− ```haskell

222− class RunClient m => RunStreamingClient m where

223− withStreamingRequest :: Request -> (StreamingResponse -> IO a) -> m a

224− ```

225−

226−- Drop support for GHC older than 8.0

227− [#1008](https://github.com/haskell-servant/servant/pull/1008)

228− [#1009](https://github.com/haskell-servant/servant/pull/1009)

229−

230−- *servant-client-core* Add `NFData (GenResponse a)` and `NFData ServantError` instances.

231− [#1076](https://github.com/haskell-servant/servant/pull/1076)

232−

233−- *servant-client-core* Add `aeson` and `Lift BaseUrl` instances

234− [#1037](https://github.com/haskell-servant/servant/pull/1037)

235−

236−0.14.1

237−------

238−

239−- Merge in `servant-generic` (by [Patrick Chilton](https://github.com/chpatrick))

240− into `servant` (`Servant.API.Generic`),

241− `servant-client-code` (`Servant.Client.Generic`)

242− and `servant-server` (`Servant.Server.Generic`).

243−

244−0.14

245−----

246−

247−- `Stream` takes a status code argument

248−

249− ```diff

250− -Stream method framing ctype a

251− +Stream method status framing ctype a

252− ```

253−

254− ([#966](https://github.com/haskell-servant/servant/pull/966)

255− [#972](https://github.com/haskell-servant/servant/pull/972))

256−

257−- `ToStreamGenerator` definition changed, so it's possible to write an instance

258− for conduits.

259−

260− ```diff

261− -class ToStreamGenerator f a where

262− - toStreamGenerator :: f a -> StreamGenerator a

263− +class ToStreamGenerator a b | a -> b where

264− + toStreamGenerator :: a -> StreamGenerator b

265− ```

266−

267− ([#959](https://github.com/haskell-servant/servant/pull/959))

268−

269−- Added `NoFraming` streaming strategy

270− ([#959](https://github.com/haskell-servant/servant/pull/959))

271−

272−- *servant-client-core* Free `Client` implementation.

273− Useful for testing `HasClient` instances.

274− ([#920](https://github.com/haskell-servant/servant/pull/920))

275−

276−- *servant-client-core* Add `hoistClient` to `HasClient`.

277− Just like `hoistServer` allows us to change the monad in which request handlers

278− of a web application live, we also have `hoistClient` for changing the monad

279− in which *client functions* live.

280− Read [tutorial section for more information](https://docs.servant.dev/en/release-0.14/tutorial/Client.html#changing-the-monad-the-client-functions-live-in).

281− ([#936](https://github.com/haskell-servant/servant/pull/936))

282−

283− iF you have own combinators, you'll need to define a new method of

284− `HasClient` class, for example:

285−

286− ```haskell

287− type Client m (MyCombinator :> api) = MyValue :> Client m api

288− hoistClientMonad pm _ nt cl = hoistClientMonad pm (Proxy :: Proxy api) nt . cl

289− ```

290−

291−0.13.0.1

292−--------

293−

294−- Support `base-compat-0.10`

295−

296−0.13

297−----

298−

299−- Streaming endpoint support.

300− ([#836](https://github.com/haskell-servant/servant/pull/836))

301−- *servant* Add `Servant.API.Modifiers`

302− ([#873](https://github.com/haskell-servant/servant/pull/873))

303−

304−0.12

305−----

306−

307−- First version. Factored out of `servant-client` all the functionality that was

308− independent of the `http-client` backend.

servant-client-core/LICENSEdeleted−30

@@ -1,30 +0,0 @@

2−

4−

5−Redistribution and use in source and binary forms, with or without

6−modification, are permitted provided that the following conditions are met:

7−

8− * Redistributions of source code must retain the above copyright

9− notice, this list of conditions and the following disclaimer.

10−

11− * Redistributions in binary form must reproduce the above

12− copyright notice, this list of conditions and the following

13− disclaimer in the documentation and/or other materials provided

14− with the distribution.

15−

16− * Neither the name of Servant Contributors nor the names of other