git.iko.soy/servant

on b033871 help sign in

fromaaeee88

swap

to0 ahead, 145 behind

compare

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

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

1313 strategy:

1414 matrix:

1515 os: [ubuntu-latest]

16− cabal: ["3.6"]

16+ cabal: ["3.4"]

1717 ghc:

1818 - "8.6.5"

1919 - "8.8.4"

2020 - "8.10.7"

21− - "9.0.2"

22− - "9.2.2"

23− - "9.4.2"

21+ - "9.0.1"

2422

2523 steps:

2624 - uses: actions/checkout@v2

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

4947

5048 - name: Configure

5149 run: |

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

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'

5354

5455 - name: Build

5556 run: |

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

6061 cabal test all

6162

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

6367 run: |

6468 # Necessary for doctest to be found in $PATH

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

6670

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

68− (cd servant && eval $DOCTEST)

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

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

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

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

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

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

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

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

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

78−

79− # stack:

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

81− # runs-on: ubuntu-latest

82− # strategy:

83− # matrix:

84− # stack: ["2.7.5"]

85− # ghc: ["8.10.7"]

86−

87− # steps:

88− # - uses: actions/checkout@v2

89−

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

91− # name: Setup Haskell Stack

92− # with:

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

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

95−

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

97− # name: Cache ~/.stack

98− # with:

99− # path: ~/.stack

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

101−

102− # - name: Install dependencies

103− # run: |

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

105−

106− # - name: Build

107− # run: |

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

109−

110− # - name: Test

111− # run: |

112− # stack test --system-ghc

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)

89+

90+ stack:

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

92+ runs-on: ubuntu-latest

93+ strategy:

94+ matrix:

95+ stack: ["2.7.3"]

96+ ghc: ["8.10.4"]

97+

98+ steps:

99+ - uses: actions/checkout@v2

100+

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

102+ name: Setup Haskell Stack

103+ with:

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

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

106+

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

108+ name: Cache ~/.stack

109+ with:

110+ path: ~/.stack

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

112+

113+ - name: Install dependencies

114+ run: |

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

116+

117+ - name: Build

118+ run: |

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

120+

121+ - name: Test

122+ run: |

123+ stack test --system-ghc

113124

114125 ghcjs:

115126 name: ubuntu-latest / ghcjs 8.6

.gitignore−1

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

3131doc/tutorial/static/api.js

3232doc/tutorial/static/jq.js

3333shell.nix

34−.hspec-failures

3534

3635# nix

3736result*

CONTRIBUTING.md+2−4

@@ -79,10 +79,8 @@ 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

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

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

8684

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

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

cabal.project+23−2

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

1212 servant-docs/

1313 servant-foreign/

1414 servant-server/

15− servant-swagger/

1615 doc/tutorial/

1716

1817-- servant streaming

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

4746 doc/cookbook/using-custom-monad

4847 doc/cookbook/using-free-client

4948 -- doc/cookbook/open-id-connect

50− doc/cookbook/managed-resource

5149

5250tests: True

5351optimization: False

5452-- reorder-goals: True

53+

54+constraints:

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

56+ foundation >=0.0.14,

57+ memory <0.14.12 || >0.14.12

58+

59+constraints: base-compat ^>=0.11

60+constraints: semigroups ^>=0.19

61+

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

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

64+

65+-- needed for doctests

66+write-ghc-environment-files: always

67+

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

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

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

71+

72+allow-newer: servant-js:servant

73+

74+-- ghc 9

75+allow-newer: tdigest:base

changelog.d/1469deleted−11

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

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

2−prs: #1469

3−description: {

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

5−`clientWithRoute` definitions.

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

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

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

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

10−the `Verb` status.

11−}

changelog.d/1529deleted−10

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

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

2−prs: #1529

3−

4−description: {

5−

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

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

8−functionality to match what servant-client provides.

9−

10−}

changelog.d/1556deleted−81

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

1−synopsis: Display capture hints in router layout

2−prs: #1556

3−

4−description: {

5−

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

7−

8−Example:

9−

10−For the following API

11−```haskell

12−type API =

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

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

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

16−```

17−

18−we previously got the following output:

19−

20−```

21−/

22−├─ a/

23−│ ├─ d/

24−│ │ └─•

25−│ └─ e/

26−│ └─•

27−└─ b/

28− └─ <capture>/

29− ├─•

30− ┆

31− └─•

32−```

33−

34−now we get:

35−

36−```

37−/

38−├─ a/

39−│ ├─ d/

40−│ │ └─•

41−│ └─ e/

42−│ └─•

43−└─ b/

44− └─ <x::Int>/

45− ├─•

46− ┆

47− └─•

48−```

49−

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

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

52−

53−N.B.:

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

55−

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

57−

58−Warning:

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

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

61−

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

63−```haskell

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

65−

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

67−myServer = const $ return ()

68−

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

70−myApi = Proxy

71−

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

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

74−```

75−

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

77−```haskell

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

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

80−```

81−}

changelog.d/1569deleted−13

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

1−synopsis: Encode captures using toEncodedUrlPiece

2−prs: #1569

3−issues: #1511

4−

5−description: {

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

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

8−URL-encoding however they need.

9−

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

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

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

13−}

changelog.d/1571deleted−10

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

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

2−prs: #1571

3−issues: #1570

4−description: {

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

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

7−servant-auth-client.

8−

9−This PR also brings Headers support in UVerb responses

10−}

changelog.d/1573deleted−2

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

1−synopsis: Add API docs for ServerT

2−prs: #1573

changelog.d/1580deleted−12

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

1−synopsis: Allow IO in validationKeys

2−prs: #1580

3−issues: #1579

4−

5−description: {

6−

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

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

9−discover new and expired keys.

10−

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

12−}

changelog.d/1589deleted−2

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

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

2−prs: 1589

changelog.d/1595deleted−2

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

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

2−prs: #1595

changelog.d/1606deleted−10

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

1−synopsis: Handle Cookies correctly for RunStreamingClient

2−prs: #1606

3−issues: #1605

4−

5−description: {

6−

7−Makes performWithStreamingRequest take into consideration the

8−CookieJar, which it previously didn't.

9−

10−}

changelog.d/1638deleted−2

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

1−synopsis: Add Functor instance to AuthHandler.

2−prs: #1638

changelog.d/1649deleted−8

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

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

2−prs: #1649

3−

4−description: {

5−

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

7−

8−}

doc/Makefile+1−1

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

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 README.md."; fi

13+ @if [ ! -d venv ]; then echo "WARNING: There is no venv directory, did you forget to 'virtualenv venv'. Check building-the-docs file."; 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+2−1

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

4646

4747# General information about the project.

4848project = u'Servant'

49−copyright = u'2022, Servant Contributors'

49+copyright = u'2018, Servant Contributors'

5050author = u'Servant Contributors'

5151

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

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

169169source_parsers = {

170170 '.lhs': CommonMarkParser,

171171}

172+

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

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

1−cabal-version: 2.2

21name: cookbook-basic-auth

32version: 0.1

43synopsis: Basic Authentication cookbook example

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

87author: Servant Contributors

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

109build-type: Simple

10+cabal-version: >=1.10

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

1212

1313executable cookbook-basic-auth

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

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

1−cabal-version: 2.2

21name: cookbook-basic-streaming

32version: 2.1

43synopsis: Streaming in servant without streaming libs

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

87author: Servant Contributors

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

109build-type: Simple

10+cabal-version: >=1.10

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

1212

1313executable cookbook-basic-streaming

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

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

1−cabal-version: 2.2

21name: cookbook-curl-mock

32version: 0.1

43synopsis: Generate curl mock requests cookbook example

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

87author: Servant Contributors

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

109build-type: Simple

10+cabal-version: >=1.10

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

1714 main-is: CurlMock.lhs

1815 build-depends: base == 4.*

1916 , aeson

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

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

1−cabal-version: 2.2

21name: cookbook-custom-errors

32version: 0.1

43synopsis: Return custom error messages from combinators

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

87author: Servant Contributors

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

109build-type: Simple

10+cabal-version: >=1.10

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

1212

1313executable cookbook-custom-errors

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

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

1−cabal-version: 2.2

21name: mysql-basics

32version: 0.1.0.0

43synopsis: Simple MySQL API cookbook example

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

87author: Servant Contributors

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

109build-type: Simple

10+cabal-version: >=1.10

1111

1212executable run

1313 hs-source-dirs: .

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

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

1−cabal-version: 2.2

21name: cookbook-db-postgres-pool

32version: 0.1

43synopsis: Simple PostgreSQL connection pool cookbook example

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

87author: Servant Contributors

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

109build-type: Simple

10+cabal-version: >=1.10

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

1212

1313executable cookbook-db-postgres-pool

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

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

1−cabal-version: 2.2

21name: cookbook-db-sqlite-simple

32version: 0.1

43synopsis: Simple SQLite DB cookbook example

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

87author: Servant Contributors

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

109build-type: Simple

10+cabal-version: >=1.10

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

1212

1313executable cookbook-db-sqlite-simple

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

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

1−cabal-version: 2.2

21name: cookbook-file-upload

32version: 0.1

43synopsis: File upload cookbook example

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

87author: Servant Contributors

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

109build-type: Simple

10+cabal-version: >=1.10

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

1212

1313executable cookbook-file-upload

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

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

1−cabal-version: 2.2

21name: cookbook-generic

32version: 0.1

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

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

87author: Servant Contributors

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

109build-type: Simple

10+cabal-version: >=1.10

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

1212

1313executable cookbook-using-custom-monad

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

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

1−cabal-version: 2.2

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

32version: 0.0.1

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

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

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

1211category: Servant

1312build-type: Simple

13+cabal-version: >=1.10

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

1515

1616executable cookbook-hoist-server-with-context

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

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

1−cabal-version: 2.2

21name: cookbook-https

32version: 0.1

43synopsis: HTTPS cookbook example

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

87author: Servant Contributors

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

109build-type: Simple

10+cabal-version: >=1.10

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

1212

1313executable cookbook-https

doc/cookbook/index.rst+2−3

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

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

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

10+on freenode 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,

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

3737 sentry/Sentry.lhs

3838 testing/Testing.lhs

3939 open-id-connect/OpenIdConnect.lhs

40− managed-resource/ManagedResource.lhs

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

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

1−cabal-version: 2.2

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

32version: 0.0.1

43synopsis: JWT and basic access authentication cookbook example

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

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

1211category: Servant

1312build-type: Simple

13+cabal-version: >=1.10

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

1515

1616executable cookbook-jwt-and-basic-auth

doc/cookbook/managed-resource/ManagedResource.lhsdeleted−114

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

1−# Request-lifetime Managed Resources

2−

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

4−

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

6−

7−

8−``` haskell

9−{-# LANGUAGE DataKinds #-}

10−{-# LANGUAGE TypeOperators #-}

11−import Control.Concurrent

12−import Control.Exception (bracket, throwIO)

13−import Control.Monad.IO.Class

14−import Control.Monad.Trans.Resource

15−import Data.Acquire

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

17−import Network.Wai.Handler.Warp

18−import Servant

19−import Servant.Client

20−import System.IO

21−```

22−

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

24−

25−``` haskell

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

27−

28−api :: Proxy API

29−api = Proxy

30−```

31−

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

33−

34−``` haskell

35−appContext :: Context '[Acquire Handle]

36−appContext = acquireHandle :. EmptyContext

37−

38−acquireHandle :: Acquire Handle

39−acquireHandle = mkAcquire newHandle closeHandle

40−

41−newHandle :: IO Handle

42−newHandle = do

43− putStrLn "opening file"

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

45− putStrLn "opened file"

46− return h

47−

48−closeHandle :: Handle -> IO ()

49−closeHandle h = do

50− putStrLn "closing file"

51− hClose h

52− putStrLn "closed file"

53−```

54−

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

56−

57−``` haskell

58−server :: Server API

59−server = writeToFile

60−

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

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

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

64− legalMsg -> liftIO $ do

65− putStrLn "writing file"

66− hPutStrLn h legalMsg

67− putStrLn "wrote file"

68− return NoContent

69−```

70−

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

72−

73−``` haskell

74−runApp :: IO ()

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

76−

77−postMsg :: String -> ClientM NoContent

78−postMsg = client api

79−

80−main :: IO ()

81−main = do

82− mgr <- newManager defaultManagerSettings

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

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

85− liftIO $ putStrLn "sending hello message"

86− _ <- postMsg "hello"

87− liftIO $ putStrLn "sending illegal message"

88− _ <- postMsg "illegal"

89− liftIO $ putStrLn "done"

90− print ms

91−```

92−

93−This program prints

94−

95−```

96−sending hello message

97−opening file

98−opened file

99−writing file

100−wrote file

101−closing file

102−closed file

103−sending illegal message

104−opening file

105−opened file

106−closing file

107−closed file

108−wait, that's illegal!

109−CallStack (from HasCallStack):

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

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

112−```

113−

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

doc/cookbook/managed-resource/managed-resource.cabaldeleted−30

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

1−cabal-version: 2.2

2−name: cookbook-managed-resource

3−version: 0.1

4−synopsis: Simple managed resource cookbook example

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

6−license: BSD-3-Clause

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

8−author: Servant Contributors

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

10−build-type: Simple

11−tested-with: GHC==9.4.2

12−

13−executable cookbook-managed-resource

14− main-is: ManagedResource.lhs

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

16− , text >= 1.2

17− , aeson >= 1.2

18− , servant

19− , servant-client

20− , servant-server

21− , warp >= 3.2

22− , wai >= 3.2

23− , http-types >= 0.12

24− , markdown-unlit >= 0.4

25− , http-client >= 0.5

26− , transformers

27− , resourcet

28− default-language: Haskell2010

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

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

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

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

1−cabal-version: 2.2

21name: open-id-connect

32version: 0.1

43synopsis: OpenId Connect with Servant example

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

87author: Servant Contributors

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

109build-type: Simple

10+cabal-version: >= 1.10

1111tested-with: GHC==8.6.5

1212

1313executable cookbook-openidconnect

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

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

330330```

331331

332332Here is the code that displays the homepage.

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

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

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

335335with some generated information.

336336

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

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

1−cabal-version: 2.2

21name: cookbook-pagination

32version: 2.1

43synopsis: Pagination with Servant example

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

87author: Servant Contributors

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

109build-type: Simple

10+cabal-version: >=1.10

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

1212

1313executable cookbook-pagination

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

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

1−cabal-version: 2.2

21name: cookbook-sentry

32version: 0.1

43synopsis: Collecting runtime exceptions using Sentry

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

87author: Servant Contributors

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

109build-type: Simple

10+cabal-version: >=1.10

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

1212

1313executable cookbook-sentry

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

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

1−cabal-version: 2.2

21name: cookbook-structuring-apis

32version: 0.1

43synopsis: Example that shows how APIs can be structured

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

87author: Servant Contributors

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

109build-type: Simple

10+cabal-version: >=1.10

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

1212

1313executable cookbook-structuring-apis

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

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

1−cabal-version: 2.2

21name: cookbook-testing

32version: 0.0.1

43synopsis: Common testing patterns in Servant apps

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

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

1110category: Servant

1211build-type: Simple

12+cabal-version: >=1.10

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

1414

1515executable cookbook-testing

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

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

1−cabal-version: 2.2

21name: cookbook-using-custom-monad

32version: 0.1

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

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

87author: Servant Contributors

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

109build-type: Simple

10+cabal-version: >=1.10

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

1212

1313executable cookbook-using-custom-monad

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

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

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

120120

121121```haskell

122− req' <- I.defaultMakeClientRequest burl req

122+ let req' = I.defaultMakeClientRequest burl req

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

124124```

125125

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

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

1−cabal-version: 2.2

21name: cookbook-using-free-client

32version: 0.1

43synopsis: Using Free client

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

87author: Servant Contributors

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

109build-type: Simple

10+cabal-version: >=1.10

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

1212

1313executable cookbook-using-free-client

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

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

199199you can try until the right one returns a value.)

200200

201201[servant-exceptions](https://github.com/ch1bo/servant-exceptions) is

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

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

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

204204The README claims that

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

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

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

1−cabal-version: 2.2

21name: cookbook-uverb

32version: 0.0.1

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

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

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

1110category: Servant

1211build-type: Simple

12+cabal-version: >=1.10

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

1414

1515executable cookbook-uverb

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− `#haskell-servant on libera.chat <https://web.libera.chat/#haskell-servant>`_

15+ ``#servant`` on freenode

1616

1717- the mailing list:

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

doc/requirements.txt−1

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

11recommonmark==0.5.0

22Sphinx==1.8.4

33sphinx_rtd_theme>=0.4.2

4−jinja2<3.1.0

doc/tutorial/install.rst−26

@@ -40,29 +40,3 @@ 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+2−2

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

1−cabal-version: 2.2

21name: tutorial

32version: 0.10

43synopsis: The servant tutorial

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

1211author: Servant Contributors

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

1413build-type: Simple

14+cabal-version: >=1.10

1515tested-with:

1616 GHC==8.6.5

1717 GHC==8.8.3, GHC ==8.10.7

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

67+ , lucid >= 2.9.11 && < 2.10

6868 , random >= 1.1 && < 1.3

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

7070 , time >= 1.6.0.1 && < 1.13

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

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

1−cabal-version: 2.2

21name: servant-auth-client

32version: 0.4.1.0

43synopsis: servant-client/servant-auth compatibility

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

76 APIs that use

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

98 .

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

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

1110category: Web, Servant, Authentication

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

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

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

1413author: Julian K. Arni

1514maintainer: jkarni@gmail.com

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

1817license-file: LICENSE

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

2019build-type: Simple

20+cabal-version: >= 1.10

2121extra-source-files:

2222 CHANGELOG.md

2323

@@ -31,12 +31,12 @@ 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.18

35− , bytestring >= 0.10.6.0 && < 0.12

34+ base >= 4.10 && < 4.16

35+ , bytestring >= 0.10.6.0 && < 0.11

3636 , containers >= 0.5.6.2 && < 0.7

3737 , servant-auth == 0.4.*

38− , servant >= 0.13 && < 0.20

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

38+ , servant >= 0.13 && < 0.19

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

4040

4141 exposed-modules:

4242 Servant.Auth.Client

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

53+ build-tool-depends: hspec-discover:hspec-discover >=2.5.5 && <2.9

5454

5555 -- dependencies with bounds inherited from the library stanza

5656 build-depends:

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

6262

6363 -- test dependencies

6464 build-depends:

65− hspec >= 2.5.5 && < 2.10

65+ hspec >= 2.5.5 && < 2.9

6666 , QuickCheck >= 2.11.3 && < 2.15

67− , aeson >= 1.3.1.1 && < 3

68− , bytestring >= 0.10.6.0 && < 0.12

67+ , aeson >= 1.3.1.1 && < 1.6

68+ , bytestring >= 0.10.6.0 && < 0.11

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

72− , servant-server >= 0.13 && < 0.20

72+ , servant-server >= 0.13 && < 0.19

7373 , time >= 1.5.0.1 && < 1.13

7474 , transformers >= 0.4.2.0 && < 0.6

7575 , wai >= 3.2.1.2 && < 3.3

7676 , warp >= 3.2.25 && < 3.4

77− , jose >= 0.10 && < 0.11

77+ , jose >= 0.7.0.0 && < 0.9

7878 other-modules:

7979 Servant.Auth.ClientSpec

8080 default-language: Haskell2010

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

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

1−cabal-version: 2.2

21name: servant-auth-docs

32version: 0.2.10.0

43synopsis: servant-docs/servant-auth compatibility

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

76 APIs that use

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

98 .

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

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

1110category: Web, Servant, Authentication

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

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

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

1413author: Julian K. Arni

1514maintainer: jkarni@gmail.com

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

1817license-file: LICENSE

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

2019build-type: Custom

20+cabal-version: >= 1.10

2121extra-source-files:

2222 CHANGELOG.md

2323

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

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

40− , servant >= 0.13 && < 0.20

38+ base >= 4.10 && < 4.16

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

40+ , servant >= 0.13 && < 0.19

4141 , servant-auth == 0.4.*

42− , lens >= 4.16.1 && <5.3

42+ , lens >= 4.16.1 && <5.1

4343 exposed-modules:

4444 Servant.Auth.Docs

4545 default-language: Haskell2010

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

5050 build-depends:

5151 base,

5252 servant-auth-docs,

53− doctest >= 0.16 && < 0.21,

53+ doctest >= 0.16 && < 0.19,

5454 QuickCheck >= 2.11.3 && < 2.15,

5555 template-haskell

5656 ghc-options: -Wall -threaded

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

67+ build-tool-depends: hspec-discover:hspec-discover >=2.5.5 && <2.9

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

81+ , hspec >= 2.5.5 && < 2.9

8282 , QuickCheck >= 2.11.3 && < 2.15

8383

8484 default-language: Haskell2010

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

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

1−cabal-version: 2.2

21name: servant-auth-server

3−version: 0.4.7.0

2+version: 0.4.6.0

43synopsis: servant-server/servant-auth compatibility

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

65 in your 'servant' server.

76 .

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

98 .

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

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

1110category: Web, Servant, Authentication

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

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

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

1413author: Julian K. Arni

1514maintainer: jkarni@gmail.com

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

1817license-file: LICENSE

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

2019build-type: Simple

20+cabal-version: >= 1.10

2121extra-source-files:

2222 CHANGELOG.md

2323

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

35− , aeson >= 1.0.0.1 && < 3

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

34+ base >= 4.10 && < 4.16

35+ , aeson >= 1.3.1.1 && < 1.6

36+ , base64-bytestring >= 1.0.0.1 && < 1.3

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

38− , bytestring >= 0.10.6.0 && < 0.12

38+ , bytestring >= 0.10.6.0 && < 0.11

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

44− , jose >= 0.10 && < 0.11

45− , lens >= 4.16.1 && < 5.3

46− , memory >= 0.14.16 && < 0.19

44+ , jose >= 0.7.0.0 && < 0.9

45+ , lens >= 4.16.1 && < 5.1

46+ , memory >= 0.14.16 && < 0.17

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

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

49− , servant >= 0.13 && < 0.20

48+ , mtl >= 2.2.2 && < 2.3

49+ , servant >= 0.13 && < 0.19

5050 , servant-auth == 0.4.*

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

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

5252 , tagged >= 0.8.4 && < 0.9

53− , text >= 1.2.3.0 && < 2.1

54− , time >= 1.5.0.1 && < 1.13

53+ , text >= 1.2.3.0 && < 1.3

54+ , time >= 1.5.0.1 && < 1.10

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

105+ build-tool-depends: hspec-discover:hspec-discover >=2.5.5 && <2.8

106106

107107 -- dependencies with bounds inherited from the library stanza

108108 build-depends:

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

123123 -- test dependencies

124124 build-depends:

125125 servant-auth-server

126− , hspec >= 2.5.5 && < 2.10

126+ , hspec >= 2.5.5 && < 2.8

127127 , QuickCheck >= 2.11.3 && < 2.15

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

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

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

130130 , warp >= 3.2.25 && < 3.4

131131 , wreq >= 0.5.2.1 && < 0.6

132− , text >= 1.2.3.0 && < 2.1

133132 other-modules:

134133 Servant.Auth.ServerSpec

135134 default-language: Haskell2010

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

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

5454

