e598917..master · typeable/servant

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

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

1313 strategy:

1414 matrix:

1515 os: [ubuntu-latest]

16− cabal: ["3.4"]

16+ cabal: ["3.6"]

1717 ghc:

1818 - "8.6.5"

1919 - "8.8.4"

2020 - "8.10.7"

21− - "9.0.1"

21+ - "9.0.2"

22+ - "9.2.2"

2223

2324 steps:

2425 - uses: actions/checkout@v2

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

4748

4849 - name: Configure

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

5452

5553 - name: Build

5654 run: |

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

6159 cabal test all

6260

6361 - 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' }}

6762 run: |

6863 # Necessary for doctest to be found in $PATH

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

7065

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

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)

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

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

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

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

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

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

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

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

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

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

67+ (cd servant && eval $DOCTEST)

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

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

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

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

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

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

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

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

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

8977

9078 stack:

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

9280 runs-on: ubuntu-latest

9381 strategy:

9482 matrix:

95− stack: ["2.7.3"]

96− ghc: ["8.10.4"]

83+ stack: ["2.7.5"]

84+ ghc: ["8.10.7"]

9785

9886 steps:

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

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

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

8181getting 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

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

82+know about it! Either hop on

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

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

85+read it).

8486

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

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

cabal.project−26

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

5151tests: True

5252optimization: False

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

1010

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

1212help:

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

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

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

1616

doc/conf.py+1−2

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

4646

4747# General information about the project.

4848project = u'Servant'

49−copyright = u'2018, Servant Contributors'

49+copyright = u'2022, Servant Contributors'

5050author = u'Servant Contributors'

5151

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

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

169169source_parsers = {

170170 '.lhs': CommonMarkParser,

171171}

172−

doc/cookbook/curl-mock/curl-mock.cabal+3

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

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

1212

1313executable cookbock-curl-mock

14+ if impl(ghc >= 9.2)

15+ -- generic-arbitrary is incompatible

16+ buildable: False

1417 main-is: CurlMock.lhs

1518 build-depends: base == 4.*

1619 , aeson

doc/cookbook/index.rst+2−2

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

66interested in contributing examples of your own, feel free

77to open an issue or a pull request on

88`our github repository <https://github.com/haskell-servant/servant>`_

9−or even to just get in touch with us on the **#servant** IRC channel

10−on freenode or on

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

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

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

1212

1313The 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`

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

120120

121121```haskell

122− let req' = I.defaultMakeClientRequest burl req

122+ req' <- I.defaultMakeClientRequest burl req

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

