5f8aaec..master · servant

.github/workflows/master.yml+51−62

since splitsnapshots

unifiedsplit

@@ -13,12 +13,14 @@ jobs:

13 strategy:

14 matrix:

15 os: [ubuntu-latest]

16− cabal: ["3.4"]

16+ cabal: ["3.6"]

17 ghc:

18 - "8.6.5"

19 - "8.8.4"

20 - "8.10.7"

21− - "9.0.1"

21+ - "9.0.2"

22+ - "9.2.2"

23+ - "9.4.2"

22

24

23 steps:

25 steps:

24 - uses: actions/checkout@v2

26 - uses: actions/checkout@v2

@@ -47,10 +49,7 @@ jobs:

47

49

48 - name: Configure

50 - name: Configure

49 run: |

51 run: |

50− # Using separate store-dir because default one already has 'ghc-paths' package installed

51− # with hardcoded path to ghcup's GHC path (which it was built with). This leads to failure in

52− # doctest, as it tries to invoke that GHC, and it doesn't exist here.

53− cabal --store-dir /tmp/cabal-store install --ignore-project -j2 doctest --constraint='doctest ^>=0.18'

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

54

53

55 - name: Build

54 - name: Build

56 run: |

55 run: |

@@ -61,66 +60,56 @@ jobs:

61 cabal test all

60 cabal test all

62

61

63 - name: Run doctests

62 - name: Run doctests

64− # doctests are broken on GHC 9 due to compiler bug:

65− # https://gitlab.haskell.org/ghc/ghc/-/issues/19460

66− continue-on-error: ${{ matrix.ghc == '9.0.1' }}

67 run: |

63 run: |

68 # Necessary for doctest to be found in $PATH

64 # Necessary for doctest to be found in $PATH

69 export PATH="$HOME/.cabal/bin:$PATH"

65 export PATH="$HOME/.cabal/bin:$PATH"

70

66

71− # Filter out base-compat-batteries from .ghc.environment.*, as its modules

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

72− # conflict with those of base-compat.

73− #

74− # FIXME: This is an ugly hack. Ultimately, we'll want to use cabal-doctest

75− # (or cabal v2-doctest, if it ever lands) to provide a clean GHC environment.

76− # This might allow running doctests in GHCJS build as well.

77− perl -i -e 'while (<ARGV>) { print unless /package-id\s+(base-compat-batteries)-\d+(\.\d+)*/; }' .ghc.environment.*

78−

79− (cd servant && doctest src)

68+ (cd servant && eval $DOCTEST)

80− (cd servant-client && doctest src)

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

81− (cd servant-client-core && doctest src)

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

82− (cd servant-http-streams && doctest src)

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

83− (cd servant-docs && doctest src)

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

84− (cd servant-foreign && doctest src)

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

85− (cd servant-server && doctest src)

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

86− (cd servant-machines && doctest src)

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

87− (cd servant-conduit && doctest src)

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

88− (cd servant-pipes && doctest src)

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

89−

78+

90− stack:

79+ # stack:

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

80+ # name: stack / ghc ${{ matrix.ghc }}

92− runs-on: ubuntu-latest

81+ # runs-on: ubuntu-latest

93− strategy:

82+ # strategy:

94− matrix:

83+ # matrix:

95− stack: ["2.7.3"]

84+ # stack: ["2.7.5"]

96− ghc: ["8.10.4"]

85+ # ghc: ["8.10.7"]

97−

86+

98− steps:

87+ # steps:

99− - uses: actions/checkout@v2

88+ # - uses: actions/checkout@v2

100−

89+

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

90+ # - uses: haskell/actions/setup@v1

102− name: Setup Haskell Stack

91+ # name: Setup Haskell Stack

103− with:

92+ # with:

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

93+ # ghc-version: ${{ matrix.ghc }}

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

94+ # stack-version: ${{ matrix.stack }}

106−

95+

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

96+ # - uses: actions/cache@v2.1.3

108− name: Cache ~/.stack

97+ # name: Cache ~/.stack

109− with:

98+ # with:

110− path: ~/.stack

99+ # path: ~/.stack

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

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

112−

101+

113− - name: Install dependencies

102+ # - name: Install dependencies

114− run: |

103+ # run: |

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

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

116−

105+

117− - name: Build

106+ # - name: Build

118− run: |

107+ # run: |

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

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

120−

109+

121− - name: Test

110+ # - name: Test

122− run: |

111+ # run: |

123− stack test --system-ghc

112+ # stack test --system-ghc

124

113

125 ghcjs:

114 ghcjs:

126 name: ubuntu-latest / ghcjs 8.6

115 name: ubuntu-latest / ghcjs 8.6

.gitignore+1

@@ -31,6 +31,7 @@ doc/venv

31doc/tutorial/static/api.js

32doc/tutorial/static/jq.js

33shell.nix

34+.hspec-failures

34

35

35# nix

36# nix

36result*

37result*

CONTRIBUTING.md+4−2

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

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

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

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

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

82+know about it! Either hop on

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

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

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

85+read it).

84

86

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

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

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

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

cabal.project+2−23

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

12 servant-docs/

13 servant-foreign/

14 servant-server/

15+ servant-swagger/

15 doc/tutorial/

16 doc/tutorial/

16

17

17-- servant streaming

18-- servant streaming

@@ -46,30 +47,8 @@ packages:

46 doc/cookbook/using-custom-monad

47 doc/cookbook/using-custom-monad

47 doc/cookbook/using-free-client

48 doc/cookbook/using-free-client

48 -- doc/cookbook/open-id-connect

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

50+ doc/cookbook/managed-resource

49

51

50tests: True

52tests: True

51optimization: False

53optimization: False

52-- reorder-goals: True

54-- reorder-goals: True

53−

54−constraints:

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

56− foundation >=0.0.14,

57− memory <0.14.12 || >0.14.12

58−

59−constraints: base-compat ^>=0.11

60−constraints: semigroups ^>=0.19

61−

62−-- allow-newer: sqlite-simple-0.4.16.0:semigroups

63−-- allow-newer: direct-sqlite-2.3.24:semigroups

64−

65−-- needed for doctests

66−write-ghc-environment-files: always

67−

68−-- https://github.com/chordify/haskell-servant-pagination/pull/12

69−allow-newer: servant-pagination-2.2.2:servant

70−allow-newer: servant-pagination-2.2.2:servant-server

71−

72−allow-newer: servant-js:servant

73−

74−-- ghc 9

75−allow-newer: tdigest:base

changelog.d/1469new file+11

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

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

2+prs: #1469

3+description: {

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

5+`clientWithRoute` definitions.

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

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

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

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

10+the `Verb` status.

11+}

changelog.d/1529new file+10

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

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

2+prs: #1529

3+

4+description: {

5+

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

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

8+functionality to match what servant-client provides.

9+

10+}

changelog.d/1556new file+81

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

1+synopsis: Display capture hints in router layout

2+prs: #1556

3+

4+description: {

5+

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

7+

8+Example:

9+

10+For the following API

11+```haskell

12+type API =

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

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

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

16+```

17+

18+we previously got the following output:

19+

20+```

21+/

22+├─ a/

23+│ ├─ d/

24+│ │ └─•

25+│ └─ e/

26+│ └─•

27+└─ b/

28+ └─ <capture>/

29+ ├─•

30+ ┆

31+ └─•

32+```

33+

34+now we get:

35+

36+```

37+/

38+├─ a/

39+│ ├─ d/

40+│ │ └─•

41+│ └─ e/

42+│ └─•

43+└─ b/

44+ └─ <x::Int>/

45+ ├─•

46+ ┆

47+ └─•

48+```

49+

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

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

52+

53+N.B.:

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

55+

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

57+

58+Warning:

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

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

61+

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

63+```haskell

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

65+

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

67+myServer = const $ return ()

68+

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

70+myApi = Proxy

71+

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

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

74+```

75+

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

77+```haskell

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

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

80+```

81+}

changelog.d/1569new file+13

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

1+synopsis: Encode captures using toEncodedUrlPiece

2+prs: #1569

3+issues: #1511

4+

5+description: {

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

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

8+URL-encoding however they need.

9+

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

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

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

13+}

changelog.d/1571new file+10

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

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

2+prs: #1571

3+issues: #1570

4+description: {

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

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

7+servant-auth-client.

8+

9+This PR also brings Headers support in UVerb responses

10+}

changelog.d/1573new file+2

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

1+synopsis: Add API docs for ServerT

2+prs: #1573

changelog.d/1580new file+12

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

1+synopsis: Allow IO in validationKeys

2+prs: #1580

3+issues: #1579

4+

5+description: {

6+

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

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

9+discover new and expired keys.

10+

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

12+}

changelog.d/1589new file+2

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

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

2+prs: 1589

changelog.d/1595new file+2

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

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

2+prs: #1595

changelog.d/1606new file+10

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

1+synopsis: Handle Cookies correctly for RunStreamingClient

2+prs: #1606

3+issues: #1605

4+

5+description: {

6+

7+Makes performWithStreamingRequest take into consideration the

8+CookieJar, which it previously didn't.

9+

10+}

changelog.d/1638new file+2

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

1+synopsis: Add Functor instance to AuthHandler.

2+prs: #1638

changelog.d/1649new file+8

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

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

2+prs: #1649

3+

4+description: {

5+

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

7+

8+}

doc/Makefile+1−1

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

10

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

12help:

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

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

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

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

16

doc/conf.py+1−2

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

46

47# General information about the project.

48project = u'Servant'

49−copyright = u'2018, Servant Contributors'

49+copyright = u'2022, Servant Contributors'

50author = u'Servant Contributors'

51

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