5555 makeCookies :: AuthResult v -> IO (SetCookieList ('S ('S 'Z)))

5656 makeCookies authResult = do

57− case authResult of

58− (Authenticated v) -> do

59− ejwt <- makeSessionCookie cookieSettings jwtSettings v

60− xsrf <- makeXsrfCookie cookieSettings

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

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

57+ xsrf <- makeXsrfCookie cookieSettings

58+ fmap (Just xsrf `SetCookieCons`) $

59+ case authResult of

60+ (Authenticated v) -> do

61+ ejwt <- makeSessionCookie cookieSettings jwtSettings v

62+ case ejwt of

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

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

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

6366

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

6568 -> (AuthResult v, SetCookieList n)

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

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

1111import qualified Network.HTTP.Types as HTTP

1212import Network.Wai (mapResponseHeaders)

1313import Servant

14−import Servant.API.UVerb.Union

15−import Servant.API.Generic

16−import Servant.Server.Generic

1714import Web.Cookie

1815

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

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

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

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

3633

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

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

39− MapAddSetCookieApiVerb '[] = '[]

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

41−#endif

42−

4334type family AddSetCookieApi a :: *

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

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

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

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

48−#endif

4937type instance AddSetCookieApi (Verb method stat ctyps a)

5038 = Verb method stat ctyps (AddSetCookieApiVerb a)

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

52−type instance AddSetCookieApi (UVerb method ctyps as)

53− = UVerb method ctyps (MapAddSetCookieApiVerb as)

54−#endif

5539type instance AddSetCookieApi Raw = Raw

5640#if MIN_VERSION_servant_server(0,15,0)

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

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

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

7155 addSetCookies cookies oldfn = addSetCookies cookies . oldfn

7256

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

57+instance AddSetCookies 'Z orig orig where

7458 addSetCookies _ = id

7559

7660instance {-# OVERLAPPABLE #-}

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

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

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

9074

91−instance {-# OVERLAPS #-}

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

93− , Generic (api (AsServerT m))

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

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

96− )

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

98− addSetCookies cookies = addSetCookies cookies . toServant

99−

10075-- | for @servant <0.11@

10176instance

10277 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 :: IO Jose.JWKSet

36+ , validationKeys :: 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 = pure $ Jose.JWKSet [k]

47+ , validationKeys = 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/Cookie.hs−1

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

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

33

44import Blaze.ByteString.Builder (toByteString)

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

65import Control.Monad.Except

76import Control.Monad.Reader

87import qualified Crypto.JOSE as Jose

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

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

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

22

33import Control.Lens

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

4+import Control.Monad.Except

55import Control.Monad.Reader

66import qualified Crypto.JOSE as Jose

77import qualified Crypto.JWT as Jose

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

9+ toJSON)

810import Data.ByteArray (constEq)

911import qualified Data.ByteString as BS

1012import qualified Data.ByteString.Lazy as BSL

13+import qualified Data.HashMap.Strict as HM

1114import Data.Maybe (fromMaybe)

15+import qualified Data.Text as T

1216import Data.Time (UTCTime)

1317import Network.Wai (requestHeaders)

1418

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

3842-- token expires.

3943makeJWT :: ToJWT a

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

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

45+makeJWT v cfg expiry = runExceptT $ do

4246 bestAlg <- Jose.bestJWSAlg $ signingKey cfg

4347 let alg = fromMaybe bestAlg $ jwtAlg cfg

4448 ejwt <- Jose.signClaims (signingKey cfg)

@@ -54,15 +58,14 @@ makeJWT v cfg expiry = Jose.runJOSE $ do

5458

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

5660verifyJWT jwtCfg input = do

57− keys <- validationKeys jwtCfg

58− verifiedJWT <- Jose.runJOSE $ do

61+ verifiedJWT <- liftIO $ runExceptT $ do

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

6063 Jose.verifyClaims

6164 (jwtSettingsToJwtValidationSettings jwtCfg)

62− keys

65+ (validationKeys jwtCfg)

6366 unverifiedJWT

6467 return $ case verifiedJWT of

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

6669 Right v -> case decodeJWT v of

6770 Left _ -> Nothing

68− Right v' -> Just v'

71+ Right v' -> Just v'

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

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

88

99import Control.Monad.Error.Class

1010import Data.Tagged (Tagged (..))

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

12−import Servant.API.Generic

13−import Servant.Server.Generic

14−import Servant.Server

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

1512import Network.HTTP.Types

1613import Network.Wai

1714

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

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

3027 throwAll e = throwAll e :<|> throwAll e

3128

32−instance

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

34− ThrowAll (api (AsServerT m)) where

35−

36− throwAll = fromServant . throwAll

37−

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

3930-- MonadError, no?

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

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

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

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

33

44import Control.Applicative

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

65import Control.Monad.Reader

76import Control.Monad.Time

87import Data.Monoid (Monoid (..))

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

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

11{-# LANGUAGE CPP #-}

2−{-# LANGUAGE TypeApplications #-}

32module Servant.Auth.ServerSpec (spec) where

43

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

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

76#endif

87

98import Control.Lens

9+import Control.Monad.Except (runExceptT)

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

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

1212 JWK, JWSHeader,

1313 KeyMaterialGenParam (OctGenParam),

1414 ToCompact, encodeCompact,

15− genJWK, newJWSHeader, runJOSE)

15+ genJWK, newJWSHeader)

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

1717 NumericDate (NumericDate),

1818 SignedJWT,

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

2525import Data.Aeson.Lens (_JSON)

2626import qualified Data.ByteString as BS

2727import qualified Data.ByteString.Lazy as BSL

28−import Data.Text (Text, pack)

2928import Data.CaseInsensitive (mk)

3029import Data.Foldable (find)

3130import Data.Monoid

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

4140import Network.Wai (responseLBS)

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

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

44− checkResponse,

4543 cookieExpiryTime, cookies,

4644 defaults, get, getWith, postWith,

4745 header, oauth2Bearer,

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

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

5351import Servant hiding (BasicAuth,

5452 IsSecure (..), header)

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

5653import Servant.Auth.Server

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

5855import Servant.Auth.Server.SetCookieOrphan ()

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

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

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

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

188− opts' <- addJwtToCookie cookieCfg jwt

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

190− resp <- getWith opts (url port)

191− resp ^. responseStatus `shouldBe` status401

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

193−

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

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

196− -- which revealed a bug:

197− --

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

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

200− resp ^. responseStatus `shouldBe` status401

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

202−

185+ opts <- addJwtToCookie cookieCfg jwt

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

203187

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

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

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

421405 = Auth auths User :>

422406 ( Get '[JSON] Int

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

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

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

426409#if MIN_VERSION_servant_server(0,15,0)

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

428411#endif

429412 :<|> "raw" :> Raw

430413 )

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

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

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

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

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

436418

437−data DummyRoutes mode = DummyRoutes

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

439− } deriving Generic

440−

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

442420jwtOnlyApi = Proxy

443421

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

498476 (\authResult -> case authResult of

499477 Authenticated usr -> getInt usr

500478 :<|> postInt usr

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

502479 :<|> getHeaderInt

503480#if MIN_VERSION_servant_server(0,15,0)

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

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

506483 :<|> raw

507484 Indefinite -> throwAll err401

508485 _ -> throwAll err403

509− ) :<|>

510− (\authResult -> case authResult of

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

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

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

514486 )

515487 :<|> getLogin

516488 :<|> getLogout

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

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

562534

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

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

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

565537

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

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

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

591563 = fmap cookie_name (destroyCookieJar cj)

592564 `shouldMatchList` patterns

593565

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

595−shouldNotHaveCookies cj patterns =

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

597− where cookieNames :: [BS.ByteString]

598− cookieNames = cookie_name <$> destroyCookieJar cj

599−

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

601567shouldMatchCookieNameValues cj patterns

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

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

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

1−cabal-version: 2.2

21name: servant-auth-swagger

32version: 0.2.10.1

43synopsis: servant-swagger/servant-auth compatibility

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

76 APIs that use

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

98 .

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

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

1110category: Web, Servant, Authentication

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

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

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

1413author: Julian K. Arni

1514maintainer: jkarni@gmail.com

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

1817license-file: LICENSE

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

2019build-type: Simple

20+cabal-version: >= 1.10

2121extra-source-files:

2222 CHANGELOG.md

2323

@@ -31,13 +31,15 @@ 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.18

35− , text >= 1.2.3.0 && < 2.1

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

37− , swagger2 >= 2.2.2 && < 3

38− , servant >= 0.13 && < 0.20

34+ base >= 4.10 && < 4.16

35+ , text >= 1.2.3.0 && < 1.3

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

37+ , swagger2 >= 2.2.2 && < 2.7

38+ , servant >= 0.13 && < 0.19

3939 , servant-auth == 0.4.*

40− , lens >= 4.16.1 && < 5.3

40+ , lens >= 4.16.1 && < 5.1

41+ if impl(ghc >= 9)

42+ buildable: False

4143 exposed-modules:

4244 Servant.Auth.Swagger

4345 default-language: Haskell2010

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

4951 test

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

5153 ghc-options: -Wall

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

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

5355 -- dependencies with bounds inherited from the library stanza

5456 build-depends:

5557 base

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

5961 , servant

6062 , servant-auth

6163 , lens

62−

64+ if impl(ghc >= 9)

65+ buildable: False

66+

6367 -- test dependencies

6468 build-depends:

6569 servant-auth-swagger

66− , hspec >= 2.5.5 && < 2.10

70+ , hspec >= 2.5.5 && < 2.9

6771 , QuickCheck >= 2.11.3 && < 2.15

6872 other-modules:

6973 Servant.Auth.SwaggerSpec

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

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

1−cabal-version: 2.2

21name: servant-auth

3−version: 0.4.1.0

2+version: 0.4.0.0

43synopsis: Authentication combinators for servant

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

65 allows using different authentication schemes in a straightforward way,

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

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

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

1110 .

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

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

1312category: Web, Servant, Authentication

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

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

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

1615author: Julian K. Arni

1716maintainer: jkarni@gmail.com

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

2019license-file: LICENSE

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

2221build-type: Simple

22+cabal-version: >= 1.10

2323extra-source-files:

2424 CHANGELOG.md

2525

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

37− , containers >= 0.6 && < 0.7

38− , aeson >= 1.3.1.1 && < 3

39− , jose >= 0.10 && < 0.11

40− , lens >= 4.16.1 && < 5.3

41− , servant >= 0.15 && < 0.20

42− , text >= 1.2.3.0 && < 2.1

36+ base >= 4.10 && < 4.16

37+ , aeson >= 1.3.1.1 && < 1.6

38+ , jose >= 0.7.0.0 && < 0.9

39+ , lens >= 4.16.1 && < 5.1

40+ , servant >= 0.15 && < 0.19

41+ , text >= 1.2.3.0 && < 1.3

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

4443 exposed-modules:

4544 Servant.Auth

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

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

2727

2828-- ** Combinators

2929

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

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

3131--

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

3333--

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

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

1−{-# LANGUAGE CPP #-}

2−

31module Servant.Auth.JWT where

42

53import Control.Lens ((^.))

64import qualified Crypto.JWT as Jose

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

86 toJSON)

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

10−import qualified Data.Map as KM

11−#else

12−import qualified Data.HashMap.Strict as KM

13−#endif

14−

7+import qualified Data.HashMap.Strict as HM

158import qualified Data.Text as T

169

1710

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

2417class FromJWT a where

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

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

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

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

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

2922 Just v -> case fromJSON v of

3023 Error e -> Left $ T.pack e

servant-client-core/CHANGELOG.md−31

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

11[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-client-core/CHANGELOG.md)

22[Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)

33

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

5−

6−0.19

7−----

8−

9−### Significant changes

10−

11−- Drop support for GHC < 8.6.

12−- Support GHC 9.0 (GHC 9.2 should work as well, but isn't fully tested yet).

13−- Support Aeson 2 ([#1475](https://github.com/haskell-servant/servant/pull/1475)),

14− which fixes a [DOS vulnerability](https://github.com/haskell/aeson/issues/864)

15− related to hash collisions.

16−- Add `NamedRoutes` combinator, making support for records first-class in Servant

17− ([#1388](https://github.com/haskell-servant/servant/pull/1388)).

18−- Add custom type errors for partially applied combinators

19− ([#1289](https://github.com/haskell-servant/servant/pull/1289),

20− [#1486](https://github.com/haskell-servant/servant/pull/1486)).

21−- *servant-client* / *servant-client-core* / *servant-http-streams*: Fix

22− erroneous behavior, where only 2XX status codes would be considered

23− successful, irrelevant of the status parameter specified by the verb

24− combinator. ([#1469](https://github.com/haskell-servant/servant/pull/1469))

25−- *servant-client* / *servant-client-core*: Fix `Show` instance for

26− `Servant.Client.Core.Request`.

27−- *servant-client* / *servant-client-core*: Allow passing arbitrary binary data

28− in Query parameters.

29− ([#1432](https://github.com/haskell-servant/servant/pull/1432)).

30−

31−### Other changes

32−

33−- Various version bumps.

34−

3540.18.3

365------

376

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

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

1−cabal-version: 2.2

1+cabal-version: >=1.10

22name: servant-client-core

3−version: 0.19

3+version: 0.18.3

44

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

66category: Servant, Web

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

53+ base >= 4.9 && < 4.16

5454 , bytestring >= 0.10.8.1 && < 0.12

55− , constraints >= 0.2 && < 0.14

55+ , constraints

5656 , containers >= 0.5.7.1 && < 0.7

5757 , deepseq >= 1.4.2.0 && < 1.5

58− , text >= 1.2.3.0 && < 2.1

59− , transformers >= 0.5.2.0 && < 0.7

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

58+ , text >= 1.2.3.0 && < 1.3

59+ , transformers >= 0.5.2.0 && < 0.6

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

6161

6262 if !impl(ghc >= 8.2)

6363 build-depends:

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

6565

6666 -- Servant dependencies

6767 build-depends:

68− servant >= 0.19

68+ servant >= 0.18.3 && <0.19

6969

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

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

7272 build-depends:

73− aeson >= 1.4.1.0 && < 3

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

73+ aeson >= 1.4.1.0 && < 1.6

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

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

107+ , hspec >= 2.6.0 && < 2.9

108108 , QuickCheck >= 2.12.6.1 && < 2.15

109109

110110 build-tool-depends:

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

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

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

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

5959 , appendToPath

6060 , setRequestBodyLBS

6161 , setRequestBody

62− , encodeQueryParamValue

6362 ) where

6463import Servant.Client.Core.Auth

6564import Servant.Client.Core.BaseUrl

servant-client-core/src/Servant/Client/Core/HasClient.hs+38−190

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

11{-# LANGUAGE ConstraintKinds #-}

2+{-# LANGUAGE CPP #-}

23{-# LANGUAGE DataKinds #-}

34{-# LANGUAGE FlexibleContexts #-}

45{-# LANGUAGE FlexibleInstances #-}

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

67{-# LANGUAGE MultiParamTypeClasses #-}

78{-# LANGUAGE OverloadedStrings #-}

89{-# LANGUAGE PolyKinds #-}

9−{-# LANGUAGE QuantifiedConstraints #-}

1010{-# LANGUAGE RankNTypes #-}

1111{-# LANGUAGE ScopedTypeVariables #-}

1212{-# LANGUAGE TypeApplications #-}

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

1414{-# LANGUAGE TypeOperators #-}

1515{-# LANGUAGE UndecidableInstances #-}

1616

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

18+#define HAS_TYPE_ERROR

19+#endif

20+

1721module Servant.Client.Core.HasClient (

1822 clientIn,

1923 HasClient (..),

2024 EmptyClient (..),

21− AsClientT,

22− (//),

23− (/:),

2425 foldMapUnion,

2526 matchUnion,

2627 ) where

@@ -33,10 +34,11 @@ import Control.Arrow

3334import Control.Monad

3435 (unless)

3536import qualified Data.ByteString as BS

36−import qualified Data.ByteString.Lazy as BL

37+import Data.ByteString.Builder

38+ (toLazyByteString)

39+import qualified Data.ByteString.Lazy as BL

3740import Data.Either

3841 (partitionEithers)

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

4042import Data.Foldable

4143 (toList)

4244import Data.List

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

4547 (fromList)

4648import qualified Data.Text as T

4749import Network.HTTP.Media

48− (MediaType, matches, parseAccept)

49−import qualified Network.HTTP.Media as Media

50+ (MediaType, matches, parseAccept, (//))

5051import qualified Data.Sequence as Seq

5152import Data.SOP.BasicFunctors

5253 (I (I), (:.:) (Comp))

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

6364import Data.Proxy

6465 (Proxy (Proxy))

6566import GHC.TypeLits

66− (KnownNat, KnownSymbol, TypeError, symbolVal)

67+ (KnownSymbol, symbolVal)

6768import Network.HTTP.Types

6869 (Status)

6970import qualified Network.HTTP.Types as H

@@ -74,22 +75,16 @@ import Servant.API

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

7576 IsSecure, MimeRender (mimeRender),

7677 MimeUnrender (mimeUnrender), NoContent (NoContent),

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

78+ NoContentVerb, QueryFlag, QueryParam', QueryParams, Raw,

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

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

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

81− getResponse, toEncodedUrlPiece, toUrlPiece, NamedRoutes)

82−import Servant.API.Generic

83− (GenericMode(..), ToServant, ToServantApi

84− , GenericServant, toServant, fromServant)

81+ Verb, WithNamedContext, WithStatus (..), contentType, getHeadersHList,

82+ getResponse, toEncodedUrlPiece, toUrlPiece)

8583import Servant.API.ContentTypes

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

87−import Servant.API.Status

88− (statusFromNat)

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

9086import Servant.API.Modifiers

9187 (FoldRequired, RequiredArgument, foldRequiredArgument)

92−import Servant.API.TypeErrors

9388import Servant.API.UVerb

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

9590

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

208203 clientWithRoute pm (Proxy :: Proxy api)

209204 (appendToPath p req)

210205

211− where p = toEncodedUrlPiece val

206+ where p = (toUrlPiece val)

212207

213208 hoistClientMonad pm _ f cl = \a ->

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

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

243238 clientWithRoute pm (Proxy :: Proxy sublayout)

244239 (foldl' (flip appendToPath) req ps)

245240

246− where ps = map toEncodedUrlPiece vals

241+ where ps = map (toUrlPiece) vals

247242

248243 hoistClientMonad pm _ f cl = \as ->

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

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

251246instance {-# OVERLAPPABLE #-}

252247 -- Note [Non-Empty Content Types]

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

254− , KnownNat status

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

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

257251 clientWithRoute _pm Proxy req = do

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

252+ response <- runRequest req

259253 { requestAccept = fromList $ toList accept

260254 , requestMethod = method

261255 }

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

263257 where

264258 accept = contentTypes (Proxy :: Proxy ct)

265259 method = reflectMethod (Proxy :: Proxy method)

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

267260

268261 hoistClientMonad _ _ f ma = f ma

269262

270263instance {-# OVERLAPPING #-}

271− ( RunClient m, ReflectMethod method, KnownNat status

264+ ( RunClient m, ReflectMethod method

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

273266 type Client m (Verb method status cts NoContent)

274267 = m NoContent

275268 clientWithRoute _pm Proxy req = do

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

269+ _response <- runRequest req { requestMethod = method }

277270 return NoContent

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

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

280272

281273 hoistClientMonad _ _ f ma = f ma

282274

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

293285

294286instance {-# OVERLAPPING #-}

295287 -- Note [Non-Empty Content Types]

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

288+ ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls

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

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

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

300292 = m (Headers ls a)

301293 clientWithRoute _pm Proxy req = do

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

294+ response <- runRequest req

303295 { requestMethod = method

304296 , requestAccept = fromList $ toList accept

305297 }

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

307299 return $ Headers { getResponse = val

308300 , getHeadersHList = buildHeadersTo . toList $ responseHeaders response

309301 }

310− where

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

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

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

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

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

314304

315305 hoistClientMonad _ _ f ma = f ma

316306

317307instance {-# OVERLAPPING #-}

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

308+ ( RunClient m, BuildHeadersTo ls, ReflectMethod method

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

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

321311 = m (Headers ls NoContent)

322312 clientWithRoute _pm Proxy req = do

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

313+ let method = reflectMethod (Proxy :: Proxy method)

314+ response <- runRequest req { requestMethod = method }

324315 return $ Headers { getResponse = NoContent

325316 , getHeadersHList = buildHeadersTo . toList $ responseHeaders response

326317 }

327− where

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

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

330318

331319 hoistClientMonad _ _ f ma = f ma

332320

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

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

570558 where

571559 add :: a -> Request

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

560+ add param = appendToQueryString pname (Just $ encodeQueryParam param) req

573561

574562 pname :: Text

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

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

577565 hoistClientMonad pm _ f cl = \arg ->

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

579567

568+encodeQueryParam :: ToHttpApiData a => a -> BS.ByteString

569+encodeQueryParam = BL.toStrict . toLazyByteString . toEncodedUrlPiece

570+

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

581572-- the corresponding querying function will automatically take

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

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

618609 )

619610

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

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

612+ paramlist' = map (Just . encodeQueryParam) paramlist

622613

623614 hoistClientMonad pm _ f cl = \as ->

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

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

674665

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

676667

677−instance RunClient m => HasClient m RawM where

678− type Client m RawM

679− = H.Method -> m Response

680−

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

682− clientWithRoute _pm Proxy req httpMethod = do

683− runRequest req { requestMethod = httpMethod }

684−

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

686−

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

688669-- the corresponding querying function will automatically take

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

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

750731 clientWithRoute pm (Proxy :: Proxy api)

751732 (appendToPath p req)

752733

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

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

754735

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

756737

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

786767

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

788769

789−instance HasClient m subapi =>

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

791−

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

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

794−

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

796−

797770instance ( HasClient m api

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

799772 type Client m (AuthProtect tag :> api)

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

807780

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

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

810−--

783+--

811784-- Example:

812785--

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

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

819792-- > getBooks = client myApi

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

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

795+#ifdef HAS_TYPE_ERROR

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

797+#else

798+instance ( HasClient m api

799+#endif

823800 ) => HasClient m (Fragment a :> api) where

824801

825802 type Client m (Fragment a :> api) = Client m api

826803

827− clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api)

804+ clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api)

828805

829806 hoistClientMonad pm _ = hoistClientMonad pm (Proxy :: Proxy api)

830807

@@ -839,119 +816,6 @@ instance HasClient m api => HasClient m (BasicAuth realm usr :> api) where

839816 hoistClientMonad pm _ f cl = \bauth ->

840817 hoistClientMonad pm (Proxy :: Proxy api) f (cl bauth)

841818

842−-- | A type that specifies that an API record contains a client implementation.

843−data AsClientT (m :: * -> *)

844−instance GenericMode (AsClientT m) where

845− type AsClientT m :- api = Client m api

846−

847−

848−type GClientConstraints api m =

849− ( GenericServant api (AsClientT m)

850− , Client m (ToServantApi api) ~ ToServant api (AsClientT m)

851− )

852−

853−class GClient (api :: * -> *) m where

854− gClientProof :: Dict (GClientConstraints api m)

855−

856−instance GClientConstraints api m => GClient api m where

857− gClientProof = Dict

858−

859−instance

860− ( forall n. GClient api n

861− , HasClient m (ToServantApi api)

862− , RunClient m

863− )

864− => HasClient m (NamedRoutes api) where

865− type Client m (NamedRoutes api) = api (AsClientT m)

866−

867− clientWithRoute :: Proxy m -> Proxy (NamedRoutes api) -> Request -> Client m (NamedRoutes api)

868− clientWithRoute pm _ request =

869− case gClientProof @api @m of

870− Dict -> fromServant $ clientWithRoute pm (Proxy @(ToServantApi api)) request

871−

872− hoistClientMonad

873− :: forall ma mb.

874− Proxy m

875− -> Proxy (NamedRoutes api)

876− -> (forall x. ma x -> mb x)

877− -> Client ma (NamedRoutes api)

878− -> Client mb (NamedRoutes api)

879− hoistClientMonad _ _ nat clientA =

880− case (gClientProof @api @ma, gClientProof @api @mb) of

881− (Dict, Dict) ->

882− fromServant @api @(AsClientT mb) $

883− hoistClientMonad @m @(ToServantApi api) @ma @mb Proxy Proxy nat $

884− toServant @api @(AsClientT ma) clientA

885−

886−infixl 1 //

887−infixl 2 /:

888−

889−-- | Helper to make code using records of clients more readable.

890−--

891−-- Can be mixed with (/:) for supplying arguments.

892−--

893−-- Example:

894−--

895−-- @

896−-- type Api = NamedRoutes RootApi

897−--

898−-- data RootApi mode = RootApi

899−-- { subApi :: mode :- NamedRoutes SubApi

900−-- , …

901−-- } deriving Generic

902−--

903−-- data SubApi mode = SubApi

904−-- { endpoint :: mode :- Get '[JSON] Person

905−-- , …

906−-- } deriving Generic

907−--

908−-- api :: Proxy API

909−-- api = Proxy

910−--

911−-- rootClient :: RootApi (AsClientT ClientM)

912−-- rootClient = client api

913−--

914−-- endpointClient :: ClientM Person

915−-- endpointClient = client \/\/ subApi \/\/ endpoint

916−-- @

917−(//) :: a -> (a -> b) -> b

918−x // f = f x

919−

920−-- | Convenience function for supplying arguments to client functions when

921−-- working with records of clients.

922−--

923−-- Intended to be used in conjunction with '(//)'.

924−--

925−-- Example:

926−--

927−-- @

928−-- type Api = NamedRoutes RootApi

929−--

930−-- data RootApi mode = RootApi

931−-- { subApi :: mode :- Capture "token" String :> NamedRoutes SubApi

932−-- , hello :: mode :- Capture "name" String :> Get '[JSON] String

933−-- , …

934−-- } deriving Generic

935−--

936−-- data SubApi mode = SubApi

937−-- { endpoint :: mode :- Get '[JSON] Person

938−-- , …

939−-- } deriving Generic

940−--

941−-- api :: Proxy API

942−-- api = Proxy

943−--

944−-- rootClient :: RootApi (AsClientT ClientM)

945−-- rootClient = client api

946−--

947−-- hello :: String -> ClientM String

948−-- hello name = rootClient \/\/ hello \/: name

949−--

950−-- endpointClient :: ClientM Person

951−-- endpointClient = client \/\/ subApi \/: "foobar123" \/\/ endpoint

952−-- @

953−(/:) :: (a -> b -> c) -> b -> a -> c

954−(/:) = flip

955819

956820

957821{- Note [Non-Empty Content Types]

@@ -977,7 +841,7 @@ for empty and one for non-empty lists).

977841checkContentTypeHeader :: RunClient m => Response -> m MediaType

978842checkContentTypeHeader response =

979843 case lookup "Content-Type" $ toList $ responseHeaders response of

980− Nothing -> return $ "application" Media.// "octet-stream"

844+ Nothing -> return $ "application"//"octet-stream"

981845 Just t -> case parseAccept t of

982846 Nothing -> throwClientError $ InvalidContentTypeHeader response

983847 Just t' -> return t'

@@ -993,19 +857,3 @@ decodedAs response ct = do

993857 Right val -> return val

994858 where

995859 accept = toList $ contentTypes ct

996−

997−-------------------------------------------------------------------------------

998−-- Custom type errors

999−-------------------------------------------------------------------------------

1000−

1001−-- Erroring instance for HasClient' when a combinator is not fully applied

1002−instance (RunClient m, TypeError (PartialApplication HasClient arr)) => HasClient m ((arr :: a -> b) :> sub)

1003− where

1004− type Client m (arr :> sub) = TypeError (PartialApplication HasClient arr)

1005− clientWithRoute _ _ _ = error "unreachable"

1006− hoistClientMonad _ _ _ _ = error "unreachable"

1007−

1008−-- Erroring instances for 'HasClient' for unknown API combinators

1009−instance {-# OVERLAPPABLE #-} (RunClient m, TypeError (NoInstanceForSub (HasClient m) ty)) => HasClient m (ty :> sub)

1010−

1011−instance {-# OVERLAPPABLE #-} (RunClient m, TypeError (NoInstanceFor (HasClient m api))) => HasClient m api

servant-client-core/src/Servant/Client/Core/Reexport.hs−4

@@ -7,9 +7,6 @@ module Servant.Client.Core.Reexport

77 HasClient(..)

88 , foldMapUnion

99 , matchUnion

10− , AsClientT

11− , (//)

12− , (/:)

1310

1411 -- * Response (for @Raw@)

1512 , Response

@@ -26,7 +23,6 @@ module Servant.Client.Core.Reexport

2623 , showBaseUrl

2724 , parseBaseUrl

2825 , InvalidBaseUrlException

29−

3026 ) where

3127

3228

servant-client-core/src/Servant/Client/Core/Request.hs+6−22

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

1717 addHeader,

1818 appendToPath,

1919 appendToQueryString,

20− encodeQueryParamValue,

2120 setRequestBody,

2221 setRequestBodyLBS,

2322 ) where

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

3433import Data.Bitraversable

3534 (Bitraversable (..), bifoldMapDefault, bimapDefault)

3635import qualified Data.ByteString as BS

37−import Data.ByteString.Builder

38− (Builder)

3936import qualified Data.ByteString.Builder as Builder

4037import qualified Data.ByteString.Lazy as LBS

4138import qualified Data.Sequence as Seq

@@ -81,13 +78,12 @@ instance (Show a, Show b) =>

8178 . showString ", requestAccept = "

8279 . showsPrec 0 (requestAccept req)

8380 . showString ", requestHeaders = "

84− . showsPrec 0 (redactSensitiveHeader <$> requestHeaders req)

81+ . showsPrec 0 (redactSensitiveHeader <$> requestHeaders req))

8582 . showString ", requestHttpVersion = "

8683 . showsPrec 0 (requestHttpVersion req)

8784 . showString ", requestMethod = "

8885 . showsPrec 0 (requestMethod req)

8986 . showString "}"

90− )

9187 where

9288 redactSensitiveHeader :: Header -> Header

9389 redactSensitiveHeader ("Authorization", _) = ("Authorization", "<REDACTED>")

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

114110 rnfB Nothing = ()

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

116112

117−type Request = RequestF RequestBody Builder

113+type Request = RequestF RequestBody Builder.Builder

118114

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

120116data RequestBody

@@ -145,30 +141,18 @@ defaultRequest = Request

145141 , requestMethod = methodGet

146142 }

147143

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

144+appendToPath :: Text -> Request -> Request

152145appendToPath p req

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

146+ = req { requestPath = requestPath req <> "/" <> toEncodedUrlPiece p }

154147

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

156−--

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

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

148+appendToQueryString :: Text -- ^ param name

149+ -> Maybe BS.ByteString -- ^ param value

159150 -> Request

160151 -> Request

161152appendToQueryString pname pvalue req

162153 = req { requestQueryString = requestQueryString req

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

164155

165−-- | Encode a query parameter value.

166−--

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

168−encodeQueryParamValue = LBS.toStrict . Builder.toLazyByteString . toEncodedUrlPiece

169−

170−-- | Add header to the request being constructed.

171−--

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

173157addHeader name val req

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

servant-client-core/src/Servant/Client/Generic.hs+59−1

@@ -1,9 +1,20 @@

11{-# OPTIONS_GHC -fno-warn-orphans #-}

2+{-# LANGUAGE ConstraintKinds #-}

3+{-# LANGUAGE CPP #-}

24{-# LANGUAGE FlexibleContexts #-}

5+{-# LANGUAGE FlexibleInstances #-}

6+{-# LANGUAGE InstanceSigs #-}

37{-# LANGUAGE KindSignatures #-}

8+{-# LANGUAGE MultiParamTypeClasses #-}

49{-# LANGUAGE RankNTypes #-}

510{-# LANGUAGE ScopedTypeVariables #-}

11+{-# LANGUAGE TypeApplications #-}

612{-# LANGUAGE TypeFamilies #-}

13+{-# LANGUAGE UndecidableInstances #-}

14+

15+#if __GLASGOW_HASKELL__ >= 806

16+{-# LANGUAGE QuantifiedConstraints #-}

17+#endif

718

819module Servant.Client.Generic (

920 AsClientT,

@@ -11,12 +22,17 @@ module Servant.Client.Generic (

1122 genericClientHoist,

1223 ) where

1324

25+import Data.Constraint (Dict(..))

1426import Data.Proxy

1527 (Proxy (..))

1628

1729import Servant.API.Generic

1830import Servant.Client.Core

19−import Servant.Client.Core.HasClient (AsClientT)

31+

32+-- | A type that specifies that an API record contains a client implementation.

33+data AsClientT (m :: * -> *)

34+instance GenericMode (AsClientT m) where

35+ type AsClientT m :- api = Client m api

2036

2137-- | Generate a record of client functions.

2238genericClient

@@ -46,3 +62,45 @@ genericClientHoist nt

4662 where

4763 m = Proxy :: Proxy m

4864 api = Proxy :: Proxy (ToServantApi routes)

65+

66+#if __GLASGOW_HASKELL__ >= 806

67+

68+type GClientConstraints api m =

69+ ( GenericServant api (AsClientT m)

70+ , Client m (ToServantApi api) ~ ToServant api (AsClientT m)

71+ )

72+

73+class GClient (api :: * -> *) m where

74+ proof :: Dict (GClientConstraints api m)

75+

76+instance GClientConstraints api m => GClient api m where

77+ proof = Dict

78+

79+instance

80+ ( forall n. GClient api n

81+ , HasClient m (ToServantApi api)

82+ , RunClient m

83+ )

84+ => HasClient m (NamedRoutes api) where

85+ type Client m (NamedRoutes api) = api (AsClientT m)

86+

87+ clientWithRoute :: Proxy m -> Proxy (NamedRoutes api) -> Request -> Client m (NamedRoutes api)

88+ clientWithRoute pm _ request =

89+ case proof @api @m of

90+ Dict -> fromServant $ clientWithRoute pm (Proxy @(ToServantApi api)) request

91+

92+ hoistClientMonad

93+ :: forall ma mb.

94+ Proxy m

95+ -> Proxy (NamedRoutes api)

96+ -> (forall x. ma x -> mb x)

97+ -> Client ma (NamedRoutes api)

98+ -> Client mb (NamedRoutes api)

99+ hoistClientMonad _ _ nat clientA =

100+ case (proof @api @ma, proof @api @mb) of

101+ (Dict, Dict) ->

102+ fromServant @api @(AsClientT mb) $

103+ hoistClientMonad @m @(ToServantApi api) @ma @mb Proxy Proxy nat $

104+ toServant @api @(AsClientT ma) clientA

105+

106+#endif

servant-client-core/test/Servant/Client/Core/RequestSpec.hs−12

@@ -10,22 +10,10 @@ import Data.List (isInfixOf)

1010import Servant.Client.Core.Request

1111import Test.Hspec

1212

13−newtype DataWithRequest = DataWithRequest (RequestF RequestBody ())

14− deriving Show

15−

1613spec :: Spec

1714spec = do

1815 describe "Request" $ do

1916 describe "show" $ do

20− it "has parenthesis correctly positioned" $ do

21− let d = DataWithRequest (void defaultRequest)

22− show d `shouldBe` "DataWithRequest (Request {requestPath = ()\

23− \, requestQueryString = fromList []\

24− \, requestBody = Nothing\

25− \, requestAccept = fromList []\

26− \, requestHeaders = fromList []\

27− \, requestHttpVersion = HTTP/1.1\

28− \, requestMethod = \"GET\"})"

2917 it "redacts the authorization header" $ do

3018 let request = void $ defaultRequest { requestHeaders = pure ("authorization", "secret") }

3119 isInfixOf "secret" (show request) `shouldBe` False

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

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

1−cabal-version: 2.2

1+cabal-version: >=1.10

22name: servant-client-ghcjs

33version: 0.16

44synopsis:

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

3838 Servant.Client.Internal.XhrClient

3939

4040 build-depends:

41− base >=4.11 && <5

41+ base >=4.11 && <4.12

4242 , bytestring >=0.10 && <0.12

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

4444 , containers >=0.5 && <0.7

@@ -48,7 +48,7 @@ library

4848 , http-media >=0.6.2 && <0.9

4949 , http-types >=0.12 && <0.13

5050 , monad-control >=1.0.0.4 && <1.1

51− , mtl ^>=2.2.2 || ^>=2.3.1

51+ , mtl >=2.2.2 && <2.3

5252 , semigroupoids >=5.3 && <5.4

5353 , string-conversions >=0.3 && <0.5

5454 , transformers >=0.3 && <0.6

@@ -56,8 +56,8 @@ library

5656

5757 -- strict, as we re-export stuff

5858 build-depends:

59− servant >=0.16 && <0.20

60− , servant-client-core >=0.16 && <0.20

59+ servant >=0.16 && <0.17

60+ , servant-client-core >=0.16 && <0.16.1

6161

6262 hs-source-dirs: src

6363 default-language: Haskell2010

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

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

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

121121

122122instance RunClient ClientM where

123− runRequestAcceptStatus = performRequest

123+ runRequest = performRequest

124124 throwClientError = throwError

125125

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

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

152152

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

154154

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

156−performRequest acceptStatus req = do

155+performRequest :: Request -> ClientM Response

156+performRequest req = do

157157 xhr <- liftIO initXhr

158158 burl <- asks baseUrl

159159 liftIO $ performXhr xhr burl req

160160 resp <- toResponse xhr

161161

162− let status = responseStatusCode resp

163− goodStatus = case acceptStatus of

164− Nothing -> statusIsSuccessful status

165− Just good -> status `elem` good

166− unless goodStatus $ do

162+ let status = statusCode (responseStatusCode resp)

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

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

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

169166

servant-client/CHANGELOG.md−31

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

11[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-client/CHANGELOG.md)

22[Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)

33

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

5−

6−0.19

7−----

8−

9−### Significant changes

10−

11−- Drop support for GHC < 8.6.

12−- Support GHC 9.0 (GHC 9.2 should work as well, but isn't fully tested yet).

13−- Support Aeson 2 ([#1475](https://github.com/haskell-servant/servant/pull/1475)),

14− which fixes a [DOS vulnerability](https://github.com/haskell/aeson/issues/864)

15− related to hash collisions.

16−- Add `NamedRoutes` combinator, making support for records first-class in Servant

17− ([#1388](https://github.com/haskell-servant/servant/pull/1388)).

18−- Add custom type errors for partially applied combinators

19− ([#1289](https://github.com/haskell-servant/servant/pull/1289),

20− [#1486](https://github.com/haskell-servant/servant/pull/1486)).

21−- *servant-client* / *servant-client-core* / *servant-http-streams*: Fix

22− erroneous behavior, where only 2XX status codes would be considered

23− successful, irrelevant of the status parameter specified by the verb

24− combinator. ([#1469](https://github.com/haskell-servant/servant/pull/1469))

25−- *servant-client* / *servant-client-core*: Fix `Show` instance for

26− `Servant.Client.Core.Request`.

27−- *servant-client* / *servant-client-core*: Allow passing arbitrary binary data

28− in Query parameters.

29− ([#1432](https://github.com/haskell-servant/servant/pull/1432)).

30−

31−### Other changes

32−

33−- Various version bumps.

34−

3540.18.3

365------

376

servant-client/servant-client.cabal+14−15

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

1−cabal-version: 2.2

1+cabal-version: >=1.10

22name: servant-client

3−version: 0.19

3+version: 0.18.3

44

55synopsis: Automatic derivation of querying functions for servant

66category: Servant, Web

@@ -41,15 +41,15 @@ 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.18

44+ base >= 4.9 && < 4.16

4545 , bytestring >= 0.10.8.1 && < 0.12

4646 , containers >= 0.5.7.1 && < 0.7

4747 , deepseq >= 1.4.2.0 && < 1.5

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

48+ , mtl >= 2.2.2 && < 2.3

4949 , stm >= 2.4.5.1 && < 2.6

50− , text >= 1.2.3.0 && < 2.1

51− , time >= 1.6.0.1 && < 1.13

52− , transformers >= 0.5.2.0 && < 0.7

50+ , text >= 1.2.3.0 && < 1.3

51+ , time >= 1.6.0.1 && < 1.10

52+ , transformers >= 0.5.2.0 && < 0.6

5353

5454 if !impl(ghc >= 8.2)

5555 build-depends:

@@ -58,13 +58,13 @@ library

5858 -- Servant dependencies.

5959 -- Strict dependency on `servant-client-core` as we re-export things.

6060 build-depends:

61− servant >= 0.18 && < 0.20

62− , servant-client-core >= 0.19 && < 0.19.1

61+ servant == 0.18.*

62+ , servant-client-core >= 0.18.3 && <0.18.4

6363

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

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

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

@@ -89,7 +89,6 @@ test-suite spec

8989 main-is: Spec.hs

9090 other-modules:

9191 Servant.BasicAuthSpec

92− Servant.BrokenSpec

9392 Servant.ClientTestUtils

9493 Servant.ConnectionErrorSpec

9594 Servant.FailSpec

@@ -124,16 +123,16 @@ test-suite spec

124123 -- Additional dependencies

125124 build-depends:

126125 entropy >= 0.4.1.3 && < 0.5

127− , hspec >= 2.6.0 && < 2.10

126+ , hspec >= 2.6.0 && < 2.9

128127 , HUnit >= 1.6.0.0 && < 1.7

129128 , network >= 2.8.0.0 && < 3.2

130129 , QuickCheck >= 2.12.6.1 && < 2.15

131− , servant == 0.19.*

132− , servant-server == 0.19.*

130+ , servant == 0.18.*

131+ , servant-server == 0.18.*

133132 , tdigest >= 0.2 && < 0.3

134133

135134 build-tool-depends:

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

135+ hspec-discover:hspec-discover >= 2.6.0 && < 2.9

137136

138137test-suite readme

139138 type: exitcode-stdio-1.0

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

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

2424import Control.Monad.Base

2525 (MonadBase (..))

2626import Control.Monad.Catch

27− (MonadCatch, MonadThrow, MonadMask)

27+ (MonadCatch, MonadThrow)

2828import Control.Monad.Error.Class

2929 (MonadError (..))

3030import Control.Monad.IO.Class

@@ -63,7 +63,7 @@ import GHC.Generics

6363import Network.HTTP.Media

6464 (renderHeader)

6565import Network.HTTP.Types

66− (hContentType, renderQuery, statusIsSuccessful, urlEncode, Status)

66+ (hContentType, renderQuery, statusCode, urlEncode, Status)

6767import Servant.Client.Core

6868

6969import qualified Network.HTTP.Client as Client

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

8080 { manager :: Client.Manager

8181 , baseUrl :: BaseUrl

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

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

83+ , makeClientRequest :: BaseUrl -> Request -> 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, MonadMask)

139+ , MonadCatch)

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− clientRequest <- liftIO $ createClientRequest burl req

165+ let clientRequest = createClientRequest burl req

166166 request <- case cookieJar' of

167167 Nothing -> pure clientRequest

168168 Just cj -> liftIO $ do

@@ -179,9 +179,10 @@ performRequest acceptStatus req = do

179179

180180 response <- maybe (requestWithoutCookieJar m request) (requestWithCookieJar m request) cookieJar'

181181 let status = Client.responseStatus response

182+ status_code = statusCode status

182183 ourResponse = clientResponseToResponse id response

183184 goodStatus = case acceptStatus of

184− Nothing -> statusIsSuccessful status

185+ Nothing -> status_code >= 200 && status_code < 300

185186 Just good -> status `elem` good

186187 unless goodStatus $ do

187188 throwError $ mkFailureResponse burl req ourResponse

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

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

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

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

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

233−defaultMakeClientRequest burl r = return Client.defaultRequest

233+defaultMakeClientRequest :: BaseUrl -> Request -> Client.Request

234+defaultMakeClientRequest burl r = Client.defaultRequest

234235 { Client.method = requestMethod r

235236 , Client.host = fromString $ baseUrlHost burl

236237 , Client.port = baseUrlPort burl

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

246247 where

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

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

249− toList $ requestHeaders r

250+ toList $requestHeaders r

250251

251252 acceptHdr

252253 | null hs = Nothing

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

289290 Https -> True

290291

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

292− buildQueryString [] = mempty

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

293+ buildQueryString = ("?" <>) . foldl' addQueryParam mempty

294294

295295 addQueryParam qs (k, v) =

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

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

@@ -24,8 +24,7 @@ import Control.DeepSeq

2424 (NFData, force)

2525import Control.Exception

2626 (evaluate, throwIO)

27−import Control.Monad

28− (unless)

27+import Control.Monad ()

2928import Control.Monad.Base

3029 (MonadBase (..))

3130import Control.Monad.Codensity

@@ -48,7 +47,7 @@ import Data.Time.Clock

4847 (getCurrentTime)

4948import GHC.Generics

5049import Network.HTTP.Types

51− (Status, statusIsSuccessful)

50+ (Status, statusCode)

5251

5352import qualified Network.HTTP.Client as Client

5453

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

141140performRequest acceptStatus req = do

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

143142 ClientEnv m burl cookieJar' createClientRequest <- ask

144− clientRequest <- liftIO $ createClientRequest burl req

143+ let clientRequest = createClientRequest burl req

145144 request <- case cookieJar' of

146145 Nothing -> pure clientRequest

147146 Just cj -> liftIO $ do

@@ -164,9 +163,10 @@ performRequest acceptStatus req = do

164163 now' <- getCurrentTime

165164 atomically $ modifyTVar' cj (fst . Client.updateCookieJar response request now')

166165 let status = Client.responseStatus response

166+ status_code = statusCode status

167167 ourResponse = clientResponseToResponse id response

168168 goodStatus = case acceptStatus of

169− Nothing -> statusIsSuccessful status

169+ Nothing -> status_code >= 200 && status_code < 300

170170 Just good -> status `elem` good

171171 unless goodStatus $ do

172172 throwError $ mkFailureResponse burl req ourResponse

@@ -175,27 +175,17 @@ performRequest acceptStatus req = do

175175-- | TODO: support UVerb ('acceptStatus' argument, like in 'performRequest' above).

176176performWithStreamingRequest :: Request -> (StreamingResponse -> IO a) -> ClientM a

177177performWithStreamingRequest req k = do

178− ClientEnv m burl cookieJar' createClientRequest <- ask

179− clientRequest <- liftIO $ createClientRequest burl req

180− request <- case cookieJar' of

181− Nothing -> pure clientRequest

182− Just cj -> liftIO $ do

183− now <- getCurrentTime

184− atomically $ do

185− oldCookieJar <- readTVar cj

186− let (newRequest, newCookieJar) =

187− Client.insertCookiesIntoRequest

188− clientRequest

189− oldCookieJar

190− now

191− writeTVar cj newCookieJar

192− pure newRequest

178+ m <- asks manager

179+ burl <- asks baseUrl

180+ createClientRequest <- asks makeClientRequest

181+ let request = createClientRequest burl req

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

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

195184 let status = Client.responseStatus res

185+ status_code = statusCode status

196186

197187 -- we throw FailureResponse in IO :(

198− unless (statusIsSuccessful status) $ do

188+ unless (status_code >= 200 && status_code < 300) $ do

199189 b <- BSL.fromChunks <$> Client.brConsume (Client.responseBody res)

200190 throwIO $ mkFailureResponse burl req (clientResponseToResponse (const b) res)

201191

servant-client/test/Servant/BrokenSpec.hsdeleted−71

@@ -1,71 +0,0 @@

1−{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE TypeOperators #-}

3−{-# OPTIONS_GHC -freduction-depth=100 #-}

4−{-# OPTIONS_GHC -fno-warn-orphans #-}

5−{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

6−

7−module Servant.BrokenSpec (spec) where

8−

9−import Prelude ()

10−import Prelude.Compat

11−

12−import Data.Monoid ()

13−import Data.Proxy

14−import qualified Network.HTTP.Types as HTTP

15−import Test.Hspec

16−

17−import Servant.API

18− ((:<|>) ((:<|>)), (:>), JSON, Verb, Get, StdMethod (GET))

19−import Servant.Client

20−import Servant.ClientTestUtils

21−import Servant.Server

22−

23−-- * api for testing inconsistencies between client and server

24−

25−type Get201 = Verb 'GET 201

26−type Get301 = Verb 'GET 301

27−

28−type BrokenAPI =

29− -- the server should respond with 200, but returns 201

30− "get200" :> Get201 '[JSON] ()

31− -- the server should respond with 307, but returns 301

32− :<|> "get307" :> Get301 '[JSON] ()

33−

34−brokenApi :: Proxy BrokenAPI

35−brokenApi = Proxy

36−

37−brokenServer :: Application

38−brokenServer = serve brokenApi (pure () :<|> pure ())

39−

40−type PublicAPI =

41− -- the client expects 200

42− "get200" :> Get '[JSON] ()

43− -- the client expects 307

44− :<|> "get307" :> Get307 '[JSON] ()

45−

46−publicApi :: Proxy PublicAPI

47−publicApi = Proxy

48−

49−get200Client :: ClientM ()

50−get307Client :: ClientM ()

51−get200Client :<|> get307Client = client publicApi

52−

53−

54−spec :: Spec

55−spec = describe "Servant.BrokenSpec" $ do

56− brokenSpec

57−

58−brokenSpec :: Spec

59−brokenSpec = beforeAll (startWaiApp brokenServer) $ afterAll endWaiApp $ do

60− context "client returns errors for inconsistencies between client and server api" $ do

61− it "reports FailureResponse with wrong 2xx status code" $ \(_, baseUrl) -> do

62− res <- runClient get200Client baseUrl

63− case res of

64− Left (FailureResponse _ r) | responseStatusCode r == HTTP.status201 -> return ()

65− _ -> fail $ "expected 201 broken response, but got " <> show res

66−

67− it "reports FailureResponse with wrong 3xx status code" $ \(_, baseUrl) -> do

68− res <- runClient get307Client baseUrl

69− case res of

70− Left (FailureResponse _ r) | responseStatusCode r == HTTP.status301 -> return ()

71− _ -> fail $ "expected 301 broken response, but got " <> show res

servant-client/test/Servant/ClientTestUtils.hs+9−31

@@ -64,11 +64,13 @@ import Servant.API

6464 JSON, MimeRender (mimeRender), MimeUnrender (mimeUnrender),

6565 NoContent (NoContent), PlainText, Post, QueryFlag, QueryParam,

6666 QueryParams, Raw, ReqBody, StdMethod (GET), ToHttpApiData (..), UVerb, Union,

67− Verb, WithStatus (WithStatus), NamedRoutes, addHeader)

68−import Servant.API.Generic ((:-))

67+ WithStatus (WithStatus), addHeader)

68+import Servant.API.Generic

6969import Servant.Client

70+import Servant.Client.Generic

7071import qualified Servant.Client.Core.Auth as Auth

7172import Servant.Server

73+import Servant.Server.Generic

7274import Servant.Server.Experimental.Auth

7375import Servant.Test.ComprehensiveAPI

7476

@@ -111,23 +113,16 @@ type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]

111113data RecordRoutes mode = RecordRoutes

112114 { version :: mode :- "version" :> Get '[JSON] Int

113115 , echo :: mode :- "echo" :> Capture "string" String :> Get '[JSON] String

114− , otherRoutes :: mode :- "other" :> Capture "someParam" Int :> NamedRoutes OtherRoutes

116+ , otherRoutes :: mode :- "other" :> NamedRoutes OtherRoutes

115117 } deriving Generic

116118

117119data OtherRoutes mode = OtherRoutes

118120 { something :: mode :- "something" :> Get '[JSON] [String]

119121 } deriving Generic

120122

121−-- Get for HTTP 307 Temporary Redirect

122−type Get307 = Verb 'GET 307

123−

124123type Api =

125124 Get '[JSON] Person

126125 :<|> "get" :> Get '[JSON] Person

127− -- This endpoint returns a response with status code 307 Temporary Redirect,

128− -- different from the ones in the 2xx successful class, to test derivation

129− -- of clients' api.

130− :<|> "get307" :> Get307 '[PlainText] Text

131126 :<|> "deleteEmpty" :> DeleteNoContent

132127 :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person

133128 :<|> "captureAll" :> CaptureAll "names" String :> Get '[JSON] [Person]

@@ -160,14 +155,13 @@ type Api =

160155 WithStatus 301 Text]

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

162157 :<|> NamedRoutes RecordRoutes

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

158+

164159

165160api :: Proxy Api

166161api = Proxy

167162

168163getRoot :: ClientM Person

169164getGet :: ClientM Person

170−getGet307 :: ClientM Text

171165getDeleteEmpty :: ClientM NoContent

172166getCapture :: String -> ClientM Person

173167getCaptureAll :: [String] -> ClientM [Person]

@@ -190,11 +184,9 @@ uverbGetSuccessOrRedirect :: Bool

190184 -> ClientM (Union '[WithStatus 200 Person,

191185 WithStatus 301 Text])

192186uverbGetCreated :: ClientM (Union '[WithStatus 201 Person])

193−recordRoutes :: RecordRoutes (AsClientT ClientM)

194187

195188getRoot

196189 :<|> getGet

197− :<|> getGet307

198190 :<|> getDeleteEmpty

199191 :<|> getCapture

200192 :<|> getCaptureAll

@@ -215,14 +207,12 @@ getRoot

215207 :<|> EmptyClient

216208 :<|> uverbGetSuccessOrRedirect

217209 :<|> uverbGetCreated

218− :<|> recordRoutes

219− :<|> captureVerbatim = client api

210+ :<|> recordRoutes = client api

220211

221212server :: Application

222213server = serve api (

223214 return carol

224215 :<|> return alice

225− :<|> return "redirecting"

226216 :<|> return NoContent

227217 :<|> (\ name -> return $ Person name 0)

228218 :<|> (\ names -> return (zipWith Person names [0..]))

@@ -257,15 +247,12 @@ server = serve api (

257247 :<|> RecordRoutes

258248 { version = pure 42

259249 , echo = pure

260− , otherRoutes = \_ -> OtherRoutes

250+ , otherRoutes = OtherRoutes

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

262252 }

263253 }

264− :<|> pure . decodeUtf8 . unVerbatim

265254 )

266255

267−-- * api for testing failures

268−

269256type FailApi =

270257 "get" :> Raw

271258 :<|> "capture" :> Capture "name" String :> Raw

@@ -280,7 +267,7 @@ failServer = serve failApi (

280267 :<|> (\ _capture -> Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "application/json")] "")

281268 :<|> (Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "fooooo")] "")

282269 :<|> (Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "application/x-www-form-urlencoded"), ("X-Example1", "1"), ("X-Example2", "foo")] "")

283− )

270+ )

284271

285272-- * basic auth stuff

286273

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

373360

374361instance FromHttpApiData UrlEncodedByteString where

375362 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/FailSpec.hs+3−3

@@ -38,14 +38,14 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do

3838

3939 context "client returns errors appropriately" $ do

4040 it "reports FailureResponse" $ \(_, baseUrl) -> do

41− let (_ :<|> _ :<|> _ :<|> getDeleteEmpty :<|> _) = client api

41+ let (_ :<|> _ :<|> getDeleteEmpty :<|> _) = client api

4242 Left res <- runClient getDeleteEmpty baseUrl

4343 case res of

4444 FailureResponse _ r | responseStatusCode r == HTTP.status404 -> return ()

4545 _ -> fail $ "expected 404 response, but got " <> show res

4646

4747 it "reports DecodeFailure" $ \(_, baseUrl) -> do

48− let (_ :<|> _ :<|> _ :<|> _ :<|> getCapture :<|> _) = client api

48+ let (_ :<|> _ :<|> _ :<|> getCapture :<|> _) = client api

4949 Left res <- runClient (getCapture "foo") baseUrl

5050 case res of

5151 DecodeFailure _ _ -> return ()

@@ -72,7 +72,7 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do

7272 _ -> fail $ "expected UnsupportedContentType, but got " <> show res

7373

7474 it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do

75− let (_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api

75+ let (_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api

7676 Left res <- runClient (getBody alice) baseUrl

7777 case res of

7878 InvalidContentTypeHeader _ -> return ()

servant-client/test/Servant/GenericSpec.hs+4−4

@@ -17,9 +17,9 @@

1717

1818module Servant.GenericSpec (spec) where

1919

20+import Data.Function ((&))

2021import Test.Hspec

2122

22−import Servant.Client ((//), (/:))

2323import Servant.ClientTestUtils

2424

2525spec :: Spec

@@ -31,7 +31,7 @@ genericSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do

3131 context "Record clients work as expected" $ do

3232

3333 it "Client functions return expected values" $ \(_,baseUrl) -> do

34− runClient (recordRoutes // version) baseUrl `shouldReturn` Right 42

35− runClient (recordRoutes // echo /: "foo") baseUrl `shouldReturn` Right "foo"

34+ runClient (recordRoutes & version) baseUrl `shouldReturn` Right 42

35+ runClient (recordRoutes & echo $ "foo") baseUrl `shouldReturn` Right "foo"

3636 it "Clients can be nested" $ \(_,baseUrl) -> do

37− runClient (recordRoutes // otherRoutes /: 42 // something) baseUrl `shouldReturn` Right ["foo", "bar", "pweet"]

37+ runClient (recordRoutes & otherRoutes & something) baseUrl `shouldReturn` Right ["foo", "bar", "pweet"]

servant-client/test/Servant/SuccessSpec.hs+6−21

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

3636import Data.Monoid ()

3737import Data.Text

3838 (Text)

39−import Data.Text.Encoding

40− (encodeUtf8)

4139import qualified Network.HTTP.Client as C

4240import qualified Network.HTTP.Types as HTTP

4341import Test.Hspec

@@ -61,15 +59,11 @@ spec = describe "Servant.SuccessSpec" $ do

6159

6260successSpec :: Spec

6361successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do

64− describe "Servant.API.Get" $ do

65− it "get root endpoint" $ \(_, baseUrl) -> do

66− left show <$> runClient getRoot baseUrl `shouldReturn` Right carol

62+ it "Servant.API.Get root" $ \(_, baseUrl) -> do

63+ left show <$> runClient getRoot baseUrl `shouldReturn` Right carol

6764

68− it "get simple endpoint" $ \(_, baseUrl) -> do

69− left show <$> runClient getGet baseUrl `shouldReturn` Right alice

70−

71− it "get redirection endpoint" $ \(_, baseUrl) -> do

72− left show <$> runClient getGet307 baseUrl `shouldReturn` Right "redirecting"

65+ it "Servant.API.Get" $ \(_, baseUrl) -> do

66+ left show <$> runClient getGet baseUrl `shouldReturn` Right alice

7367

7468 describe "Servant.API.Delete" $ do

7569 it "allows empty content type" $ \(_, baseUrl) -> do

@@ -117,7 +111,6 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do

117111

118112 it "Servant.API.Fragment" $ \(_, baseUrl) -> do

119113 left id <$> runClient getFragment baseUrl `shouldReturn` Right alice

120−

121114 it "Servant.API.Raw on success" $ \(_, baseUrl) -> do

122115 res <- runClient (getRawSuccess HTTP.methodGet) baseUrl

123116 case res of

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

162155 mgr <- C.newManager C.defaultManagerSettings

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

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

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

166− (defaultMakeClientRequest url r)

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

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

159+ let clientEnv = (mkClientEnv mgr baseUrl) { makeClientRequest = createClientRequest }

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

169161 case res of

170162 Left e ->

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

199191 case eitherResponse of

200192 Left clientError -> fail $ show clientError

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

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

1−cabal-version: 2.2

1+cabal-version: >=1.10

22name: servant-conduit

33version: 0.15.1

44

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

2323

2424source-repository head

2525 type: git

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

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

2727

2828library

2929 exposed-modules: Servant.Conduit

@@ -31,9 +31,9 @@ library

3131 base >=4.9 && <5

3232 , bytestring >=0.10.8.1 && <0.12

3333 , conduit >=1.3.1 && <1.4

34− , mtl ^>=2.2.2 || ^>=2.3.1

35− , resourcet >=1.2.2 && <1.4

36− , servant >=0.15 && <0.20

34+ , mtl >=2.2.2 && <2.3

35+ , resourcet >=1.2.2 && <1.3

36+ , servant >=0.15 && <0.19

3737 , unliftio-core >=0.1.2.0 && <0.3

3838 hs-source-dirs: src

3939 default-language: Haskell2010

@@ -54,8 +54,8 @@ test-suite example

5454 , resourcet

5555 , servant

5656 , servant-conduit

57− , servant-server >=0.15 && <0.20

58− , servant-client >=0.15 && <0.20

57+ , servant-server >=0.15 && <0.19

58+ , servant-client >=0.15 && <0.19

5959 , wai >=3.2.1.2 && <3.3

6060 , warp >=3.2.25 && <3.4

6161 , http-client

servant-docs/CHANGELOG.md−9

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

11[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-docs/CHANGELOG.md)

22[Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)

33

4−0.12

5−----

6−

7−### Significant changes

8−

9−- Generate sample cURL requests

10− ([#1401](https://github.com/haskell-servant/servant/pull/1401/files)).

11− Breaking change: requires sample header values to be supplied with `headers`.

12−

1340.11.9

145------

156

servant-docs/golden/comprehensive.md−18

@@ -530,24 +530,6 @@

530530

531531```

532532

533−## GET /resource

534−

535−### Response:

536−

537−- Status code 200

538−- Headers: []

539−

540−- Supported content types are:

541−

542− - `application/json;charset=utf-8`

543− - `application/json`

544−

545−- Example (`application/json;charset=utf-8`, `application/json`):

546−

547−```javascript

548−

549−```

550−

551533## GET /streaming

552534

553535### Request:

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

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

1−cabal-version: 2.2

1+cabal-version: >=1.10

22name: servant-docs

3−version: 0.12

3+version: 0.11.9

44

55synopsis: generate API docs for your servant webservice

66category: Servant, Web

@@ -41,25 +41,25 @@ library

4141 --

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

4343 build-depends:

44− base >= 4.9 && < 4.18

44+ base >= 4.9 && < 4.16

4545 , bytestring >= 0.10.8.1 && < 0.12

46− , text >= 1.2.3.0 && < 2.1

46+ , text >= 1.2.3.0 && < 1.3

4747

4848 -- Servant dependencies

4949 build-depends:

50− servant >= 0.18 && <0.20

50+ servant >= 0.18 && <0.19

5151

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

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

5454 build-depends:

55− aeson >= 1.4.1.0 && < 3

55+ aeson >= 1.4.1.0 && < 1.6

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

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

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

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

59− , hashable >= 1.2.7.0 && < 1.5

59+ , hashable >= 1.2.7.0 && < 1.4

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

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

62− , lens >= 4.17 && < 5.3

62+ , lens >= 4.17 && < 5.1

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

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

6262import Servant.API

6363import Servant.API.ContentTypes

6464import Servant.API.TypeLevel

65−import Servant.API.Generic

6665

6766import qualified Data.Universe.Helpers as U

6867

@@ -447,7 +446,7 @@ docsWith opts intros (ExtraInfo endpoints) p =

447446 & apiEndpoints %~ HM.unionWith (flip combineAction) endpoints

448447

449448

450−-- | Generate the docs for a given API that implements 'HasDocs' with any

449+-- | Generate the docs for a given API that implements 'HasDocs' with with any

451450-- number of introduction(s)

452451docsWithIntros :: HasDocs api => [DocIntro] -> Proxy api -> API

453452docsWithIntros intros = docsWith defaultDocOptions intros mempty

@@ -1144,9 +1143,6 @@ instance HasDocs api => HasDocs (Vault :> api) where

11441143instance HasDocs api => HasDocs (WithNamedContext name context api) where

11451144 docsFor Proxy = docsFor (Proxy :: Proxy api)

11461145

1147−instance HasDocs api => HasDocs (WithResource res :> api) where

1148− docsFor Proxy = docsFor (Proxy :: Proxy api)

1149−

11501146instance (ToAuthInfo (BasicAuth realm usr), HasDocs api) => HasDocs (BasicAuth realm usr :> api) where

11511147 docsFor Proxy (endpoint, action) =

11521148 docsFor (Proxy :: Proxy api) (endpoint, action')

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

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

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

11561152

1157−instance HasDocs (ToServantApi api) => HasDocs (NamedRoutes api) where

1158− docsFor Proxy = docsFor (Proxy :: Proxy (ToServantApi api))

1159−

11601153-- ToSample instances for simple types

11611154instance ToSample NoContent

11621155instance ToSample Bool

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

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

1−cabal-version: 2.2

1+cabal-version: >=1.10

22name: servant-foreign

33version: 0.15.4

44

@@ -41,18 +41,18 @@ library

4141 --

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

4343 build-depends:

44− base >= 4.9 && < 4.18

45− , text >= 1.2.3.0 && < 2.1

44+ base >= 4.9 && < 4.16

45+ , text >= 1.2.3.0 && < 1.3

4646

4747 -- Servant dependencies

4848 build-depends:

49− servant >=0.18 && <0.20

49+ servant >=0.18 && <0.19

5050

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

55− , lens >= 4.17 && < 5.3

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

55+ , lens >= 4.17 && < 5.1

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

77+ hspec >= 2.6.0 && <2.9

7878 build-tool-depends:

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

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

8080 default-language: Haskell2010

servant-foreign/src/Servant/Foreign/Internal.hs−7

@@ -487,13 +487,6 @@ instance HasForeign lang ftype api =>

487487

488488 foreignFor lang ftype Proxy = foreignFor lang ftype (Proxy :: Proxy api)

489489

490−instance HasForeign lang ftype api =>

491− HasForeign lang ftype (WithResource res :> api) where

492−

493− type Foreign ftype (WithResource res :> api) = Foreign ftype api

494−

495− foreignFor lang ftype Proxy = foreignFor lang ftype (Proxy :: Proxy api)

496−

497490instance HasForeign lang ftype api

498491 => HasForeign lang ftype (HttpVersion :> api) where

499492 type Foreign ftype (HttpVersion :> api) = Foreign ftype api

servant-http-streams/CHANGELOG.md−10

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

11 [The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-http-streams/CHANGELOG.md)

22[Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)

33

4−0.18.4

5−------

6−

7−### Significant changes

8−

9−- *servant-client* / *servant-client-core* / *servant-http-streams*:

10− Fix erroneous behavior, where only 2XX status codes would be considered

11− successful, irrelevant of the status parameter specified by the verb

12− combinator. ([#1469](https://github.com/haskell-servant/servant/pull/1469))

13−

1440.18.3

155------

166

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

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

1−cabal-version: 2.2

1+cabal-version: >=1.10

22name: servant-http-streams

3−version: 0.18.4

3+version: 0.18.3

44

55synopsis: Automatic derivation of querying functions for servant

66category: Servant, Web

@@ -38,14 +38,14 @@ 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.18

41+ base >= 4.9 && < 4.16

4242 , bytestring >= 0.10.8.1 && < 0.12

4343 , containers >= 0.5.7.1 && < 0.7

4444 , deepseq >= 1.4.2.0 && < 1.5

45− , mtl ^>= 2.2.2 || ^>= 2.3.1

46− , text >= 1.2.3.0 && < 2.1

47− , time >= 1.6.0.1 && < 1.13

48− , transformers >= 0.5.2.0 && < 0.7

45+ , mtl >= 2.2.2 && < 2.3

46+ , text >= 1.2.3.0 && < 1.3

47+ , time >= 1.6.0.1 && < 1.10

48+ , transformers >= 0.5.2.0 && < 0.6

4949

5050 if !impl(ghc >= 8.2)

5151 build-depends:

@@ -54,25 +54,25 @@ library

5454 -- Servant dependencies.

5555 -- Strict dependency on `servant-client-core` as we re-export things.

5656 build-depends:

57− servant >= 0.18 && < 0.20

58− , servant-client-core >= 0.18.3 && <0.20

57+ servant == 0.18.*

58+ , servant-client-core >= 0.18.3 && <0.18.4

5959

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

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

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

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

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

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

7676

7777 hs-source-dirs: src

7878 default-language: Haskell2010

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

112112 -- Additional dependencies

113113 build-depends:

114114 entropy >= 0.4.1.3 && < 0.5

115− , hspec >= 2.6.0 && < 2.10

115+ , hspec >= 2.6.0 && < 2.9

116116 , HUnit >= 1.6.0.0 && < 1.7

117117 , network >= 2.8.0.0 && < 3.2

118118 , QuickCheck >= 2.12.6.1 && < 2.15

119− , servant == 0.19.*

120− , servant-server == 0.19.*

119+ , servant == 0.18.*

120+ , servant-server == 0.18.*

121121 , tdigest >= 0.2 && < 0.3

122122

123123 build-tool-depends:

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

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

125125

126126test-suite readme

127127 type: exitcode-stdio-1.0

servant-http-streams/src/Servant/HttpStreams/Internal.hs+6−6

@@ -57,7 +57,7 @@ import GHC.Generics

5757import Network.HTTP.Media

5858 (renderHeader)

5959import Network.HTTP.Types

60− (Status (..), hContentType, http11, renderQuery, statusIsSuccessful)

60+ (Status (..), hContentType, http11, renderQuery)

6161import Servant.Client.Core

6262

6363import qualified Network.Http.Client as Client

@@ -160,12 +160,12 @@ performRequest acceptStatus req = do

160160 x <- ClientM $ lift $ lift $ Codensity $ \k -> do

161161 Client.sendRequest conn req' body

162162 Client.receiveResponse conn $ \res' body' -> do

163− let status = toEnum $ Client.getStatusCode res'

163+ let sc = Client.getStatusCode res'

164164 lbs <- BSL.fromChunks <$> Streams.toList body'

165165 let res'' = clientResponseToResponse res' lbs

166166 goodStatus = case acceptStatus of

167− Nothing -> statusIsSuccessful status

168− Just good -> status `elem` good

167+ Nothing -> sc >= 200 && sc < 300

168+ Just good -> sc `elem` (statusCode <$> good)

169169 if goodStatus

170170 then k (Right res'')

171171 else k (Left (mkFailureResponse burl req res''))

@@ -180,8 +180,8 @@ performWithStreamingRequest req k = do

180180 Client.sendRequest conn req' body

181181 Client.receiveResponseRaw conn $ \res' body' -> do

182182 -- check status code

183− let status = toEnum $ Client.getStatusCode res'

184− unless (statusIsSuccessful status) $ do

183+ let sc = Client.getStatusCode res'

184+ unless (sc >= 200 && sc < 300) $ do

185185 lbs <- BSL.fromChunks <$> Streams.toList body'

186186 throwIO $ mkFailureResponse burl req (clientResponseToResponse res' lbs)

187187

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

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

1−cabal-version: 2.2

1+cabal-version: >=1.10

22name: servant-machines

33version: 0.15.1

44

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

2323

2424source-repository head

2525 type: git

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

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

2727

2828library

2929 exposed-modules: Servant.Machines

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

3131 base >=4.9 && <5

3232 , bytestring >=0.10.8.1 && <0.12

3333 , machines >=0.6.4 && <0.8

34− , mtl ^>=2.2.2 || ^>=2.3.1

35− , servant >=0.15 && <0.20

34+ , mtl >=2.2.2 && <2.3

35+ , servant >=0.15 && <0.19

3636 hs-source-dirs: src

3737 default-language: Haskell2010

3838 ghc-options: -Wall

@@ -51,8 +51,8 @@ test-suite example

5151 , servant

5252 , machines

5353 , servant-machines

54− , servant-server >=0.15 && <0.20

55− , servant-client >=0.15 && <0.20

54+ , servant-server >=0.15 && <0.19

55+ , servant-client >=0.15 && <0.19

5656 , wai >=3.2.1.2 && <3.3

5757 , warp >=3.2.25 && <3.4

5858 , http-client

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

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

1−cabal-version: 2.2

1+cabal-version: >=1.10

22name: servant-pipes

33version: 0.15.3

44

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

2323

2424source-repository head

2525 type: git

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

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

2727

2828library

2929 exposed-modules: Servant.Pipes

@@ -32,9 +32,9 @@ library

3232 , bytestring >=0.10.8.1 && <0.12

3333 , pipes >=4.3.9 && <4.4

3434 , pipes-safe >=2.3.1 && <2.4

35− , mtl ^>=2.2.2 || ^>=2.3.1

35+ , mtl >=2.2.2 && <2.3

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

37− , servant >=0.15 && <0.20

37+ , servant >=0.15 && <0.19

3838 hs-source-dirs: src

3939 default-language: Haskell2010

4040 ghc-options: -Wall

@@ -51,12 +51,12 @@ test-suite example

5151 , bytestring

5252 , http-media

5353 , servant

54− , pipes

54+ , pipes

5555 , pipes-safe

5656 , servant-pipes

5757 , pipes-bytestring >=2.1.6 && <2.2

58− , servant-server >=0.15 && <0.20

59− , servant-client >=0.15 && <0.20

58+ , servant-server >=0.15 && <0.19

59+ , servant-client >=0.15 && <0.19

6060 , wai >=3.2.1.2 && <3.3

6161 , warp >=3.2.25 && <3.4

6262 , http-client

servant-server/CHANGELOG.md−30

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

11[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-server/CHANGELOG.md)

22[Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)

33

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

5−

6−0.19.2

7−------

8−

9−Compatibility with GHC 9.4, see [PR #1592](https://github.com/haskell-servant/servant/pull/1592).

10−

11−0.19.1

12−------

13−

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

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

16−- Add capture hints in `Router` type for debug and display purposes [PR #1556] (https://github.com/haskell-servant/servant/pull/1556)

17−

18−0.19

19−----

20−

21−### Significant changes

22−

23−- Drop support for GHC < 8.6.

24−- Support GHC 9.0 (GHC 9.2 should work as well, but isn't fully tested yet).

25−- Support Aeson 2 ([#1475](https://github.com/haskell-servant/servant/pull/1475)),

26− which fixes a [DOS vulnerability](https://github.com/haskell/aeson/issues/864)

27− related to hash collisions.

28−- Add `NamedRoutes` combinator, making support for records first-class in Servant

29− ([#1388](https://github.com/haskell-servant/servant/pull/1388)).

30−- Add custom type errors for partially applied combinators

31− ([#1289](https://github.com/haskell-servant/servant/pull/1289),

32− [#1486](https://github.com/haskell-servant/servant/pull/1486)).

33−

3440.18.3

355------

366

servant-server/example/greet.hs+1

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

1818

1919import Servant

2020import Servant.Server.Generic ()

21+import Servant.API.Generic

2122

2223-- * Example

2324

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

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

1−cabal-version: 2.2

1+cabal-version: >=1.10

22name: servant-server

3−version: 0.19.2

3+version: 0.18.3

44

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

66category: Servant, Web

@@ -23,7 +23,7 @@ author: Servant Contributors

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

2424copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors

2525build-type: Simple

26−tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.4 || ==9.4.3

26+tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1

2727

2828extra-source-files:

2929 CHANGELOG.md

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

63+ base >= 4.9 && < 4.16

6464 , bytestring >= 0.10.8.1 && < 0.12

65− , constraints >= 0.2 && < 0.14

65+ , constraints

6666 , containers >= 0.5.7.1 && < 0.7

67− , mtl ^>= 2.2.2 || ^>= 2.3.1

68− , text >= 1.2.3.0 && < 2.1

69− , transformers >= 0.5.2.0 && < 0.7

67+ , mtl >= 2.2.2 && < 2.3

68+ , text >= 1.2.3.0 && < 1.3

69+ , 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 && < 0.20

76− , http-api-data >= 0.4.1 && < 0.5.1

75+ servant >= 0.18.3 && < 0.18.4

76+ , 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.13

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

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

@@ -88,10 +88,10 @@ library

8888 , network >= 2.8 && < 3.2

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

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

91− , resourcet >= 1.2.2 && < 1.4

91+ , resourcet >= 1.2.2 && < 1.3

9292 , tagged >= 0.8.6 && < 0.9

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

94− , wai >= 3.2.2.1 && < 3.3

94+ , wai >= 3.2.1.2 && < 3.3

9595 , wai-app-static >= 3.1.6.2 && < 3.2

9696 , word8 >= 0.1.3 && < 0.2

9797

@@ -114,7 +114,7 @@ executable greet

114114 , text

115115

116116 build-depends:

117− aeson >= 1.4.1.0 && < 3

117+ aeson >= 1.4.1.0 && < 1.6

118118 , warp >= 3.2.25 && < 3.4

119119

120120test-suite spec

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

157157

158158 -- Additional dependencies

159159 build-depends:

160− aeson >= 1.4.1.0 && < 3

160+ aeson >= 1.4.1.0 && < 1.6

161161 , directory >= 1.3.0.0 && < 1.4

162− , hspec >= 2.6.0 && < 2.10

162+ , hspec >= 2.6.0 && < 2.9

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

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

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

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

235235-- > │ └─ e/

236236-- > │ └─•

237237-- > ├─ b/

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

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

239239-- > │ ├─•

240240-- > │ ┆

241241-- > │ └─•

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

252252--

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

254254--

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

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

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

257256--

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

259258--

servant-server/src/Servant/Server/Experimental/Auth.hs+1−2

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

11{-# OPTIONS_GHC -fno-warn-orphans #-}

22{-# LANGUAGE DeriveDataTypeable #-}

3−{-# LANGUAGE DeriveFunctor #-}

43{-# LANGUAGE DeriveGeneric #-}

54{-# LANGUAGE FlexibleContexts #-}

65{-# LANGUAGE FlexibleInstances #-}

@@ -45,7 +44,7 @@ type family AuthServerData a :: *

4544-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE

4645newtype AuthHandler r usr = AuthHandler

4746 { unAuthHandler :: r -> Handler usr }

48− deriving (Functor, Generic, Typeable)

47+ deriving (Generic, Typeable)

4948

5049-- | NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE

5150mkAuthHandler :: (r -> Handler usr) -> AuthHandler r usr

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

@@ -1,9 +1,25 @@

1+{-# OPTIONS_GHC -fno-warn-orphans #-}

2+{-# LANGUAGE AllowAmbiguousTypes #-}

3+{-# LANGUAGE ConstraintKinds #-}

4+{-# LANGUAGE CPP #-}

15{-# LANGUAGE DataKinds #-}

6+{-# LANGUAGE DefaultSignatures #-}

27{-# LANGUAGE FlexibleContexts #-}

8+{-# LANGUAGE FlexibleInstances #-}

9+{-# LANGUAGE InstanceSigs #-}

10+{-# LANGUAGE KindSignatures #-}

11+{-# LANGUAGE MultiParamTypeClasses #-}

12+{-# LANGUAGE QuantifiedConstraints #-}

313{-# LANGUAGE RankNTypes #-}

414{-# LANGUAGE ScopedTypeVariables #-}

15+{-# LANGUAGE TypeApplications #-}

516{-# LANGUAGE TypeFamilies #-}

617{-# LANGUAGE TypeOperators #-}

18+{-# LANGUAGE UndecidableInstances #-}

19+

20+#if __GLASGOW_HASKELL__ >= 806

21+{-# LANGUAGE QuantifiedConstraints #-}

22+#endif

723

824-- | @since 0.14.1

925module Servant.Server.Generic (

@@ -13,16 +29,29 @@ module Servant.Server.Generic (

1329 genericServeT,

1430 genericServeTWithContext,

1531 genericServer,

16− genericServerT

32+ genericServerT,

33+ -- * Internal machinery

34+ GServerConstraints,

35+ GServer,

36+ -- * Re-exports

37+ NamedRoutes

1738 ) where

1839

40+import Data.Constraint

1941import Data.Proxy

2042 (Proxy (..))

2143

22−import Servant.Server

2344import Servant.API.Generic

45+import Servant.Server

2446import Servant.Server.Internal

2547

48+-- | A type that specifies that an API record contains a server implementation.

49+data AsServerT (m :: * -> *)

50+instance GenericMode (AsServerT m) where

51+ type AsServerT m :- api = ServerT api m

52+

53+type AsServer = AsServerT Handler

54+

2655-- | Transform a record of routes into a WAI 'Application'.

2756genericServe

2857 :: forall routes.

@@ -90,3 +119,67 @@ genericServerT

90119 -> ToServant routes (AsServerT m)

91120genericServerT = toServant

92121

122+#if __GLASGOW_HASKELL__ >= 806

123+

124+-- | Set of constraints required to convert to / from vanilla server types.

125+type GServerConstraints api m =

126+ ( ToServant api (AsServerT m) ~ ServerT (ToServantApi api) m

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

128+ )

129+

130+-- | This class is a necessary evil: in the implementation of 'HasServer' for

131+-- @'NamedRoutes' api@, we essentially need the quantified constraint @forall

132+-- m. 'GServerConstraints' m@ to hold.

133+--

134+-- We cannot require do that directly as the definition of 'GServerConstraints'

135+-- contains type family applications ('Rep' and 'ServerT'). The trick is to hide

136+-- those type family applications behind a typeclass providing evidence for

137+-- @'GServerConstraints' api m@ in the form of a dictionary, and require that

138+-- @forall m. 'GServer' api m@ instead.

139+--

140+-- Users shouldn't have to worry about this class, as the only possible instance

141+-- is provided in this module for all record APIs.

142+

143+class GServer (api :: * -> *) (m :: * -> *) where

144+ proof :: Dict (GServerConstraints api m)

145+

146+instance

147+ ( ToServant api (AsServerT m) ~ ServerT (ToServantApi api) m

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

149+ ) => GServer api m where

150+ proof = Dict

151+

152+instance

153+ ( HasServer (ToServantApi api) context

154+ , forall m. Generic (api (AsServerT m))

155+ , forall m. GServer api m

156+ ) => HasServer (NamedRoutes api) context where

157+

158+ type ServerT (NamedRoutes api) m = api (AsServerT m)

159+

160+ route

161+ :: Proxy (NamedRoutes api)

162+ -> Context context

163+ -> Delayed env (api (AsServerT Handler))

164+ -> Router env

165+ route _ ctx delayed =

166+ case proof @api @Handler of

167+ Dict -> route (Proxy @(ToServantApi api)) ctx (toServant <$> delayed)

168+

169+ hoistServerWithContext

170+ :: forall m n. Proxy (NamedRoutes api)

171+ -> Proxy context

172+ -> (forall x. m x -> n x)

173+ -> api (AsServerT m)

174+ -> api (AsServerT n)

175+ hoistServerWithContext _ pctx nat server =

176+ case (proof @api @m, proof @api @n) of

177+ (Dict, Dict) ->

178+ fromServant servantSrvN

179+ where

180+ servantSrvM :: ServerT (ToServantApi api) m =

181+ toServant server

182+ servantSrvN :: ServerT (ToServantApi api) n =

183+ hoistServerWithContext (Proxy @(ToServantApi api)) pctx nat servantSrvM

184+

185+#endif

servant-server/src/Servant/Server/Internal.hs+56−192

@@ -1,24 +1,23 @@

1−{-# LANGUAGE AllowAmbiguousTypes #-}

2−{-# LANGUAGE ConstraintKinds #-}

31{-# LANGUAGE CPP #-}

2+{-# LANGUAGE ConstraintKinds #-}

43{-# LANGUAGE DataKinds #-}

54{-# LANGUAGE DeriveDataTypeable #-}

65{-# LANGUAGE FlexibleContexts #-}

76{-# LANGUAGE FlexibleInstances #-}

8−{-# LANGUAGE InstanceSigs #-}

9−{-# LANGUAGE LambdaCase #-}

107{-# LANGUAGE MultiParamTypeClasses #-}

118{-# LANGUAGE OverloadedStrings #-}

129{-# LANGUAGE PolyKinds #-}

13−{-# LANGUAGE QuantifiedConstraints #-}

1410{-# LANGUAGE RankNTypes #-}

1511{-# LANGUAGE ScopedTypeVariables #-}

1612{-# LANGUAGE TupleSections #-}

17−{-# LANGUAGE TypeApplications #-}

1813{-# LANGUAGE TypeFamilies #-}

1914{-# LANGUAGE TypeOperators #-}

2015{-# LANGUAGE UndecidableInstances #-}

2116

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

18+#define HAS_TYPE_ERROR

19+#endif

20+

2221module Servant.Server.Internal

2322 ( module Servant.Server.Internal

2423 , module Servant.Server.Internal.BasicAuth

@@ -36,15 +35,13 @@ module Servant.Server.Internal

3635import Control.Monad

3736 (join, when)

3837import Control.Monad.Trans

39− (liftIO, lift)

38+ (liftIO)

4039import Control.Monad.Trans.Resource

41− (runResourceT, ReleaseKey)

42−import Data.Acquire

40+ (runResourceT)

4341import qualified Data.ByteString as B

4442import qualified Data.ByteString.Builder as BB

4543import qualified Data.ByteString.Char8 as BC8

4644import qualified Data.ByteString.Lazy as BL

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

4845import Data.Either

4946 (partitionEithers)

5047import Data.Maybe

@@ -57,16 +54,15 @@ import Data.Tagged

5754 (Tagged (..), retag, untag)

5855import qualified Data.Text as T

5956import Data.Typeable

60−import GHC.Generics

6157import GHC.TypeLits

62− (KnownNat, KnownSymbol, TypeError, symbolVal)

58+ (KnownNat, KnownSymbol, natVal, symbolVal)

6359import qualified Network.HTTP.Media as NHM

6460import Network.HTTP.Types hiding

6561 (Header, ResponseHeaders)

6662import Network.Socket

6763 (SockAddr)

6864import Network.Wai

69− (Application, Request, Response, ResponseReceived, httpVersion, isSecure, lazyRequestBody,

65+ (Application, Request, httpVersion, isSecure, lazyRequestBody,

7066 queryString, remoteHost, getRequestBodyChunk, requestHeaders,

7167 requestMethod, responseLBS, responseStream, vault)

7268import Prelude ()

@@ -76,11 +72,10 @@ import Servant.API

7672 CaptureAll, Description, EmptyAPI, Fragment,

7773 FramingRender (..), FramingUnrender (..), FromSourceIO (..),

7874 Header', If, IsSecure (..), NoContentVerb, QueryFlag,

79− QueryParam', QueryParams, Raw, RawM, ReflectMethod (reflectMethod),

75+ QueryParam', QueryParams, Raw, ReflectMethod (reflectMethod),

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

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

82− WithNamedContext, WithResource, NamedRoutes)

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

78+ WithNamedContext)

8479import Servant.API.ContentTypes

8580 (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),

8681 AllMime, MimeRender (..), MimeUnrender (..), NoContent,

@@ -90,15 +85,10 @@ import Servant.API.Modifiers

9085 unfoldRequestArgument)

9186import Servant.API.ResponseHeaders

9287 (GetHeaders, Headers, getHeaders, getResponse)

93−import Servant.API.Status

94− (statusFromNat)

9588import qualified Servant.Types.SourceT as S

96−import Servant.API.TypeErrors

9789import Web.HttpApiData

9890 (FromHttpApiData, parseHeader, parseQueryParam, parseUrlPiece,

9991 parseUrlPieces)

100−import Data.Kind

101− (Type)

10292

10393import Servant.Server.Internal.BasicAuth

10494import Servant.Server.Internal.Context

@@ -111,16 +101,14 @@ import Servant.Server.Internal.RouteResult

111101import Servant.Server.Internal.RoutingApplication

112102import Servant.Server.Internal.ServerError

113103

104+#ifdef HAS_TYPE_ERROR

114105import GHC.TypeLits

115106 (ErrorMessage (..), TypeError)

116107import Servant.API.TypeLevel

117108 (AtLeastOneFragment, FragmentUnique)

109+#endif

118110

119111class HasServer api context where

120− -- | The type of a server for this API, given a monad to run effects in.

121− --

122− -- Note that the result kind is @*@, so it is /not/ a monad transformer, unlike

123− -- what the @T@ in the name might suggest.

124112 type ServerT api (m :: * -> *) :: *

125113

126114 route ::

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

182170-- > server = getBook

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

184172-- > getBook isbn = ...

185−instance (KnownSymbol capture, FromHttpApiData a, Typeable a

173+instance (KnownSymbol capture, FromHttpApiData a

186174 , HasServer api context, SBoolI (FoldLenient mods)

187175 , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters

188176 )

@@ -194,7 +182,7 @@ instance (KnownSymbol capture, FromHttpApiData a, Typeable a

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

195183

196184 route Proxy context d =

197− CaptureRouter [hint] $

185+ CaptureRouter $

198186 route (Proxy :: Proxy api)

199187 context

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

@@ -206,7 +194,6 @@ instance (KnownSymbol capture, FromHttpApiData a, Typeable a

206194 where

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

208196 formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)

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

210197

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

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

@@ -225,7 +212,7 @@ instance (KnownSymbol capture, FromHttpApiData a, Typeable a

225212-- > server = getSourceFile

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

227214-- > getSourceFile pathSegments = ...

228−instance (KnownSymbol capture, FromHttpApiData a, Typeable a

215+instance (KnownSymbol capture, FromHttpApiData a

229216 , HasServer api context

230217 , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters

231218 )

@@ -237,7 +224,7 @@ instance (KnownSymbol capture, FromHttpApiData a, Typeable a

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

238225

239226 route Proxy context d =

240− CaptureAllRouter [hint] $

227+ CaptureAllRouter $

241228 route (Proxy :: Proxy api)

242229 context

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

@@ -248,43 +235,6 @@ instance (KnownSymbol capture, FromHttpApiData a, Typeable a

248235 where

249236 rep = typeRep (Proxy :: Proxy CaptureAll)

250237 formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)

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

252−

253−-- | If you use 'WithResource' in one of the endpoints for your API Servant

254−-- will provide the handler for this endpoint an argument of the specified type.

255−-- The lifespan of this resource will be automatically managed by Servant. This

256−-- resource will be created before the handler starts and it will be destoyed

257−-- after it ends. A new resource is created for each request to the endpoint.

258−

259−-- The creation and destruction are done using a 'Data.Acquire.Acquire'

260−-- provided via server 'Context'.

261−--

262−-- Example

263−--

264−-- > type MyApi = WithResource Handle :> "writeToFile" :> Post '[JSON] NoContent

265−-- >

266−-- > server :: Server MyApi

267−-- > server = writeToFile

268−-- > where writeToFile :: (ReleaseKey, Handle) -> Handler NoContent

269−-- > writeToFile (_, h) = hPutStrLn h "message"

270−--

271−-- In addition to the resource, the handler will also receive a 'ReleaseKey'

272−-- which can be used to deallocate the resource before the end of the request

273−-- if desired.

274−

275−instance (HasServer api ctx, HasContextEntry ctx (Acquire a))

276− => HasServer (WithResource a :> api) ctx where

277−

278− type ServerT (WithResource a :> api) m = (ReleaseKey, a) -> ServerT api m

279−

280− hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy @api) pc nt . s

281−

282− route Proxy context d = route (Proxy @api) context (d `addParameterCheck` allocateResource)

283− where

284− allocateResource :: DelayedIO (ReleaseKey, a)

285− allocateResource = DelayedIO $ lift $ allocateAcquire (getContextEntry context)

286−

287−

288238

289239allowedMethodHead :: Method -> Request -> Bool

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

@@ -348,7 +298,7 @@ instance {-# OVERLAPPABLE #-}

348298

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

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

351− status = statusFromNat (Proxy :: Proxy status)

301+ status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)

352302

353303instance {-# OVERLAPPING #-}

354304 ( AllCTRender ctypes a, ReflectMethod method, KnownNat status

@@ -360,7 +310,7 @@ instance {-# OVERLAPPING #-}

360310

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

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

363− status = statusFromNat (Proxy :: Proxy status)

313+ status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)

364314

365315instance (ReflectMethod method) =>

366316 HasServer (NoContentVerb method) context where

@@ -381,7 +331,7 @@ instance {-# OVERLAPPABLE #-}

381331

382332 route Proxy _ = streamRouter ([],) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)

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

384− status = statusFromNat (Proxy :: Proxy status)

334+ status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)

385335

386336

387337instance {-# OVERLAPPING #-}

@@ -395,7 +345,7 @@ instance {-# OVERLAPPING #-}

395345

396346 route Proxy _ = streamRouter (\x -> (getHeaders x, getResponse x)) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)

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

398− status = statusFromNat (Proxy :: Proxy status)

348+ status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)

399349

400350

401351streamRouter :: forall ctype a c chunk env framing. (MimeRender ctype chunk, FramingRender framing, ToSourceIO chunk a) =>

@@ -653,35 +603,6 @@ instance HasServer Raw context where

653603 Fail a -> respond $ Fail a

654604 FailFatal e -> respond $ FailFatal e

655605

656−-- | Just pass the request to the underlying application and serve its response.

657−--

658−-- Example:

659−--

660−-- > type MyApi = "images" :> Raw

661−-- >

662−-- > server :: Server MyApi

663−-- > server = serveDirectory "/var/www/images"

664−instance HasServer RawM context where

665− type ServerT RawM m = Request -> (Response -> IO ResponseReceived) -> m ResponseReceived

666−

667− route

668− :: Proxy RawM

669− -> Context context

670− -> Delayed env (Request -> (Response -> IO ResponseReceived) -> Handler ResponseReceived) -> Router env

671− route _ _ handleDelayed = RawRouter $ \env request respond -> runResourceT $ do

672− routeResult <- runDelayed handleDelayed env request

673− let respond' = liftIO . respond

674− liftIO $ case routeResult of

675− Route handler -> runHandler (handler request (respond . Route)) >>=

676− \case

677− Left e -> respond' $ FailFatal e

678− Right a -> pure a

679− Fail e -> respond' $ Fail e

680− FailFatal e -> respond' $ FailFatal e

681−

682− hoistServerWithContext _ _ f srvM = \req respond -> f (srvM req respond)

683−

684−

685606-- | If you use 'ReqBody' in one of the endpoints for your API,

686607-- this automatically requires your server-side handler to be a function

687608-- that takes an argument of the type specified by 'ReqBody'.

@@ -863,7 +784,7 @@ instance ( KnownSymbol realm

863784-- * helpers

864785

865786ct_wildcard :: B.ByteString

866−ct_wildcard = "*" <> "/" <> "*"

787+ct_wildcard = "*" <> "/" <> "*" -- Because CPP

867788

868789getAcceptHeader :: Request -> AcceptHeader

869790getAcceptHeader = AcceptHeader . fromMaybe ct_wildcard . lookup hAccept . requestHeaders

@@ -891,19 +812,39 @@ instance (HasContextEntry context (NamedContext name subContext), HasServer subA

891812 hoistServerWithContext _ _ nt s = hoistServerWithContext (Proxy :: Proxy subApi) (Proxy :: Proxy subContext) nt s

892813

893814-------------------------------------------------------------------------------

894−-- Custom type errors

815+-- TypeError helpers

895816-------------------------------------------------------------------------------

896817

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

898−instance TypeError (PartialApplication

899−#if __GLASGOW_HASKELL__ >= 904

900− @(Type -> [Type] -> Constraint)

901−#endif

902− HasServer arr) => HasServer ((arr :: a -> b) :> sub) context

818+#ifdef HAS_TYPE_ERROR

819+-- | This instance catches mistakes when there are non-saturated

820+-- type applications on LHS of ':>'.

821+--

822+-- >>> serve (Proxy :: Proxy (Capture "foo" :> Get '[JSON] Int)) (error "...")

823+-- ...

824+-- ...Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'.

825+-- ...Maybe you haven't applied enough arguments to

826+-- ...Capture' '[] "foo"

827+-- ...

828+--

829+-- >>> undefined :: Server (Capture "foo" :> Get '[JSON] Int)

830+-- ...

831+-- ...Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'.

832+-- ...Maybe you haven't applied enough arguments to

833+-- ...Capture' '[] "foo"

834+-- ...

835+--

836+instance TypeError (HasServerArrowKindError arr) => HasServer ((arr :: k -> l) :> api) context

903837 where

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

905− route = error "unreachable"

906− hoistServerWithContext _ _ _ _ = error "unreachable"

838+ type ServerT (arr :> api) m = TypeError (HasServerArrowKindError arr)

839+ -- it doesn't really matter what sub route we peak

840+ route _ _ _ = error "servant-server panic: impossible happened in HasServer (arr :> api)"

841+ hoistServerWithContext _ _ _ = id

842+

843+-- Cannot have TypeError here, otherwise use of this symbol will error :)

844+type HasServerArrowKindError arr =

845+ 'Text "Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'."

846+ ':$$: 'Text "Maybe you haven't applied enough arguments to"

847+ ':$$: 'ShowType arr

907848

908849-- | This instance prevents from accidentally using '->' instead of ':>'

909850--

@@ -937,19 +878,7 @@ type HasServerArrowTypeError a b =

937878 ':$$: 'ShowType a

938879 ':$$: 'Text "and"

939880 ':$$: 'ShowType b

940−

941−-- Erroring instances for 'HasServer' for unknown API combinators

942−

943−-- XXX: This omits the @context@ parameter, e.g.:

944−--

945−-- "There is no instance for HasServer (Bool :> …)". Do we care ?

946−instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub

947−#if __GLASGOW_HASKELL__ >= 904

948− @(Type -> [Type] -> Constraint)

949881#endif

950− HasServer ty) => HasServer (ty :> sub) context

951−

952−instance {-# OVERLAPPABLE #-} TypeError (NoInstanceFor (HasServer api context)) => HasServer api context

953882

954883-- | Ignore @'Fragment'@ in server handlers.

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

@@ -962,7 +891,11 @@ instance {-# OVERLAPPABLE #-} TypeError (NoInstanceFor (HasServer api context))

962891-- > server = getBooks

963892-- > where getBooks :: Handler [Book]

964893-- > getBooks = ...return all books...

894+#ifdef HAS_TYPE_ERROR

965895instance (AtLeastOneFragment api, FragmentUnique (Fragment a1 :> api), HasServer api context)

896+#else

897+instance (HasServer api context)

898+#endif

966899 => HasServer (Fragment a1 :> api) context where

967900 type ServerT (Fragment a1 :> api) m = ServerT api m

968901

@@ -972,72 +905,3 @@ instance (AtLeastOneFragment api, FragmentUnique (Fragment a1 :> api), HasServer

972905

973906-- $setup

974907-- >>> import Servant

975−

976−-- | A type that specifies that an API record contains a server implementation.

977−data AsServerT (m :: * -> *)

978−instance GenericMode (AsServerT m) where

979− type AsServerT m :- api = ServerT api m

980−

981−type AsServer = AsServerT Handler

982−

983−

984−-- | Set of constraints required to convert to / from vanilla server types.

985−type GServerConstraints api m =

986− ( ToServant api (AsServerT m) ~ ServerT (ToServantApi api) m

987− , GServantProduct (Rep (api (AsServerT m)))

988− )

989−

990−-- | This class is a necessary evil: in the implementation of 'HasServer' for

991−-- @'NamedRoutes' api@, we essentially need the quantified constraint @forall

992−-- m. 'GServerConstraints' m@ to hold.

993−--

994−-- We cannot require do that directly as the definition of 'GServerConstraints'

995−-- contains type family applications ('Rep' and 'ServerT'). The trick is to hide

996−-- those type family applications behind a typeclass providing evidence for

997−-- @'GServerConstraints' api m@ in the form of a dictionary, and require that

998−-- @forall m. 'GServer' api m@ instead.

999−--

1000−-- Users shouldn't have to worry about this class, as the only possible instance

1001−-- is provided in this module for all record APIs.

1002−

1003−class GServer (api :: * -> *) (m :: * -> *) where

1004− gServerProof :: Dict (GServerConstraints api m)

1005−

1006−instance

1007− ( ToServant api (AsServerT m) ~ ServerT (ToServantApi api) m

1008− , GServantProduct (Rep (api (AsServerT m)))

1009− ) => GServer api m where

1010− gServerProof = Dict

1011−

1012−instance

1013− ( HasServer (ToServantApi api) context

1014− , forall m. Generic (api (AsServerT m))

1015− , forall m. GServer api m

1016− ) => HasServer (NamedRoutes api) context where

1017−

1018− type ServerT (NamedRoutes api) m = api (AsServerT m)

1019−

1020− route

1021− :: Proxy (NamedRoutes api)

1022− -> Context context

1023− -> Delayed env (api (AsServerT Handler))

1024− -> Router env

1025− route _ ctx delayed =

1026− case gServerProof @api @Handler of

1027− Dict -> route (Proxy @(ToServantApi api)) ctx (toServant <$> delayed)

1028−

1029− hoistServerWithContext

1030− :: forall m n. Proxy (NamedRoutes api)

1031− -> Proxy context

1032− -> (forall x. m x -> n x)

1033− -> api (AsServerT m)

1034− -> api (AsServerT n)

1035− hoistServerWithContext _ pctx nat server =

1036− case (gServerProof @api @m, gServerProof @api @n) of

1037− (Dict, Dict) ->

1038− fromServant servantSrvN

1039− where

1040− servantSrvM :: ServerT (ToServantApi api) m =

1041− toServant server

1042− servantSrvN :: ServerT (ToServantApi api) n =

1043− hoistServerWithContext (Proxy @(ToServantApi api)) pctx nat servantSrvM

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

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

1313import Control.Monad.Catch

1414 (MonadCatch, MonadMask, MonadThrow)

1515import Control.Monad.Error.Class

16− (MonadError, throwError)

16+ (MonadError)

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)

2523import GHC.Generics

2624 (Generic)

2725import Servant.Server.Internal.ServerError

28− (ServerError, errBody, err500)

26+ (ServerError)

2927

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

3129 deriving

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

3432 , MonadThrow, MonadCatch, MonadMask

3533 )

3634

37−instance MonadFail Handler where

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

39−

4035instance MonadBase IO Handler where

4136 liftBase = Handler . liftBase

4237

servant-server/src/Servant/Server/Internal/Router.hs+15−50

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

99

1010import Data.Function

1111 (on)

12−import Data.List

13− (nub)

1412import Data.Map

1513 (Map)

1614import qualified Data.Map as M

1715import Data.Text

1816 (Text)

1917import qualified Data.Text as T

20−import Data.Typeable

21− (TypeRep)

2218import Network.Wai

2319 (Response, pathInfo)

2420import Servant.Server.Internal.ErrorFormatter

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

2824

2925type Router env = Router' env RoutingApplication

3026

31−-- | Holds information about pieces of url that are captured as variables.

32−data CaptureHint = CaptureHint

33− { captureName :: Text

34− -- ^ Holds the name of the captured variable

35− , captureType :: TypeRep

36− -- ^ Holds the type of the captured variable

37− }

38− deriving (Show, Eq)

39−

40−toCaptureTag :: CaptureHint -> Text

41−toCaptureTag hint = captureName hint <> "::" <> (T.pack . show) (captureType hint)

42−

43−toCaptureTags :: [CaptureHint] -> Text

44−toCaptureTags hints = "<" <> T.intercalate "|" (map toCaptureTag hints) <> ">"

45−

4627-- | Internal representation of a router.

4728--

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

@@ -55,23 +36,12 @@ data Router' env a =

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

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

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

58− | CaptureRouter [CaptureHint] (Router' (Text, env) a)

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

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

60− -- environment and removed afterwards.

61− -- The first argument is a list of hints for all variables that can be

62− -- captured by the router. The fact that it is a list is counter-intuitive,

63− -- because the 'Capture' combinator only allows to capture a single varible,

64− -- with a single name and a single type. However, the 'choice' smart

65− -- constructor may merge two 'Capture' combinators with different hints, thus

66− -- forcing the type to be '[CaptureHint]'.

67− -- Because 'CaptureRouter' is built from a 'Capture' combinator, the list of

68− -- hints should always be non-empty.

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

41+ -- environment and removed afterwards

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

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

7144 -- environment and are removed afterwards

72− -- The first argument is a hint for the list of variables that can be

73− -- captured by the router. Note that the 'captureType' field of the hint

74− -- should always be '[a]' for some 'a'.

7545 | RawRouter (env -> a)

7646 -- ^ to be used for routes we do not know anything about

7747 | Choice (Router' env a) (Router' env a)

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

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

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

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

102−choice (CaptureRouter hints1 router1) (CaptureRouter hints2 router2) =

103− CaptureRouter (nub $ hints1 ++ hints2) (choice router1 router2)

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

73+ CaptureRouter (choice router1 router2)

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

10575choice router1 router2 = Choice router1 router2

10676

@@ -114,11 +84,7 @@ choice router1 router2 = Choice router1 router2

11484--

11585data RouterStructure =

11686 StaticRouterStructure (Map Text RouterStructure) Int

117− | CaptureRouterStructure [CaptureHint] RouterStructure

118− -- ^ The first argument holds information about variables

119− -- that are captured by the router. There may be several hints

120− -- if several routers have been aggregated by the 'choice'

121− -- smart constructor.

87+ | CaptureRouterStructure RouterStructure

12288 | RawRouterStructure

12389 | ChoiceStructure RouterStructure RouterStructure

12490 deriving (Eq, Show)

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

13298routerStructure :: Router' env a -> RouterStructure

13399routerStructure (StaticRouter m ls) =

134100 StaticRouterStructure (fmap routerStructure m) (length ls)

135−routerStructure (CaptureRouter hints router) =

136− CaptureRouterStructure hints $

101+routerStructure (CaptureRouter router) =

102+ CaptureRouterStructure $

137103 routerStructure router

138−routerStructure (CaptureAllRouter hints router) =

139− CaptureRouterStructure hints $

104+routerStructure (CaptureAllRouter router) =

105+ CaptureRouterStructure $

140106 routerStructure router

141107routerStructure (RawRouter _) =

142108 RawRouterStructure

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

148114-- | Compare the structure of two routers.

149115--

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

151−sameStructure router1 router2 =

152− routerStructure router1 == routerStructure router2

117+sameStructure r1 r2 =

118+ routerStructure r1 == routerStructure r2

153119

154120-- | Provide a textual representation of the

155121-- structure of a router.

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

160126 where

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

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

163− mkRouterLayout c (CaptureRouterStructure hints r) =

164− mkSubTree c (toCaptureTags hints) (mkRouterLayout False r)

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

165130 mkRouterLayout c RawRouterStructure =

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

167132 mkRouterLayout c (ChoiceStructure r1 r2) =

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

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

205170 in runRouterEnv fmt router' env request' respond

206171 _ -> respond $ Fail $ fmt request

207− CaptureRouter _ router' ->

172+ CaptureRouter router' ->

208173 case pathInfo request of

209174 [] -> respond $ Fail $ fmt request

210175 -- This case is to handle trailing slashes.

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

212177 first : rest

213178 -> let request' = request { pathInfo = rest }

214179 in runRouterEnv fmt router' (first, env) request' respond

215− CaptureAllRouter _ router' ->

180+ CaptureAllRouter router' ->

216181 let segments = pathInfo request

217182 request' = request { pathInfo = [] }

218183 in runRouterEnv fmt router' (segments, env) request' respond

servant-server/test/Servant/Server/RouterSpec.hs+6−127

@@ -9,9 +9,7 @@ import Control.Monad

99import Data.Proxy

1010 (Proxy (..))

1111import Data.Text

12− (Text, unpack)

13−import Data.Typeable

14− (typeRep)

12+ (unpack)

1513import Network.HTTP.Types

1614 (Status (..))

1715import Network.Wai

@@ -29,7 +27,6 @@ spec :: Spec

2927spec = describe "Servant.Server.Internal.Router" $ do

3028 routerSpec

3129 distributivitySpec

32− serverLayoutSpec

3330

3431routerSpec :: Spec

3532routerSpec = do

@@ -54,7 +51,7 @@ routerSpec = do

5451 toApp = toApplication . runRouter (const err404)

5552

5653 cap :: Router ()

57− cap = CaptureRouter [hint] $

54+ cap = CaptureRouter $

5855 let delayed = addCapture (emptyDelayed $ Route pure) (const $ delayedFail err400)

5956 in leafRouter

6057 $ \env req res ->

@@ -62,9 +59,6 @@ routerSpec = do

6259 . const

6360 $ Route success

6461

65− hint :: CaptureHint

66− hint = CaptureHint "anything" $ typeRep (Proxy :: Proxy ())

67−

6862 router :: Router ()

6963 router = leafRouter (\_ _ res -> res $ Route success)

7064 `Choice` cap

@@ -104,30 +98,12 @@ distributivitySpec =

10498 it "properly handles mixing static paths at different levels" $ do

10599 level `shouldHaveSameStructureAs` levelRef

106100

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−

119101shouldHaveSameStructureAs ::

120102 (HasServer api1 '[], HasServer api2 '[]) => Proxy api1 -> Proxy api2 -> Expectation

121103shouldHaveSameStructureAs p1 p2 =

122104 unless (sameStructure (makeTrivialRouter p1) (makeTrivialRouter p2)) $

123105 expectationFailure ("expected:\n" ++ unpack (layout p2) ++ "\nbut got:\n" ++ unpack (layout p1))

124106

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−

131107makeTrivialRouter :: (HasServer layout '[]) => Proxy layout -> Router ()

132108makeTrivialRouter p =

133109 route p EmptyContext (emptyDelayed (FailFatal err501))

@@ -168,12 +144,12 @@ staticRef = Proxy

168144-- structure:

169145

170146type Dynamic =

171− "a" :> Capture "foo" Int :> "b" :> End

172− :<|> "a" :> Capture "foo" Int :> "c" :> End

173− :<|> "a" :> Capture "foo" Int :> "d" :> End

147+ "a" :> Capture "foo" Int :> "b" :> End

148+ :<|> "a" :> Capture "bar" Bool :> "c" :> End

149+ :<|> "a" :> Capture "baz" Char :> "d" :> End

174150

175151type DynamicRef =

176− "a" :> Capture "foo" Int :>

152+ "a" :> Capture "anything" () :>

177153 ("b" :> End :<|> "c" :> End :<|> "d" :> End)

178154

179155dynamic :: Proxy Dynamic

@@ -363,100 +339,3 @@ level = Proxy

363339

364340levelRef :: Proxy LevelRef

365341levelRef = Proxy

366−

367−-- The example API for the 'layout' function.

368−-- Should get factorized by the 'choice' smart constructor.

369−type ExampleLayout =

370− "a" :> "d" :> Get '[JSON] NoContent

371− :<|> "b" :> Capture "x" Int :> Get '[JSON] Bool

372− :<|> "c" :> Put '[JSON] Bool

373− :<|> "a" :> "e" :> Get '[JSON] Int

374− :<|> "b" :> Capture "x" Int :> Put '[JSON] Bool

375− :<|> Raw

376−

377−exampleLayout :: Proxy ExampleLayout

378−exampleLayout = Proxy

379−

380−-- The expected representation of the example API layout

381−--

382−expectedExampleLayout :: Text

383−expectedExampleLayout =

384− "/\n\

385− \├─ a/\n\

386− \│ ├─ d/\n\

387− \│ │ └─•\n\

388− \│ └─ e/\n\

389− \│ └─•\n\

390− \├─ b/\n\

391− \│ └─ <x::Int>/\n\

392− \│ ├─•\n\

393− \│ ┆\n\

394− \│ └─•\n\

395− \├─ c/\n\

396− \│ └─•\n\

397− \┆\n\

398− \└─ <raw>\n"

399−

400−-- A capture API with all capture types being the same

401−--

402−type CaptureSameType =

403− "a" :> Capture "foo" Int :> "b" :> End

404− :<|> "a" :> Capture "foo" Int :> "c" :> End

405− :<|> "a" :> Capture "foo" Int :> "d" :> End

406−

407−captureSameType :: Proxy CaptureSameType

408−captureSameType = Proxy

409−

410−-- The expected representation of the CaptureSameType API layout.

411−--

412−expectedCaptureSameType :: Text

413−expectedCaptureSameType =

414− "/\n\

415− \└─ a/\n\

416− \ └─ <foo::Int>/\n\

417− \ ├─ b/\n\

418− \ │ └─•\n\

419− \ ├─ c/\n\

420− \ │ └─•\n\

421− \ └─ d/\n\

422− \ └─•\n"

423−

424−-- A capture API capturing different types

425−--

426−type CaptureDifferentTypes =

427− "a" :> Capture "foo" Int :> "b" :> End

428− :<|> "a" :> Capture "bar" Bool :> "c" :> End

429− :<|> "a" :> Capture "baz" Char :> "d" :> End

430−

431−captureDifferentTypes :: Proxy CaptureDifferentTypes

432−captureDifferentTypes = Proxy

433−

434−-- The expected representation of the CaptureDifferentTypes API layout.

435−--

436−expectedCaptureDifferentTypes :: Text

437−expectedCaptureDifferentTypes =

438− "/\n\

439− \└─ a/\n\

440− \ └─ <foo::Int|bar::Bool|baz::Char>/\n\

441− \ ├─ b/\n\

442− \ │ └─•\n\

443− \ ├─ c/\n\

444− \ │ └─•\n\

445− \ └─ d/\n\

446− \ └─•\n"

447−

448−-- An API with a CaptureAll part

449−

450−type CaptureAllLayout = "a" :> CaptureAll "foos" Int :> End

451−

452−captureAllLayout :: Proxy CaptureAllLayout

453−captureAllLayout = Proxy

454−

455−-- The expected representation of the CaptureAllLayout API.

456−--

457−expectedCaptureAllLayout :: Text

458−expectedCaptureAllLayout =

459− "/\n\

460− \└─ a/\n\

461− \ └─ <foos::[Int]>/\n\

462− \ └─•\n"

servant-server/test/Servant/ServerSpec.hs+6−54

@@ -17,14 +17,10 @@ import Prelude.Compat

1717

1818import Control.Monad

1919 (forM_, unless, when)

20−import Control.Monad.Reader (runReaderT, ask)

2120import Control.Monad.Error.Class

2221 (MonadError (..))

23−import Control.Monad.IO.Class (MonadIO(..))

2422import Data.Aeson

2523 (FromJSON, ToJSON, decode', encode)

26−import Data.Acquire

27− (Acquire, mkAcquire)

2824import qualified Data.ByteString as BS

2925import qualified Data.ByteString.Base64 as Base64

3026import Data.Char

@@ -56,19 +52,19 @@ import Servant.API

5652 Delete, EmptyAPI, Fragment, Get, HasStatus (StatusOf), Header,

5753 Headers, HttpVersion, IsSecure (..), JSON, Lenient,

5854 NoContent (..), NoContentVerb, NoFraming, OctetStream, Patch,

59− PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw, RawM,

55+ PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw,

6056 RemoteHost, ReqBody, SourceIO, StdMethod (..), Stream, Strict,

6157 UVerb, Union, Verb, WithStatus (..), addHeader)

6258import Servant.Server

63− (Context ((:.), EmptyContext), Handler, Server, ServerT, Tagged (..),

64− emptyServer, err401, err403, err404, hoistServer, respond, serve,

59+ (Context ((:.), EmptyContext), Handler, Server, Tagged (..),

60+ emptyServer, err401, err403, err404, respond, serve,

6561 serveWithContext)

6662import Servant.Test.ComprehensiveAPI

6763import qualified Servant.Types.SourceT as S

6864import Test.Hspec

6965 (Spec, context, describe, it, shouldBe, shouldContain)

7066import Test.Hspec.Wai

71− (get, matchHeaders, matchStatus, shouldRespondWith,

67+ (get, liftIO, matchHeaders, matchStatus, shouldRespondWith,

7268 with, (<:>))

7369import qualified Test.Hspec.Wai as THW

7470

@@ -85,11 +81,8 @@ import Servant.Server.Internal.Context

8581-- This declaration simply checks that all instances are in place.

8682_ = serveWithContext comprehensiveAPI comprehensiveApiContext

8783

88−comprehensiveApiContext :: Context '[NamedContext "foo" '[], Acquire Int]

89−comprehensiveApiContext =

90− NamedContext EmptyContext :.

91− mkAcquire (pure 10) (\_ -> pure ()) :.

92− EmptyContext

84+comprehensiveApiContext :: Context '[NamedContext "foo" '[]]

85+comprehensiveApiContext = NamedContext EmptyContext :. EmptyContext

9386

9487-- * Specs

9588

@@ -104,7 +97,6 @@ spec = do

10497 reqBodySpec

10598 headerSpec

10699 rawSpec

107− rawMSpec

108100 alternativeSpec

109101 responseHeadersSpec

110102 uverbResponseHeadersSpec

@@ -613,46 +605,6 @@ rawSpec = do

613605

614606-- }}}

615607------------------------------------------------------------------------------

616−-- * rawMSpec {{{

617−------------------------------------------------------------------------------

618−

619−type RawMApi = "foo" :> RawM

620−

621−rawMApi :: Proxy RawMApi

622−rawMApi = Proxy

623−

624−rawMServer :: (Monad m, MonadIO m, Show a) => (Request -> m a) -> ServerT RawMApi m

625−rawMServer f req resp = liftIO . resp . responseLBS ok200 [] . cs . show =<< f req

626−

627−rawMSpec :: Spec

628−rawMSpec = do

629− describe "Servant.API.RawM" $ do

630− it "gives access to monadic context" $ do

631− flip runSession (serve rawMApi

632− (hoistServer rawMApi (flip runReaderT (42 :: Integer)) (rawMServer (const ask)))) $ do

633− response <- Network.Wai.Test.request defaultRequest{

634− pathInfo = ["foo"]

635− }

636− liftIO $ do

637− simpleBody response `shouldBe` "42"

638−

639− it "lets users throw servant errors" $ do

640− flip runSession (serve rawMApi (rawMServer (const $ throwError err404 >> pure (42 :: Integer)))) $ do

641− response <- Network.Wai.Test.request defaultRequest{

642− pathInfo = ["foo"]

643− }

644− liftIO $ do

645− statusCode (simpleStatus response) `shouldBe` 404

646−

647− it "gets the pathInfo modified" $ do

648− flip runSession (serve rawMApi (rawMServer (pure . pathInfo))) $ do

649− response <- Network.Wai.Test.request defaultRequest{

650− pathInfo = ["foo", "bar"]

651− }

652− liftIO $ do

653− simpleBody response `shouldBe` cs (show ["bar" :: String])

654−-- }}}

655−------------------------------------------------------------------------------

656608-- * alternativeSpec {{{

657609------------------------------------------------------------------------------

658610type AlternativeApi =

servant-swagger/CHANGELOG.mddeleted−143

@@ -1,143 +0,0 @@

1−1.1.9

2−-------

3−

4−* Support `servant-0.18`

5−

6−1.1.8

7−-------

8−

9−* Support `servant-0.17`

10−

11−1.1.7.1

12−-------

13−

14−* Support `swagger2-2.4`

15−

16−1.1.7

17−-----

18−

19−* Support servant-0.15

20− - support for 'Stream' and 'StreamBody' combinators

21− - orphan 'ToSchema (SourceT m a)' instance

22−* Fix BodyTypes to work with generalized ReqBody'

23− [#88](https://github.com/haskell-servant/servant-swagger/pull/88)

24−

25−1.1.6

26−-----

27−

28−* Fixes:

29− * `validateEveryToJSON` now prints validation errors

30−

31−* Notes:

32− * GHC-8.6 compatible release

33−

34−1.1.5

35−-----

36−

37−* Notes:

38− * `servant-0.13` compatible release

39− * Drops compatibility with previous `servant` versions.

40−

41−1.1.4

42−-----

43−

44−* Notes:

45− * `servant-0.12` compatible release

46−

47−1.1.3.1

48−---

49−

50−* Notes:

51− * GHC-8.2 compatible release

52−

53−1.1.3

54−---

55−

56−* Notes:

57− * `servant-0.11` compatible release

58−

59−1.1.2.1

60−---

61−

62−* Notes:

63− * `servant-0.10` compatible release

64−

65−1.1.2

66−---

67−

68−* Minor fixes:

69− * Support for aeson-1, insert-ordered-containers-0.2

70− * CaptureAll instance

71−

72−1.1.1

73−---

74−

75−* Minor fixes:

76− * Fix `unused-imports` and `unused-foralls` warnings;

77− * Fix tests to match `swagger2-2.1.1` (add `example` property for `UTCTime` schema).

78−

79−1.1

80−---

81−

82−* Breaking changes:

83− * Requires `swagger2 >= 2.1`

84− * Requires `servant >= 0.5`

85−

86−* Notes:

87− * GHC-8.0 compatible release

88−

89−1.0.3

90−---

91−

92−* Fixes:

93− * Improve compile-time performance of `BodyTypes` even further (see [18e0d95](https://github.com/haskell-servant/servant-swagger/commit/18e0d95ef6fe9076dd9621cb515d8d1a189f71d3))!

94−

95−1.0.2

96−---

97−

98−* Minor changes:

99− * Add GHC 7.8 support (see [#26](https://github.com/haskell-servant/servant-swagger/pull/26)).

100−

101−* Fixes:

102− * Improve compile-time performance of `BodyTypes` (see [#25](https://github.com/haskell-servant/servant-swagger/issues/25)).

103−

104−1.0.1

105−---

106−

107−* Fixes:

108− * Stop using `Data.Swagger.Internal`;

109− * Documentation fixes (links to examples).

110−

111−1.0

112−---

113−

114−* Major changes (see [#24](https://github.com/haskell-servant/servant-swagger/pull/24)):

115− * Switch to `swagger2-2.*`;

116− * Add automatic `ToJSON`/`ToSchema` validation tests;

117− * Add great documentation;

118− * Export some type-level functions for servant API.

119−

120−* Minor changes:

121− * Rework Todo API example;

122− * Stop exporting `ToResponseHeader`, `AllAccept` and `AllToResponseHeader` (see [bd50db4](https://github.com/haskell-servant/servant-swagger/commit/bd50db48ca6a106e4366560ded70932d409de1e2));

123− * Change maintainer, update authors/copyrights (see [1a62681](https://github.com/haskell-servant/servant-swagger/commit/1a6268101dc826a92c42e832e402e251c0d32147));

124− * Include changelog and example files into `extra-source-files`.

125−

126−0.1.2

127−---

128−

129−* Fixes:

130− * Fix default spec for `ReqBody` param to be required (see [#22](https://github.com/haskell-servant/servant-swagger/issues/22));

131− * Set version bounds for `swagger2`.

132−

133−0.1.1

134−---

135−

136−* Fixes:

137− * Fix `subOperations` to filter endpoints also by method (see [#18](https://github.com/haskell-servant/servant-swagger/issues/18));

138− * Fix response schema in `ToSwagger` instance for `Header` (see [b59e557](https://github.com/haskell-servant/servant-swagger/commit/b59e557a05bc2669332c52b397879e7598747b82)).

139−

140−0.1

141−---

142−* Major changes

143− * Use `swagger2` for data model (see [#9](https://github.com/dmjio/servant-swagger/pull/9)); this changes almost everything.

servant-swagger/LICENSEdeleted−28

@@ -1,28 +0,0 @@

1−Copyright (c) 2015-2016, Servant contributors

2−All rights reserved.

3−

4−Redistribution and use in source and binary forms, with or without

5−modification, are permitted provided that the following conditions are met:

6−

7−* Redistributions of source code must retain the above copyright notice, this

8− list of conditions and the following disclaimer.

9−

10−* Redistributions in binary form must reproduce the above copyright notice,

11− this list of conditions and the following disclaimer in the documentation

12− and/or other materials provided with the distribution.

13−

14−* Neither the name of servant-swagger nor the names of its

15− contributors may be used to endorse or promote products derived from

16− this software without specific prior written permission.

17−

18−THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"

19−AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE

20−IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE

21−DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE

22−FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL

23−DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR

24−SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER

25−CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,

26−OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE

27−OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

28−

servant-swagger/README.mddeleted−46

@@ -1,46 +0,0 @@

1−# servant-swagger

2−

3−[](http://hackage.haskell.org/package/servant-swagger)

4−[](http://stackage.org/lts/package/servant-swagger)

5−[](http://stackage.org/nightly/package/servant-swagger)

6−

7−Swagger 2.0 conforming json for [servant](https://github.com/haskell-servant/servant) APIs.

8−

9−

10−

11−### Motivation

12−

13−Swagger is a project used to describe and document RESTful APIs.

14−Unlike Servant it is language-agnostic and thus is quite popular among developers

15−in different languages. It also exists for a longer time and has more tools to work with.

16−

17−This package provides means to generate Swagger specification for a Servant API

18−and also to partially test whether API conforms with its specification.

19−

20−Generated Swagger specification then can be used for many things such as

21−- displaying interactive documentation using [Swagger UI](http://swagger.io/swagger-ui/);

22−- generating clients and servers in many languages using [Swagger Codegen](http://swagger.io/swagger-codegen/);

23−- and [many others](http://swagger.io/open-source-integrations/).

24−

25−### Usage

26−

27−Please refer to [haddock documentation](http://hackage.haskell.org/package/servant/servant-swagger).

28−

29−Some examples can be found in [`example/` directory](/example).

30−

31−### Try it out

32−

33−All generated swagger specifications can be interactively viewed on [Swagger Editor](http://editor.swagger.io/).

34−

35−Ready-to-use specification can be served as JSON and interactive API documentation

36−can be displayed using [Swagger UI](https://github.com/swagger-api/swagger-ui).

37−

38−Many Swagger tools, including server and client code generation for many languages, can be found on

39−[Swagger's Tools and Integrations page](http://swagger.io/open-source-integrations/).

40−

41−### Contributing

42−

43−We are happy to receive bug reports, fixes, documentation enhancements, and other improvements.

44−

45−Please report bugs via the [github issue tracker](https://github.com/haskell-servant/servant/issues).

46−

servant-swagger/Setup.hsdeleted−33

@@ -1,33 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# OPTIONS_GHC -Wall #-}

3−module Main (main) where

4−

5−#ifndef MIN_VERSION_cabal_doctest

6−#define MIN_VERSION_cabal_doctest(x,y,z) 0

7−#endif

8−

9−#if MIN_VERSION_cabal_doctest(1,0,0)

10−

11−import Distribution.Extra.Doctest ( defaultMainWithDoctests )

12−main :: IO ()

13−main = defaultMainWithDoctests "doctests"

14−

15−#else

16−

17−#ifdef MIN_VERSION_Cabal

18−-- If the macro is defined, we have new cabal-install,

19−-- but for some reason we don't have cabal-doctest in package-db

20−--

21−-- Probably we are running cabal sdist, when otherwise using new-build

22−-- workflow

23−#warning You are configuring this package without cabal-doctest installed. \

24− The doctests test-suite will not work as a result. \

25− To fix this, install cabal-doctest before configuring.

26−#endif

27−

28−import Distribution.Simple

29−

30−main :: IO ()

31−main = defaultMain

32−

33−#endif

servant-swagger/example/LICENSEdeleted−28

@@ -1,28 +0,0 @@

1−Copyright (c) 2015-2016, Servant contributors

2−All rights reserved.

3−

4−Redistribution and use in source and binary forms, with or without

5−modification, are permitted provided that the following conditions are met:

6−

7−* Redistributions of source code must retain the above copyright notice, this

8− list of conditions and the following disclaimer.

9−

10−* Redistributions in binary form must reproduce the above copyright notice,

11− this list of conditions and the following disclaimer in the documentation

12− and/or other materials provided with the distribution.

13−

14−* Neither the name of servant-swagger nor the names of its

15− contributors may be used to endorse or promote products derived from

16− this software without specific prior written permission.

17−

18−THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"

19−AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE

20−IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE

21−DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE

22−FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL

23−DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR

24−SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER

25−CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,

26−OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE

27−OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

28−

servant-swagger/example/example.cabaldeleted−62

@@ -1,62 +0,0 @@

1−cabal-version: 2.2

2−name: example

3−version: 1.0

4−synopsis: servant-swagger demonstration

5−description: servant-swagger demonstration

6−license: BSD-3-Clause

7−license-file: LICENSE

8−author: David Johnson, Nickolay Kudasov

9−maintainer: nickolay.kudasov@gmail.com

10−copyright: (c) 2015-2016, Servant contributors

11−category: Web

12−build-type: Simple

13−data-files:

14− swagger.json

15−

16−library

17− ghc-options: -Wall

18− hs-source-dirs: src/

19− exposed-modules:

20− Todo

21− build-depends: base

22− , aeson

23− , aeson-pretty

24− , bytestring

25− , lens

26− , servant

27− , servant-server

28− , servant-swagger

29− , swagger2

30− , text

31− , time

32− default-language: Haskell2010

33−

34−executable swagger-server

35− ghc-options: -Wall

36− hs-source-dirs: server/

37− main-is: Main.hs

38− build-depends: base

39− , example

40− , servant-server

41− , warp

42− default-language: Haskell2010

43−

44−test-suite swagger-server-spec

45− ghc-options: -Wall

46− type: exitcode-stdio-1.0

47− hs-source-dirs: test

48− main-is: Spec.hs

49− other-modules:

50− TodoSpec

51− Paths_example

52− build-depends: base == 4.*

53− , base-compat >= 0.6.0

54− , aeson >=0.11.2.0

55− , bytestring

56− , example

57− , hspec

58− , servant-swagger

59− , QuickCheck

60− , quickcheck-instances

61− default-language: Haskell2010

62−

servant-swagger/example/server/Main.hsdeleted−11

@@ -1,11 +0,0 @@

1−module Main where

2−

3−import Network.Wai.Handler.Warp

4−import Servant

5−import Todo

6−

7−main :: IO ()

8−main = do

9− putStrLn "Running on port 8000"

10− run 8000 $ serve (Proxy :: Proxy API) server

11−

servant-swagger/example/src/Todo.hsdeleted−73

@@ -1,73 +0,0 @@

1−{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE DeriveDataTypeable #-}

3−{-# LANGUAGE DeriveGeneric #-}

4−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5−{-# LANGUAGE OverloadedStrings #-}

6−{-# LANGUAGE TypeOperators #-}

7−module Todo where

8−

9−import Control.Lens

10−import Data.Aeson

11−import Data.Aeson.Encode.Pretty (encodePretty)

12−import qualified Data.ByteString.Lazy.Char8 as BL8

13−import Data.Proxy

14−import Data.Swagger

15−import Data.Text (Text)

16−import Data.Time (UTCTime (..), fromGregorian)

17−import Data.Typeable (Typeable)

18−import GHC.Generics

19−import Servant

20−import Servant.Swagger

21−

22−todoAPI :: Proxy TodoAPI

23−todoAPI = Proxy

24−

25−-- | The API of a Todo service.

26−type TodoAPI

27− = "todo" :> Get '[JSON] [Todo]

28− :<|> "todo" :> ReqBody '[JSON] Todo :> Post '[JSON] TodoId

29− :<|> "todo" :> Capture "id" TodoId :> Get '[JSON] Todo

30− :<|> "todo" :> Capture "id" TodoId :> ReqBody '[JSON] Todo :> Put '[JSON] TodoId

31−

32−-- | API for serving @swagger.json@.

33−type SwaggerAPI = "swagger.json" :> Get '[JSON] Swagger

34−

35−-- | Combined API of a Todo service with Swagger documentation.

36−type API = SwaggerAPI :<|> TodoAPI

37−

38−-- | A single Todo entry.

39−data Todo = Todo

40− { created :: UTCTime -- ^ Creation datetime.

41− , summary :: Text -- ^ Task summary.

42− } deriving (Show, Generic, Typeable)

43−

44−-- | A unique Todo entry ID.

45−newtype TodoId = TodoId Int

46− deriving (Show, Generic, Typeable, ToJSON, FromHttpApiData)

47−

48−instance ToJSON Todo

49−instance FromJSON Todo

50−

51−instance ToSchema Todo where

52− declareNamedSchema proxy = genericDeclareNamedSchema defaultSchemaOptions proxy

53− & mapped.schema.description ?~ "This is some real Todo right here"

54− & mapped.schema.example ?~ toJSON (Todo (UTCTime (fromGregorian 2015 12 31) 0) "get milk")

55−

56−instance ToParamSchema TodoId

57−instance ToSchema TodoId

58−

59−-- | Swagger spec for Todo API.

60−todoSwagger :: Swagger

61−todoSwagger = toSwagger todoAPI

62− & info.title .~ "Todo API"

63− & info.version .~ "1.0"

64− & info.description ?~ "This is an API that tests swagger integration"

65− & info.license ?~ ("MIT" & url ?~ URL "http://mit.com")

66−

67−-- | Combined server of a Todo service with Swagger documentation.

68−server :: Server API

69−server = return todoSwagger :<|> error "not implemented"

70−

71−-- | Output generated @swagger.json@ file for the @'TodoAPI'@.

72−writeSwaggerJSON :: IO ()

73−writeSwaggerJSON = BL8.writeFile "example/swagger.json" (encodePretty todoSwagger)

servant-swagger/example/swagger.jsondeleted−158

@@ -1,158 +0,0 @@

1−{

2− "swagger": "2.0",

3− "info": {

4− "version": "1.0",

5− "title": "Todo API",

6− "license": {

7− "url": "http://mit.com",

8− "name": "MIT"

9− },

10− "description": "This is an API that tests swagger integration"

11− },

12− "definitions": {

13− "Todo": {

14− "example": {

15− "summary": "get milk",

16− "created": "2015-12-31T00:00:00Z"

17− },

18− "required": [

19− "created",

20− "summary"

21− ],

22− "type": "object",

23− "description": "This is some real Todo right here",

24− "properties": {

25− "summary": {

26− "type": "string"

27− },

28− "created": {

29− "$ref": "#/definitions/UTCTime"

30− }

31− }

32− },

33− "UTCTime": {

34− "example": "2016-07-22T00:00:00Z",

35− "format": "yyyy-mm-ddThh:MM:ssZ",

36− "type": "string"

37− },

38− "TodoId": {

39− "maximum": 9223372036854775807,

40− "minimum": -9223372036854775808,

41− "type": "integer"

42− }

43− },

44− "paths": {

45− "/todo/{id}": {

46− "get": {

47− "responses": {

48− "400": {

49− "description": "Invalid `id`"

50− },

51− "200": {

52− "schema": {

53− "$ref": "#/definitions/Todo"

54− },

55− "description": ""

56− }

57− },

58− "produces": [

59− "application/json;charset=utf-8"

60− ],

61− "parameters": [

62− {

63− "maximum": 9223372036854775807,

64− "minimum": -9223372036854775808,

65− "required": true,

66− "in": "path",

67− "name": "id",

68− "type": "integer"

69− }

70− ]

71− },

72− "put": {

73− "consumes": [

74− "application/json;charset=utf-8"

75− ],

76− "responses": {

77− "400": {

78− "description": "Invalid `body` or `id`"

79− },

80− "200": {

81− "schema": {

82− "$ref": "#/definitions/TodoId"

83− },

84− "description": ""

85− }

86− },

87− "produces": [

88− "application/json;charset=utf-8"

89− ],

90− "parameters": [

91− {

92− "maximum": 9223372036854775807,

93− "minimum": -9223372036854775808,

94− "required": true,

95− "in": "path",

96− "name": "id",

97− "type": "integer"

98− },

99− {

100− "required": true,

101− "schema": {

102− "$ref": "#/definitions/Todo"

103− },

104− "in": "body",

105− "name": "body"

106− }

107− ]

108− }

109− },

110− "/todo": {

111− "post": {

112− "consumes": [

113− "application/json;charset=utf-8"

114− ],

115− "responses": {

116− "400": {

117− "description": "Invalid `body`"

118− },

119− "200": {

120− "schema": {

121− "$ref": "#/definitions/TodoId"

122− },

123− "description": ""

124− }

125− },

126− "produces": [

127− "application/json;charset=utf-8"

128− ],

129− "parameters": [

130− {

131− "required": true,

132− "schema": {

133− "$ref": "#/definitions/Todo"

134− },

135− "in": "body",

136− "name": "body"

137− }

138− ]

139− },

140− "get": {

141− "responses": {

142− "200": {

143− "schema": {

144− "items": {

145− "$ref": "#/definitions/Todo"

146− },

147− "type": "array"

148− },

149− "description": ""

150− }

151− },

152− "produces": [

153− "application/json;charset=utf-8"

154− ]

155− }

156− }

157− }

158−}

servant-swagger/example/test/Spec.hsdeleted−1

@@ -1 +0,0 @@

1−{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

servant-swagger/example/test/TodoSpec.hsdeleted−28

@@ -1,28 +0,0 @@

1−{-# OPTIONS_GHC -fno-warn-orphans #-}

2−module TodoSpec where

3−

4−import Prelude ()

5−import Prelude.Compat

6−

7−import Data.Aeson

8−import qualified Data.ByteString.Lazy.Char8 as BL8

9−import Paths_example

10−import Servant.Swagger.Test

11−import Test.Hspec

12−import Test.QuickCheck

13−import Test.QuickCheck.Instances ()

14−import Todo

15−

16−spec :: Spec

17−spec = describe "Swagger" $ do

18− context "ToJSON matches ToSchema" $ validateEveryToJSON todoAPI

19− it "swagger.json is up-to-date" $ do

20− path <- getDataFileName "swagger.json"

21− swag <- eitherDecode <$> BL8.readFile path

22− swag `shouldBe` Right todoSwagger

23−

24−instance Arbitrary Todo where

25− arbitrary = Todo <$> arbitrary <*> arbitrary

26−

27−instance Arbitrary TodoId where

28− arbitrary = TodoId <$> arbitrary

servant-swagger/servant-swagger.cabaldeleted−127

@@ -1,127 +0,0 @@

1−cabal-version: 2.2

2−name: servant-swagger

3−version: 1.1.11

4−synopsis: Generate a Swagger/OpenAPI/OAS 2.0 specification for your servant API.

5−description:

6− Swagger is a project used to describe and document RESTful APIs. The core of the

7− project is the [OpenAPI Specification (OAS)](https://swagger.io/docs/specification/about/).

8− This library implements v2.0 of the spec. Unlike Servant it is language-agnostic and thus is

9− quite popular among developers in different languages. It has also existed for a longer time

10− and has more helpful tooling.

11− .

12− This package provides means to generate a Swagger/OAS specification for a Servant API

13− and also to partially test whether an API conforms with its specification.

14− .

15− Generated Swagger specification then can be used for many things such as

16− .

17− * displaying interactive documentation using [Swagger UI](http://swagger.io/swagger-ui/);

18− .

19− * generating clients and servers in many languages using [Swagger Codegen](http://swagger.io/swagger-codegen/);

20− .

21− * and [many others](http://swagger.io/open-source-integrations/).

22−homepage: https://github.com/haskell-servant/servant/tree/master/servant-swagger#readme

23−bug-reports: https://github.com/haskell-servant/servant/issues

24−license: BSD-3-Clause

25−license-file: LICENSE

26−author: Servant Contributors

27−maintainer: haskell-servant-maintainers@googlegroups.com

28−copyright: (c) 2015-2018, Servant contributors

29−category: Web, Servant, Swagger

30−build-type: Custom

31−tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2

32−

33−extra-source-files:

34− README.md

35− , CHANGELOG.md

36− , example/server/*.hs

37− , example/src/*.hs

38− , example/test/*.hs

39− , example/*.cabal

40− , example/swagger.json

41− , example/LICENSE

42−extra-doc-files:

43− example/src/*.hs

44− , example/test/*.hs

45−

46−source-repository head

47− type: git

48− location: https://github.com/haskell-servant/servant.git

49−

50−custom-setup

51− setup-depends:

52− base >=4.9 && <5,

53− Cabal >= 1.24,

54− cabal-doctest >=1.0.6 && <1.1

55−

56−library

57− ghc-options: -Wall

58− exposed-modules:

59− Servant.Swagger

60− Servant.Swagger.Test

61− Servant.Swagger.TypeLevel

62−

63− -- Internal modules

64− Servant.Swagger.Internal

65− Servant.Swagger.Internal.Orphans

66− Servant.Swagger.Internal.Test

67− Servant.Swagger.Internal.TypeLevel

68− Servant.Swagger.Internal.TypeLevel.API

69− Servant.Swagger.Internal.TypeLevel.Every

70− Servant.Swagger.Internal.TypeLevel.TMap

71− hs-source-dirs: src

72− build-depends: aeson >=1.4.2.0 && <3

73− , aeson-pretty >=0.8.7 && <0.9

74− , base >=4.9.1.0 && <5

75− , base-compat >=0.10.5 && <0.13

76− , bytestring >=0.10.8.1 && <0.12

77− , http-media >=0.7.1.3 && <0.9

78− , insert-ordered-containers >=0.2.1.0 && <0.3

79− , lens >=4.17 && <6

80− , servant >=0.18.2 && <0.20

81− , singleton-bool >=0.1.4 && <0.2

82− , swagger2 >=2.3.0.1 && <3

83− , text >=1.2.3.0 && <2.1

84− , unordered-containers >=0.2.9.0 && <0.3

85−

86− , hspec

87− , QuickCheck

88− default-language: Haskell2010

89−

90−test-suite doctests

91− ghc-options: -Wall

92− build-depends:

93− base,

94− directory >= 1.0,

95− doctest >= 0.17 && <0.21,

96− servant,

97− QuickCheck,

98− filepath

99− default-language: Haskell2010

100− hs-source-dirs: test

101− main-is: doctests.hs

102− type: exitcode-stdio-1.0

103−

104−test-suite spec

105− ghc-options: -Wall

106− type: exitcode-stdio-1.0

107− hs-source-dirs: test

108− main-is: Spec.hs

109− build-tool-depends: hspec-discover:hspec-discover >=2.6.0 && <2.11

110− build-depends: base

111− , base-compat

112− , aeson >=1.4.2.0 && <3

113− , hspec >=2.6.0 && <2.11

114− , QuickCheck

115− , lens

116− , lens-aeson >=1.0.2 && <1.3

117− , servant

118− , servant-swagger

119− , swagger2

120− , text

121− , template-haskell

122− , utf8-string >=1.0.1.1 && <1.1

123− , time

124− , vector

125− other-modules:

126− Servant.SwaggerSpec

127− default-language: Haskell2010

servant-swagger/src/Servant/Swagger.hsdeleted−188

@@ -1,188 +0,0 @@

1−-- |

2−-- Module: Servant.Swagger

3−-- License: BSD3

4−-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>

5−-- Stability: experimental

6−--

7−-- This module provides means to generate and manipulate

8−-- Swagger specification for servant APIs.

9−--

10−-- Swagger is a project used to describe and document RESTful APIs.

11−--

12−-- The Swagger specification defines a set of files required to describe such an API.

13−-- These files can then be used by the Swagger-UI project to display the API

14−-- and Swagger-Codegen to generate clients in various languages.

15−-- Additional utilities can also take advantage of the resulting files, such as testing tools.

16−--

17−-- For more information see <http://swagger.io/ Swagger documentation>.

18−module Servant.Swagger (

19− -- * How to use this library

20− -- $howto

21−

22− -- ** Generate @'Swagger'@

23− -- $generate

24−

25− -- ** Annotate

26− -- $annotate

27−

28− -- ** Test

29− -- $test

30−

31− -- ** Serve

32− -- $serve

33−

34− -- * @'HasSwagger'@ class

35− HasSwagger(..),

36−

37− -- * Manipulation

38− subOperations,

39−

40− -- * Testing

41− validateEveryToJSON,

42− validateEveryToJSONWithPatternChecker,

43−) where

44−

45−import Servant.Swagger.Internal

46−import Servant.Swagger.Test

47−import Servant.Swagger.Internal.Orphans ()

48−

49−-- $setup

50−-- >>> import Control.Applicative

51−-- >>> import Control.Lens

52−-- >>> import Data.Aeson

53−-- >>> import Data.Aeson.Encode.Pretty

54−-- >>> import Data.Swagger

55−-- >>> import Data.Typeable

56−-- >>> import GHC.Generics

57−-- >>> import Servant.API

58−-- >>> import System.Environment

59−-- >>> import Test.Hspec

60−-- >>> import Test.QuickCheck

61−-- >>> import qualified Data.ByteString.Lazy.Char8 as BSL8

62−-- >>> :set -XDataKinds

63−-- >>> :set -XDeriveDataTypeable

64−-- >>> :set -XDeriveGeneric

65−-- >>> :set -XGeneralizedNewtypeDeriving

66−-- >>> :set -XOverloadedStrings

67−-- >>> :set -XTypeOperators

68−-- >>> setEnv "HSPEC_COLOR" "no"

69−-- >>> data User = User { name :: String, age :: Int } deriving (Show, Generic, Typeable)

70−-- >>> newtype UserId = UserId Integer deriving (Show, Generic, Typeable, ToJSON)

71−-- >>> instance ToJSON User

72−-- >>> instance ToSchema User

73−-- >>> instance ToSchema UserId

74−-- >>> instance ToParamSchema UserId

75−-- >>> type GetUsers = Get '[JSON] [User]

76−-- >>> type GetUser = Capture "user_id" UserId :> Get '[JSON] User

77−-- >>> type PostUser = ReqBody '[JSON] User :> Post '[JSON] UserId

78−-- >>> type UserAPI = GetUsers :<|> GetUser :<|> PostUser

79−-- >>> orderedKeys = encodePretty' (defConfig { confCompare = compare, confIndent = Spaces 0 })

80−

81−-- $howto

82−--

83−-- This section explains how to use this library to generate Swagger specification,

84−-- modify it and run automatic tests for a servant API.

85−--

86−-- For the purposes of this section we will use this servant API:

87−--

88−-- >>> data User = User { name :: String, age :: Int } deriving (Show, Generic, Typeable)

89−-- >>> newtype UserId = UserId Integer deriving (Show, Generic, Typeable, ToJSON)

90−-- >>> instance ToJSON User

91−-- >>> instance ToSchema User

92−-- >>> instance ToSchema UserId

93−-- >>> instance ToParamSchema UserId

94−-- >>> type GetUsers = Get '[JSON] [User]

95−-- >>> type GetUser = Capture "user_id" UserId :> Get '[JSON] User

96−-- >>> type PostUser = ReqBody '[JSON] User :> Post '[JSON] UserId

97−-- >>> type UserAPI = GetUsers :<|> GetUser :<|> PostUser

98−--

99−-- Here we define a user API with three endpoints. @GetUsers@ endpoint returns a list of all users.

100−-- @GetUser@ returns a user given his\/her ID. @PostUser@ creates a new user and returns his\/her ID.

101−

102−-- $generate

103−-- In order to generate @'Swagger'@ specification for a servant API, just use @'toSwagger'@:

104−--

105−-- >>> BSL8.putStrLn . orderedKeys $ toSwagger (Proxy :: Proxy UserAPI)

106−-- {"definitions":{"User":{"properties":{"age":{"maximum":9223372036854775807,"minimum":-9223372036854775808,"type":"integer"},"name":{"type":"string"}},"required":["name","age"],"type":"object"},"UserId":{"type":"integer"}},"info":{"title":"","version":""},"paths":{"/":{"get":{"produces":["application/json;charset=utf-8"],"responses":{"200":{"description":"","schema":{"items":{"$ref":"#/definitions/User"},"type":"array"}}}},"post":{"consumes":["application/json;charset=utf-8"],"parameters":[{"in":"body","name":"body","required":true,"schema":{"$ref":"#/definitions/User"}}],"produces":["application/json;charset=utf-8"],"responses":{"200":{"description":"","schema":{"$ref":"#/definitions/UserId"}},"400":{"description":"Invalid `body`"}}}},"/{user_id}":{"get":{"parameters":[{"in":"path","name":"user_id","required":true,"type":"integer"}],"produces":["application/json;charset=utf-8"],"responses":{"200":{"description":"","schema":{"$ref":"#/definitions/User"}},"400":{"description":"Invalid `user_id`"}}}}},"swagger":"2.0"}

107−--

108−-- By default @'toSwagger'@ will generate specification for all API routes, parameters, headers, responses and data schemas.

109−--

110−-- For some parameters it will also add 400 responses with a description mentioning parameter name.

111−--

112−-- Data schemas come from @'ToParamSchema'@ and @'ToSchema'@ classes.

113−

114−-- $annotate

115−-- While initially generated @'Swagger'@ looks good, it lacks some information it can't get from a servant API.

116−--

117−-- We can add this information using field lenses from @"Data.Swagger"@:

118−--

119−-- >>> :{

120−-- BSL8.putStrLn $ orderedKeys $ toSwagger (Proxy :: Proxy UserAPI)

121−-- & info.title .~ "User API"

122−-- & info.version .~ "1.0"

123−-- & info.description ?~ "This is an API for the Users service"

124−-- & info.license ?~ "MIT"

125−-- & host ?~ "example.com"

126−-- :}

127−-- {"definitions":{"User":{"properties":{"age":{"maximum":9223372036854775807,"minimum":-9223372036854775808,"type":"integer"},"name":{"type":"string"}},"required":["name","age"],"type":"object"},"UserId":{"type":"integer"}},"host":"example.com","info":{"description":"This is an API for the Users service","license":{"name":"MIT"},"title":"User API","version":"1.0"},"paths":{"/":{"get":{"produces":["application/json;charset=utf-8"],"responses":{"200":{"description":"","schema":{"items":{"$ref":"#/definitions/User"},"type":"array"}}}},"post":{"consumes":["application/json;charset=utf-8"],"parameters":[{"in":"body","name":"body","required":true,"schema":{"$ref":"#/definitions/User"}}],"produces":["application/json;charset=utf-8"],"responses":{"200":{"description":"","schema":{"$ref":"#/definitions/UserId"}},"400":{"description":"Invalid `body`"}}}},"/{user_id}":{"get":{"parameters":[{"in":"path","name":"user_id","required":true,"type":"integer"}],"produces":["application/json;charset=utf-8"],"responses":{"200":{"description":"","schema":{"$ref":"#/definitions/User"}},"400":{"description":"Invalid `user_id`"}}}}},"swagger":"2.0"}

128−--

129−-- It is also useful to annotate or modify certain endpoints.

130−-- @'subOperations'@ provides a convenient way to zoom into a part of an API.

131−--

132−-- @'subOperations' sub api@ traverses all operations of the @api@ which are also present in @sub@.

133−-- Furthermore, @sub@ is required to be an exact sub API of @api. Otherwise it will not typecheck.

134−--

135−-- @"Data.Swagger.Operation"@ provides some useful helpers that can be used with @'subOperations'@.

136−-- One example is applying tags to certain endpoints:

137−--

138−-- >>> let getOps = subOperations (Proxy :: Proxy (GetUsers :<|> GetUser)) (Proxy :: Proxy UserAPI)

139−-- >>> let postOps = subOperations (Proxy :: Proxy PostUser) (Proxy :: Proxy UserAPI)

140−-- >>> :{

141−-- BSL8.putStrLn $ orderedKeys $ toSwagger (Proxy :: Proxy UserAPI)

142−-- & applyTagsFor getOps ["get" & description ?~ "GET operations"]

143−-- & applyTagsFor postOps ["post" & description ?~ "POST operations"]

144−-- :}

145−-- {"definitions":{"User":{"properties":{"age":{"maximum":9223372036854775807,"minimum":-9223372036854775808,"type":"integer"},"name":{"type":"string"}},"required":["name","age"],"type":"object"},"UserId":{"type":"integer"}},"info":{"title":"","version":""},"paths":{"/":{"get":{"produces":["application/json;charset=utf-8"],"responses":{"200":{"description":"","schema":{"items":{"$ref":"#/definitions/User"},"type":"array"}}},"tags":["get"]},"post":{"consumes":["application/json;charset=utf-8"],"parameters":[{"in":"body","name":"body","required":true,"schema":{"$ref":"#/definitions/User"}}],"produces":["application/json;charset=utf-8"],"responses":{"200":{"description":"","schema":{"$ref":"#/definitions/UserId"}},"400":{"description":"Invalid `body`"}},"tags":["post"]}},"/{user_id}":{"get":{"parameters":[{"in":"path","name":"user_id","required":true,"type":"integer"}],"produces":["application/json;charset=utf-8"],"responses":{"200":{"description":"","schema":{"$ref":"#/definitions/User"}},"400":{"description":"Invalid `user_id`"}},"tags":["get"]}}},"swagger":"2.0","tags":[{"description":"GET operations","name":"get"},{"description":"POST operations","name":"post"}]}

146−--

147−-- This applies @\"get\"@ tag to the @GET@ endpoints and @\"post\"@ tag to the @POST@ endpoint of the User API.

148−

149−-- $test

150−-- Automatic generation of data schemas uses @'ToSchema'@ instances for the types

151−-- used in a servant API. But to encode/decode actual data servant uses different classes.

152−-- For instance in @UserAPI@ @User@ is always encoded/decoded using @'ToJSON'@ and @'FromJSON'@ instances.

153−--

154−-- To be sure your Haskell server/client handles data properly you need to check

155−-- that @'ToJSON'@ instance always generates values that satisfy schema produced

156−-- by @'ToSchema'@ instance.

157−--

158−-- With @'validateEveryToJSON'@ it is possible to test all those instances automatically,

159−-- without having to write down every type:

160−--

161−-- >>> instance Arbitrary User where arbitrary = User <$> arbitrary <*> arbitrary

162−-- >>> instance Arbitrary UserId where arbitrary = UserId <$> arbitrary

163−-- >>> hspec $ validateEveryToJSON (Proxy :: Proxy UserAPI)

164−-- <BLANKLINE>

165−-- [User]...

166−-- ...

167−-- User...

168−-- ...

169−-- UserId...

170−-- ...

171−-- Finished in ... seconds

172−-- 3 examples, 0 failures

173−--

174−-- Although servant is great, chances are that your API clients don't use Haskell.

175−-- In many cases @swagger.json@ serves as a specification, not a Haskell type.

176−--

177−-- In this cases it is a good idea to store generated and annotated @'Swagger'@ in a @swagger.json@ file

178−-- under a version control system (such as Git, Subversion, Mercurial, etc.).

179−--

180−-- It is also recommended to version API based on changes to the @swagger.json@ rather than changes

181−-- to the Haskell API.

182−--

183−-- See <example/test/TodoSpec.hs TodoSpec.hs> for an example of a complete test suite for a swagger specification.

184−

185−-- $serve

186−-- If you're implementing a server for an API, you might also want to serve its @'Swagger'@ specification.

187−--

188−-- See <example/src/Todo.hs Todo.hs> for an example of a server.

servant-swagger/src/Servant/Swagger/Internal.hsdeleted−492

@@ -1,492 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE ConstraintKinds #-}

3−{-# LANGUAGE DataKinds #-}

4−{-# LANGUAGE FlexibleContexts #-}

5−{-# LANGUAGE FlexibleInstances #-}

6−{-# LANGUAGE OverloadedLists #-}

7−{-# LANGUAGE OverloadedStrings #-}

8−{-# LANGUAGE PolyKinds #-}

9−{-# LANGUAGE RankNTypes #-}

10−{-# LANGUAGE ScopedTypeVariables #-}

11−{-# LANGUAGE TypeOperators #-}

12−{-# LANGUAGE TypeFamilies #-}

13−#if __GLASGOW_HASKELL__ >= 806

14−{-# LANGUAGE UndecidableInstances #-}

15−#endif

16−module Servant.Swagger.Internal where

17−

18−import Prelude ()

19−import Prelude.Compat

20−

21−import Control.Applicative ((<|>))

22−import Control.Lens

23−import Data.Aeson

24−import Data.HashMap.Strict.InsOrd (InsOrdHashMap)

25−import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap

26−import Data.Foldable (toList)

27−import Data.Proxy

28−import Data.Typeable

29−import Data.Singletons.Bool

30−import Data.Swagger hiding (Header)

31−import qualified Data.Swagger as Swagger

32−import Data.Swagger.Declare

33−import Data.Text (Text)

34−import qualified Data.Text as Text

35−import GHC.Generics (D1, Meta(..), Rep)

36−import GHC.TypeLits

37−import Network.HTTP.Media (MediaType)

38−import Servant.API

39−import Servant.API.Description (FoldDescription,

40− reflectDescription)

41−import Servant.API.Generic (ToServantApi, AsApi)

42−import Servant.API.Modifiers (FoldRequired)

43−

44−import Servant.Swagger.Internal.TypeLevel.API

45−

46−-- | Generate a Swagger specification for a servant API.

47−--

48−-- To generate Swagger specification, your data types need

49−-- @'ToParamSchema'@ and/or @'ToSchema'@ instances.

50−--

51−-- @'ToParamSchema'@ is used for @'Capture'@, @'QueryParam'@ and @'Header'@.

52−-- @'ToSchema'@ is used for @'ReqBody'@ and response data types.

53−--

54−-- You can easily derive those instances via @Generic@.

55−-- For more information, refer to <http://hackage.haskell.org/package/swagger2/docs/Data-Swagger.html swagger2 documentation>.

56−--

57−-- Example:

58−--

59−-- @

60−-- newtype Username = Username String deriving (Generic, ToText)

61−--

62−-- instance ToParamSchema Username

63−--

64−-- data User = User

65−-- { username :: Username

66−-- , fullname :: String

67−-- } deriving (Generic)

68−--

69−-- instance ToJSON User

70−-- instance ToSchema User

71−--

72−-- type MyAPI = QueryParam "username" Username :> Get '[JSON] User

73−--

74−-- mySwagger :: Swagger

75−-- mySwagger = toSwagger (Proxy :: Proxy MyAPI)

76−-- @

77−class HasSwagger api where

78− -- | Generate a Swagger specification for a servant API.

79− toSwagger :: Proxy api -> Swagger

80−

81−instance HasSwagger Raw where

82− toSwagger _ = mempty & paths . at "/" ?~ mempty

83−

84−instance HasSwagger EmptyAPI where

85− toSwagger _ = mempty

86−

87−-- | All operations of sub API.

88−-- This is similar to @'operationsOf'@ but ensures that operations

89−-- indeed belong to the API at compile time.

90−subOperations :: (IsSubAPI sub api, HasSwagger sub) =>

91− Proxy sub -- ^ Part of a servant API.

92− -> Proxy api -- ^ The whole servant API.

93− -> Traversal' Swagger Operation

94−subOperations sub _ = operationsOf (toSwagger sub)

95−

96−-- | Make a singleton Swagger spec (with only one endpoint).

97−-- For endpoints with no content see 'mkEndpointNoContent'.

98−mkEndpoint :: forall a cs hs proxy method status.

99− (ToSchema a, AllAccept cs, AllToResponseHeader hs, SwaggerMethod method, KnownNat status)

100− => FilePath -- ^ Endpoint path.

101− -> proxy (Verb method status cs (Headers hs a)) -- ^ Method, content-types, headers and response.

102− -> Swagger

103−mkEndpoint path proxy

104− = mkEndpointWithSchemaRef (Just ref) path proxy

105− & definitions .~ defs

106− where

107− (defs, ref) = runDeclare (declareSchemaRef (Proxy :: Proxy a)) mempty

108−

109−-- | Make a singletone 'Swagger' spec (with only one endpoint) and with no content schema.

110−mkEndpointNoContent :: forall nocontent cs hs proxy method status.

111− (AllAccept cs, AllToResponseHeader hs, SwaggerMethod method, KnownNat status)

112− => FilePath -- ^ Endpoint path.

113− -> proxy (Verb method status cs (Headers hs nocontent)) -- ^ Method, content-types, headers and response.

114− -> Swagger

115−mkEndpointNoContent path proxy

116− = mkEndpointWithSchemaRef Nothing path proxy

117−

118−-- | Like @'mkEndpoint'@ but with explicit schema reference.

119−-- Unlike @'mkEndpoint'@ this function does not update @'definitions'@.

120−mkEndpointWithSchemaRef :: forall cs hs proxy method status a.

121− (AllAccept cs, AllToResponseHeader hs, SwaggerMethod method, KnownNat status)

122− => Maybe (Referenced Schema)

123− -> FilePath

124− -> proxy (Verb method status cs (Headers hs a))

125− -> Swagger

126−mkEndpointWithSchemaRef mref path _ = mempty

127− & paths.at path ?~

128− (mempty & method ?~ (mempty

129− & produces ?~ MimeList responseContentTypes

130− & at code ?~ Inline (mempty

131− & schema .~ mref

132− & headers .~ responseHeaders)))

133− where

134− method = swaggerMethod (Proxy :: Proxy method)

135− code = fromIntegral (natVal (Proxy :: Proxy status))

136− responseContentTypes = allContentType (Proxy :: Proxy cs)

137− responseHeaders = toAllResponseHeaders (Proxy :: Proxy hs)

138−

139−mkEndpointNoContentVerb :: forall proxy method.

140− (SwaggerMethod method)

141− => FilePath -- ^ Endpoint path.

142− -> proxy (NoContentVerb method) -- ^ Method

143− -> Swagger

144−mkEndpointNoContentVerb path _ = mempty

145− & paths.at path ?~

146− (mempty & method ?~ (mempty

147− & at code ?~ Inline mempty))

148− where

149− method = swaggerMethod (Proxy :: Proxy method)

150− code = 204 -- hardcoded in servant-server

151−

152−-- | Add parameter to every operation in the spec.

153−addParam :: Param -> Swagger -> Swagger

154−addParam param = allOperations.parameters %~ (Inline param :)

155−

156−-- | Add a tag to every operation in the spec.

157−addTag :: Text -> Swagger -> Swagger

158−addTag tag = allOperations.tags %~ ([tag] <>)

159−

160−-- | Add accepted content types to every operation in the spec.

161−addConsumes :: [MediaType] -> Swagger -> Swagger

162−addConsumes cs = allOperations.consumes %~ (<> Just (MimeList cs))

163−

164−-- | Format given text as inline code in Markdown.

165−markdownCode :: Text -> Text

166−markdownCode s = "`" <> s <> "`"

167−

168−addDefaultResponse400 :: ParamName -> Swagger -> Swagger

169−addDefaultResponse400 pname = setResponseWith (\old _new -> alter400 old) 400 (return response400)

170− where

171− sname = markdownCode pname

172− description400 = "Invalid " <> sname

173− alter400 = description %~ (<> (" or " <> sname))

174− response400 = mempty & description .~ description400

175−

176−-- | Methods, available for Swagger.

177−class SwaggerMethod method where

178− swaggerMethod :: proxy method -> Lens' PathItem (Maybe Operation)

179−

180−instance SwaggerMethod 'GET where swaggerMethod _ = get

181−instance SwaggerMethod 'PUT where swaggerMethod _ = put

182−instance SwaggerMethod 'POST where swaggerMethod _ = post

183−instance SwaggerMethod 'DELETE where swaggerMethod _ = delete

184−instance SwaggerMethod 'OPTIONS where swaggerMethod _ = options

185−instance SwaggerMethod 'HEAD where swaggerMethod _ = head_

186−instance SwaggerMethod 'PATCH where swaggerMethod _ = patch

187−

188−instance HasSwagger (UVerb method cs '[]) where

189− toSwagger _ = mempty

190−

191−-- | @since <TODO>

192−instance

193− {-# OVERLAPPABLE #-}

194− ( ToSchema a,

195− HasStatus a,

196− AllAccept cs,

197− SwaggerMethod method,

198− HasSwagger (UVerb method cs as)

199− ) =>

200− HasSwagger (UVerb method cs (a ': as))

201− where

202− toSwagger _ =

203− toSwagger (Proxy :: Proxy (Verb method (StatusOf a) cs a))

204− `combineSwagger` toSwagger (Proxy :: Proxy (UVerb method cs as))

205−

206−-- ATTENTION: do not remove this instance!

207−-- A similar instance above will always use the more general

208−-- polymorphic -- HasSwagger instance and will result in a type error

209−-- since 'NoContent' does not have a 'ToSchema' instance.

210−instance

211− ( KnownNat status,

212− AllAccept cs,

213− SwaggerMethod method,

214− HasSwagger (UVerb method cs as)

215− ) =>

216− HasSwagger (UVerb method cs (WithStatus status NoContent ': as))

217− where

218− toSwagger _ =

219− toSwagger (Proxy :: Proxy (Verb method status cs NoContent))

220− `combineSwagger` toSwagger (Proxy :: Proxy (UVerb method cs as))

221−

222−

223−-- workaround for https://github.com/GetShopTV/swagger2/issues/218

224−-- We'd like to juse use (<>) but the instances are wrong

225−combinePathItem :: PathItem -> PathItem -> PathItem

226−combinePathItem s t = PathItem

227− { _pathItemGet = _pathItemGet s <> _pathItemGet t

228− , _pathItemPut = _pathItemPut s <> _pathItemPut t

229− , _pathItemPost = _pathItemPost s <> _pathItemPost t

230− , _pathItemDelete = _pathItemDelete s <> _pathItemDelete t

231− , _pathItemOptions = _pathItemOptions s <> _pathItemOptions t

232− , _pathItemHead = _pathItemHead s <> _pathItemHead t

233− , _pathItemPatch = _pathItemPatch s <> _pathItemPatch t

234− , _pathItemParameters = _pathItemParameters s <> _pathItemParameters t

235− }

236−

237−combineSwagger :: Swagger -> Swagger -> Swagger

238−combineSwagger s t = Swagger

239− { _swaggerInfo = _swaggerInfo s <> _swaggerInfo t

240− , _swaggerHost = _swaggerHost s <|> _swaggerHost t

241− , _swaggerBasePath = _swaggerBasePath s <|> _swaggerBasePath t

242− , _swaggerSchemes = _swaggerSchemes s <> _swaggerSchemes t

243− , _swaggerConsumes = _swaggerConsumes s <> _swaggerConsumes t

244− , _swaggerProduces = _swaggerProduces s <> _swaggerProduces t

245− , _swaggerPaths = InsOrdHashMap.unionWith combinePathItem (_swaggerPaths s) (_swaggerPaths t)

246− , _swaggerDefinitions = _swaggerDefinitions s <> _swaggerDefinitions t

247− , _swaggerParameters = _swaggerParameters s <> _swaggerParameters t

248− , _swaggerResponses = _swaggerResponses s <> _swaggerResponses t

249− , _swaggerSecurityDefinitions = _swaggerSecurityDefinitions s <> _swaggerSecurityDefinitions t

250− , _swaggerSecurity = _swaggerSecurity s <> _swaggerSecurity t

251− , _swaggerTags = _swaggerTags s <> _swaggerTags t

252− , _swaggerExternalDocs = _swaggerExternalDocs s <|> _swaggerExternalDocs t

253− }

254−

255−instance {-# OVERLAPPABLE #-} (ToSchema a, AllAccept cs, KnownNat status, SwaggerMethod method) => HasSwagger (Verb method status cs a) where

256− toSwagger _ = toSwagger (Proxy :: Proxy (Verb method status cs (Headers '[] a)))

257−

258−-- | @since 1.1.7

259−instance (ToSchema a, Accept ct, KnownNat status, SwaggerMethod method) => HasSwagger (Stream method status fr ct a) where

260− toSwagger _ = toSwagger (Proxy :: Proxy (Verb method status '[ct] (Headers '[] a)))

261−

262−instance {-# OVERLAPPABLE #-} (ToSchema a, AllAccept cs, AllToResponseHeader hs, KnownNat status, SwaggerMethod method)

263− => HasSwagger (Verb method status cs (Headers hs a)) where

264− toSwagger = mkEndpoint "/"

265−

266−-- ATTENTION: do not remove this instance!

267−-- A similar instance above will always use the more general

268−-- polymorphic -- HasSwagger instance and will result in a type error

269−-- since 'NoContent' does not have a 'ToSchema' instance.

270−instance (AllAccept cs, KnownNat status, SwaggerMethod method) => HasSwagger (Verb method status cs NoContent) where

271− toSwagger _ = toSwagger (Proxy :: Proxy (Verb method status cs (Headers '[] NoContent)))

272−

273−instance (AllAccept cs, AllToResponseHeader hs, KnownNat status, SwaggerMethod method)

274− => HasSwagger (Verb method status cs (Headers hs NoContent)) where

275− toSwagger = mkEndpointNoContent "/"

276−

277−instance (SwaggerMethod method) => HasSwagger (NoContentVerb method) where

278− toSwagger = mkEndpointNoContentVerb "/"

279−

280−instance (HasSwagger a, HasSwagger b) => HasSwagger (a :<|> b) where

281− toSwagger _ = toSwagger (Proxy :: Proxy a) <> toSwagger (Proxy :: Proxy b)

282−

283−-- | @'Vault'@ combinator does not change our specification at all.

284−instance (HasSwagger sub) => HasSwagger (Vault :> sub) where

285− toSwagger _ = toSwagger (Proxy :: Proxy sub)

286−

287−-- | @'IsSecure'@ combinator does not change our specification at all.

288−instance (HasSwagger sub) => HasSwagger (IsSecure :> sub) where

289− toSwagger _ = toSwagger (Proxy :: Proxy sub)

290−

291−-- | @'RemoteHost'@ combinator does not change our specification at all.

292−instance (HasSwagger sub) => HasSwagger (RemoteHost :> sub) where

293− toSwagger _ = toSwagger (Proxy :: Proxy sub)

294−

295−-- | @'Fragment'@ combinator does not change our specification at all.

296−instance HasSwagger sub => HasSwagger (Fragment a :> sub) where

297− toSwagger _ = toSwagger (Proxy :: Proxy sub)

298−

299−-- | @'HttpVersion'@ combinator does not change our specification at all.

300−instance (HasSwagger sub) => HasSwagger (HttpVersion :> sub) where

301− toSwagger _ = toSwagger (Proxy :: Proxy sub)

302−

303−-- | @'WithNamedContext'@ combinator does not change our specification at all.

304−instance (HasSwagger sub) => HasSwagger (WithNamedContext x c sub) where

305− toSwagger _ = toSwagger (Proxy :: Proxy sub)

306−

307−-- | @'WithResource'@ combinator does not change our specification at all.

308−instance (HasSwagger sub) => HasSwagger (WithResource res :> sub) where

309− toSwagger _ = toSwagger (Proxy :: Proxy sub)

310−

311−instance (KnownSymbol sym, HasSwagger sub) => HasSwagger (sym :> sub) where

312− toSwagger _ = prependPath piece (toSwagger (Proxy :: Proxy sub))

313− where

314− piece = symbolVal (Proxy :: Proxy sym)

315−

316−instance (KnownSymbol sym, Typeable a, ToParamSchema a, HasSwagger sub, KnownSymbol (FoldDescription mods)) => HasSwagger (Capture' mods sym a :> sub) where

317− toSwagger _ = toSwagger (Proxy :: Proxy sub)

318− & addParam param

319− & prependPath capture

320− & addDefaultResponse400 tname

321− where

322− symbol = symbolVal (Proxy :: Proxy sym)

323− pname = if symbol == ""

324− then camelTo2 '-' . tyConName . typeRepTyCon $ typeRep (Proxy :: Proxy a)

325− else symbol

326− tname = Text.pack pname

327− transDesc "" = Nothing

328− transDesc desc = Just (Text.pack desc)

329− capture = "{" <> pname <> "}"

330− param = mempty

331− & name .~ tname

332− & description .~ transDesc (reflectDescription (Proxy :: Proxy mods))

333− & required ?~ True

334− & schema .~ ParamOther (mempty

335− & in_ .~ ParamPath

336− & paramSchema .~ toParamSchema (Proxy :: Proxy a))

337−

338−-- | Swagger Spec doesn't have a notion of CaptureAll, this instance is the best effort.

339−instance (KnownSymbol sym, Typeable a, ToParamSchema a, HasSwagger sub) => HasSwagger (CaptureAll sym a :> sub) where

340− toSwagger _ = toSwagger (Proxy :: Proxy (Capture sym a :> sub))

341−

342−instance (KnownSymbol desc, HasSwagger api) => HasSwagger (Description desc :> api) where

343− toSwagger _ = toSwagger (Proxy :: Proxy api)

344− & allOperations.description %~ (Just (Text.pack (symbolVal (Proxy :: Proxy desc))) <>)

345−

346−instance (KnownSymbol desc, HasSwagger api) => HasSwagger (Summary desc :> api) where

347− toSwagger _ = toSwagger (Proxy :: Proxy api)

348− & allOperations.summary %~ (Just (Text.pack (symbolVal (Proxy :: Proxy desc))) <>)

349−

350−instance (KnownSymbol sym, ToParamSchema a, HasSwagger sub, SBoolI (FoldRequired mods), KnownSymbol (FoldDescription mods)) => HasSwagger (QueryParam' mods sym a :> sub) where

351− toSwagger _ = toSwagger (Proxy :: Proxy sub)

352− & addParam param

353− & addDefaultResponse400 tname

354− where

355− tname = Text.pack (symbolVal (Proxy :: Proxy sym))

356− transDesc "" = Nothing

357− transDesc desc = Just (Text.pack desc)

358− param = mempty

359− & name .~ tname

360− & description .~ transDesc (reflectDescription (Proxy :: Proxy mods))

361− & required ?~ reflectBool (Proxy :: Proxy (FoldRequired mods))

362− & schema .~ ParamOther sch

363− sch = mempty

364− & in_ .~ ParamQuery

365− & paramSchema .~ toParamSchema (Proxy :: Proxy a)

366−

367−instance (KnownSymbol sym, ToParamSchema a, HasSwagger sub) => HasSwagger (QueryParams sym a :> sub) where

368− toSwagger _ = toSwagger (Proxy :: Proxy sub)

369− & addParam param

370− & addDefaultResponse400 tname

371− where

372− tname = Text.pack (symbolVal (Proxy :: Proxy sym))

373− param = mempty

374− & name .~ tname

375− & schema .~ ParamOther sch

376− sch = mempty

377− & in_ .~ ParamQuery

378− & paramSchema .~ pschema

379− pschema = mempty

380−#if MIN_VERSION_swagger2(2,4,0)

381− & type_ ?~ SwaggerArray

382−#else

383− & type_ .~ SwaggerArray

384−#endif

385− & items ?~ SwaggerItemsPrimitive (Just CollectionMulti) (toParamSchema (Proxy :: Proxy a))

386−

387−instance (KnownSymbol sym, HasSwagger sub) => HasSwagger (QueryFlag sym :> sub) where

388− toSwagger _ = toSwagger (Proxy :: Proxy sub)

389− & addParam param

390− & addDefaultResponse400 tname

391− where

392− tname = Text.pack (symbolVal (Proxy :: Proxy sym))

393− param = mempty

394− & name .~ tname

395− & schema .~ ParamOther (mempty

396− & in_ .~ ParamQuery

397− & allowEmptyValue ?~ True

398− & paramSchema .~ (toParamSchema (Proxy :: Proxy Bool)

399− & default_ ?~ toJSON False))

400−

401−instance (KnownSymbol sym, ToParamSchema a, HasSwagger sub, SBoolI (FoldRequired mods), KnownSymbol (FoldDescription mods)) => HasSwagger (Header' mods sym a :> sub) where

402− toSwagger _ = toSwagger (Proxy :: Proxy sub)

403− & addParam param

404− & addDefaultResponse400 tname

405− where

406− tname = Text.pack (symbolVal (Proxy :: Proxy sym))

407− transDesc "" = Nothing

408− transDesc desc = Just (Text.pack desc)

409− param = mempty

410− & name .~ tname

411− & description .~ transDesc (reflectDescription (Proxy :: Proxy mods))

412− & required ?~ reflectBool (Proxy :: Proxy (FoldRequired mods))

413− & schema .~ ParamOther (mempty

414− & in_ .~ ParamHeader

415− & paramSchema .~ toParamSchema (Proxy :: Proxy a))

416−

417−instance (ToSchema a, AllAccept cs, HasSwagger sub, KnownSymbol (FoldDescription mods)) => HasSwagger (ReqBody' mods cs a :> sub) where

418− toSwagger _ = toSwagger (Proxy :: Proxy sub)

419− & addParam param

420− & addConsumes (allContentType (Proxy :: Proxy cs))

421− & addDefaultResponse400 tname

422− & definitions %~ (<> defs)

423− where

424− tname = "body"

425− transDesc "" = Nothing

426− transDesc desc = Just (Text.pack desc)

427− (defs, ref) = runDeclare (declareSchemaRef (Proxy :: Proxy a)) mempty

428− param = mempty

429− & name .~ tname

430− & description .~ transDesc (reflectDescription (Proxy :: Proxy mods))

431− & required ?~ True

432− & schema .~ ParamBody ref

433−

434−-- | This instance is an approximation.

435−--

436−-- @since 1.1.7

437−instance (ToSchema a, Accept ct, HasSwagger sub, KnownSymbol (FoldDescription mods)) => HasSwagger (StreamBody' mods fr ct a :> sub) where

438− toSwagger _ = toSwagger (Proxy :: Proxy sub)

439− & addParam param

440− & addConsumes (toList (contentTypes (Proxy :: Proxy ct)))

441− & addDefaultResponse400 tname

442− & definitions %~ (<> defs)

443− where

444− tname = "body"

445− transDesc "" = Nothing

446− transDesc desc = Just (Text.pack desc)

447− (defs, ref) = runDeclare (declareSchemaRef (Proxy :: Proxy a)) mempty

448− param = mempty

449− & name .~ tname

450− & description .~ transDesc (reflectDescription (Proxy :: Proxy mods))

451− & required ?~ True

452− & schema .~ ParamBody ref

453−

454−instance (HasSwagger (ToServantApi routes), KnownSymbol datatypeName, Rep (routes AsApi) ~ D1 ('MetaData datatypeName moduleName packageName isNewtype) f) => HasSwagger (NamedRoutes routes) where

455− toSwagger _ = addTag (Text.pack $ symbolVal (Proxy :: Proxy datatypeName)) (toSwagger (Proxy :: Proxy (ToServantApi routes)))

456−

457−-- =======================================================================

458−-- Below are the definitions that should be in Servant.API.ContentTypes

459−-- =======================================================================

460−

461−class AllAccept cs where

462− allContentType :: Proxy cs -> [MediaType]

463−

464−instance AllAccept '[] where

465− allContentType _ = []

466−

467−instance (Accept c, AllAccept cs) => AllAccept (c ': cs) where

468− allContentType _ = contentType (Proxy :: Proxy c) : allContentType (Proxy :: Proxy cs)

469−

470−class ToResponseHeader h where

471− toResponseHeader :: Proxy h -> (HeaderName, Swagger.Header)

472−

473−instance (KnownSymbol sym, ToParamSchema a) => ToResponseHeader (Header sym a) where

474− toResponseHeader _ = (hname, Swagger.Header Nothing hschema)

475− where

476− hname = Text.pack (symbolVal (Proxy :: Proxy sym))

477− hschema = toParamSchema (Proxy :: Proxy a)

478−

479−class AllToResponseHeader hs where

480− toAllResponseHeaders :: Proxy hs -> InsOrdHashMap HeaderName Swagger.Header

481−

482−instance AllToResponseHeader '[] where

483− toAllResponseHeaders _ = mempty

484−

485−instance (ToResponseHeader h, AllToResponseHeader hs) => AllToResponseHeader (h ': hs) where

486− toAllResponseHeaders _ = InsOrdHashMap.insert headerName headerBS hdrs

487− where

488− (headerName, headerBS) = toResponseHeader (Proxy :: Proxy h)

489− hdrs = toAllResponseHeaders (Proxy :: Proxy hs)

490−

491−instance AllToResponseHeader hs => AllToResponseHeader (HList hs) where

492− toAllResponseHeaders _ = toAllResponseHeaders (Proxy :: Proxy hs)

servant-swagger/src/Servant/Swagger/Internal/Orphans.hsdeleted−27

@@ -1,27 +0,0 @@

1−{-# OPTIONS_GHC -fno-warn-orphans #-}

2−{-# LANGUAGE CPP #-}

3−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4−{-# LANGUAGE ScopedTypeVariables #-}

5−{-# LANGUAGE StandaloneDeriving #-}

6−module Servant.Swagger.Internal.Orphans where

7−

8−import Data.Proxy

9− (Proxy (..))

10−import Data.Swagger

11−import Servant.Types.SourceT

12− (SourceT)

13−#if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)

14−import Servant.API (WithStatus(..))

15−#endif

16−

17−-- | Pretend that 'SourceT m a' is '[a]'.

18−--

19−-- @since 1.1.7

20−--

21−instance ToSchema a => ToSchema (SourceT m a) where

22− declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])

23−

24−#if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)

25−-- @since 1.1.11

26−deriving instance ToSchema a => ToSchema (WithStatus s a)

27−#endif

servant-swagger/src/Servant/Swagger/Internal/Test.hsdeleted−207

@@ -1,207 +0,0 @@

1−{-# LANGUAGE ConstraintKinds #-}

2−{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE FlexibleContexts #-}

4−{-# LANGUAGE RankNTypes #-}

5−{-# LANGUAGE ScopedTypeVariables #-}

6−{-# LANGUAGE TypeOperators #-}

7−{-# LANGUAGE OverloadedStrings #-}

8−module Servant.Swagger.Internal.Test where

9−

10−import Data.Aeson (ToJSON (..))

11−import Data.Aeson.Encode.Pretty (encodePretty', defConfig,

12− confCompare)

13−import Data.Swagger (Pattern, ToSchema,

14− toSchema)

15−import Data.Swagger.Schema.Validation

16−import Data.Text (Text)

17−import qualified Data.Text.Lazy as TL

18−import qualified Data.Text.Lazy.Encoding as TL

19−import Data.Typeable

20−import Test.Hspec

21−import Test.Hspec.QuickCheck

22−import Test.QuickCheck (Arbitrary, Property,

23− counterexample, property)

24−

25−import Servant.API

26−import Servant.Swagger.Internal.TypeLevel

27−

28−-- $setup

29−-- >>> import Control.Applicative

30−-- >>> import GHC.Generics

31−-- >>> import Test.QuickCheck

32−-- >>> import System.Environment (setEnv)

33−-- >>> :set -XDeriveGeneric

34−-- >>> :set -XGeneralizedNewtypeDeriving

35−-- >>> :set -XDataKinds

36−-- >>> :set -XTypeOperators

37−-- >>> setEnv "HSPEC_COLOR" "no"

38−

39−-- | Verify that every type used with @'JSON'@ content type in a servant API

40−-- has compatible @'ToJSON'@ and @'ToSchema'@ instances using @'validateToJSON'@.

41−--

42−-- /NOTE:/ @'validateEveryToJSON'@ does not perform string pattern validation.

43−-- See @'validateEveryToJSONWithPatternChecker'@.

44−--

45−-- @'validateEveryToJSON'@ will produce one @'prop'@ specification for every type in the API.

46−-- Each type only gets one test, even if it occurs multiple times in the API.

47−--

48−-- >>> data User = User { name :: String, age :: Maybe Int } deriving (Show, Generic, Typeable)

49−-- >>> newtype UserId = UserId String deriving (Show, Generic, Typeable, ToJSON, Arbitrary)

50−-- >>> instance ToJSON User

51−-- >>> instance ToSchema User

52−-- >>> instance ToSchema UserId

53−-- >>> instance Arbitrary User where arbitrary = User <$> arbitrary <*> arbitrary

54−-- >>> type UserAPI = (Capture "user_id" UserId :> Get '[JSON] User) :<|> (ReqBody '[JSON] User :> Post '[JSON] UserId)

55−--

56−-- >>> hspec $ context "ToJSON matches ToSchema" $ validateEveryToJSON (Proxy :: Proxy UserAPI)

57−-- <BLANKLINE>

58−-- ToJSON matches ToSchema...

59−-- User...

60−-- ...

61−-- UserId...

62−-- ...

63−-- Finished in ... seconds

64−-- 2 examples, 0 failures

65−--

66−-- For the test to compile all body types should have the following instances:

67−--

68−-- * @'ToJSON'@ and @'ToSchema'@ are used to perform the validation;

69−-- * @'Typeable'@ is used to name the test for each type;

70−-- * @'Show'@ is used to display value for which @'ToJSON'@ does not satisfy @'ToSchema'@.

71−-- * @'Arbitrary'@ is used to arbitrarily generate values.

72−--

73−-- If any of the instances is missing, you'll get a descriptive type error:

74−--

75−-- >>> data Contact = Contact { fullname :: String, phone :: Integer } deriving (Show, Generic)

76−-- >>> instance ToJSON Contact

77−-- >>> instance ToSchema Contact

78−-- >>> type ContactAPI = Get '[JSON] Contact

79−-- >>> hspec $ validateEveryToJSON (Proxy :: Proxy ContactAPI)

80−-- ...

81−-- ...No instance for (Arbitrary Contact)

82−-- ... arising from a use of ‘validateEveryToJSON’

83−-- ...

84−validateEveryToJSON

85− :: forall proxy api .

86− TMap (Every [Typeable, Show, Arbitrary, ToJSON, ToSchema])

87− (BodyTypes JSON api)

88− => proxy api -- ^ Servant API.

89− -> Spec

90−validateEveryToJSON _ = props

91− (Proxy :: Proxy [ToJSON, ToSchema])

92− (maybeCounterExample . prettyValidateWith validateToJSON)

93− (Proxy :: Proxy (BodyTypes JSON api))

94−

95−-- | Verify that every type used with @'JSON'@ content type in a servant API

96−-- has compatible @'ToJSON'@ and @'ToSchema'@ instances using @'validateToJSONWithPatternChecker'@.

97−--

98−-- For validation without patterns see @'validateEveryToJSON'@.

99−validateEveryToJSONWithPatternChecker :: forall proxy api. TMap (Every [Typeable, Show, Arbitrary, ToJSON, ToSchema]) (BodyTypes JSON api) =>

100− (Pattern -> Text -> Bool) -- ^ @'Pattern'@ checker.

101− -> proxy api -- ^ Servant API.

102− -> Spec

103−validateEveryToJSONWithPatternChecker checker _ = props

104− (Proxy :: Proxy [ToJSON, ToSchema])

105− (maybeCounterExample . prettyValidateWith (validateToJSONWithPatternChecker checker))

106− (Proxy :: Proxy (BodyTypes JSON api))

107−

108−-- * QuickCheck-related stuff

109−

110−-- | Construct property tests for each type in a list.

111−-- The name for each property is the name of the corresponding type.

112−--

113−-- >>> :{

114−-- hspec $

115−-- context "read . show == id" $

116−-- props

117−-- (Proxy :: Proxy [Eq, Show, Read])

118−-- (\x -> read (show x) === x)

119−-- (Proxy :: Proxy [Bool, Int, String])

120−-- :}

121−-- <BLANKLINE>

122−-- read . show == id

123−-- Bool...

124−-- ...

125−-- Int...

126−-- ...

127−-- [Char]...

128−-- ...

129−-- Finished in ... seconds

130−-- 3 examples, 0 failures

131−props :: forall p p'' cs xs. TMap (Every (Typeable ': Show ': Arbitrary ': cs)) xs =>

132− p cs -- ^ A list of constraints.

133− -> (forall x. EveryTF cs x => x -> Property) -- ^ Property predicate.

134− -> p'' xs -- ^ A list of types.

135− -> Spec

136−props _ f px = sequence_ specs

137− where

138− specs :: [Spec]

139− specs = tmapEvery (Proxy :: Proxy (Typeable ': Show ': Arbitrary ': cs)) aprop px

140−

141− aprop :: forall p' a. (EveryTF cs a, Typeable a, Show a, Arbitrary a) => p' a -> Spec

142− aprop _ = prop (show (typeOf (undefined :: a))) (f :: a -> Property)

143−

144−-- | Pretty print validation errors

145−-- together with actual JSON and Swagger Schema

146−-- (using 'encodePretty').

147−--

148−-- >>> import Data.Aeson

149−-- >>> import Data.Foldable (traverse_)

150−-- >>> data Person = Person { name :: String, phone :: Integer } deriving (Generic)

151−-- >>> instance ToJSON Person where toJSON p = object [ "name" .= name p ]

152−-- >>> instance ToSchema Person

153−-- >>> let person = Person { name = "John", phone = 123456 }

154−-- >>> traverse_ putStrLn $ prettyValidateWith validateToJSON person

155−-- Validation against the schema fails:

156−-- * property "phone" is required, but not found in "{\"name\":\"John\"}"

157−-- <BLANKLINE>

158−-- JSON value:

159−-- {

160−-- "name": "John"

161−-- }

162−-- <BLANKLINE>

163−-- Swagger Schema:

164−-- {

165−-- "properties": {

166−-- "name": {

167−-- "type": "string"

168−-- },

169−-- "phone": {

170−-- "type": "integer"

171−-- }

172−-- },

173−-- "required": [

174−-- "name",

175−-- "phone"

176−-- ],

177−-- "type": "object"

178−-- }

179−-- <BLANKLINE>

180−--

181−-- FIXME: this belongs in "Data.Swagger.Schema.Validation" (in @swagger2@).

182−prettyValidateWith

183− :: forall a. (ToJSON a, ToSchema a)

184− => (a -> [ValidationError]) -> a -> Maybe String

185−prettyValidateWith f x =

186− case f x of

187− [] -> Nothing

188− errors -> Just $ unlines

189− [ "Validation against the schema fails:"

190− , unlines (map (" * " ++) errors)

191− , "JSON value:"

192− , ppJSONString json

193− , ""

194− , "Swagger Schema:"

195− , ppJSONString (toJSON schema)

196− ]

197− where

198− ppJSONString = TL.unpack . TL.decodeUtf8 . encodePretty' ppCfg

199− ppCfg = defConfig { confCompare = compare }

200−

201− json = toJSON x

202− schema = toSchema (Proxy :: Proxy a)

203−

204−-- | Provide a counterexample if there is any.

205−maybeCounterExample :: Maybe String -> Property

206−maybeCounterExample Nothing = property True

207−maybeCounterExample (Just s) = counterexample s (property False)

servant-swagger/src/Servant/Swagger/Internal/TypeLevel.hsdeleted−9

@@ -1,9 +0,0 @@

1−module Servant.Swagger.Internal.TypeLevel (

2− module Servant.Swagger.Internal.TypeLevel.API,

3− module Servant.Swagger.Internal.TypeLevel.Every,

4− module Servant.Swagger.Internal.TypeLevel.TMap,

5−) where

6−

7−import Servant.Swagger.Internal.TypeLevel.API

8−import Servant.Swagger.Internal.TypeLevel.Every

9−import Servant.Swagger.Internal.TypeLevel.TMap

servant-swagger/src/Servant/Swagger/Internal/TypeLevel/API.hsdeleted−86

@@ -1,86 +0,0 @@

1−{-# LANGUAGE ConstraintKinds #-}

2−{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE KindSignatures #-}

4−{-# LANGUAGE PolyKinds #-}

5−{-# LANGUAGE TypeFamilies #-}

6−{-# LANGUAGE TypeOperators #-}

7−{-# LANGUAGE UndecidableInstances #-}

8−module Servant.Swagger.Internal.TypeLevel.API where

9−

10−import GHC.Exts (Constraint)

11−import Servant.API

12−

13−-- | Build a list of endpoints from an API.

14−type family EndpointsList api where

15− EndpointsList (a :<|> b) = AppendList (EndpointsList a) (EndpointsList b)

16− EndpointsList (e :> a) = MapSub e (EndpointsList a)

17− EndpointsList a = '[a]

18−

19−-- | Check whether @sub@ is a sub API of @api@.

20−type family IsSubAPI sub api :: Constraint where

21− IsSubAPI sub api = AllIsElem (EndpointsList sub) api

22−

23−-- | Check that every element of @xs@ is an endpoint of @api@.

24−type family AllIsElem xs api :: Constraint where

25− AllIsElem '[] api = ()

26− AllIsElem (x ': xs) api = (IsIn x api, AllIsElem xs api)

27−

28−-- | Apply @(e :>)@ to every API in @xs@.

29−type family MapSub e xs where

30− MapSub e '[] = '[]

31− MapSub e (x ': xs) = (e :> x) ': MapSub e xs

32−

33−-- | Append two type-level lists.

34−type family AppendList xs ys where

35− AppendList '[] ys = ys

36− AppendList (x ': xs) ys = x ': AppendList xs ys

37−

38−type family Or (a :: Constraint) (b :: Constraint) :: Constraint where

39− Or () b = ()

40− Or a () = ()

41−

42−type family IsIn sub api :: Constraint where

43− IsIn e (a :<|> b) = Or (IsIn e a) (IsIn e b)

44− IsIn (e :> a) (e :> b) = IsIn a b

45− IsIn e e = ()

46−

47−-- | Check whether a type is a member of a list of types.

48−-- This is a type-level analogue of @'elem'@.

49−type family Elem x xs where

50− Elem x '[] = 'False

51− Elem x (x ': xs) = 'True

52− Elem x (y ': xs) = Elem x xs

53−

54−-- | Remove duplicates from a type-level list.

55−type family Nub xs where

56− Nub '[] = '[]

57− Nub (x ': xs) = x ': Nub (Remove x xs)

58−

59−-- | Remove element from a type-level list.

60−type family Remove x xs where

61− Remove x '[] = '[]

62− Remove x (x ': ys) = Remove x ys

63− Remove x (y ': ys) = y ': Remove x ys

64−

65−-- | Extract a list of unique "body" types for a specific content-type from a servant API.

66−type BodyTypes c api = Nub (BodyTypes' c api)

67−

68−-- | @'AddBodyType' c cs a as@ adds type @a@ to the list @as@

69−-- only if @c@ is in @cs@.

70−type AddBodyType c cs a as = If (Elem c cs) (a ': as) as

71−

72−-- | Extract a list of "body" types for a specific content-type from a servant API.

73−-- To extract unique types see @'BodyTypes'@.

74−--

75−-- @'NoContent'@ is removed from the list and not tested. (This allows for leaving the body

76−-- completely empty on responses to requests that only accept 'application/json', while

77−-- setting the content-type in the response accordingly.)

78−type family BodyTypes' c api :: [*] where

79− BodyTypes' c (Verb verb b cs (Headers hdrs a)) = AddBodyType c cs a '[]

80− BodyTypes' c (Verb verb b cs NoContent) = '[]

81− BodyTypes' c (Verb verb b cs a) = AddBodyType c cs a '[]

82− BodyTypes' c (ReqBody' mods cs a :> api) = AddBodyType c cs a (BodyTypes' c api)

83− BodyTypes' c (e :> api) = BodyTypes' c api

84− BodyTypes' c (a :<|> b) = AppendList (BodyTypes' c a) (BodyTypes' c b)

85− BodyTypes' c api = '[]

86−

servant-swagger/src/Servant/Swagger/Internal/TypeLevel/Every.hsdeleted−63

@@ -1,63 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE ConstraintKinds #-}

3−{-# LANGUAGE DataKinds #-}

4−{-# LANGUAGE FlexibleContexts #-}

5−{-# LANGUAGE FlexibleInstances #-}

6−{-# LANGUAGE GADTs #-}

7−{-# LANGUAGE InstanceSigs #-}

8−{-# LANGUAGE KindSignatures #-}

9−{-# LANGUAGE MultiParamTypeClasses #-}

10−{-# LANGUAGE PolyKinds #-}

11−{-# LANGUAGE RankNTypes #-}

12−{-# LANGUAGE ScopedTypeVariables #-}

13−{-# LANGUAGE TypeFamilies #-}

14−{-# LANGUAGE TypeOperators #-}

15−{-# LANGUAGE UndecidableInstances #-}

16−#if __GLASGOW_HASKELL__ >= 800

17−{-# LANGUAGE UndecidableSuperClasses #-}

18−#endif

19−module Servant.Swagger.Internal.TypeLevel.Every where

20−

21−import Data.Proxy

22−import GHC.Exts (Constraint)

23−

24−import Servant.Swagger.Internal.TypeLevel.TMap

25−

26−-- $setup

27−-- >>> :set -XDataKinds

28−-- >>> :set -XFlexibleContexts

29−-- >>> :set -XGADTs

30−-- >>> :set -XRankNTypes

31−-- >>> :set -XScopedTypeVariables

32−-- >>> import GHC.TypeLits

33−-- >>> import Data.List

34−

35−-- | Apply multiple constraint constructors to a type.

36−--

37−-- @

38−-- EveryTF '[Show, Read] a ~ (Show a, Read a)

39−-- @

40−--

41−-- Note that since this is a type family, you have to alway fully apply @'EveryTF'@.

42−--

43−-- For partial application of multiple constraint constructors see @'Every'@.

44−type family EveryTF cs x :: Constraint where

45− EveryTF '[] x = ()

46− EveryTF (c ': cs) x = (c x, EveryTF cs x)

47−

48−-- | Apply multiple constraint constructors to a type as a class.

49−--

50−-- This is different from @'EveryTF'@ in that it allows partial application.

51−class EveryTF cs x => Every (cs :: [* -> Constraint]) (x :: *) where

52−

53−instance Every '[] x where

54−instance (c x, Every cs x) => Every (c ': cs) x where

55−

56−-- | Like @'tmap'@, but uses @'Every'@ for multiple constraints.

57−--

58−-- >>> let zero :: forall p a. (Show a, Num a) => p a -> String; zero _ = show (0 :: a)

59−-- >>> tmapEvery (Proxy :: Proxy [Show, Num]) zero (Proxy :: Proxy [Int, Float]) :: [String]

60−-- ["0","0.0"]

61−tmapEvery :: forall a cs p p'' xs. (TMap (Every cs) xs) =>

62− p cs -> (forall x p'. Every cs x => p' x -> a) -> p'' xs -> [a]

63−tmapEvery _ = tmap (Proxy :: Proxy (Every cs))

servant-swagger/src/Servant/Swagger/Internal/TypeLevel/TMap.hsdeleted−37

@@ -1,37 +0,0 @@

1−{-# LANGUAGE ConstraintKinds #-}

2−{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE FlexibleInstances #-}

4−{-# LANGUAGE KindSignatures #-}

5−{-# LANGUAGE MultiParamTypeClasses #-}

6−{-# LANGUAGE PolyKinds #-}

7−{-# LANGUAGE RankNTypes #-}

8−{-# LANGUAGE ScopedTypeVariables #-}

9−{-# LANGUAGE TypeOperators #-}

10−{-# LANGUAGE UndecidableInstances #-}

11−module Servant.Swagger.Internal.TypeLevel.TMap where

12−

13−import Data.Proxy

14−import GHC.Exts (Constraint)

15−

16−-- $setup

17−-- >>> :set -XDataKinds

18−-- >>> :set -XFlexibleContexts

19−-- >>> :set -XGADTs

20−-- >>> :set -XRankNTypes

21−-- >>> :set -XScopedTypeVariables

22−-- >>> import GHC.TypeLits

23−-- >>> import Data.List

24−

25−-- | Map a list of constrained types to a list of values.

26−--

27−-- >>> tmap (Proxy :: Proxy KnownSymbol) symbolVal (Proxy :: Proxy ["hello", "world"])

28−-- ["hello","world"]

29−class TMap (q :: k -> Constraint) (xs :: [k]) where

30− tmap :: p q -> (forall x p'. q x => p' x -> a) -> p'' xs -> [a]

31−

32−instance TMap q '[] where

33− tmap _ _ _ = []

34−

35−instance (q x, TMap q xs) => TMap q (x ': xs) where

36− tmap q f _ = f (Proxy :: Proxy x) : tmap q f (Proxy :: Proxy xs)

37−

servant-swagger/src/Servant/Swagger/Test.hsdeleted−13

@@ -1,13 +0,0 @@

1−-- |

2−-- Module: Servant.Swagger.Test

3−-- License: BSD3

4−-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>

5−-- Stability: experimental

6−--

7−-- Automatic tests for servant API against Swagger spec.

8−module Servant.Swagger.Test (

9− validateEveryToJSON,

10− validateEveryToJSONWithPatternChecker,

11−) where

12−

13−import Servant.Swagger.Internal.Test

servant-swagger/src/Servant/Swagger/TypeLevel.hsdeleted−15

@@ -1,15 +0,0 @@

1−-- |

2−-- Module: Servant.Swagger.TypeLevel

3−-- License: BSD3

4−-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>

5−-- Stability: experimental

6−--

7−-- Useful type families for servant APIs.

8−module Servant.Swagger.TypeLevel (

9− IsSubAPI,

10− EndpointsList,

11− BodyTypes,

12−) where

13−

14−import Servant.Swagger.Internal.TypeLevel

15−

servant-swagger/test/Servant/SwaggerSpec.hsdeleted−489

@@ -1,489 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE DeriveDataTypeable #-}

4−{-# LANGUAGE DeriveGeneric #-}

5−{-# LANGUAGE OverloadedStrings #-}

6−{-# LANGUAGE QuasiQuotes #-}

7−{-# LANGUAGE TypeFamilies #-}

8−{-# LANGUAGE TypeOperators #-}

9−{-# LANGUAGE PackageImports #-}

10−module Servant.SwaggerSpec where

11−

12−import Control.Lens

13−import Data.Aeson (ToJSON(toJSON), Value, genericToJSON)

14−import Data.Aeson.QQ.Simple

15−import qualified Data.Aeson.Types as JSON

16−import Data.Char (toLower)

17−import Data.Int (Int64)

18−import Data.Proxy

19−import Data.Swagger

20−import Data.Text (Text)

21−import Data.Time

22−import GHC.Generics

23−import Servant.API

24−import Servant.Swagger

25−import Servant.Test.ComprehensiveAPI (comprehensiveAPI)

26−import Test.Hspec hiding (example)

27−

28−#if !MIN_VERSION_swagger2(2,4,0)

29−import Data.Aeson.Lens (key, _Array)

30−import qualified Data.Vector as V

31−#endif

32−

33−checkAPI :: HasSwagger api => Proxy api -> Value -> IO ()

34−checkAPI proxy = checkSwagger (toSwagger proxy)

35−

36−checkSwagger :: Swagger -> Value -> IO ()

37−checkSwagger swag js = toJSON swag `shouldBe` js

38−

39−spec :: Spec

40−spec = describe "HasSwagger" $ do

41− it "Todo API" $ checkAPI (Proxy :: Proxy TodoAPI) todoAPI

42− it "Hackage API (with tags)" $ checkSwagger hackageSwaggerWithTags hackageAPI

43− it "GetPost API (test subOperations)" $ checkSwagger getPostSwagger getPostAPI

44− it "UVerb API" $ checkSwagger uverbSwagger uverbAPI

45− it "Comprehensive API" $ do

46− let _x = toSwagger comprehensiveAPI

47− True `shouldBe` True -- type-level test

48−

49−main :: IO ()

50−main = hspec spec

51−

52−-- =======================================================================

53−-- Todo API

54−-- =======================================================================

55−

56−data Todo = Todo

57− { created :: UTCTime

58− , title :: String

59− , summary :: Maybe String

60− } deriving (Generic)

61−

62−instance ToJSON Todo

63−instance ToSchema Todo

64−

65−newtype TodoId = TodoId String deriving (Generic)

66−instance ToParamSchema TodoId

67−

68−type TodoAPI = "todo" :> Capture "id" TodoId :> Get '[JSON] Todo

69−

70−todoAPI :: Value

71−todoAPI = [aesonQQ|

72−{

73− "swagger":"2.0",

74− "info":

75− {

76− "title": "",

77− "version": ""

78− },

79− "definitions":

80− {

81− "Todo":

82− {

83− "type": "object",

84− "required": [ "created", "title" ],

85− "properties":

86− {

87− "created": { "$ref": "#/definitions/UTCTime" },

88− "title": { "type": "string" },

89− "summary": { "type": "string" }

90− }

91− },

92− "UTCTime":

93− {

94− "type": "string",

95− "format": "yyyy-mm-ddThh:MM:ssZ",

96− "example": "2016-07-22T00:00:00Z"

97− }

98− },

99− "paths":

100− {

101− "/todo/{id}":

102− {

103− "get":

104− {

105− "responses":

106− {

107− "200":

108− {

109− "schema": { "$ref":"#/definitions/Todo" },

110− "description": ""

111− },

112− "400": { "description": "Invalid `id`" }

113− },

114− "produces": [ "application/json;charset=utf-8" ],

115− "parameters":

116− [

117− {

118− "required": true,

119− "in": "path",

120− "name": "id",

121− "type": "string"

122− }

123− ]

124− }

125− }

126− }

127−}

128−|]

129−

130−-- =======================================================================

131−-- Hackage API

132−-- =======================================================================

133−

134−type HackageAPI

135− = HackageUserAPI

136− :<|> HackagePackagesAPI

137−

138−type HackageUserAPI =

139− "users" :> Get '[JSON] [UserSummary]

140− :<|> "user" :> Capture "username" Username :> Get '[JSON] UserDetailed

141−

142−type HackagePackagesAPI

143− = "packages" :> Get '[JSON] [Package]

144−

145−type Username = Text

146−

147−data UserSummary = UserSummary

148− { summaryUsername :: Username

149− , summaryUserid :: Int64 -- Word64 would make sense too

150− } deriving (Eq, Show, Generic)

151−

152−lowerCutPrefix :: String -> String -> String

153−lowerCutPrefix s = map toLower . drop (length s)

154−

155−instance ToJSON UserSummary where

156− toJSON = genericToJSON JSON.defaultOptions { JSON.fieldLabelModifier = lowerCutPrefix "summary" }

157−

158−instance ToSchema UserSummary where

159− declareNamedSchema proxy = genericDeclareNamedSchema defaultSchemaOptions { fieldLabelModifier = lowerCutPrefix "summary" } proxy

160− & mapped.schema.example ?~ toJSON UserSummary

161− { summaryUsername = "JohnDoe"

162− , summaryUserid = 123 }

163−

164−type Group = Text

165−

166−data UserDetailed = UserDetailed

167− { username :: Username

168− , userid :: Int64

169− , groups :: [Group]

170− } deriving (Eq, Show, Generic)

171−instance ToSchema UserDetailed

172−

173−newtype Package = Package { packageName :: Text }

174− deriving (Eq, Show, Generic)

175−instance ToSchema Package

176−

177−hackageSwaggerWithTags :: Swagger

178−hackageSwaggerWithTags = toSwagger (Proxy :: Proxy HackageAPI)

179− & host ?~ Host "hackage.haskell.org" Nothing

180− & applyTagsFor usersOps ["users" & description ?~ "Operations about user"]

181− & applyTagsFor packagesOps ["packages" & description ?~ "Query packages"]

182− where

183− usersOps, packagesOps :: Traversal' Swagger Operation

184− usersOps = subOperations (Proxy :: Proxy HackageUserAPI) (Proxy :: Proxy HackageAPI)

185− packagesOps = subOperations (Proxy :: Proxy HackagePackagesAPI) (Proxy :: Proxy HackageAPI)

186−

187−hackageAPI :: Value

188−hackageAPI = modifyValue [aesonQQ|

189−{

190− "swagger":"2.0",

191− "host":"hackage.haskell.org",

192− "info":{

193− "version":"",

194− "title":""

195− },

196− "definitions":{

197− "UserDetailed":{

198− "required":[

199− "username",

200− "userid",

201− "groups"

202− ],

203− "type":"object",

204− "properties":{

205− "groups":{

206− "items":{

207− "type":"string"

208− },

209− "type":"array"

210− },

211− "username":{

212− "type":"string"

213− },

214− "userid":{

215− "maximum":9223372036854775807,

216− "minimum":-9223372036854775808,

217− "type":"integer",

218− "format":"int64"

219− }

220− }

221− },

222− "Package":{

223− "required":[

224− "packageName"

225− ],

226− "type":"object",

227− "properties":{

228− "packageName":{

229− "type":"string"

230− }

231− }

232− },

233− "UserSummary":{

234− "required":[

235− "username",

236− "userid"

237− ],

238− "type":"object",

239− "properties":{

240− "username":{

241− "type":"string"

242− },

243− "userid":{

244− "maximum":9223372036854775807,

245− "minimum":-9223372036854775808,

246− "type":"integer",

247− "format":"int64"

248− }

249− },

250− "example":{

251− "username": "JohnDoe",

252− "userid": 123

253− }

254− }

255− },

256− "paths":{

257− "/users":{

258− "get":{

259− "responses":{

260− "200":{

261− "schema":{

262− "items":{

263− "$ref":"#/definitions/UserSummary"

264− },

265− "type":"array"

266− },

267− "description":""

268− }

269− },

270− "produces":[

271− "application/json;charset=utf-8"

272− ],

273− "tags":[

274− "users"

275− ]

276− }

277− },

278− "/packages":{

279− "get":{

280− "responses":{

281− "200":{

282− "schema":{

283− "items":{

284− "$ref":"#/definitions/Package"

285− },

286− "type":"array"

287− },

288− "description":""

289− }

290− },

291− "produces":[

292− "application/json;charset=utf-8"

293− ],

294− "tags":[

295− "packages"

296− ]

297− }

298− },

299− "/user/{username}":{

300− "get":{

301− "responses":{

302− "400":{

303− "description":"Invalid `username`"

304− },

305− "200":{

306− "schema":{

307− "$ref":"#/definitions/UserDetailed"

308− },

309− "description":""

310− }

311− },

312− "produces":[

313− "application/json;charset=utf-8"

314− ],

315− "parameters":[

316− {

317− "required":true,

318− "in":"path",

319− "name":"username",

320− "type":"string"

321− }

322− ],

323− "tags":[

324− "users"

325− ]

326− }

327− }

328− },

329− "tags":[

330− {

331− "name":"users",

332− "description":"Operations about user"

333− },

334− {

335− "name":"packages",

336− "description":"Query packages"

337− }

338− ]

339−}

340−|]

341− where

342− modifyValue :: Value -> Value

343−#if MIN_VERSION_swagger2(2,4,0)

344− modifyValue = id

345−#else

346− -- swagger2-2.4 preserves order of tags

347− -- swagger2-2.3 used Set, so they are ordered

348− -- packages comes before users.

349− -- We simply reverse, not properly sort here for simplicity: 2 elements.

350− modifyValue = over (key "tags" . _Array) V.reverse

351−#endif

352−

353−

354−-- =======================================================================

355−-- Get/Post API (test for subOperations)

356−-- =======================================================================

357−

358−type GetPostAPI = Get '[JSON] String :<|> Post '[JSON] String

359−

360−getPostSwagger :: Swagger

361−getPostSwagger = toSwagger (Proxy :: Proxy GetPostAPI)

362− & applyTagsFor getOps ["get" & description ?~ "GET operations"]

363− where

364− getOps :: Traversal' Swagger Operation

365− getOps = subOperations (Proxy :: Proxy (Get '[JSON] String)) (Proxy :: Proxy GetPostAPI)

366−

367−getPostAPI :: Value

368−getPostAPI = [aesonQQ|

369−{

370− "swagger":"2.0",

371− "info":{

372− "version":"",

373− "title":""

374− },

375− "paths":{

376− "/":{

377− "post":{

378− "responses":{

379− "200":{

380− "schema":{

381− "type":"string"

382− },

383− "description":""

384− }

385− },

386− "produces":[ "application/json;charset=utf-8" ]

387− },

388− "get":{

389− "responses":{

390− "200":{

391− "schema":{

392− "type":"string"

393− },

394− "description":""

395− }

396− },

397− "produces":[ "application/json;charset=utf-8" ],

398− "tags":[ "get" ]

399− }

400− }

401− },

402− "tags":[

403− {

404− "name":"get",

405− "description":"GET operations"

406− }

407− ]

408−}

409−|]

410−

411−-- =======================================================================

412−-- UVerb API

413−-- =======================================================================

414−

415−data Lunch = Lunch {name :: String}

416− deriving (Eq, Show, Generic)

417−

418−instance ToSchema Lunch

419−

420−instance HasStatus Lunch where

421− type StatusOf Lunch = 200

422−

423−data NoLunch = NoLunch

424− deriving (Eq, Show, Generic)

425−

426−instance ToSchema NoLunch

427−

428−instance HasStatus NoLunch where

429− type StatusOf NoLunch = 404

430−

431−type UVerbAPI2 =

432− "lunch" :> UVerb 'GET '[JSON] '[Lunch, NoLunch]

433−

434−uverbSwagger :: Swagger

435−uverbSwagger = toSwagger (Proxy :: Proxy UVerbAPI2)

436−

437−uverbAPI :: Value

438−uverbAPI =

439− [aesonQQ|

440− {

441− "swagger": "2.0",

442− "info": {

443− "version": "",

444− "title": ""

445− },

446− "definitions": {

447− "Lunch": {

448− "required": [

449− "name"

450− ],

451− "type": "object",

452− "properties": {

453− "name": {

454− "type": "string"

455− }

456− }

457− },

458− "NoLunch": {

459− "type": "string",

460− "enum": [

461− "NoLunch"

462− ]

463− }

464− },

465− "paths": {

466− "/lunch": {

467− "get": {

468− "responses": {

469− "404": {

470− "schema": {

471− "$ref": "#/definitions/NoLunch"

472− },

473− "description": ""

474− },

475− "200": {

476− "schema": {

477− "$ref": "#/definitions/Lunch"

478− },

479− "description": ""

480− }

481− },

482− "produces": [

483− "application/json;charset=utf-8"

484− ]

485− }

486− }

487− }

488−}

489−|]

servant-swagger/test/Spec.hsdeleted−1

@@ -1 +0,0 @@

1−{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

servant-swagger/test/doctests.hsdeleted−12

@@ -1,12 +0,0 @@

1−module Main where

2−

3−import Build_doctests (flags, pkgs, module_sources)

4−import Data.Foldable (traverse_)

5−import Test.DocTest

6−

7−main :: IO ()

8−main = do

9− traverse_ putStrLn args

10− doctest args

11− where

12− args = flags ++ pkgs ++ module_sources

servant/CHANGELOG.md−121

@@ -1,126 +1,5 @@

11[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)

22

3−Package versions follow the [Package Versioning Policy](https://pvp.haskell.org/): in A.B.C, bumps to either A or B represent major versions.

4−

5−0.19.1

6−------

7−

8−Compatibility with GHC 9.4, see [PR #1592](https://github.com/haskell-servant/servant/pull/1592).

9−

10−0.19

11−----

12−

13−### Significant changes

14−

15−- Drop support for GHC < 8.6.

16−- Support GHC 9.0 (GHC 9.2 should work as well, but isn't fully tested yet).

17−- Support Aeson 2 ([#1475](https://github.com/haskell-servant/servant/pull/1475)),

18− which fixes a [DOS vulnerability](https://github.com/haskell/aeson/issues/864)

19− related to hash collisions.

20−- Add `NamedRoutes` combinator, making support for records first-class in Servant

21− ([#1388](https://github.com/haskell-servant/servant/pull/1388)).

22−

23− Users can now directly mark part as an API as defined by a record, instead of

24− using `(:<|>)` to combine routes. Concretely, the anonymous:

25−

26− ```haskell

27− type API =

28− "version" :> Get '[JSON] String :<|>

29− "products" :> Get '[JSON] [Product]

30− ```

31−

32− can be replaced with the explicitly-named:

33−

34− ```haskell

35− type API = NamedRoutes NamedAPI

36− data NamedAPI mode = NamedAPI

37− { version :: mode :- "version" :> Get '[JSON] String

38− , products :: mode :- "products" :> Get '[JSON] [Product]

39− }

40− ```

41−

42− `NamedRoutes` builds upon `servant-generic`, but improves usability by freeing

43− users from the need to perform `toServant` / `fromServant` conversions

44− manually. Serving `NamedRoutes NamedAPI` is now done directly by providing a

45− record of handlers, and servant generates clients directly as records as well.

46− In particular, it makes it much more practical to work with nested hierarchies

47− of named routes.

48−

49− Two convenience functions, `(//)` and `(/:)`, have been added to make the

50− usage of named route hierarchies more pleasant:

51−

52− ```haskell

53− rootClient :: RootApi (AsClientT ClientM)

54− rootClient = client (Proxy @API)

55−

56− helloClient :: String -> ClientM String

57− helloClient name = rootClient // hello /: name

58−

59− endpointClient :: ClientM Person

60− endpointClient = rootClient // subApi /: "foobar123" // endpoint

61−

62− type Api = NamedRoutes RootApi

63−

64− data RootApi mode = RootApi

65− { subApi :: mode :- Capture "token" String :> NamedRoutes SubApi

66− , hello :: mode :- Capture "name" String :> Get '[JSON] String

67− , …

68− } deriving Generic

69−

70− data SubApi mode = SubApi

71− { endpoint :: mode :- Get '[JSON] Person

72− , …

73− } deriving Generic

74− ```

75−

76−- Add custom type errors for partially applied combinators

77− ([#1289](https://github.com/haskell-servant/servant/pull/1289),

78− [#1486](https://github.com/haskell-servant/servant/pull/1486)).

79−

80− For example, forgetting to document the expected type for a query parameter,

81− as in:

82−

83− ``` haskell

84− type API = QueryParam "param" :> Get '[JSON] NoContent

85− ```

86−

87− will raise to the following error when trying to serve the API:

88−

89− ```

90− • There is no instance for HasServer (QueryParam'

91− '[Optional, Strict] "param" :> ...)

92− QueryParam' '[Optional, Strict] "1" expects 1 more arguments

93− ```

94−

95− As a consequence of this change, unsaturated types are now forbidden before `(:>)`.

96−

97−- Add a `HeadNoContent` verb ([#1502](https://github.com/haskell-servant/servant/pull/1502)).

98−

99−- *servant-client* / *servant-client-core* / *servant-http-streams*:

100− Fix erroneous behavior, where only 2XX status codes would be considered

101− successful, irrelevant of the status parameter specified by the verb

102− combinator. ([#1469](https://github.com/haskell-servant/servant/pull/1469))

103−

104−- *servant-client* / *servant-client-core*: Fix `Show` instance for

105− `Servant.Client.Core.Request`.

106−

107−

108−- *servant-client* / *servant-client-core*: Allow passing arbitrary binary data

109− in Query parameters.

110− ([#1432](https://github.com/haskell-servant/servant/pull/1432)).

111−

112−- *servant-docs*: Generate sample cURL requests

113− ([#1401](https://github.com/haskell-servant/servant/pull/1401/files)).

114−

115− Breaking change: requires sample header values to be supplied with `headers`.

116−

117−### Other changes

118−

119−- Various bit rotten cookbooks have been updated and re-introduced on

120− [docs.servant.dev](https://docs.servant.dev).

121−

122−- Various version bumps.

123−

12430.18.3

1254------

1265

servant/servant.cabal+13−16

@@ -1,6 +1,6 @@

1−cabal-version: 2.2

1+cabal-version: >=1.10

22name: servant

3−version: 0.19.1

3+version: 0.18.3

44

55synopsis: A family of combinators for defining webservices APIs

66category: Servant, Web

@@ -46,7 +46,6 @@ library

4646 Servant.API.HttpVersion

4747 Servant.API.IsSecure

4848 Servant.API.Modifiers

49− Servant.API.NamedRoutes

5049 Servant.API.QueryParam

5150 Servant.API.Raw

5251 Servant.API.RemoteHost

@@ -55,14 +54,12 @@ library

5554 Servant.API.Status

5655 Servant.API.Stream

5756 Servant.API.Sub

58− Servant.API.TypeErrors

5957 Servant.API.TypeLevel

6058 Servant.API.UVerb

6159 Servant.API.UVerb.Union

6260 Servant.API.Vault

6361 Servant.API.Verbs

6462 Servant.API.WithNamedContext

65− Servant.API.WithResource

6663

6764 -- Types

6865 exposed-modules:

@@ -81,33 +78,33 @@ library

8178 --

8279 -- note: mtl lower bound is so low because of GHC-7.8

8380 build-depends:

84− base >= 4.9 && < 4.18

81+ base >= 4.9 && < 4.16

8582 , bytestring >= 0.10.8.1 && < 0.12

86− , constraints >= 0.2

87− , mtl ^>= 2.2.2 || ^>= 2.3.1

83+ , constraints

84+ , mtl >= 2.2.2 && < 2.3

8885 , sop-core >= 0.4.0.0 && < 0.6

89− , transformers >= 0.5.2.0 && < 0.7

90− , text >= 1.2.3.0 && < 2.1

86+ , transformers >= 0.5.2.0 && < 0.6

87+ , text >= 1.2.3.0 && < 1.3

9188

9289

9390 -- We depend (heavily) on the API of these packages:

9491 -- i.e. re-export, or allow using without direct dependency

9592 build-depends:

96− http-api-data >= 0.4.1 && < 0.5.1

93+ http-api-data >= 0.4.1 && < 0.4.4

9794 , singleton-bool >= 0.1.4 && < 0.1.7

9895

9996 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.

10097 -- Here can be exceptions if we really need features from the newer versions.

10198 build-depends:

102− base-compat >= 0.10.5 && < 0.13

103− , aeson >= 1.4.1.0 && < 3

99+ base-compat >= 0.10.5 && < 0.12

100+ , aeson >= 1.4.1.0 && < 1.6

104101 , attoparsec >= 0.13.2.2 && < 0.15

105102 , bifunctors >= 5.5.3 && < 5.6

106103 , case-insensitive >= 1.2.0.11 && < 1.3

107104 , deepseq >= 1.4.2.0 && < 1.5

108105 , http-media >= 0.7.1.3 && < 0.9

109106 , http-types >= 0.12.2 && < 0.13

110− , mmorph >= 1.1.2 && < 1.3

107+ , mmorph >= 1.1.2 && < 1.2

111108 , network-uri >= 2.6.1.0 && < 2.7

112109 , QuickCheck >= 2.12.6.1 && < 2.15

113110 , string-conversions >= 0.4.0.1 && < 0.5

@@ -167,9 +164,9 @@ test-suite spec

167164

168165 -- Additional dependencies

169166 build-depends:

170− hspec >= 2.6.0 && < 2.10

167+ hspec >= 2.6.0 && < 2.9

171168 , QuickCheck >= 2.12.6.1 && < 2.15

172169 , quickcheck-instances >= 0.3.19 && < 0.4

173170

174171 build-tool-depends:

175− hspec-discover:hspec-discover >= 2.6.0 && < 2.10

172+ hspec-discover:hspec-discover >= 2.6.0 && < 2.9

servant/src/Servant/API.hs+1−14

@@ -31,17 +31,11 @@ module Servant.API (

3131 -- | Access the location for arbitrary data to be shared by applications and middleware

3232 module Servant.API.WithNamedContext,

3333 -- | Access context entries in combinators in servant-server

34− module Servant.API.WithResource,

35− -- | Access a managed resource scoped to a single request

3634

3735 -- * Actual endpoints, distinguished by HTTP method

3836 module Servant.API.Verbs,

3937 module Servant.API.UVerb,

4038

41− -- * Sub-APIs defined as records of routes

42− module Servant.API.NamedRoutes,

43− module Servant.API.Generic,

44−

4539 -- * Streaming endpoints, distinguished by HTTP method

4640 module Servant.API.Stream,

4741

@@ -103,9 +97,6 @@ import Servant.API.Experimental.Auth

10397 (AuthProtect)

10498import Servant.API.Fragment

10599 (Fragment)

106−import Servant.API.Generic

107− (AsApi, GServantProduct, GenericMode ((:-)), GenericServant,

108− ToServant, ToServantApi, fromServant, genericApi, toServant)

109100import Servant.API.Header

110101 (Header, Header')

111102import Servant.API.HttpVersion

@@ -114,12 +105,10 @@ import Servant.API.IsSecure

114105 (IsSecure (..))

115106import Servant.API.Modifiers

116107 (Lenient, Optional, Required, Strict)

117−import Servant.API.NamedRoutes

118− (NamedRoutes)

119108import Servant.API.QueryParam

120109 (QueryFlag, QueryParam, QueryParam', QueryParams)

121110import Servant.API.Raw

122− (Raw, RawM)

111+ (Raw)

123112import Servant.API.RemoteHost

124113 (RemoteHost)

125114import Servant.API.ReqBody

@@ -152,8 +141,6 @@ import Servant.API.Verbs

152141 ReflectMethod (reflectMethod), StdMethod (..), Verb)

153142import Servant.API.WithNamedContext

154143 (WithNamedContext)

155−import Servant.API.WithResource

156− (WithResource)

157144import Servant.Links

158145 (HasLink (..), IsElem, IsElem', Link, URI (..), safeLink)

159146import Web.HttpApiData

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 _ NoContent = map (, "") $ NE.toList $ contentTypes pctyp

298+ allMimeRender _ _ = map (, "") $ NE.toList $ contentTypes pctyp

299299 where

300300 pctyp = Proxy :: Proxy ctyp

301301

servant/src/Servant/API/Generic.hs+5

@@ -37,6 +37,8 @@ module Servant.API.Generic (

3737 ToServant,

3838 toServant,

3939 fromServant,

40+ -- * NamedRoutes combinator

41+ NamedRoutes,

4042 -- * AsApi

4143 AsApi,

4244 ToServantApi,

@@ -120,6 +122,9 @@ genericApi

120122 -> Proxy (ToServantApi routes)

121123genericApi _ = Proxy

122124

125+-- | Combinator for embedding a record of named routes into a Servant API type.

126+data NamedRoutes (api :: * -> *)

127+

123128-------------------------------------------------------------------------------

124129-- Class

125130-------------------------------------------------------------------------------

servant/src/Servant/API/NamedRoutes.hsdeleted−10

@@ -1,10 +0,0 @@

1−{-# LANGUAGE KindSignatures #-}

2−{-# OPTIONS_HADDOCK not-home #-}

3−

4−module Servant.API.NamedRoutes (

5− -- * NamedRoutes combinator

6− NamedRoutes

7− ) where

8−

9−-- | Combinator for embedding a record of named routes into a Servant API type.

10−data NamedRoutes (api :: * -> *)

servant/src/Servant/API/Raw.hs−3

@@ -15,6 +15,3 @@ import Data.Typeable

1515-- <https://hackage.haskell.org/package/servant-server/docs/Servant-Server-StaticFiles.html Servant.Server.StaticFiles>

1616-- to serve static files stored in a particular directory on your filesystem

1717data Raw deriving Typeable

18−

19−-- | Variant of 'Raw' that lets you access the underlying monadic context to process the request.

20−data RawM deriving Typeable

servant/src/Servant/API/ResponseHeaders.hs+11−29

@@ -3,12 +3,13 @@

33{-# LANGUAGE DeriveFunctor #-}

44{-# LANGUAGE FlexibleContexts #-}

55{-# LANGUAGE FlexibleInstances #-}

6−{-# LANGUAGE GADTs #-}

76{-# LANGUAGE FunctionalDependencies #-}

7+{-# LANGUAGE GADTs #-}

8+{-# LANGUAGE KindSignatures #-}

9+{-# LANGUAGE MultiParamTypeClasses #-}

810{-# LANGUAGE PolyKinds #-}

911{-# LANGUAGE ScopedTypeVariables #-}

1012{-# LANGUAGE TypeFamilies #-}

11−{-# LANGUAGE TypeFamilyDependencies #-}

1213{-# LANGUAGE TypeOperators #-}

1314{-# LANGUAGE UndecidableInstances #-}

1415{-# OPTIONS_HADDOCK not-home #-}

@@ -50,11 +51,11 @@ import Web.HttpApiData

5051

5152import Prelude ()

5253import Prelude.Compat

54+import Servant.API.ContentTypes

55+ (JSON, PlainText, FormUrlEncoded, OctetStream,

56+ MimeRender(..))

5357import Servant.API.Header

5458 (Header)

55−import Servant.API.UVerb.Union

56−import qualified Data.SOP.BasicFunctors as SOP

57−import qualified Data.SOP.NS as SOP

5859

5960-- | Response Header objects. You should never need to construct one directly.

6061-- Instead, use 'addOptionalHeader'.

@@ -116,7 +117,7 @@ instance {-# OVERLAPPABLE #-} ( FromHttpApiData v, BuildHeadersTo xs, KnownSymbo

116117 `HCons` buildHeadersTo headers

117118 Right h -> Header h `HCons` buildHeadersTo headers

118119

119−-- * Getting headers

120+-- * Getting

120121

121122class GetHeaders ls where

122123 getHeaders :: ls -> [HTTP.Header]

@@ -157,42 +158,23 @@ instance (KnownSymbol h, GetHeadersFromHList rest, ToHttpApiData v)

157158 where

158159 getHeaders' hs = getHeadersFromHList $ getHeadersHList hs

159160

160−-- * Adding headers

161+-- * Adding

161162

162163-- We need all these fundeps to save type inference

163164class AddHeader h v orig new

164165 | h v orig -> new, new -> h, new -> v, new -> orig where

165166 addOptionalHeader :: ResponseHeader h v -> orig -> new -- ^ N.B.: The same header can't be added multiple times

166167

167−-- In this instance, we add a Header on top of something that is already decorated with some headers

168+

168169instance {-# OVERLAPPING #-} ( KnownSymbol h, ToHttpApiData v )

169170 => AddHeader h v (Headers (fst ': rest) a) (Headers (Header h v ': fst ': rest) a) where

170171 addOptionalHeader hdr (Headers resp heads) = Headers resp (HCons hdr heads)

171172

172−-- In this instance, 'a' parameter is decorated with a Header.

173−instance {-# OVERLAPPABLE #-} ( KnownSymbol h, ToHttpApiData v , new ~ Headers '[Header h v] a)

173+instance {-# OVERLAPPABLE #-} ( KnownSymbol h, ToHttpApiData v

174+ , new ~ (Headers '[Header h v] a) )

174175 => AddHeader h v a new where

175176 addOptionalHeader hdr resp = Headers resp (HCons hdr HNil)

176177

177−-- Instances to decorate all responses in a 'Union' with headers. The functional

178−-- dependencies force us to consider singleton lists as the base case in the

179−-- recursion (it is impossible to determine h and v otherwise from old / new

180−-- responses if the list is empty).

181−instance (AddHeader h v old new) => AddHeader h v (Union '[old]) (Union '[new]) where

182− addOptionalHeader hdr resp =

183− SOP.Z $ SOP.I $ addOptionalHeader hdr $ SOP.unI $ SOP.unZ $ resp

184−

185−instance

186− ( AddHeader h v old new, AddHeader h v (Union oldrest) (Union newrest)

187− -- This ensures that the remainder of the response list is _not_ empty

188− -- It is necessary to prevent the two instances for union types from

189− -- overlapping.

190− , oldrest ~ (a ': as), newrest ~ (b ': bs))

191− => AddHeader h v (Union (old ': (a ': as))) (Union (new ': (b ': bs))) where

192− addOptionalHeader hdr resp = case resp of

193− SOP.Z (SOP.I rHead) -> SOP.Z $ SOP.I $ addOptionalHeader hdr rHead

194− SOP.S rOthers -> SOP.S $ addOptionalHeader hdr rOthers

195−

196178-- | @addHeader@ adds a header to a response. Note that it changes the type of

197179-- the value in the following ways:

198180--

servant/src/Servant/API/Status.hs+1−6

@@ -1,15 +1,10 @@

11{-# LANGUAGE DataKinds #-}

22-- Flexible instances is necessary on GHC 8.4 and earlier

33{-# LANGUAGE FlexibleInstances #-}

4−{-# LANGUAGE ScopedTypeVariables #-}

54module Servant.API.Status where

65

7−import GHC.TypeLits (KnownNat, natVal)

86import Network.HTTP.Types.Status

9−

10−-- | Retrieve a known or unknown Status from a KnownNat

11−statusFromNat :: forall a proxy. KnownNat a => proxy a -> Status

12−statusFromNat = toEnum . fromInteger . natVal

7+import GHC.TypeLits

138

149-- | Witness that a type-level natural number corresponds to a HTTP status code

1510class KnownNat n => KnownStatus n where

servant/src/Servant/API/TypeErrors.hsdeleted−40

@@ -1,40 +0,0 @@

1−{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE PolyKinds #-}

3−{-# LANGUAGE TypeFamilies #-}

4−{-# LANGUAGE TypeOperators #-}

5−{-# LANGUAGE UndecidableInstances #-}

6−

7−-- | This module defines the error messages used in type-level errors.

8−-- Type-level errors can signal non-existing instances, for instance when

9−-- a combinator is not applied to the correct number of arguments.

10−

11−module Servant.API.TypeErrors (

12− PartialApplication,

13− NoInstanceFor,

14− NoInstanceForSub,

15−) where

16−

17−import Data.Kind

18−import GHC.TypeLits

19−

20−-- | No instance exists for @tycls (expr :> ...)@ because

21−-- @expr@ is not recognised.

22−type NoInstanceForSub (tycls :: k) (expr :: k') =

23− Text "There is no instance for " :<>: ShowType tycls

24− :<>: Text " (" :<>: ShowType expr :<>: Text " :> ...)"

25−

26−-- | No instance exists for @expr@.

27−type NoInstanceFor (expr :: k) =

28− Text "There is no instance for " :<>: ShowType expr

29−

30−-- | No instance exists for @tycls (expr :> ...)@ because @expr@ is not fully saturated.

31−type PartialApplication (tycls :: k) (expr :: k') =

32− NoInstanceForSub tycls expr

33− :$$: ShowType expr :<>: Text " expects " :<>: ShowType (Arity expr) :<>: Text " more arguments"

34−

35−-- The arity of a combinator, i.e. the number of required arguments.

36−type Arity (ty :: k) = Arity' k

37−

38−type family Arity' (ty :: k) :: Nat where

39− Arity' (_ -> ty) = 1 + Arity' ty

40− Arity' _ = 0

servant/src/Servant/API/TypeLevel.hs+3−3

@@ -110,7 +110,7 @@ type family IsElem' a s :: Constraint

110110--

111111-- >>> ok (Proxy :: Proxy (IsElem ("bye" :> Get '[JSON] Int) SampleAPI))

112112-- ...

113−-- ... Could not ...

113+-- ... Could not deduce...

114114-- ...

115115--

116116-- An endpoint is considered within an api even if it is missing combinators

@@ -151,7 +151,7 @@ type family IsElem endpoint api :: Constraint where

151151--

152152-- >>> ok (Proxy :: Proxy (IsSubAPI (SampleAPI :<|> Get '[JSON] Int) SampleAPI))

153153-- ...

154−-- ... Could not ...

154+-- ... Could not deduce...

155155-- ...

156156--

157157-- This uses @IsElem@ for checking; thus the note there applies here.

@@ -174,7 +174,7 @@ type family AllIsElem xs api :: Constraint where

174174--

175175-- >>> ok (Proxy :: Proxy (IsIn (Get '[JSON] Int) (Header "h" Bool :> Get '[JSON] Int)))

176176-- ...

177−-- ... Could not ...

177+-- ... Could not deduce...

178178-- ...

179179type family IsIn (endpoint :: *) (api :: *) :: Constraint where

180180 IsIn e (sa :<|> sb) = Or (IsIn e sa) (IsIn e sb)

servant/src/Servant/API/UVerb.hs−3

@@ -38,7 +38,6 @@ import GHC.TypeLits (Nat)

3838import Network.HTTP.Types (Status, StdMethod)

3939import Servant.API.ContentTypes (JSON, PlainText, FormUrlEncoded, OctetStream, NoContent, MimeRender(mimeRender), MimeUnrender(mimeUnrender))

4040import Servant.API.Status (KnownStatus, statusVal)

41−import Servant.API.ResponseHeaders (Headers)

4241import Servant.API.UVerb.Union

4342

4443class KnownStatus (StatusOf a) => HasStatus (a :: *) where

@@ -87,8 +86,6 @@ newtype WithStatus (k :: Nat) a = WithStatus a

8786instance KnownStatus n => HasStatus (WithStatus n a) where

8887 type StatusOf (WithStatus n a) = n

8988

90−instance HasStatus a => HasStatus (Headers ls a) where

91− type StatusOf (Headers ls a) = StatusOf a

9289

9390-- | A variant of 'Verb' that can have any of a number of response values and status codes.

9491--

servant/src/Servant/API/UVerb/Union.hs+2−2

@@ -128,9 +128,9 @@ type DuplicateElementError (rs :: [k]) =

128128 ':$$: 'Text " " ':<>: 'ShowType rs

129129

130130type family Elem (x :: k) (xs :: [k]) :: Bool where

131− Elem x (x ': _) = 'True

132− Elem x (_ ': xs) = Elem x xs

133131 Elem _ '[] = 'False

132+ Elem x (x' ': xs) =

133+ If (x == x') 'True (Elem x xs)

134134

135135type family Unique xs :: Constraint where

136136 Unique xs = If (Nubbed xs == 'True) (() :: Constraint) (TypeError (DuplicateElementError xs))

servant/src/Servant/API/Verbs.hs+1−2

@@ -128,8 +128,7 @@ type DeleteNoContent = NoContentVerb 'DELETE

128128type PatchNoContent = NoContentVerb 'PATCH

129129-- | 'PUT' with 204 status code.

130130type PutNoContent = NoContentVerb 'PUT

131−-- | 'HEAD' with 204 status code.

132−type HeadNoContent = NoContentVerb 'HEAD

131+

133132

134133-- ** 205 Reset Content

135134--

servant/src/Servant/API/WithResource.hsdeleted−3

@@ -1,3 +0,0 @@

1−module Servant.API.WithResource (WithResource) where

2−

3−data WithResource res

servant/src/Servant/Links.hs+12−41

@@ -7,13 +7,16 @@

77{-# LANGUAGE FunctionalDependencies #-}

88{-# LANGUAGE InstanceSigs #-}

99{-# LANGUAGE PolyKinds #-}

10−{-# LANGUAGE QuantifiedConstraints #-}

1110{-# LANGUAGE ScopedTypeVariables #-}

1211{-# LANGUAGE TypeApplications #-}

1312{-# LANGUAGE TypeFamilies #-}

1413{-# LANGUAGE TypeOperators #-}

1514{-# LANGUAGE UndecidableInstances #-}

1615

16+#if __GLASGOW_HASKELL__ >= 806

17+{-# LANGUAGE QuantifiedConstraints #-}

18+#endif

19+

1720{-# OPTIONS_HADDOCK not-home #-}

1821

1922-- | Type safe generation of internal links.

@@ -92,7 +95,7 @@

9295-- >>> let bad_link = Proxy :: Proxy ("hello" :> Delete '[JSON] NoContent)

9396-- >>> safeLink api bad_link

9497-- ...

95−-- ...Could not ...

98+-- ...Could not deduce...

9699-- ...

97100--

98101-- This error is essentially saying that the type family couldn't find

@@ -141,7 +144,7 @@ import qualified Data.Text.Encoding as TE

141144import Data.Type.Bool

142145 (If)

143146import GHC.TypeLits

144− (KnownSymbol, TypeError, symbolVal)

147+ (KnownSymbol, symbolVal)

145148import Network.URI

146149 (URI (..), escapeURIString, isUnreserved)

147150import Prelude ()

@@ -170,12 +173,10 @@ import Servant.API.IsSecure

170173 (IsSecure)

171174import Servant.API.Modifiers

172175 (FoldRequired)

173−import Servant.API.NamedRoutes

174− (NamedRoutes)

175176import Servant.API.QueryParam

176177 (QueryFlag, QueryParam', QueryParams)

177178import Servant.API.Raw

178− (Raw, RawM)

179+ (Raw)

179180import Servant.API.RemoteHost

180181 (RemoteHost)

181182import Servant.API.ReqBody

@@ -184,7 +185,6 @@ import Servant.API.Stream

184185 (Stream, StreamBody')

185186import Servant.API.Sub

186187 (type (:>))

187−import Servant.API.TypeErrors

188188import Servant.API.TypeLevel

189189import Servant.API.UVerb

190190import Servant.API.Vault

@@ -193,11 +193,7 @@ import Servant.API.Verbs

193193 (Verb, NoContentVerb)

194194import Servant.API.WithNamedContext

195195 (WithNamedContext)

196−import Servant.API.WithResource

197− (WithResource)

198196import Web.HttpApiData

199−import Data.Kind

200− (Type)

201197

202198-- | A safe link datatype.

203199-- The only way of constructing a 'Link' is using 'safeLink', which means any

@@ -560,10 +556,6 @@ instance HasLink sub => HasLink (WithNamedContext name context sub) where

560556 type MkLink (WithNamedContext name context sub) a = MkLink sub a

561557 toLink toA _ = toLink toA (Proxy :: Proxy sub)

562558

563−instance HasLink sub => HasLink (WithResource res :> sub) where

564− type MkLink (WithResource res :> sub) a = MkLink sub a

565− toLink toA _ = toLink toA (Proxy :: Proxy sub)

566−

567559instance HasLink sub => HasLink (RemoteHost :> sub) where

568560 type MkLink (RemoteHost :> sub) a = MkLink sub a

569561 toLink = simpleToLink (Proxy :: Proxy sub)

@@ -589,10 +581,6 @@ instance HasLink Raw where

589581 type MkLink Raw a = a

590582 toLink toA _ = toA

591583

592−instance HasLink RawM where

593− type MkLink RawM a = a

594− toLink toA _ = toA

595−

596584instance HasLink (Stream m status fr ct a) where

597585 type MkLink (Stream m status fr ct a) r = r

598586 toLink toA _ = toA

@@ -603,16 +591,17 @@ instance HasLink (UVerb m ct a) where

603591 toLink toA _ = toA

604592-- Instance for NamedRoutes combinator

605593

594+#if __GLASGOW_HASKELL__ >= 806

606595type GLinkConstraints routes a =

607596 ( MkLink (ToServant routes AsApi) a ~ ToServant routes (AsLink a)

608597 , GenericServant routes (AsLink a)

609598 )

610599

611600class GLink (routes :: * -> *) (a :: *) where

612− gLinkProof :: Dict (GLinkConstraints routes a)

601+ proof :: Dict (GLinkConstraints routes a)

613602

614603instance GLinkConstraints routes a => GLink routes a where

615− gLinkProof = Dict

604+ proof = Dict

616605

617606instance

618607 ( HasLink (ToServantApi routes)

@@ -627,8 +616,9 @@ instance

627616 -> Link

628617 -> routes (AsLink a)

629618

630− toLink toA _ l = case gLinkProof @routes @a of

619+ toLink toA _ l = case proof @routes @a of

631620 Dict -> fromServant $ toLink toA (Proxy @(ToServantApi routes)) l

621+#endif

632622

633623-- AuthProtext instances

634624instance HasLink sub => HasLink (AuthProtect tag :> sub) where

@@ -658,22 +648,3 @@ simpleToLink _ toA _ = toLink toA (Proxy :: Proxy sub)

658648-- $setup

659649-- >>> import Servant.API

660650-- >>> import Data.Text (Text)

661−

662−-- Erroring instance for 'HasLink' when a combinator is not fully applied

663−instance TypeError (PartialApplication

664−#if __GLASGOW_HASKELL__ >= 904

665− @(Type -> Constraint)

666−#endif

667− HasLink arr) => HasLink ((arr :: a -> b) :> sub)

668− where

669− type MkLink (arr :> sub) _ = TypeError (PartialApplication (HasLink :: * -> Constraint) arr)

670− toLink = error "unreachable"

671−

672−-- Erroring instances for 'HasLink' for unknown API combinators

673−instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub

674−#if __GLASGOW_HASKELL__ >= 904

675− @(Type -> Constraint)

676−#endif

677− HasLink ty) => HasLink (ty :> sub)

678−

679−instance {-# OVERLAPPABLE #-} TypeError (NoInstanceFor (HasLink api)) => HasLink api

servant/src/Servant/Test/ComprehensiveAPI.hs−1

@@ -72,7 +72,6 @@ type ComprehensiveAPIWithoutStreamingOrRaw' endpoint =

7272 :<|> "description" :> Description "foo" :> GET

7373 :<|> "alternative" :> ("left" :> GET :<|> "right" :> GET)

7474 :<|> "fragment" :> Fragment Int :> GET

75− :<|> "resource" :> WithResource Int :> GET

7675 :<|> endpoint

7776

7877type ComprehensiveAPIWithoutStreamingOrRaw = ComprehensiveAPIWithoutStreamingOrRaw' EmptyEndpoint

servant/src/Servant/Types/SourceT.hs+1−4

@@ -1,4 +1,3 @@

1−{-# LANGUAGE CPP #-}

21{-# LANGUAGE DeriveFunctor #-}

32{-# LANGUAGE GADTs #-}

43{-# LANGUAGE RankNTypes #-}

@@ -155,10 +154,8 @@ instance (Applicative m, Show1 m, Show a) => Show (StepT m a) where

155154-- | >>> lift [1,2,3] :: StepT [] Int

156155-- Effect [Yield 1 Stop,Yield 2 Stop,Yield 3 Stop]

157156--

158−#if !MIN_VERSION_transformers(0,6,0)

159157instance MonadTrans StepT where

160158 lift = Effect . fmap (`Yield` Stop)

161−#endif

162159

163160instance MFunctor StepT where

164161 hoist f = go where

@@ -322,7 +319,7 @@ fromActionStep stop action = loop where

322319-- | Read file.

323320--

324321-- >>> foreach fail BS.putStr (readFile "servant.cabal")

325−-- cabal-version: 2.2

322+-- cabal-version: >=1.10

326323-- name: servant

327324-- ...

328325--

servant/test/Servant/API/ContentTypesSpec.hs−11

@@ -33,8 +33,6 @@ 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)

3836import GHC.Generics

3937import Test.Hspec

4038import Test.QuickCheck

@@ -80,15 +78,6 @@ spec = describe "Servant.API.ContentTypes" $ do

8078 it "has mimeUnrender reverse mimeRender for valid top-level json " $ do

8179 property $ \x -> mimeUnrender p (mimeRender p x) == Right (x::SomeData)

8280

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−

9281 describe "The PlainText Content-Type type" $ do

9382 let p = Proxy :: Proxy PlainText

9483

servant/test/Servant/API/ResponseHeadersSpec.hs−11

@@ -2,14 +2,10 @@

22{-# LANGUAGE OverloadedStrings #-}

33module Servant.API.ResponseHeadersSpec where

44

5−import Data.Proxy

6−import GHC.TypeLits

75import Test.Hspec

86

9−import Servant.API.ContentTypes

107import Servant.API.Header

118import Servant.API.ResponseHeaders

12−import Servant.API.UVerb

139

1410spec :: Spec

1511spec = describe "Servant.API.ResponseHeaders" $ do

@@ -32,10 +28,3 @@ spec = describe "Servant.API.ResponseHeaders" $ do

3228 it "does not add a header" $ do

3329 let val = noHeader 5 :: Headers '[Header "test" Int] Int

3430 getHeaders val `shouldBe` []

35−

36− describe "HasStatus Headers" $ do

37−

38− it "gets the status from the underlying value" $ do

39− natVal (Proxy :: Proxy (StatusOf (Headers '[Header "first" Int] NoContent))) `shouldBe` 204

40− natVal (Proxy :: Proxy (StatusOf (Headers '[Header "first" Int] (WithStatus 503 ())))) `shouldBe` 503

41−

stack.yaml−1

@@ -11,7 +11,6 @@ packages:

1111- servant-conduit

1212- servant-machines/

1313- servant-pipes/

14−- servant-swagger/

1514

1615# allow-newer: true # ignores all bounds, that's a sledgehammer

1716# - doc/tutorial/