124124```

125125

doc/links.rst+1−1

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

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

1313

1414- the irc channel:

15− ``#servant`` on freenode

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

1616

1717- the mailing list:

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

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

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

4242environment 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

6464 , blaze-markup >= 0.8.0.0 && < 0.9

6565 , cookie >= 0.4.3 && < 0.5

6666 , js-jquery >= 3.3.1 && < 3.4

67− , lucid >= 2.9.11 && < 2.10

67+ , lucid >= 2.9.11 && < 2.12

6868 , random >= 1.1 && < 1.3

6969 , servant-js >= 0.9 && < 0.10

7070 , time >= 1.6.0.1 && < 1.13

nix/nixpkgs.json+2−2

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

11{

2− "rev": "0f316e4d72daed659233817ffe52bf08e081b5de",

3− "sha256": "0vh0fk5is5s9l0lxpi16aabv2kk1fwklr7szy731kfcz9gdrr65l"

2+ "rev" : "05f0934825c2a0750d4888c4735f9420c906b388",

3+ "sha256" : "1g8c2w0661qn89ajp44znmwfmghbbiygvdzq0rzlvlpdiz28v6gy"

44}

nix/nixpkgs.nix+4−7

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

1−let nixpkgsSnapshot =

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

3−import (builtins.fetchTarball

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

5− sha256 = nixpkgsSnapshot.sha256;

6− })

7− {}

1+import (builtins.fetchTarball {

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

3+ sha256 = "sha256:1ckzhh24mgz6jd1xhfgx0i9mijk6xjqxwsshnvq789xsavrmsc36";

4+}) {}

nix/shell.nix+1−1

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

1−{ compiler ? "ghc901"

1+{ compiler ? "ghc8104"

22, tutorial ? false

33, pkgs ? import ./nixpkgs.nix

44}:

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

77 APIs that use

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

99 .

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

1111category: 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

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

1414author: Julian K. Arni

1515maintainer: jkarni@gmail.com

@@ -31,8 +31,8 @@ library

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

3232 ghc-options: -Wall

3333 build-depends:

34− base >= 4.10 && < 4.16

35− , bytestring >= 0.10.6.0 && < 0.11

34+ base >= 4.10 && < 4.17

35+ , bytestring >= 0.10.6.0 && < 0.12

3636 , containers >= 0.5.6.2 && < 0.7

3737 , servant-auth == 0.4.*

3838 , servant >= 0.13 && < 0.20

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

5050 test

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

5252 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

5454

5555 -- dependencies with bounds inherited from the library stanza

5656 build-depends:

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

6262

6363 -- test dependencies

6464 build-depends:

65− hspec >= 2.5.5 && < 2.9

65+ hspec >= 2.5.5 && < 2.10

6666 , QuickCheck >= 2.11.3 && < 2.15

6767 , aeson >= 1.3.1.1 && < 3

68− , bytestring >= 0.10.6.0 && < 0.11

68+ , bytestring >= 0.10.6.0 && < 0.12

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

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

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

77 APIs that use

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

99 .

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

1111category: 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

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

1414author: Julian K. Arni

1515maintainer: jkarni@gmail.com

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

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

3636 ghc-options: -Wall

3737 build-depends:

38− base >= 4.10 && < 4.16

38+ base >= 4.10 && < 4.17

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

4040 , servant >= 0.13 && < 0.20

4141 , servant-auth == 0.4.*

42− , lens >= 4.16.1 && <5.1

42+ , lens >= 4.16.1 && <5.2

4343 exposed-modules:

4444 Servant.Auth.Docs

4545 default-language: Haskell2010

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

6464 test

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

6666 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

6868

6969 -- dependencies with bounds inherited from the library stanza

7070 build-depends:

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

7878 -- test dependencies

7979 build-depends:

8080 servant-auth-docs

81− , hspec >= 2.5.5 && < 2.9

81+ , hspec >= 2.5.5 && < 2.10

8282 , QuickCheck >= 2.11.3 && < 2.15

8383

8484 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

77 .

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

99 .

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

1111category: 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

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

1414author: Julian K. Arni

1515maintainer: jkarni@gmail.com

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

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

3232 ghc-options: -Wall

3333 build-depends:

34− base >= 4.10 && < 4.16

34+ base >= 4.10 && < 4.17

3535 , aeson >= 1.0.0.1 && < 3

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

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

38− , bytestring >= 0.10.6.0 && < 0.11

38+ , bytestring >= 0.10.6.0 && < 0.12

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

4040 , cookie >= 0.4.4 && < 0.5

4141 , data-default-class >= 0.1.2.0 && < 0.2

4242 , entropy >= 0.4.1.3 && < 0.5

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

4444 , jose >= 0.7.0.0 && < 0.10

45− , lens >= 4.16.1 && < 5.1

46− , memory >= 0.14.16 && < 0.17

45+ , lens >= 4.16.1 && < 5.2

46+ , memory >= 0.14.16 && < 0.18

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

4848 , mtl >= 2.2.2 && < 2.3

4949 , servant >= 0.13 && < 0.20

5050 , servant-auth == 0.4.*

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

5252 , tagged >= 0.8.4 && < 0.9

53− , text >= 1.2.3.0 && < 1.3

54− , time >= 1.5.0.1 && < 1.10

53+ , text >= 1.2.3.0 && < 2.1

54+ , time >= 1.5.0.1 && < 1.12

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

5656 , wai >= 3.2.1.2 && < 3.3

5757

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

102102 test

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

104104 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

106106

107107 -- dependencies with bounds inherited from the library stanza

108108 build-depends:

@@ -123,10 +123,10 @@ test-suite spec

123123 -- test dependencies

124124 build-depends:

125125 servant-auth-server

126− , hspec >= 2.5.5 && < 2.8

126+ , hspec >= 2.5.5 && < 2.10

127127 , QuickCheck >= 2.11.3 && < 2.15

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

129− , lens-aeson >= 1.0.2 && < 1.2

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

130130 , warp >= 3.2.25 && < 3.4

131131 , wreq >= 0.5.2.1 && < 0.6

132132 other-modules:

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

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

1111import qualified Network.HTTP.Types as HTTP

1212import Network.Wai (mapResponseHeaders)

1313import Servant

14+import Servant.API.Generic

15+import Servant.Server.Generic

1416import Web.Cookie

1517

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

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

3436type family AddSetCookieApi a :: *

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

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

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

3740type instance AddSetCookieApi (Verb method stat ctyps a)

3841 = Verb method stat ctyps (AddSetCookieApiVerb a)

3942type instance AddSetCookieApi Raw = Raw

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

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

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

7477

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+

7587-- | for @servant <0.11@

7688instance

7789 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

3333 -- | Algorithm used to sign JWT.

3434 , jwtAlg :: Maybe Jose.Alg

3535 -- | Keys used to validate JWT.

36− , validationKeys :: Jose.JWKSet

36+ , validationKeys :: IO Jose.JWKSet

3737 -- | An @aud@ predicate. The @aud@ is a string or URI that identifies the

3838 -- intended recipient of the JWT.

3939 , audienceMatches :: Jose.StringOrURI -> IsMatch

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

4444defaultJWTSettings k = JWTSettings

4545 { signingKey = k

4646 , jwtAlg = Nothing

47− , validationKeys = Jose.JWKSet [k]

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

4848 , audienceMatches = const Matches }

4949

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

5858

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

6060verifyJWT jwtCfg input = do

61− verifiedJWT <- liftIO $ runExceptT $ do

61+ keys <- validationKeys jwtCfg

62+ verifiedJWT <- runExceptT $ do

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

6364 Jose.verifyClaims

6465 (jwtSettingsToJwtValidationSettings jwtCfg)

65− (validationKeys jwtCfg)

66+ keys

6667 unverifiedJWT

6768 return $ case verifiedJWT of

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

6970 Right v -> case decodeJWT v of

7071 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

88

99import Control.Monad.Error.Class

1010import 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

1215import Network.HTTP.Types

1316import Network.Wai

1417

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

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

2730 throwAll e = throwAll e :<|> throwAll e

2831

32+instance

33+ ( ThrowAll (ToServant api (AsServerT m)) , GenericServant api (AsServerT m)) =>

34+ ThrowAll (api (AsServerT m)) where

35+

36+ throwAll = fromServant . throwAll

37+

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

3039-- MonadError, no?

3140instance {-# 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,

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

5151import Servant hiding (BasicAuth,

5252 IsSecure (..), header)

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

5354import Servant.Auth.Server

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

5556import Servant.Auth.Server.SetCookieOrphan ()

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

405406 = Auth auths User :>

406407 ( Get '[JSON] Int

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

409+ :<|> NamedRoutes DummyRoutes

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

409411#if MIN_VERSION_servant_server(0,15,0)

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

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

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

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

418420

421+data DummyRoutes mode = DummyRoutes

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

423+ } deriving Generic

424+

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

420426jwtOnlyApi = Proxy

421427

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

476482 (\authResult -> case authResult of

477483 Authenticated usr -> getInt usr

478484 :<|> postInt usr

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

479486 :<|> getHeaderInt

480487#if MIN_VERSION_servant_server(0,15,0)

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

77 APIs that use

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

99 .

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

1111category: 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

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

1414author: Julian K. Arni

1515maintainer: jkarni@gmail.com

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

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

3232 ghc-options: -Wall

3333 build-depends:

34− base >= 4.10 && < 4.16

35− , text >= 1.2.3.0 && < 1.3

34+ base >= 4.10 && < 4.17

35+ , text >= 1.2.3.0 && < 2.1

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

3737 , swagger2 >= 2.2.2 && < 3

3838 , servant >= 0.13 && < 0.20

3939 , servant-auth == 0.4.*

40− , lens >= 4.16.1 && < 5.1

41− if impl(ghc >= 9)

42− buildable: False

40+ , lens >= 4.16.1 && < 5.2

4341 exposed-modules:

4442 Servant.Auth.Swagger

4543 default-language: Haskell2010

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

5149 test

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

5351 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

5553 -- dependencies with bounds inherited from the library stanza

5654 build-depends:

5755 base

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

6159 , servant

6260 , servant-auth

6361 , lens

64− if impl(ghc >= 9)

65− buildable: False

66−

62+

6763 -- test dependencies

6864 build-depends:

6965 servant-auth-swagger

70− , hspec >= 2.5.5 && < 2.9

66+ , hspec >= 2.5.5 && < 2.10

7167 , QuickCheck >= 2.11.3 && < 2.15

7268 other-modules:

7369 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

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

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

1111 .

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

1313category: 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

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

1616author: Julian K. Arni

1717maintainer: jkarni@gmail.com

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

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

3434 ghc-options: -Wall

3535 build-depends:

36− base >= 4.10 && < 4.16

36+ base >= 4.10 && < 4.17

3737 , containers >= 0.6 && < 0.7

3838 , aeson >= 1.3.1.1 && < 3

3939 , jose >= 0.7.0.0 && < 0.10

40− , lens >= 4.16.1 && < 5.1

40+ , lens >= 4.16.1 && < 5.2

4141 , servant >= 0.15 && < 0.20

42− , text >= 1.2.3.0 && < 1.3

42+ , text >= 1.2.3.0 && < 2.1

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

4444 exposed-modules:

4545 Servant.Auth

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

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

5050 --

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

5252 build-depends:

53− base >= 4.9 && < 4.16

53+ base >= 4.9 && < 4.17

5454 , bytestring >= 0.10.8.1 && < 0.12

5555 , constraints >= 0.2 && < 0.14

5656 , containers >= 0.5.7.1 && < 0.7

5757 , deepseq >= 1.4.2.0 && < 1.5

58− , text >= 1.2.3.0 && < 1.3

58+ , text >= 1.2.3.0 && < 2.1

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

6161

6262 if !impl(ghc >= 8.2)

6363 build-depends:

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

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

7272 build-depends:

7373 aeson >= 1.4.1.0 && < 3

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

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

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

7676 , exceptions >= 0.10.0 && < 0.11

7777 , free >= 5.1 && < 5.2

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

104104 -- Additional dependencies

105105 build-depends:

106106 deepseq >= 1.4.2.0 && < 1.5

107− , hspec >= 2.6.0 && < 2.9

107+ , hspec >= 2.6.0 && < 2.10

108108 , QuickCheck >= 2.12.6.1 && < 2.15

109109

110110 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

5959 , appendToPath

6060 , setRequestBodyLBS

6161 , setRequestBody

62+ , encodeQueryParamValue

6263 ) where

6364import Servant.Client.Core.Auth

6465import Servant.Client.Core.BaseUrl

servant-client-core/src/Servant/Client/Core/HasClient.hs+10−15

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

3333import Control.Monad

3434 (unless)

3535import 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

3937import Data.Either

4038 (partitionEithers)

4139import Data.Constraint (Dict(..))

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

210208 clientWithRoute pm (Proxy :: Proxy api)

211209 (appendToPath p req)

212210

213− where p = (toUrlPiece val)

211+ where p = toEncodedUrlPiece val

214212

215213 hoistClientMonad pm _ f cl = \a ->

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

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

245243 clientWithRoute pm (Proxy :: Proxy sublayout)

246244 (foldl' (flip appendToPath) req ps)

247245

248− where ps = map (toUrlPiece) vals

246+ where ps = map toEncodedUrlPiece vals

249247

250248 hoistClientMonad pm _ f cl = \as ->

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

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

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

572570 where

573571 add :: a -> Request

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

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

575573

576574 pname :: Text

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

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

579577 hoistClientMonad pm _ f cl = \arg ->

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

581579

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

583−encodeQueryParam = BL.toStrict . toLazyByteString . toEncodedUrlPiece

584−

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

586581-- the corresponding querying function will automatically take

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

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

623618 )

624619

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

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

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

627622

628623 hoistClientMonad pm _ f cl = \as ->

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

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

745740 clientWithRoute pm (Proxy :: Proxy api)

746741 (appendToPath p req)

747742

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

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

749744

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

751746

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

879874--

880875-- Example:

881876--

882−-- @@

877+-- @

883878-- type Api = NamedRoutes RootApi

884879--

885880-- data RootApi mode = RootApi

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

900895--

901896-- endpointClient :: ClientM Person

902897-- endpointClient = client // subApi // endpoint

903−-- @@

898+-- @

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

905900x // f = f x

906901

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

911906--

912907-- Example:

913908--

914−-- @@

909+-- @

915910-- type Api = NamedRoutes RootApi

916911--

917912-- data RootApi mode = RootApi

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

936931--

937932-- endpointClient :: ClientM Person

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

939−-- @@

934+-- @

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

941936(/:) = flip

942937

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

@@ -17,6 +17,7 @@ module Servant.Client.Core.Request (

1717 addHeader,

1818 appendToPath,

1919 appendToQueryString,

20+ encodeQueryParamValue,

2021 setRequestBody,

2122 setRequestBodyLBS,

2223 ) where

@@ -33,6 +34,8 @@ import Data.Bifunctor

3334import Data.Bitraversable

3435 (Bitraversable (..), bifoldMapDefault, bimapDefault)

3536import qualified Data.ByteString as BS

37+import Data.ByteString.Builder

38+ (Builder)

3639import qualified Data.ByteString.Builder as Builder

3740import qualified Data.ByteString.Lazy as LBS

3841import qualified Data.Sequence as Seq

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

4851 (MediaType)

4952import Network.HTTP.Types

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

51− http11, methodGet)

54+ http11, methodGet, urlEncodeBuilder)

5255import Servant.API

53− (ToHttpApiData, toEncodedUrlPiece, toHeader, SourceIO)

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

5457

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

5659

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

111114 rnfB Nothing = ()

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

113116

114−type Request = RequestF RequestBody Builder.Builder

117+type Request = RequestF RequestBody Builder

115118

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

117120data RequestBody

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

142145 , requestMethod = methodGet

143146 }

144147

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

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

149+--

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

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

146152appendToPath p req

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

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

148154

149−appendToQueryString :: Text -- ^ param name

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

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

156+--

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

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

151159 -> Request

152160 -> Request

153161appendToQueryString pname pvalue req

154162 = req { requestQueryString = requestQueryString req

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

156164

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

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

158174addHeader name val req

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

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

@@ -38,7 +38,7 @@ library

3838 Servant.Client.Internal.XhrClient

3939

4040 build-depends:

41− base >=4.11 && <4.12

41+ base >=4.11 && <5

4242 , bytestring >=0.10 && <0.12

4343 , case-insensitive >=1.2.0.0 && <1.3.0.0

4444 , containers >=0.5 && <0.7

servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs+8−5

@@ -120,7 +120,7 @@ instance Exception StreamingNotSupportedException where

120120 displayException _ = "streamingRequest: streaming is not supported!"

121121

122122instance RunClient ClientM where

123− runRequest = performRequest

123+ runRequestAcceptStatus = performRequest

124124 throwClientError = throwError

125125

126126runClientMOrigin :: ClientM a -> ClientEnv -> IO (Either ClientError a)

@@ -152,15 +152,18 @@ runClientM m = do

152152

153153 runClientMOrigin m (ClientEnv (BaseUrl protocol hostname port ""))

154154

155−performRequest :: Request -> ClientM Response

156−performRequest req = do

155+performRequest :: Maybe [Status] -> Request -> ClientM Response

156+performRequest acceptStatus req = do

157157 xhr <- liftIO initXhr

158158 burl <- asks baseUrl

159159 liftIO $ performXhr xhr burl req

160160 resp <- toResponse xhr

161161

162− let status = statusCode (responseStatusCode resp)

163− unless (status >= 200 && status < 300) $ do

162+ let status = responseStatusCode resp

163+ goodStatus = case acceptStatus of

164+ Nothing -> statusIsSuccessful status

165+ Just good -> status `elem` good

166+ unless goodStatus $ do

164167 let f b = (burl, BL.toStrict $ toLazyByteString b)

165168 throwError $ FailureResponse (bimap (const ()) f req) resp

166169

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

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

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

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

4343 build-depends:

44− base >= 4.9 && < 4.16

44+ base >= 4.9 && < 4.17

4545 , bytestring >= 0.10.8.1 && < 0.12

4646 , containers >= 0.5.7.1 && < 0.7

4747 , deepseq >= 1.4.2.0 && < 1.5

4848 , mtl >= 2.2.2 && < 2.3

4949 , stm >= 2.4.5.1 && < 2.6

50− , text >= 1.2.3.0 && < 1.3

51− , time >= 1.6.0.1 && < 1.10

50+ , text >= 1.2.3.0 && < 2.1

51+ , time >= 1.6.0.1 && < 1.12

5252 , transformers >= 0.5.2.0 && < 0.6

5353

5454 if !impl(ghc >= 8.2)

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

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

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

6666 build-depends:

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

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

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

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

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

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

124124 -- Additional dependencies

125125 build-depends:

126126 entropy >= 0.4.1.3 && < 0.5

127− , hspec >= 2.6.0 && < 2.9

127+ , hspec >= 2.6.0 && < 2.10

128128 , HUnit >= 1.6.0.0 && < 1.7

129129 , network >= 2.8.0.0 && < 3.2

130130 , QuickCheck >= 2.12.6.1 && < 2.15

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

133133 , tdigest >= 0.2 && < 0.3

134134

135135 build-tool-depends:

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

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

137137

138138test-suite readme

139139 type: exitcode-stdio-1.0

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

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

2424import Control.Monad.Base

2525 (MonadBase (..))

2626import Control.Monad.Catch

27− (MonadCatch, MonadThrow)

27+ (MonadCatch, MonadThrow, MonadMask)

2828import Control.Monad.Error.Class

2929 (MonadError (..))

3030import Control.Monad.IO.Class

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

8080 { manager :: Client.Manager

8181 , baseUrl :: BaseUrl

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

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

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

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

8585 -- Note that:

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

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

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

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

138138 , MonadReader ClientEnv, MonadError ClientError, MonadThrow

139− , MonadCatch)

139+ , MonadCatch, MonadMask)

140140

141141instance MonadBase IO ClientM where

142142 liftBase = ClientM . liftBase

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

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

163163performRequest acceptStatus req = do

164164 ClientEnv m burl cookieJar' createClientRequest <- ask

165− let clientRequest = createClientRequest burl req

165+ clientRequest <- liftIO $ createClientRequest burl req

166166 request <- case cookieJar' of

167167 Nothing -> pure clientRequest

168168 Just cj -> liftIO $ do

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

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

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

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

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

233−defaultMakeClientRequest burl r = Client.defaultRequest

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

233+defaultMakeClientRequest burl r = return Client.defaultRequest

234234 { Client.method = requestMethod r

235235 , Client.host = fromString $ baseUrlHost burl

236236 , Client.port = baseUrlPort burl

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

246246 where

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

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

249− toList $requestHeaders r

249+ toList $ requestHeaders r

250250

251251 acceptHdr

252252 | null hs = Nothing

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

289289 Https -> True

290290

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

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

292+ buildQueryString [] = mempty

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

293294

294295 addQueryParam qs (k, v) =

295296 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

140140performRequest acceptStatus req = do

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

142142 ClientEnv m burl cookieJar' createClientRequest <- ask

143− let clientRequest = createClientRequest burl req

143+ clientRequest <- liftIO $ createClientRequest burl req

144144 request <- case cookieJar' of

145145 Nothing -> pure clientRequest

146146 Just cj -> liftIO $ do

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

177177 m <- asks manager

178178 burl <- asks baseUrl

179179 createClientRequest <- asks makeClientRequest

180− let request = createClientRequest burl req

180+ request <- liftIO $ createClientRequest burl req

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

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

183183 let status = Client.responseStatus res

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

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

160160 WithStatus 301 Text]

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

162162 :<|> NamedRoutes RecordRoutes

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

163164

164165api :: Proxy Api

165166api = Proxy

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

214215 :<|> EmptyClient

215216 :<|> uverbGetSuccessOrRedirect

216217 :<|> uverbGetCreated

217− :<|> recordRoutes = client api

218+ :<|> recordRoutes

219+ :<|> captureVerbatim = client api

218220

219221server :: Application

220222server = serve api (

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

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

260262 }

261263 }

264+ :<|> pure . decodeUtf8 . unVerbatim

262265 )

263266

264267-- * api for testing failures

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

370373

371374instance FromHttpApiData UrlEncodedByteString where

372375 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

3636import Data.Monoid ()

3737import Data.Text

3838 (Text)

39+import Data.Text.Encoding

40+ (encodeUtf8)

3941import qualified Network.HTTP.Client as C

4042import qualified Network.HTTP.Types as HTTP

4143import Test.Hspec

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

160162 mgr <- C.newManager C.defaultManagerSettings

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

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

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

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

166169 case res of

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

196199 case eitherResponse of

197200 Left clientError -> fail $ show clientError

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

2323

2424source-repository head

2525 type: git

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

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

2727

2828library

2929 exposed-modules: Servant.Conduit

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

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

4141 --

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

4343 build-depends:

44− base >= 4.9 && < 4.16

44+ base >= 4.9 && < 4.17

4545 , bytestring >= 0.10.8.1 && < 0.12

46− , text >= 1.2.3.0 && < 1.3

46+ , text >= 1.2.3.0 && < 2.1

4747

4848 -- Servant dependencies

4949 build-depends:

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

5454 build-depends:

5555 aeson >= 1.4.1.0 && < 3

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

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

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

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

59− , hashable >= 1.2.7.0 && < 1.4

59+ , hashable >= 1.2.7.0 && < 1.5

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

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

62− , lens >= 4.17 && < 5.1

62+ , lens >= 4.17 && < 5.2

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

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

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

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

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

6262import Servant.API

6363import Servant.API.ContentTypes

6464import Servant.API.TypeLevel

65+import Servant.API.Generic

6566

6667import qualified Data.Universe.Helpers as U

6768

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

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

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

11521153

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

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

1156+

11531157-- ToSample instances for simple types

11541158instance ToSample NoContent

11551159instance ToSample Bool

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

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

4141 --

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

4343 build-depends:

44− base >= 4.9 && < 4.16

45− , text >= 1.2.3.0 && < 1.3

44+ base >= 4.9 && < 4.17

45+ , text >= 1.2.3.0 && < 2.1

4646

4747 -- Servant dependencies

4848 build-depends:

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

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

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

5353 build-depends:

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

55− , lens >= 4.17 && < 5.1

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

55+ , lens >= 4.17 && < 5.2

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

5757

5858 hs-source-dirs: src

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

7474

7575 -- Additional dependencies

7676 build-depends:

77− hspec >= 2.6.0 && <2.9

77+ hspec >= 2.6.0 && <2.10

7878 build-tool-depends:

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

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

8080 default-language: Haskell2010

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

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

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

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

4040 build-depends:

41− base >= 4.9 && < 4.16

41+ base >= 4.9 && < 4.17

4242 , bytestring >= 0.10.8.1 && < 0.12

4343 , containers >= 0.5.7.1 && < 0.7

4444 , deepseq >= 1.4.2.0 && < 1.5

4545 , mtl >= 2.2.2 && < 2.3

46− , text >= 1.2.3.0 && < 1.3

47− , time >= 1.6.0.1 && < 1.10

46+ , text >= 1.2.3.0 && < 2.1

47+ , time >= 1.6.0.1 && < 1.12

4848 , transformers >= 0.5.2.0 && < 0.6

4949

5050 if !impl(ghc >= 8.2)

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

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

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

6262 build-depends:

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

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

6464 , case-insensitive

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

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

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

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

7070 , exceptions >= 0.10.0 && < 0.11

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

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

7373 , semigroupoids >= 5.3.1 && < 5.4

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

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

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

7676

7777 hs-source-dirs: src

7878 default-language: Haskell2010

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

112112 -- Additional dependencies

113113 build-depends:

114114 entropy >= 0.4.1.3 && < 0.5

115− , hspec >= 2.6.0 && < 2.9

115+ , hspec >= 2.6.0 && < 2.10

116116 , HUnit >= 1.6.0.0 && < 1.7

117117 , network >= 2.8.0.0 && < 3.2

118118 , QuickCheck >= 2.12.6.1 && < 2.15

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

121121 , tdigest >= 0.2 && < 0.3

122122

123123 build-tool-depends:

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

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

125125

126126test-suite readme

127127 type: exitcode-stdio-1.0

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

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

2323

2424source-repository head

2525 type: git

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

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

2727

2828library

2929 exposed-modules: Servant.Machines

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

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

2323

2424source-repository head

2525 type: git

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

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

2727

2828library

2929 exposed-modules: Servant.Pipes

servant-server/CHANGELOG.md+6

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

33

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

55

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+

6120.19

713----

814

servant-server/example/greet.hs−1

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

1818

1919import Servant

2020import Servant.Server.Generic ()

21−import Servant.API.Generic

2221

2322-- * Example

2423

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

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

11cabal-version: 2.2

22name: servant-server

3−version: 0.19

3+version: 0.19.1

44

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

66category: Servant, Web

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

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

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

6262 build-depends:

63− base >= 4.9 && < 4.16

63+ base >= 4.9 && < 4.17

6464 , bytestring >= 0.10.8.1 && < 0.12

6565 , constraints >= 0.2 && < 0.14

6666 , containers >= 0.5.7.1 && < 0.7

6767 , mtl >= 2.2.2 && < 2.3

68− , text >= 1.2.3.0 && < 1.3

68+ , text >= 1.2.3.0 && < 2.1

6969 , transformers >= 0.5.2.0 && < 0.6

7070 , filepath >= 1.4.1.1 && < 1.5

7171

7272 -- Servant dependencies

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

7474 build-depends:

75− servant >= 0.19

75+ servant >= 0.19 && < 0.20

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

7777

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

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

8080 build-depends:

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

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

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

8383 , exceptions >= 0.10.0 && < 0.11

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

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

159159 build-depends:

160160 aeson >= 1.4.1.0 && < 3

161161 , directory >= 1.3.0.0 && < 1.4

162− , hspec >= 2.6.0 && < 2.9

162+ , hspec >= 2.6.0 && < 2.10

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

164164 , QuickCheck >= 2.12.6.1 && < 2.15

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

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

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

168168

169169 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 '[])

235235-- > │ └─ e/

236236-- > │ └─•

237237-- > ├─ b/

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

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

239239-- > │ ├─•

240240-- > │ ┆

241241-- > │ └─•

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

252252--

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

254254--

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

256257--

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

258259--

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

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

3131 , module Servant.Server.Internal.ServerError

3232 ) where

3333

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−

4034import Control.Monad

4135 (join, when)

4236import Control.Monad.Trans

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

4741import qualified Data.ByteString.Builder as BB

4842import qualified Data.ByteString.Char8 as BC8

4943import qualified Data.ByteString.Lazy as BL

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

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

5145import Data.Either

5246 (partitionEithers)

5347import Data.Maybe

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

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

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

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

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

86−

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

79+ WithNamedContext, NamedRoutes)

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

8981import Servant.API.ContentTypes

9082 (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),

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

9688import Servant.API.ResponseHeaders

9789 (GetHeaders, Headers, getHeaders, getResponse)

9890import Servant.API.Status

99− (statusFromNat, KnownStatus)

91+ (statusFromNat)

10092import qualified Servant.Types.SourceT as S

10193import Servant.API.TypeErrors

10294import Web.HttpApiData

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

181173-- > server = getBook

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

183175-- > getBook isbn = ...

184−instance (KnownSymbol capture, FromHttpApiData a

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

185177 , HasServer api context, SBoolI (FoldLenient mods)

186178 , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters

187179 )

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

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

194186

195187 route Proxy context d =

196− CaptureRouter $

188+ CaptureRouter [hint] $

197189 route (Proxy :: Proxy api)

198190 context

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

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

205197 where

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

207199 formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)

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

208201

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

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

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

223216-- > server = getSourceFile

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

225218-- > getSourceFile pathSegments = ...

226−instance (KnownSymbol capture, FromHttpApiData a

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

227220 , HasServer api context

228221 , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters

229222 )

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

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

236229

237230 route Proxy context d =

238− CaptureAllRouter $

231+ CaptureAllRouter [hint] $

239232 route (Proxy :: Proxy api)

240233 context

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

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

246239 where

247240 rep = typeRep (Proxy :: Proxy CaptureAll)

248241 formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)

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

249243

250244allowedMethodHead :: Method -> Request -> Bool

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

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

300294 env request respond $ \ _output ->

301295 Route $ responseLBS status [] ""

302296

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

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

305−-- ) => 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)

297+instance {-# OVERLAPPABLE #-}

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

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

313300

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

318303

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

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

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

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

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

321307

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

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

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

308+instance {-# OVERLAPPING #-}

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

310+ , GetHeaders (Headers h a)

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

325312

326−instance

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

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

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

314+ hoistServerWithContext _ _ nt s = nt s

329315

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

331− route = undefined

332− hoistServerWithContext p1 p2 nat s = undefined

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

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

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

333319

334320instance (ReflectMethod method) =>

335321 HasServer (NoContentVerb method) context where

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

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

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

839825 where

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

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

841827 route = error "unreachable"

842828 hoistServerWithContext _ _ _ _ = error "unreachable"

843829

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

973959 toServant server

974960 servantSrvN :: ServerT (ToServantApi api) n =

975961 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

1313import Control.Monad.Catch

1414 (MonadCatch, MonadMask, MonadThrow)

1515import Control.Monad.Error.Class

16− (MonadError)

16+ (MonadError, throwError)

1717import Control.Monad.IO.Class

1818 (MonadIO)

1919import Control.Monad.Trans.Control

2020 (MonadBaseControl (..))

2121import Control.Monad.Trans.Except

2222 (ExceptT, runExceptT)

23+import Data.String

24+ (fromString)

2325import GHC.Generics

2426 (Generic)

2527import Servant.Server.Internal.ServerError

26− (ServerError)

28+ (ServerError, errBody, err500)

2729

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

2931 deriving

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

3234 , MonadThrow, MonadCatch, MonadMask

3335 )

3436

37+instance MonadFail Handler where

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

39+

3540instance MonadBase IO Handler where

3641 liftBase = Handler . liftBase

3742

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

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

99

1010import Data.Function

1111 (on)

12+import Data.List

13+ (nub)

1214import Data.Map

1315 (Map)

1416import qualified Data.Map as M

1517import Data.Text

1618 (Text)

1719import qualified Data.Text as T

20+import Data.Typeable

21+ (TypeRep)

1822import Network.Wai

1923 (Response, pathInfo)

2024import Servant.Server.Internal.ErrorFormatter

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

2428

2529type Router env = Router' env RoutingApplication

2630

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+

2743-- | Internal representation of a router.

2844--

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

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

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

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

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

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

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

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

4157 -- environment and removed afterwards

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

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

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

4460 -- environment and are removed afterwards

4561 | RawRouter (env -> a)

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

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

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

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

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

73− CaptureRouter (choice router1 router2)

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

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

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

7591choice router1 router2 = Choice router1 router2

7692

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

84100--

85101data RouterStructure =

86102 StaticRouterStructure (Map Text RouterStructure) Int

87− | CaptureRouterStructure RouterStructure

103+ | CaptureRouterStructure [CaptureHint] RouterStructure

88104 | RawRouterStructure

89105 | ChoiceStructure RouterStructure RouterStructure

90106 deriving (Eq, Show)

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

98114routerStructure :: Router' env a -> RouterStructure

99115routerStructure (StaticRouter m ls) =

100116 StaticRouterStructure (fmap routerStructure m) (length ls)

101−routerStructure (CaptureRouter router) =

102− CaptureRouterStructure $

117+routerStructure (CaptureRouter hints router) =

118+ CaptureRouterStructure hints $

103119 routerStructure router

104−routerStructure (CaptureAllRouter router) =

105− CaptureRouterStructure $

120+routerStructure (CaptureAllRouter hints router) =

121+ CaptureRouterStructure hints $

106122 routerStructure router

107123routerStructure (RawRouter _) =

108124 RawRouterStructure

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

114130-- | Compare the structure of two routers.

115131--

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

117−sameStructure r1 r2 =

118− routerStructure r1 == routerStructure r2

133+sameStructure router1 router2 =

134+ routerStructure router1 == routerStructure router2

119135

120136-- | Provide a textual representation of the

121137-- structure of a router.

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

126142 where

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

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

130147 mkRouterLayout c RawRouterStructure =

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

132149 mkRouterLayout c (ChoiceStructure r1 r2) =

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

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

170187 in runRouterEnv fmt router' env request' respond

171188 _ -> respond $ Fail $ fmt request

172− CaptureRouter router' ->

189+ CaptureRouter _ router' ->

173190 case pathInfo request of

174191 [] -> respond $ Fail $ fmt request

175192 -- This case is to handle trailing slashes.

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

177194 first : rest

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

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

180− CaptureAllRouter router' ->

197+ CaptureAllRouter _ router' ->

181198 let segments = pathInfo request

182199 request' = request { pathInfo = [] }

183200 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

2222 )

2323where

2424

25−-- import qualified Data.ByteString as B

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

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

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

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

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

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

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

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

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

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

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

25+import qualified Data.ByteString as B

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

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

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

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

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

31+import Network.Wai (responseLBS, Request)

32+import Servant.API (ReflectMethod, reflectMethod)

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

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

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

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

3737

3838

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

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

41−-- respond ::

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

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

44−-- x ->

45−-- f (Union xs)

46−-- respond = pure . inject . I

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

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

41+respond ::

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

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

44+ x ->

45+ f (Union xs)

46+respond = pure . inject . I

4747

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

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

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

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

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

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

5151

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

53−-- => IsServerResource cts a where

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

55−-- resourceHeaders _ _ = []

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

53+ => IsServerResource cts a where

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

55+ resourceHeaders _ _ = []

5656

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

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

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

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

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

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

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

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

6161

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

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

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

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

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

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

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

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

6666

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

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

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

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

71−-- resourceResponse request cts res,

72−-- resourceHeaders cts res)

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

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

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

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

71+ resourceResponse request cts res,

72+ resourceHeaders cts res)

7373

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

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

7575

76−-- instance

77−-- ( ReflectMethod method,

78−-- AllMime contentTypes,

79−-- All (IsServerResourceWithStatus contentTypes) as,

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

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

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

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

84−-- -- corner cases.

85−-- ) =>

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

87−-- where

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

76+instance

77+ ( ReflectMethod method,

78+ AllMime contentTypes,

79+ All (IsServerResourceWithStatus contentTypes) as,

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

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

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

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

84+ -- corner cases.

85+ ) =>

86+ HasServer (UVerb method contentTypes as) context

87+ where

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

8989

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

90+ hoistServerWithContext _ _ nt s = nt s

9191

92−-- route ::

93−-- forall env.

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

95−-- Context context ->

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

97−-- Router env

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

99−-- where

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

101−-- route' env request cont = do

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

103−-- action' =

104−-- action

105−-- `addMethodCheck` methodCheck method request

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

92+ route ::

93+ forall env.

94+ Proxy (UVerb method contentTypes as) ->

95+ Context context ->

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

97+ Router env

98+ route _proxy _ctx action = leafRouter route'

99+ where

100+ method = reflectMethod (Proxy @method)

101+ route' env request cont = do

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

103+ action' =

104+ action

105+ `addMethodCheck` methodCheck method request

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

107107

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

109−-- let cts = Proxy @contentTypes

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

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

112−-- case pickResource output of

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

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

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

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

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

109+ let cts = Proxy @contentTypes

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

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

112+ case pickResource output of

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

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

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

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

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

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

99import Data.Proxy

1010 (Proxy (..))

1111import Data.Text

12− (unpack)

12+ (Text, unpack)

13+import Data.Typeable

14+ (typeRep)

1315import Network.HTTP.Types

1416 (Status (..))

1517import Network.Wai

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

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

2830 routerSpec

2931 distributivitySpec

32+ serverLayoutSpec

3033

3134routerSpec :: Spec

3235routerSpec = do

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

5154 toApp = toApplication . runRouter (const err404)

5255

5356 cap :: Router ()

54− cap = CaptureRouter $

57+ cap = CaptureRouter [hint] $

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

5659 in leafRouter

5760 $ \env req res ->

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

5962 . const

6063 $ Route success

6164

65+ hint :: CaptureHint

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

67+

6268 router :: Router ()

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

6470 `Choice` cap

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

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

99105 level `shouldHaveSameStructureAs` levelRef

100106

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+

101119shouldHaveSameStructureAs ::

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

103121shouldHaveSameStructureAs p1 p2 =

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

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

106124

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+

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

108132makeTrivialRouter p =

109133 route p EmptyContext (emptyDelayed (FailFatal err501))

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

144168-- structure:

145169

146170type Dynamic =

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

148− :<|> "a" :> Capture "bar" Bool :> "c" :> End

149− :<|> "a" :> Capture "baz" Char :> "d" :> End

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

172+ :<|> "a" :> Capture "foo" Int :> "c" :> End

173+ :<|> "a" :> Capture "foo" Int :> "d" :> End

150174

151175type DynamicRef =

152− "a" :> Capture "anything" () :>

176+ "a" :> Capture "foo" Int :>

153177 ("b" :> End :<|> "c" :> End :<|> "d" :> End)

154178

155179dynamic :: Proxy Dynamic

@@ -339,3 +363,100 @@ level = Proxy

339363

340364levelRef :: Proxy LevelRef

341365levelRef = 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

33version: 1.1.11

44synopsis: Generate a Swagger/OpenAPI/OAS 2.0 specification for your servant API.

55description:

6− Swagger is a project used to describe and document RESTful APIs. The core of the

7− project is the [OpenAPI Specification (OAS)](https://swagger.io/docs/specification/about/).

8− This library implements v2.0 of the spec. Unlike Servant it is language-agnostic and thus is

9− quite popular among developers in different languages. It has also existed for a longer time

6+ Swagger is a project used to describe and document RESTful APIs. The core of the

7+ project is the [OpenAPI Specification (OAS)](https://swagger.io/docs/specification/about/).

8+ This library implements v2.0 of the spec. Unlike Servant it is language-agnostic and thus is

9+ quite popular among developers in different languages. It has also existed for a longer time

1010 and has more helpful tooling.

1111 .

1212 This package provides means to generate a Swagger/OAS specification for a Servant API

@@ -19,7 +19,7 @@ description:

1919 * generating clients and servers in many languages using [Swagger Codegen](http://swagger.io/swagger-codegen/);

2020 .

2121 * 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

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

2424license: BSD-3-Clause

2525license-file: LICENSE

@@ -50,7 +50,7 @@ source-repository head

5050custom-setup

5151 setup-depends:

5252 base >=4.9 && <5,

53− Cabal >= 1.24 && < 3.5,

53+ Cabal >= 1.24,

5454 cabal-doctest >=1.0.6 && <1.1

5555

5656library

@@ -72,15 +72,15 @@ library

7272 build-depends: aeson >=1.4.2.0 && <3

7373 , aeson-pretty >=0.8.7 && <0.9

7474 , base >=4.9.1.0 && <5

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

76− , bytestring >=0.10.8.1 && <0.11

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

76+ , bytestring >=0.10.8.1 && <0.12

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

7878 , insert-ordered-containers >=0.2.1.0 && <0.3

7979 , lens >=4.17 && <6

80− , servant >=0.18.1 && <0.20

80+ , servant >=0.18.2 && <0.20

8181 , singleton-bool >=0.1.4 && <0.2

8282 , swagger2 >=2.3.0.1 && <3

83− , text >=1.2.3.0 && <1.3

83+ , text >=1.2.3.0 && <2.1

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

8585

8686 , hspec

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

9292 build-depends:

9393 base,

9494 directory >= 1.0,

95− doctest >= 0.17 && <0.19,

95+ doctest >= 0.17 && <0.21,

9696 servant,

9797 QuickCheck,

9898 filepath

@@ -106,14 +106,14 @@ test-suite spec

106106 type: exitcode-stdio-1.0

107107 hs-source-dirs: test

108108 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

110110 build-depends: base

111111 , base-compat

112112 , aeson >=1.4.2.0 && <3

113− , hspec >=2.6.0 && <2.8

113+ , hspec >=2.6.0 && <2.10

114114 , QuickCheck

115115 , lens

116− , lens-aeson >=1.0.2 && <1.2

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

117117 , servant

118118 , servant-swagger

119119 , swagger2

servant-swagger/src/Servant/Swagger.hs+5−3

@@ -55,6 +55,7 @@ import Servant.Swagger.Internal.Orphans ()

5555-- >>> import Data.Typeable

5656-- >>> import GHC.Generics

5757-- >>> import Servant.API

58+-- >>> import System.Environment

5859-- >>> import Test.Hspec

5960-- >>> import Test.QuickCheck

6061-- >>> import qualified Data.ByteString.Lazy.Char8 as BSL8

@@ -64,6 +65,7 @@ import Servant.Swagger.Internal.Orphans ()

6465-- >>> :set -XGeneralizedNewtypeDeriving

6566-- >>> :set -XOverloadedStrings

6667-- >>> :set -XTypeOperators

68+-- >>> setEnv "HSPEC_COLOR" "no"

6769-- >>> data User = User { name :: String, age :: Int } deriving (Show, Generic, Typeable)

6870-- >>> newtype UserId = UserId Integer deriving (Show, Generic, Typeable, ToJSON)

6971-- >>> instance ToJSON User

@@ -160,11 +162,11 @@ import Servant.Swagger.Internal.Orphans ()

160162-- >>> instance Arbitrary UserId where arbitrary = UserId <$> arbitrary

161163-- >>> hspec $ validateEveryToJSON (Proxy :: Proxy UserAPI)

162164-- <BLANKLINE>

163−-- [User]

165+-- [User]...

164166-- ...

165−-- User

167+-- User...

166168-- ...

167−-- UserId

169+-- UserId...

168170-- ...

169171-- Finished in ... seconds

170172-- 3 examples, 0 failures

servant-swagger/src/Servant/Swagger/Internal.hs+11

@@ -3,11 +3,13 @@

33{-# LANGUAGE DataKinds #-}

44{-# LANGUAGE FlexibleContexts #-}

55{-# LANGUAGE FlexibleInstances #-}

6+{-# LANGUAGE OverloadedLists #-}

67{-# LANGUAGE OverloadedStrings #-}

78{-# LANGUAGE PolyKinds #-}

89{-# LANGUAGE RankNTypes #-}

910{-# LANGUAGE ScopedTypeVariables #-}

1011{-# LANGUAGE TypeOperators #-}

12+{-# LANGUAGE TypeFamilies #-}

1113#if __GLASGOW_HASKELL__ >= 806

1214{-# LANGUAGE UndecidableInstances #-}

1315#endif

@@ -30,11 +32,13 @@ import qualified Data.Swagger as Swagger

3032import Data.Swagger.Declare

3133import Data.Text (Text)

3234import qualified Data.Text as Text

35+import GHC.Generics (D1, Meta(..), Rep)

3336import GHC.TypeLits

3437import Network.HTTP.Media (MediaType)

3538import Servant.API

3639import Servant.API.Description (FoldDescription,

3740 reflectDescription)

41+import Servant.API.Generic (ToServantApi, AsApi)

3842import Servant.API.Modifiers (FoldRequired)

3943

4044import Servant.Swagger.Internal.TypeLevel.API

@@ -149,6 +153,10 @@ mkEndpointNoContentVerb path _ = mempty

149153addParam :: Param -> Swagger -> Swagger

150154addParam param = allOperations.parameters %~ (Inline param :)

151155

156+-- | Add a tag to every operation in the spec.

157+addTag :: Text -> Swagger -> Swagger

158+addTag tag = allOperations.tags %~ ([tag] <>)

159+

152160-- | Add accepted content types to every operation in the spec.

153161addConsumes :: [MediaType] -> Swagger -> Swagger

154162addConsumes cs = allOperations.consumes %~ (<> Just (MimeList cs))

@@ -439,6 +447,9 @@ instance (ToSchema a, Accept ct, HasSwagger sub, KnownSymbol (FoldDescription mo

439447 & required ?~ True

440448 & schema .~ ParamBody ref

441449

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+

442453-- =======================================================================

443454-- Below are the definitions that should be in Servant.API.ContentTypes

444455-- =======================================================================

servant-swagger/src/Servant/Swagger/Internal/Test.hs+8−6

@@ -29,10 +29,12 @@ import Servant.Swagger.Internal.TypeLevel

2929-- >>> import Control.Applicative

3030-- >>> import GHC.Generics

3131-- >>> import Test.QuickCheck

32+-- >>> import System.Environment (setEnv)

3233-- >>> :set -XDeriveGeneric

3334-- >>> :set -XGeneralizedNewtypeDeriving

3435-- >>> :set -XDataKinds

3536-- >>> :set -XTypeOperators

37+-- >>> setEnv "HSPEC_COLOR" "no"

3638

3739-- | Verify that every type used with @'JSON'@ content type in a servant API

3840-- has compatible @'ToJSON'@ and @'ToSchema'@ instances using @'validateToJSON'@.

@@ -53,10 +55,10 @@ import Servant.Swagger.Internal.TypeLevel

5355--

5456-- >>> hspec $ context "ToJSON matches ToSchema" $ validateEveryToJSON (Proxy :: Proxy UserAPI)

5557-- <BLANKLINE>

56−-- ToJSON matches ToSchema

57−-- User

58+-- ToJSON matches ToSchema...

59+-- User...

5860-- ...

59−-- UserId

61+-- UserId...

6062-- ...

6163-- Finished in ... seconds

6264-- 2 examples, 0 failures

@@ -118,11 +120,11 @@ validateEveryToJSONWithPatternChecker checker _ = props

118120-- :}

119121-- <BLANKLINE>

120122-- read . show == id

121−-- Bool

123+-- Bool...

122124-- ...

123−-- Int

125+-- Int...

124126-- ...

125−-- [Char]

127+-- [Char]...

126128-- ...

127129-- Finished in ... seconds

128130-- 3 examples, 0 failures

servant/servant.cabal+6−6

@@ -80,13 +80,13 @@ library

8080 --

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

8282 build-depends:

83− base >= 4.9 && < 4.16

83+ base >= 4.9 && < 4.17

8484 , bytestring >= 0.10.8.1 && < 0.12

8585 , constraints >= 0.2

8686 , mtl >= 2.2.2 && < 2.3

8787 , sop-core >= 0.4.0.0 && < 0.6

8888 , transformers >= 0.5.2.0 && < 0.6

89− , text >= 1.2.3.0 && < 1.3

89+ , text >= 1.2.3.0 && < 2.1

9090

9191

9292 -- We depend (heavily) on the API of these packages:

@@ -98,7 +98,7 @@ library

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

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

100100 build-depends:

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

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

102102 , aeson >= 1.4.1.0 && < 3

103103 , attoparsec >= 0.13.2.2 && < 0.15

104104 , bifunctors >= 5.5.3 && < 5.6

@@ -106,7 +106,7 @@ library

106106 , deepseq >= 1.4.2.0 && < 1.5

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

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

109− , mmorph >= 1.1.2 && < 1.2

109+ , mmorph >= 1.1.2 && < 1.3

110110 , network-uri >= 2.6.1.0 && < 2.7

111111 , QuickCheck >= 2.12.6.1 && < 2.15

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

@@ -166,9 +166,9 @@ test-suite spec

166166

167167 -- Additional dependencies

168168 build-depends:

169− hspec >= 2.6.0 && < 2.9

169+ hspec >= 2.6.0 && < 2.10

170170 , QuickCheck >= 2.12.6.1 && < 2.15

171171 , quickcheck-instances >= 0.3.19 && < 0.4

172172

173173 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 (

3838

3939 -- * Sub-APIs defined as records of routes

4040 module Servant.API.NamedRoutes,

41+ module Servant.API.Generic,

4142

4243 -- * Streaming endpoints, distinguished by HTTP method

4344 module Servant.API.Stream,

@@ -102,6 +103,9 @@ import Servant.API.Fragment

102103 (Fragment)

103104import Servant.API.Header

104105 (Header, Header')

106+import Servant.API.Generic

107+ (GenericMode ((:-)), AsApi, ToServant, ToServantApi, GServantProduct,

108+ GenericServant, fromServant, toServant, genericApi)

105109import Servant.API.HttpVersion

106110 (HttpVersion (..))

107111import Servant.API.IsSecure

servant/src/Servant/API/ContentTypes.hs+1−1

@@ -295,7 +295,7 @@ instance {-# OVERLAPPABLE #-}

295295-- then this would be taken care of. However there is no more specific instance

296296-- between that and 'MimeRender JSON a', so we do this instead

297297instance {-# OVERLAPPING #-} ( Accept ctyp ) => AllMimeRender '[ctyp] NoContent where

298− allMimeRender _ _ = map (, "") $ NE.toList $ contentTypes pctyp

298+ allMimeRender _ NoContent = map (, "") $ NE.toList $ contentTypes pctyp

299299 where

300300 pctyp = Proxy :: Proxy ctyp

301301

servant/src/Servant/API/Verbs.hs+2−2

@@ -26,13 +26,13 @@ import Network.HTTP.Types.Method

2626-- provided, but you are free to define your own:

2727--

2828-- >>> 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 :: *)

3030 deriving (Typeable, Generic)

3131

3232-- | @NoContentVerb@ is a specific type to represent 'NoContent' responses.

3333-- It does not require either a list of content types (because there's

3434-- no content) or a status code (because it should always be 204).

35−data NoContentVerb (method :: StdMethod)

35+data NoContentVerb (method :: k1)

3636 deriving (Typeable, Generic)

3737

3838-- * 200 responses

servant/test/Servant/API/ContentTypesSpec.hs+11

@@ -33,6 +33,8 @@ import Data.String.Conversions

3333import qualified Data.Text as TextS

3434import qualified Data.Text.Encoding as TextSE

3535import qualified Data.Text.Lazy as TextL

36+import Control.Exception

37+ (evaluate)

3638import GHC.Generics

3739import Test.Hspec

3840import Test.QuickCheck

@@ -78,6 +80,15 @@ spec = describe "Servant.API.ContentTypes" $ do

7880 it "has mimeUnrender reverse mimeRender for valid top-level json " $ do

7981 property $ \x -> mimeUnrender p (mimeRender p x) == Right (x::SomeData)

8082

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+

8192 describe "The PlainText Content-Type type" $ do

8293 let p = Proxy :: Proxy PlainText

8394