@@ -169,4 +169,3 @@ texinfo_documents = [

169source_parsers = {

170 '.lhs': CommonMarkParser,

171}

172−

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

@@ -1,3 +1,4 @@

1+cabal-version: 2.2

1name: cookbook-basic-auth

2name: cookbook-basic-auth

2version: 0.1

3version: 0.1

3synopsis: Basic Authentication cookbook example

4synopsis: Basic Authentication cookbook example

@@ -7,7 +8,6 @@ license-file: ../../../servant/LICENSE

7author: Servant Contributors

8author: Servant Contributors

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

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

9build-type: Simple

10build-type: Simple

10−cabal-version: >=1.10

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

12

13executable cookbook-basic-auth

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

@@ -1,3 +1,4 @@

1+cabal-version: 2.2

1name: cookbook-basic-streaming

2name: cookbook-basic-streaming

2version: 2.1

3version: 2.1

3synopsis: Streaming in servant without streaming libs

4synopsis: Streaming in servant without streaming libs

@@ -7,7 +8,6 @@ license-file: ../../../servant/LICENSE

7author: Servant Contributors

8author: Servant Contributors

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

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

9build-type: Simple

10build-type: Simple

10−cabal-version: >=1.10

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

12

13executable cookbook-basic-streaming

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

@@ -1,3 +1,4 @@

1+cabal-version: 2.2

1name: cookbook-curl-mock

2name: cookbook-curl-mock

2version: 0.1

3version: 0.1

3synopsis: Generate curl mock requests cookbook example

4synopsis: Generate curl mock requests cookbook example

@@ -7,10 +8,12 @@ license-file: ../../../servant/LICENSE

7author: Servant Contributors

8author: Servant Contributors

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

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

9build-type: Simple

10build-type: Simple

10−cabal-version: >=1.10

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

12

13executable cookbock-curl-mock

14+ if impl(ghc >= 9.2)

15+ -- generic-arbitrary is incompatible

16+ buildable: False

14 main-is: CurlMock.lhs

17 main-is: CurlMock.lhs

15 build-depends: base == 4.*

18 build-depends: base == 4.*

16 , aeson

19 , aeson

doc/cookbook/custom-errors/custom-errors.cabal+1−1

@@ -1,3 +1,4 @@

1+cabal-version: 2.2

1name: cookbook-custom-errors

2name: cookbook-custom-errors

2version: 0.1

3version: 0.1

3synopsis: Return custom error messages from combinators

4synopsis: Return custom error messages from combinators

@@ -7,7 +8,6 @@ license-file: ../../../servant/LICENSE

7author: Servant Contributors

8author: Servant Contributors

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

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

9build-type: Simple

10build-type: Simple

10−cabal-version: >=1.10

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

12

13executable cookbook-custom-errors

doc/cookbook/db-mysql-basics/mysql-basics.cabal+1−1

@@ -1,3 +1,4 @@

1+cabal-version: 2.2

1name: mysql-basics

2name: mysql-basics

2version: 0.1.0.0

3version: 0.1.0.0

3synopsis: Simple MySQL API cookbook example

4synopsis: Simple MySQL API cookbook example

@@ -7,7 +8,6 @@ license-file: ../../../servant/LICENSE

7author: Servant Contributors

8author: Servant Contributors

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

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

9build-type: Simple

10build-type: Simple

10−cabal-version: >=1.10

11

12executable run

13 hs-source-dirs: .

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

@@ -1,3 +1,4 @@

1+cabal-version: 2.2

1name: cookbook-db-postgres-pool

2name: cookbook-db-postgres-pool

2version: 0.1

3version: 0.1

3synopsis: Simple PostgreSQL connection pool cookbook example

4synopsis: Simple PostgreSQL connection pool cookbook example

@@ -7,7 +8,6 @@ license-file: ../../../servant/LICENSE

7author: Servant Contributors

8author: Servant Contributors

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

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

9build-type: Simple

10build-type: Simple

10−cabal-version: >=1.10

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

12

13executable cookbook-db-postgres-pool

doc/cookbook/db-sqlite-simple/db-sqlite-simple.cabal+1−1

@@ -1,3 +1,4 @@

1+cabal-version: 2.2

1name: cookbook-db-sqlite-simple

2name: cookbook-db-sqlite-simple

2version: 0.1

3version: 0.1

3synopsis: Simple SQLite DB cookbook example

4synopsis: Simple SQLite DB cookbook example

@@ -7,7 +8,6 @@ license-file: ../../../servant/LICENSE

7author: Servant Contributors

8author: Servant Contributors

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

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

9build-type: Simple

10build-type: Simple

10−cabal-version: >=1.10

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

12

13executable cookbook-db-sqlite-simple

doc/cookbook/file-upload/file-upload.cabal+1−1

@@ -1,3 +1,4 @@

1+cabal-version: 2.2

1name: cookbook-file-upload

2name: cookbook-file-upload

2version: 0.1

3version: 0.1

3synopsis: File upload cookbook example

4synopsis: File upload cookbook example

@@ -7,7 +8,6 @@ license-file: ../../../servant/LICENSE

7author: Servant Contributors

8author: Servant Contributors

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

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

9build-type: Simple

10build-type: Simple

10−cabal-version: >=1.10

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

12

13executable cookbook-file-upload

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

@@ -1,3 +1,4 @@

1+cabal-version: 2.2

1name: cookbook-generic

2name: cookbook-generic

2version: 0.1

3version: 0.1

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

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

@@ -7,7 +8,6 @@ license-file: ../../../servant/LICENSE

7author: Servant Contributors

8author: Servant Contributors

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

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

9build-type: Simple

10build-type: Simple

10−cabal-version: >=1.10

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

12

13executable cookbook-using-custom-monad

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

@@ -1,3 +1,4 @@

1+cabal-version: 2.2

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

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

2version: 0.0.1

3version: 0.0.1

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

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

@@ -10,7 +11,6 @@ author: Servant Contributors

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

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

11category: Servant

12category: Servant

12build-type: Simple

13build-type: Simple

13−cabal-version: >=1.10

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

15

16executable cookbook-hoist-server-with-context

doc/cookbook/https/https.cabal+1−1

@@ -1,3 +1,4 @@

1+cabal-version: 2.2

1name: cookbook-https

2name: cookbook-https

2version: 0.1

3version: 0.1

3synopsis: HTTPS cookbook example

4synopsis: HTTPS cookbook example

@@ -7,7 +8,6 @@ license-file: ../../../servant/LICENSE

7author: Servant Contributors

8author: Servant Contributors

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

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

9build-type: Simple

10build-type: Simple

10−cabal-version: >=1.10

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

12

13executable cookbook-https

doc/cookbook/index.rst+3−2

@@ -6,8 +6,8 @@ how to solve many common problems with servant. If you're

6interested in contributing examples of your own, feel free

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

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

10−on freenode or on

10+on libera.chat <https://web.libera.chat/#haskell-servant>_ or on

11`the mailing list <https://groups.google.com/forum/#!forum/haskell-servant>`_.

12

13The scope is very wide. Simple and fancy authentication schemes,

@@ -37,3 +37,4 @@ you name it!

37 sentry/Sentry.lhs

38 testing/Testing.lhs

39 open-id-connect/OpenIdConnect.lhs

40+ managed-resource/ManagedResource.lhs

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

@@ -1,3 +1,4 @@

1+cabal-version: 2.2

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

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

2version: 0.0.1

3version: 0.0.1

3synopsis: JWT and basic access authentication cookbook example

4synopsis: JWT and basic access authentication cookbook example

@@ -10,7 +11,6 @@ author: Servant Contributors

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

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

11category: Servant

12category: Servant

12build-type: Simple

13build-type: Simple

13−cabal-version: >=1.10

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

15

16executable cookbook-jwt-and-basic-auth

doc/cookbook/managed-resource/ManagedResource.lhsnew file+114

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

1+# Request-lifetime Managed Resources

2+

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

4+

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

6+

7+

8+``` haskell

9+{-# LANGUAGE DataKinds #-}

10+{-# LANGUAGE TypeOperators #-}

11+import Control.Concurrent

12+import Control.Exception (bracket, throwIO)

13+import Control.Monad.IO.Class

14+import Control.Monad.Trans.Resource

15+import Data.Acquire

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

17+import Network.Wai.Handler.Warp

18+import Servant

19+import Servant.Client

20+import System.IO

21+```

22+

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

24+

25+``` haskell

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

27+

28+api :: Proxy API

29+api = Proxy

30+```

31+

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

33+

34+``` haskell

35+appContext :: Context '[Acquire Handle]

36+appContext = acquireHandle :. EmptyContext

37+

38+acquireHandle :: Acquire Handle

39+acquireHandle = mkAcquire newHandle closeHandle

40+

41+newHandle :: IO Handle

42+newHandle = do

43+ putStrLn "opening file"

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

45+ putStrLn "opened file"

46+ return h

47+

48+closeHandle :: Handle -> IO ()

49+closeHandle h = do

50+ putStrLn "closing file"

51+ hClose h

52+ putStrLn "closed file"

53+```

54+

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

56+

57+``` haskell

58+server :: Server API

59+server = writeToFile

60+

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

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

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

64+ legalMsg -> liftIO $ do

65+ putStrLn "writing file"

66+ hPutStrLn h legalMsg

67+ putStrLn "wrote file"

68+ return NoContent

69+```

70+

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

72+

73+``` haskell

74+runApp :: IO ()

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

76+

77+postMsg :: String -> ClientM NoContent

78+postMsg = client api

79+

80+main :: IO ()

81+main = do

82+ mgr <- newManager defaultManagerSettings

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

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

85+ liftIO $ putStrLn "sending hello message"

86+ _ <- postMsg "hello"

87+ liftIO $ putStrLn "sending illegal message"

88+ _ <- postMsg "illegal"

89+ liftIO $ putStrLn "done"

90+ print ms

91+```

92+

93+This program prints

94+

95+```

96+sending hello message

97+opening file

98+opened file

99+writing file

100+wrote file

101+closing file

102+closed file

103+sending illegal message

104+opening file

105+opened file

106+closing file

107+closed file

108+wait, that's illegal!

109+CallStack (from HasCallStack):

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

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

112+```

113+

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

doc/cookbook/managed-resource/managed-resource.cabalnew file+30

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

1+cabal-version: 2.2

2+name: cookbook-managed-resource

3+version: 0.1

4+synopsis: Simple managed resource cookbook example

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

6+license: BSD-3-Clause

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

8+author: Servant Contributors

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

10+build-type: Simple

11+tested-with: GHC==9.4.2

12+

13+executable cookbook-managed-resource

14+ main-is: ManagedResource.lhs

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

16+ , text >= 1.2

17+ , aeson >= 1.2

18+ , servant

19+ , servant-client

20+ , servant-server

21+ , warp >= 3.2

22+ , wai >= 3.2

23+ , http-types >= 0.12

24+ , markdown-unlit >= 0.4

25+ , http-client >= 0.5

26+ , transformers

27+ , resourcet

28+ default-language: Haskell2010

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

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

doc/cookbook/open-id-connect/OpenIdConnect.cabal+1−1

@@ -1,3 +1,4 @@

1+cabal-version: 2.2

1name: open-id-connect

2name: open-id-connect

2version: 0.1

3version: 0.1

3synopsis: OpenId Connect with Servant example

4synopsis: OpenId Connect with Servant example

@@ -7,7 +8,6 @@ license-file: ../../../servant/LICENSE

7author: Servant Contributors

8author: Servant Contributors

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

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

9build-type: Simple

10build-type: Simple

10−cabal-version: >= 1.10

11tested-with: GHC==8.6.5

12

13executable cookbook-openidconnect

doc/cookbook/open-id-connect/OpenIdConnect.lhs+1−1

@@ -330,7 +330,7 @@ data Customer = Customer {

330```

331

332Here is the code that displays the homepage.

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

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

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

335with some generated information.

336

doc/cookbook/pagination/pagination.cabal+1−1

@@ -1,3 +1,4 @@

1+cabal-version: 2.2

1name: cookbook-pagination

2name: cookbook-pagination

2version: 2.1

3version: 2.1

3synopsis: Pagination with Servant example

4synopsis: Pagination with Servant example

@@ -7,7 +8,6 @@ license-file: ../../../servant/LICENSE

7author: Servant Contributors

8author: Servant Contributors

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

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

9build-type: Simple

10build-type: Simple

10−cabal-version: >=1.10

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

12

13executable cookbook-pagination

doc/cookbook/sentry/sentry.cabal+1−1

@@ -1,3 +1,4 @@

1+cabal-version: 2.2

1name: cookbook-sentry

2name: cookbook-sentry

2version: 0.1

3version: 0.1

3synopsis: Collecting runtime exceptions using Sentry

4synopsis: Collecting runtime exceptions using Sentry

@@ -7,7 +8,6 @@ license-file: ../../../servant/LICENSE

7author: Servant Contributors

8author: Servant Contributors

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

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

9build-type: Simple

10build-type: Simple

10−cabal-version: >=1.10

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

12

13executable cookbook-sentry

doc/cookbook/structuring-apis/structuring-apis.cabal+1−1

@@ -1,3 +1,4 @@

1+cabal-version: 2.2

1name: cookbook-structuring-apis

2name: cookbook-structuring-apis

2version: 0.1

3version: 0.1

3synopsis: Example that shows how APIs can be structured

4synopsis: Example that shows how APIs can be structured

@@ -7,7 +8,6 @@ license-file: ../../../servant/LICENSE

7author: Servant Contributors

8author: Servant Contributors

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

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

9build-type: Simple

10build-type: Simple

10−cabal-version: >=1.10

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

12

13executable cookbook-structuring-apis

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

@@ -1,3 +1,4 @@

1+cabal-version: 2.2

1name: cookbook-testing

2name: cookbook-testing

2version: 0.0.1

3version: 0.0.1

3synopsis: Common testing patterns in Servant apps

4synopsis: Common testing patterns in Servant apps

@@ -9,7 +10,6 @@ author: Servant Contributors

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

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

10category: Servant

11category: Servant

11build-type: Simple

12build-type: Simple

12−cabal-version: >=1.10

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

14

15executable cookbook-testing

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

@@ -1,3 +1,4 @@

1+cabal-version: 2.2

1name: cookbook-using-custom-monad

2name: cookbook-using-custom-monad

2version: 0.1

3version: 0.1

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

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

@@ -7,7 +8,6 @@ license-file: ../../../servant/LICENSE

7author: Servant Contributors

8author: Servant Contributors

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

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

9build-type: Simple

10build-type: Simple

10−cabal-version: >=1.10

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

12

13executable cookbook-using-custom-monad

doc/cookbook/using-free-client/UsingFreeClient.lhs+1−1

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

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

120

121```haskell

122− let req' = I.defaultMakeClientRequest burl req

122+ req' <- I.defaultMakeClientRequest burl req

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

124```

125

doc/cookbook/using-free-client/using-free-client.cabal+1−1

@@ -1,3 +1,4 @@

1+cabal-version: 2.2

1name: cookbook-using-free-client

2name: cookbook-using-free-client

2version: 0.1

3version: 0.1

3synopsis: Using Free client

4synopsis: Using Free client

@@ -7,7 +8,6 @@ license-file: ../../../servant/LICENSE

7author: Servant Contributors

8author: Servant Contributors

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

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

9build-type: Simple

10build-type: Simple

10−cabal-version: >=1.10

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

12

13executable cookbook-using-free-client

doc/cookbook/uverb/UVerb.lhs+1−1

@@ -199,7 +199,7 @@ parsers in the hope that the ones that should will always error out so

199you 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

202+another shot at the problem. It is inspired by

203servant-checked-exceptions, so it may be worth taking a closer look.

204The README claims that

205[cardano-sl](https://github.com/input-output-hk/cardano-sl) also has

doc/cookbook/uverb/uverb.cabal+1−1

@@ -1,3 +1,4 @@

1+cabal-version: 2.2

1name: cookbook-uverb

2name: cookbook-uverb

2version: 0.0.1

3version: 0.0.1

3synopsis: How to use the 'UVerb' type.

4synopsis: How to use the 'UVerb' type.

@@ -9,7 +10,6 @@ author: Servant Contributors

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

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

10category: Servant

11category: Servant

11build-type: Simple

12build-type: Simple

12−cabal-version: >=1.10

13tested-with: GHC==8.6.5, GHC==8.8.4, GHC==8.10.7

14

15executable cookbook-uverb

doc/links.rst+1−1

@@ -12,7 +12,7 @@ Helpful Links

12 `https://github.com/haskell-servant/servant/issues <https://github.com/haskell-servant/servant/issues>`_

13

14- the irc channel:

15− ``#servant`` on freenode

15+ `#haskell-servant on libera.chat <https://web.libera.chat/#haskell-servant>`_

16

17- the mailing list:

18 `groups.google.com/forum/#!forum/haskell-servant <https://groups.google.com/forum/#!forum/haskell-servant>`_

doc/requirements.txt+1

@@ -1,3 +1,4 @@

1recommonmark==0.5.0

2Sphinx==1.8.4

3sphinx_rtd_theme>=0.4.2

4+jinja2<3.1.0

doc/tutorial/install.rst+26

@@ -40,3 +40,29 @@ nix

40`Nix <https://nixos.org/nix/>`_ users should feel free to take a look at

41the `nix/shell.nix` file in the repository and use it to provision a suitable

42environment 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/tutorial.cabal+2−2

@@ -1,3 +1,4 @@

1+cabal-version: 2.2

1name: tutorial

2name: tutorial

2version: 0.10

3version: 0.10

3synopsis: The servant tutorial

4synopsis: The servant tutorial

@@ -11,7 +12,6 @@ license-file: LICENSE

11author: Servant Contributors

12author: Servant Contributors

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

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

13build-type: Simple

14build-type: Simple

14−cabal-version: >=1.10

15tested-with:

16 GHC==8.6.5

17 GHC==8.8.3, GHC ==8.10.7

@@ -64,7 +64,7 @@ library

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

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

servant-auth/servant-auth-client/servant-auth-client.cabal+13−13

@@ -1,3 +1,4 @@

1+cabal-version: 2.2

1name: servant-auth-client

2name: servant-auth-client

2version: 0.4.1.0

3version: 0.4.1.0

3synopsis: servant-client/servant-auth compatibility

4synopsis: servant-client/servant-auth compatibility

@@ -6,9 +7,9 @@ description: This package provides instances that allow generating clients fr

6 APIs that use

7 APIs that use

7 <https://hackage.haskell.org/package/servant-auth servant-auth's> @Auth@ combinator.

8 <https://hackage.haskell.org/package/servant-auth servant-auth's> @Auth@ combinator.

8 .

9 .

9− For a quick overview of the usage, see the <http://github.com/haskell-servant/servant/servant-auth#readme README>.

10+ For a quick overview of the usage, see the <https://github.com/haskell-servant/servant/tree/master/servant-auth#readme README>.

10category: Web, Servant, Authentication

11category: Web, Servant, Authentication

11−homepage: http://github.com/haskell-servant/servant/servant-auth#readme

12+homepage: https://github.com/haskell-servant/servant/tree/master/servant-auth#readme

12bug-reports: https://github.com/haskell-servant/servant/issues

13bug-reports: https://github.com/haskell-servant/servant/issues

13author: Julian K. Arni

14author: Julian K. Arni

14maintainer: jkarni@gmail.com

15maintainer: jkarni@gmail.com

@@ -17,7 +18,6 @@ license: BSD-3-Clause

17license-file: LICENSE

18license-file: LICENSE

18tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1

19tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1

19build-type: Simple

20build-type: Simple

20−cabal-version: >= 1.10

21extra-source-files:

22 CHANGELOG.md

23

@@ -31,12 +31,12 @@ library

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

34+ base >= 4.10 && < 4.18

35− , bytestring >= 0.10.6.0 && < 0.11

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

38+ , servant >= 0.13 && < 0.20

39− , servant-client-core >= 0.13 && < 0.19

39+ , servant-client-core >= 0.13 && < 0.20

40

41 exposed-modules:

42 Servant.Auth.Client

@@ -50,7 +50,7 @@ test-suite spec

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

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:

@@ -62,19 +62,19 @@ test-suite spec

62

63 -- test dependencies

64 build-depends:

65− hspec >= 2.5.5 && < 2.9

65+ hspec >= 2.5.5 && < 2.10

66 , QuickCheck >= 2.11.3 && < 2.15

67− , aeson >= 1.3.1.1 && < 1.6

67+ , aeson >= 1.3.1.1 && < 3

68− , bytestring >= 0.10.6.0 && < 0.11

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

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

77+ , jose >= 0.10 && < 0.11

78 other-modules:

79 Servant.Auth.ClientSpec

80 default-language: Haskell2010

servant-auth/servant-auth-docs/servant-auth-docs.cabal+10−10

@@ -1,3 +1,4 @@

1+cabal-version: 2.2

1name: servant-auth-docs

2name: servant-auth-docs

2version: 0.2.10.0

3version: 0.2.10.0

3synopsis: servant-docs/servant-auth compatibility

4synopsis: servant-docs/servant-auth compatibility

@@ -6,9 +7,9 @@ description: This package provides instances that allow generating docs from

6 APIs that use

7 APIs that use

7 <https://hackage.haskell.org/package/servant-auth servant-auth's> @Auth@ combinator.

8 <https://hackage.haskell.org/package/servant-auth servant-auth's> @Auth@ combinator.

8 .

9 .

9− For a quick overview of the usage, see the <http://github.com/haskell-servant/servant/servant-auth#readme README>.

10+ For a quick overview of the usage, see the <https://github.com/haskell-servant/servant/tree/master/servant-auth#readme README>.

10category: Web, Servant, Authentication

11category: Web, Servant, Authentication

11−homepage: http://github.com/haskell-servant/servant/servant-auth#readme

12+homepage: https://github.com/haskell-servant/servant/tree/master/servant-auth#readme

12bug-reports: https://github.com/haskell-servant/servant/issues

13bug-reports: https://github.com/haskell-servant/servant/issues

13author: Julian K. Arni

14author: Julian K. Arni

14maintainer: jkarni@gmail.com

15maintainer: jkarni@gmail.com

@@ -17,7 +18,6 @@ license: BSD-3-Clause

17license-file: LICENSE

18license-file: LICENSE

18tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1

19tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1

19build-type: Custom

20build-type: Custom

20−cabal-version: >= 1.10

21extra-source-files:

22 CHANGELOG.md

23

@@ -35,11 +35,11 @@ library

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

38+ base >= 4.10 && < 4.18

39− , servant-docs >= 0.11.2 && < 0.12

39+ , servant-docs >= 0.11.2 && < 0.13

40− , servant >= 0.13 && < 0.19

40+ , servant >= 0.13 && < 0.20

41 , servant-auth == 0.4.*

42− , lens >= 4.16.1 && <5.1

42+ , lens >= 4.16.1 && <5.3

43 exposed-modules:

44 Servant.Auth.Docs

45 default-language: Haskell2010

@@ -50,7 +50,7 @@ test-suite doctests

50 build-depends:

51 base,

52 servant-auth-docs,

53− doctest >= 0.16 && < 0.19,

53+ doctest >= 0.16 && < 0.21,

54 QuickCheck >= 2.11.3 && < 2.15,

55 template-haskell

56 ghc-options: -Wall -threaded

@@ -64,7 +64,7 @@ test-suite spec

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

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:

@@ -78,7 +78,7 @@ test-suite spec

78 -- test dependencies

79 build-depends:

80 servant-auth-docs

81− , hspec >= 2.5.5 && < 2.9

81+ , hspec >= 2.5.5 && < 2.10

82 , QuickCheck >= 2.11.3 && < 2.15

83

84 default-language: Haskell2010

servant-auth/servant-auth-server/servant-auth-server.cabal+20−19

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

1+cabal-version: 2.2

1name: servant-auth-server

2name: servant-auth-server

2−version: 0.4.6.0

3+version: 0.4.7.0

3synopsis: servant-server/servant-auth compatibility

4synopsis: servant-server/servant-auth compatibility

4description: This package provides the required instances for using the @Auth@ combinator

5description: This package provides the required instances for using the @Auth@ combinator

5 in your 'servant' server.

6 in your 'servant' server.

6 .

7 .

7 Both cookie- and token- (REST API) based authentication is provided.

8 Both cookie- and token- (REST API) based authentication is provided.

8 .

9 .

9− For a quick overview of the usage, see the <http://github.com/haskell-servant/servant/servant-auth#readme README>.

10+ For a quick overview of the usage, see the <https://github.com/haskell-servant/servant/tree/master/servant-auth#readme README>.

10category: Web, Servant, Authentication

11category: Web, Servant, Authentication

11−homepage: http://github.com/haskell-servant/servant/servant-auth#readme

12+homepage: https://github.com/haskell-servant/servant/tree/master/servant-auth#readme

12bug-reports: https://github.com/haskell-servant/servant/issues

13bug-reports: https://github.com/haskell-servant/servant/issues

13author: Julian K. Arni

14author: Julian K. Arni

14maintainer: jkarni@gmail.com

15maintainer: jkarni@gmail.com

@@ -17,7 +18,6 @@ license: BSD-3-Clause

17license-file: LICENSE

18license-file: LICENSE

18tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1

19tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1

19build-type: Simple

20build-type: Simple

20−cabal-version: >= 1.10

21extra-source-files:

22 CHANGELOG.md

23

@@ -31,27 +31,27 @@ library

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

34+ base >= 4.10 && < 4.18

35− , aeson >= 1.3.1.1 && < 1.6

35+ , aeson >= 1.0.0.1 && < 3

36− , base64-bytestring >= 1.0.0.1 && < 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.11

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

44+ , jose >= 0.10 && < 0.11

45− , lens >= 4.16.1 && < 5.1

45+ , lens >= 4.16.1 && < 5.3

46− , memory >= 0.14.16 && < 0.17

46+ , memory >= 0.14.16 && < 0.19

47 , monad-time >= 0.3.1.0 && < 0.4

48− , mtl >= 2.2.2 && < 2.3

48+ , mtl ^>= 2.2.2 || ^>= 2.3.1

49− , servant >= 0.13 && < 0.19

49+ , servant >= 0.13 && < 0.20

50 , servant-auth == 0.4.*

51− , servant-server >= 0.13 && < 0.19

51+ , servant-server >= 0.13 && < 0.20

52 , tagged >= 0.8.4 && < 0.9

53− , text >= 1.2.3.0 && < 1.3

53+ , text >= 1.2.3.0 && < 2.1

54− , time >= 1.5.0.1 && < 1.10

54+ , time >= 1.5.0.1 && < 1.13

55 , unordered-containers >= 0.2.9.0 && < 0.3

56 , wai >= 3.2.1.2 && < 3.3

57

@@ -102,7 +102,7 @@ test-suite spec

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

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:

@@ -123,12 +123,13 @@ test-suite spec

123 -- test dependencies

124 build-depends:

125 servant-auth-server

126− , hspec >= 2.5.5 && < 2.8

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

129+ , lens-aeson >= 1.0.2 && < 1.3

130 , warp >= 3.2.25 && < 3.4

131 , wreq >= 0.5.2.1 && < 0.6

132+ , text >= 1.2.3.0 && < 2.1

132 other-modules:

133 other-modules:

133 Servant.Auth.ServerSpec

134 Servant.Auth.ServerSpec

134 default-language: Haskell2010

135 default-language: Haskell2010

servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal.hs+6−9

@@ -54,15 +54,12 @@ instance ( n ~ 'S ('S 'Z)

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

57+ case authResult of

60− (Authenticated v) -> do

58+ (Authenticated v) -> do

61− ejwt <- makeSessionCookie cookieSettings jwtSettings v

59+ ejwt <- makeSessionCookie cookieSettings jwtSettings v

62− case ejwt of

60+ xsrf <- makeXsrfCookie cookieSettings

63− Nothing -> return $ Nothing `SetCookieCons` SetCookieNil

64− Just jwt -> return $ Just jwt `SetCookieCons` SetCookieNil

61+ return $ Just xsrf `SetCookieCons` (ejwt `SetCookieCons` SetCookieNil)

65− _ -> return $ Nothing `SetCookieCons` SetCookieNil

62+ _ -> return $ Nothing `SetCookieCons` (Nothing `SetCookieCons` SetCookieNil)

66

63

67 go :: (AuthResult v -> ServerT api Handler)

64 go :: (AuthResult v -> ServerT api Handler)

68 -> (AuthResult v, SetCookieList n)

65 -> (AuthResult v, SetCookieList n)

servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/AddSetCookie.hs+26−1

@@ -11,6 +11,9 @@ import Data.Tagged (Tagged (..))

11import qualified Network.HTTP.Types as HTTP

12import Network.Wai (mapResponseHeaders)

13import Servant

14+import Servant.API.UVerb.Union

15+import Servant.API.Generic

16+import Servant.Server.Generic

14import Web.Cookie

17import Web.Cookie

15

18

16-- What are we doing here? Well, the idea is to add headers to the response,

19-- What are we doing here? Well, the idea is to add headers to the response,

@@ -31,11 +34,24 @@ type family AddSetCookieApiVerb a where

31 AddSetCookieApiVerb (Headers ls a) = Headers (Header "Set-Cookie" SetCookie ': ls) a

34 AddSetCookieApiVerb (Headers ls a) = Headers (Header "Set-Cookie" SetCookie ': ls) a

32 AddSetCookieApiVerb a = Headers '[Header "Set-Cookie" SetCookie] a

35 AddSetCookieApiVerb a = Headers '[Header "Set-Cookie" SetCookie] a

33

36

37+#if MIN_VERSION_servant_server(0,18,1)

38+type family MapAddSetCookieApiVerb (as :: [*]) where

39+ MapAddSetCookieApiVerb '[] = '[]

40+ MapAddSetCookieApiVerb (a ': as) = (AddSetCookieApiVerb a ': MapAddSetCookieApiVerb as)

41+#endif

42+

34type family AddSetCookieApi a :: *

43type family AddSetCookieApi a :: *

35type instance AddSetCookieApi (a :> b) = a :> AddSetCookieApi b

44type instance AddSetCookieApi (a :> b) = a :> AddSetCookieApi b

36type instance AddSetCookieApi (a :<|> b) = AddSetCookieApi a :<|> AddSetCookieApi b

45type instance AddSetCookieApi (a :<|> b) = AddSetCookieApi a :<|> AddSetCookieApi b

46+#if MIN_VERSION_servant_server(0,19,0)

47+type instance AddSetCookieApi (NamedRoutes api) = AddSetCookieApi (ToServantApi api)

48+#endif

37type instance AddSetCookieApi (Verb method stat ctyps a)

49type instance AddSetCookieApi (Verb method stat ctyps a)

38 = Verb method stat ctyps (AddSetCookieApiVerb a)

50 = Verb method stat ctyps (AddSetCookieApiVerb a)

51+#if MIN_VERSION_servant_server(0,18,1)

52+type instance AddSetCookieApi (UVerb method ctyps as)

53+ = UVerb method ctyps (MapAddSetCookieApiVerb as)

54+#endif

39type instance AddSetCookieApi Raw = Raw

55type instance AddSetCookieApi Raw = Raw

40#if MIN_VERSION_servant_server(0,15,0)

56#if MIN_VERSION_servant_server(0,15,0)

41type instance AddSetCookieApi (Stream method stat framing ctyps a)

57type instance AddSetCookieApi (Stream method stat framing ctyps a)

@@ -54,7 +70,7 @@ instance {-# OVERLAPS #-} AddSetCookies ('S n) oldb newb

54 => AddSetCookies ('S n) (a -> oldb) (a -> newb) where

70 => AddSetCookies ('S n) (a -> oldb) (a -> newb) where

55 addSetCookies cookies oldfn = addSetCookies cookies . oldfn

71 addSetCookies cookies oldfn = addSetCookies cookies . oldfn

56

72

57−instance AddSetCookies 'Z orig orig where

73+instance (orig1 ~ orig2) => AddSetCookies 'Z orig1 orig2 where

58 addSetCookies _ = id

74 addSetCookies _ = id

59

75

60instance {-# OVERLAPPABLE #-}

76instance {-# OVERLAPPABLE #-}

@@ -72,6 +88,15 @@ instance {-# OVERLAPS #-}

72 => AddSetCookies ('S n) (a :<|> b) (a' :<|> b') where

88 => AddSetCookies ('S n) (a :<|> b) (a' :<|> b') where

73 addSetCookies cookies (a :<|> b) = addSetCookies cookies a :<|> addSetCookies cookies b

89 addSetCookies cookies (a :<|> b) = addSetCookies cookies a :<|> addSetCookies cookies b

74

90

91+instance {-# OVERLAPS #-}

92+ ( AddSetCookies ('S n) (ServerT (ToServantApi api) m) cookiedApi

93+ , Generic (api (AsServerT m))

94+ , GServantProduct (Rep (api (AsServerT m)))

95+ , ToServant api (AsServerT m) ~ ServerT (ToServantApi api) m

96+ )

97+ => AddSetCookies ('S n) (api (AsServerT m)) cookiedApi where

98+ addSetCookies cookies = addSetCookies cookies . toServant

99+

75-- | for @servant <0.11@

100-- | for @servant <0.11@

76instance

101instance

77 AddSetCookies ('S n) Application Application where

102 AddSetCookies ('S n) Application Application where

servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/ConfigTypes.hs+2−2

@@ -33,7 +33,7 @@ data JWTSettings = JWTSettings

33 -- | Algorithm used to sign JWT.

34 , jwtAlg :: Maybe Jose.Alg

35 -- | Keys used to validate JWT.

36− , validationKeys :: Jose.JWKSet

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

@@ -44,7 +44,7 @@ defaultJWTSettings :: Jose.JWK -> JWTSettings

44defaultJWTSettings k = JWTSettings

45 { signingKey = k

46 , jwtAlg = Nothing

47− , validationKeys = Jose.JWKSet [k]

47+ , validationKeys = pure $ Jose.JWKSet [k]

48 , audienceMatches = const Matches }

49

50-- | The policies to use when generating cookies.

servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/Cookie.hs+1

@@ -2,6 +2,7 @@

2module Servant.Auth.Server.Internal.Cookie where

3

4import Blaze.ByteString.Builder (toByteString)

5+import Control.Monad (MonadPlus(..), guard)

5import Control.Monad.Except

6import Control.Monad.Except

6import Control.Monad.Reader

7import Control.Monad.Reader

7import qualified Crypto.JOSE as Jose

8import qualified Crypto.JOSE as Jose

servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/JWT.hs+6−9

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

1module Servant.Auth.Server.Internal.JWT where

2

3import Control.Lens

4−import Control.Monad.Except

4+import Control.Monad (MonadPlus(..), guard)

5import Control.Monad.Reader

6import qualified Crypto.JOSE as Jose

7import qualified Crypto.JWT as Jose

8−import Data.Aeson (FromJSON, Result (..), ToJSON, fromJSON,

9− toJSON)

10import Data.ByteArray (constEq)

8import Data.ByteArray (constEq)

11import qualified Data.ByteString as BS

9import qualified Data.ByteString as BS

12import qualified Data.ByteString.Lazy as BSL

10import qualified Data.ByteString.Lazy as BSL

13−import qualified Data.HashMap.Strict as HM

14import Data.Maybe (fromMaybe)

11import Data.Maybe (fromMaybe)

15−import qualified Data.Text as T

16import Data.Time (UTCTime)

12import Data.Time (UTCTime)

17import Network.Wai (requestHeaders)

13import Network.Wai (requestHeaders)

18

14

@@ -42,7 +38,7 @@ jwtAuthCheck jwtSettings = do

42-- token expires.

38-- token expires.

43makeJWT :: ToJWT a

39makeJWT :: ToJWT a

44 => a -> JWTSettings -> Maybe UTCTime -> IO (Either Jose.Error BSL.ByteString)

40 => a -> JWTSettings -> Maybe UTCTime -> IO (Either Jose.Error BSL.ByteString)

45−makeJWT v cfg expiry = runExceptT $ do

41+makeJWT v cfg expiry = Jose.runJOSE $ do

46 bestAlg <- Jose.bestJWSAlg $ signingKey cfg

42 bestAlg <- Jose.bestJWSAlg $ signingKey cfg

47 let alg = fromMaybe bestAlg $ jwtAlg cfg

43 let alg = fromMaybe bestAlg $ jwtAlg cfg

48 ejwt <- Jose.signClaims (signingKey cfg)

44 ejwt <- Jose.signClaims (signingKey cfg)

@@ -58,14 +54,15 @@ makeJWT v cfg expiry = runExceptT $ do

58

54

59verifyJWT :: FromJWT a => JWTSettings -> BS.ByteString -> IO (Maybe a)

55verifyJWT :: FromJWT a => JWTSettings -> BS.ByteString -> IO (Maybe a)

60verifyJWT jwtCfg input = do

56verifyJWT jwtCfg input = do

57+ keys <- validationKeys jwtCfg

61− verifiedJWT <- liftIO $ runExceptT $ do

58+ verifiedJWT <- Jose.runJOSE $ do

62 unverifiedJWT <- Jose.decodeCompact (BSL.fromStrict input)

59 unverifiedJWT <- Jose.decodeCompact (BSL.fromStrict input)

63 Jose.verifyClaims

60 Jose.verifyClaims

64 (jwtSettingsToJwtValidationSettings jwtCfg)

61 (jwtSettingsToJwtValidationSettings jwtCfg)

65− (validationKeys jwtCfg)

62+ keys

66 unverifiedJWT

63 unverifiedJWT

67 return $ case verifiedJWT of

64 return $ case verifiedJWT of

68 Left (_ :: Jose.JWTError) -> Nothing

65 Left (_ :: Jose.JWTError) -> Nothing

69 Right v -> case decodeJWT v of

66 Right v -> case decodeJWT v of

70 Left _ -> Nothing

67 Left _ -> Nothing

71− Right v' -> Just v'

68+ Right v' -> Just v'

servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/ThrowAll.hs+10−1

@@ -8,7 +8,10 @@ module Servant.Auth.Server.Internal.ThrowAll where

8

9import Control.Monad.Error.Class

10import Data.Tagged (Tagged (..))

11−import Servant ((:<|>) (..), ServerError(..))

11+import Servant ((:<|>) (..), ServerError(..), NamedRoutes(..))

12+import Servant.API.Generic

13+import Servant.Server.Generic

14+import Servant.Server

12import Network.HTTP.Types

15import Network.HTTP.Types

13import Network.Wai

16import Network.Wai

14

17

@@ -26,6 +29,12 @@ class ThrowAll a where

26instance (ThrowAll a, ThrowAll b) => ThrowAll (a :<|> b) where

29instance (ThrowAll a, ThrowAll b) => ThrowAll (a :<|> b) where

27 throwAll e = throwAll e :<|> throwAll e

30 throwAll e = throwAll e :<|> throwAll e

28

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+

29-- Really this shouldn't be necessary - ((->) a) should be an instance of

38-- Really this shouldn't be necessary - ((->) a) should be an instance of

30-- MonadError, no?

39-- MonadError, no?

31instance {-# OVERLAPPING #-} ThrowAll b => ThrowAll (a -> b) where

40instance {-# OVERLAPPING #-} ThrowAll b => ThrowAll (a -> b) where

servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/Types.hs+1

@@ -2,6 +2,7 @@

2module Servant.Auth.Server.Internal.Types where

3

4import Control.Applicative

5+import Control.Monad (MonadPlus(..), ap)

5import Control.Monad.Reader

6import Control.Monad.Reader

6import Control.Monad.Time

7import Control.Monad.Time

7import Data.Monoid (Monoid (..))

8import Data.Monoid (Monoid (..))

servant-auth/servant-auth-server/test/Servant/Auth/ServerSpec.hs+39−5

@@ -1,4 +1,5 @@

1{-# LANGUAGE CPP #-}

2+{-# LANGUAGE TypeApplications #-}

2module Servant.Auth.ServerSpec (spec) where

3module Servant.Auth.ServerSpec (spec) where

3

4

4#if !MIN_VERSION_servant_server(0,16,0)

5#if !MIN_VERSION_servant_server(0,16,0)

@@ -6,13 +7,12 @@ module Servant.Auth.ServerSpec (spec) where

6#endif

7#endif

7

8

8import Control.Lens

9import Control.Lens

9−import Control.Monad.Except (runExceptT)

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

11import Crypto.JOSE (Alg (HS256, None), Error,

12 JWK, JWSHeader,

13 KeyMaterialGenParam (OctGenParam),

14 ToCompact, encodeCompact,

15− genJWK, newJWSHeader)

15+ genJWK, newJWSHeader, runJOSE)

16import Crypto.JWT (Audience (..), ClaimsSet,

17 NumericDate (NumericDate),

18 SignedJWT,

@@ -25,6 +25,7 @@ import Data.Aeson (FromJSON, ToJSON, Value,

25import Data.Aeson.Lens (_JSON)

26import qualified Data.ByteString as BS

27import qualified Data.ByteString.Lazy as BSL

28+import Data.Text (Text, pack)

28import Data.CaseInsensitive (mk)

29import Data.CaseInsensitive (mk)

29import Data.Foldable (find)

30import Data.Foldable (find)

30import Data.Monoid

31import Data.Monoid

@@ -40,6 +41,7 @@ import Network.HTTP.Types (Status, status200,

40import Network.Wai (responseLBS)

41import Network.Wai (responseLBS)

41import Network.Wai.Handler.Warp (testWithApplication)

42import Network.Wai.Handler.Warp (testWithApplication)

42import Network.Wreq (Options, auth, basicAuth,

43import Network.Wreq (Options, auth, basicAuth,

44+ checkResponse,

43 cookieExpiryTime, cookies,

45 cookieExpiryTime, cookies,

44 defaults, get, getWith, postWith,

46 defaults, get, getWith, postWith,

45 header, oauth2Bearer,

47 header, oauth2Bearer,

@@ -50,6 +52,7 @@ import Network.Wreq (Options, auth, basicAuth,

50import Network.Wreq.Types (Postable(..))

52import Network.Wreq.Types (Postable(..))

51import Servant hiding (BasicAuth,

53import Servant hiding (BasicAuth,

52 IsSecure (..), header)

54 IsSecure (..), header)

55+import Servant.API.Generic ((:-))

53import Servant.Auth.Server

56import Servant.Auth.Server

54import Servant.Auth.Server.Internal.Cookie (expireTime)

57import Servant.Auth.Server.Internal.Cookie (expireTime)

55import Servant.Auth.Server.SetCookieOrphan ()

58import Servant.Auth.Server.SetCookieOrphan ()

@@ -182,8 +185,21 @@ cookieAuthSpec

182 it "fails with no XSRF header or cookie" $ \port -> property

185 it "fails with no XSRF header or cookie" $ \port -> property

183 $ \(user :: User) -> do

186 $ \(user :: User) -> do

184 jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)

187 jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user)

185− opts <- addJwtToCookie cookieCfg jwt

188+ opts' <- addJwtToCookie cookieCfg jwt

189+ let opts = opts' & checkResponse .~ Just mempty

186− getWith opts (url port) `shouldHTTPErrorWith` status401

190+ resp <- getWith opts (url port)

191+ resp ^. responseStatus `shouldBe` status401

192+ (resp ^. responseCookieJar) `shouldNotHaveCookies` ["XSRF-TOKEN"]

193+

194+ -- Validating that the XSRF cookie isn't added for UVerb routes either.

195+ -- These routes can return a 401 response directly without using throwError / throwAll,

196+ -- which revealed a bug:

197+ --

198+ -- https://github.com/haskell-servant/servant/issues/1570#issuecomment-1076374449

199+ resp <- getWith opts (url port ++ "/uverb")

200+ resp ^. responseStatus `shouldBe` status401

201+ (resp ^. responseCookieJar) `shouldNotHaveCookies` ["XSRF-TOKEN"]

202+

187

203

188 it "succeeds if XSRF header and cookie match, and JWT is valid" $ \port -> property

204 it "succeeds if XSRF header and cookie match, and JWT is valid" $ \port -> property

189 $ \(user :: User) -> do

205 $ \(user :: User) -> do

@@ -405,17 +421,23 @@ type API auths

405 = Auth auths User :>

421 = Auth auths User :>

406 ( Get '[JSON] Int

422 ( Get '[JSON] Int

407 :<|> ReqBody '[JSON] Int :> Post '[JSON] Int

423 :<|> ReqBody '[JSON] Int :> Post '[JSON] Int

424+ :<|> "named" :> NamedRoutes DummyRoutes

408 :<|> "header" :> Get '[JSON] (Headers '[Header "Blah" Int] Int)

425 :<|> "header" :> Get '[JSON] (Headers '[Header "Blah" Int] Int)

409#if MIN_VERSION_servant_server(0,15,0)

426#if MIN_VERSION_servant_server(0,15,0)

410 :<|> "stream" :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString)

427 :<|> "stream" :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString)

411#endif

428#endif

412 :<|> "raw" :> Raw

429 :<|> "raw" :> Raw

413 )

430 )

431+ :<|> "uverb" :> Auth auths User :> UVerb 'GET '[JSON] '[WithStatus 200 Int, WithStatus 401 Text, WithStatus 403 Text]

414 :<|> "login" :> ReqBody '[JSON] User :> Post '[JSON] (Headers '[ Header "Set-Cookie" SetCookie

432 :<|> "login" :> ReqBody '[JSON] User :> Post '[JSON] (Headers '[ Header "Set-Cookie" SetCookie

415 , Header "Set-Cookie" SetCookie ] NoContent)

433 , Header "Set-Cookie" SetCookie ] NoContent)

416 :<|> "logout" :> Get '[JSON] (Headers '[ Header "Set-Cookie" SetCookie

434 :<|> "logout" :> Get '[JSON] (Headers '[ Header "Set-Cookie" SetCookie

417 , Header "Set-Cookie" SetCookie ] NoContent)

435 , Header "Set-Cookie" SetCookie ] NoContent)

418

436

437+data DummyRoutes mode = DummyRoutes

438+ { dummyInt :: mode :- "dummy" :> Get '[JSON] Int

439+ } deriving Generic

440+

419jwtOnlyApi :: Proxy (API '[Servant.Auth.Server.JWT])

441jwtOnlyApi :: Proxy (API '[Servant.Auth.Server.JWT])

420jwtOnlyApi = Proxy

442jwtOnlyApi = Proxy

421

443

@@ -476,6 +498,7 @@ server ccfg =

476 (\authResult -> case authResult of

498 (\authResult -> case authResult of

477 Authenticated usr -> getInt usr

499 Authenticated usr -> getInt usr

478 :<|> postInt usr

500 :<|> postInt usr

501+ :<|> DummyRoutes { dummyInt = getInt usr }

479 :<|> getHeaderInt

502 :<|> getHeaderInt

480#if MIN_VERSION_servant_server(0,15,0)

503#if MIN_VERSION_servant_server(0,15,0)

481 :<|> return (S.source ["bytestring"])

504 :<|> return (S.source ["bytestring"])

@@ -483,6 +506,11 @@ server ccfg =

483 :<|> raw

506 :<|> raw

484 Indefinite -> throwAll err401

507 Indefinite -> throwAll err401

485 _ -> throwAll err403

508 _ -> throwAll err403

509+ ) :<|>

510+ (\authResult -> case authResult of

511+ Authenticated usr -> respond (WithStatus @200 (42 :: Int))

512+ Indefinite -> respond (WithStatus @401 $ pack "Authentication required")

513+ _ -> respond (WithStatus @403 $ pack "Forbidden")

486 )

514 )

487 :<|> getLogin

515 :<|> getLogin

488 :<|> getLogout

516 :<|> getLogout

@@ -533,7 +561,7 @@ addJwtToHeader jwt = case jwt of

533 $ defaults & header "Authorization" .~ ["Bearer " <> BSL.toStrict v]

561 $ defaults & header "Authorization" .~ ["Bearer " <> BSL.toStrict v]

534

562

535createJWT :: JWK -> JWSHeader () -> ClaimsSet -> IO (Either Error Crypto.JWT.SignedJWT)

563createJWT :: JWK -> JWSHeader () -> ClaimsSet -> IO (Either Error Crypto.JWT.SignedJWT)

536−createJWT k a b = runExceptT $ signClaims k a b

564+createJWT k a b = runJOSE $ signClaims k a b

537

565

538addJwtToCookie :: ToCompact a => CookieSettings -> Either Error a -> IO Options

566addJwtToCookie :: ToCompact a => CookieSettings -> Either Error a -> IO Options

539addJwtToCookie ccfg jwt = case jwt >>= (return . encodeCompact) of

567addJwtToCookie ccfg jwt = case jwt >>= (return . encodeCompact) of

@@ -563,6 +591,12 @@ shouldMatchCookieNames cj patterns

563 = fmap cookie_name (destroyCookieJar cj)

591 = fmap cookie_name (destroyCookieJar cj)

564 `shouldMatchList` patterns

592 `shouldMatchList` patterns

565

593

594+shouldNotHaveCookies :: HCli.CookieJar -> [BS.ByteString] -> Expectation

595+shouldNotHaveCookies cj patterns =

596+ sequence_ $ (\cookieName -> cookieNames `shouldNotContain` [cookieName]) <$> patterns

597+ where cookieNames :: [BS.ByteString]

598+ cookieNames = cookie_name <$> destroyCookieJar cj

599+

566shouldMatchCookieNameValues :: HCli.CookieJar -> [(BS.ByteString, BS.ByteString)] -> Expectation

600shouldMatchCookieNameValues :: HCli.CookieJar -> [(BS.ByteString, BS.ByteString)] -> Expectation

567shouldMatchCookieNameValues cj patterns

601shouldMatchCookieNameValues cj patterns

568 = fmap ((,) <$> cookie_name <*> cookie_value) (destroyCookieJar cj)

602 = fmap ((,) <$> cookie_name <*> cookie_value) (destroyCookieJar cj)

servant-auth/servant-auth-swagger/servant-auth-swagger.cabal+12−16

@@ -1,3 +1,4 @@

1+cabal-version: 2.2

1name: servant-auth-swagger

2name: servant-auth-swagger

2version: 0.2.10.1

3version: 0.2.10.1

3synopsis: servant-swagger/servant-auth compatibility

4synopsis: servant-swagger/servant-auth compatibility

@@ -6,9 +7,9 @@ description: This package provides instances that allow generating swagger2 s

6 APIs that use

7 APIs that use

7 <https://hackage.haskell.org/package/servant-auth servant-auth's> @Auth@ combinator.

8 <https://hackage.haskell.org/package/servant-auth servant-auth's> @Auth@ combinator.

8 .

9 .

9− For a quick overview of the usage, see the <http://github.com/haskell-servant/servant/servant-auth#readme README>.

10+ For a quick overview of the usage, see the <https://github.com/haskell-servant/servant/tree/master/servant-auth#readme README>.

10category: Web, Servant, Authentication

11category: Web, Servant, Authentication

11−homepage: http://github.com/haskell-servant/servant/servant-auth#readme

12+homepage: https://github.com/haskell-servant/servant/tree/master/servant-auth#readme

12bug-reports: https://github.com/haskell-servant/servant/issues

13bug-reports: https://github.com/haskell-servant/servant/issues

13author: Julian K. Arni

14author: Julian K. Arni

14maintainer: jkarni@gmail.com

15maintainer: jkarni@gmail.com

@@ -17,7 +18,6 @@ license: BSD-3-Clause

17license-file: LICENSE

18license-file: LICENSE

18tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4

19tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4

19build-type: Simple

20build-type: Simple

20−cabal-version: >= 1.10

21extra-source-files:

22 CHANGELOG.md

23

@@ -31,15 +31,13 @@ library

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

34+ base >= 4.10 && < 4.18

35− , text >= 1.2.3.0 && < 1.3

35+ , text >= 1.2.3.0 && < 2.1

36− , servant-swagger >= 1.1.5 && < 1.8

36+ , servant-swagger >= 1.1.5 && < 2

37− , swagger2 >= 2.2.2 && < 2.7

37+ , swagger2 >= 2.2.2 && < 3

38− , servant >= 0.13 && < 0.19

38+ , servant >= 0.13 && < 0.20

39 , servant-auth == 0.4.*

40− , lens >= 4.16.1 && < 5.1

40+ , lens >= 4.16.1 && < 5.3

41− if impl(ghc >= 9)

42− buildable: False

43 exposed-modules:

41 exposed-modules:

44 Servant.Auth.Swagger

42 Servant.Auth.Swagger

45 default-language: Haskell2010

43 default-language: Haskell2010

@@ -51,7 +49,7 @@ test-suite spec

51 test

49 test

52 default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators

50 default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators

53 ghc-options: -Wall

51 ghc-options: -Wall

54− build-tool-depends: hspec-discover:hspec-discover >= 2.5.5 && <2.9

52+ build-tool-depends: hspec-discover:hspec-discover >= 2.5.5 && <2.10

55 -- dependencies with bounds inherited from the library stanza

53 -- dependencies with bounds inherited from the library stanza

56 build-depends:

54 build-depends:

57 base

55 base

@@ -61,13 +59,11 @@ test-suite spec

61 , servant

59 , servant

62 , servant-auth

60 , servant-auth

63 , lens

61 , lens

64− if impl(ghc >= 9)

62+

65− buildable: False

66−

67 -- test dependencies

63 -- test dependencies

68 build-depends:

64 build-depends:

69 servant-auth-swagger

65 servant-auth-swagger

70− , hspec >= 2.5.5 && < 2.9

66+ , hspec >= 2.5.5 && < 2.10

71 , QuickCheck >= 2.11.3 && < 2.15

67 , QuickCheck >= 2.11.3 && < 2.15

72 other-modules:

68 other-modules:

73 Servant.Auth.SwaggerSpec

69 Servant.Auth.SwaggerSpec

servant-auth/servant-auth/servant-auth.cabal+11−10

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

1+cabal-version: 2.2

1name: servant-auth

2name: servant-auth

2−version: 0.4.0.0

3+version: 0.4.1.0

3synopsis: Authentication combinators for servant

4synopsis: Authentication combinators for servant

4description: This package provides an @Auth@ combinator for 'servant'. This combinator

5description: This package provides an @Auth@ combinator for 'servant'. This combinator

5 allows using different authentication schemes in a straightforward way,

6 allows using different authentication schemes in a straightforward way,

@@ -8,9 +9,9 @@ description: This package provides an @Auth@ combinator for 'servant'. This c

8 'servant-auth' additionally provides concrete authentication schemes, such

9 'servant-auth' additionally provides concrete authentication schemes, such

9 as Basic Access Authentication, JSON Web Tokens, and Cookies.

10 as Basic Access Authentication, JSON Web Tokens, and Cookies.

10 .

11 .

11− For more details on how to use this, see the <http://github.com/haskell-servant/servant/servant-auth#readme README>.

12+ For more details on how to use this, see the <https://github.com/haskell-servant/servant/tree/master/servant-auth#readme README>.

12category: Web, Servant, Authentication

13category: Web, Servant, Authentication

13−homepage: http://github.com/haskell-servant/servant/servant-auth#readme

14+homepage: https://github.com/haskell-servant/servant/tree/master/servant-auth#readme

14bug-reports: https://github.com/haskell-servant/servant/issues

15bug-reports: https://github.com/haskell-servant/servant/issues

15author: Julian K. Arni

16author: Julian K. Arni

16maintainer: jkarni@gmail.com

17maintainer: jkarni@gmail.com

@@ -19,7 +20,6 @@ license: BSD-3-Clause

19license-file: LICENSE

20license-file: LICENSE

20tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1

21tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1

21build-type: Simple

22build-type: Simple

22−cabal-version: >= 1.10

23extra-source-files:

24 CHANGELOG.md

25

@@ -33,12 +33,13 @@ library

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

36+ base >= 4.10 && < 4.18

37+ , containers >= 0.6 && < 0.7

37− , aeson >= 1.3.1.1 && < 1.6

38+ , aeson >= 1.3.1.1 && < 3

38− , jose >= 0.7.0.0 && < 0.9

39+ , jose >= 0.10 && < 0.11

39− , lens >= 4.16.1 && < 5.1

40+ , lens >= 4.16.1 && < 5.3

40− , servant >= 0.15 && < 0.19

41+ , servant >= 0.15 && < 0.20

41− , text >= 1.2.3.0 && < 1.3

42+ , text >= 1.2.3.0 && < 2.1

42 , unordered-containers >= 0.2.9.0 && < 0.3

43 , unordered-containers >= 0.2.9.0 && < 0.3

43 exposed-modules:

44 exposed-modules:

44 Servant.Auth

45 Servant.Auth

servant-auth/servant-auth/src/Servant/Auth.hs+1−1

@@ -27,7 +27,7 @@ instance HasLink sub => HasLink (Auth (tag :: [*]) value :> sub) where

27

28-- ** Combinators

29

30−-- | A JSON Web Token (JWT) in the the Authorization header:

30+-- | A JSON Web Token (JWT) in the Authorization header:

31--

32-- @Authorization: Bearer \<token\>@

33--

servant-auth/servant-auth/src/Servant/Auth/JWT.hs+9−2

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

1+{-# LANGUAGE CPP #-}

2+

1module Servant.Auth.JWT where

3module Servant.Auth.JWT where

2

4

3import Control.Lens ((^.))

5import Control.Lens ((^.))

4import qualified Crypto.JWT as Jose

6import qualified Crypto.JWT as Jose

5import Data.Aeson (FromJSON, Result (..), ToJSON, fromJSON,

7import Data.Aeson (FromJSON, Result (..), ToJSON, fromJSON,

6 toJSON)

8 toJSON)

9+#if MIN_VERSION_aeson(2,0,0)

10+import qualified Data.Map as KM

11+#else

7−import qualified Data.HashMap.Strict as HM

12+import qualified Data.HashMap.Strict as KM

13+#endif

14+

8import qualified Data.Text as T

15import qualified Data.Text as T

9

16

10

17

@@ -17,7 +24,7 @@ import qualified Data.Text as T

17class FromJWT a where

24class FromJWT a where

18 decodeJWT :: Jose.ClaimsSet -> Either T.Text a

25 decodeJWT :: Jose.ClaimsSet -> Either T.Text a

19 default decodeJWT :: FromJSON a => Jose.ClaimsSet -> Either T.Text a

26 default decodeJWT :: FromJSON a => Jose.ClaimsSet -> Either T.Text a

20− decodeJWT m = case HM.lookup "dat" (m ^. Jose.unregisteredClaims) of

27+ decodeJWT m = case KM.lookup "dat" (m ^. Jose.unregisteredClaims) of

21 Nothing -> Left "Missing 'dat' claim"

28 Nothing -> Left "Missing 'dat' claim"

22 Just v -> case fromJSON v of

29 Just v -> case fromJSON v of

23 Error e -> Left $ T.pack e

30 Error e -> Left $ T.pack e

servant-client-core/CHANGELOG.md+31

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

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+

40.18.3

350.18.3

5------

36------

6

37

servant-client-core/servant-client-core.cabal+12−12

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

1−cabal-version: >=1.10

1+cabal-version: 2.2

2name: servant-client-core

3−version: 0.18.3

3+version: 0.19

4

5synopsis: Core functionality and class for client function generation for servant APIs

6category: Servant, Web

@@ -50,14 +50,14 @@ library

50 --

51 -- note: mtl lower bound is so low because of GHC-7.8

52 build-depends:

53− base >= 4.9 && < 4.16

53+ base >= 4.9 && < 4.18

54 , bytestring >= 0.10.8.1 && < 0.12

55− , constraints

55+ , constraints >= 0.2 && < 0.14

56 , containers >= 0.5.7.1 && < 0.7

57 , deepseq >= 1.4.2.0 && < 1.5

58− , text >= 1.2.3.0 && < 1.3

58+ , text >= 1.2.3.0 && < 2.1

59− , transformers >= 0.5.2.0 && < 0.6

59+ , transformers >= 0.5.2.0 && < 0.7

60− , template-haskell >= 2.11.1.0 && < 2.18

60+ , template-haskell >= 2.11.1.0 && < 2.20

61

62 if !impl(ghc >= 8.2)

63 build-depends:

@@ -65,13 +65,13 @@ library

65

66 -- Servant dependencies

67 build-depends:

68− servant >= 0.18.3 && <0.19

68+ servant >= 0.19

69

70 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.

71 -- Here can be exceptions if we really need features from the newer versions.

72 build-depends:

73− aeson >= 1.4.1.0 && < 1.6

73+ aeson >= 1.4.1.0 && < 3

74− , base-compat >= 0.10.5 && < 0.12

74+ , base-compat >= 0.10.5 && < 0.13

75 , base64-bytestring >= 1.0.0.1 && < 1.3

76 , exceptions >= 0.10.0 && < 0.11

77 , free >= 5.1 && < 5.2

@@ -104,8 +104,8 @@ test-suite spec

104 -- Additional dependencies

105 build-depends:

106 deepseq >= 1.4.2.0 && < 1.5

107− , hspec >= 2.6.0 && < 2.9

107+ , hspec >= 2.6.0 && < 2.10

108 , QuickCheck >= 2.12.6.1 && < 2.15

109

110 build-tool-depends:

111− hspec-discover:hspec-discover >= 2.6.0 && <2.9

111+ hspec-discover:hspec-discover >= 2.6.0 && <2.10

servant-client-core/src/Servant/Client/Core.hs+1

@@ -59,6 +59,7 @@ module Servant.Client.Core

59 , appendToPath

60 , setRequestBodyLBS

61 , setRequestBody

62+ , encodeQueryParamValue

62 ) where

63 ) where

63import Servant.Client.Core.Auth

64import Servant.Client.Core.Auth

64import Servant.Client.Core.BaseUrl

65import Servant.Client.Core.BaseUrl

servant-client-core/src/Servant/Client/Core/HasClient.hs+144−47

@@ -1,5 +1,4 @@

1{-# LANGUAGE ConstraintKinds #-}

2−{-# LANGUAGE CPP #-}

3{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DataKinds #-}

4{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE FlexibleContexts #-}

5{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE FlexibleInstances #-}

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

7{-# LANGUAGE MultiParamTypeClasses #-}

6{-# LANGUAGE MultiParamTypeClasses #-}

8{-# LANGUAGE OverloadedStrings #-}

7{-# LANGUAGE OverloadedStrings #-}

9{-# LANGUAGE PolyKinds #-}

8{-# LANGUAGE PolyKinds #-}

9+{-# LANGUAGE QuantifiedConstraints #-}

10{-# LANGUAGE RankNTypes #-}

11{-# LANGUAGE ScopedTypeVariables #-}

12{-# LANGUAGE TypeApplications #-}

@@ -14,19 +14,13 @@

14{-# LANGUAGE TypeOperators #-}

15{-# LANGUAGE UndecidableInstances #-}

16

17−#if MIN_VERSION_base(4,9,0) && __GLASGOW_HASKELL__ >= 802

18−#define HAS_TYPE_ERROR

19−#endif

20−

21−#if __GLASGOW_HASKELL__ >= 806

22−{-# LANGUAGE QuantifiedConstraints #-}

23−#endif

24−

25module Servant.Client.Core.HasClient (

17module Servant.Client.Core.HasClient (

26 clientIn,

18 clientIn,

27 HasClient (..),

19 HasClient (..),

28 EmptyClient (..),

20 EmptyClient (..),

29 AsClientT,

21 AsClientT,

22+ (//),

23+ (/:),

30 foldMapUnion,

24 foldMapUnion,

31 matchUnion,

25 matchUnion,

32 ) where

26 ) where

@@ -39,9 +33,7 @@ import Control.Arrow

39import Control.Monad

33import Control.Monad

40 (unless)

34 (unless)

41import qualified Data.ByteString as BS

35import qualified Data.ByteString as BS

42−import Data.ByteString.Builder

43− (toLazyByteString)

44−import qualified Data.ByteString.Lazy as BL

36+import qualified Data.ByteString.Lazy as BL

45import Data.Either

37import Data.Either

46 (partitionEithers)

38 (partitionEithers)

47import Data.Constraint (Dict(..))

39import Data.Constraint (Dict(..))

@@ -53,7 +45,8 @@ import Data.Sequence

53 (fromList)

45 (fromList)

54import qualified Data.Text as T

46import qualified Data.Text as T

55import Network.HTTP.Media

47import Network.HTTP.Media

56− (MediaType, matches, parseAccept, (//))

48+ (MediaType, matches, parseAccept)

49+import qualified Network.HTTP.Media as Media

57import qualified Data.Sequence as Seq

50import qualified Data.Sequence as Seq

58import Data.SOP.BasicFunctors

51import Data.SOP.BasicFunctors

59 (I (I), (:.:) (Comp))

52 (I (I), (:.:) (Comp))

@@ -70,7 +63,7 @@ import Data.Text

70import Data.Proxy

63import Data.Proxy

71 (Proxy (Proxy))

64 (Proxy (Proxy))

72import GHC.TypeLits

65import GHC.TypeLits

73− (KnownSymbol, symbolVal)

66+ (KnownNat, KnownSymbol, TypeError, symbolVal)

74import Network.HTTP.Types

67import Network.HTTP.Types

75 (Status)

68 (Status)

76import qualified Network.HTTP.Types as H

69import qualified Network.HTTP.Types as H

@@ -81,19 +74,22 @@ import Servant.API

81 FromSourceIO (..), Header', Headers (..), HttpVersion,

74 FromSourceIO (..), Header', Headers (..), HttpVersion,

82 IsSecure, MimeRender (mimeRender),

75 IsSecure, MimeRender (mimeRender),

83 MimeUnrender (mimeUnrender), NoContent (NoContent),

76 MimeUnrender (mimeUnrender), NoContent (NoContent),

84− NoContentVerb, QueryFlag, QueryParam', QueryParams, Raw,

77+ NoContentVerb, QueryFlag, QueryParam', QueryParams, Raw, RawM,

85 ReflectMethod (..), RemoteHost, ReqBody', SBoolI, Stream,

78 ReflectMethod (..), RemoteHost, ReqBody', SBoolI, Stream,

86 StreamBody', Summary, ToHttpApiData, ToSourceIO (..), Vault,

79 StreamBody', Summary, ToHttpApiData, ToSourceIO (..), Vault,

87− Verb, WithNamedContext, WithStatus (..), contentType, getHeadersHList,

80+ Verb, WithNamedContext, WithResource, WithStatus (..), contentType, getHeadersHList,

88 getResponse, toEncodedUrlPiece, toUrlPiece, NamedRoutes)

81 getResponse, toEncodedUrlPiece, toUrlPiece, NamedRoutes)

89import Servant.API.Generic

82import Servant.API.Generic

90 (GenericMode(..), ToServant, ToServantApi

83 (GenericMode(..), ToServant, ToServantApi

91 , GenericServant, toServant, fromServant)

84 , GenericServant, toServant, fromServant)

92import Servant.API.ContentTypes

85import Servant.API.ContentTypes

93 (contentTypes, AllMime (allMime), AllMimeUnrender (allMimeUnrender))

86 (contentTypes, AllMime (allMime), AllMimeUnrender (allMimeUnrender))

87+import Servant.API.Status

88+ (statusFromNat)

94import Servant.API.TypeLevel (FragmentUnique, AtLeastOneFragment)

89import Servant.API.TypeLevel (FragmentUnique, AtLeastOneFragment)

95import Servant.API.Modifiers

90import Servant.API.Modifiers

96 (FoldRequired, RequiredArgument, foldRequiredArgument)

91 (FoldRequired, RequiredArgument, foldRequiredArgument)

92+import Servant.API.TypeErrors

97import Servant.API.UVerb

93import Servant.API.UVerb

98 (HasStatus, HasStatuses (Statuses, statuses), UVerb, Union, Unique, inject, statusOf, foldMapUnion, matchUnion)

94 (HasStatus, HasStatuses (Statuses, statuses), UVerb, Union, Unique, inject, statusOf, foldMapUnion, matchUnion)

99

95

@@ -212,7 +208,7 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m api)

212 clientWithRoute pm (Proxy :: Proxy api)

208 clientWithRoute pm (Proxy :: Proxy api)

213 (appendToPath p req)

209 (appendToPath p req)

214

210

215− where p = (toUrlPiece val)

211+ where p = toEncodedUrlPiece val

216

212

217 hoistClientMonad pm _ f cl = \a ->

213 hoistClientMonad pm _ f cl = \a ->

218 hoistClientMonad pm (Proxy :: Proxy api) f (cl a)

214 hoistClientMonad pm (Proxy :: Proxy api) f (cl a)

@@ -247,7 +243,7 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m sublayout)

247 clientWithRoute pm (Proxy :: Proxy sublayout)

243 clientWithRoute pm (Proxy :: Proxy sublayout)

248 (foldl' (flip appendToPath) req ps)

244 (foldl' (flip appendToPath) req ps)

249

245

250− where ps = map (toUrlPiece) vals

246+ where ps = map toEncodedUrlPiece vals

251

247

252 hoistClientMonad pm _ f cl = \as ->

248 hoistClientMonad pm _ f cl = \as ->

253 hoistClientMonad pm (Proxy :: Proxy sublayout) f (cl as)

249 hoistClientMonad pm (Proxy :: Proxy sublayout) f (cl as)

@@ -255,10 +251,11 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m sublayout)

255instance {-# OVERLAPPABLE #-}

251instance {-# OVERLAPPABLE #-}

256 -- Note [Non-Empty Content Types]

252 -- Note [Non-Empty Content Types]

257 ( RunClient m, MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)

253 ( RunClient m, MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)

254+ , KnownNat status

258 ) => HasClient m (Verb method status cts' a) where

255 ) => HasClient m (Verb method status cts' a) where

259 type Client m (Verb method status cts' a) = m a

256 type Client m (Verb method status cts' a) = m a

260 clientWithRoute _pm Proxy req = do

257 clientWithRoute _pm Proxy req = do

261− response <- runRequest req

258+ response <- runRequestAcceptStatus (Just [status]) req

262 { requestAccept = fromList $ toList accept

259 { requestAccept = fromList $ toList accept

263 , requestMethod = method

260 , requestMethod = method

264 }

261 }

@@ -266,18 +263,20 @@ instance {-# OVERLAPPABLE #-}

266 where

263 where

267 accept = contentTypes (Proxy :: Proxy ct)

264 accept = contentTypes (Proxy :: Proxy ct)

268 method = reflectMethod (Proxy :: Proxy method)

265 method = reflectMethod (Proxy :: Proxy method)

266+ status = statusFromNat (Proxy :: Proxy status)

269

267

270 hoistClientMonad _ _ f ma = f ma

268 hoistClientMonad _ _ f ma = f ma

271

269

272instance {-# OVERLAPPING #-}

270instance {-# OVERLAPPING #-}

273− ( RunClient m, ReflectMethod method

271+ ( RunClient m, ReflectMethod method, KnownNat status

274 ) => HasClient m (Verb method status cts NoContent) where

272 ) => HasClient m (Verb method status cts NoContent) where

275 type Client m (Verb method status cts NoContent)

273 type Client m (Verb method status cts NoContent)

276 = m NoContent

274 = m NoContent

277 clientWithRoute _pm Proxy req = do

275 clientWithRoute _pm Proxy req = do

278− _response <- runRequest req { requestMethod = method }

276+ _response <- runRequestAcceptStatus (Just [status]) req { requestMethod = method }

279 return NoContent

277 return NoContent

280 where method = reflectMethod (Proxy :: Proxy method)

278 where method = reflectMethod (Proxy :: Proxy method)

279+ status = statusFromNat (Proxy :: Proxy status)

281

280

282 hoistClientMonad _ _ f ma = f ma

281 hoistClientMonad _ _ f ma = f ma

283

282

@@ -294,13 +293,13 @@ instance (RunClient m, ReflectMethod method) =>

294

293

295instance {-# OVERLAPPING #-}

294instance {-# OVERLAPPING #-}

296 -- Note [Non-Empty Content Types]

295 -- Note [Non-Empty Content Types]

297− ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls

296+ ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls, KnownNat status

298 , ReflectMethod method, cts' ~ (ct ': cts)

297 , ReflectMethod method, cts' ~ (ct ': cts)

299 ) => HasClient m (Verb method status cts' (Headers ls a)) where

298 ) => HasClient m (Verb method status cts' (Headers ls a)) where

300 type Client m (Verb method status cts' (Headers ls a))

299 type Client m (Verb method status cts' (Headers ls a))

301 = m (Headers ls a)

300 = m (Headers ls a)

302 clientWithRoute _pm Proxy req = do

301 clientWithRoute _pm Proxy req = do

303− response <- runRequest req

302+ response <- runRequestAcceptStatus (Just [status]) req

304 { requestMethod = method

303 { requestMethod = method

305 , requestAccept = fromList $ toList accept

304 , requestAccept = fromList $ toList accept

306 }

305 }

@@ -308,22 +307,26 @@ instance {-# OVERLAPPING #-}

308 return $ Headers { getResponse = val

307 return $ Headers { getResponse = val

309 , getHeadersHList = buildHeadersTo . toList $ responseHeaders response

308 , getHeadersHList = buildHeadersTo . toList $ responseHeaders response

310 }

309 }

310+ where

311− where method = reflectMethod (Proxy :: Proxy method)

311+ method = reflectMethod (Proxy :: Proxy method)

312− accept = contentTypes (Proxy :: Proxy ct)

312+ accept = contentTypes (Proxy :: Proxy ct)

313+ status = statusFromNat (Proxy :: Proxy status)

313

314

314 hoistClientMonad _ _ f ma = f ma

315 hoistClientMonad _ _ f ma = f ma

315

316

316instance {-# OVERLAPPING #-}

317instance {-# OVERLAPPING #-}

317− ( RunClient m, BuildHeadersTo ls, ReflectMethod method

318+ ( RunClient m, BuildHeadersTo ls, ReflectMethod method, KnownNat status

318 ) => HasClient m (Verb method status cts (Headers ls NoContent)) where

319 ) => HasClient m (Verb method status cts (Headers ls NoContent)) where

319 type Client m (Verb method status cts (Headers ls NoContent))

320 type Client m (Verb method status cts (Headers ls NoContent))

320 = m (Headers ls NoContent)

321 = m (Headers ls NoContent)

321 clientWithRoute _pm Proxy req = do

322 clientWithRoute _pm Proxy req = do

322− let method = reflectMethod (Proxy :: Proxy method)

323− response <- runRequest req { requestMethod = method }

323+ response <- runRequestAcceptStatus (Just [status]) req { requestMethod = method }

324 return $ Headers { getResponse = NoContent

325 , getHeadersHList = buildHeadersTo . toList $ responseHeaders response

326 }

327+ where

328+ method = reflectMethod (Proxy :: Proxy method)

329+ status = statusFromNat (Proxy :: Proxy status)

327

330

328 hoistClientMonad _ _ f ma = f ma

331 hoistClientMonad _ _ f ma = f ma

329

332

@@ -566,7 +569,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequire

566 (Proxy :: Proxy mods) add (maybe req add) mparam

569 (Proxy :: Proxy mods) add (maybe req add) mparam

567 where

570 where

568 add :: a -> Request

571 add :: a -> Request

569− add param = appendToQueryString pname (Just $ encodeQueryParam param) req

572+ add param = appendToQueryString pname (Just $ encodeQueryParamValue param) req

570

573

571 pname :: Text

574 pname :: Text

572 pname = pack $ symbolVal (Proxy :: Proxy sym)

575 pname = pack $ symbolVal (Proxy :: Proxy sym)

@@ -574,9 +577,6 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequire

574 hoistClientMonad pm _ f cl = \arg ->

577 hoistClientMonad pm _ f cl = \arg ->

575 hoistClientMonad pm (Proxy :: Proxy api) f (cl arg)

578 hoistClientMonad pm (Proxy :: Proxy api) f (cl arg)

576

579

577−encodeQueryParam :: ToHttpApiData a => a -> BS.ByteString

578−encodeQueryParam = BL.toStrict . toLazyByteString . toEncodedUrlPiece

579−

580-- | If you use a 'QueryParams' in one of your endpoints in your API,

581-- the corresponding querying function will automatically take

582-- an additional argument, a list of values of the type specified

@@ -618,7 +618,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api)

618 )

619

620 where pname = pack $ symbolVal (Proxy :: Proxy sym)

621− paramlist' = map (Just . encodeQueryParam) paramlist

621+ paramlist' = map (Just . encodeQueryParamValue) paramlist

622

623 hoistClientMonad pm _ f cl = \as ->

624 hoistClientMonad pm (Proxy :: Proxy api) f (cl as)

@@ -674,6 +674,16 @@ instance RunClient m => HasClient m Raw where

674

675 hoistClientMonad _ _ f cl = \meth -> f (cl meth)

676

677+instance RunClient m => HasClient m RawM where

678+ type Client m RawM

679+ = H.Method -> m Response

680+

681+ clientWithRoute :: Proxy m -> Proxy RawM -> Request -> Client m RawM

682+ clientWithRoute _pm Proxy req httpMethod = do

683+ runRequest req { requestMethod = httpMethod }

684+

685+ hoistClientMonad _ _ f cl = \meth -> f (cl meth)

686+

677-- | If you use a 'ReqBody' in one of your endpoints in your API,

687-- | If you use a 'ReqBody' in one of your endpoints in your API,

678-- the corresponding querying function will automatically take

688-- the corresponding querying function will automatically take

679-- an additional argument of the type specified by your 'ReqBody'.

689-- an additional argument of the type specified by your 'ReqBody'.

@@ -740,7 +750,7 @@ instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where

740 clientWithRoute pm (Proxy :: Proxy api)

750 clientWithRoute pm (Proxy :: Proxy api)

741 (appendToPath p req)

751 (appendToPath p req)

742

752

743− where p = pack $ symbolVal (Proxy :: Proxy path)

753+ where p = toEncodedUrlPiece $ pack $ symbolVal (Proxy :: Proxy path)

744

754

745 hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl

755 hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl

746

756

@@ -776,6 +786,14 @@ instance HasClient m subapi =>

776

786

777 hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy subapi) f cl

787 hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy subapi) f cl

778

788

789+instance HasClient m subapi =>

790+ HasClient m (WithResource res :> subapi) where

791+

792+ type Client m (WithResource res :> subapi) = Client m subapi

793+ clientWithRoute pm Proxy = clientWithRoute pm (Proxy :: Proxy subapi)

794+

795+ hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy subapi) f cl

796+

779instance ( HasClient m api

797instance ( HasClient m api

780 ) => HasClient m (AuthProtect tag :> api) where

798 ) => HasClient m (AuthProtect tag :> api) where

781 type Client m (AuthProtect tag :> api)

799 type Client m (AuthProtect tag :> api)

@@ -789,7 +807,7 @@ instance ( HasClient m api

789

807

790-- | Ignore @'Fragment'@ in client functions.

808-- | Ignore @'Fragment'@ in client functions.

791-- See <https://ietf.org/rfc/rfc2616.html#section-15.1.3> for more details.

809-- See <https://ietf.org/rfc/rfc2616.html#section-15.1.3> for more details.

792−--

810+--

793-- Example:

811-- Example:

794--

812--

795-- > type MyApi = "books" :> Fragment Text :> Get '[JSON] [Book]

813-- > type MyApi = "books" :> Fragment Text :> Get '[JSON] [Book]

@@ -801,16 +819,12 @@ instance ( HasClient m api

801-- > getBooks = client myApi

819-- > getBooks = client myApi

802-- > -- then you can just use "getBooksBy" to query that endpoint.

820-- > -- then you can just use "getBooksBy" to query that endpoint.

803-- > -- 'getBooks' for all books.

821-- > -- 'getBooks' for all books.

804−#ifdef HAS_TYPE_ERROR

805instance (AtLeastOneFragment api, FragmentUnique (Fragment a :> api), HasClient m api

822instance (AtLeastOneFragment api, FragmentUnique (Fragment a :> api), HasClient m api

806−#else

807−instance ( HasClient m api

808−#endif

809 ) => HasClient m (Fragment a :> api) where

823 ) => HasClient m (Fragment a :> api) where

810

824

811 type Client m (Fragment a :> api) = Client m api

825 type Client m (Fragment a :> api) = Client m api

812

826

813− clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api)

827+ clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api)

814

828

815 hoistClientMonad pm _ = hoistClientMonad pm (Proxy :: Proxy api)

829 hoistClientMonad pm _ = hoistClientMonad pm (Proxy :: Proxy api)

816

830

@@ -830,7 +844,6 @@ data AsClientT (m :: * -> *)

830instance GenericMode (AsClientT m) where

844instance GenericMode (AsClientT m) where

831 type AsClientT m :- api = Client m api

845 type AsClientT m :- api = Client m api

832

846

833−#if __GLASGOW_HASKELL__ >= 806

834

847

835type GClientConstraints api m =

848type GClientConstraints api m =

836 ( GenericServant api (AsClientT m)

849 ( GenericServant api (AsClientT m)

@@ -838,10 +851,10 @@ type GClientConstraints api m =

838 )

851 )

839

852

840class GClient (api :: * -> *) m where

853class GClient (api :: * -> *) m where

841− proof :: Dict (GClientConstraints api m)

854+ gClientProof :: Dict (GClientConstraints api m)

842

855

843instance GClientConstraints api m => GClient api m where

856instance GClientConstraints api m => GClient api m where

844− proof = Dict

857+ gClientProof = Dict

845

858

846instance

859instance

847 ( forall n. GClient api n

860 ( forall n. GClient api n

@@ -853,7 +866,7 @@ instance

853

866

854 clientWithRoute :: Proxy m -> Proxy (NamedRoutes api) -> Request -> Client m (NamedRoutes api)

867 clientWithRoute :: Proxy m -> Proxy (NamedRoutes api) -> Request -> Client m (NamedRoutes api)

855 clientWithRoute pm _ request =

868 clientWithRoute pm _ request =

856− case proof @api @m of

869+ case gClientProof @api @m of

857 Dict -> fromServant $ clientWithRoute pm (Proxy @(ToServantApi api)) request

870 Dict -> fromServant $ clientWithRoute pm (Proxy @(ToServantApi api)) request

858

871

859 hoistClientMonad

872 hoistClientMonad

@@ -864,13 +877,81 @@ instance

864 -> Client ma (NamedRoutes api)

877 -> Client ma (NamedRoutes api)

865 -> Client mb (NamedRoutes api)

878 -> Client mb (NamedRoutes api)

866 hoistClientMonad _ _ nat clientA =

879 hoistClientMonad _ _ nat clientA =

867− case (proof @api @ma, proof @api @mb) of

880+ case (gClientProof @api @ma, gClientProof @api @mb) of

868 (Dict, Dict) ->

881 (Dict, Dict) ->

869 fromServant @api @(AsClientT mb) $

882 fromServant @api @(AsClientT mb) $

870 hoistClientMonad @m @(ToServantApi api) @ma @mb Proxy Proxy nat $

883 hoistClientMonad @m @(ToServantApi api) @ma @mb Proxy Proxy nat $

871 toServant @api @(AsClientT ma) clientA

884 toServant @api @(AsClientT ma) clientA

872

885

873−#endif

886+infixl 1 //

887+infixl 2 /:

888+

889+-- | Helper to make code using records of clients more readable.

890+--

891+-- Can be mixed with (/:) for supplying arguments.

892+--

893+-- Example:

894+--

895+-- @

896+-- type Api = NamedRoutes RootApi

897+--

898+-- data RootApi mode = RootApi

899+-- { subApi :: mode :- NamedRoutes SubApi

900+-- , …

901+-- } deriving Generic

902+--

903+-- data SubApi mode = SubApi

904+-- { endpoint :: mode :- Get '[JSON] Person

905+-- , …

906+-- } deriving Generic

907+--

908+-- api :: Proxy API

909+-- api = Proxy

910+--

911+-- rootClient :: RootApi (AsClientT ClientM)

912+-- rootClient = client api

913+--

914+-- endpointClient :: ClientM Person

915+-- endpointClient = client \/\/ subApi \/\/ endpoint

916+-- @

917+(//) :: a -> (a -> b) -> b

918+x // f = f x

919+

920+-- | Convenience function for supplying arguments to client functions when

921+-- working with records of clients.

922+--

923+-- Intended to be used in conjunction with '(//)'.

924+--

925+-- Example:

926+--

927+-- @

928+-- type Api = NamedRoutes RootApi

929+--

930+-- data RootApi mode = RootApi

931+-- { subApi :: mode :- Capture "token" String :> NamedRoutes SubApi

932+-- , hello :: mode :- Capture "name" String :> Get '[JSON] String

933+-- , …

934+-- } deriving Generic

935+--

936+-- data SubApi mode = SubApi

937+-- { endpoint :: mode :- Get '[JSON] Person

938+-- , …

939+-- } deriving Generic

940+--

941+-- api :: Proxy API

942+-- api = Proxy

943+--

944+-- rootClient :: RootApi (AsClientT ClientM)

945+-- rootClient = client api

946+--

947+-- hello :: String -> ClientM String

948+-- hello name = rootClient \/\/ hello \/: name

949+--

950+-- endpointClient :: ClientM Person

951+-- endpointClient = client \/\/ subApi \/: "foobar123" \/\/ endpoint

952+-- @

953+(/:) :: (a -> b -> c) -> b -> a -> c

954+(/:) = flip

874

955

875

956

876{- Note [Non-Empty Content Types]

957{- Note [Non-Empty Content Types]

@@ -896,7 +977,7 @@ for empty and one for non-empty lists).

896checkContentTypeHeader :: RunClient m => Response -> m MediaType

977checkContentTypeHeader :: RunClient m => Response -> m MediaType

897checkContentTypeHeader response =

978checkContentTypeHeader response =

898 case lookup "Content-Type" $ toList $ responseHeaders response of

979 case lookup "Content-Type" $ toList $ responseHeaders response of

899− Nothing -> return $ "application"//"octet-stream"

980+ Nothing -> return $ "application" Media.// "octet-stream"

900 Just t -> case parseAccept t of

981 Just t -> case parseAccept t of

901 Nothing -> throwClientError $ InvalidContentTypeHeader response

982 Nothing -> throwClientError $ InvalidContentTypeHeader response

902 Just t' -> return t'

983 Just t' -> return t'

@@ -912,3 +993,19 @@ decodedAs response ct = do

912 Right val -> return val

993 Right val -> return val

913 where

994 where

914 accept = toList $ contentTypes ct

995 accept = toList $ contentTypes ct

996+

997+-------------------------------------------------------------------------------

998+-- Custom type errors

999+-------------------------------------------------------------------------------

1000+

1001+-- Erroring instance for HasClient' when a combinator is not fully applied

1002+instance (RunClient m, TypeError (PartialApplication HasClient arr)) => HasClient m ((arr :: a -> b) :> sub)

1003+ where

1004+ type Client m (arr :> sub) = TypeError (PartialApplication HasClient arr)

1005+ clientWithRoute _ _ _ = error "unreachable"

1006+ hoistClientMonad _ _ _ _ = error "unreachable"

1007+

1008+-- Erroring instances for 'HasClient' for unknown API combinators

1009+instance {-# OVERLAPPABLE #-} (RunClient m, TypeError (NoInstanceForSub (HasClient m) ty)) => HasClient m (ty :> sub)

1010+

1011+instance {-# OVERLAPPABLE #-} (RunClient m, TypeError (NoInstanceFor (HasClient m api))) => HasClient m api

servant-client-core/src/Servant/Client/Core/Reexport.hs+2

@@ -8,6 +8,8 @@ module Servant.Client.Core.Reexport

8 , foldMapUnion

9 , matchUnion

10 , AsClientT

11+ , (//)

12+ , (/:)

11

13

12 -- * Response (for @Raw@)

14 -- * Response (for @Raw@)

13 , Response

15 , Response

servant-client-core/src/Servant/Client/Core/Request.hs+22−6

@@ -17,6 +17,7 @@ module Servant.Client.Core.Request (

17 addHeader,

18 appendToPath,

19 appendToQueryString,

20+ encodeQueryParamValue,

20 setRequestBody,

21 setRequestBody,

21 setRequestBodyLBS,

22 setRequestBodyLBS,

22 ) where

23 ) where

@@ -33,6 +34,8 @@ import Data.Bifunctor

33import Data.Bitraversable

34import Data.Bitraversable

34 (Bitraversable (..), bifoldMapDefault, bimapDefault)

35 (Bitraversable (..), bifoldMapDefault, bimapDefault)

35import qualified Data.ByteString as BS

36import qualified Data.ByteString as BS

37+import Data.ByteString.Builder

38+ (Builder)

36import qualified Data.ByteString.Builder as Builder

39import qualified Data.ByteString.Builder as Builder

37import qualified Data.ByteString.Lazy as LBS

40import qualified Data.ByteString.Lazy as LBS

38import qualified Data.Sequence as Seq

41import qualified Data.Sequence as Seq

@@ -78,12 +81,13 @@ instance (Show a, Show b) =>

78 . showString ", requestAccept = "

81 . showString ", requestAccept = "

79 . showsPrec 0 (requestAccept req)

82 . showsPrec 0 (requestAccept req)

80 . showString ", requestHeaders = "

83 . showString ", requestHeaders = "

81− . showsPrec 0 (redactSensitiveHeader <$> requestHeaders req))

84+ . showsPrec 0 (redactSensitiveHeader <$> requestHeaders req)

82 . showString ", requestHttpVersion = "

85 . showString ", requestHttpVersion = "

83 . showsPrec 0 (requestHttpVersion req)

86 . showsPrec 0 (requestHttpVersion req)

84 . showString ", requestMethod = "

87 . showString ", requestMethod = "

85 . showsPrec 0 (requestMethod req)

88 . showsPrec 0 (requestMethod req)

86 . showString "}"

89 . showString "}"

90+ )

87 where

91 where

88 redactSensitiveHeader :: Header -> Header

92 redactSensitiveHeader :: Header -> Header

89 redactSensitiveHeader ("Authorization", _) = ("Authorization", "<REDACTED>")

93 redactSensitiveHeader ("Authorization", _) = ("Authorization", "<REDACTED>")

@@ -110,7 +114,7 @@ instance (NFData path, NFData body) => NFData (RequestF body path) where

110 rnfB Nothing = ()

114 rnfB Nothing = ()

111 rnfB (Just (b, mt)) = rnf b `seq` mediaTypeRnf mt

115 rnfB (Just (b, mt)) = rnf b `seq` mediaTypeRnf mt

112

116

113−type Request = RequestF RequestBody Builder.Builder

117+type Request = RequestF RequestBody Builder

114

118

115-- | The request body. R replica of the @http-client@ @RequestBody@.

119-- | The request body. R replica of the @http-client@ @RequestBody@.

116data RequestBody

120data RequestBody

@@ -141,18 +145,30 @@ defaultRequest = Request

141 , requestMethod = methodGet

145 , requestMethod = methodGet

142 }

146 }

143

147

148+-- | Append extra path to the request being constructed.

149+--

150+-- Warning: This function assumes that the path fragment is already URL-encoded.

144−appendToPath :: Text -> Request -> Request

151+appendToPath :: Builder -> Request -> Request

145appendToPath p req

152appendToPath p req

146− = req { requestPath = requestPath req <> "/" <> toEncodedUrlPiece p }

153+ = req { requestPath = requestPath req <> "/" <> p }

147

154

155+-- | Append a query parameter to the request being constructed.

156+--

148−appendToQueryString :: Text -- ^ param name

157+appendToQueryString :: Text -- ^ query param name

149− -> Maybe BS.ByteString -- ^ param value

158+ -> Maybe BS.ByteString -- ^ query param value

150 -> Request

159 -> Request

151 -> Request

160 -> Request

152appendToQueryString pname pvalue req

161appendToQueryString pname pvalue req

153 = req { requestQueryString = requestQueryString req

162 = req { requestQueryString = requestQueryString req

154 Seq.|> (encodeUtf8 pname, pvalue)}

163 Seq.|> (encodeUtf8 pname, pvalue)}

155

164

165+-- | Encode a query parameter value.

166+--

167+encodeQueryParamValue :: ToHttpApiData a => a -> BS.ByteString

168+encodeQueryParamValue = LBS.toStrict . Builder.toLazyByteString . toEncodedUrlPiece

169+

170+-- | Add header to the request being constructed.

171+--

156addHeader :: ToHttpApiData a => HeaderName -> a -> Request -> Request

172addHeader :: ToHttpApiData a => HeaderName -> a -> Request -> Request

157addHeader name val req

173addHeader name val req

158 = req { requestHeaders = requestHeaders req Seq.|> (name, toHeader val)}

174 = req { requestHeaders = requestHeaders req Seq.|> (name, toHeader val)}

servant-client-core/test/Servant/Client/Core/RequestSpec.hs+12

@@ -10,10 +10,22 @@ import Data.List (isInfixOf)

10import Servant.Client.Core.Request

11import Test.Hspec

12

13+newtype DataWithRequest = DataWithRequest (RequestF RequestBody ())

14+ deriving Show

15+

13spec :: Spec

16spec :: Spec

14spec = do

17spec = do

15 describe "Request" $ do

18 describe "Request" $ do

16 describe "show" $ do

19 describe "show" $ do

20+ it "has parenthesis correctly positioned" $ do

21+ let d = DataWithRequest (void defaultRequest)

22+ show d `shouldBe` "DataWithRequest (Request {requestPath = ()\

23+ \, requestQueryString = fromList []\

24+ \, requestBody = Nothing\

25+ \, requestAccept = fromList []\

26+ \, requestHeaders = fromList []\

27+ \, requestHttpVersion = HTTP/1.1\

28+ \, requestMethod = \"GET\"})"

17 it "redacts the authorization header" $ do

29 it "redacts the authorization header" $ do

18 let request = void $ defaultRequest { requestHeaders = pure ("authorization", "secret") }

30 let request = void $ defaultRequest { requestHeaders = pure ("authorization", "secret") }

19 isInfixOf "secret" (show request) `shouldBe` False

31 isInfixOf "secret" (show request) `shouldBe` False

servant-client-ghcjs/servant-client-ghcjs.cabal+5−5

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

1−cabal-version: >=1.10

1+cabal-version: 2.2

2name: servant-client-ghcjs

3version: 0.16

4synopsis:

@@ -38,7 +38,7 @@ library

38 Servant.Client.Internal.XhrClient

39

40 build-depends:

41− base >=4.11 && <4.12

41+ base >=4.11 && <5

42 , bytestring >=0.10 && <0.12

43 , case-insensitive >=1.2.0.0 && <1.3.0.0

44 , containers >=0.5 && <0.7

@@ -48,7 +48,7 @@ library

48 , http-media >=0.6.2 && <0.9

49 , http-types >=0.12 && <0.13

50 , monad-control >=1.0.0.4 && <1.1

51− , mtl >=2.2.2 && <2.3

51+ , mtl ^>=2.2.2 || ^>=2.3.1

52 , semigroupoids >=5.3 && <5.4

53 , string-conversions >=0.3 && <0.5

54 , transformers >=0.3 && <0.6

@@ -56,8 +56,8 @@ library

56

57 -- strict, as we re-export stuff

58 build-depends:

59− servant >=0.16 && <0.17

59+ servant >=0.16 && <0.20

60− , servant-client-core >=0.16 && <0.16.1

60+ , servant-client-core >=0.16 && <0.20

61

62 hs-source-dirs: src

63 default-language: Haskell2010

servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs+8−5

@@ -120,7 +120,7 @@ instance Exception StreamingNotSupportedException where

120 displayException _ = "streamingRequest: streaming is not supported!"

121

122instance RunClient ClientM where

123− runRequest = performRequest

123+ runRequestAcceptStatus = performRequest

124 throwClientError = throwError

125

126runClientMOrigin :: ClientM a -> ClientEnv -> IO (Either ClientError a)

@@ -152,15 +152,18 @@ runClientM m = do

152

153 runClientMOrigin m (ClientEnv (BaseUrl protocol hostname port ""))

154

155−performRequest :: Request -> ClientM Response

155+performRequest :: Maybe [Status] -> Request -> ClientM Response

156−performRequest req = do

156+performRequest acceptStatus req = do

157 xhr <- liftIO initXhr

158 burl <- asks baseUrl

159 liftIO $ performXhr xhr burl req

160 resp <- toResponse xhr

161

162− let status = statusCode (responseStatusCode resp)

162+ let status = responseStatusCode resp

163− unless (status >= 200 && status < 300) $ do

163+ goodStatus = case acceptStatus of

164+ Nothing -> statusIsSuccessful status

165+ Just good -> status `elem` good

166+ unless goodStatus $ do

164 let f b = (burl, BL.toStrict $ toLazyByteString b)

167 let f b = (burl, BL.toStrict $ toLazyByteString b)

165 throwError $ FailureResponse (bimap (const ()) f req) resp

168 throwError $ FailureResponse (bimap (const ()) f req) resp

166

169

servant-client/CHANGELOG.md+31

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

1[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-client/CHANGELOG.md)