e598917..master · typeable/servant

.github/workflows/master.yml+17−29

since splitsnapshots

unifiedsplit

@@ -13,12 +13,13 @@ 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"

22

23

23 steps:

24 steps:

24 - uses: actions/checkout@v2

25 - uses: actions/checkout@v2

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

47

48

48 - name: Configure

49 - name: Configure

49 run: |

50 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'

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

54

52

55 - name: Build

53 - name: Build

56 run: |

54 run: |

@@ -61,39 +59,29 @@ jobs:

61 cabal test all

59 cabal test all

62

60

63 - name: Run doctests

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

62 run: |

68 # Necessary for doctest to be found in $PATH

63 # Necessary for doctest to be found in $PATH

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

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

70

65

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

66+ 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)

67+ (cd servant && eval $DOCTEST)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

89

77

90 stack:

78 stack:

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

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

92 runs-on: ubuntu-latest

80 runs-on: ubuntu-latest

93 strategy:

81 strategy:

94 matrix:

82 matrix:

95− stack: ["2.7.3"]

83+ stack: ["2.7.5"]

96− ghc: ["8.10.4"]

84+ ghc: ["8.10.7"]

97

85

98 steps:

86 steps:

99 - uses: actions/checkout@v2

87 - uses: actions/checkout@v2

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

@@ -51,29 +51,3 @@ packages:

51tests: True

52optimization: False

53-- reorder-goals: True

54−

55−constraints:

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

57− foundation >=0.0.14,

58− memory <0.14.12 || >0.14.12

59−

60−constraints: base-compat ^>=0.11

61−constraints: semigroups ^>=0.19

62−

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

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

65−

66−-- needed for doctests

67−write-ghc-environment-files: always

68−

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

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

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

72−

73−allow-newer: servant-js:servant

74−allow-newer: servant-multipart:servant

75−allow-newer: servant-multipart:servant-server

76−allow-newer: servant-multipart-api:servant

77−

78−-- ghc 9

79−allow-newer: tdigest:base

changelog.d/1529new file+10

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

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

2+prs: #1529

3+

4+description: {

5+

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

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

8+functionality to match what servant-client provides.

9+

10+}

changelog.d/1556new file+81

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

1+synopsis: Display capture hints in router layout

2+prs: #1556

3+

4+description: {

5+

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

7+

8+Example:

9+

10+For the following API

11+```haskell

12+type API =

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

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

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

16+```

17+

18+we previously got the following output:

19+

20+```

21+/

22+├─ a/

23+│ ├─ d/

24+│ │ └─•

25+│ └─ e/

26+│ └─•

27+└─ b/

28+ └─ <capture>/

29+ ├─•

30+ ┆

31+ └─•

32+```

33+

34+now we get:

35+

36+```

37+/

38+├─ a/

39+│ ├─ d/

40+│ │ └─•

41+│ └─ e/

42+│ └─•

43+└─ b/

44+ └─ <x::Int>/

45+ ├─•

46+ ┆

47+ └─•

48+```

49+

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

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

52+

53+N.B.:

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

55+

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

57+

58+Warning:

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

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

61+

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

63+```haskell

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

65+

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

67+myServer = const $ return ()

68+

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

70+myApi = Proxy

71+

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

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

74+```

75+

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

77+```haskell

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

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

80+```

81+}

changelog.d/1569new file+13

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

1+synopsis: Encode captures using toEncodedUrlPiece

2+prs: #1569

3+issues: #1511

4+

5+description: {

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

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

8+URL-encoding however they need.

9+

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

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

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

13+}

changelog.d/1580new file+12

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

1+synopsis: Allow IO in validationKeys

2+prs: #1580

3+issues: #1579

4+

5+description: {

6+

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

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

9+discover new and expired keys.

10+

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

12+}

changelog.d/1589new file+2

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

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

2+prs: 1589

changelog.d/1595new file+2

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

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

2+prs: #1595

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/curl-mock/curl-mock.cabal+3

@@ -11,6 +11,9 @@ build-type: Simple

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/index.rst+2−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,

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/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/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+1−1

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

nix/nixpkgs.json+2−2

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

1{

2− "rev": "0f316e4d72daed659233817ffe52bf08e081b5de",

2+ "rev" : "05f0934825c2a0750d4888c4735f9420c906b388",

3− "sha256": "0vh0fk5is5s9l0lxpi16aabv2kk1fwklr7szy731kfcz9gdrr65l"

3+ "sha256" : "1g8c2w0661qn89ajp44znmwfmghbbiygvdzq0rzlvlpdiz28v6gy"

4}

nix/nixpkgs.nix+4−7

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

1−let nixpkgsSnapshot =

2− builtins.fromJSON (builtins.readFile ./nixpkgs.json); in

3−import (builtins.fetchTarball

1+import (builtins.fetchTarball {

4− { url = "https://github.com/NixOS/nixpkgs/tarball/${nixpkgsSnapshot.rev}";

2+ url = "https://github.com/NixOS/nixpkgs/archive/refs/tags/21.05.tar.gz";

5− sha256 = nixpkgsSnapshot.sha256;

3+ sha256 = "sha256:1ckzhh24mgz6jd1xhfgx0i9mijk6xjqxwsshnvq789xsavrmsc36";

6− })

4+}) {}

7− {}

nix/shell.nix+1−1

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

1−{ compiler ? "ghc901"

1+{ compiler ? "ghc8104"

2, tutorial ? false

3, pkgs ? import ./nixpkgs.nix

4}:

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

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

7 APIs that use

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

9 .

10− For a quick overview of the usage, see the <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>.

11category: Web, Servant, Authentication

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

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

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

14author: Julian K. Arni

15maintainer: jkarni@gmail.com

@@ -31,8 +31,8 @@ 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.17

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

@@ -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,10 +62,10 @@ 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 && < 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

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

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

7 APIs that use

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

9 .

10− For a quick overview of the usage, see the <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>.

11category: Web, Servant, Authentication

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

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

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

14author: Julian K. Arni

15maintainer: jkarni@gmail.com

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

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

40 , servant >= 0.13 && < 0.20

41 , servant-auth == 0.4.*

42− , lens >= 4.16.1 && <5.1

42+ , lens >= 4.16.1 && <5.2

43 exposed-modules:

44 Servant.Auth.Docs

45 default-language: Haskell2010

@@ -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+11−11

@@ -7,9 +7,9 @@ description: This package provides the required instances for using the @Auth

7 .

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

9 .

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

11category: Web, Servant, Authentication

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

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

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

14author: Julian K. Arni

15maintainer: jkarni@gmail.com

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

35 , aeson >= 1.0.0.1 && < 3

36 , base64-bytestring >= 1.0.0.1 && < 2

37 , blaze-builder >= 0.4.1.0 && < 0.5

38− , bytestring >= 0.10.6.0 && < 0.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.10

45− , lens >= 4.16.1 && < 5.1

45+ , lens >= 4.16.1 && < 5.2

46− , memory >= 0.14.16 && < 0.17

46+ , memory >= 0.14.16 && < 0.18

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

48 , mtl >= 2.2.2 && < 2.3

49 , servant >= 0.13 && < 0.20

50 , servant-auth == 0.4.*

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

52 , tagged >= 0.8.4 && < 0.9

53− , text >= 1.2.3.0 && < 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.12

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,10 +123,10 @@ 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 other-modules:

servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/AddSetCookie.hs+12

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

11import qualified Network.HTTP.Types as HTTP

12import Network.Wai (mapResponseHeaders)

13import Servant

14+import Servant.API.Generic

15+import Servant.Server.Generic

14import Web.Cookie

16import Web.Cookie

15

17

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

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

@@ -34,6 +36,7 @@ type family AddSetCookieApiVerb a where

34type family AddSetCookieApi a :: *

36type family AddSetCookieApi a :: *

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

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

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

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

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

37type instance AddSetCookieApi (Verb method stat ctyps a)

40type instance AddSetCookieApi (Verb method stat ctyps a)

38 = Verb method stat ctyps (AddSetCookieApiVerb a)

41 = Verb method stat ctyps (AddSetCookieApiVerb a)

39type instance AddSetCookieApi Raw = Raw

42type instance AddSetCookieApi Raw = Raw

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

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

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

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

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

74

77

78+instance {-# OVERLAPS #-}

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

80+ , Generic (api (AsServerT m))

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

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

83+ )

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

85+ addSetCookies cookies = addSetCookies cookies . toServant

86+

75-- | for @servant <0.11@

87-- | for @servant <0.11@

76instance

88instance

77 AddSetCookies ('S n) Application Application where

89 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/JWT.hs+4−3

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

58

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

60verifyJWT jwtCfg input = do

61+ keys <- validationKeys jwtCfg

61− verifiedJWT <- liftIO $ runExceptT $ do

62+ verifiedJWT <- runExceptT $ do

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

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

63 Jose.verifyClaims

64 Jose.verifyClaims

64 (jwtSettingsToJwtValidationSettings jwtCfg)

65 (jwtSettingsToJwtValidationSettings jwtCfg)

65− (validationKeys jwtCfg)

66+ keys

66 unverifiedJWT

67 unverifiedJWT

67 return $ case verifiedJWT of

68 return $ case verifiedJWT of

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

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

69 Right v -> case decodeJWT v of

70 Right v -> case decodeJWT v of

70 Left _ -> Nothing

71 Left _ -> Nothing

71− Right v' -> Just v'

72+ 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/test/Servant/Auth/ServerSpec.hs+7

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

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

51import Servant hiding (BasicAuth,

52 IsSecure (..), header)

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

53import Servant.Auth.Server

54import Servant.Auth.Server

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

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

55import Servant.Auth.Server.SetCookieOrphan ()

56import Servant.Auth.Server.SetCookieOrphan ()

@@ -405,6 +406,7 @@ type API auths

405 = Auth auths User :>

406 = Auth auths User :>

406 ( Get '[JSON] Int

407 ( Get '[JSON] Int

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

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

409+ :<|> NamedRoutes DummyRoutes

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

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

409#if MIN_VERSION_servant_server(0,15,0)

411#if MIN_VERSION_servant_server(0,15,0)

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

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

@@ -416,6 +418,10 @@ type API auths

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

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

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

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

418

420

421+data DummyRoutes mode = DummyRoutes

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

423+ } deriving Generic

424+

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

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

420jwtOnlyApi = Proxy

426jwtOnlyApi = Proxy

421

427

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

476 (\authResult -> case authResult of

482 (\authResult -> case authResult of

477 Authenticated usr -> getInt usr

483 Authenticated usr -> getInt usr

478 :<|> postInt usr

484 :<|> postInt usr

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

479 :<|> getHeaderInt

486 :<|> getHeaderInt

480#if MIN_VERSION_servant_server(0,15,0)

487#if MIN_VERSION_servant_server(0,15,0)

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

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

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

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

7 APIs that use

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

9 .

10− For a quick overview of the usage, see the <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>.

11category: Web, Servant, Authentication

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

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

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

14author: Julian K. Arni

15maintainer: jkarni@gmail.com

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

35− , text >= 1.2.3.0 && < 1.3

35+ , text >= 1.2.3.0 && < 2.1

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

37 , swagger2 >= 2.2.2 && < 3

38 , servant >= 0.13 && < 0.20

39 , servant-auth == 0.4.*

40− , lens >= 4.16.1 && < 5.1

40+ , lens >= 4.16.1 && < 5.2

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

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

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

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

11 .

12− For more details on how to use this, see the <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>.

13category: Web, Servant, Authentication

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

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

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

16author: Julian K. Arni

17maintainer: jkarni@gmail.com

@@ -33,13 +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.17

37 , containers >= 0.6 && < 0.7

38 , aeson >= 1.3.1.1 && < 3

39 , jose >= 0.7.0.0 && < 0.10

40− , lens >= 4.16.1 && < 5.1

40+ , lens >= 4.16.1 && < 5.2

41 , servant >= 0.15 && < 0.20

42− , text >= 1.2.3.0 && < 1.3

42+ , text >= 1.2.3.0 && < 2.1

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

44 exposed-modules:

45 Servant.Auth

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

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

54 , bytestring >= 0.10.8.1 && < 0.12

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

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

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

61

62 if !impl(ghc >= 8.2)

63 build-depends:

@@ -71,7 +71,7 @@ library

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

72 build-depends:

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

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

33import Control.Monad

34 (unless)

35import qualified Data.ByteString as BS

36−import Data.ByteString.Builder

37− (toLazyByteString)

38−import qualified Data.ByteString.Lazy as BL

36+import qualified Data.ByteString.Lazy as BL

39import Data.Either

37import Data.Either

40 (partitionEithers)

38 (partitionEithers)

41import Data.Constraint (Dict(..))

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

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

210 clientWithRoute pm (Proxy :: Proxy api)

208 clientWithRoute pm (Proxy :: Proxy api)

211 (appendToPath p req)

209 (appendToPath p req)

212

210

213− where p = (toUrlPiece val)

211+ where p = toEncodedUrlPiece val

214

212

215 hoistClientMonad pm _ f cl = \a ->

213 hoistClientMonad pm _ f cl = \a ->

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

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

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

245 clientWithRoute pm (Proxy :: Proxy sublayout)

243 clientWithRoute pm (Proxy :: Proxy sublayout)

246 (foldl' (flip appendToPath) req ps)

244 (foldl' (flip appendToPath) req ps)

247

245

248− where ps = map (toUrlPiece) vals

246+ where ps = map toEncodedUrlPiece vals

249

247

250 hoistClientMonad pm _ f cl = \as ->

248 hoistClientMonad pm _ f cl = \as ->

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

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

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

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

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

572 where

570 where

573 add :: a -> Request

571 add :: a -> Request

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

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

575

573

576 pname :: Text

574 pname :: Text

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

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

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

579 hoistClientMonad pm _ f cl = \arg ->

577 hoistClientMonad pm _ f cl = \arg ->

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

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

581

579

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

583−encodeQueryParam = BL.toStrict . toLazyByteString . toEncodedUrlPiece

584−

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

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

586-- the corresponding querying function will automatically take

581-- the corresponding querying function will automatically take

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

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

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

623 )

618 )

624

619

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

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

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

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

627

622

628 hoistClientMonad pm _ f cl = \as ->

623 hoistClientMonad pm _ f cl = \as ->

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

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

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

745 clientWithRoute pm (Proxy :: Proxy api)

740 clientWithRoute pm (Proxy :: Proxy api)

746 (appendToPath p req)

741 (appendToPath p req)

747

742

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

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

749

744

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

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

751

746

@@ -879,7 +874,7 @@ infixl 2 /:

879--

874--

880-- Example:

875-- Example:

881--

876--

882−-- @@

877+-- @

883-- type Api = NamedRoutes RootApi

878-- type Api = NamedRoutes RootApi

884--

879--

885-- data RootApi mode = RootApi

880-- data RootApi mode = RootApi

@@ -900,7 +895,7 @@ infixl 2 /:

900--

895--

901-- endpointClient :: ClientM Person

896-- endpointClient :: ClientM Person

902-- endpointClient = client // subApi // endpoint

897-- endpointClient = client // subApi // endpoint

903−-- @@

898+-- @

904(//) :: a -> (a -> b) -> b

899(//) :: a -> (a -> b) -> b

905x // f = f x

900x // f = f x

906

901

@@ -911,7 +906,7 @@ x // f = f x

911--

906--

912-- Example:

907-- Example:

913--

908--

914−-- @@

909+-- @

915-- type Api = NamedRoutes RootApi

910-- type Api = NamedRoutes RootApi

916--

911--

917-- data RootApi mode = RootApi

912-- data RootApi mode = RootApi

@@ -936,7 +931,7 @@ x // f = f x

936--

931--

937-- endpointClient :: ClientM Person

932-- endpointClient :: ClientM Person

938-- endpointClient = client // subApi /: "foobar123" // endpoint

933-- endpointClient = client // subApi /: "foobar123" // endpoint

939−-- @@

934+-- @

940(/:) :: (a -> b -> c) -> b -> a -> c

935(/:) :: (a -> b -> c) -> b -> a -> c

941(/:) = flip

936(/:) = flip

942

937

servant-client-core/src/Servant/Client/Core/Request.hs+23−7

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

@@ -48,9 +51,9 @@ import Network.HTTP.Media

48 (MediaType)

51 (MediaType)

49import Network.HTTP.Types

52import Network.HTTP.Types

50 (Header, HeaderName, HttpVersion (..), Method, QueryItem,

53 (Header, HeaderName, HttpVersion (..), Method, QueryItem,

51− http11, methodGet)

54+ http11, methodGet, urlEncodeBuilder)

52import Servant.API

55import Servant.API

53− (ToHttpApiData, toEncodedUrlPiece, toHeader, SourceIO)

56+ (ToHttpApiData, toEncodedUrlPiece, toQueryParam, toHeader, SourceIO)

54

57

55import Servant.Client.Core.Internal (mediaTypeRnf)

58import Servant.Client.Core.Internal (mediaTypeRnf)

56

59

@@ -111,7 +114,7 @@ instance (NFData path, NFData body) => NFData (RequestF body path) where

111 rnfB Nothing = ()

114 rnfB Nothing = ()

112 rnfB (Just (b, mt)) = rnf b `seq` mediaTypeRnf mt

115 rnfB (Just (b, mt)) = rnf b `seq` mediaTypeRnf mt

113

116

114−type Request = RequestF RequestBody Builder.Builder

117+type Request = RequestF RequestBody Builder

115

118

116-- | The request body. R replica of the @http-client@ @RequestBody@.

119-- | The request body. R replica of the @http-client@ @RequestBody@.

117data RequestBody

120data RequestBody

@@ -142,18 +145,31 @@ defaultRequest = Request

142 , requestMethod = methodGet

145 , requestMethod = methodGet

143 }

146 }

144

147

148+-- | Append extra path to the request being constructed.

149+--

150+-- Warning: This function assumes that the path fragment is already URL-encoded.

145−appendToPath :: Text -> Request -> Request

151+appendToPath :: Builder -> Request -> Request

146appendToPath p req

152appendToPath p req

147− = req { requestPath = requestPath req <> "/" <> toEncodedUrlPiece p }

153+ = req { requestPath = requestPath req <> "/" <> p }

148

154

155+-- | Append a query parameter to the request being constructed.

156+--

149−appendToQueryString :: Text -- ^ param name

157+appendToQueryString :: Text -- ^ query param name

150− -> Maybe BS.ByteString -- ^ param value

158+ -> Maybe BS.ByteString -- ^ query param value

151 -> Request

159 -> Request

152 -> Request

160 -> Request

153appendToQueryString pname pvalue req

161appendToQueryString pname pvalue req

154 = req { requestQueryString = requestQueryString req

162 = req { requestQueryString = requestQueryString req

155 Seq.|> (encodeUtf8 pname, pvalue)}

163 Seq.|> (encodeUtf8 pname, pvalue)}

156

164

165+-- | Encode a query parameter value.

166+--

167+encodeQueryParamValue :: ToHttpApiData a => a -> BS.ByteString

168+encodeQueryParamValue = LBS.toStrict . Builder.toLazyByteString

169+ . urlEncodeBuilder True . encodeUtf8 . toQueryParam

170+

171+-- | Add header to the request being constructed.

172+--

157addHeader :: ToHttpApiData a => HeaderName -> a -> Request -> Request

173addHeader :: ToHttpApiData a => HeaderName -> a -> Request -> Request

158addHeader name val req

174addHeader name val req

159 = req { requestHeaders = requestHeaders req Seq.|> (name, toHeader val)}

175 = req { requestHeaders = requestHeaders req Seq.|> (name, toHeader val)}

servant-client-ghcjs/servant-client-ghcjs.cabal+1−1

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

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/servant-client.cabal+6−6

@@ -41,14 +41,14 @@ library

41 -- Bundled with GHC: Lower bound to not force re-installs

42 -- text and mtl are bundled starting with GHC-8.4

43 build-depends:

44− base >= 4.9 && < 4.16

44+ base >= 4.9 && < 4.17

45 , bytestring >= 0.10.8.1 && < 0.12

46 , containers >= 0.5.7.1 && < 0.7

47 , deepseq >= 1.4.2.0 && < 1.5

48 , mtl >= 2.2.2 && < 2.3

49 , stm >= 2.4.5.1 && < 2.6

50− , text >= 1.2.3.0 && < 1.3

50+ , text >= 1.2.3.0 && < 2.1

51− , time >= 1.6.0.1 && < 1.10

51+ , time >= 1.6.0.1 && < 1.12

52 , transformers >= 0.5.2.0 && < 0.6

53

54 if !impl(ghc >= 8.2)

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

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

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

66 build-depends:

67− base-compat >= 0.10.5 && < 0.12

67+ base-compat >= 0.10.5 && < 0.13

68 , http-client >= 0.5.13.1 && < 0.8

69 , http-media >= 0.7.1.3 && < 0.9

70 , http-types >= 0.12.2 && < 0.13

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

124 -- Additional dependencies

125 build-depends:

126 entropy >= 0.4.1.3 && < 0.5

127− , hspec >= 2.6.0 && < 2.9

127+ , hspec >= 2.6.0 && < 2.10

128 , HUnit >= 1.6.0.0 && < 1.7

129 , network >= 2.8.0.0 && < 3.2

130 , QuickCheck >= 2.12.6.1 && < 2.15

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

133 , tdigest >= 0.2 && < 0.3

134

135 build-tool-depends:

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

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

137

138test-suite readme

139 type: exitcode-stdio-1.0

servant-client/src/Servant/Client/Internal/HttpClient.hs+9−8

@@ -24,7 +24,7 @@ import Control.Monad

24import Control.Monad.Base

25 (MonadBase (..))

26import Control.Monad.Catch

27− (MonadCatch, MonadThrow)

27+ (MonadCatch, MonadThrow, MonadMask)

28import Control.Monad.Error.Class

29 (MonadError (..))

30import Control.Monad.IO.Class

@@ -80,7 +80,7 @@ data ClientEnv

80 { manager :: Client.Manager

81 , baseUrl :: BaseUrl

82 , cookieJar :: Maybe (TVar Client.CookieJar)

83− , makeClientRequest :: BaseUrl -> Request -> Client.Request

83+ , makeClientRequest :: BaseUrl -> Request -> IO Client.Request

84 -- ^ this function can be used to customize the creation of @http-client@ requests from @servant@ requests. Default value: 'defaultMakeClientRequest'

85 -- Note that:

86 -- 1. 'makeClientRequest' exists to allow overriding operational semantics e.g. 'responseTimeout' per request,

@@ -136,7 +136,7 @@ newtype ClientM a = ClientM

136 { unClientM :: ReaderT ClientEnv (ExceptT ClientError IO) a }

137 deriving ( Functor, Applicative, Monad, MonadIO, Generic

138 , MonadReader ClientEnv, MonadError ClientError, MonadThrow

139− , MonadCatch)

139+ , MonadCatch, MonadMask)

140

141instance MonadBase IO ClientM where

142 liftBase = ClientM . liftBase

@@ -162,7 +162,7 @@ runClientM cm env = runExceptT $ flip runReaderT env $ unClientM cm

162performRequest :: Maybe [Status] -> Request -> ClientM Response

163performRequest acceptStatus req = do

164 ClientEnv m burl cookieJar' createClientRequest <- ask

165− let clientRequest = createClientRequest burl req

165+ clientRequest <- liftIO $ createClientRequest burl req

166 request <- case cookieJar' of

167 Nothing -> pure clientRequest

168 Just cj -> liftIO $ do

@@ -229,8 +229,8 @@ clientResponseToResponse f r = Response

229-- | Create a @http-client@ 'Client.Request' from a @servant@ 'Request'

230-- The 'Client.host', 'Client.path' and 'Client.port' fields are extracted from the 'BaseUrl'

231-- otherwise the body, headers and query string are derived from the @servant@ 'Request'

232−defaultMakeClientRequest :: BaseUrl -> Request -> Client.Request

232+defaultMakeClientRequest :: BaseUrl -> Request -> IO Client.Request

233−defaultMakeClientRequest burl r = Client.defaultRequest

233+defaultMakeClientRequest burl r = return Client.defaultRequest

234 { Client.method = requestMethod r

235 , Client.host = fromString $ baseUrlHost burl

236 , Client.port = baseUrlPort burl

@@ -246,7 +246,7 @@ defaultMakeClientRequest burl r = Client.defaultRequest

246 where

247 -- Content-Type and Accept are specified by requestBody and requestAccept

248 headers = filter (\(h, _) -> h /= "Accept" && h /= "Content-Type") $

249− toList $requestHeaders r

249+ toList $ requestHeaders r

250

251 acceptHdr

252 | null hs = Nothing

@@ -289,7 +289,8 @@ defaultMakeClientRequest burl r = Client.defaultRequest

289 Https -> True

290

291 -- Query string builder which does not do any encoding

292+ buildQueryString [] = mempty

292− buildQueryString = ("?" <>) . foldl' addQueryParam mempty

293+ buildQueryString qps = "?" <> foldl' addQueryParam mempty qps

293

294

294 addQueryParam qs (k, v) =

295 addQueryParam qs (k, v) =

295 qs <> (if BS.null qs then mempty else "&") <> urlEncode True k <> foldMap ("=" <>) v

296 qs <> (if BS.null qs then mempty else "&") <> urlEncode True k <> foldMap ("=" <>) v

servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs+2−2

@@ -140,7 +140,7 @@ performRequest :: Maybe [Status] -> Request -> ClientM Response

140performRequest acceptStatus req = do

141 -- TODO: should use Client.withResponse here too

142 ClientEnv m burl cookieJar' createClientRequest <- ask

143− let clientRequest = createClientRequest burl req

143+ clientRequest <- liftIO $ createClientRequest burl req

144 request <- case cookieJar' of

145 Nothing -> pure clientRequest

146 Just cj -> liftIO $ do

@@ -177,7 +177,7 @@ performWithStreamingRequest req k = do

177 m <- asks manager

178 burl <- asks baseUrl

179 createClientRequest <- asks makeClientRequest

180− let request = createClientRequest burl req

180+ request <- liftIO $ createClientRequest burl req

181 ClientM $ lift $ lift $ Codensity $ \k1 ->

182 Client.withResponse request m $ \res -> do

183 let status = Client.responseStatus res

servant-client/test/Servant/ClientTestUtils.hs+13−1

@@ -160,6 +160,7 @@ type Api =

160 WithStatus 301 Text]

161 :<|> "uverb-get-created" :> UVerb 'GET '[PlainText] '[WithStatus 201 Person]

162 :<|> NamedRoutes RecordRoutes

163+ :<|> "captureVerbatim" :> Capture "someString" Verbatim :> Get '[PlainText] Text

163

164

164api :: Proxy Api

165api :: Proxy Api

165api = Proxy

166api = Proxy

@@ -214,7 +215,8 @@ getRoot

214 :<|> EmptyClient

215 :<|> EmptyClient

215 :<|> uverbGetSuccessOrRedirect

216 :<|> uverbGetSuccessOrRedirect

216 :<|> uverbGetCreated

217 :<|> uverbGetCreated

217− :<|> recordRoutes = client api

218+ :<|> recordRoutes

219+ :<|> captureVerbatim = client api

218

220

219server :: Application

221server :: Application

220server = serve api (

222server = serve api (

@@ -259,6 +261,7 @@ server = serve api (

259 { something = pure ["foo", "bar", "pweet"]

261 { something = pure ["foo", "bar", "pweet"]

260 }

262 }

261 }

263 }

264+ :<|> pure . decodeUtf8 . unVerbatim

262 )

265 )

263

266

264-- * api for testing failures

267-- * api for testing failures

@@ -370,3 +373,12 @@ instance ToHttpApiData UrlEncodedByteString where

370

373

371instance FromHttpApiData UrlEncodedByteString where

374instance FromHttpApiData UrlEncodedByteString where

372 parseUrlPiece = pure . UrlEncodedByteString . HTTP.urlDecode True . encodeUtf8

375 parseUrlPiece = pure . UrlEncodedByteString . HTTP.urlDecode True . encodeUtf8

376+

377+newtype Verbatim = Verbatim { unVerbatim :: ByteString }

378+

379+instance ToHttpApiData Verbatim where

380+ toEncodedUrlPiece = byteString . unVerbatim

381+ toUrlPiece = decodeUtf8 . unVerbatim

382+

383+instance FromHttpApiData Verbatim where

384+ parseUrlPiece = pure . Verbatim . encodeUtf8

servant-client/test/Servant/SuccessSpec.hs+11−1

@@ -36,6 +36,8 @@ import Data.Maybe

36import Data.Monoid ()

37import Data.Text

38 (Text)

39+import Data.Text.Encoding

40+ (encodeUtf8)

39import qualified Network.HTTP.Client as C

41import qualified Network.HTTP.Client as C

40import qualified Network.HTTP.Types as HTTP

42import qualified Network.HTTP.Types as HTTP

41import Test.Hspec

43import Test.Hspec

@@ -160,7 +162,8 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do

160 mgr <- C.newManager C.defaultManagerSettings

162 mgr <- C.newManager C.defaultManagerSettings

161 -- In proper situation, extra headers should probably be visible in API type.

163 -- In proper situation, extra headers should probably be visible in API type.

162 -- However, testing for response timeout is difficult, so we test with something which is easy to observe

164 -- However, testing for response timeout is difficult, so we test with something which is easy to observe

163− let createClientRequest url r = (defaultMakeClientRequest url r) { C.requestHeaders = [("X-Added-Header", "XXX")] }

165+ let createClientRequest url r = fmap (\req -> req { C.requestHeaders = [("X-Added-Header", "XXX")] })

166+ (defaultMakeClientRequest url r)

164 clientEnv = (mkClientEnv mgr baseUrl) { makeClientRequest = createClientRequest }

167 clientEnv = (mkClientEnv mgr baseUrl) { makeClientRequest = createClientRequest }

165 res <- runClientM (getRawSuccessPassHeaders HTTP.methodGet) clientEnv

168 res <- runClientM (getRawSuccessPassHeaders HTTP.methodGet) clientEnv

166 case res of

169 case res of

@@ -196,3 +199,10 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do

196 case eitherResponse of

199 case eitherResponse of

197 Left clientError -> fail $ show clientError

200 Left clientError -> fail $ show clientError

198 Right response -> matchUnion response `shouldBe` Just (WithStatus @201 carol)

201 Right response -> matchUnion response `shouldBe` Just (WithStatus @201 carol)

202+

203+ it "encodes URL pieces following ToHttpApiData instance" $ \(_, baseUrl) -> do

204+ let textOrig = "*"

205+ eitherResponse <- runClient (captureVerbatim $ Verbatim $ encodeUtf8 textOrig) baseUrl

206+ case eitherResponse of

207+ Left clientError -> fail $ show clientError

208+ Right textBack -> textBack `shouldBe` textOrig

servant-conduit/servant-conduit.cabal+1−1

@@ -23,7 +23,7 @@ extra-source-files:

23

24source-repository head

25 type: git

26− location: http://github.com/haskell-servant/servant-conduit.git

26+ location: http://github.com/haskell-servant/servant.git

27

28library

29 exposed-modules: Servant.Conduit

servant-docs/servant-docs.cabal+5−5

@@ -41,9 +41,9 @@ library

41 --

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

43 build-depends:

44− base >= 4.9 && < 4.16

44+ base >= 4.9 && < 4.17

45 , bytestring >= 0.10.8.1 && < 0.12

46− , text >= 1.2.3.0 && < 1.3

46+ , text >= 1.2.3.0 && < 2.1

47

48 -- Servant dependencies

49 build-depends:

@@ -54,12 +54,12 @@ library

54 build-depends:

55 aeson >= 1.4.1.0 && < 3

56 , aeson-pretty >= 0.8.5 && < 0.9

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

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

58 , case-insensitive >= 1.2.0.11 && < 1.3

59− , hashable >= 1.2.7.0 && < 1.4

59+ , hashable >= 1.2.7.0 && < 1.5

60 , http-media >= 0.7.1.3 && < 0.9

61 , http-types >= 0.12.2 && < 0.13

62− , lens >= 4.17 && < 5.1

62+ , lens >= 4.17 && < 5.2

63 , string-conversions >= 0.4.0.1 && < 0.5

64 , universe-base >= 1.1.1 && < 1.2

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

servant-docs/src/Servant/Docs/Internal.hs+4

@@ -62,6 +62,7 @@ import GHC.TypeLits

62import Servant.API

63import Servant.API.ContentTypes

64import Servant.API.TypeLevel

65+import Servant.API.Generic

65

66

66import qualified Data.Universe.Helpers as U

67import qualified Data.Universe.Helpers as U

67

68

@@ -1150,6 +1151,9 @@ instance (ToAuthInfo (BasicAuth realm usr), HasDocs api) => HasDocs (BasicAuth r

1150 authProxy = Proxy :: Proxy (BasicAuth realm usr)

1151 authProxy = Proxy :: Proxy (BasicAuth realm usr)

1151 action' = over authInfo (|> toAuthInfo authProxy) action

1152 action' = over authInfo (|> toAuthInfo authProxy) action

1152

1153

1154+instance HasDocs (ToServantApi api) => HasDocs (NamedRoutes api) where

1155+ docsFor Proxy = docsFor (Proxy :: Proxy (ToServantApi api))

1156+

1153-- ToSample instances for simple types

1157-- ToSample instances for simple types

1154instance ToSample NoContent

1158instance ToSample NoContent

1155instance ToSample Bool

1159instance ToSample Bool

servant-foreign/servant-foreign.cabal+6−6

@@ -41,8 +41,8 @@ library

41 --

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

43 build-depends:

44− base >= 4.9 && < 4.16

44+ base >= 4.9 && < 4.17

45− , text >= 1.2.3.0 && < 1.3

45+ , text >= 1.2.3.0 && < 2.1

46

47 -- Servant dependencies

48 build-depends:

@@ -51,8 +51,8 @@ library

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

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

53 build-depends:

54− base-compat >= 0.10.5 && < 0.12

54+ base-compat >= 0.10.5 && < 0.13

55− , lens >= 4.17 && < 5.1

55+ , lens >= 4.17 && < 5.2

56 , http-types >= 0.12.2 && < 0.13

57

58 hs-source-dirs: src

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

74

75 -- Additional dependencies

76 build-depends:

77− hspec >= 2.6.0 && <2.9

77+ hspec >= 2.6.0 && <2.10

78 build-tool-depends:

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

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

80 default-language: Haskell2010

servant-http-streams/servant-http-streams.cabal+8−8

@@ -38,13 +38,13 @@ library

38 -- Bundled with GHC: Lower bound to not force re-installs

39 -- text and mtl are bundled starting with GHC-8.4

40 build-depends:

41− base >= 4.9 && < 4.16

41+ base >= 4.9 && < 4.17

42 , bytestring >= 0.10.8.1 && < 0.12

43 , containers >= 0.5.7.1 && < 0.7

44 , deepseq >= 1.4.2.0 && < 1.5

45 , mtl >= 2.2.2 && < 2.3

46− , text >= 1.2.3.0 && < 1.3

46+ , text >= 1.2.3.0 && < 2.1

47− , time >= 1.6.0.1 && < 1.10

47+ , time >= 1.6.0.1 && < 1.12

48 , transformers >= 0.5.2.0 && < 0.6

49

50 if !impl(ghc >= 8.2)

@@ -60,19 +60,19 @@ library

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

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

62 build-depends:

63− base-compat >= 0.10.5 && < 0.12

63+ base-compat >= 0.10.5 && < 0.13

64 , case-insensitive

65 , http-streams >= 0.8.6.1 && < 0.9

66 , http-media >= 0.7.1.3 && < 0.9

67 , io-streams >= 1.5.0.1 && < 1.6

68 , http-types >= 0.12.2 && < 0.13

69− , http-common >= 0.8.2.0 && < 0.8.3

69+ , http-common >= 0.8.2.0 && < 0.9

70 , exceptions >= 0.10.0 && < 0.11

71 , kan-extensions >= 5.2 && < 5.3

72 , monad-control >= 1.0.2.3 && < 1.1

73 , semigroupoids >= 5.3.1 && < 5.4

74 , transformers-base >= 0.4.5.2 && < 0.5

75− , transformers-compat >= 0.6.2 && < 0.7

75+ , transformers-compat >= 0.6.2 && < 0.8

76

77 hs-source-dirs: src

78 default-language: Haskell2010

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

112 -- Additional dependencies

113 build-depends:

114 entropy >= 0.4.1.3 && < 0.5

115− , hspec >= 2.6.0 && < 2.9

115+ , hspec >= 2.6.0 && < 2.10

116 , HUnit >= 1.6.0.0 && < 1.7

117 , network >= 2.8.0.0 && < 3.2

118 , QuickCheck >= 2.12.6.1 && < 2.15

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

121 , tdigest >= 0.2 && < 0.3

122

123 build-tool-depends:

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

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

125

126test-suite readme

127 type: exitcode-stdio-1.0

servant-machines/servant-machines.cabal+1−1

@@ -23,7 +23,7 @@ extra-source-files:

23

24source-repository head

25 type: git

26− location: http://github.com/haskell-servant/servant-machines.git

26+ location: http://github.com/haskell-servant/servant.git

27

28library

29 exposed-modules: Servant.Machines

servant-pipes/servant-pipes.cabal+1−1

@@ -23,7 +23,7 @@ extra-source-files:

23

24source-repository head

25 type: git

26− location: http://github.com/haskell-servant/servant-pipes.git

26+ location: http://github.com/haskell-servant/servant.git

27

28library

29 exposed-modules: Servant.Pipes

servant-server/CHANGELOG.md+6

@@ -3,6 +3,12 @@

3

4Package versions follow the [Package Versioning Policy](https://pvp.haskell.org/): in A.B.C, bumps to either A or B represent major versions.

5

6+0.19.1

7+------

8+

9+- Add `MonadFail` instance for `Handler` wrt [#1545](https://github.com/haskell-servant/servant/issues/1545)

10+- Support GHC 9.2 [#1525](https://github.com/haskell-servant/servant/issues/1525)

11+

60.19

120.19

7----

13----

8

14

servant-server/example/greet.hs−1

@@ -18,7 +18,6 @@ import Network.Wai.Handler.Warp

18

19import Servant

20import Servant.Server.Generic ()

21−import Servant.API.Generic

22

21

23-- * Example

22-- * Example

24

23

servant-server/servant-server.cabal+7−7

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

1cabal-version: 2.2

2name: servant-server

3−version: 0.19

3+version: 0.19.1

4

5synopsis: A family of combinators for defining webservices APIs and serving them

6category: Servant, Web

@@ -60,25 +60,25 @@ library

60 -- Bundled with GHC: Lower bound to not force re-installs

61 -- text and mtl are bundled starting with GHC-8.4

62 build-depends:

63− base >= 4.9 && < 4.16

63+ base >= 4.9 && < 4.17

64 , bytestring >= 0.10.8.1 && < 0.12

65 , constraints >= 0.2 && < 0.14

66 , containers >= 0.5.7.1 && < 0.7

67 , mtl >= 2.2.2 && < 2.3

68− , text >= 1.2.3.0 && < 1.3

68+ , text >= 1.2.3.0 && < 2.1

69 , transformers >= 0.5.2.0 && < 0.6

70 , filepath >= 1.4.1.1 && < 1.5

71

72 -- Servant dependencies

73 -- strict dependency as we re-export 'servant' things.

74 build-depends:

75− servant >= 0.19

75+ servant >= 0.19 && < 0.20

76 , http-api-data >= 0.4.1 && < 0.4.4

77

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

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

80 build-depends:

81− base-compat >= 0.10.5 && < 0.12

81+ base-compat >= 0.10.5 && < 0.13

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

83 , exceptions >= 0.10.0 && < 0.11

84 , http-media >= 0.7.1.3 && < 0.9

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

159 build-depends:

160 aeson >= 1.4.1.0 && < 3

161 , directory >= 1.3.0.0 && < 1.4

162− , hspec >= 2.6.0 && < 2.9

162+ , hspec >= 2.6.0 && < 2.10

163 , hspec-wai >= 0.10.1 && < 0.12

164 , QuickCheck >= 2.12.6.1 && < 2.15

165 , should-not-typecheck >= 2.1.0 && < 2.2

@@ -167,4 +167,4 @@ test-suite spec

167 , wai-extra >= 3.0.24.3 && < 3.2

168

169 build-tool-depends:

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

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

servant-server/src/Servant/Server.hs+3−2

@@ -235,7 +235,7 @@ hoistServer p = hoistServerWithContext p (Proxy :: Proxy '[])

235-- > │ └─ e/

236-- > │ └─•

237-- > ├─ b/

238−-- > │ └─ <capture>/

238+-- > │ └─ <x::Int>/

239-- > │ ├─•

240-- > │ ┆

241-- > │ └─•

@@ -252,7 +252,8 @@ hoistServer p = hoistServerWithContext p (Proxy :: Proxy '[])

252--

253-- [@─•@] Leaves reflect endpoints.

254--

255−-- [@\<capture\>/@] This is a delayed capture of a path component.

255+-- [@\<x::Int\>/@] This is a delayed capture of a single

256+-- path component named @x@, of expected type @Int@.

256--

257--

257-- [@\<raw\>@] This is a part of the API we do not know anything about.

258-- [@\<raw\>@] This is a part of the API we do not know anything about.

258--

259--

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

@@ -31,12 +31,6 @@ module Servant.Server.Internal

31 , module Servant.Server.Internal.ServerError

32 ) where

33

34−import Data.Proxy (Proxy (Proxy))

35−import Data.SOP (I (I))

36−import Data.SOP.Constraint (All, And)

37−import Data.String.Conversions (LBS, cs)

38−import Network.HTTP.Types (Status, HeaderName, hContentType)

39−

40import Control.Monad

34import Control.Monad

41 (join, when)

35 (join, when)

42import Control.Monad.Trans

36import Control.Monad.Trans

@@ -47,7 +41,7 @@ import qualified Data.ByteString as B

47import qualified Data.ByteString.Builder as BB

41import qualified Data.ByteString.Builder as BB

48import qualified Data.ByteString.Char8 as BC8

42import qualified Data.ByteString.Char8 as BC8

49import qualified Data.ByteString.Lazy as BL

43import qualified Data.ByteString.Lazy as BL

50−import Data.Constraint (Dict(..))

44+import Data.Constraint (Constraint, Dict(..))

51import Data.Either

45import Data.Either

52 (partitionEithers)

46 (partitionEithers)

53import Data.Maybe

47import Data.Maybe

@@ -82,9 +76,7 @@ import Servant.API

82 QueryParam', QueryParams, Raw, ReflectMethod (reflectMethod),

76 QueryParam', QueryParams, Raw, ReflectMethod (reflectMethod),

83 RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO,

77 RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO,

84 Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb,

78 Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb,

85− WithNamedContext, NamedRoutes, UVerb, WithStatus(..))

79+ WithNamedContext, NamedRoutes)

86−

87−import Servant.API.UVerb (HasStatus, IsMember, Statuses, UVerb, Union, Unique, WithStatus (..), foldMapUnion, inject, statusOf)

88import Servant.API.Generic (GenericMode(..), ToServant, ToServantApi, GServantProduct, toServant, fromServant)

80import Servant.API.Generic (GenericMode(..), ToServant, ToServantApi, GServantProduct, toServant, fromServant)

89import Servant.API.ContentTypes

81import Servant.API.ContentTypes

90 (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),

82 (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),

@@ -96,7 +88,7 @@ import Servant.API.Modifiers

96import Servant.API.ResponseHeaders

88import Servant.API.ResponseHeaders

97 (GetHeaders, Headers, getHeaders, getResponse)

89 (GetHeaders, Headers, getHeaders, getResponse)

98import Servant.API.Status

90import Servant.API.Status

99− (statusFromNat, KnownStatus)

91+ (statusFromNat)

100import qualified Servant.Types.SourceT as S

92import qualified Servant.Types.SourceT as S

101import Servant.API.TypeErrors

93import Servant.API.TypeErrors

102import Web.HttpApiData

94import Web.HttpApiData

@@ -181,7 +173,7 @@ instance (HasServer a context, HasServer b context) => HasServer (a :<|> b) cont

181-- > server = getBook

173-- > server = getBook

182-- > where getBook :: Text -> Handler Book

174-- > where getBook :: Text -> Handler Book

183-- > getBook isbn = ...

175-- > getBook isbn = ...

184−instance (KnownSymbol capture, FromHttpApiData a

176+instance (KnownSymbol capture, FromHttpApiData a, Typeable a

185 , HasServer api context, SBoolI (FoldLenient mods)

177 , HasServer api context, SBoolI (FoldLenient mods)

186 , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters

178 , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters

187 )

179 )

@@ -193,7 +185,7 @@ instance (KnownSymbol capture, FromHttpApiData a

193 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s

185 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s

194

186

195 route Proxy context d =

187 route Proxy context d =

196− CaptureRouter $

188+ CaptureRouter [hint] $

197 route (Proxy :: Proxy api)

189 route (Proxy :: Proxy api)

198 context

190 context

199 (addCapture d $ \ txt -> withRequest $ \ request ->

191 (addCapture d $ \ txt -> withRequest $ \ request ->

@@ -205,6 +197,7 @@ instance (KnownSymbol capture, FromHttpApiData a

205 where

197 where

206 rep = typeRep (Proxy :: Proxy Capture')

198 rep = typeRep (Proxy :: Proxy Capture')

207 formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)

199 formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)

200+ hint = CaptureHint (T.pack $ symbolVal $ Proxy @capture) (typeRep (Proxy :: Proxy a))

208

201

209-- | If you use 'CaptureAll' in one of the endpoints for your API,

202-- | If you use 'CaptureAll' in one of the endpoints for your API,

210-- this automatically requires your server-side handler to be a

203-- this automatically requires your server-side handler to be a

@@ -223,7 +216,7 @@ instance (KnownSymbol capture, FromHttpApiData a

223-- > server = getSourceFile

216-- > server = getSourceFile

224-- > where getSourceFile :: [Text] -> Handler Book

217-- > where getSourceFile :: [Text] -> Handler Book

225-- > getSourceFile pathSegments = ...

218-- > getSourceFile pathSegments = ...

226−instance (KnownSymbol capture, FromHttpApiData a

219+instance (KnownSymbol capture, FromHttpApiData a, Typeable a

227 , HasServer api context

220 , HasServer api context

228 , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters

221 , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters

229 )

222 )

@@ -235,7 +228,7 @@ instance (KnownSymbol capture, FromHttpApiData a

235 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s

228 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s

236

229

237 route Proxy context d =

230 route Proxy context d =

238− CaptureAllRouter $

231+ CaptureAllRouter [hint] $

239 route (Proxy :: Proxy api)

232 route (Proxy :: Proxy api)

240 context

233 context

241 (addCapture d $ \ txts -> withRequest $ \ request ->

234 (addCapture d $ \ txts -> withRequest $ \ request ->

@@ -246,6 +239,7 @@ instance (KnownSymbol capture, FromHttpApiData a

246 where

239 where

247 rep = typeRep (Proxy :: Proxy CaptureAll)

240 rep = typeRep (Proxy :: Proxy CaptureAll)

248 formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)

241 formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)

242+ hint = CaptureHint (T.pack $ symbolVal $ Proxy @capture) (typeRep (Proxy :: Proxy [a]))

249

243

250allowedMethodHead :: Method -> Request -> Bool

244allowedMethodHead :: Method -> Request -> Bool

251allowedMethodHead method request = method == methodGet && requestMethod request == methodHead

245allowedMethodHead method request = method == methodGet && requestMethod request == methodHead

@@ -300,36 +294,28 @@ noContentRouter method status action = leafRouter route'

300 env request respond $ \ _output ->

294 env request respond $ \ _output ->

301 Route $ responseLBS status [] ""

295 Route $ responseLBS status [] ""

302

296

303−-- instance {-# OVERLAPPABLE #-}

297+instance {-# OVERLAPPABLE #-}

304−-- ( AllCTRender ctypes a, ReflectMethod method, KnownNat status

298+ ( AllCTRender ctypes a, ReflectMethod method, KnownNat status

305−-- ) => HasServer (Verb method status ctypes a) context where

299+ ) => HasServer (Verb method status ctypes a) context where

306−

307−-- type ServerT (Verb method status ctypes a) m = m a

308−-- hoistServerWithContext _ _ nt s = nt s

309−

310−-- route Proxy _ = methodRouter ([],) method (Proxy :: Proxy ctypes) status

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

312−-- status = statusFromNat (Proxy :: Proxy status)

313

300

314−-- instance {-# OVERLAPPING #-}

315−-- ( AllCTRender ctypes a, ReflectMethod method, KnownNat status

316−-- , GetHeaders (Headers h a)

317−-- ) => HasServer (Verb method status ctypes (Headers h a)) context where

301+ type ServerT (Verb method status ctypes a) m = m a

302+ hoistServerWithContext _ _ nt s = nt s

318

303

319−-- type ServerT (Verb method status ctypes (Headers h a)) m = m (Headers h a)

304+ route Proxy _ = methodRouter ([],) method (Proxy :: Proxy ctypes) status

320−-- hoistServerWithContext _ _ nt s = nt s

305+ where method = reflectMethod (Proxy :: Proxy method)

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

321

307

322−-- route Proxy _ = methodRouter (\x -> (getHeaders x, getResponse x)) method (Proxy :: Proxy ctypes) status

308+instance {-# OVERLAPPING #-}

323−-- where method = reflectMethod (Proxy :: Proxy method)

309+ ( AllCTRender ctypes a, ReflectMethod method, KnownNat status

324−-- status = statusFromNat (Proxy :: Proxy status)

310+ , GetHeaders (Headers h a)

311+ ) => HasServer (Verb method status ctypes (Headers h a)) context where

325

312

326−instance

313+ type ServerT (Verb method status ctypes (Headers h a)) m = m (Headers h a)

327− (KnownStatus statusCode, HasServer (UVerb method ctypes '[WithStatus statusCode a]) context) =>

314+ hoistServerWithContext _ _ nt s = nt s

328− HasServer (Verb method statusCode ctypes a) context where

329

315

330− type ServerT (Verb method statusCode ctypes a) m = m a

316+ route Proxy _ = methodRouter (\x -> (getHeaders x, getResponse x)) method (Proxy :: Proxy ctypes) status

331− route = undefined

317+ where method = reflectMethod (Proxy :: Proxy method)

332− hoistServerWithContext p1 p2 nat s = undefined

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

333

319

334instance (ReflectMethod method) =>

320instance (ReflectMethod method) =>

335 HasServer (NoContentVerb method) context where

321 HasServer (NoContentVerb method) context where

@@ -837,7 +823,7 @@ instance (HasContextEntry context (NamedContext name subContext), HasServer subA

837-- Erroring instance for 'HasServer' when a combinator is not fully applied

823-- Erroring instance for 'HasServer' when a combinator is not fully applied

838instance TypeError (PartialApplication HasServer arr) => HasServer ((arr :: a -> b) :> sub) context

824instance TypeError (PartialApplication HasServer arr) => HasServer ((arr :: a -> b) :> sub) context

839 where

825 where

840− type ServerT (arr :> sub) _ = TypeError (PartialApplication HasServer arr)

826+ type ServerT (arr :> sub) _ = TypeError (PartialApplication (HasServer :: * -> [*] -> Constraint) arr)

841 route = error "unreachable"

827 route = error "unreachable"

842 hoistServerWithContext _ _ _ _ = error "unreachable"

828 hoistServerWithContext _ _ _ _ = error "unreachable"

843

829

@@ -973,84 +959,3 @@ instance

973 toServant server

959 toServant server

974 servantSrvN :: ServerT (ToServantApi api) n =

960 servantSrvN :: ServerT (ToServantApi api) n =

975 hoistServerWithContext (Proxy @(ToServantApi api)) pctx nat servantSrvM

961 hoistServerWithContext (Proxy @(ToServantApi api)) pctx nat servantSrvM

976−

977−

978−

979−-- | 'return' for 'UVerb' handlers. Takes a value of any of the members of the open union,

980−-- and will construct a union value in an 'Applicative' (eg. 'Server').

981−respond ::

982− forall (x :: *) (xs :: [*]) (f :: * -> *).

983− (Applicative f, HasStatus x, IsMember x xs) =>

984− x ->

985− f (Union xs)

986−respond = pure . inject . I

987−

988−class IsServerResource (cts :: [*]) a where

989− resourceResponse :: Request -> Proxy cts -> a -> Maybe (LBS, LBS)

990− resourceHeaders :: Proxy cts -> a -> [(HeaderName, B.ByteString)]

991−

992−instance {-# OVERLAPPABLE #-} AllCTRender cts a

993− => IsServerResource cts a where

994− resourceResponse request p res = handleAcceptH p (getAcceptHeader request) res

995− resourceHeaders _ _ = []

996−

997−instance {-# OVERLAPPING #-} (IsServerResource cts a, GetHeaders (Headers h a))

998− => IsServerResource cts (Headers h a) where

999− resourceResponse request p res = resourceResponse request p (getResponse res)

1000− resourceHeaders cts res = getHeaders res ++ resourceHeaders cts (getResponse res)

1001−

1002−instance {-# OVERLAPPING #-} IsServerResource cts a

1003− => IsServerResource cts (WithStatus n a) where

1004− resourceResponse request p (WithStatus x) = resourceResponse request p x

1005− resourceHeaders cts (WithStatus x) = resourceHeaders cts x

1006−

1007−encodeResource :: forall a cts . (IsServerResource cts a, HasStatus a)

1008− => Request -> Proxy cts -> a

1009− -> (Status, Maybe (LBS, LBS), [(HeaderName, B.ByteString)])

1010−encodeResource request cts res = (statusOf (Proxy @a),

1011− resourceResponse request cts res,

1012− resourceHeaders cts res)

1013−

1014−type IsServerResourceWithStatus cts = IsServerResource cts `And` HasStatus

1015−

1016−instance

1017− ( ReflectMethod method,

1018− AllMime contentTypes,

1019− All (IsServerResourceWithStatus contentTypes) as,

1020− Unique (Statuses as) -- for consistency with servant-swagger (server would work fine

1021− -- without; client is a bit of a corner case, because it dispatches

1022− -- the parser based on the status code. with this uniqueness

1023− -- constraint it won't have to run more than one parser in weird

1024− -- corner cases.

1025− ) =>

1026− HasServer (UVerb method contentTypes as) context

1027− where

1028− type ServerT (UVerb method contentTypes as) m = m (Union as)

1029−

1030− hoistServerWithContext _ _ nt s = nt s

1031−

1032− route ::

1033− forall env.

1034− Proxy (UVerb method contentTypes as) ->

1035− Context context ->

1036− Delayed env (Server (UVerb method contentTypes as)) ->

1037− Router env

1038− route _proxy _ctx action = leafRouter route'

1039− where

1040− method = reflectMethod (Proxy @method)

1041− route' env request cont = do

1042− let action' :: Delayed env (Handler (Union as))

1043− action' =

1044− action

1045− `addMethodCheck` methodCheck method request

1046− `addAcceptCheck` acceptCheck (Proxy @contentTypes) (getAcceptHeader request)

1047−

1048− runAction action' env request cont $ \(output :: Union as) -> do

1049− let cts = Proxy @contentTypes

1050− pickResource :: Union as -> (Status, Maybe (LBS, LBS), [(HeaderName, B.ByteString)])

1051− pickResource = foldMapUnion (Proxy @(IsServerResourceWithStatus contentTypes)) (encodeResource request cts)

1052− case pickResource output of

1053− (_, Nothing, _) -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does

1054− (status, Just (contentT, body), headers) ->

1055− let bdy = if allowedMethodHead method request then "" else body

1056− in Route $ responseLBS status ((hContentType, cs contentT) : headers) bdy

servant-server/src/Servant/Server/Internal/Handler.hs+7−2

@@ -13,17 +13,19 @@ import Control.Monad.Base

13import Control.Monad.Catch

14 (MonadCatch, MonadMask, MonadThrow)

15import Control.Monad.Error.Class

16− (MonadError)

16+ (MonadError, throwError)

17import Control.Monad.IO.Class

18 (MonadIO)

19import Control.Monad.Trans.Control

20 (MonadBaseControl (..))

21import Control.Monad.Trans.Except

22 (ExceptT, runExceptT)

23+import Data.String

24+ (fromString)

23import GHC.Generics

25import GHC.Generics

24 (Generic)

26 (Generic)

25import Servant.Server.Internal.ServerError

27import Servant.Server.Internal.ServerError

26− (ServerError)

28+ (ServerError, errBody, err500)

27

29

28newtype Handler a = Handler { runHandler' :: ExceptT ServerError IO a }

30newtype Handler a = Handler { runHandler' :: ExceptT ServerError IO a }

29 deriving

31 deriving

@@ -32,6 +34,9 @@ newtype Handler a = Handler { runHandler' :: ExceptT ServerError IO a }

32 , MonadThrow, MonadCatch, MonadMask

34 , MonadThrow, MonadCatch, MonadMask

33 )

35 )

34

36

37+instance MonadFail Handler where

38+ fail str = throwError err500 { errBody = fromString str }

39+

35instance MonadBase IO Handler where

40instance MonadBase IO Handler where

36 liftBase = Handler . liftBase

41 liftBase = Handler . liftBase

37

42

servant-server/src/Servant/Server/Internal/Router.hs+31−14

@@ -9,12 +9,16 @@ import Prelude.Compat

9

10import Data.Function

11 (on)

12+import Data.List

13+ (nub)

12import Data.Map

14import Data.Map

13 (Map)

15 (Map)

14import qualified Data.Map as M

16import qualified Data.Map as M

15import Data.Text

17import Data.Text

16 (Text)

18 (Text)

17import qualified Data.Text as T

19import qualified Data.Text as T

20+import Data.Typeable

21+ (TypeRep)

18import Network.Wai

22import Network.Wai

19 (Response, pathInfo)

23 (Response, pathInfo)

20import Servant.Server.Internal.ErrorFormatter

24import Servant.Server.Internal.ErrorFormatter

@@ -24,6 +28,18 @@ import Servant.Server.Internal.ServerError

24

28

25type Router env = Router' env RoutingApplication

29type Router env = Router' env RoutingApplication

26

30

31+data CaptureHint = CaptureHint

32+ { captureName :: Text

33+ , captureType :: TypeRep

34+ }

35+ deriving (Show, Eq)

36+

37+toCaptureTag :: CaptureHint -> Text

38+toCaptureTag hint = captureName hint <> "::" <> (T.pack . show) (captureType hint)

39+

40+toCaptureTags :: [CaptureHint] -> Text

41+toCaptureTags hints = "<" <> T.intercalate "|" (map toCaptureTag hints) <> ">"

42+

27-- | Internal representation of a router.

43-- | Internal representation of a router.

28--

44--

29-- The first argument describes an environment type that is

45-- The first argument describes an environment type that is

@@ -36,10 +52,10 @@ data Router' env a =

36 -- ^ the map contains routers for subpaths (first path component used

52 -- ^ the map contains routers for subpaths (first path component used

37 -- for lookup and removed afterwards), the list contains handlers

53 -- for lookup and removed afterwards), the list contains handlers

38 -- for the empty path, to be tried in order

54 -- for the empty path, to be tried in order

39− | CaptureRouter (Router' (Text, env) a)

55+ | CaptureRouter [CaptureHint] (Router' (Text, env) a)

40 -- ^ first path component is passed to the child router in its

56 -- ^ first path component is passed to the child router in its

41 -- environment and removed afterwards

57 -- environment and removed afterwards

42− | CaptureAllRouter (Router' ([Text], env) a)

58+ | CaptureAllRouter [CaptureHint] (Router' ([Text], env) a)

43 -- ^ all path components are passed to the child router in its

59 -- ^ all path components are passed to the child router in its

44 -- environment and are removed afterwards

60 -- environment and are removed afterwards

45 | RawRouter (env -> a)

61 | RawRouter (env -> a)

@@ -69,8 +85,8 @@ leafRouter l = StaticRouter M.empty [l]

69choice :: Router' env a -> Router' env a -> Router' env a

85choice :: Router' env a -> Router' env a -> Router' env a

70choice (StaticRouter table1 ls1) (StaticRouter table2 ls2) =

86choice (StaticRouter table1 ls1) (StaticRouter table2 ls2) =

71 StaticRouter (M.unionWith choice table1 table2) (ls1 ++ ls2)

87 StaticRouter (M.unionWith choice table1 table2) (ls1 ++ ls2)

72−choice (CaptureRouter router1) (CaptureRouter router2) =

88+choice (CaptureRouter hints1 router1) (CaptureRouter hints2 router2) =

73− CaptureRouter (choice router1 router2)

89+ CaptureRouter (nub $ hints1 ++ hints2) (choice router1 router2)

74choice router1 (Choice router2 router3) = Choice (choice router1 router2) router3

90choice router1 (Choice router2 router3) = Choice (choice router1 router2) router3

75choice router1 router2 = Choice router1 router2

91choice router1 router2 = Choice router1 router2

76

92

@@ -84,7 +100,7 @@ choice router1 router2 = Choice router1 router2

84--

100--

85data RouterStructure =

101data RouterStructure =

86 StaticRouterStructure (Map Text RouterStructure) Int

102 StaticRouterStructure (Map Text RouterStructure) Int

87− | CaptureRouterStructure RouterStructure

103+ | CaptureRouterStructure [CaptureHint] RouterStructure

88 | RawRouterStructure

104 | RawRouterStructure

89 | ChoiceStructure RouterStructure RouterStructure

105 | ChoiceStructure RouterStructure RouterStructure

90 deriving (Eq, Show)

106 deriving (Eq, Show)

@@ -98,11 +114,11 @@ data RouterStructure =

98routerStructure :: Router' env a -> RouterStructure

114routerStructure :: Router' env a -> RouterStructure

99routerStructure (StaticRouter m ls) =

115routerStructure (StaticRouter m ls) =

100 StaticRouterStructure (fmap routerStructure m) (length ls)

116 StaticRouterStructure (fmap routerStructure m) (length ls)

101−routerStructure (CaptureRouter router) =

117+routerStructure (CaptureRouter hints router) =

102− CaptureRouterStructure $

118+ CaptureRouterStructure hints $

103 routerStructure router

119 routerStructure router

104−routerStructure (CaptureAllRouter router) =

120+routerStructure (CaptureAllRouter hints router) =

105− CaptureRouterStructure $

121+ CaptureRouterStructure hints $

106 routerStructure router

122 routerStructure router

107routerStructure (RawRouter _) =

123routerStructure (RawRouter _) =

108 RawRouterStructure

124 RawRouterStructure

@@ -114,8 +130,8 @@ routerStructure (Choice r1 r2) =

114-- | Compare the structure of two routers.

130-- | Compare the structure of two routers.

115--

131--

116sameStructure :: Router' env a -> Router' env b -> Bool

132sameStructure :: Router' env a -> Router' env b -> Bool

117−sameStructure r1 r2 =

133+sameStructure router1 router2 =

118− routerStructure r1 == routerStructure r2

134+ routerStructure router1 == routerStructure router2

119

135

120-- | Provide a textual representation of the

136-- | Provide a textual representation of the

121-- structure of a router.

137-- structure of a router.

@@ -126,7 +142,8 @@ routerLayout router =

126 where

142 where

127 mkRouterLayout :: Bool -> RouterStructure -> [Text]

143 mkRouterLayout :: Bool -> RouterStructure -> [Text]

128 mkRouterLayout c (StaticRouterStructure m n) = mkSubTrees c (M.toList m) n

144 mkRouterLayout c (StaticRouterStructure m n) = mkSubTrees c (M.toList m) n

129− mkRouterLayout c (CaptureRouterStructure r) = mkSubTree c "<capture>" (mkRouterLayout False r)

145+ mkRouterLayout c (CaptureRouterStructure hints r) =

146+ mkSubTree c (toCaptureTags hints) (mkRouterLayout False r)

130 mkRouterLayout c RawRouterStructure =

147 mkRouterLayout c RawRouterStructure =

131 if c then ["├─ <raw>"] else ["└─ <raw>"]

148 if c then ["├─ <raw>"] else ["└─ <raw>"]

132 mkRouterLayout c (ChoiceStructure r1 r2) =

149 mkRouterLayout c (ChoiceStructure r1 r2) =

@@ -169,7 +186,7 @@ runRouterEnv fmt router env request respond =

169 -> let request' = request { pathInfo = rest }

186 -> let request' = request { pathInfo = rest }

170 in runRouterEnv fmt router' env request' respond

187 in runRouterEnv fmt router' env request' respond

171 _ -> respond $ Fail $ fmt request

188 _ -> respond $ Fail $ fmt request

172− CaptureRouter router' ->

189+ CaptureRouter _ router' ->

173 case pathInfo request of

190 case pathInfo request of

174 [] -> respond $ Fail $ fmt request

191 [] -> respond $ Fail $ fmt request

175 -- This case is to handle trailing slashes.

192 -- This case is to handle trailing slashes.

@@ -177,7 +194,7 @@ runRouterEnv fmt router env request respond =

177 first : rest

194 first : rest

178 -> let request' = request { pathInfo = rest }

195 -> let request' = request { pathInfo = rest }

179 in runRouterEnv fmt router' (first, env) request' respond

196 in runRouterEnv fmt router' (first, env) request' respond

180− CaptureAllRouter router' ->

197+ CaptureAllRouter _ router' ->

181 let segments = pathInfo request

198 let segments = pathInfo request

182 request' = request { pathInfo = [] }

199 request' = request { pathInfo = [] }

183 in runRouterEnv fmt router' (segments, env) request' respond

200 in runRouterEnv fmt router' (segments, env) request' respond

servant-server/src/Servant/Server/UVerb.hs+80−80

@@ -22,95 +22,95 @@ module Servant.Server.UVerb

22 )

23where

24

25−-- import qualified Data.ByteString as B

25+import qualified Data.ByteString as B

26−-- import Data.Proxy (Proxy (Proxy))

26+import Data.Proxy (Proxy (Proxy))

27−-- import Data.SOP (I (I))

27+import Data.SOP (I (I))

28−-- import Data.SOP.Constraint (All, And)

28+import Data.SOP.Constraint (All, And)

29−-- import Data.String.Conversions (LBS, cs)

29+import Data.String.Conversions (LBS, cs)

30−-- import Network.HTTP.Types (Status, HeaderName, hContentType)

30+import Network.HTTP.Types (Status, HeaderName, hContentType)

31−-- import Network.Wai (responseLBS, Request)

31+import Network.Wai (responseLBS, Request)

32−-- import Servant.API (ReflectMethod, reflectMethod)

32+import Servant.API (ReflectMethod, reflectMethod)

33−-- import Servant.API.ContentTypes (AllCTRender (handleAcceptH), AllMime)

33+import Servant.API.ContentTypes (AllCTRender (handleAcceptH), AllMime)

34−-- import Servant.API.ResponseHeaders (GetHeaders (..), Headers (..))

34+import Servant.API.ResponseHeaders (GetHeaders (..), Headers (..))

35−-- import Servant.API.UVerb (HasStatus, IsMember, Statuses, UVerb, Union, Unique, WithStatus (..), foldMapUnion, inject, statusOf)

35+import Servant.API.UVerb (HasStatus, IsMember, Statuses, UVerb, Union, Unique, WithStatus (..), foldMapUnion, inject, statusOf)

36−import Servant.Server.Internal (respond, IsServerResource)

36+import Servant.Server.Internal (Context, Delayed, Handler, HasServer (..), RouteResult (FailFatal, Route), Router, Server, ServerT, acceptCheck, addAcceptCheck, addMethodCheck, allowedMethodHead, err406, getAcceptHeader, leafRouter, methodCheck, runAction)

37

38

39−-- -- | 'return' for 'UVerb' handlers. Takes a value of any of the members of the open union,

39+-- | 'return' for 'UVerb' handlers. Takes a value of any of the members of the open union,

40−-- -- and will construct a union value in an 'Applicative' (eg. 'Server').

40+-- and will construct a union value in an 'Applicative' (eg. 'Server').

41−-- respond ::

41+respond ::

42−-- forall (x :: *) (xs :: [*]) (f :: * -> *).

42+ forall (x :: *) (xs :: [*]) (f :: * -> *).

43−-- (Applicative f, HasStatus x, IsMember x xs) =>

43+ (Applicative f, HasStatus x, IsMember x xs) =>

44−-- x ->

44+ x ->

45−-- f (Union xs)

45+ f (Union xs)

46−-- respond = pure . inject . I

46+respond = pure . inject . I

47

48−-- class IsServerResource (cts :: [*]) a where

48+class IsServerResource (cts :: [*]) a where

49−-- resourceResponse :: Request -> Proxy cts -> a -> Maybe (LBS, LBS)

49+ resourceResponse :: Request -> Proxy cts -> a -> Maybe (LBS, LBS)

50−-- resourceHeaders :: Proxy cts -> a -> [(HeaderName, B.ByteString)]

50+ resourceHeaders :: Proxy cts -> a -> [(HeaderName, B.ByteString)]

51

52−-- instance {-# OVERLAPPABLE #-} AllCTRender cts a

52+instance {-# OVERLAPPABLE #-} AllCTRender cts a

53−-- => IsServerResource cts a where

53+ => IsServerResource cts a where

54−-- resourceResponse request p res = handleAcceptH p (getAcceptHeader request) res

54+ resourceResponse request p res = handleAcceptH p (getAcceptHeader request) res

55−-- resourceHeaders _ _ = []

55+ resourceHeaders _ _ = []

56

57−-- instance {-# OVERLAPPING #-} (IsServerResource cts a, GetHeaders (Headers h a))

57+instance {-# OVERLAPPING #-} (IsServerResource cts a, GetHeaders (Headers h a))

58−-- => IsServerResource cts (Headers h a) where

58+ => IsServerResource cts (Headers h a) where

59−-- resourceResponse request p res = resourceResponse request p (getResponse res)

59+ resourceResponse request p res = resourceResponse request p (getResponse res)

60−-- resourceHeaders cts res = getHeaders res ++ resourceHeaders cts (getResponse res)

60+ resourceHeaders cts res = getHeaders res ++ resourceHeaders cts (getResponse res)

61

62−-- instance {-# OVERLAPPING #-} IsServerResource cts a

62+instance {-# OVERLAPPING #-} IsServerResource cts a

63−-- => IsServerResource cts (WithStatus n a) where

63+ => IsServerResource cts (WithStatus n a) where

64−-- resourceResponse request p (WithStatus x) = resourceResponse request p x

64+ resourceResponse request p (WithStatus x) = resourceResponse request p x

65−-- resourceHeaders cts (WithStatus x) = resourceHeaders cts x

65+ resourceHeaders cts (WithStatus x) = resourceHeaders cts x

66

67−-- encodeResource :: forall a cts . (IsServerResource cts a, HasStatus a)

67+encodeResource :: forall a cts . (IsServerResource cts a, HasStatus a)

68−-- => Request -> Proxy cts -> a

68+ => Request -> Proxy cts -> a

69−-- -> (Status, Maybe (LBS, LBS), [(HeaderName, B.ByteString)])

69+ -> (Status, Maybe (LBS, LBS), [(HeaderName, B.ByteString)])

70−-- encodeResource request cts res = (statusOf (Proxy @a),

70+encodeResource request cts res = (statusOf (Proxy @a),

71−-- resourceResponse request cts res,

71+ resourceResponse request cts res,

72−-- resourceHeaders cts res)

72+ resourceHeaders cts res)

73

74−-- type IsServerResourceWithStatus cts = IsServerResource cts `And` HasStatus

74+type IsServerResourceWithStatus cts = IsServerResource cts `And` HasStatus

75

76−-- instance

76+instance

77−-- ( ReflectMethod method,

77+ ( ReflectMethod method,

78−-- AllMime contentTypes,

78+ AllMime contentTypes,

79−-- All (IsServerResourceWithStatus contentTypes) as,

79+ All (IsServerResourceWithStatus contentTypes) as,

80−-- Unique (Statuses as) -- for consistency with servant-swagger (server would work fine

80+ Unique (Statuses as) -- for consistency with servant-swagger (server would work fine

81−-- -- without; client is a bit of a corner case, because it dispatches

81+ -- without; client is a bit of a corner case, because it dispatches

82−-- -- the parser based on the status code. with this uniqueness

82+ -- the parser based on the status code. with this uniqueness

83−-- -- constraint it won't have to run more than one parser in weird

83+ -- constraint it won't have to run more than one parser in weird

84−-- -- corner cases.

84+ -- corner cases.

85−-- ) =>

85+ ) =>

86−-- HasServer (UVerb method contentTypes as) context

86+ HasServer (UVerb method contentTypes as) context

87−-- where

87+ where

88−-- type ServerT (UVerb method contentTypes as) m = m (Union as)

88+ type ServerT (UVerb method contentTypes as) m = m (Union as)

89

90−-- hoistServerWithContext _ _ nt s = nt s

90+ hoistServerWithContext _ _ nt s = nt s

91

92−-- route ::

92+ route ::

93−-- forall env.

93+ forall env.

94−-- Proxy (UVerb method contentTypes as) ->

94+ Proxy (UVerb method contentTypes as) ->

95−-- Context context ->

95+ Context context ->

96−-- Delayed env (Server (UVerb method contentTypes as)) ->

96+ Delayed env (Server (UVerb method contentTypes as)) ->

97−-- Router env

97+ Router env

98−-- route _proxy _ctx action = leafRouter route'

98+ route _proxy _ctx action = leafRouter route'

99−-- where

99+ where

100−-- method = reflectMethod (Proxy @method)

100+ method = reflectMethod (Proxy @method)

101−-- route' env request cont = do

101+ route' env request cont = do

102−-- let action' :: Delayed env (Handler (Union as))

102+ let action' :: Delayed env (Handler (Union as))

103−-- action' =

103+ action' =

104−-- action

104+ action

105−-- `addMethodCheck` methodCheck method request

105+ `addMethodCheck` methodCheck method request

106−-- `addAcceptCheck` acceptCheck (Proxy @contentTypes) (getAcceptHeader request)

106+ `addAcceptCheck` acceptCheck (Proxy @contentTypes) (getAcceptHeader request)

107

108−-- runAction action' env request cont $ \(output :: Union as) -> do

108+ runAction action' env request cont $ \(output :: Union as) -> do

109−-- let cts = Proxy @contentTypes

109+ let cts = Proxy @contentTypes

110−-- pickResource :: Union as -> (Status, Maybe (LBS, LBS), [(HeaderName, B.ByteString)])

110+ pickResource :: Union as -> (Status, Maybe (LBS, LBS), [(HeaderName, B.ByteString)])

111−-- pickResource = foldMapUnion (Proxy @(IsServerResourceWithStatus contentTypes)) (encodeResource request cts)

111+ pickResource = foldMapUnion (Proxy @(IsServerResourceWithStatus contentTypes)) (encodeResource request cts)

112−-- case pickResource output of

112+ case pickResource output of

113−-- (_, Nothing, _) -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does

113+ (_, Nothing, _) -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does

114−-- (status, Just (contentT, body), headers) ->

114+ (status, Just (contentT, body), headers) ->

115−-- let bdy = if allowedMethodHead method request then "" else body

115+ let bdy = if allowedMethodHead method request then "" else body

116−-- in Route $ responseLBS status ((hContentType, cs contentT) : headers) bdy

116+ in Route $ responseLBS status ((hContentType, cs contentT) : headers) bdy

servant-server/test/Servant/Server/RouterSpec.hs+127−6

@@ -9,7 +9,9 @@ import Control.Monad

9import Data.Proxy

10 (Proxy (..))

11import Data.Text

12− (unpack)

12+ (Text, unpack)

13+import Data.Typeable

14+ (typeRep)

13import Network.HTTP.Types

15import Network.HTTP.Types

14 (Status (..))

16 (Status (..))

15import Network.Wai

17import Network.Wai

@@ -27,6 +29,7 @@ spec :: Spec

27spec = describe "Servant.Server.Internal.Router" $ do

29spec = describe "Servant.Server.Internal.Router" $ do

28 routerSpec

30 routerSpec

29 distributivitySpec

31 distributivitySpec

32+ serverLayoutSpec

30

33

31routerSpec :: Spec

34routerSpec :: Spec

32routerSpec = do

35routerSpec = do

@@ -51,7 +54,7 @@ routerSpec = do

51 toApp = toApplication . runRouter (const err404)

54 toApp = toApplication . runRouter (const err404)

52

55

53 cap :: Router ()

56 cap :: Router ()

54− cap = CaptureRouter $

57+ cap = CaptureRouter [hint] $

55 let delayed = addCapture (emptyDelayed $ Route pure) (const $ delayedFail err400)

58 let delayed = addCapture (emptyDelayed $ Route pure) (const $ delayedFail err400)

56 in leafRouter

59 in leafRouter

57 $ \env req res ->

60 $ \env req res ->

@@ -59,6 +62,9 @@ routerSpec = do

59 . const

62 . const

60 $ Route success

63 $ Route success

61

64

65+ hint :: CaptureHint

66+ hint = CaptureHint "anything" $ typeRep (Proxy :: Proxy ())

67+

62 router :: Router ()

68 router :: Router ()

63 router = leafRouter (\_ _ res -> res $ Route success)

69 router = leafRouter (\_ _ res -> res $ Route success)

64 `Choice` cap

70 `Choice` cap

@@ -98,12 +104,30 @@ distributivitySpec =

98 it "properly handles mixing static paths at different levels" $ do

104 it "properly handles mixing static paths at different levels" $ do

99 level `shouldHaveSameStructureAs` levelRef

105 level `shouldHaveSameStructureAs` levelRef

100

106

107+serverLayoutSpec :: Spec

108+serverLayoutSpec =

109+ describe "serverLayout" $ do

110+ it "correctly represents the example API" $ do

111+ exampleLayout `shouldHaveLayout` expectedExampleLayout

112+ it "aggregates capture hints when different" $ do

113+ captureDifferentTypes `shouldHaveLayout` expectedCaptureDifferentTypes

114+ it "nubs capture hints when equal" $ do

115+ captureSameType `shouldHaveLayout` expectedCaptureSameType

116+ it "properly displays CaptureAll hints" $ do

117+ captureAllLayout `shouldHaveLayout` expectedCaptureAllLayout

118+

101shouldHaveSameStructureAs ::

119shouldHaveSameStructureAs ::

102 (HasServer api1 '[], HasServer api2 '[]) => Proxy api1 -> Proxy api2 -> Expectation

120 (HasServer api1 '[], HasServer api2 '[]) => Proxy api1 -> Proxy api2 -> Expectation

103shouldHaveSameStructureAs p1 p2 =

121shouldHaveSameStructureAs p1 p2 =

104 unless (sameStructure (makeTrivialRouter p1) (makeTrivialRouter p2)) $

122 unless (sameStructure (makeTrivialRouter p1) (makeTrivialRouter p2)) $

105 expectationFailure ("expected:\n" ++ unpack (layout p2) ++ "\nbut got:\n" ++ unpack (layout p1))

123 expectationFailure ("expected:\n" ++ unpack (layout p2) ++ "\nbut got:\n" ++ unpack (layout p1))

106

124

125+shouldHaveLayout ::

126+ (HasServer api '[]) => Proxy api -> Text -> Expectation

127+shouldHaveLayout p l =

128+ unless (routerLayout (makeTrivialRouter p) == l) $

129+ expectationFailure ("expected:\n" ++ unpack l ++ "\nbut got:\n" ++ unpack (layout p))

130+

107makeTrivialRouter :: (HasServer layout '[]) => Proxy layout -> Router ()

131makeTrivialRouter :: (HasServer layout '[]) => Proxy layout -> Router ()

108makeTrivialRouter p =

132makeTrivialRouter p =

109 route p EmptyContext (emptyDelayed (FailFatal err501))

133 route p EmptyContext (emptyDelayed (FailFatal err501))

@@ -144,12 +168,12 @@ staticRef = Proxy

144-- structure:

168-- structure:

145

169

146type Dynamic =

170type Dynamic =

147− "a" :> Capture "foo" Int :> "b" :> End

171+ "a" :> Capture "foo" Int :> "b" :> End

148− :<|> "a" :> Capture "bar" Bool :> "c" :> End

172+ :<|> "a" :> Capture "foo" Int :> "c" :> End

149− :<|> "a" :> Capture "baz" Char :> "d" :> End

173+ :<|> "a" :> Capture "foo" Int :> "d" :> End

150

174

151type DynamicRef =

175type DynamicRef =

152− "a" :> Capture "anything" () :>

176+ "a" :> Capture "foo" Int :>

153 ("b" :> End :<|> "c" :> End :<|> "d" :> End)

177 ("b" :> End :<|> "c" :> End :<|> "d" :> End)

154

178

155dynamic :: Proxy Dynamic

179dynamic :: Proxy Dynamic

@@ -339,3 +363,100 @@ level = Proxy

339

363

340levelRef :: Proxy LevelRef

364levelRef :: Proxy LevelRef

341levelRef = Proxy

365levelRef = Proxy

366+

367+-- The example API for the 'layout' function.

368+-- Should get factorized by the 'choice' smart constructor.

369+type ExampleLayout =

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

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

372+ :<|> "c" :> Put '[JSON] Bool

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

374+ :<|> "b" :> Capture "x" Int :> Put '[JSON] Bool

375+ :<|> Raw

376+

377+exampleLayout :: Proxy ExampleLayout

378+exampleLayout = Proxy

379+

380+-- The expected representation of the example API layout

381+--

382+expectedExampleLayout :: Text

383+expectedExampleLayout =

384+ "/\n\

385+ \├─ a/\n\

386+ \│ ├─ d/\n\

387+ \│ │ └─•\n\

388+ \│ └─ e/\n\

389+ \│ └─•\n\

390+ \├─ b/\n\

391+ \│ └─ <x::Int>/\n\

392+ \│ ├─•\n\

393+ \│ ┆\n\

394+ \│ └─•\n\

395+ \├─ c/\n\

396+ \│ └─•\n\

397+ \┆\n\

398+ \└─ <raw>\n"

399+

400+-- A capture API with all capture types being the same

401+--

402+type CaptureSameType =

403+ "a" :> Capture "foo" Int :> "b" :> End

404+ :<|> "a" :> Capture "foo" Int :> "c" :> End

405+ :<|> "a" :> Capture "foo" Int :> "d" :> End

406+

407+captureSameType :: Proxy CaptureSameType

408+captureSameType = Proxy

409+

410+-- The expected representation of the CaptureSameType API layout.

411+--

412+expectedCaptureSameType :: Text

413+expectedCaptureSameType =

414+ "/\n\

415+ \└─ a/\n\

416+ \ └─ <foo::Int>/\n\

417+ \ ├─ b/\n\

418+ \ │ └─•\n\

419+ \ ├─ c/\n\

420+ \ │ └─•\n\

421+ \ └─ d/\n\

422+ \ └─•\n"

423+

424+-- A capture API capturing different types

425+--

426+type CaptureDifferentTypes =

427+ "a" :> Capture "foo" Int :> "b" :> End

428+ :<|> "a" :> Capture "bar" Bool :> "c" :> End

429+ :<|> "a" :> Capture "baz" Char :> "d" :> End

430+

431+captureDifferentTypes :: Proxy CaptureDifferentTypes

432+captureDifferentTypes = Proxy

433+

434+-- The expected representation of the CaptureDifferentTypes API layout.

435+--

436+expectedCaptureDifferentTypes :: Text

437+expectedCaptureDifferentTypes =

438+ "/\n\

439+ \└─ a/\n\

440+ \ └─ <foo::Int|bar::Bool|baz::Char>/\n\

441+ \ ├─ b/\n\

442+ \ │ └─•\n\

443+ \ ├─ c/\n\

444+ \ │ └─•\n\

445+ \ └─ d/\n\

446+ \ └─•\n"

447+

448+-- An API with a CaptureAll part

449+

450+type CaptureAllLayout = "a" :> CaptureAll "foos" Int :> End

451+

452+captureAllLayout :: Proxy CaptureAllLayout

453+captureAllLayout = Proxy

454+

455+-- The expected representation of the CaptureAllLayout API.

456+--

457+expectedCaptureAllLayout :: Text

458+expectedCaptureAllLayout =

459+ "/\n\

460+ \└─ a/\n\

461+ \ └─ <foos::[Int]>/\n\

462+ \ └─•\n"

servant-swagger/servant-swagger.cabal+14−14

@@ -3,10 +3,10 @@ name: servant-swagger

3version: 1.1.11

4synopsis: Generate a Swagger/OpenAPI/OAS 2.0 specification for your servant API.

5description:

6− Swagger is a project used to describe and document RESTful APIs. The core of the

6+ Swagger is a project used to describe and document RESTful APIs. The core of the

7− project is the [OpenAPI Specification (OAS)](https://swagger.io/docs/specification/about/).

7+ project is the [OpenAPI Specification (OAS)](https://swagger.io/docs/specification/about/).

8− This library implements v2.0 of the spec. Unlike Servant it is language-agnostic and thus is

8+ This library implements v2.0 of the spec. Unlike Servant it is language-agnostic and thus is

9− quite popular among developers in different languages. It has also existed for a longer time

9+ quite popular among developers in different languages. It has also existed for a longer time

10 and has more helpful tooling.

11 .

12 This package provides means to generate a Swagger/OAS specification for a Servant API

@@ -19,7 +19,7 @@ description:

19 * generating clients and servers in many languages using [Swagger Codegen](http://swagger.io/swagger-codegen/);

20 .

21 * and [many others](http://swagger.io/open-source-integrations/).

22−homepage: https://github.com/haskell-servant/servant/servant-swagger

22+homepage: https://github.com/haskell-servant/servant/tree/master/servant-swagger#readme

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

24license: BSD-3-Clause

25license-file: LICENSE

@@ -50,7 +50,7 @@ source-repository head

50custom-setup

51 setup-depends:

52 base >=4.9 && <5,

53− Cabal >= 1.24 && < 3.5,

53+ Cabal >= 1.24,

54 cabal-doctest >=1.0.6 && <1.1

55

56library

@@ -72,15 +72,15 @@ library

72 build-depends: aeson >=1.4.2.0 && <3

73 , aeson-pretty >=0.8.7 && <0.9

74 , base >=4.9.1.0 && <5

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

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

76− , bytestring >=0.10.8.1 && <0.11

76+ , bytestring >=0.10.8.1 && <0.12

77 , http-media >=0.7.1.3 && <0.9

78 , insert-ordered-containers >=0.2.1.0 && <0.3

79 , lens >=4.17 && <6

80− , servant >=0.18.1 && <0.20

80+ , servant >=0.18.2 && <0.20

81 , singleton-bool >=0.1.4 && <0.2

82 , swagger2 >=2.3.0.1 && <3

83− , text >=1.2.3.0 && <1.3

83+ , text >=1.2.3.0 && <2.1

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

85

86 , hspec

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

92 build-depends:

93 base,

94 directory >= 1.0,

95− doctest >= 0.17 && <0.19,

95+ doctest >= 0.17 && <0.21,

96 servant,

97 QuickCheck,

98 filepath

@@ -106,14 +106,14 @@ test-suite spec

106 type: exitcode-stdio-1.0

107 hs-source-dirs: test

108 main-is: Spec.hs

109− build-tool-depends: hspec-discover:hspec-discover >=2.6.0 && <2.8

109+ build-tool-depends: hspec-discover:hspec-discover >=2.6.0 && <2.10

110 build-depends: base

111 , base-compat

112 , aeson >=1.4.2.0 && <3

113− , hspec >=2.6.0 && <2.8

113+ , hspec >=2.6.0 && <2.10

114 , QuickCheck

115 , lens

116− , lens-aeson >=1.0.2 && <1.2

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

117 , servant

118 , servant-swagger

119 , swagger2

servant-swagger/src/Servant/Swagger.hs+5−3

@@ -55,6 +55,7 @@ import Servant.Swagger.Internal.Orphans ()

55-- >>> import Data.Typeable

56-- >>> import GHC.Generics

57-- >>> import Servant.API

58+-- >>> import System.Environment

58-- >>> import Test.Hspec

59-- >>> import Test.Hspec

59-- >>> import Test.QuickCheck

60-- >>> import Test.QuickCheck

60-- >>> import qualified Data.ByteString.Lazy.Char8 as BSL8

61-- >>> import qualified Data.ByteString.Lazy.Char8 as BSL8

@@ -64,6 +65,7 @@ import Servant.Swagger.Internal.Orphans ()

64-- >>> :set -XGeneralizedNewtypeDeriving

65-- >>> :set -XGeneralizedNewtypeDeriving

65-- >>> :set -XOverloadedStrings

66-- >>> :set -XOverloadedStrings

66-- >>> :set -XTypeOperators

67-- >>> :set -XTypeOperators

68+-- >>> setEnv "HSPEC_COLOR" "no"

67-- >>> data User = User { name :: String, age :: Int } deriving (Show, Generic, Typeable)

69-- >>> data User = User { name :: String, age :: Int } deriving (Show, Generic, Typeable)

68-- >>> newtype UserId = UserId Integer deriving (Show, Generic, Typeable, ToJSON)

70-- >>> newtype UserId = UserId Integer deriving (Show, Generic, Typeable, ToJSON)

69-- >>> instance ToJSON User

71-- >>> instance ToJSON User

@@ -160,11 +162,11 @@ import Servant.Swagger.Internal.Orphans ()

160-- >>> instance Arbitrary UserId where arbitrary = UserId <$> arbitrary

162-- >>> instance Arbitrary UserId where arbitrary = UserId <$> arbitrary

161-- >>> hspec $ validateEveryToJSON (Proxy :: Proxy UserAPI)

163-- >>> hspec $ validateEveryToJSON (Proxy :: Proxy UserAPI)

162-- <BLANKLINE>

164-- <BLANKLINE>

163−-- [User]

165+-- [User]...

164-- ...

166-- ...

165−-- User

167+-- User...

166-- ...

168-- ...

167−-- UserId

169+-- UserId...

168-- ...

170-- ...

169-- Finished in ... seconds

171-- Finished in ... seconds

170-- 3 examples, 0 failures

172-- 3 examples, 0 failures

servant-swagger/src/Servant/Swagger/Internal.hs+11

@@ -3,11 +3,13 @@

3{-# LANGUAGE DataKinds #-}

4{-# LANGUAGE FlexibleContexts #-}

5{-# LANGUAGE FlexibleInstances #-}

6+{-# LANGUAGE OverloadedLists #-}

6{-# LANGUAGE OverloadedStrings #-}

7{-# LANGUAGE OverloadedStrings #-}

7{-# LANGUAGE PolyKinds #-}

8{-# LANGUAGE PolyKinds #-}

8{-# LANGUAGE RankNTypes #-}

9{-# LANGUAGE RankNTypes #-}

9{-# LANGUAGE ScopedTypeVariables #-}

10{-# LANGUAGE ScopedTypeVariables #-}

10{-# LANGUAGE TypeOperators #-}

11{-# LANGUAGE TypeOperators #-}

12+{-# LANGUAGE TypeFamilies #-}

11#if __GLASGOW_HASKELL__ >= 806

13#if __GLASGOW_HASKELL__ >= 806

12{-# LANGUAGE UndecidableInstances #-}

14{-# LANGUAGE UndecidableInstances #-}

13#endif

15#endif

@@ -30,11 +32,13 @@ import qualified Data.Swagger as Swagger

30import Data.Swagger.Declare

32import Data.Swagger.Declare

31import Data.Text (Text)

33import Data.Text (Text)

32import qualified Data.Text as Text

34import qualified Data.Text as Text

35+import GHC.Generics (D1, Meta(..), Rep)

33import GHC.TypeLits

36import GHC.TypeLits

34import Network.HTTP.Media (MediaType)

37import Network.HTTP.Media (MediaType)

35import Servant.API

38import Servant.API

36import Servant.API.Description (FoldDescription,

39import Servant.API.Description (FoldDescription,

37 reflectDescription)

40 reflectDescription)

41+import Servant.API.Generic (ToServantApi, AsApi)

38import Servant.API.Modifiers (FoldRequired)

42import Servant.API.Modifiers (FoldRequired)

39

43

40import Servant.Swagger.Internal.TypeLevel.API

44import Servant.Swagger.Internal.TypeLevel.API

@@ -149,6 +153,10 @@ mkEndpointNoContentVerb path _ = mempty

149addParam :: Param -> Swagger -> Swagger

153addParam :: Param -> Swagger -> Swagger

150addParam param = allOperations.parameters %~ (Inline param :)

154addParam param = allOperations.parameters %~ (Inline param :)

151

155

156+-- | Add a tag to every operation in the spec.

157+addTag :: Text -> Swagger -> Swagger

158+addTag tag = allOperations.tags %~ ([tag] <>)

159+

152-- | Add accepted content types to every operation in the spec.

160-- | Add accepted content types to every operation in the spec.

153addConsumes :: [MediaType] -> Swagger -> Swagger

161addConsumes :: [MediaType] -> Swagger -> Swagger

154addConsumes cs = allOperations.consumes %~ (<> Just (MimeList cs))

162addConsumes cs = allOperations.consumes %~ (<> Just (MimeList cs))

@@ -439,6 +447,9 @@ instance (ToSchema a, Accept ct, HasSwagger sub, KnownSymbol (FoldDescription mo

439 & required ?~ True

447 & required ?~ True

440 & schema .~ ParamBody ref

448 & schema .~ ParamBody ref

441

449

450+instance (HasSwagger (ToServantApi routes), KnownSymbol datatypeName, Rep (routes AsApi) ~ D1 ('MetaData datatypeName moduleName packageName isNewtype) f) => HasSwagger (NamedRoutes routes) where

451+ toSwagger _ = addTag (Text.pack $ symbolVal (Proxy :: Proxy datatypeName)) (toSwagger (Proxy :: Proxy (ToServantApi routes)))

452+

442-- =======================================================================

453-- =======================================================================

443-- Below are the definitions that should be in Servant.API.ContentTypes

454-- Below are the definitions that should be in Servant.API.ContentTypes

444-- =======================================================================

455-- =======================================================================

servant-swagger/src/Servant/Swagger/Internal/Test.hs+8−6

@@ -29,10 +29,12 @@ import Servant.Swagger.Internal.TypeLevel

29-- >>> import Control.Applicative

30-- >>> import GHC.Generics

31-- >>> import Test.QuickCheck

32+-- >>> import System.Environment (setEnv)

32-- >>> :set -XDeriveGeneric

33-- >>> :set -XDeriveGeneric

33-- >>> :set -XGeneralizedNewtypeDeriving

34-- >>> :set -XGeneralizedNewtypeDeriving

34-- >>> :set -XDataKinds

35-- >>> :set -XDataKinds

35-- >>> :set -XTypeOperators

36-- >>> :set -XTypeOperators

37+-- >>> setEnv "HSPEC_COLOR" "no"

36

38

37-- | Verify that every type used with @'JSON'@ content type in a servant API

39-- | Verify that every type used with @'JSON'@ content type in a servant API

38-- has compatible @'ToJSON'@ and @'ToSchema'@ instances using @'validateToJSON'@.

40-- has compatible @'ToJSON'@ and @'ToSchema'@ instances using @'validateToJSON'@.

@@ -53,10 +55,10 @@ import Servant.Swagger.Internal.TypeLevel

53--

55--

54-- >>> hspec $ context "ToJSON matches ToSchema" $ validateEveryToJSON (Proxy :: Proxy UserAPI)

56-- >>> hspec $ context "ToJSON matches ToSchema" $ validateEveryToJSON (Proxy :: Proxy UserAPI)

55-- <BLANKLINE>

57-- <BLANKLINE>

56−-- ToJSON matches ToSchema

58+-- ToJSON matches ToSchema...

57−-- User

59+-- User...

58-- ...

60-- ...

59−-- UserId

61+-- UserId...

60-- ...

62-- ...

61-- Finished in ... seconds

63-- Finished in ... seconds

62-- 2 examples, 0 failures

64-- 2 examples, 0 failures

@@ -118,11 +120,11 @@ validateEveryToJSONWithPatternChecker checker _ = props

118-- :}

120-- :}

119-- <BLANKLINE>

121-- <BLANKLINE>

120-- read . show == id

122-- read . show == id

121−-- Bool

123+-- Bool...

122-- ...

124-- ...

123−-- Int

125+-- Int...

124-- ...

126-- ...

125−-- [Char]

127+-- [Char]...

126-- ...

128-- ...

127-- Finished in ... seconds

129-- Finished in ... seconds

128-- 3 examples, 0 failures

130-- 3 examples, 0 failures

servant/servant.cabal+6−6

@@ -80,13 +80,13 @@ library

80 --

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

82 build-depends:

83− base >= 4.9 && < 4.16

83+ base >= 4.9 && < 4.17

84 , bytestring >= 0.10.8.1 && < 0.12

85 , constraints >= 0.2

86 , mtl >= 2.2.2 && < 2.3

87 , sop-core >= 0.4.0.0 && < 0.6

88 , transformers >= 0.5.2.0 && < 0.6

89− , text >= 1.2.3.0 && < 1.3

89+ , text >= 1.2.3.0 && < 2.1

90

91

92 -- We depend (heavily) on the API of these packages:

@@ -98,7 +98,7 @@ library

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

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

100 build-depends:

101− base-compat >= 0.10.5 && < 0.12

101+ base-compat >= 0.10.5 && < 0.13

102 , aeson >= 1.4.1.0 && < 3

103 , attoparsec >= 0.13.2.2 && < 0.15

104 , bifunctors >= 5.5.3 && < 5.6

@@ -106,7 +106,7 @@ library

106 , deepseq >= 1.4.2.0 && < 1.5

107 , http-media >= 0.7.1.3 && < 0.9

108 , http-types >= 0.12.2 && < 0.13

109− , mmorph >= 1.1.2 && < 1.2

109+ , mmorph >= 1.1.2 && < 1.3

110 , network-uri >= 2.6.1.0 && < 2.7

111 , QuickCheck >= 2.12.6.1 && < 2.15

112 , string-conversions >= 0.4.0.1 && < 0.5

@@ -166,9 +166,9 @@ test-suite spec

166

167 -- Additional dependencies

168 build-depends:

169− hspec >= 2.6.0 && < 2.9

169+ hspec >= 2.6.0 && < 2.10

170 , QuickCheck >= 2.12.6.1 && < 2.15

171 , quickcheck-instances >= 0.3.19 && < 0.4

172

173 build-tool-depends:

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

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

servant/src/Servant/API.hs+4

@@ -38,6 +38,7 @@ module Servant.API (

38

39 -- * Sub-APIs defined as records of routes

40 module Servant.API.NamedRoutes,

41+ module Servant.API.Generic,

41

42

42 -- * Streaming endpoints, distinguished by HTTP method

43 -- * Streaming endpoints, distinguished by HTTP method

43 module Servant.API.Stream,

44 module Servant.API.Stream,

@@ -102,6 +103,9 @@ import Servant.API.Fragment

102 (Fragment)

103 (Fragment)

103import Servant.API.Header

104import Servant.API.Header

104 (Header, Header')

105 (Header, Header')

106+import Servant.API.Generic

107+ (GenericMode ((:-)), AsApi, ToServant, ToServantApi, GServantProduct,

108+ GenericServant, fromServant, toServant, genericApi)

105import Servant.API.HttpVersion

109import Servant.API.HttpVersion

106 (HttpVersion (..))

110 (HttpVersion (..))

107import Servant.API.IsSecure

111import Servant.API.IsSecure

servant/src/Servant/API/ContentTypes.hs+1−1

@@ -295,7 +295,7 @@ instance {-# OVERLAPPABLE #-}

295-- then this would be taken care of. However there is no more specific instance

296-- between that and 'MimeRender JSON a', so we do this instead

297instance {-# OVERLAPPING #-} ( Accept ctyp ) => AllMimeRender '[ctyp] NoContent where

298− allMimeRender _ _ = map (, "") $ NE.toList $ contentTypes pctyp

298+ allMimeRender _ NoContent = map (, "") $ NE.toList $ contentTypes pctyp

299 where

300 pctyp = Proxy :: Proxy ctyp

301

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

@@ -26,13 +26,13 @@ import Network.HTTP.Types.Method

26-- provided, but you are free to define your own:

27--

28-- >>> type Post204 contentTypes a = Verb 'POST 204 contentTypes a

29−data Verb (method :: StdMethod) (statusCode :: Nat) (contentTypes :: [*]) (a :: *)

29+data Verb (method :: k1) (statusCode :: Nat) (contentTypes :: [*]) (a :: *)

30 deriving (Typeable, Generic)

31

32-- | @NoContentVerb@ is a specific type to represent 'NoContent' responses.

33-- It does not require either a list of content types (because there's

34-- no content) or a status code (because it should always be 204).

35−data NoContentVerb (method :: StdMethod)

35+data NoContentVerb (method :: k1)

36 deriving (Typeable, Generic)

37

38-- * 200 responses

servant/test/Servant/API/ContentTypesSpec.hs+11

@@ -33,6 +33,8 @@ import Data.String.Conversions

33import qualified Data.Text as TextS

34import qualified Data.Text.Encoding as TextSE

35import qualified Data.Text.Lazy as TextL

36+import Control.Exception

37+ (evaluate)

36import GHC.Generics

38import GHC.Generics

37import Test.Hspec

39import Test.Hspec

38import Test.QuickCheck

40import Test.QuickCheck

@@ -78,6 +80,15 @@ spec = describe "Servant.API.ContentTypes" $ do

78 it "has mimeUnrender reverse mimeRender for valid top-level json " $ do

80 it "has mimeUnrender reverse mimeRender for valid top-level json " $ do

79 property $ \x -> mimeUnrender p (mimeRender p x) == Right (x::SomeData)

81 property $ \x -> mimeUnrender p (mimeRender p x) == Right (x::SomeData)

80

82

83+ describe "The NoContent Content-Type type" $ do

84+ let p = Proxy :: Proxy '[JSON]

85+

86+ it "does not render any content" $

87+ allMimeRender p NoContent `shouldSatisfy` (all (BSL8.null . snd))

88+

89+ it "evaluates the NoContent value" $

90+ evaluate (allMimeRender p (undefined :: NoContent)) `shouldThrow` anyErrorCall

91+

81 describe "The PlainText Content-Type type" $ do

92 describe "The PlainText Content-Type type" $ do

82 let p = Proxy :: Proxy PlainText

93 let p = Proxy :: Proxy PlainText

83

94