Compare commits

..

131 Commits

Author SHA1 Message Date
Intolerable
a2e003367d
Add HasStatus instance for Headers (that defers StatusOf to underlying value) (#1649)
* Add HasStatus instance for Headers (that defers StatusOf to underlying value)

* changelog.d/1649
2023-02-14 23:28:57 +01:00
ˌbodʲɪˈɡrʲim
b3214eac38
Require wai >= 3.2.2.1 (#1644) 2023-01-28 13:02:36 +01:00
Jan Hrcek
f71953e63d
Fix haddock code examples in HasClient (#1640) 2023-01-28 13:02:11 +01:00
Théophile Choutri
c382a1f34e
Allow resourcet-1.3 in servant-server and servant-conduit (#1632) 2023-01-18 09:44:11 +01:00
Daan Rijks
2daae80ea8
Add (basic) API docs for ServerT (#1573) 2023-01-09 17:05:08 +01:00
Torgeir Strand Henriksen
a22600979a
Add Functor instance to AuthHandler. (#1638) 2022-12-30 12:56:52 +01:00
Théophile Choutri
b8675c0924
Provisionally disable the Stack CI, it's too flaky. (#1639) 2022-12-29 19:25:58 +01:00
andremarianiello
751350ba9e
WithResource combinator for Servant-managed resources (#1630) 2022-12-29 19:00:47 +01:00
Guillaume Bouchard
a4194dc490
feat: Polymorphic Elem for Union (#1637)
Close https://github.com/haskell-servant/servant/issues/1590
2022-12-23 09:42:52 +01:00
nbacquey
6392dce4bf
Document CaptureHint in Capture[All]Router (#1634)
Co-authored-by: Nicolas BACQUEY <nicolas.bacquey@tweag.io>
2022-12-08 09:20:53 +01:00
Janus Troelsen
8f081bd9ad
Allow mtl-2.3, require jose-0.10 (#1627) 2022-11-17 16:58:52 +01:00
romes
ad25e98e19
Handle Cookies correctly for RunStreamingClient (#1606) 2022-11-03 09:46:49 +01:00
Maxim Koltsov
0fc6e395cb
Remove allow-newer for postgresql-simple (#1625)
Upstream has released updated versions.
2022-10-31 23:59:35 +03:00
Maxim Koltsov
58aa0d1c0c
Merge pull request #1621 from haskell-servant/maksbotan/version-up
Version up for servant, servant-server
2022-10-28 01:26:00 +03:00
Maxim Koltsov
18bc2cf314
Version up for servant, servant-server 2022-10-27 21:26:36 +02:00
Maxim Koltsov
d5b9cbf634
Merge pull request #1592 from TeofilC/ghc-9.4
Support GHC-9.4
2022-10-27 22:14:26 +03:00
Teo Camarasu
ff135e868b Add flags to cabal.project to allow building with GHC-9.4 2022-10-27 13:05:51 +01:00
Teo Camarasu
86c61c6dbd Update doctest to be compatible with newer GHC 2022-10-27 13:05:51 +01:00
Teo Camarasu
3f6886ad2d Bump depedency bounds 2022-10-27 13:05:38 +01:00
Teo Camarasu
53c132173c Bump http-api-data bounds 2022-10-27 13:05:05 +01:00
Teo Camarasu
a445fbafd6 Use CPP to avoid errors with old GHC from TypeApplications in class instance 2022-10-27 13:05:05 +01:00
Teo Camarasu
52f76ea722 Add GHC-9.4 to workflow 2022-10-27 13:05:05 +01:00
Teo Camarasu
4627683a64 Fix TypeError for GHC-9.4
In GHC-9.4 the typechecker changed requiring more annotations in positions like this. See https://gitlab.haskell.org/ghc/ghc/-/wikis/migration/9.4#ambiguous-types-containing-a-typeerror and https://gitlab.haskell.org/ghc/ghc/-/issues/21149
2022-10-18 10:45:21 +01:00
l-epple
e4650de303
Allow lens 5.2 (#1607) 2022-10-02 17:21:43 +02:00
Felix Yan
2323906080
Allow hspec 2.10 (#1609)
Builds fine and all tests pass.
2022-09-07 07:31:58 +02:00
Maxim Koltsov
f0e2316895
Merge pull request #1596 from haskell-servant/maksbotan/servant-auth-ghc9.2
servant-auth-swagger: allow base-4.16
2022-07-17 21:11:45 +03:00
Maxim Koltsov
43c57332dd
servant-auth-swagger: buildable on GHC 9 2022-07-17 20:48:52 +03:00
Maxim Koltsov
1833ef0d6e
servant-auth-swagger: allow base-4.16 2022-07-17 20:01:25 +03:00
Bart Schuurmans
489cbd59f4
servant-client: Run ClientEnv's makeClientRequest in IO (#1595)
* servant-client: Run ClientEnv's makeClientRequest in IO

* Add changelog.d entry for #1595
2022-07-01 13:25:13 +02:00
Ian Shipman
1fba9dc604
Only add a ? when query string is nonempty (#1589)
* Only add a ? when query string is nonempty

* Adds changelog entry
2022-05-16 16:50:10 +02:00
Gaël Deest
8ef5021a5f
Merge pull request #1588 from LightAndLight/master
Add HasSwagger instance for NamedRoutes
2022-05-13 07:41:12 +02:00
Tom Sydney Kerckhove
036102af58
Evaluate NoContent before (not) rendering it. (#1587)
* Evaluate NoContent before rendering it, so it shows up as covered in coverage reports

* failing test as well

* test that NoContent gets rendered if it is not an exception

Co-authored-by: Tom Sydney Kerckhove <syd@cs-syd.eu>
2022-05-04 14:40:26 +02:00
Isaac Elliott
59b5fe67cd servant-swagger: clean up imports 2022-05-03 11:43:30 +10:00
Isaac Elliott
ae8e1e6003 servant-swagger: tag NamedRoutes endpoints with datatype name 2022-05-03 11:43:27 +10:00
Isaac Elliott
cb310b8294 servant-swagger: add HasSwagger instance for NamedRoutes 2022-05-03 11:43:16 +10:00
Julian Arni
5e1569e9e2
Merge pull request #1580 from haskell-servant/jkarni/servant-auth-io-keyset
Allow IO in JWTSettings' validationKeys
2022-04-23 18:17:00 -03:00
Julian K. Arni
4e8fb045e2 Review fix 2022-04-20 21:07:08 +02:00
Julian K. Arni
4cc714d654 Changelog entry 2022-04-20 21:07:08 +02:00
Julian K. Arni
3006e90126 Allow IO in JWTSettings' validationKeys 2022-04-20 21:07:08 +02:00
Gaël Deest
c48a6702b7
Merge pull request #1582 from haskell-servant/named-routes-servant-docs
Add support for NamedRoutes in servant-docs
2022-04-19 13:13:50 +02:00
Gaël Deest
9c81b4927a Add support for NamedRoutes in servant-docs 2022-04-19 12:51:31 +02:00
Gaël Deest
117a2cc5e1
Merge pull request #1583 from haskell-servant/hspec-no-color
Disable hspec colored output in servant-swagger doctests
2022-04-19 12:41:15 +02:00
Gaël Deest
78280dc267 Disable hspec colored output in servant-swagger doctests
Colored output is the default since hspec 2.9.5.

This causes CI failures due to terminal escaping characters when running
the doctests on GitHub Actions.
2022-04-19 11:16:03 +02:00
Alp
c19ed0fb92
Major bound for servant-server's dependency on servant (#1574)
Reflecting a revision made on hackage for servant-server 0.19.1
2022-03-30 02:10:54 +02:00
Shea Levy
658585a7cd
Derive MonadMask for ClientM (#1572) 2022-03-26 17:03:01 +01:00
Gaël Deest
65de6f701c
Merge pull request #1556 from nbacquey/router_layout_captures
Display capture hints in router layout
2022-03-25 10:42:33 +01:00
Nicolas BACQUEY
a19cb84a0e Update changelog 2022-03-24 16:43:27 +01:00
Nicolas BACQUEY
9d66e16706 Add spec for serverLayout 2022-03-23 14:30:45 +01:00
Nicolas BACQUEY
77b92d0d7d Display capture hints in router layout
This commit introduces a `CaptureHint` type, which is passed as an extra
argument to the `CaptureRouter` and `CaptureAllRouter` constructors for
the `Router'` type.
`CaptureHint` values are then used in `routerLayout`, to display the
name and "type" of captured values (single or list), instead of just
"<capture>" previously.

N.B.:
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.
2022-03-23 14:30:45 +01:00
Maxim Koltsov
f5a91d20e1
Merge pull request #1568 from haskell-servant/maksbotan/stackage-deps
Allow hspec-2.9, lens-aeson-1.2
2022-03-22 23:43:22 +01:00
Maxim Koltsov
dd29f25f77
Allow lens-aeson 1.2 2022-03-22 23:22:02 +01:00
Maxim Koltsov
04f59c012b
Require servant-0.18.2 in servant-swagger
This version of servant adds Fragment, which servant-swagger adds
instance for.
2022-03-22 23:10:05 +01:00
Maxim Koltsov
256cec566f
Support hspec >= 2.9 in servant-swagger tests 2022-03-22 22:54:58 +01:00
Gaël Deest
276ca2ed01
Merge pull request #1569 from haskell-servant/url-encoding
Use toEncodedUrlPiece directly when encoding captures
2022-03-22 14:19:07 +01:00
Gaël Deest
c1c631eaff Add changelog entry 2022-03-22 11:56:18 +01:00
Gaël Deest
0e051ccfdf
Merge pull request #1557 from ysangkok/janus/newer-stack
Use Stack 2.7.5, cleanup allow-newer/CI
2022-03-22 11:36:17 +01:00
Gaël Deest
658217b021 Use toEncodedUrlPiece directly when encoding captures
Current implementation of captures uses the `toUrlPiece` method from the
`ToHttpApiData` typeclass, and encodes the resulting `Text` using `toEncodedUrlPiece`
when appending to the request path.

The problem with this approach is that the instance for `Text` percent-encodes
characters that are perfectly valid in URLs, such as `*`.

This patch makes direct use of `toEncodedUrlPiece`, which lets users implement
encoding according to their needs.

Closes #1511
2022-03-21 17:29:23 +01:00
Gaël Deest
af3dde1b1d
Merge pull request #1566 from haskell-servant/fix-operator-doc
Fix haddock documentation for (//) and (/:)
2022-03-21 16:14:47 +01:00
Maxim Koltsov
ced5f1a655
Allow hspec-2.9 2022-03-21 15:44:10 +01:00
Maxim Koltsov
626e1c3a7c
Relax more deps for Stackage (#1567) 2022-03-21 17:18:08 +03:00
Gaël Deest
0c80bc8f8e Fix haddock documentation for (//) and (/:)
The examples for these two operators weren't displayed properly due to invalid Haddock markup.
2022-03-21 14:18:49 +01:00
Maxim Koltsov
d52c5d08a0
servant-server 0.19.1 2022-03-21 14:13:52 +01:00
Maxim Koltsov
89b66a3634
Merge pull request #1555 from ysangkok/janus/ghc-92
Allow GHC 9.2 for all packages
2022-03-21 13:58:48 +01:00
Gaël Deest
3370b75622
Merge pull request #1565 from haskell-servant/re-export
Re-export Servant.API.Generic in Servant.API
2022-03-21 13:57:40 +01:00
Gaël Deest
9a99ef9a0b Re-export Servant.API.Generic in Servant.API 2022-03-21 13:31:33 +01:00
Maxim Koltsov
408352320e
Remove obsolete allow-newer 2022-03-21 11:45:49 +01:00
Janus Troelsen
010e6a72af Disable curl-mock for 9.2 because of generic-arbitrary 2022-03-13 20:35:40 -06:00
Janus Troelsen
39898676a8 Enable all packages on GHC 9.2 2022-03-13 19:58:24 -06:00
Janus Troelsen
bbd82a736f Use Stack 2.7.5, cleanup 2022-03-09 12:58:50 -06:00
Janus Troelsen
17e3eb1041 Allow GHC 9.2 for compatible packages 2022-03-08 08:59:35 -06:00
Gaël Deest
de923fc887
Merge pull request #1554 from ysangkok/repl-doctest
Use cabal-install to invoke doctest
2022-03-08 09:16:19 +01:00
Janus Troelsen
222ccf107c Use cabal-install to invoke doctest 2022-03-08 01:01:37 -06:00
Giorgio Marinelli
d05da71f09
Export encoding function for a query parameter value (#1549) 2022-03-01 15:22:25 +01:00
Marco Perone
cedab6572d
fix broken links (#1548) 2022-03-01 09:34:45 +01:00
Gaël Deest
15b364ae93
Merge pull request #1541 from mjdominus/master
Update documentation
2022-02-28 09:50:17 +01:00
Gaël Deest
8fccfccae0
Merge pull request #1546 from hasufell/PR/hasufell/issue-1545/monad-fail
Add `MonadFail` instance for `Handler` wrt #1545
2022-02-28 09:47:33 +01:00
Julian Ospald
181e51db8a
Add MonadFail instance for Handler wrt #1545 2022-02-26 22:31:56 +01:00
Mark Jason Dominus (陶敏修)
0e4d02ae75 Update copyright notice from 2018 to 2022 2022-02-25 14:44:13 -05:00
Mark Jason Dominus (陶敏修)
b4c4131778 Update error message in Makefile
The file this message refers to was renamed in
commit 53b3b939e4.
2022-02-25 14:44:13 -05:00
Mark Jason Dominus (陶敏修)
6d5c3023ce Discuss ghcup in tutorial installation instructions
The instructions as written will not work on Ubuntu systems,
which provide an extremely out-of-date Haskell toolchain.

Addresses issue https://github.com/haskell-servant/servant/issues/1540

https://github.com/haskell-servant/servant/issues/1540
2022-02-25 14:44:12 -05:00
Caroline GAUDREAU
7ef9730f77
Merge pull request #1538 from akhesaCaro/reverting
Reverting NamedRoutes cookbook
2022-02-18 12:37:05 +01:00
akhesaCaro
6da8488f9b Revert "removing Generic cookbook in favour of NamedRoutes"
This reverts commit 34aed1d289.
2022-02-18 12:14:28 +01:00
akhesaCaro
f4cd56446b Revert "introducing NamedRoutes cookbook"
This reverts commit 5c80214351.
2022-02-18 12:13:09 +01:00
Caroline GAUDREAU
50355d0125
Merge pull request #1534 from akhesaCaro/cookbook_namedRoutes
Cookbook named routes
2022-02-18 11:41:19 +01:00
akhesaCaro
34aed1d289 removing Generic cookbook in favour of NamedRoutes 2022-02-18 11:08:43 +01:00
akhesaCaro
5c80214351 introducing NamedRoutes cookbook 2022-02-18 11:08:36 +01:00
Gaël Deest
009dc06e76
Merge pull request #1535 from ysangkok/remove-unnecessary-constraints-and-allow-newer
Remove unnecessary constraint/allow-newer
2022-02-16 22:51:59 +01:00
Janus Troelsen
e2a9165229 Remove unnecessary constraint/allow-newer 2022-02-15 09:54:17 -06:00
Gaël Deest
d35b3e9b70
Merge pull request #1529 from purefunsolutions/fix-servant-client-ghcjs-for-servant-0.19
Fix servant-client-ghcjs for servant 0.19
2022-02-14 16:39:00 +01:00
Gaël Deest
002fa2107a
Merge pull request #1531 from gdeest/servant-auth-named-routes
servant-auth-server: Support NamedRoutes
2022-02-14 14:57:19 +01:00
Gaël Deest
bd9151b9de servant-auth-server: Support NamedRoutes
Trying to use `NamedRoutes` with `servant-auth-server` currently results
in hideous error messages such as:

```
app/Main.hs:50:7: error:
    • No instance for (Servant.Auth.Server.Internal.AddSetCookie.AddSetCookies
                         ('Servant.Auth.Server.Internal.AddSetCookie.S
                            ('Servant.Auth.Server.Internal.AddSetCookie.S
                               'Servant.Auth.Server.Internal.AddSetCookie.Z))
                         (AdminRoutes (Servant.Server.Internal.AsServerT Handler))
                         (ServerT
                            (Servant.Auth.Server.Internal.AddSetCookie.AddSetCookieApi
                               (Servant.Auth.Server.Internal.AddSetCookie.AddSetCookieApi
                                  (NamedRoutes AdminRoutes)))
                            Handler))
        arising from a use of 'serveWithContext'
    • In the expression: serveWithContext (Proxy @API) ctx RootAPI {..}
```

This is because we didn't teach it how to recurse along `NamedRoutes`
trees and sprinkle headers at the tip of each branch.

This commit adds a test case and fixes the issue. In the process, it
also implements `ThrowAll` for `NamedRoutes`, which was necessary for
the test to run, and should also prove convenient for users.
2022-02-14 14:28:46 +01:00
Mika Tammi
17b55634b3
servant-client-ghcjs: Fix performRequest function
Fix performRequest function to be compatible with the latest
servant-client-core RunClient typeclass
2022-02-11 20:55:34 +02:00
Mika Tammi
3158809631
servant-client-ghcjs: Bump base max-bound 2022-02-11 20:22:57 +02:00
Gaël Deest
cdd7c34add
Merge pull request #1526 from ysangkok/master
Allow newer hashable, lens, text
2022-02-07 10:00:58 +01:00
Gaël Deest
67322d8ab8
Merge pull request #1525 from k0001/fix-9.2.1
servant-server: Fix build on GHC 9.2.1
2022-02-07 09:57:23 +01:00
Janus Troelsen
67da8514a0 Allow newer hashable, lens, text 2022-02-06 16:12:25 -06:00
Renzo Carbonara
61d0d14b5c servant-server: Fix build on GHC 9.2.1
The issue is similar to the one in #1513:

```
src/Servant/Server/Internal.hs:824:10: error:
    • Uninferrable type variable k0 in
      type family equation right-hand side: (TypeError ...)
    • In the type instance declaration for ‘ServerT’
      In the instance declaration for
        ‘HasServer ((arr :: a -> b) :> sub) context’
    |
824 |     type ServerT (arr :> sub) _ = TypeError (PartialApplication HasServer arr)
    |
```

This fix is similar to the one in #1514.
2022-02-04 14:34:12 +02:00
Sven Tennie
a8f1a7603f
Update docs: #haskell-servant is now on libera.chat (#1503) 2022-02-03 12:40:00 +01:00
Gaël Deest
78034cd2b3
Merge pull request #1522 from peterbecich/github-actions-updates
minor updates to GitHub Actions
2022-02-03 10:20:23 +01:00
Clément Delafargue
6f12e38698
Fix NamedRoutes example in 0.19 changelog (#1523) 2022-02-03 09:56:19 +01:00
Peter Becich
9a3fd77a3a
minor updates to GitHub Actions 2022-02-02 23:50:10 -08:00
Gaël Deest
e14f445e2a
Merge pull request #1521 from gdeest/minor-releases
servant-auth 0.4.0.0 -> 0.4.1.0, servant-auth-server 0.4.6.0 -> 0.4.7.0
2022-02-02 16:14:21 +01:00
Gaël Deest
4caa1f563b servant-auth 0.4.0.0 -> 0.4.1.0, servant-auth-server 0.4.6.0 -> 0.4.7.0 2022-02-02 15:54:31 +01:00
Gaël Deest
e1b59dbb31
Merge pull request #1519 from haskell-servant/prepare-0.19
Changelog tweaks + servant-http-streams / servant-docs bump
2022-02-01 12:42:34 +01:00
Gaël Deest
b17d018d3f Changelog tweaks + servant-http-streams / servant-docs bump 2022-02-01 12:29:31 +01:00
Gaël Deest
e98ae8adba
Merge pull request #1517 from haskell-servant/prepare-0.19
Prepare 0.19 release
2022-02-01 10:28:15 +01:00
Gaël Deest
e4945740aa Prepare 0.19 release 2022-02-01 10:17:03 +01:00
Gaël Deest
7a770b5a1e
Merge pull request #1514 from guibou/fix_ghc92_build
Fix GHC 9.2 build
2022-01-25 11:42:10 +01:00
Guillaume Bouchard
22d5790e73 Fix GHC 9.2 build
Close #1513.

GHC 9.2 needs explicit kind signature here, I don't really understand
why.

This kind signature is correct and not too restritive, because `HasLink`
is technically defined `class HasLink endpoint` which means that it is
infered as `k -> Constraint`. In the instance signature, we have
`HasLink ((arr :: a -> b) :> sub)`, so here the `k` is the same kind as
the one of `:>` which is not polykinded.
2022-01-24 17:14:44 +01:00
Gaël Deest
75db4a5327
Merge pull request #1486 from haskell-servant/type-errors
Custom errors for HasClient, HasServer
2022-01-18 17:16:37 +01:00
Gaël Deest
75cb9ac246 Add comment about slightly incorrect error message 2022-01-18 16:25:11 +01:00
Gaël Deest
aab7e0d5dd Custom errors for HasClient, HasServer 2022-01-18 16:25:05 +01:00
Gaël Deest
3493d135f0
Merge pull request #1508 from haskell-servant/fix-servant-swagger-build
Fix servant-swagger Cabal
2022-01-18 11:15:10 +01:00
Gaël Deest
e8c301afc9 Add servant-swagger to stack.yaml 2022-01-18 11:07:38 +01:00
Gaël Deest
b56d681fde Relax doctest lower bound 2022-01-18 11:07:38 +01:00
Gaël Deest
b33442423e Re-adding Cabal-the-library as a dep
Fixes #1507.
2022-01-18 11:07:17 +01:00
Sven Tennie
c388c5e82c
Add HeadNoContent to Servant.API.Verbs (#1502)
As the head method isn't allowed to contain any response body, no
general Head Verb is added. (This may easily lead to wrong usages...)

(https://httpwg.org/specs/rfc7231.html#HEAD)
2022-01-06 13:02:57 +01:00
Matthieu Coudron
73c87bc2bc
bumped cabal-version field (#1498)
* bumped cabal-version field

Cabal supports two types of licenses, native and SPDX, which can be seen here hackage.haskell.org/package/Cabal-3.6.2.0/docs/Distribution-Types-PackageDescription.html#v:licenseRaw

Several packages use BSD-3-Clause as a license, in conjonction with cabal-version: >=1.10 which cabal parses as Right (UnknownLicense "BSD-3").
If I change teh cabal-version to cabal-version: 2.2 , cabal correctly identifdies the license License (ELicense (ELicenseId BSD_3_Clause)).

* changed license from cabal to spdx format

aka BSD3 -> BSD-3-Clause: next cabal may deprecate the old format
2022-01-04 22:06:23 +01:00
Giorgio Marinelli
29d2553e74
Derive HasClient good response status from Verb status (#1469) 2021-12-09 10:09:18 +01:00
antoine-fl
cb294aa2b3
Fix Request's Show instance (#1492) 2021-12-01 19:16:59 +01:00
Théophile Choutri
a975cfc361
Add details about AddHeaders instances (#1490)
* Add details about the instances of AddHeader

Also:

* Cleanup of extensions and imports
2021-11-30 23:52:06 +01:00
Caroline GAUDREAU
9a3979926d
Merge pull request #1475 from akhesaCaro/aeson_2
support Aeson 2
2021-11-26 17:25:56 +01:00
akhesacaro
05ef0dd1d3 Allow using aeson 1 (lax with min-bounds) 2021-11-26 17:14:31 +01:00
akhesacaro
62033db535 servant-auth-swagger: bump servant-swagger and swagger2 2021-11-18 11:56:38 +01:00
akhesacaro
d9d8fa7525 servant-swagger: remove obsolete files 2021-11-18 11:56:38 +01:00
akhesacaro
42ceb3916d changing servant-swagger info 2021-11-18 11:56:38 +01:00
akhesacaro
bcb484774e servant-swagger: bump aeson and cabal (aeson > 2) 2021-11-18 11:56:38 +01:00
akhesacaro
39fb875951 moving servant-swagger into the main servant repo 2021-11-18 11:56:38 +01:00
akhesacaro
efffc70919 fixing servant-auth (aeson 2.0 bump) 2021-11-18 11:56:38 +01:00
akhesacaro
8af80d35a0 bump jose min and max-bound (aeson 2.0 bump) 2021-11-18 11:56:38 +01:00
akhesacaro
e01188aaad min bound aeson 2 2021-11-18 11:56:32 +01:00
141 changed files with 3919 additions and 500 deletions

View File

@ -13,12 +13,14 @@ jobs:
strategy: strategy:
matrix: matrix:
os: [ubuntu-latest] os: [ubuntu-latest]
cabal: ["3.4"] cabal: ["3.6"]
ghc: ghc:
- "8.6.5" - "8.6.5"
- "8.8.4" - "8.8.4"
- "8.10.7" - "8.10.7"
- "9.0.1" - "9.0.2"
- "9.2.2"
- "9.4.2"
steps: steps:
- uses: actions/checkout@v2 - uses: actions/checkout@v2
@ -47,10 +49,7 @@ jobs:
- name: Configure - name: Configure
run: | run: |
# Using separate store-dir because default one already has 'ghc-paths' package installed cabal install --ignore-project -j2 doctest --constraint='doctest ^>=0.20'
# with hardcoded path to ghcup's GHC path (which it was built with). This leads to failure in
# doctest, as it tries to invoke that GHC, and it doesn't exist here.
cabal --store-dir /tmp/cabal-store install --ignore-project -j2 doctest --constraint='doctest ^>=0.18'
- name: Build - name: Build
run: | run: |
@ -61,66 +60,56 @@ jobs:
cabal test all cabal test all
- name: Run doctests - name: Run doctests
# doctests are broken on GHC 9 due to compiler bug:
# https://gitlab.haskell.org/ghc/ghc/-/issues/19460
continue-on-error: ${{ matrix.ghc == '9.0.1' }}
run: | run: |
# Necessary for doctest to be found in $PATH # Necessary for doctest to be found in $PATH
export PATH="$HOME/.cabal/bin:$PATH" export PATH="$HOME/.cabal/bin:$PATH"
# Filter out base-compat-batteries from .ghc.environment.*, as its modules DOCTEST="cabal repl --with-ghc=doctest --ghc-options=-w"
# conflict with those of base-compat. (cd servant && eval $DOCTEST)
# (cd servant-client && eval $DOCTEST)
# FIXME: This is an ugly hack. Ultimately, we'll want to use cabal-doctest (cd servant-client-core && eval $DOCTEST)
# (or cabal v2-doctest, if it ever lands) to provide a clean GHC environment. (cd servant-http-streams && eval $DOCTEST)
# This might allow running doctests in GHCJS build as well. (cd servant-docs && eval $DOCTEST)
perl -i -e 'while (<ARGV>) { print unless /package-id\s+(base-compat-batteries)-\d+(\.\d+)*/; }' .ghc.environment.* (cd servant-foreign && eval $DOCTEST)
(cd servant-server && eval $DOCTEST)
(cd servant-machines && eval $DOCTEST)
(cd servant-conduit && eval $DOCTEST)
(cd servant-pipes && eval $DOCTEST)
(cd servant && doctest src) # stack:
(cd servant-client && doctest src) # name: stack / ghc ${{ matrix.ghc }}
(cd servant-client-core && doctest src) # runs-on: ubuntu-latest
(cd servant-http-streams && doctest src) # strategy:
(cd servant-docs && doctest src) # matrix:
(cd servant-foreign && doctest src) # stack: ["2.7.5"]
(cd servant-server && doctest src) # ghc: ["8.10.7"]
(cd servant-machines && doctest src)
(cd servant-conduit && doctest src)
(cd servant-pipes && doctest src)
stack: # steps:
name: stack / ghc ${{ matrix.ghc }} # - uses: actions/checkout@v2
runs-on: ubuntu-latest
strategy:
matrix:
stack: ["2.7.3"]
ghc: ["8.10.4"]
steps: # - uses: haskell/actions/setup@v1
- uses: actions/checkout@v2 # name: Setup Haskell Stack
# with:
# ghc-version: ${{ matrix.ghc }}
# stack-version: ${{ matrix.stack }}
- uses: haskell/actions/setup@v1 # - uses: actions/cache@v2.1.3
name: Setup Haskell Stack # name: Cache ~/.stack
with: # with:
ghc-version: ${{ matrix.ghc }} # path: ~/.stack
stack-version: ${{ matrix.stack }} # key: ${{ runner.os }}-${{ matrix.ghc }}-stack
- uses: actions/cache@v2.1.3 # - name: Install dependencies
name: Cache ~/.stack # run: |
with: # stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks --only-dependencies
path: ~/.stack
key: ${{ runner.os }}-${{ matrix.ghc }}-stack
- name: Install dependencies # - name: Build
run: | # run: |
stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks --only-dependencies # stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks
- name: Build # - name: Test
run: | # run: |
stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks # stack test --system-ghc
- name: Test
run: |
stack test --system-ghc
ghcjs: ghcjs:
name: ubuntu-latest / ghcjs 8.6 name: ubuntu-latest / ghcjs 8.6

1
.gitignore vendored
View File

@ -31,6 +31,7 @@ doc/venv
doc/tutorial/static/api.js doc/tutorial/static/api.js
doc/tutorial/static/jq.js doc/tutorial/static/jq.js
shell.nix shell.nix
.hspec-failures
# nix # nix
result* result*

View File

@ -79,8 +79,10 @@ not been a timely response to a PR, you can ping the Maintainers group (with
We encourage people to experiment with new combinators and instances - it is We encourage people to experiment with new combinators and instances - it is
one of the most powerful ways of using `servant`, and a wonderful way of one of the most powerful ways of using `servant`, and a wonderful way of
getting to know it better. If you do write a new combinator, we would love to getting to know it better. If you do write a new combinator, we would love to
know about it! Either hop on #servant on freenode and let us know, or open an know about it! Either hop on
issue with the `news` tag (which we will close when we read it). [#haskell-servant on libera.chat](https://web.libera.chat/#haskell-servant) and
let us know, or open an issue with the `news` tag (which we will close when we
read it).
As for adding them to the main repo: maintaining combinators can be expensive, As for adding them to the main repo: maintaining combinators can be expensive,
since official combinators must have instances for all classes (and new classes since official combinators must have instances for all classes (and new classes

View File

@ -12,6 +12,7 @@ packages:
servant-docs/ servant-docs/
servant-foreign/ servant-foreign/
servant-server/ servant-server/
servant-swagger/
doc/tutorial/ doc/tutorial/
-- servant streaming -- servant streaming
@ -46,30 +47,8 @@ packages:
doc/cookbook/using-custom-monad doc/cookbook/using-custom-monad
doc/cookbook/using-free-client doc/cookbook/using-free-client
-- doc/cookbook/open-id-connect -- doc/cookbook/open-id-connect
doc/cookbook/managed-resource
tests: True tests: True
optimization: False optimization: False
-- reorder-goals: True -- reorder-goals: True
constraints:
-- see https://github.com/haskell-infra/hackage-trustees/issues/119
foundation >=0.0.14,
memory <0.14.12 || >0.14.12
constraints: base-compat ^>=0.11
constraints: semigroups ^>=0.19
-- allow-newer: sqlite-simple-0.4.16.0:semigroups
-- allow-newer: direct-sqlite-2.3.24:semigroups
-- needed for doctests
write-ghc-environment-files: always
-- https://github.com/chordify/haskell-servant-pagination/pull/12
allow-newer: servant-pagination-2.2.2:servant
allow-newer: servant-pagination-2.2.2:servant-server
allow-newer: servant-js:servant
-- ghc 9
allow-newer: tdigest:base

11
changelog.d/1469 Normal file
View File

@ -0,0 +1,11 @@
synopsis: Derive HasClient good response status from Verb status
prs: #1469
description: {
`HasClient` instances for the `Verb` datatype use `runRequest` in
`clientWithRoute` definitions.
This means that a request performed with `runClientM` will be successful if and
only if the endpoint specify a response status code >=200 and <300.
This change replaces `runRequest` with `runRequestAcceptStatus` in `Verb`
instances for the `HasClient` class, deriving the good response status from
the `Verb` status.
}

10
changelog.d/1529 Normal file
View File

@ -0,0 +1,10 @@
synopsis: Fix performRequest in servant-client-ghcjs
prs: #1529
description: {
performRequest function in servant-client-ghcjs was not compatible with the
latest RunClient typeclass. Added the acceptStatus parameter and fixed the
functionality to match what servant-client provides.
}

81
changelog.d/1556 Normal file
View File

@ -0,0 +1,81 @@
synopsis: Display capture hints in router layout
prs: #1556
description: {
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.
Example:
For the following API
```haskell
type API =
"a" :> "d" :> Get '[JSON] NoContent
:<|> "b" :> Capture "x" Int :> Get '[JSON] Bool
:<|> "a" :> "e" :> Get '[JSON] Int
```
we previously got the following output:
```
/
├─ a/
│ ├─ d/
│ │ └─•
│ └─ e/
│ └─•
└─ b/
└─ <capture>/
├─•
└─•
```
now we get:
```
/
├─ a/
│ ├─ d/
│ │ └─•
│ └─ e/
│ └─•
└─ b/
└─ <x::Int>/
├─•
└─•
```
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.
CaptureHint values are then used in routerLayout, to display the name and type of captured values, instead of just `<capture>` previously.
N.B.:
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.
This PR also introduces Spec tests for the routerLayout function.
Warning:
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`.
In those cases, the fix is easy: it suffices to add `Typeable a` to the left-hand side of the quantification constraint.
For instance, the following code will no longer compile:
```haskell
type MyAPI a = Capture "foo" a :> Get '[JSON] ()
myServer :: forall a. Server (MyAPI a)
myServer = const $ return ()
myApi :: forall a. Proxy (MyAPI a)
myApi = Proxy
app :: forall a. (FromHttpApiData a) => Application
app = serve (myApi @a) (myServer @a)
```
Indeed, `app` should be replaced with:
```haskell
app :: forall a. (FromHttpApiData a, Typeable a) => Application
app = serve (myApi @a) (myServer @a)
```
}

13
changelog.d/1569 Normal file
View File

@ -0,0 +1,13 @@
synopsis: Encode captures using toEncodedUrlPiece
prs: #1569
issues: #1511
description: {
The `servant-client` library now makes direct use of `toEncodedUrlPiece` from `ToHttpApiData`
to encode captured values when building the request path. It gives user freedom to implement
URL-encoding however they need.
Previous behavior was to use `toUrlPiece` and URL-encode its output using `toEncodedUrlPiece`
from the `Text` instance of `ToHttpApiData`. The issue with this approach is that
`ToHttpApiData Text` is overly zealous and also encodes characters, such as `*`, which are perfectly valid in a URL.
}

2
changelog.d/1573 Normal file
View File

@ -0,0 +1,2 @@
synopsis: Add API docs for ServerT
prs: #1573

12
changelog.d/1580 Normal file
View File

@ -0,0 +1,12 @@
synopsis: Allow IO in validationKeys
prs: #1580
issues: #1579
description: {
Currently validationKeys are a fixed JWKSet. This does not work with OIDC
providers such as AWS Cognito or Okta, which regularly fetching jwks_uri to
discover new and expired keys.
This change alters the type of validationKeys from JWKSet to IO JWKSet.
}

2
changelog.d/1589 Normal file
View File

@ -0,0 +1,2 @@
synopsis: Only include question mark for nonempty query strings
prs: 1589

2
changelog.d/1595 Normal file
View File

@ -0,0 +1,2 @@
synopsis: Run ClientEnv's makeClientRequest in IO.
prs: #1595

10
changelog.d/1606 Normal file
View File

@ -0,0 +1,10 @@
synopsis: Handle Cookies correctly for RunStreamingClient
prs: #1606
issues: #1605
description: {
Makes performWithStreamingRequest take into consideration the
CookieJar, which it previously didn't.
}

2
changelog.d/1638 Normal file
View File

@ -0,0 +1,2 @@
synopsis: Add Functor instance to AuthHandler.
prs: #1638

8
changelog.d/1649 Normal file
View File

@ -0,0 +1,8 @@
synopsis: Add HasStatus instance for Headers (that defers StatusOf to underlying value)
prs: #1649
description: {
Adds a new HasStatus (Headers hs a) instance (StatusOf (Headers hs a) = StatusOf a)
}

View File

@ -10,7 +10,7 @@ BUILDDIR = _build
# Put it first so that "make" without argument is like "make help". # Put it first so that "make" without argument is like "make help".
help: help:
@if [ ! -d venv ]; then echo "WARNING: There is no venv directory, did you forget to 'virtualenv venv'. Check building-the-docs file."; fi @if [ ! -d venv ]; then echo "WARNING: There is no venv directory, did you forget to 'virtualenv venv'. Check README.md."; fi
@if [ ! "z$$(which $(SPHINXBUILD))" = "z$$(pwd)/venv/bin/sphinx-build" ]; then echo "WARNING: Did you forgot to 'source venv/bin/activate'"; fi @if [ ! "z$$(which $(SPHINXBUILD))" = "z$$(pwd)/venv/bin/sphinx-build" ]; then echo "WARNING: Did you forgot to 'source venv/bin/activate'"; fi
@$(SPHINXBUILD) -M help "$(SOURCEDIR)" "$(BUILDDIR)" $(SPHINXOPTS) $(O) @$(SPHINXBUILD) -M help "$(SOURCEDIR)" "$(BUILDDIR)" $(SPHINXOPTS) $(O)

View File

@ -46,7 +46,7 @@ master_doc = 'index'
# General information about the project. # General information about the project.
project = u'Servant' project = u'Servant'
copyright = u'2018, Servant Contributors' copyright = u'2022, Servant Contributors'
author = u'Servant Contributors' author = u'Servant Contributors'
# The version info for the project you're documenting, acts as replacement for # The version info for the project you're documenting, acts as replacement for
@ -169,4 +169,3 @@ texinfo_documents = [
source_parsers = { source_parsers = {
'.lhs': CommonMarkParser, '.lhs': CommonMarkParser,
} }

View File

@ -1,3 +1,4 @@
cabal-version: 2.2
name: cookbook-basic-auth name: cookbook-basic-auth
version: 0.1 version: 0.1
synopsis: Basic Authentication cookbook example synopsis: Basic Authentication cookbook example
@ -7,7 +8,6 @@ license-file: ../../../servant/LICENSE
author: Servant Contributors author: Servant Contributors
maintainer: haskell-servant-maintainers@googlegroups.com maintainer: haskell-servant-maintainers@googlegroups.com
build-type: Simple build-type: Simple
cabal-version: >=1.10
tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7 tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
executable cookbook-basic-auth executable cookbook-basic-auth

View File

@ -1,3 +1,4 @@
cabal-version: 2.2
name: cookbook-basic-streaming name: cookbook-basic-streaming
version: 2.1 version: 2.1
synopsis: Streaming in servant without streaming libs synopsis: Streaming in servant without streaming libs
@ -7,7 +8,6 @@ license-file: ../../../servant/LICENSE
author: Servant Contributors author: Servant Contributors
maintainer: haskell-servant-maintainers@googlegroups.com maintainer: haskell-servant-maintainers@googlegroups.com
build-type: Simple build-type: Simple
cabal-version: >=1.10
tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7 tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
executable cookbook-basic-streaming executable cookbook-basic-streaming

View File

@ -1,3 +1,4 @@
cabal-version: 2.2
name: cookbook-curl-mock name: cookbook-curl-mock
version: 0.1 version: 0.1
synopsis: Generate curl mock requests cookbook example synopsis: Generate curl mock requests cookbook example
@ -7,10 +8,12 @@ license-file: ../../../servant/LICENSE
author: Servant Contributors author: Servant Contributors
maintainer: haskell-servant-maintainers@googlegroups.com maintainer: haskell-servant-maintainers@googlegroups.com
build-type: Simple build-type: Simple
cabal-version: >=1.10
tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7 tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
executable cookbock-curl-mock executable cookbock-curl-mock
if impl(ghc >= 9.2)
-- generic-arbitrary is incompatible
buildable: False
main-is: CurlMock.lhs main-is: CurlMock.lhs
build-depends: base == 4.* build-depends: base == 4.*
, aeson , aeson

View File

@ -1,3 +1,4 @@
cabal-version: 2.2
name: cookbook-custom-errors name: cookbook-custom-errors
version: 0.1 version: 0.1
synopsis: Return custom error messages from combinators synopsis: Return custom error messages from combinators
@ -7,7 +8,6 @@ license-file: ../../../servant/LICENSE
author: Servant Contributors author: Servant Contributors
maintainer: haskell-servant-maintainers@googlegroups.com maintainer: haskell-servant-maintainers@googlegroups.com
build-type: Simple build-type: Simple
cabal-version: >=1.10
tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7 tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
executable cookbook-custom-errors executable cookbook-custom-errors

View File

@ -1,3 +1,4 @@
cabal-version: 2.2
name: mysql-basics name: mysql-basics
version: 0.1.0.0 version: 0.1.0.0
synopsis: Simple MySQL API cookbook example synopsis: Simple MySQL API cookbook example
@ -7,7 +8,6 @@ license-file: ../../../servant/LICENSE
author: Servant Contributors author: Servant Contributors
maintainer: haskell-servant-maintainers@googlegroups.com maintainer: haskell-servant-maintainers@googlegroups.com
build-type: Simple build-type: Simple
cabal-version: >=1.10
executable run executable run
hs-source-dirs: . hs-source-dirs: .

View File

@ -1,3 +1,4 @@
cabal-version: 2.2
name: cookbook-db-postgres-pool name: cookbook-db-postgres-pool
version: 0.1 version: 0.1
synopsis: Simple PostgreSQL connection pool cookbook example synopsis: Simple PostgreSQL connection pool cookbook example
@ -7,7 +8,6 @@ license-file: ../../../servant/LICENSE
author: Servant Contributors author: Servant Contributors
maintainer: haskell-servant-maintainers@googlegroups.com maintainer: haskell-servant-maintainers@googlegroups.com
build-type: Simple build-type: Simple
cabal-version: >=1.10
tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7 tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
executable cookbook-db-postgres-pool executable cookbook-db-postgres-pool

View File

@ -1,3 +1,4 @@
cabal-version: 2.2
name: cookbook-db-sqlite-simple name: cookbook-db-sqlite-simple
version: 0.1 version: 0.1
synopsis: Simple SQLite DB cookbook example synopsis: Simple SQLite DB cookbook example
@ -7,7 +8,6 @@ license-file: ../../../servant/LICENSE
author: Servant Contributors author: Servant Contributors
maintainer: haskell-servant-maintainers@googlegroups.com maintainer: haskell-servant-maintainers@googlegroups.com
build-type: Simple build-type: Simple
cabal-version: >=1.10
tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7 tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
executable cookbook-db-sqlite-simple executable cookbook-db-sqlite-simple

View File

@ -1,3 +1,4 @@
cabal-version: 2.2
name: cookbook-file-upload name: cookbook-file-upload
version: 0.1 version: 0.1
synopsis: File upload cookbook example synopsis: File upload cookbook example
@ -7,7 +8,6 @@ license-file: ../../../servant/LICENSE
author: Servant Contributors author: Servant Contributors
maintainer: haskell-servant-maintainers@googlegroups.com maintainer: haskell-servant-maintainers@googlegroups.com
build-type: Simple build-type: Simple
cabal-version: >=1.10
tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7 tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
executable cookbook-file-upload executable cookbook-file-upload

View File

@ -1,3 +1,4 @@
cabal-version: 2.2
name: cookbook-generic name: cookbook-generic
version: 0.1 version: 0.1
synopsis: Using custom monad to pass a state between handlers synopsis: Using custom monad to pass a state between handlers
@ -7,7 +8,6 @@ license-file: ../../../servant/LICENSE
author: Servant Contributors author: Servant Contributors
maintainer: haskell-servant-maintainers@googlegroups.com maintainer: haskell-servant-maintainers@googlegroups.com
build-type: Simple build-type: Simple
cabal-version: >=1.10
tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7 tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
executable cookbook-using-custom-monad executable cookbook-using-custom-monad

View File

@ -1,3 +1,4 @@
cabal-version: 2.2
name: cookbook-hoist-server-with-context name: cookbook-hoist-server-with-context
version: 0.0.1 version: 0.0.1
synopsis: JWT and basic access authentication with a Custom Monad cookbook example synopsis: JWT and basic access authentication with a Custom Monad cookbook example
@ -10,7 +11,6 @@ author: Servant Contributors
maintainer: haskell-servant-maintainers@googlegroups.com maintainer: haskell-servant-maintainers@googlegroups.com
category: Servant category: Servant
build-type: Simple build-type: Simple
cabal-version: >=1.10
tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7 tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
executable cookbook-hoist-server-with-context executable cookbook-hoist-server-with-context

View File

@ -1,3 +1,4 @@
cabal-version: 2.2
name: cookbook-https name: cookbook-https
version: 0.1 version: 0.1
synopsis: HTTPS cookbook example synopsis: HTTPS cookbook example
@ -7,7 +8,6 @@ license-file: ../../../servant/LICENSE
author: Servant Contributors author: Servant Contributors
maintainer: haskell-servant-maintainers@googlegroups.com maintainer: haskell-servant-maintainers@googlegroups.com
build-type: Simple build-type: Simple
cabal-version: >=1.10
tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7 tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
executable cookbook-https executable cookbook-https

View File

@ -6,8 +6,8 @@ how to solve many common problems with servant. If you're
interested in contributing examples of your own, feel free interested in contributing examples of your own, feel free
to open an issue or a pull request on to open an issue or a pull request on
`our github repository <https://github.com/haskell-servant/servant>`_ `our github repository <https://github.com/haskell-servant/servant>`_
or even to just get in touch with us on the **#servant** IRC channel or even to just get in touch with us on the `**#haskell-servant** IRC channel
on freenode or on on libera.chat <https://web.libera.chat/#haskell-servant>_ or on
`the mailing list <https://groups.google.com/forum/#!forum/haskell-servant>`_. `the mailing list <https://groups.google.com/forum/#!forum/haskell-servant>`_.
The scope is very wide. Simple and fancy authentication schemes, The scope is very wide. Simple and fancy authentication schemes,
@ -37,3 +37,4 @@ you name it!
sentry/Sentry.lhs sentry/Sentry.lhs
testing/Testing.lhs testing/Testing.lhs
open-id-connect/OpenIdConnect.lhs open-id-connect/OpenIdConnect.lhs
managed-resource/ManagedResource.lhs

View File

@ -1,3 +1,4 @@
cabal-version: 2.2
name: cookbook-jwt-and-basic-auth name: cookbook-jwt-and-basic-auth
version: 0.0.1 version: 0.0.1
synopsis: JWT and basic access authentication cookbook example synopsis: JWT and basic access authentication cookbook example
@ -10,7 +11,6 @@ author: Servant Contributors
maintainer: haskell-servant-maintainers@googlegroups.com maintainer: haskell-servant-maintainers@googlegroups.com
category: Servant category: Servant
build-type: Simple build-type: Simple
cabal-version: >=1.10
tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7 tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
executable cookbook-jwt-and-basic-auth executable cookbook-jwt-and-basic-auth

View File

@ -0,0 +1,114 @@
# Request-lifetime Managed Resources
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.
As usual, we start with a little bit of throat clearing.
``` haskell
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
import Control.Concurrent
import Control.Exception (bracket, throwIO)
import Control.Monad.IO.Class
import Control.Monad.Trans.Resource
import Data.Acquire
import Network.HTTP.Client (newManager, defaultManagerSettings)
import Network.Wai.Handler.Warp
import Servant
import Servant.Client
import System.IO
```
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.
``` haskell
type API = WithResource Handle :> ReqBody '[PlainText] String :> Post '[JSON] NoContent
api :: Proxy API
api = Proxy
```
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.
``` haskell
appContext :: Context '[Acquire Handle]
appContext = acquireHandle :. EmptyContext
acquireHandle :: Acquire Handle
acquireHandle = mkAcquire newHandle closeHandle
newHandle :: IO Handle
newHandle = do
putStrLn "opening file"
h <- openFile "test.txt" AppendMode
putStrLn "opened file"
return h
closeHandle :: Handle -> IO ()
closeHandle h = do
putStrLn "closing file"
hClose h
putStrLn "closed file"
```
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.
``` haskell
server :: Server API
server = writeToFile
where writeToFile :: (ReleaseKey, Handle) -> String -> Handler NoContent
writeToFile (_, h) msg = case msg of
"illegal" -> error "wait, that's illegal!"
legalMsg -> liftIO $ do
putStrLn "writing file"
hPutStrLn h legalMsg
putStrLn "wrote file"
return NoContent
```
Finally we run the server in the background while we post messages to it.
``` haskell
runApp :: IO ()
runApp = run 8080 (serveWithContext api appContext $ server)
postMsg :: String -> ClientM NoContent
postMsg = client api
main :: IO ()
main = do
mgr <- newManager defaultManagerSettings
bracket (forkIO $ runApp) killThread $ \_ -> do
ms <- flip runClientM (mkClientEnv mgr (BaseUrl Http "localhost" 8080 "")) $ do
liftIO $ putStrLn "sending hello message"
_ <- postMsg "hello"
liftIO $ putStrLn "sending illegal message"
_ <- postMsg "illegal"
liftIO $ putStrLn "done"
print ms
```
This program prints
```
sending hello message
opening file
opened file
writing file
wrote file
closing file
closed file
sending illegal message
opening file
opened file
closing file
closed file
wait, that's illegal!
CallStack (from HasCallStack):
error, called at ManagedResource.lhs:63:24 in main:Main
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"}))
```
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.

View File

@ -0,0 +1,30 @@
cabal-version: 2.2
name: cookbook-managed-resource
version: 0.1
synopsis: Simple managed resource cookbook example
homepage: http://docs.servant.dev/
license: BSD-3-Clause
license-file: ../../../servant/LICENSE
author: Servant Contributors
maintainer: haskell-servant-maintainers@googlegroups.com
build-type: Simple
tested-with: GHC==9.4.2
executable cookbook-managed-resource
main-is: ManagedResource.lhs
build-depends: base == 4.*
, text >= 1.2
, aeson >= 1.2
, servant
, servant-client
, servant-server
, warp >= 3.2
, wai >= 3.2
, http-types >= 0.12
, markdown-unlit >= 0.4
, http-client >= 0.5
, transformers
, resourcet
default-language: Haskell2010
ghc-options: -Wall -pgmL markdown-unlit
build-tool-depends: markdown-unlit:markdown-unlit

View File

@ -1,3 +1,4 @@
cabal-version: 2.2
name: open-id-connect name: open-id-connect
version: 0.1 version: 0.1
synopsis: OpenId Connect with Servant example synopsis: OpenId Connect with Servant example
@ -7,7 +8,6 @@ license-file: ../../../servant/LICENSE
author: Servant Contributors author: Servant Contributors
maintainer: haskell-servant-maintainers@googlegroups.com maintainer: haskell-servant-maintainers@googlegroups.com
build-type: Simple build-type: Simple
cabal-version: >= 1.10
tested-with: GHC==8.6.5 tested-with: GHC==8.6.5
executable cookbook-openidconnect executable cookbook-openidconnect

View File

@ -330,7 +330,7 @@ data Customer = Customer {
``` ```
Here is the code that displays the homepage. Here is the code that displays the homepage.
It should contain a link to the the `/login` URL. It should contain a link to the `/login` URL.
When the user clicks on this link it will be redirected to Google login page When the user clicks on this link it will be redirected to Google login page
with some generated information. with some generated information.

View File

@ -1,3 +1,4 @@
cabal-version: 2.2
name: cookbook-pagination name: cookbook-pagination
version: 2.1 version: 2.1
synopsis: Pagination with Servant example synopsis: Pagination with Servant example
@ -7,7 +8,6 @@ license-file: ../../../servant/LICENSE
author: Servant Contributors author: Servant Contributors
maintainer: haskell-servant-maintainers@googlegroups.com maintainer: haskell-servant-maintainers@googlegroups.com
build-type: Simple build-type: Simple
cabal-version: >=1.10
tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7 tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
executable cookbook-pagination executable cookbook-pagination

View File

@ -1,3 +1,4 @@
cabal-version: 2.2
name: cookbook-sentry name: cookbook-sentry
version: 0.1 version: 0.1
synopsis: Collecting runtime exceptions using Sentry synopsis: Collecting runtime exceptions using Sentry
@ -7,7 +8,6 @@ license-file: ../../../servant/LICENSE
author: Servant Contributors author: Servant Contributors
maintainer: haskell-servant-maintainers@googlegroups.com maintainer: haskell-servant-maintainers@googlegroups.com
build-type: Simple build-type: Simple
cabal-version: >=1.10
tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7 tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
executable cookbook-sentry executable cookbook-sentry

View File

@ -1,3 +1,4 @@
cabal-version: 2.2
name: cookbook-structuring-apis name: cookbook-structuring-apis
version: 0.1 version: 0.1
synopsis: Example that shows how APIs can be structured synopsis: Example that shows how APIs can be structured
@ -7,7 +8,6 @@ license-file: ../../../servant/LICENSE
author: Servant Contributors author: Servant Contributors
maintainer: haskell-servant-maintainers@googlegroups.com maintainer: haskell-servant-maintainers@googlegroups.com
build-type: Simple build-type: Simple
cabal-version: >=1.10
tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7 tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
executable cookbook-structuring-apis executable cookbook-structuring-apis

View File

@ -1,3 +1,4 @@
cabal-version: 2.2
name: cookbook-testing name: cookbook-testing
version: 0.0.1 version: 0.0.1
synopsis: Common testing patterns in Servant apps synopsis: Common testing patterns in Servant apps
@ -9,7 +10,6 @@ author: Servant Contributors
maintainer: haskell-servant-maintainers@googlegroups.com maintainer: haskell-servant-maintainers@googlegroups.com
category: Servant category: Servant
build-type: Simple build-type: Simple
cabal-version: >=1.10
tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7 tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
executable cookbook-testing executable cookbook-testing

View File

@ -1,3 +1,4 @@
cabal-version: 2.2
name: cookbook-using-custom-monad name: cookbook-using-custom-monad
version: 0.1 version: 0.1
synopsis: Using custom monad to pass a state between handlers synopsis: Using custom monad to pass a state between handlers
@ -7,7 +8,6 @@ license-file: ../../../servant/LICENSE
author: Servant Contributors author: Servant Contributors
maintainer: haskell-servant-maintainers@googlegroups.com maintainer: haskell-servant-maintainers@googlegroups.com
build-type: Simple build-type: Simple
cabal-version: >=1.10
tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7 tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
executable cookbook-using-custom-monad executable cookbook-using-custom-monad

View File

@ -119,7 +119,7 @@ Now we can use `servant-client`'s internals to convert servant's `Request`
to http-client's `Request`, and we can inspect it: to http-client's `Request`, and we can inspect it:
```haskell ```haskell
let req' = I.defaultMakeClientRequest burl req req' <- I.defaultMakeClientRequest burl req
putStrLn $ "Making request: " ++ show req' putStrLn $ "Making request: " ++ show req'
``` ```

View File

@ -1,3 +1,4 @@
cabal-version: 2.2
name: cookbook-using-free-client name: cookbook-using-free-client
version: 0.1 version: 0.1
synopsis: Using Free client synopsis: Using Free client
@ -7,7 +8,6 @@ license-file: ../../../servant/LICENSE
author: Servant Contributors author: Servant Contributors
maintainer: haskell-servant-maintainers@googlegroups.com maintainer: haskell-servant-maintainers@googlegroups.com
build-type: Simple build-type: Simple
cabal-version: >=1.10
tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7 tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7
executable cookbook-using-free-client executable cookbook-using-free-client

View File

@ -199,7 +199,7 @@ parsers in the hope that the ones that should will always error out so
you can try until the right one returns a value.) you can try until the right one returns a value.)
[servant-exceptions](https://github.com/ch1bo/servant-exceptions) is [servant-exceptions](https://github.com/ch1bo/servant-exceptions) is
another shot at at the problem. It is inspired by another shot at the problem. It is inspired by
servant-checked-exceptions, so it may be worth taking a closer look. servant-checked-exceptions, so it may be worth taking a closer look.
The README claims that The README claims that
[cardano-sl](https://github.com/input-output-hk/cardano-sl) also has [cardano-sl](https://github.com/input-output-hk/cardano-sl) also has

View File

@ -1,3 +1,4 @@
cabal-version: 2.2
name: cookbook-uverb name: cookbook-uverb
version: 0.0.1 version: 0.0.1
synopsis: How to use the 'UVerb' type. synopsis: How to use the 'UVerb' type.
@ -9,7 +10,6 @@ author: Servant Contributors
maintainer: haskell-servant-maintainers@googlegroups.com maintainer: haskell-servant-maintainers@googlegroups.com
category: Servant category: Servant
build-type: Simple build-type: Simple
cabal-version: >=1.10
tested-with: GHC==8.6.5, GHC==8.8.4, GHC==8.10.7 tested-with: GHC==8.6.5, GHC==8.8.4, GHC==8.10.7
executable cookbook-uverb executable cookbook-uverb

View File

@ -12,7 +12,7 @@ Helpful Links
`https://github.com/haskell-servant/servant/issues <https://github.com/haskell-servant/servant/issues>`_ `https://github.com/haskell-servant/servant/issues <https://github.com/haskell-servant/servant/issues>`_
- the irc channel: - the irc channel:
``#servant`` on freenode `#haskell-servant on libera.chat <https://web.libera.chat/#haskell-servant>`_
- the mailing list: - the mailing list:
`groups.google.com/forum/#!forum/haskell-servant <https://groups.google.com/forum/#!forum/haskell-servant>`_ `groups.google.com/forum/#!forum/haskell-servant <https://groups.google.com/forum/#!forum/haskell-servant>`_

View File

@ -1,3 +1,4 @@
recommonmark==0.5.0 recommonmark==0.5.0
Sphinx==1.8.4 Sphinx==1.8.4
sphinx_rtd_theme>=0.4.2 sphinx_rtd_theme>=0.4.2
jinja2<3.1.0

View File

@ -40,3 +40,29 @@ nix
`Nix <https://nixos.org/nix/>`_ users should feel free to take a look at `Nix <https://nixos.org/nix/>`_ users should feel free to take a look at
the `nix/shell.nix` file in the repository and use it to provision a suitable the `nix/shell.nix` file in the repository and use it to provision a suitable
environment to build and run the examples. environment to build and run the examples.
Note for Ubuntu users
--------
Ubuntu's packages for `ghc`, `cabal`, and `stack` are years out of date.
If the instructions above fail for you,
try replacing the Ubuntu packages with up-to-date versions.
First remove the installed versions:
.. code-block:: bash
# remove the obsolete versions
$ sudo apt remove ghc haskell-stack cabal-install
Then install fresh versions of the Haskell toolchain
using the `ghcup <https://www.haskell.org/ghcup/install/>`_ installer.
As of February 2022, one easy way to do this is by running a bootstrap script:
.. code-block:: bash
$ curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh
The script is interactive and will prompt you for details about what
you want installed and where. To install manually,
see `the detailed instructions <https://www.haskell.org/ghcup/install/#manual-install>`_.

View File

@ -1,3 +1,4 @@
cabal-version: 2.2
name: tutorial name: tutorial
version: 0.10 version: 0.10
synopsis: The servant tutorial synopsis: The servant tutorial
@ -11,7 +12,6 @@ license-file: LICENSE
author: Servant Contributors author: Servant Contributors
maintainer: haskell-servant-maintainers@googlegroups.com maintainer: haskell-servant-maintainers@googlegroups.com
build-type: Simple build-type: Simple
cabal-version: >=1.10
tested-with: tested-with:
GHC==8.6.5 GHC==8.6.5
GHC==8.8.3, GHC ==8.10.7 GHC==8.8.3, GHC ==8.10.7
@ -64,7 +64,7 @@ library
, blaze-markup >= 0.8.0.0 && < 0.9 , blaze-markup >= 0.8.0.0 && < 0.9
, cookie >= 0.4.3 && < 0.5 , cookie >= 0.4.3 && < 0.5
, js-jquery >= 3.3.1 && < 3.4 , js-jquery >= 3.3.1 && < 3.4
, lucid >= 2.9.11 && < 2.10 , lucid >= 2.9.11 && < 2.12
, random >= 1.1 && < 1.3 , random >= 1.1 && < 1.3
, servant-js >= 0.9 && < 0.10 , servant-js >= 0.9 && < 0.10
, time >= 1.6.0.1 && < 1.13 , time >= 1.6.0.1 && < 1.13

View File

@ -1,3 +1,4 @@
cabal-version: 2.2
name: servant-auth-client name: servant-auth-client
version: 0.4.1.0 version: 0.4.1.0
synopsis: servant-client/servant-auth compatibility synopsis: servant-client/servant-auth compatibility
@ -6,9 +7,9 @@ description: This package provides instances that allow generating clients fr
APIs that use APIs that use
<https://hackage.haskell.org/package/servant-auth servant-auth's> @Auth@ combinator. <https://hackage.haskell.org/package/servant-auth servant-auth's> @Auth@ combinator.
. .
For a quick overview of the usage, see the <http://github.com/haskell-servant/servant/servant-auth#readme README>. For a quick overview of the usage, see the <https://github.com/haskell-servant/servant/tree/master/servant-auth#readme README>.
category: Web, Servant, Authentication category: Web, Servant, Authentication
homepage: http://github.com/haskell-servant/servant/servant-auth#readme homepage: https://github.com/haskell-servant/servant/tree/master/servant-auth#readme
bug-reports: https://github.com/haskell-servant/servant/issues bug-reports: https://github.com/haskell-servant/servant/issues
author: Julian K. Arni author: Julian K. Arni
maintainer: jkarni@gmail.com maintainer: jkarni@gmail.com
@ -17,7 +18,6 @@ license: BSD-3-Clause
license-file: LICENSE license-file: LICENSE
tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1 tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1
build-type: Simple build-type: Simple
cabal-version: >= 1.10
extra-source-files: extra-source-files:
CHANGELOG.md CHANGELOG.md
@ -31,12 +31,12 @@ library
default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
ghc-options: -Wall ghc-options: -Wall
build-depends: build-depends:
base >= 4.10 && < 4.16 base >= 4.10 && < 4.18
, bytestring >= 0.10.6.0 && < 0.11 , bytestring >= 0.10.6.0 && < 0.12
, containers >= 0.5.6.2 && < 0.7 , containers >= 0.5.6.2 && < 0.7
, servant-auth == 0.4.* , servant-auth == 0.4.*
, servant >= 0.13 && < 0.19 , servant >= 0.13 && < 0.20
, servant-client-core >= 0.13 && < 0.19 , servant-client-core >= 0.13 && < 0.20
exposed-modules: exposed-modules:
Servant.Auth.Client Servant.Auth.Client
@ -50,7 +50,7 @@ test-suite spec
test test
default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
ghc-options: -Wall ghc-options: -Wall
build-tool-depends: hspec-discover:hspec-discover >=2.5.5 && <2.9 build-tool-depends: hspec-discover:hspec-discover >=2.5.5 && <2.10
-- dependencies with bounds inherited from the library stanza -- dependencies with bounds inherited from the library stanza
build-depends: build-depends:
@ -62,19 +62,19 @@ test-suite spec
-- test dependencies -- test dependencies
build-depends: build-depends:
hspec >= 2.5.5 && < 2.9 hspec >= 2.5.5 && < 2.10
, QuickCheck >= 2.11.3 && < 2.15 , QuickCheck >= 2.11.3 && < 2.15
, aeson >= 1.3.1.1 && < 1.6 , aeson >= 1.3.1.1 && < 3
, bytestring >= 0.10.6.0 && < 0.11 , bytestring >= 0.10.6.0 && < 0.12
, http-client >= 0.5.13.1 && < 0.8 , http-client >= 0.5.13.1 && < 0.8
, http-types >= 0.12.2 && < 0.13 , http-types >= 0.12.2 && < 0.13
, servant-auth-server >= 0.4.2.0 && < 0.5 , servant-auth-server >= 0.4.2.0 && < 0.5
, servant-server >= 0.13 && < 0.19 , servant-server >= 0.13 && < 0.20
, time >= 1.5.0.1 && < 1.13 , time >= 1.5.0.1 && < 1.13
, transformers >= 0.4.2.0 && < 0.6 , transformers >= 0.4.2.0 && < 0.6
, wai >= 3.2.1.2 && < 3.3 , wai >= 3.2.1.2 && < 3.3
, warp >= 3.2.25 && < 3.4 , warp >= 3.2.25 && < 3.4
, jose >= 0.7.0.0 && < 0.9 , jose >= 0.10 && < 0.11
other-modules: other-modules:
Servant.Auth.ClientSpec Servant.Auth.ClientSpec
default-language: Haskell2010 default-language: Haskell2010

View File

@ -1,3 +1,4 @@
cabal-version: 2.2
name: servant-auth-docs name: servant-auth-docs
version: 0.2.10.0 version: 0.2.10.0
synopsis: servant-docs/servant-auth compatibility synopsis: servant-docs/servant-auth compatibility
@ -6,9 +7,9 @@ description: This package provides instances that allow generating docs from
APIs that use APIs that use
<https://hackage.haskell.org/package/servant-auth servant-auth's> @Auth@ combinator. <https://hackage.haskell.org/package/servant-auth servant-auth's> @Auth@ combinator.
. .
For a quick overview of the usage, see the <http://github.com/haskell-servant/servant/servant-auth#readme README>. For a quick overview of the usage, see the <https://github.com/haskell-servant/servant/tree/master/servant-auth#readme README>.
category: Web, Servant, Authentication category: Web, Servant, Authentication
homepage: http://github.com/haskell-servant/servant/servant-auth#readme homepage: https://github.com/haskell-servant/servant/tree/master/servant-auth#readme
bug-reports: https://github.com/haskell-servant/servant/issues bug-reports: https://github.com/haskell-servant/servant/issues
author: Julian K. Arni author: Julian K. Arni
maintainer: jkarni@gmail.com maintainer: jkarni@gmail.com
@ -17,7 +18,6 @@ license: BSD-3-Clause
license-file: LICENSE license-file: LICENSE
tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1 tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1
build-type: Custom build-type: Custom
cabal-version: >= 1.10
extra-source-files: extra-source-files:
CHANGELOG.md CHANGELOG.md
@ -35,11 +35,11 @@ library
default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
ghc-options: -Wall ghc-options: -Wall
build-depends: build-depends:
base >= 4.10 && < 4.16 base >= 4.10 && < 4.18
, servant-docs >= 0.11.2 && < 0.12 , servant-docs >= 0.11.2 && < 0.13
, servant >= 0.13 && < 0.19 , servant >= 0.13 && < 0.20
, servant-auth == 0.4.* , servant-auth == 0.4.*
, lens >= 4.16.1 && <5.1 , lens >= 4.16.1 && <5.3
exposed-modules: exposed-modules:
Servant.Auth.Docs Servant.Auth.Docs
default-language: Haskell2010 default-language: Haskell2010
@ -50,7 +50,7 @@ test-suite doctests
build-depends: build-depends:
base, base,
servant-auth-docs, servant-auth-docs,
doctest >= 0.16 && < 0.19, doctest >= 0.16 && < 0.21,
QuickCheck >= 2.11.3 && < 2.15, QuickCheck >= 2.11.3 && < 2.15,
template-haskell template-haskell
ghc-options: -Wall -threaded ghc-options: -Wall -threaded
@ -64,7 +64,7 @@ test-suite spec
test test
default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
ghc-options: -Wall ghc-options: -Wall
build-tool-depends: hspec-discover:hspec-discover >=2.5.5 && <2.9 build-tool-depends: hspec-discover:hspec-discover >=2.5.5 && <2.10
-- dependencies with bounds inherited from the library stanza -- dependencies with bounds inherited from the library stanza
build-depends: build-depends:
@ -78,7 +78,7 @@ test-suite spec
-- test dependencies -- test dependencies
build-depends: build-depends:
servant-auth-docs servant-auth-docs
, hspec >= 2.5.5 && < 2.9 , hspec >= 2.5.5 && < 2.10
, QuickCheck >= 2.11.3 && < 2.15 , QuickCheck >= 2.11.3 && < 2.15
default-language: Haskell2010 default-language: Haskell2010

View File

@ -1,14 +1,15 @@
cabal-version: 2.2
name: servant-auth-server name: servant-auth-server
version: 0.4.6.0 version: 0.4.7.0
synopsis: servant-server/servant-auth compatibility synopsis: servant-server/servant-auth compatibility
description: This package provides the required instances for using the @Auth@ combinator description: This package provides the required instances for using the @Auth@ combinator
in your 'servant' server. in your 'servant' server.
. .
Both cookie- and token- (REST API) based authentication is provided. Both cookie- and token- (REST API) based authentication is provided.
. .
For a quick overview of the usage, see the <http://github.com/haskell-servant/servant/servant-auth#readme README>. For a quick overview of the usage, see the <https://github.com/haskell-servant/servant/tree/master/servant-auth#readme README>.
category: Web, Servant, Authentication category: Web, Servant, Authentication
homepage: http://github.com/haskell-servant/servant/servant-auth#readme homepage: https://github.com/haskell-servant/servant/tree/master/servant-auth#readme
bug-reports: https://github.com/haskell-servant/servant/issues bug-reports: https://github.com/haskell-servant/servant/issues
author: Julian K. Arni author: Julian K. Arni
maintainer: jkarni@gmail.com maintainer: jkarni@gmail.com
@ -17,7 +18,6 @@ license: BSD-3-Clause
license-file: LICENSE license-file: LICENSE
tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1 tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1
build-type: Simple build-type: Simple
cabal-version: >= 1.10
extra-source-files: extra-source-files:
CHANGELOG.md CHANGELOG.md
@ -31,27 +31,27 @@ library
default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
ghc-options: -Wall ghc-options: -Wall
build-depends: build-depends:
base >= 4.10 && < 4.16 base >= 4.10 && < 4.18
, aeson >= 1.3.1.1 && < 1.6 , aeson >= 1.0.0.1 && < 3
, base64-bytestring >= 1.0.0.1 && < 1.3 , base64-bytestring >= 1.0.0.1 && < 2
, blaze-builder >= 0.4.1.0 && < 0.5 , blaze-builder >= 0.4.1.0 && < 0.5
, bytestring >= 0.10.6.0 && < 0.11 , bytestring >= 0.10.6.0 && < 0.12
, case-insensitive >= 1.2.0.11 && < 1.3 , case-insensitive >= 1.2.0.11 && < 1.3
, cookie >= 0.4.4 && < 0.5 , cookie >= 0.4.4 && < 0.5
, data-default-class >= 0.1.2.0 && < 0.2 , data-default-class >= 0.1.2.0 && < 0.2
, entropy >= 0.4.1.3 && < 0.5 , entropy >= 0.4.1.3 && < 0.5
, http-types >= 0.12.2 && < 0.13 , http-types >= 0.12.2 && < 0.13
, jose >= 0.7.0.0 && < 0.9 , jose >= 0.10 && < 0.11
, lens >= 4.16.1 && < 5.1 , lens >= 4.16.1 && < 5.3
, memory >= 0.14.16 && < 0.17 , memory >= 0.14.16 && < 0.19
, monad-time >= 0.3.1.0 && < 0.4 , monad-time >= 0.3.1.0 && < 0.4
, mtl >= 2.2.2 && < 2.3 , mtl ^>= 2.2.2 || ^>= 2.3.1
, servant >= 0.13 && < 0.19 , servant >= 0.13 && < 0.20
, servant-auth == 0.4.* , servant-auth == 0.4.*
, servant-server >= 0.13 && < 0.19 , servant-server >= 0.13 && < 0.20
, tagged >= 0.8.4 && < 0.9 , tagged >= 0.8.4 && < 0.9
, text >= 1.2.3.0 && < 1.3 , text >= 1.2.3.0 && < 2.1
, time >= 1.5.0.1 && < 1.10 , time >= 1.5.0.1 && < 1.13
, unordered-containers >= 0.2.9.0 && < 0.3 , unordered-containers >= 0.2.9.0 && < 0.3
, wai >= 3.2.1.2 && < 3.3 , wai >= 3.2.1.2 && < 3.3
@ -102,7 +102,7 @@ test-suite spec
test test
default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
ghc-options: -Wall ghc-options: -Wall
build-tool-depends: hspec-discover:hspec-discover >=2.5.5 && <2.8 build-tool-depends: hspec-discover:hspec-discover >=2.5.5 && <2.10
-- dependencies with bounds inherited from the library stanza -- dependencies with bounds inherited from the library stanza
build-depends: build-depends:
@ -123,10 +123,10 @@ test-suite spec
-- test dependencies -- test dependencies
build-depends: build-depends:
servant-auth-server servant-auth-server
, hspec >= 2.5.5 && < 2.8 , hspec >= 2.5.5 && < 2.10
, QuickCheck >= 2.11.3 && < 2.15 , QuickCheck >= 2.11.3 && < 2.15
, http-client >= 0.5.13.1 && < 0.8 , http-client >= 0.5.13.1 && < 0.8
, lens-aeson >= 1.0.2 && < 1.2 , lens-aeson >= 1.0.2 && < 1.3
, warp >= 3.2.25 && < 3.4 , warp >= 3.2.25 && < 3.4
, wreq >= 0.5.2.1 && < 0.6 , wreq >= 0.5.2.1 && < 0.6
other-modules: other-modules:

View File

@ -11,6 +11,8 @@ import Data.Tagged (Tagged (..))
import qualified Network.HTTP.Types as HTTP import qualified Network.HTTP.Types as HTTP
import Network.Wai (mapResponseHeaders) import Network.Wai (mapResponseHeaders)
import Servant import Servant
import Servant.API.Generic
import Servant.Server.Generic
import Web.Cookie import Web.Cookie
-- What are we doing here? Well, the idea is to add headers to the response, -- What are we doing here? Well, the idea is to add headers to the response,
@ -34,6 +36,7 @@ type family AddSetCookieApiVerb a where
type family AddSetCookieApi a :: * type family AddSetCookieApi a :: *
type instance AddSetCookieApi (a :> b) = a :> AddSetCookieApi b type instance AddSetCookieApi (a :> b) = a :> AddSetCookieApi b
type instance AddSetCookieApi (a :<|> b) = AddSetCookieApi a :<|> AddSetCookieApi b type instance AddSetCookieApi (a :<|> b) = AddSetCookieApi a :<|> AddSetCookieApi b
type instance AddSetCookieApi (NamedRoutes api) = AddSetCookieApi (ToServantApi api)
type instance AddSetCookieApi (Verb method stat ctyps a) type instance AddSetCookieApi (Verb method stat ctyps a)
= Verb method stat ctyps (AddSetCookieApiVerb a) = Verb method stat ctyps (AddSetCookieApiVerb a)
type instance AddSetCookieApi Raw = Raw type instance AddSetCookieApi Raw = Raw
@ -72,6 +75,15 @@ instance {-# OVERLAPS #-}
=> AddSetCookies ('S n) (a :<|> b) (a' :<|> b') where => AddSetCookies ('S n) (a :<|> b) (a' :<|> b') where
addSetCookies cookies (a :<|> b) = addSetCookies cookies a :<|> addSetCookies cookies b addSetCookies cookies (a :<|> b) = addSetCookies cookies a :<|> addSetCookies cookies b
instance {-# OVERLAPS #-}
( AddSetCookies ('S n) (ServerT (ToServantApi api) m) cookiedApi
, Generic (api (AsServerT m))
, GServantProduct (Rep (api (AsServerT m)))
, ToServant api (AsServerT m) ~ ServerT (ToServantApi api) m
)
=> AddSetCookies ('S n) (api (AsServerT m)) cookiedApi where
addSetCookies cookies = addSetCookies cookies . toServant
-- | for @servant <0.11@ -- | for @servant <0.11@
instance instance
AddSetCookies ('S n) Application Application where AddSetCookies ('S n) Application Application where

View File

@ -33,7 +33,7 @@ data JWTSettings = JWTSettings
-- | Algorithm used to sign JWT. -- | Algorithm used to sign JWT.
, jwtAlg :: Maybe Jose.Alg , jwtAlg :: Maybe Jose.Alg
-- | Keys used to validate JWT. -- | Keys used to validate JWT.
, validationKeys :: Jose.JWKSet , validationKeys :: IO Jose.JWKSet
-- | An @aud@ predicate. The @aud@ is a string or URI that identifies the -- | An @aud@ predicate. The @aud@ is a string or URI that identifies the
-- intended recipient of the JWT. -- intended recipient of the JWT.
, audienceMatches :: Jose.StringOrURI -> IsMatch , audienceMatches :: Jose.StringOrURI -> IsMatch
@ -44,7 +44,7 @@ defaultJWTSettings :: Jose.JWK -> JWTSettings
defaultJWTSettings k = JWTSettings defaultJWTSettings k = JWTSettings
{ signingKey = k { signingKey = k
, jwtAlg = Nothing , jwtAlg = Nothing
, validationKeys = Jose.JWKSet [k] , validationKeys = pure $ Jose.JWKSet [k]
, audienceMatches = const Matches } , audienceMatches = const Matches }
-- | The policies to use when generating cookies. -- | The policies to use when generating cookies.

View File

@ -2,6 +2,7 @@
module Servant.Auth.Server.Internal.Cookie where module Servant.Auth.Server.Internal.Cookie where
import Blaze.ByteString.Builder (toByteString) import Blaze.ByteString.Builder (toByteString)
import Control.Monad (MonadPlus(..), guard)
import Control.Monad.Except import Control.Monad.Except
import Control.Monad.Reader import Control.Monad.Reader
import qualified Crypto.JOSE as Jose import qualified Crypto.JOSE as Jose

View File

@ -1,18 +1,14 @@
module Servant.Auth.Server.Internal.JWT where module Servant.Auth.Server.Internal.JWT where
import Control.Lens import Control.Lens
import Control.Monad.Except import Control.Monad (MonadPlus(..), guard)
import Control.Monad.Reader import Control.Monad.Reader
import qualified Crypto.JOSE as Jose import qualified Crypto.JOSE as Jose
import qualified Crypto.JWT as Jose import qualified Crypto.JWT as Jose
import Data.Aeson (FromJSON, Result (..), ToJSON, fromJSON,
toJSON)
import Data.ByteArray (constEq) import Data.ByteArray (constEq)
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Lazy as BSL
import qualified Data.HashMap.Strict as HM
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import qualified Data.Text as T
import Data.Time (UTCTime) import Data.Time (UTCTime)
import Network.Wai (requestHeaders) import Network.Wai (requestHeaders)
@ -42,7 +38,7 @@ jwtAuthCheck jwtSettings = do
-- token expires. -- token expires.
makeJWT :: ToJWT a makeJWT :: ToJWT a
=> a -> JWTSettings -> Maybe UTCTime -> IO (Either Jose.Error BSL.ByteString) => a -> JWTSettings -> Maybe UTCTime -> IO (Either Jose.Error BSL.ByteString)
makeJWT v cfg expiry = runExceptT $ do makeJWT v cfg expiry = Jose.runJOSE $ do
bestAlg <- Jose.bestJWSAlg $ signingKey cfg bestAlg <- Jose.bestJWSAlg $ signingKey cfg
let alg = fromMaybe bestAlg $ jwtAlg cfg let alg = fromMaybe bestAlg $ jwtAlg cfg
ejwt <- Jose.signClaims (signingKey cfg) ejwt <- Jose.signClaims (signingKey cfg)
@ -58,14 +54,15 @@ makeJWT v cfg expiry = runExceptT $ do
verifyJWT :: FromJWT a => JWTSettings -> BS.ByteString -> IO (Maybe a) verifyJWT :: FromJWT a => JWTSettings -> BS.ByteString -> IO (Maybe a)
verifyJWT jwtCfg input = do verifyJWT jwtCfg input = do
verifiedJWT <- liftIO $ runExceptT $ do keys <- validationKeys jwtCfg
verifiedJWT <- Jose.runJOSE $ do
unverifiedJWT <- Jose.decodeCompact (BSL.fromStrict input) unverifiedJWT <- Jose.decodeCompact (BSL.fromStrict input)
Jose.verifyClaims Jose.verifyClaims
(jwtSettingsToJwtValidationSettings jwtCfg) (jwtSettingsToJwtValidationSettings jwtCfg)
(validationKeys jwtCfg) keys
unverifiedJWT unverifiedJWT
return $ case verifiedJWT of return $ case verifiedJWT of
Left (_ :: Jose.JWTError) -> Nothing Left (_ :: Jose.JWTError) -> Nothing
Right v -> case decodeJWT v of Right v -> case decodeJWT v of
Left _ -> Nothing Left _ -> Nothing
Right v' -> Just v' Right v' -> Just v'

View File

@ -8,7 +8,10 @@ module Servant.Auth.Server.Internal.ThrowAll where
import Control.Monad.Error.Class import Control.Monad.Error.Class
import Data.Tagged (Tagged (..)) import Data.Tagged (Tagged (..))
import Servant ((:<|>) (..), ServerError(..)) import Servant ((:<|>) (..), ServerError(..), NamedRoutes(..))
import Servant.API.Generic
import Servant.Server.Generic
import Servant.Server
import Network.HTTP.Types import Network.HTTP.Types
import Network.Wai import Network.Wai
@ -26,6 +29,12 @@ class ThrowAll a where
instance (ThrowAll a, ThrowAll b) => ThrowAll (a :<|> b) where instance (ThrowAll a, ThrowAll b) => ThrowAll (a :<|> b) where
throwAll e = throwAll e :<|> throwAll e throwAll e = throwAll e :<|> throwAll e
instance
( ThrowAll (ToServant api (AsServerT m)) , GenericServant api (AsServerT m)) =>
ThrowAll (api (AsServerT m)) where
throwAll = fromServant . throwAll
-- Really this shouldn't be necessary - ((->) a) should be an instance of -- Really this shouldn't be necessary - ((->) a) should be an instance of
-- MonadError, no? -- MonadError, no?
instance {-# OVERLAPPING #-} ThrowAll b => ThrowAll (a -> b) where instance {-# OVERLAPPING #-} ThrowAll b => ThrowAll (a -> b) where

View File

@ -2,6 +2,7 @@
module Servant.Auth.Server.Internal.Types where module Servant.Auth.Server.Internal.Types where
import Control.Applicative import Control.Applicative
import Control.Monad (MonadPlus(..), ap)
import Control.Monad.Reader import Control.Monad.Reader
import Control.Monad.Time import Control.Monad.Time
import Data.Monoid (Monoid (..)) import Data.Monoid (Monoid (..))

View File

@ -6,13 +6,12 @@ module Servant.Auth.ServerSpec (spec) where
#endif #endif
import Control.Lens import Control.Lens
import Control.Monad.Except (runExceptT)
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Crypto.JOSE (Alg (HS256, None), Error, import Crypto.JOSE (Alg (HS256, None), Error,
JWK, JWSHeader, JWK, JWSHeader,
KeyMaterialGenParam (OctGenParam), KeyMaterialGenParam (OctGenParam),
ToCompact, encodeCompact, ToCompact, encodeCompact,
genJWK, newJWSHeader) genJWK, newJWSHeader, runJOSE)
import Crypto.JWT (Audience (..), ClaimsSet, import Crypto.JWT (Audience (..), ClaimsSet,
NumericDate (NumericDate), NumericDate (NumericDate),
SignedJWT, SignedJWT,
@ -50,6 +49,7 @@ import Network.Wreq (Options, auth, basicAuth,
import Network.Wreq.Types (Postable(..)) import Network.Wreq.Types (Postable(..))
import Servant hiding (BasicAuth, import Servant hiding (BasicAuth,
IsSecure (..), header) IsSecure (..), header)
import Servant.API.Generic ((:-))
import Servant.Auth.Server import Servant.Auth.Server
import Servant.Auth.Server.Internal.Cookie (expireTime) import Servant.Auth.Server.Internal.Cookie (expireTime)
import Servant.Auth.Server.SetCookieOrphan () import Servant.Auth.Server.SetCookieOrphan ()
@ -405,6 +405,7 @@ type API auths
= Auth auths User :> = Auth auths User :>
( Get '[JSON] Int ( Get '[JSON] Int
:<|> ReqBody '[JSON] Int :> Post '[JSON] Int :<|> ReqBody '[JSON] Int :> Post '[JSON] Int
:<|> NamedRoutes DummyRoutes
:<|> "header" :> Get '[JSON] (Headers '[Header "Blah" Int] Int) :<|> "header" :> Get '[JSON] (Headers '[Header "Blah" Int] Int)
#if MIN_VERSION_servant_server(0,15,0) #if MIN_VERSION_servant_server(0,15,0)
:<|> "stream" :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString) :<|> "stream" :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString)
@ -416,6 +417,10 @@ type API auths
:<|> "logout" :> Get '[JSON] (Headers '[ Header "Set-Cookie" SetCookie :<|> "logout" :> Get '[JSON] (Headers '[ Header "Set-Cookie" SetCookie
, Header "Set-Cookie" SetCookie ] NoContent) , Header "Set-Cookie" SetCookie ] NoContent)
data DummyRoutes mode = DummyRoutes
{ dummyInt :: mode :- "dummy" :> Get '[JSON] Int
} deriving Generic
jwtOnlyApi :: Proxy (API '[Servant.Auth.Server.JWT]) jwtOnlyApi :: Proxy (API '[Servant.Auth.Server.JWT])
jwtOnlyApi = Proxy jwtOnlyApi = Proxy
@ -476,6 +481,7 @@ server ccfg =
(\authResult -> case authResult of (\authResult -> case authResult of
Authenticated usr -> getInt usr Authenticated usr -> getInt usr
:<|> postInt usr :<|> postInt usr
:<|> DummyRoutes { dummyInt = getInt usr }
:<|> getHeaderInt :<|> getHeaderInt
#if MIN_VERSION_servant_server(0,15,0) #if MIN_VERSION_servant_server(0,15,0)
:<|> return (S.source ["bytestring"]) :<|> return (S.source ["bytestring"])
@ -533,7 +539,7 @@ addJwtToHeader jwt = case jwt of
$ defaults & header "Authorization" .~ ["Bearer " <> BSL.toStrict v] $ defaults & header "Authorization" .~ ["Bearer " <> BSL.toStrict v]
createJWT :: JWK -> JWSHeader () -> ClaimsSet -> IO (Either Error Crypto.JWT.SignedJWT) createJWT :: JWK -> JWSHeader () -> ClaimsSet -> IO (Either Error Crypto.JWT.SignedJWT)
createJWT k a b = runExceptT $ signClaims k a b createJWT k a b = runJOSE $ signClaims k a b
addJwtToCookie :: ToCompact a => CookieSettings -> Either Error a -> IO Options addJwtToCookie :: ToCompact a => CookieSettings -> Either Error a -> IO Options
addJwtToCookie ccfg jwt = case jwt >>= (return . encodeCompact) of addJwtToCookie ccfg jwt = case jwt >>= (return . encodeCompact) of

View File

@ -1,3 +1,4 @@
cabal-version: 2.2
name: servant-auth-swagger name: servant-auth-swagger
version: 0.2.10.1 version: 0.2.10.1
synopsis: servant-swagger/servant-auth compatibility synopsis: servant-swagger/servant-auth compatibility
@ -6,9 +7,9 @@ description: This package provides instances that allow generating swagger2 s
APIs that use APIs that use
<https://hackage.haskell.org/package/servant-auth servant-auth's> @Auth@ combinator. <https://hackage.haskell.org/package/servant-auth servant-auth's> @Auth@ combinator.
. .
For a quick overview of the usage, see the <http://github.com/haskell-servant/servant/servant-auth#readme README>. For a quick overview of the usage, see the <https://github.com/haskell-servant/servant/tree/master/servant-auth#readme README>.
category: Web, Servant, Authentication category: Web, Servant, Authentication
homepage: http://github.com/haskell-servant/servant/servant-auth#readme homepage: https://github.com/haskell-servant/servant/tree/master/servant-auth#readme
bug-reports: https://github.com/haskell-servant/servant/issues bug-reports: https://github.com/haskell-servant/servant/issues
author: Julian K. Arni author: Julian K. Arni
maintainer: jkarni@gmail.com maintainer: jkarni@gmail.com
@ -17,7 +18,6 @@ license: BSD-3-Clause
license-file: LICENSE license-file: LICENSE
tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4
build-type: Simple build-type: Simple
cabal-version: >= 1.10
extra-source-files: extra-source-files:
CHANGELOG.md CHANGELOG.md
@ -31,15 +31,13 @@ library
default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
ghc-options: -Wall ghc-options: -Wall
build-depends: build-depends:
base >= 4.10 && < 4.16 base >= 4.10 && < 4.18
, text >= 1.2.3.0 && < 1.3 , text >= 1.2.3.0 && < 2.1
, servant-swagger >= 1.1.5 && < 1.8 , servant-swagger >= 1.1.5 && < 2
, swagger2 >= 2.2.2 && < 2.7 , swagger2 >= 2.2.2 && < 3
, servant >= 0.13 && < 0.19 , servant >= 0.13 && < 0.20
, servant-auth == 0.4.* , servant-auth == 0.4.*
, lens >= 4.16.1 && < 5.1 , lens >= 4.16.1 && < 5.3
if impl(ghc >= 9)
buildable: False
exposed-modules: exposed-modules:
Servant.Auth.Swagger Servant.Auth.Swagger
default-language: Haskell2010 default-language: Haskell2010
@ -51,7 +49,7 @@ test-suite spec
test test
default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
ghc-options: -Wall ghc-options: -Wall
build-tool-depends: hspec-discover:hspec-discover >= 2.5.5 && <2.9 build-tool-depends: hspec-discover:hspec-discover >= 2.5.5 && <2.10
-- dependencies with bounds inherited from the library stanza -- dependencies with bounds inherited from the library stanza
build-depends: build-depends:
base base
@ -61,13 +59,11 @@ test-suite spec
, servant , servant
, servant-auth , servant-auth
, lens , lens
if impl(ghc >= 9)
buildable: False
-- test dependencies -- test dependencies
build-depends: build-depends:
servant-auth-swagger servant-auth-swagger
, hspec >= 2.5.5 && < 2.9 , hspec >= 2.5.5 && < 2.10
, QuickCheck >= 2.11.3 && < 2.15 , QuickCheck >= 2.11.3 && < 2.15
other-modules: other-modules:
Servant.Auth.SwaggerSpec Servant.Auth.SwaggerSpec

View File

@ -1,5 +1,6 @@
cabal-version: 2.2
name: servant-auth name: servant-auth
version: 0.4.0.0 version: 0.4.1.0
synopsis: Authentication combinators for servant synopsis: Authentication combinators for servant
description: This package provides an @Auth@ combinator for 'servant'. This combinator description: This package provides an @Auth@ combinator for 'servant'. This combinator
allows using different authentication schemes in a straightforward way, allows using different authentication schemes in a straightforward way,
@ -8,9 +9,9 @@ description: This package provides an @Auth@ combinator for 'servant'. This c
'servant-auth' additionally provides concrete authentication schemes, such 'servant-auth' additionally provides concrete authentication schemes, such
as Basic Access Authentication, JSON Web Tokens, and Cookies. as Basic Access Authentication, JSON Web Tokens, and Cookies.
. .
For more details on how to use this, see the <http://github.com/haskell-servant/servant/servant-auth#readme README>. For more details on how to use this, see the <https://github.com/haskell-servant/servant/tree/master/servant-auth#readme README>.
category: Web, Servant, Authentication category: Web, Servant, Authentication
homepage: http://github.com/haskell-servant/servant/servant-auth#readme homepage: https://github.com/haskell-servant/servant/tree/master/servant-auth#readme
bug-reports: https://github.com/haskell-servant/servant/issues bug-reports: https://github.com/haskell-servant/servant/issues
author: Julian K. Arni author: Julian K. Arni
maintainer: jkarni@gmail.com maintainer: jkarni@gmail.com
@ -19,7 +20,6 @@ license: BSD-3-Clause
license-file: LICENSE license-file: LICENSE
tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1 tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1
build-type: Simple build-type: Simple
cabal-version: >= 1.10
extra-source-files: extra-source-files:
CHANGELOG.md CHANGELOG.md
@ -33,12 +33,13 @@ library
default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators
ghc-options: -Wall ghc-options: -Wall
build-depends: build-depends:
base >= 4.10 && < 4.16 base >= 4.10 && < 4.18
, aeson >= 1.3.1.1 && < 1.6 , containers >= 0.6 && < 0.7
, jose >= 0.7.0.0 && < 0.9 , aeson >= 1.3.1.1 && < 3
, lens >= 4.16.1 && < 5.1 , jose >= 0.10 && < 0.11
, servant >= 0.15 && < 0.19 , lens >= 4.16.1 && < 5.3
, text >= 1.2.3.0 && < 1.3 , servant >= 0.15 && < 0.20
, text >= 1.2.3.0 && < 2.1
, unordered-containers >= 0.2.9.0 && < 0.3 , unordered-containers >= 0.2.9.0 && < 0.3
exposed-modules: exposed-modules:
Servant.Auth Servant.Auth

View File

@ -27,7 +27,7 @@ instance HasLink sub => HasLink (Auth (tag :: [*]) value :> sub) where
-- ** Combinators -- ** Combinators
-- | A JSON Web Token (JWT) in the the Authorization header: -- | A JSON Web Token (JWT) in the Authorization header:
-- --
-- @Authorization: Bearer \<token\>@ -- @Authorization: Bearer \<token\>@
-- --

View File

@ -1,10 +1,17 @@
{-# LANGUAGE CPP #-}
module Servant.Auth.JWT where module Servant.Auth.JWT where
import Control.Lens ((^.)) import Control.Lens ((^.))
import qualified Crypto.JWT as Jose import qualified Crypto.JWT as Jose
import Data.Aeson (FromJSON, Result (..), ToJSON, fromJSON, import Data.Aeson (FromJSON, Result (..), ToJSON, fromJSON,
toJSON) toJSON)
import qualified Data.HashMap.Strict as HM #if MIN_VERSION_aeson(2,0,0)
import qualified Data.Map as KM
#else
import qualified Data.HashMap.Strict as KM
#endif
import qualified Data.Text as T import qualified Data.Text as T
@ -17,7 +24,7 @@ import qualified Data.Text as T
class FromJWT a where class FromJWT a where
decodeJWT :: Jose.ClaimsSet -> Either T.Text a decodeJWT :: Jose.ClaimsSet -> Either T.Text a
default decodeJWT :: FromJSON a => Jose.ClaimsSet -> Either T.Text a default decodeJWT :: FromJSON a => Jose.ClaimsSet -> Either T.Text a
decodeJWT m = case HM.lookup "dat" (m ^. Jose.unregisteredClaims) of decodeJWT m = case KM.lookup "dat" (m ^. Jose.unregisteredClaims) of
Nothing -> Left "Missing 'dat' claim" Nothing -> Left "Missing 'dat' claim"
Just v -> case fromJSON v of Just v -> case fromJSON v of
Error e -> Left $ T.pack e Error e -> Left $ T.pack e

View File

@ -1,6 +1,37 @@
[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-client-core/CHANGELOG.md) [The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-client-core/CHANGELOG.md)
[Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md) [Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)
Package versions follow the [Package Versioning Policy](https://pvp.haskell.org/): in A.B.C, bumps to either A or B represent major versions.
0.19
----
### Significant changes
- Drop support for GHC < 8.6.
- Support GHC 9.0 (GHC 9.2 should work as well, but isn't fully tested yet).
- Support Aeson 2 ([#1475](https://github.com/haskell-servant/servant/pull/1475)),
which fixes a [DOS vulnerability](https://github.com/haskell/aeson/issues/864)
related to hash collisions.
- Add `NamedRoutes` combinator, making support for records first-class in Servant
([#1388](https://github.com/haskell-servant/servant/pull/1388)).
- Add custom type errors for partially applied combinators
([#1289](https://github.com/haskell-servant/servant/pull/1289),
[#1486](https://github.com/haskell-servant/servant/pull/1486)).
- *servant-client* / *servant-client-core* / *servant-http-streams*: Fix
erroneous behavior, where only 2XX status codes would be considered
successful, irrelevant of the status parameter specified by the verb
combinator. ([#1469](https://github.com/haskell-servant/servant/pull/1469))
- *servant-client* / *servant-client-core*: Fix `Show` instance for
`Servant.Client.Core.Request`.
- *servant-client* / *servant-client-core*: Allow passing arbitrary binary data
in Query parameters.
([#1432](https://github.com/haskell-servant/servant/pull/1432)).
### Other changes
- Various version bumps.
0.18.3 0.18.3
------ ------

View File

@ -1,6 +1,6 @@
cabal-version: >=1.10 cabal-version: 2.2
name: servant-client-core name: servant-client-core
version: 0.18.3 version: 0.19
synopsis: Core functionality and class for client function generation for servant APIs synopsis: Core functionality and class for client function generation for servant APIs
category: Servant, Web category: Servant, Web
@ -50,14 +50,14 @@ library
-- --
-- note: mtl lower bound is so low because of GHC-7.8 -- note: mtl lower bound is so low because of GHC-7.8
build-depends: build-depends:
base >= 4.9 && < 4.16 base >= 4.9 && < 4.18
, bytestring >= 0.10.8.1 && < 0.12 , bytestring >= 0.10.8.1 && < 0.12
, constraints >= 0.2 && < 0.14 , constraints >= 0.2 && < 0.14
, containers >= 0.5.7.1 && < 0.7 , containers >= 0.5.7.1 && < 0.7
, deepseq >= 1.4.2.0 && < 1.5 , deepseq >= 1.4.2.0 && < 1.5
, text >= 1.2.3.0 && < 1.3 , text >= 1.2.3.0 && < 2.1
, transformers >= 0.5.2.0 && < 0.6 , transformers >= 0.5.2.0 && < 0.7
, template-haskell >= 2.11.1.0 && < 2.18 , template-haskell >= 2.11.1.0 && < 2.20
if !impl(ghc >= 8.2) if !impl(ghc >= 8.2)
build-depends: build-depends:
@ -65,13 +65,13 @@ library
-- Servant dependencies -- Servant dependencies
build-depends: build-depends:
servant >= 0.18.3 && <0.19 servant >= 0.19
-- Other dependencies: Lower bound around what is in the latest Stackage LTS. -- Other dependencies: Lower bound around what is in the latest Stackage LTS.
-- Here can be exceptions if we really need features from the newer versions. -- Here can be exceptions if we really need features from the newer versions.
build-depends: build-depends:
aeson >= 1.4.1.0 && < 1.6 aeson >= 1.4.1.0 && < 3
, base-compat >= 0.10.5 && < 0.12 , base-compat >= 0.10.5 && < 0.13
, base64-bytestring >= 1.0.0.1 && < 1.3 , base64-bytestring >= 1.0.0.1 && < 1.3
, exceptions >= 0.10.0 && < 0.11 , exceptions >= 0.10.0 && < 0.11
, free >= 5.1 && < 5.2 , free >= 5.1 && < 5.2
@ -104,8 +104,8 @@ test-suite spec
-- Additional dependencies -- Additional dependencies
build-depends: build-depends:
deepseq >= 1.4.2.0 && < 1.5 deepseq >= 1.4.2.0 && < 1.5
, hspec >= 2.6.0 && < 2.9 , hspec >= 2.6.0 && < 2.10
, QuickCheck >= 2.12.6.1 && < 2.15 , QuickCheck >= 2.12.6.1 && < 2.15
build-tool-depends: build-tool-depends:
hspec-discover:hspec-discover >= 2.6.0 && <2.9 hspec-discover:hspec-discover >= 2.6.0 && <2.10

View File

@ -59,6 +59,7 @@ module Servant.Client.Core
, appendToPath , appendToPath
, setRequestBodyLBS , setRequestBodyLBS
, setRequestBody , setRequestBody
, encodeQueryParamValue
) where ) where
import Servant.Client.Core.Auth import Servant.Client.Core.Auth
import Servant.Client.Core.BaseUrl import Servant.Client.Core.BaseUrl

View File

@ -33,9 +33,7 @@ import Control.Arrow
import Control.Monad import Control.Monad
(unless) (unless)
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import Data.ByteString.Builder import qualified Data.ByteString.Lazy as BL
(toLazyByteString)
import qualified Data.ByteString.Lazy as BL
import Data.Either import Data.Either
(partitionEithers) (partitionEithers)
import Data.Constraint (Dict(..)) import Data.Constraint (Dict(..))
@ -65,7 +63,7 @@ import Data.Text
import Data.Proxy import Data.Proxy
(Proxy (Proxy)) (Proxy (Proxy))
import GHC.TypeLits import GHC.TypeLits
(KnownSymbol, symbolVal) (KnownNat, KnownSymbol, TypeError, symbolVal)
import Network.HTTP.Types import Network.HTTP.Types
(Status) (Status)
import qualified Network.HTTP.Types as H import qualified Network.HTTP.Types as H
@ -79,16 +77,19 @@ import Servant.API
NoContentVerb, QueryFlag, QueryParam', QueryParams, Raw, NoContentVerb, QueryFlag, QueryParam', QueryParams, Raw,
ReflectMethod (..), RemoteHost, ReqBody', SBoolI, Stream, ReflectMethod (..), RemoteHost, ReqBody', SBoolI, Stream,
StreamBody', Summary, ToHttpApiData, ToSourceIO (..), Vault, StreamBody', Summary, ToHttpApiData, ToSourceIO (..), Vault,
Verb, WithNamedContext, WithStatus (..), contentType, getHeadersHList, Verb, WithNamedContext, WithResource, WithStatus (..), contentType, getHeadersHList,
getResponse, toEncodedUrlPiece, toUrlPiece, NamedRoutes) getResponse, toEncodedUrlPiece, toUrlPiece, NamedRoutes)
import Servant.API.Generic import Servant.API.Generic
(GenericMode(..), ToServant, ToServantApi (GenericMode(..), ToServant, ToServantApi
, GenericServant, toServant, fromServant) , GenericServant, toServant, fromServant)
import Servant.API.ContentTypes import Servant.API.ContentTypes
(contentTypes, AllMime (allMime), AllMimeUnrender (allMimeUnrender)) (contentTypes, AllMime (allMime), AllMimeUnrender (allMimeUnrender))
import Servant.API.Status
(statusFromNat)
import Servant.API.TypeLevel (FragmentUnique, AtLeastOneFragment) import Servant.API.TypeLevel (FragmentUnique, AtLeastOneFragment)
import Servant.API.Modifiers import Servant.API.Modifiers
(FoldRequired, RequiredArgument, foldRequiredArgument) (FoldRequired, RequiredArgument, foldRequiredArgument)
import Servant.API.TypeErrors
import Servant.API.UVerb import Servant.API.UVerb
(HasStatus, HasStatuses (Statuses, statuses), UVerb, Union, Unique, inject, statusOf, foldMapUnion, matchUnion) (HasStatus, HasStatuses (Statuses, statuses), UVerb, Union, Unique, inject, statusOf, foldMapUnion, matchUnion)
@ -207,7 +208,7 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m api)
clientWithRoute pm (Proxy :: Proxy api) clientWithRoute pm (Proxy :: Proxy api)
(appendToPath p req) (appendToPath p req)
where p = (toUrlPiece val) where p = toEncodedUrlPiece val
hoistClientMonad pm _ f cl = \a -> hoistClientMonad pm _ f cl = \a ->
hoistClientMonad pm (Proxy :: Proxy api) f (cl a) hoistClientMonad pm (Proxy :: Proxy api) f (cl a)
@ -242,7 +243,7 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m sublayout)
clientWithRoute pm (Proxy :: Proxy sublayout) clientWithRoute pm (Proxy :: Proxy sublayout)
(foldl' (flip appendToPath) req ps) (foldl' (flip appendToPath) req ps)
where ps = map (toUrlPiece) vals where ps = map toEncodedUrlPiece vals
hoistClientMonad pm _ f cl = \as -> hoistClientMonad pm _ f cl = \as ->
hoistClientMonad pm (Proxy :: Proxy sublayout) f (cl as) hoistClientMonad pm (Proxy :: Proxy sublayout) f (cl as)
@ -250,10 +251,11 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m sublayout)
instance {-# OVERLAPPABLE #-} instance {-# OVERLAPPABLE #-}
-- Note [Non-Empty Content Types] -- Note [Non-Empty Content Types]
( RunClient m, MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts) ( RunClient m, MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)
, KnownNat status
) => HasClient m (Verb method status cts' a) where ) => HasClient m (Verb method status cts' a) where
type Client m (Verb method status cts' a) = m a type Client m (Verb method status cts' a) = m a
clientWithRoute _pm Proxy req = do clientWithRoute _pm Proxy req = do
response <- runRequest req response <- runRequestAcceptStatus (Just [status]) req
{ requestAccept = fromList $ toList accept { requestAccept = fromList $ toList accept
, requestMethod = method , requestMethod = method
} }
@ -261,18 +263,20 @@ instance {-# OVERLAPPABLE #-}
where where
accept = contentTypes (Proxy :: Proxy ct) accept = contentTypes (Proxy :: Proxy ct)
method = reflectMethod (Proxy :: Proxy method) method = reflectMethod (Proxy :: Proxy method)
status = statusFromNat (Proxy :: Proxy status)
hoistClientMonad _ _ f ma = f ma hoistClientMonad _ _ f ma = f ma
instance {-# OVERLAPPING #-} instance {-# OVERLAPPING #-}
( RunClient m, ReflectMethod method ( RunClient m, ReflectMethod method, KnownNat status
) => HasClient m (Verb method status cts NoContent) where ) => HasClient m (Verb method status cts NoContent) where
type Client m (Verb method status cts NoContent) type Client m (Verb method status cts NoContent)
= m NoContent = m NoContent
clientWithRoute _pm Proxy req = do clientWithRoute _pm Proxy req = do
_response <- runRequest req { requestMethod = method } _response <- runRequestAcceptStatus (Just [status]) req { requestMethod = method }
return NoContent return NoContent
where method = reflectMethod (Proxy :: Proxy method) where method = reflectMethod (Proxy :: Proxy method)
status = statusFromNat (Proxy :: Proxy status)
hoistClientMonad _ _ f ma = f ma hoistClientMonad _ _ f ma = f ma
@ -289,13 +293,13 @@ instance (RunClient m, ReflectMethod method) =>
instance {-# OVERLAPPING #-} instance {-# OVERLAPPING #-}
-- Note [Non-Empty Content Types] -- Note [Non-Empty Content Types]
( RunClient m, MimeUnrender ct a, BuildHeadersTo ls ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls, KnownNat status
, ReflectMethod method, cts' ~ (ct ': cts) , ReflectMethod method, cts' ~ (ct ': cts)
) => HasClient m (Verb method status cts' (Headers ls a)) where ) => HasClient m (Verb method status cts' (Headers ls a)) where
type Client m (Verb method status cts' (Headers ls a)) type Client m (Verb method status cts' (Headers ls a))
= m (Headers ls a) = m (Headers ls a)
clientWithRoute _pm Proxy req = do clientWithRoute _pm Proxy req = do
response <- runRequest req response <- runRequestAcceptStatus (Just [status]) req
{ requestMethod = method { requestMethod = method
, requestAccept = fromList $ toList accept , requestAccept = fromList $ toList accept
} }
@ -303,22 +307,26 @@ instance {-# OVERLAPPING #-}
return $ Headers { getResponse = val return $ Headers { getResponse = val
, getHeadersHList = buildHeadersTo . toList $ responseHeaders response , getHeadersHList = buildHeadersTo . toList $ responseHeaders response
} }
where method = reflectMethod (Proxy :: Proxy method) where
accept = contentTypes (Proxy :: Proxy ct) method = reflectMethod (Proxy :: Proxy method)
accept = contentTypes (Proxy :: Proxy ct)
status = statusFromNat (Proxy :: Proxy status)
hoistClientMonad _ _ f ma = f ma hoistClientMonad _ _ f ma = f ma
instance {-# OVERLAPPING #-} instance {-# OVERLAPPING #-}
( RunClient m, BuildHeadersTo ls, ReflectMethod method ( RunClient m, BuildHeadersTo ls, ReflectMethod method, KnownNat status
) => HasClient m (Verb method status cts (Headers ls NoContent)) where ) => HasClient m (Verb method status cts (Headers ls NoContent)) where
type Client m (Verb method status cts (Headers ls NoContent)) type Client m (Verb method status cts (Headers ls NoContent))
= m (Headers ls NoContent) = m (Headers ls NoContent)
clientWithRoute _pm Proxy req = do clientWithRoute _pm Proxy req = do
let method = reflectMethod (Proxy :: Proxy method) response <- runRequestAcceptStatus (Just [status]) req { requestMethod = method }
response <- runRequest req { requestMethod = method }
return $ Headers { getResponse = NoContent return $ Headers { getResponse = NoContent
, getHeadersHList = buildHeadersTo . toList $ responseHeaders response , getHeadersHList = buildHeadersTo . toList $ responseHeaders response
} }
where
method = reflectMethod (Proxy :: Proxy method)
status = statusFromNat (Proxy :: Proxy status)
hoistClientMonad _ _ f ma = f ma hoistClientMonad _ _ f ma = f ma
@ -561,7 +569,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequire
(Proxy :: Proxy mods) add (maybe req add) mparam (Proxy :: Proxy mods) add (maybe req add) mparam
where where
add :: a -> Request add :: a -> Request
add param = appendToQueryString pname (Just $ encodeQueryParam param) req add param = appendToQueryString pname (Just $ encodeQueryParamValue param) req
pname :: Text pname :: Text
pname = pack $ symbolVal (Proxy :: Proxy sym) pname = pack $ symbolVal (Proxy :: Proxy sym)
@ -569,9 +577,6 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequire
hoistClientMonad pm _ f cl = \arg -> hoistClientMonad pm _ f cl = \arg ->
hoistClientMonad pm (Proxy :: Proxy api) f (cl arg) hoistClientMonad pm (Proxy :: Proxy api) f (cl arg)
encodeQueryParam :: ToHttpApiData a => a -> BS.ByteString
encodeQueryParam = BL.toStrict . toLazyByteString . toEncodedUrlPiece
-- | If you use a 'QueryParams' in one of your endpoints in your API, -- | If you use a 'QueryParams' in one of your endpoints in your API,
-- the corresponding querying function will automatically take -- the corresponding querying function will automatically take
-- an additional argument, a list of values of the type specified -- an additional argument, a list of values of the type specified
@ -613,7 +618,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api)
) )
where pname = pack $ symbolVal (Proxy :: Proxy sym) where pname = pack $ symbolVal (Proxy :: Proxy sym)
paramlist' = map (Just . encodeQueryParam) paramlist paramlist' = map (Just . encodeQueryParamValue) paramlist
hoistClientMonad pm _ f cl = \as -> hoistClientMonad pm _ f cl = \as ->
hoistClientMonad pm (Proxy :: Proxy api) f (cl as) hoistClientMonad pm (Proxy :: Proxy api) f (cl as)
@ -735,7 +740,7 @@ instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where
clientWithRoute pm (Proxy :: Proxy api) clientWithRoute pm (Proxy :: Proxy api)
(appendToPath p req) (appendToPath p req)
where p = pack $ symbolVal (Proxy :: Proxy path) where p = toEncodedUrlPiece $ pack $ symbolVal (Proxy :: Proxy path)
hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
@ -771,6 +776,14 @@ instance HasClient m subapi =>
hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy subapi) f cl hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy subapi) f cl
instance HasClient m subapi =>
HasClient m (WithResource res :> subapi) where
type Client m (WithResource res :> subapi) = Client m subapi
clientWithRoute pm Proxy = clientWithRoute pm (Proxy :: Proxy subapi)
hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy subapi) f cl
instance ( HasClient m api instance ( HasClient m api
) => HasClient m (AuthProtect tag :> api) where ) => HasClient m (AuthProtect tag :> api) where
type Client m (AuthProtect tag :> api) type Client m (AuthProtect tag :> api)
@ -784,7 +797,7 @@ instance ( HasClient m api
-- | Ignore @'Fragment'@ in client functions. -- | Ignore @'Fragment'@ in client functions.
-- See <https://ietf.org/rfc/rfc2616.html#section-15.1.3> for more details. -- See <https://ietf.org/rfc/rfc2616.html#section-15.1.3> for more details.
-- --
-- Example: -- Example:
-- --
-- > type MyApi = "books" :> Fragment Text :> Get '[JSON] [Book] -- > type MyApi = "books" :> Fragment Text :> Get '[JSON] [Book]
@ -801,7 +814,7 @@ instance (AtLeastOneFragment api, FragmentUnique (Fragment a :> api), HasClient
type Client m (Fragment a :> api) = Client m api type Client m (Fragment a :> api) = Client m api
clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api) clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api)
hoistClientMonad pm _ = hoistClientMonad pm (Proxy :: Proxy api) hoistClientMonad pm _ = hoistClientMonad pm (Proxy :: Proxy api)
@ -869,7 +882,7 @@ infixl 2 /:
-- --
-- Example: -- Example:
-- --
-- @@ -- @
-- type Api = NamedRoutes RootApi -- type Api = NamedRoutes RootApi
-- --
-- data RootApi mode = RootApi -- data RootApi mode = RootApi
@ -889,8 +902,8 @@ infixl 2 /:
-- rootClient = client api -- rootClient = client api
-- --
-- endpointClient :: ClientM Person -- endpointClient :: ClientM Person
-- endpointClient = client // subApi // endpoint -- endpointClient = client \/\/ subApi \/\/ endpoint
-- @@ -- @
(//) :: a -> (a -> b) -> b (//) :: a -> (a -> b) -> b
x // f = f x x // f = f x
@ -901,7 +914,7 @@ x // f = f x
-- --
-- Example: -- Example:
-- --
-- @@ -- @
-- type Api = NamedRoutes RootApi -- type Api = NamedRoutes RootApi
-- --
-- data RootApi mode = RootApi -- data RootApi mode = RootApi
@ -922,11 +935,11 @@ x // f = f x
-- rootClient = client api -- rootClient = client api
-- --
-- hello :: String -> ClientM String -- hello :: String -> ClientM String
-- hello name = rootClient // hello /: name -- hello name = rootClient \/\/ hello \/: name
-- --
-- endpointClient :: ClientM Person -- endpointClient :: ClientM Person
-- endpointClient = client // subApi /: "foobar123" // endpoint -- endpointClient = client \/\/ subApi \/: "foobar123" \/\/ endpoint
-- @@ -- @
(/:) :: (a -> b -> c) -> b -> a -> c (/:) :: (a -> b -> c) -> b -> a -> c
(/:) = flip (/:) = flip
@ -970,3 +983,19 @@ decodedAs response ct = do
Right val -> return val Right val -> return val
where where
accept = toList $ contentTypes ct accept = toList $ contentTypes ct
-------------------------------------------------------------------------------
-- Custom type errors
-------------------------------------------------------------------------------
-- Erroring instance for HasClient' when a combinator is not fully applied
instance (RunClient m, TypeError (PartialApplication HasClient arr)) => HasClient m ((arr :: a -> b) :> sub)
where
type Client m (arr :> sub) = TypeError (PartialApplication HasClient arr)
clientWithRoute _ _ _ = error "unreachable"
hoistClientMonad _ _ _ _ = error "unreachable"
-- Erroring instances for 'HasClient' for unknown API combinators
instance {-# OVERLAPPABLE #-} (RunClient m, TypeError (NoInstanceForSub (HasClient m) ty)) => HasClient m (ty :> sub)
instance {-# OVERLAPPABLE #-} (RunClient m, TypeError (NoInstanceFor (HasClient m api))) => HasClient m api

View File

@ -17,6 +17,7 @@ module Servant.Client.Core.Request (
addHeader, addHeader,
appendToPath, appendToPath,
appendToQueryString, appendToQueryString,
encodeQueryParamValue,
setRequestBody, setRequestBody,
setRequestBodyLBS, setRequestBodyLBS,
) where ) where
@ -33,6 +34,8 @@ import Data.Bifunctor
import Data.Bitraversable import Data.Bitraversable
(Bitraversable (..), bifoldMapDefault, bimapDefault) (Bitraversable (..), bifoldMapDefault, bimapDefault)
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import Data.ByteString.Builder
(Builder)
import qualified Data.ByteString.Builder as Builder import qualified Data.ByteString.Builder as Builder
import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Lazy as LBS
import qualified Data.Sequence as Seq import qualified Data.Sequence as Seq
@ -78,12 +81,13 @@ instance (Show a, Show b) =>
. showString ", requestAccept = " . showString ", requestAccept = "
. showsPrec 0 (requestAccept req) . showsPrec 0 (requestAccept req)
. showString ", requestHeaders = " . showString ", requestHeaders = "
. showsPrec 0 (redactSensitiveHeader <$> requestHeaders req)) . showsPrec 0 (redactSensitiveHeader <$> requestHeaders req)
. showString ", requestHttpVersion = " . showString ", requestHttpVersion = "
. showsPrec 0 (requestHttpVersion req) . showsPrec 0 (requestHttpVersion req)
. showString ", requestMethod = " . showString ", requestMethod = "
. showsPrec 0 (requestMethod req) . showsPrec 0 (requestMethod req)
. showString "}" . showString "}"
)
where where
redactSensitiveHeader :: Header -> Header redactSensitiveHeader :: Header -> Header
redactSensitiveHeader ("Authorization", _) = ("Authorization", "<REDACTED>") redactSensitiveHeader ("Authorization", _) = ("Authorization", "<REDACTED>")
@ -110,7 +114,7 @@ instance (NFData path, NFData body) => NFData (RequestF body path) where
rnfB Nothing = () rnfB Nothing = ()
rnfB (Just (b, mt)) = rnf b `seq` mediaTypeRnf mt rnfB (Just (b, mt)) = rnf b `seq` mediaTypeRnf mt
type Request = RequestF RequestBody Builder.Builder type Request = RequestF RequestBody Builder
-- | The request body. R replica of the @http-client@ @RequestBody@. -- | The request body. R replica of the @http-client@ @RequestBody@.
data RequestBody data RequestBody
@ -141,18 +145,30 @@ defaultRequest = Request
, requestMethod = methodGet , requestMethod = methodGet
} }
appendToPath :: Text -> Request -> Request -- | Append extra path to the request being constructed.
--
-- Warning: This function assumes that the path fragment is already URL-encoded.
appendToPath :: Builder -> Request -> Request
appendToPath p req appendToPath p req
= req { requestPath = requestPath req <> "/" <> toEncodedUrlPiece p } = req { requestPath = requestPath req <> "/" <> p }
appendToQueryString :: Text -- ^ param name -- | Append a query parameter to the request being constructed.
-> Maybe BS.ByteString -- ^ param value --
appendToQueryString :: Text -- ^ query param name
-> Maybe BS.ByteString -- ^ query param value
-> Request -> Request
-> Request -> Request
appendToQueryString pname pvalue req appendToQueryString pname pvalue req
= req { requestQueryString = requestQueryString req = req { requestQueryString = requestQueryString req
Seq.|> (encodeUtf8 pname, pvalue)} Seq.|> (encodeUtf8 pname, pvalue)}
-- | Encode a query parameter value.
--
encodeQueryParamValue :: ToHttpApiData a => a -> BS.ByteString
encodeQueryParamValue = LBS.toStrict . Builder.toLazyByteString . toEncodedUrlPiece
-- | Add header to the request being constructed.
--
addHeader :: ToHttpApiData a => HeaderName -> a -> Request -> Request addHeader :: ToHttpApiData a => HeaderName -> a -> Request -> Request
addHeader name val req addHeader name val req
= req { requestHeaders = requestHeaders req Seq.|> (name, toHeader val)} = req { requestHeaders = requestHeaders req Seq.|> (name, toHeader val)}

View File

@ -10,10 +10,22 @@ import Data.List (isInfixOf)
import Servant.Client.Core.Request import Servant.Client.Core.Request
import Test.Hspec import Test.Hspec
newtype DataWithRequest = DataWithRequest (RequestF RequestBody ())
deriving Show
spec :: Spec spec :: Spec
spec = do spec = do
describe "Request" $ do describe "Request" $ do
describe "show" $ do describe "show" $ do
it "has parenthesis correctly positioned" $ do
let d = DataWithRequest (void defaultRequest)
show d `shouldBe` "DataWithRequest (Request {requestPath = ()\
\, requestQueryString = fromList []\
\, requestBody = Nothing\
\, requestAccept = fromList []\
\, requestHeaders = fromList []\
\, requestHttpVersion = HTTP/1.1\
\, requestMethod = \"GET\"})"
it "redacts the authorization header" $ do it "redacts the authorization header" $ do
let request = void $ defaultRequest { requestHeaders = pure ("authorization", "secret") } let request = void $ defaultRequest { requestHeaders = pure ("authorization", "secret") }
isInfixOf "secret" (show request) `shouldBe` False isInfixOf "secret" (show request) `shouldBe` False

View File

@ -1,4 +1,4 @@
cabal-version: >=1.10 cabal-version: 2.2
name: servant-client-ghcjs name: servant-client-ghcjs
version: 0.16 version: 0.16
synopsis: synopsis:
@ -38,7 +38,7 @@ library
Servant.Client.Internal.XhrClient Servant.Client.Internal.XhrClient
build-depends: build-depends:
base >=4.11 && <4.12 base >=4.11 && <5
, bytestring >=0.10 && <0.12 , bytestring >=0.10 && <0.12
, case-insensitive >=1.2.0.0 && <1.3.0.0 , case-insensitive >=1.2.0.0 && <1.3.0.0
, containers >=0.5 && <0.7 , containers >=0.5 && <0.7
@ -48,7 +48,7 @@ library
, http-media >=0.6.2 && <0.9 , http-media >=0.6.2 && <0.9
, http-types >=0.12 && <0.13 , http-types >=0.12 && <0.13
, monad-control >=1.0.0.4 && <1.1 , monad-control >=1.0.0.4 && <1.1
, mtl >=2.2.2 && <2.3 , mtl ^>=2.2.2 || ^>=2.3.1
, semigroupoids >=5.3 && <5.4 , semigroupoids >=5.3 && <5.4
, string-conversions >=0.3 && <0.5 , string-conversions >=0.3 && <0.5
, transformers >=0.3 && <0.6 , transformers >=0.3 && <0.6
@ -56,8 +56,8 @@ library
-- strict, as we re-export stuff -- strict, as we re-export stuff
build-depends: build-depends:
servant >=0.16 && <0.17 servant >=0.16 && <0.20
, servant-client-core >=0.16 && <0.16.1 , servant-client-core >=0.16 && <0.20
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010

View File

@ -120,7 +120,7 @@ instance Exception StreamingNotSupportedException where
displayException _ = "streamingRequest: streaming is not supported!" displayException _ = "streamingRequest: streaming is not supported!"
instance RunClient ClientM where instance RunClient ClientM where
runRequest = performRequest runRequestAcceptStatus = performRequest
throwClientError = throwError throwClientError = throwError
runClientMOrigin :: ClientM a -> ClientEnv -> IO (Either ClientError a) runClientMOrigin :: ClientM a -> ClientEnv -> IO (Either ClientError a)
@ -152,15 +152,18 @@ runClientM m = do
runClientMOrigin m (ClientEnv (BaseUrl protocol hostname port "")) runClientMOrigin m (ClientEnv (BaseUrl protocol hostname port ""))
performRequest :: Request -> ClientM Response performRequest :: Maybe [Status] -> Request -> ClientM Response
performRequest req = do performRequest acceptStatus req = do
xhr <- liftIO initXhr xhr <- liftIO initXhr
burl <- asks baseUrl burl <- asks baseUrl
liftIO $ performXhr xhr burl req liftIO $ performXhr xhr burl req
resp <- toResponse xhr resp <- toResponse xhr
let status = statusCode (responseStatusCode resp) let status = responseStatusCode resp
unless (status >= 200 && status < 300) $ do goodStatus = case acceptStatus of
Nothing -> statusIsSuccessful status
Just good -> status `elem` good
unless goodStatus $ do
let f b = (burl, BL.toStrict $ toLazyByteString b) let f b = (burl, BL.toStrict $ toLazyByteString b)
throwError $ FailureResponse (bimap (const ()) f req) resp throwError $ FailureResponse (bimap (const ()) f req) resp

View File

@ -1,6 +1,37 @@
[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-client/CHANGELOG.md) [The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-client/CHANGELOG.md)
[Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md) [Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)
Package versions follow the [Package Versioning Policy](https://pvp.haskell.org/): in A.B.C, bumps to either A or B represent major versions.
0.19
----
### Significant changes
- Drop support for GHC < 8.6.
- Support GHC 9.0 (GHC 9.2 should work as well, but isn't fully tested yet).
- Support Aeson 2 ([#1475](https://github.com/haskell-servant/servant/pull/1475)),
which fixes a [DOS vulnerability](https://github.com/haskell/aeson/issues/864)
related to hash collisions.
- Add `NamedRoutes` combinator, making support for records first-class in Servant
([#1388](https://github.com/haskell-servant/servant/pull/1388)).
- Add custom type errors for partially applied combinators
([#1289](https://github.com/haskell-servant/servant/pull/1289),
[#1486](https://github.com/haskell-servant/servant/pull/1486)).
- *servant-client* / *servant-client-core* / *servant-http-streams*: Fix
erroneous behavior, where only 2XX status codes would be considered
successful, irrelevant of the status parameter specified by the verb
combinator. ([#1469](https://github.com/haskell-servant/servant/pull/1469))
- *servant-client* / *servant-client-core*: Fix `Show` instance for
`Servant.Client.Core.Request`.
- *servant-client* / *servant-client-core*: Allow passing arbitrary binary data
in Query parameters.
([#1432](https://github.com/haskell-servant/servant/pull/1432)).
### Other changes
- Various version bumps.
0.18.3 0.18.3
------ ------

View File

@ -1,6 +1,6 @@
cabal-version: >=1.10 cabal-version: 2.2
name: servant-client name: servant-client
version: 0.18.3 version: 0.19
synopsis: Automatic derivation of querying functions for servant synopsis: Automatic derivation of querying functions for servant
category: Servant, Web category: Servant, Web
@ -41,15 +41,15 @@ library
-- Bundled with GHC: Lower bound to not force re-installs -- Bundled with GHC: Lower bound to not force re-installs
-- text and mtl are bundled starting with GHC-8.4 -- text and mtl are bundled starting with GHC-8.4
build-depends: build-depends:
base >= 4.9 && < 4.16 base >= 4.9 && < 4.18
, bytestring >= 0.10.8.1 && < 0.12 , bytestring >= 0.10.8.1 && < 0.12
, containers >= 0.5.7.1 && < 0.7 , containers >= 0.5.7.1 && < 0.7
, deepseq >= 1.4.2.0 && < 1.5 , deepseq >= 1.4.2.0 && < 1.5
, mtl >= 2.2.2 && < 2.3 , mtl ^>= 2.2.2 || ^>= 2.3.1
, stm >= 2.4.5.1 && < 2.6 , stm >= 2.4.5.1 && < 2.6
, text >= 1.2.3.0 && < 1.3 , text >= 1.2.3.0 && < 2.1
, time >= 1.6.0.1 && < 1.10 , time >= 1.6.0.1 && < 1.13
, transformers >= 0.5.2.0 && < 0.6 , transformers >= 0.5.2.0 && < 0.7
if !impl(ghc >= 8.2) if !impl(ghc >= 8.2)
build-depends: build-depends:
@ -58,13 +58,13 @@ library
-- Servant dependencies. -- Servant dependencies.
-- Strict dependency on `servant-client-core` as we re-export things. -- Strict dependency on `servant-client-core` as we re-export things.
build-depends: build-depends:
servant == 0.18.* servant >= 0.18 && < 0.20
, servant-client-core >= 0.18.3 && <0.18.4 , servant-client-core >= 0.19 && < 0.19.1
-- Other dependencies: Lower bound around what is in the latest Stackage LTS. -- Other dependencies: Lower bound around what is in the latest Stackage LTS.
-- Here can be exceptions if we really need features from the newer versions. -- Here can be exceptions if we really need features from the newer versions.
build-depends: build-depends:
base-compat >= 0.10.5 && < 0.12 base-compat >= 0.10.5 && < 0.13
, http-client >= 0.5.13.1 && < 0.8 , http-client >= 0.5.13.1 && < 0.8
, http-media >= 0.7.1.3 && < 0.9 , http-media >= 0.7.1.3 && < 0.9
, http-types >= 0.12.2 && < 0.13 , http-types >= 0.12.2 && < 0.13
@ -89,6 +89,7 @@ test-suite spec
main-is: Spec.hs main-is: Spec.hs
other-modules: other-modules:
Servant.BasicAuthSpec Servant.BasicAuthSpec
Servant.BrokenSpec
Servant.ClientTestUtils Servant.ClientTestUtils
Servant.ConnectionErrorSpec Servant.ConnectionErrorSpec
Servant.FailSpec Servant.FailSpec
@ -123,16 +124,16 @@ test-suite spec
-- Additional dependencies -- Additional dependencies
build-depends: build-depends:
entropy >= 0.4.1.3 && < 0.5 entropy >= 0.4.1.3 && < 0.5
, hspec >= 2.6.0 && < 2.9 , hspec >= 2.6.0 && < 2.10
, HUnit >= 1.6.0.0 && < 1.7 , HUnit >= 1.6.0.0 && < 1.7
, network >= 2.8.0.0 && < 3.2 , network >= 2.8.0.0 && < 3.2
, QuickCheck >= 2.12.6.1 && < 2.15 , QuickCheck >= 2.12.6.1 && < 2.15
, servant == 0.18.* , servant == 0.19.*
, servant-server == 0.18.* , servant-server == 0.19.*
, tdigest >= 0.2 && < 0.3 , tdigest >= 0.2 && < 0.3
build-tool-depends: build-tool-depends:
hspec-discover:hspec-discover >= 2.6.0 && < 2.9 hspec-discover:hspec-discover >= 2.6.0 && < 2.10
test-suite readme test-suite readme
type: exitcode-stdio-1.0 type: exitcode-stdio-1.0

View File

@ -24,7 +24,7 @@ import Control.Monad
import Control.Monad.Base import Control.Monad.Base
(MonadBase (..)) (MonadBase (..))
import Control.Monad.Catch import Control.Monad.Catch
(MonadCatch, MonadThrow) (MonadCatch, MonadThrow, MonadMask)
import Control.Monad.Error.Class import Control.Monad.Error.Class
(MonadError (..)) (MonadError (..))
import Control.Monad.IO.Class import Control.Monad.IO.Class
@ -63,7 +63,7 @@ import GHC.Generics
import Network.HTTP.Media import Network.HTTP.Media
(renderHeader) (renderHeader)
import Network.HTTP.Types import Network.HTTP.Types
(hContentType, renderQuery, statusCode, urlEncode, Status) (hContentType, renderQuery, statusIsSuccessful, urlEncode, Status)
import Servant.Client.Core import Servant.Client.Core
import qualified Network.HTTP.Client as Client import qualified Network.HTTP.Client as Client
@ -80,7 +80,7 @@ data ClientEnv
{ manager :: Client.Manager { manager :: Client.Manager
, baseUrl :: BaseUrl , baseUrl :: BaseUrl
, cookieJar :: Maybe (TVar Client.CookieJar) , cookieJar :: Maybe (TVar Client.CookieJar)
, makeClientRequest :: BaseUrl -> Request -> Client.Request , makeClientRequest :: BaseUrl -> Request -> IO Client.Request
-- ^ this function can be used to customize the creation of @http-client@ requests from @servant@ requests. Default value: 'defaultMakeClientRequest' -- ^ this function can be used to customize the creation of @http-client@ requests from @servant@ requests. Default value: 'defaultMakeClientRequest'
-- Note that: -- Note that:
-- 1. 'makeClientRequest' exists to allow overriding operational semantics e.g. 'responseTimeout' per request, -- 1. 'makeClientRequest' exists to allow overriding operational semantics e.g. 'responseTimeout' per request,
@ -136,7 +136,7 @@ newtype ClientM a = ClientM
{ unClientM :: ReaderT ClientEnv (ExceptT ClientError IO) a } { unClientM :: ReaderT ClientEnv (ExceptT ClientError IO) a }
deriving ( Functor, Applicative, Monad, MonadIO, Generic deriving ( Functor, Applicative, Monad, MonadIO, Generic
, MonadReader ClientEnv, MonadError ClientError, MonadThrow , MonadReader ClientEnv, MonadError ClientError, MonadThrow
, MonadCatch) , MonadCatch, MonadMask)
instance MonadBase IO ClientM where instance MonadBase IO ClientM where
liftBase = ClientM . liftBase liftBase = ClientM . liftBase
@ -162,7 +162,7 @@ runClientM cm env = runExceptT $ flip runReaderT env $ unClientM cm
performRequest :: Maybe [Status] -> Request -> ClientM Response performRequest :: Maybe [Status] -> Request -> ClientM Response
performRequest acceptStatus req = do performRequest acceptStatus req = do
ClientEnv m burl cookieJar' createClientRequest <- ask ClientEnv m burl cookieJar' createClientRequest <- ask
let clientRequest = createClientRequest burl req clientRequest <- liftIO $ createClientRequest burl req
request <- case cookieJar' of request <- case cookieJar' of
Nothing -> pure clientRequest Nothing -> pure clientRequest
Just cj -> liftIO $ do Just cj -> liftIO $ do
@ -179,10 +179,9 @@ performRequest acceptStatus req = do
response <- maybe (requestWithoutCookieJar m request) (requestWithCookieJar m request) cookieJar' response <- maybe (requestWithoutCookieJar m request) (requestWithCookieJar m request) cookieJar'
let status = Client.responseStatus response let status = Client.responseStatus response
status_code = statusCode status
ourResponse = clientResponseToResponse id response ourResponse = clientResponseToResponse id response
goodStatus = case acceptStatus of goodStatus = case acceptStatus of
Nothing -> status_code >= 200 && status_code < 300 Nothing -> statusIsSuccessful status
Just good -> status `elem` good Just good -> status `elem` good
unless goodStatus $ do unless goodStatus $ do
throwError $ mkFailureResponse burl req ourResponse throwError $ mkFailureResponse burl req ourResponse
@ -230,8 +229,8 @@ clientResponseToResponse f r = Response
-- | Create a @http-client@ 'Client.Request' from a @servant@ 'Request' -- | Create a @http-client@ 'Client.Request' from a @servant@ 'Request'
-- The 'Client.host', 'Client.path' and 'Client.port' fields are extracted from the 'BaseUrl' -- The 'Client.host', 'Client.path' and 'Client.port' fields are extracted from the 'BaseUrl'
-- otherwise the body, headers and query string are derived from the @servant@ 'Request' -- otherwise the body, headers and query string are derived from the @servant@ 'Request'
defaultMakeClientRequest :: BaseUrl -> Request -> Client.Request defaultMakeClientRequest :: BaseUrl -> Request -> IO Client.Request
defaultMakeClientRequest burl r = Client.defaultRequest defaultMakeClientRequest burl r = return Client.defaultRequest
{ Client.method = requestMethod r { Client.method = requestMethod r
, Client.host = fromString $ baseUrlHost burl , Client.host = fromString $ baseUrlHost burl
, Client.port = baseUrlPort burl , Client.port = baseUrlPort burl
@ -247,7 +246,7 @@ defaultMakeClientRequest burl r = Client.defaultRequest
where where
-- Content-Type and Accept are specified by requestBody and requestAccept -- Content-Type and Accept are specified by requestBody and requestAccept
headers = filter (\(h, _) -> h /= "Accept" && h /= "Content-Type") $ headers = filter (\(h, _) -> h /= "Accept" && h /= "Content-Type") $
toList $requestHeaders r toList $ requestHeaders r
acceptHdr acceptHdr
| null hs = Nothing | null hs = Nothing
@ -290,7 +289,8 @@ defaultMakeClientRequest burl r = Client.defaultRequest
Https -> True Https -> True
-- Query string builder which does not do any encoding -- Query string builder which does not do any encoding
buildQueryString = ("?" <>) . foldl' addQueryParam mempty buildQueryString [] = mempty
buildQueryString qps = "?" <> foldl' addQueryParam mempty qps
addQueryParam qs (k, v) = addQueryParam qs (k, v) =
qs <> (if BS.null qs then mempty else "&") <> urlEncode True k <> foldMap ("=" <>) v qs <> (if BS.null qs then mempty else "&") <> urlEncode True k <> foldMap ("=" <>) v

View File

@ -24,7 +24,8 @@ import Control.DeepSeq
(NFData, force) (NFData, force)
import Control.Exception import Control.Exception
(evaluate, throwIO) (evaluate, throwIO)
import Control.Monad () import Control.Monad
(unless)
import Control.Monad.Base import Control.Monad.Base
(MonadBase (..)) (MonadBase (..))
import Control.Monad.Codensity import Control.Monad.Codensity
@ -47,7 +48,7 @@ import Data.Time.Clock
(getCurrentTime) (getCurrentTime)
import GHC.Generics import GHC.Generics
import Network.HTTP.Types import Network.HTTP.Types
(Status, statusCode) (Status, statusIsSuccessful)
import qualified Network.HTTP.Client as Client import qualified Network.HTTP.Client as Client
@ -140,7 +141,7 @@ performRequest :: Maybe [Status] -> Request -> ClientM Response
performRequest acceptStatus req = do performRequest acceptStatus req = do
-- TODO: should use Client.withResponse here too -- TODO: should use Client.withResponse here too
ClientEnv m burl cookieJar' createClientRequest <- ask ClientEnv m burl cookieJar' createClientRequest <- ask
let clientRequest = createClientRequest burl req clientRequest <- liftIO $ createClientRequest burl req
request <- case cookieJar' of request <- case cookieJar' of
Nothing -> pure clientRequest Nothing -> pure clientRequest
Just cj -> liftIO $ do Just cj -> liftIO $ do
@ -163,10 +164,9 @@ performRequest acceptStatus req = do
now' <- getCurrentTime now' <- getCurrentTime
atomically $ modifyTVar' cj (fst . Client.updateCookieJar response request now') atomically $ modifyTVar' cj (fst . Client.updateCookieJar response request now')
let status = Client.responseStatus response let status = Client.responseStatus response
status_code = statusCode status
ourResponse = clientResponseToResponse id response ourResponse = clientResponseToResponse id response
goodStatus = case acceptStatus of goodStatus = case acceptStatus of
Nothing -> status_code >= 200 && status_code < 300 Nothing -> statusIsSuccessful status
Just good -> status `elem` good Just good -> status `elem` good
unless goodStatus $ do unless goodStatus $ do
throwError $ mkFailureResponse burl req ourResponse throwError $ mkFailureResponse burl req ourResponse
@ -175,17 +175,27 @@ performRequest acceptStatus req = do
-- | TODO: support UVerb ('acceptStatus' argument, like in 'performRequest' above). -- | TODO: support UVerb ('acceptStatus' argument, like in 'performRequest' above).
performWithStreamingRequest :: Request -> (StreamingResponse -> IO a) -> ClientM a performWithStreamingRequest :: Request -> (StreamingResponse -> IO a) -> ClientM a
performWithStreamingRequest req k = do performWithStreamingRequest req k = do
m <- asks manager ClientEnv m burl cookieJar' createClientRequest <- ask
burl <- asks baseUrl clientRequest <- liftIO $ createClientRequest burl req
createClientRequest <- asks makeClientRequest request <- case cookieJar' of
let request = createClientRequest burl req Nothing -> pure clientRequest
Just cj -> liftIO $ do
now <- getCurrentTime
atomically $ do
oldCookieJar <- readTVar cj
let (newRequest, newCookieJar) =
Client.insertCookiesIntoRequest
clientRequest
oldCookieJar
now
writeTVar cj newCookieJar
pure newRequest
ClientM $ lift $ lift $ Codensity $ \k1 -> ClientM $ lift $ lift $ Codensity $ \k1 ->
Client.withResponse request m $ \res -> do Client.withResponse request m $ \res -> do
let status = Client.responseStatus res let status = Client.responseStatus res
status_code = statusCode status
-- we throw FailureResponse in IO :( -- we throw FailureResponse in IO :(
unless (status_code >= 200 && status_code < 300) $ do unless (statusIsSuccessful status) $ do
b <- BSL.fromChunks <$> Client.brConsume (Client.responseBody res) b <- BSL.fromChunks <$> Client.brConsume (Client.responseBody res)
throwIO $ mkFailureResponse burl req (clientResponseToResponse (const b) res) throwIO $ mkFailureResponse burl req (clientResponseToResponse (const b) res)

View File

@ -0,0 +1,71 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -freduction-depth=100 #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
module Servant.BrokenSpec (spec) where
import Prelude ()
import Prelude.Compat
import Data.Monoid ()
import Data.Proxy
import qualified Network.HTTP.Types as HTTP
import Test.Hspec
import Servant.API
((:<|>) ((:<|>)), (:>), JSON, Verb, Get, StdMethod (GET))
import Servant.Client
import Servant.ClientTestUtils
import Servant.Server
-- * api for testing inconsistencies between client and server
type Get201 = Verb 'GET 201
type Get301 = Verb 'GET 301
type BrokenAPI =
-- the server should respond with 200, but returns 201
"get200" :> Get201 '[JSON] ()
-- the server should respond with 307, but returns 301
:<|> "get307" :> Get301 '[JSON] ()
brokenApi :: Proxy BrokenAPI
brokenApi = Proxy
brokenServer :: Application
brokenServer = serve brokenApi (pure () :<|> pure ())
type PublicAPI =
-- the client expects 200
"get200" :> Get '[JSON] ()
-- the client expects 307
:<|> "get307" :> Get307 '[JSON] ()
publicApi :: Proxy PublicAPI
publicApi = Proxy
get200Client :: ClientM ()
get307Client :: ClientM ()
get200Client :<|> get307Client = client publicApi
spec :: Spec
spec = describe "Servant.BrokenSpec" $ do
brokenSpec
brokenSpec :: Spec
brokenSpec = beforeAll (startWaiApp brokenServer) $ afterAll endWaiApp $ do
context "client returns errors for inconsistencies between client and server api" $ do
it "reports FailureResponse with wrong 2xx status code" $ \(_, baseUrl) -> do
res <- runClient get200Client baseUrl
case res of
Left (FailureResponse _ r) | responseStatusCode r == HTTP.status201 -> return ()
_ -> fail $ "expected 201 broken response, but got " <> show res
it "reports FailureResponse with wrong 3xx status code" $ \(_, baseUrl) -> do
res <- runClient get307Client baseUrl
case res of
Left (FailureResponse _ r) | responseStatusCode r == HTTP.status301 -> return ()
_ -> fail $ "expected 301 broken response, but got " <> show res

View File

@ -64,7 +64,7 @@ import Servant.API
JSON, MimeRender (mimeRender), MimeUnrender (mimeUnrender), JSON, MimeRender (mimeRender), MimeUnrender (mimeUnrender),
NoContent (NoContent), PlainText, Post, QueryFlag, QueryParam, NoContent (NoContent), PlainText, Post, QueryFlag, QueryParam,
QueryParams, Raw, ReqBody, StdMethod (GET), ToHttpApiData (..), UVerb, Union, QueryParams, Raw, ReqBody, StdMethod (GET), ToHttpApiData (..), UVerb, Union,
WithStatus (WithStatus), NamedRoutes, addHeader) Verb, WithStatus (WithStatus), NamedRoutes, addHeader)
import Servant.API.Generic ((:-)) import Servant.API.Generic ((:-))
import Servant.Client import Servant.Client
import qualified Servant.Client.Core.Auth as Auth import qualified Servant.Client.Core.Auth as Auth
@ -118,9 +118,16 @@ data OtherRoutes mode = OtherRoutes
{ something :: mode :- "something" :> Get '[JSON] [String] { something :: mode :- "something" :> Get '[JSON] [String]
} deriving Generic } deriving Generic
-- Get for HTTP 307 Temporary Redirect
type Get307 = Verb 'GET 307
type Api = type Api =
Get '[JSON] Person Get '[JSON] Person
:<|> "get" :> Get '[JSON] Person :<|> "get" :> Get '[JSON] Person
-- This endpoint returns a response with status code 307 Temporary Redirect,
-- different from the ones in the 2xx successful class, to test derivation
-- of clients' api.
:<|> "get307" :> Get307 '[PlainText] Text
:<|> "deleteEmpty" :> DeleteNoContent :<|> "deleteEmpty" :> DeleteNoContent
:<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person
:<|> "captureAll" :> CaptureAll "names" String :> Get '[JSON] [Person] :<|> "captureAll" :> CaptureAll "names" String :> Get '[JSON] [Person]
@ -153,13 +160,14 @@ type Api =
WithStatus 301 Text] WithStatus 301 Text]
:<|> "uverb-get-created" :> UVerb 'GET '[PlainText] '[WithStatus 201 Person] :<|> "uverb-get-created" :> UVerb 'GET '[PlainText] '[WithStatus 201 Person]
:<|> NamedRoutes RecordRoutes :<|> NamedRoutes RecordRoutes
:<|> "captureVerbatim" :> Capture "someString" Verbatim :> Get '[PlainText] Text
api :: Proxy Api api :: Proxy Api
api = Proxy api = Proxy
getRoot :: ClientM Person getRoot :: ClientM Person
getGet :: ClientM Person getGet :: ClientM Person
getGet307 :: ClientM Text
getDeleteEmpty :: ClientM NoContent getDeleteEmpty :: ClientM NoContent
getCapture :: String -> ClientM Person getCapture :: String -> ClientM Person
getCaptureAll :: [String] -> ClientM [Person] getCaptureAll :: [String] -> ClientM [Person]
@ -186,6 +194,7 @@ recordRoutes :: RecordRoutes (AsClientT ClientM)
getRoot getRoot
:<|> getGet :<|> getGet
:<|> getGet307
:<|> getDeleteEmpty :<|> getDeleteEmpty
:<|> getCapture :<|> getCapture
:<|> getCaptureAll :<|> getCaptureAll
@ -206,12 +215,14 @@ getRoot
:<|> EmptyClient :<|> EmptyClient
:<|> uverbGetSuccessOrRedirect :<|> uverbGetSuccessOrRedirect
:<|> uverbGetCreated :<|> uverbGetCreated
:<|> recordRoutes = client api :<|> recordRoutes
:<|> captureVerbatim = client api
server :: Application server :: Application
server = serve api ( server = serve api (
return carol return carol
:<|> return alice :<|> return alice
:<|> return "redirecting"
:<|> return NoContent :<|> return NoContent
:<|> (\ name -> return $ Person name 0) :<|> (\ name -> return $ Person name 0)
:<|> (\ names -> return (zipWith Person names [0..])) :<|> (\ names -> return (zipWith Person names [0..]))
@ -250,8 +261,11 @@ server = serve api (
{ something = pure ["foo", "bar", "pweet"] { something = pure ["foo", "bar", "pweet"]
} }
} }
:<|> pure . decodeUtf8 . unVerbatim
) )
-- * api for testing failures
type FailApi = type FailApi =
"get" :> Raw "get" :> Raw
:<|> "capture" :> Capture "name" String :> Raw :<|> "capture" :> Capture "name" String :> Raw
@ -266,7 +280,7 @@ failServer = serve failApi (
:<|> (\ _capture -> Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "application/json")] "") :<|> (\ _capture -> Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "application/json")] "")
:<|> (Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "fooooo")] "") :<|> (Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "fooooo")] "")
:<|> (Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "application/x-www-form-urlencoded"), ("X-Example1", "1"), ("X-Example2", "foo")] "") :<|> (Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "application/x-www-form-urlencoded"), ("X-Example1", "1"), ("X-Example2", "foo")] "")
) )
-- * basic auth stuff -- * basic auth stuff
@ -359,3 +373,12 @@ instance ToHttpApiData UrlEncodedByteString where
instance FromHttpApiData UrlEncodedByteString where instance FromHttpApiData UrlEncodedByteString where
parseUrlPiece = pure . UrlEncodedByteString . HTTP.urlDecode True . encodeUtf8 parseUrlPiece = pure . UrlEncodedByteString . HTTP.urlDecode True . encodeUtf8
newtype Verbatim = Verbatim { unVerbatim :: ByteString }
instance ToHttpApiData Verbatim where
toEncodedUrlPiece = byteString . unVerbatim
toUrlPiece = decodeUtf8 . unVerbatim
instance FromHttpApiData Verbatim where
parseUrlPiece = pure . Verbatim . encodeUtf8

View File

@ -38,14 +38,14 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
context "client returns errors appropriately" $ do context "client returns errors appropriately" $ do
it "reports FailureResponse" $ \(_, baseUrl) -> do it "reports FailureResponse" $ \(_, baseUrl) -> do
let (_ :<|> _ :<|> getDeleteEmpty :<|> _) = client api let (_ :<|> _ :<|> _ :<|> getDeleteEmpty :<|> _) = client api
Left res <- runClient getDeleteEmpty baseUrl Left res <- runClient getDeleteEmpty baseUrl
case res of case res of
FailureResponse _ r | responseStatusCode r == HTTP.status404 -> return () FailureResponse _ r | responseStatusCode r == HTTP.status404 -> return ()
_ -> fail $ "expected 404 response, but got " <> show res _ -> fail $ "expected 404 response, but got " <> show res
it "reports DecodeFailure" $ \(_, baseUrl) -> do it "reports DecodeFailure" $ \(_, baseUrl) -> do
let (_ :<|> _ :<|> _ :<|> getCapture :<|> _) = client api let (_ :<|> _ :<|> _ :<|> _ :<|> getCapture :<|> _) = client api
Left res <- runClient (getCapture "foo") baseUrl Left res <- runClient (getCapture "foo") baseUrl
case res of case res of
DecodeFailure _ _ -> return () DecodeFailure _ _ -> return ()
@ -72,7 +72,7 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
_ -> fail $ "expected UnsupportedContentType, but got " <> show res _ -> fail $ "expected UnsupportedContentType, but got " <> show res
it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do
let (_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api let (_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api
Left res <- runClient (getBody alice) baseUrl Left res <- runClient (getBody alice) baseUrl
case res of case res of
InvalidContentTypeHeader _ -> return () InvalidContentTypeHeader _ -> return ()

View File

@ -36,6 +36,8 @@ import Data.Maybe
import Data.Monoid () import Data.Monoid ()
import Data.Text import Data.Text
(Text) (Text)
import Data.Text.Encoding
(encodeUtf8)
import qualified Network.HTTP.Client as C import qualified Network.HTTP.Client as C
import qualified Network.HTTP.Types as HTTP import qualified Network.HTTP.Types as HTTP
import Test.Hspec import Test.Hspec
@ -59,11 +61,15 @@ spec = describe "Servant.SuccessSpec" $ do
successSpec :: Spec successSpec :: Spec
successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
it "Servant.API.Get root" $ \(_, baseUrl) -> do describe "Servant.API.Get" $ do
left show <$> runClient getRoot baseUrl `shouldReturn` Right carol it "get root endpoint" $ \(_, baseUrl) -> do
left show <$> runClient getRoot baseUrl `shouldReturn` Right carol
it "Servant.API.Get" $ \(_, baseUrl) -> do it "get simple endpoint" $ \(_, baseUrl) -> do
left show <$> runClient getGet baseUrl `shouldReturn` Right alice left show <$> runClient getGet baseUrl `shouldReturn` Right alice
it "get redirection endpoint" $ \(_, baseUrl) -> do
left show <$> runClient getGet307 baseUrl `shouldReturn` Right "redirecting"
describe "Servant.API.Delete" $ do describe "Servant.API.Delete" $ do
it "allows empty content type" $ \(_, baseUrl) -> do it "allows empty content type" $ \(_, baseUrl) -> do
@ -111,6 +117,7 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
it "Servant.API.Fragment" $ \(_, baseUrl) -> do it "Servant.API.Fragment" $ \(_, baseUrl) -> do
left id <$> runClient getFragment baseUrl `shouldReturn` Right alice left id <$> runClient getFragment baseUrl `shouldReturn` Right alice
it "Servant.API.Raw on success" $ \(_, baseUrl) -> do it "Servant.API.Raw on success" $ \(_, baseUrl) -> do
res <- runClient (getRawSuccess HTTP.methodGet) baseUrl res <- runClient (getRawSuccess HTTP.methodGet) baseUrl
case res of case res of
@ -155,8 +162,9 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
mgr <- C.newManager C.defaultManagerSettings mgr <- C.newManager C.defaultManagerSettings
-- In proper situation, extra headers should probably be visible in API type. -- In proper situation, extra headers should probably be visible in API type.
-- However, testing for response timeout is difficult, so we test with something which is easy to observe -- However, testing for response timeout is difficult, so we test with something which is easy to observe
let createClientRequest url r = (defaultMakeClientRequest url r) { C.requestHeaders = [("X-Added-Header", "XXX")] } let createClientRequest url r = fmap (\req -> req { C.requestHeaders = [("X-Added-Header", "XXX")] })
let clientEnv = (mkClientEnv mgr baseUrl) { makeClientRequest = createClientRequest } (defaultMakeClientRequest url r)
clientEnv = (mkClientEnv mgr baseUrl) { makeClientRequest = createClientRequest }
res <- runClientM (getRawSuccessPassHeaders HTTP.methodGet) clientEnv res <- runClientM (getRawSuccessPassHeaders HTTP.methodGet) clientEnv
case res of case res of
Left e -> Left e ->
@ -191,3 +199,10 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
case eitherResponse of case eitherResponse of
Left clientError -> fail $ show clientError Left clientError -> fail $ show clientError
Right response -> matchUnion response `shouldBe` Just (WithStatus @201 carol) Right response -> matchUnion response `shouldBe` Just (WithStatus @201 carol)
it "encodes URL pieces following ToHttpApiData instance" $ \(_, baseUrl) -> do
let textOrig = "*"
eitherResponse <- runClient (captureVerbatim $ Verbatim $ encodeUtf8 textOrig) baseUrl
case eitherResponse of
Left clientError -> fail $ show clientError
Right textBack -> textBack `shouldBe` textOrig

View File

@ -1,4 +1,4 @@
cabal-version: >=1.10 cabal-version: 2.2
name: servant-conduit name: servant-conduit
version: 0.15.1 version: 0.15.1
@ -23,7 +23,7 @@ extra-source-files:
source-repository head source-repository head
type: git type: git
location: http://github.com/haskell-servant/servant-conduit.git location: http://github.com/haskell-servant/servant.git
library library
exposed-modules: Servant.Conduit exposed-modules: Servant.Conduit
@ -31,9 +31,9 @@ library
base >=4.9 && <5 base >=4.9 && <5
, bytestring >=0.10.8.1 && <0.12 , bytestring >=0.10.8.1 && <0.12
, conduit >=1.3.1 && <1.4 , conduit >=1.3.1 && <1.4
, mtl >=2.2.2 && <2.3 , mtl ^>=2.2.2 || ^>=2.3.1
, resourcet >=1.2.2 && <1.3 , resourcet >=1.2.2 && <1.4
, servant >=0.15 && <0.19 , servant >=0.15 && <0.20
, unliftio-core >=0.1.2.0 && <0.3 , unliftio-core >=0.1.2.0 && <0.3
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010
@ -54,8 +54,8 @@ test-suite example
, resourcet , resourcet
, servant , servant
, servant-conduit , servant-conduit
, servant-server >=0.15 && <0.19 , servant-server >=0.15 && <0.20
, servant-client >=0.15 && <0.19 , servant-client >=0.15 && <0.20
, wai >=3.2.1.2 && <3.3 , wai >=3.2.1.2 && <3.3
, warp >=3.2.25 && <3.4 , warp >=3.2.25 && <3.4
, http-client , http-client

View File

@ -1,6 +1,15 @@
[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-docs/CHANGELOG.md) [The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-docs/CHANGELOG.md)
[Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md) [Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)
0.12
----
### Significant changes
- Generate sample cURL requests
([#1401](https://github.com/haskell-servant/servant/pull/1401/files)).
Breaking change: requires sample header values to be supplied with `headers`.
0.11.9 0.11.9
------ ------

View File

@ -530,6 +530,24 @@
``` ```
## GET /resource
### Response:
- Status code 200
- Headers: []
- Supported content types are:
- `application/json;charset=utf-8`
- `application/json`
- Example (`application/json;charset=utf-8`, `application/json`):
```javascript
```
## GET /streaming ## GET /streaming
### Request: ### Request:

View File

@ -1,6 +1,6 @@
cabal-version: >=1.10 cabal-version: 2.2
name: servant-docs name: servant-docs
version: 0.11.9 version: 0.12
synopsis: generate API docs for your servant webservice synopsis: generate API docs for your servant webservice
category: Servant, Web category: Servant, Web
@ -41,25 +41,25 @@ library
-- --
-- note: mtl lower bound is so low because of GHC-7.8 -- note: mtl lower bound is so low because of GHC-7.8
build-depends: build-depends:
base >= 4.9 && < 4.16 base >= 4.9 && < 4.18
, bytestring >= 0.10.8.1 && < 0.12 , bytestring >= 0.10.8.1 && < 0.12
, text >= 1.2.3.0 && < 1.3 , text >= 1.2.3.0 && < 2.1
-- Servant dependencies -- Servant dependencies
build-depends: build-depends:
servant >= 0.18 && <0.19 servant >= 0.18 && <0.20
-- Other dependencies: Lower bound around what is in the latest Stackage LTS. -- Other dependencies: Lower bound around what is in the latest Stackage LTS.
-- Here can be exceptions if we really need features from the newer versions. -- Here can be exceptions if we really need features from the newer versions.
build-depends: build-depends:
aeson >= 1.4.1.0 && < 1.6 aeson >= 1.4.1.0 && < 3
, aeson-pretty >= 0.8.5 && < 0.9 , aeson-pretty >= 0.8.5 && < 0.9
, base-compat >= 0.10.5 && < 0.12 , base-compat >= 0.10.5 && < 0.13
, case-insensitive >= 1.2.0.11 && < 1.3 , case-insensitive >= 1.2.0.11 && < 1.3
, hashable >= 1.2.7.0 && < 1.4 , hashable >= 1.2.7.0 && < 1.5
, http-media >= 0.7.1.3 && < 0.9 , http-media >= 0.7.1.3 && < 0.9
, http-types >= 0.12.2 && < 0.13 , http-types >= 0.12.2 && < 0.13
, lens >= 4.17 && < 5.1 , lens >= 4.17 && < 5.3
, string-conversions >= 0.4.0.1 && < 0.5 , string-conversions >= 0.4.0.1 && < 0.5
, universe-base >= 1.1.1 && < 1.2 , universe-base >= 1.1.1 && < 1.2
, unordered-containers >= 0.2.9.0 && < 0.3 , unordered-containers >= 0.2.9.0 && < 0.3

View File

@ -62,6 +62,7 @@ import GHC.TypeLits
import Servant.API import Servant.API
import Servant.API.ContentTypes import Servant.API.ContentTypes
import Servant.API.TypeLevel import Servant.API.TypeLevel
import Servant.API.Generic
import qualified Data.Universe.Helpers as U import qualified Data.Universe.Helpers as U
@ -446,7 +447,7 @@ docsWith opts intros (ExtraInfo endpoints) p =
& apiEndpoints %~ HM.unionWith (flip combineAction) endpoints & apiEndpoints %~ HM.unionWith (flip combineAction) endpoints
-- | Generate the docs for a given API that implements 'HasDocs' with with any -- | Generate the docs for a given API that implements 'HasDocs' with any
-- number of introduction(s) -- number of introduction(s)
docsWithIntros :: HasDocs api => [DocIntro] -> Proxy api -> API docsWithIntros :: HasDocs api => [DocIntro] -> Proxy api -> API
docsWithIntros intros = docsWith defaultDocOptions intros mempty docsWithIntros intros = docsWith defaultDocOptions intros mempty
@ -1143,6 +1144,9 @@ instance HasDocs api => HasDocs (Vault :> api) where
instance HasDocs api => HasDocs (WithNamedContext name context api) where instance HasDocs api => HasDocs (WithNamedContext name context api) where
docsFor Proxy = docsFor (Proxy :: Proxy api) docsFor Proxy = docsFor (Proxy :: Proxy api)
instance HasDocs api => HasDocs (WithResource res :> api) where
docsFor Proxy = docsFor (Proxy :: Proxy api)
instance (ToAuthInfo (BasicAuth realm usr), HasDocs api) => HasDocs (BasicAuth realm usr :> api) where instance (ToAuthInfo (BasicAuth realm usr), HasDocs api) => HasDocs (BasicAuth realm usr :> api) where
docsFor Proxy (endpoint, action) = docsFor Proxy (endpoint, action) =
docsFor (Proxy :: Proxy api) (endpoint, action') docsFor (Proxy :: Proxy api) (endpoint, action')
@ -1150,6 +1154,9 @@ instance (ToAuthInfo (BasicAuth realm usr), HasDocs api) => HasDocs (BasicAuth r
authProxy = Proxy :: Proxy (BasicAuth realm usr) authProxy = Proxy :: Proxy (BasicAuth realm usr)
action' = over authInfo (|> toAuthInfo authProxy) action action' = over authInfo (|> toAuthInfo authProxy) action
instance HasDocs (ToServantApi api) => HasDocs (NamedRoutes api) where
docsFor Proxy = docsFor (Proxy :: Proxy (ToServantApi api))
-- ToSample instances for simple types -- ToSample instances for simple types
instance ToSample NoContent instance ToSample NoContent
instance ToSample Bool instance ToSample Bool

View File

@ -1,4 +1,4 @@
cabal-version: >=1.10 cabal-version: 2.2
name: servant-foreign name: servant-foreign
version: 0.15.4 version: 0.15.4
@ -41,18 +41,18 @@ library
-- --
-- note: mtl lower bound is so low because of GHC-7.8 -- note: mtl lower bound is so low because of GHC-7.8
build-depends: build-depends:
base >= 4.9 && < 4.16 base >= 4.9 && < 4.18
, text >= 1.2.3.0 && < 1.3 , text >= 1.2.3.0 && < 2.1
-- Servant dependencies -- Servant dependencies
build-depends: build-depends:
servant >=0.18 && <0.19 servant >=0.18 && <0.20
-- Other dependencies: Lower bound around what is in the latest Stackage LTS. -- Other dependencies: Lower bound around what is in the latest Stackage LTS.
-- Here can be exceptions if we really need features from the newer versions. -- Here can be exceptions if we really need features from the newer versions.
build-depends: build-depends:
base-compat >= 0.10.5 && < 0.12 base-compat >= 0.10.5 && < 0.13
, lens >= 4.17 && < 5.1 , lens >= 4.17 && < 5.3
, http-types >= 0.12.2 && < 0.13 , http-types >= 0.12.2 && < 0.13
hs-source-dirs: src hs-source-dirs: src
@ -74,7 +74,7 @@ test-suite spec
-- Additional dependencies -- Additional dependencies
build-depends: build-depends:
hspec >= 2.6.0 && <2.9 hspec >= 2.6.0 && <2.10
build-tool-depends: build-tool-depends:
hspec-discover:hspec-discover >=2.6.0 && <2.9 hspec-discover:hspec-discover >=2.6.0 && <2.10
default-language: Haskell2010 default-language: Haskell2010

View File

@ -487,6 +487,13 @@ instance HasForeign lang ftype api =>
foreignFor lang ftype Proxy = foreignFor lang ftype (Proxy :: Proxy api) foreignFor lang ftype Proxy = foreignFor lang ftype (Proxy :: Proxy api)
instance HasForeign lang ftype api =>
HasForeign lang ftype (WithResource res :> api) where
type Foreign ftype (WithResource res :> api) = Foreign ftype api
foreignFor lang ftype Proxy = foreignFor lang ftype (Proxy :: Proxy api)
instance HasForeign lang ftype api instance HasForeign lang ftype api
=> HasForeign lang ftype (HttpVersion :> api) where => HasForeign lang ftype (HttpVersion :> api) where
type Foreign ftype (HttpVersion :> api) = Foreign ftype api type Foreign ftype (HttpVersion :> api) = Foreign ftype api

View File

@ -1,6 +1,16 @@
[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-http-streams/CHANGELOG.md) [The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-http-streams/CHANGELOG.md)
[Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md) [Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)
0.18.4
------
### Significant changes
- *servant-client* / *servant-client-core* / *servant-http-streams*:
Fix erroneous behavior, where only 2XX status codes would be considered
successful, irrelevant of the status parameter specified by the verb
combinator. ([#1469](https://github.com/haskell-servant/servant/pull/1469))
0.18.3 0.18.3
------ ------

View File

@ -1,6 +1,6 @@
cabal-version: >=1.10 cabal-version: 2.2
name: servant-http-streams name: servant-http-streams
version: 0.18.3 version: 0.18.4
synopsis: Automatic derivation of querying functions for servant synopsis: Automatic derivation of querying functions for servant
category: Servant, Web category: Servant, Web
@ -38,14 +38,14 @@ library
-- Bundled with GHC: Lower bound to not force re-installs -- Bundled with GHC: Lower bound to not force re-installs
-- text and mtl are bundled starting with GHC-8.4 -- text and mtl are bundled starting with GHC-8.4
build-depends: build-depends:
base >= 4.9 && < 4.16 base >= 4.9 && < 4.18
, bytestring >= 0.10.8.1 && < 0.12 , bytestring >= 0.10.8.1 && < 0.12
, containers >= 0.5.7.1 && < 0.7 , containers >= 0.5.7.1 && < 0.7
, deepseq >= 1.4.2.0 && < 1.5 , deepseq >= 1.4.2.0 && < 1.5
, mtl >= 2.2.2 && < 2.3 , mtl ^>= 2.2.2 || ^>= 2.3.1
, text >= 1.2.3.0 && < 1.3 , text >= 1.2.3.0 && < 2.1
, time >= 1.6.0.1 && < 1.10 , time >= 1.6.0.1 && < 1.13
, transformers >= 0.5.2.0 && < 0.6 , transformers >= 0.5.2.0 && < 0.7
if !impl(ghc >= 8.2) if !impl(ghc >= 8.2)
build-depends: build-depends:
@ -54,25 +54,25 @@ library
-- Servant dependencies. -- Servant dependencies.
-- Strict dependency on `servant-client-core` as we re-export things. -- Strict dependency on `servant-client-core` as we re-export things.
build-depends: build-depends:
servant == 0.18.* servant >= 0.18 && < 0.20
, servant-client-core >= 0.18.3 && <0.18.4 , servant-client-core >= 0.18.3 && <0.20
-- Other dependencies: Lower bound around what is in the latest Stackage LTS. -- Other dependencies: Lower bound around what is in the latest Stackage LTS.
-- Here can be exceptions if we really need features from the newer versions. -- Here can be exceptions if we really need features from the newer versions.
build-depends: build-depends:
base-compat >= 0.10.5 && < 0.12 base-compat >= 0.10.5 && < 0.13
, case-insensitive , case-insensitive
, http-streams >= 0.8.6.1 && < 0.9 , http-streams >= 0.8.6.1 && < 0.9
, http-media >= 0.7.1.3 && < 0.9 , http-media >= 0.7.1.3 && < 0.9
, io-streams >= 1.5.0.1 && < 1.6 , io-streams >= 1.5.0.1 && < 1.6
, http-types >= 0.12.2 && < 0.13 , http-types >= 0.12.2 && < 0.13
, http-common >= 0.8.2.0 && < 0.8.3 , http-common >= 0.8.2.0 && < 0.9
, exceptions >= 0.10.0 && < 0.11 , exceptions >= 0.10.0 && < 0.11
, kan-extensions >= 5.2 && < 5.3 , kan-extensions >= 5.2 && < 5.3
, monad-control >= 1.0.2.3 && < 1.1 , monad-control >= 1.0.2.3 && < 1.1
, semigroupoids >= 5.3.1 && < 5.4 , semigroupoids >= 5.3.1 && < 5.4
, transformers-base >= 0.4.5.2 && < 0.5 , transformers-base >= 0.4.5.2 && < 0.5
, transformers-compat >= 0.6.2 && < 0.7 , transformers-compat >= 0.6.2 && < 0.8
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010
@ -112,16 +112,16 @@ test-suite spec
-- Additional dependencies -- Additional dependencies
build-depends: build-depends:
entropy >= 0.4.1.3 && < 0.5 entropy >= 0.4.1.3 && < 0.5
, hspec >= 2.6.0 && < 2.9 , hspec >= 2.6.0 && < 2.10
, HUnit >= 1.6.0.0 && < 1.7 , HUnit >= 1.6.0.0 && < 1.7
, network >= 2.8.0.0 && < 3.2 , network >= 2.8.0.0 && < 3.2
, QuickCheck >= 2.12.6.1 && < 2.15 , QuickCheck >= 2.12.6.1 && < 2.15
, servant == 0.18.* , servant == 0.19.*
, servant-server == 0.18.* , servant-server == 0.19.*
, tdigest >= 0.2 && < 0.3 , tdigest >= 0.2 && < 0.3
build-tool-depends: build-tool-depends:
hspec-discover:hspec-discover >= 2.6.0 && < 2.9 hspec-discover:hspec-discover >= 2.6.0 && < 2.10
test-suite readme test-suite readme
type: exitcode-stdio-1.0 type: exitcode-stdio-1.0

View File

@ -57,7 +57,7 @@ import GHC.Generics
import Network.HTTP.Media import Network.HTTP.Media
(renderHeader) (renderHeader)
import Network.HTTP.Types import Network.HTTP.Types
(Status (..), hContentType, http11, renderQuery) (Status (..), hContentType, http11, renderQuery, statusIsSuccessful)
import Servant.Client.Core import Servant.Client.Core
import qualified Network.Http.Client as Client import qualified Network.Http.Client as Client
@ -160,12 +160,12 @@ performRequest acceptStatus req = do
x <- ClientM $ lift $ lift $ Codensity $ \k -> do x <- ClientM $ lift $ lift $ Codensity $ \k -> do
Client.sendRequest conn req' body Client.sendRequest conn req' body
Client.receiveResponse conn $ \res' body' -> do Client.receiveResponse conn $ \res' body' -> do
let sc = Client.getStatusCode res' let status = toEnum $ Client.getStatusCode res'
lbs <- BSL.fromChunks <$> Streams.toList body' lbs <- BSL.fromChunks <$> Streams.toList body'
let res'' = clientResponseToResponse res' lbs let res'' = clientResponseToResponse res' lbs
goodStatus = case acceptStatus of goodStatus = case acceptStatus of
Nothing -> sc >= 200 && sc < 300 Nothing -> statusIsSuccessful status
Just good -> sc `elem` (statusCode <$> good) Just good -> status `elem` good
if goodStatus if goodStatus
then k (Right res'') then k (Right res'')
else k (Left (mkFailureResponse burl req res'')) else k (Left (mkFailureResponse burl req res''))
@ -180,8 +180,8 @@ performWithStreamingRequest req k = do
Client.sendRequest conn req' body Client.sendRequest conn req' body
Client.receiveResponseRaw conn $ \res' body' -> do Client.receiveResponseRaw conn $ \res' body' -> do
-- check status code -- check status code
let sc = Client.getStatusCode res' let status = toEnum $ Client.getStatusCode res'
unless (sc >= 200 && sc < 300) $ do unless (statusIsSuccessful status) $ do
lbs <- BSL.fromChunks <$> Streams.toList body' lbs <- BSL.fromChunks <$> Streams.toList body'
throwIO $ mkFailureResponse burl req (clientResponseToResponse res' lbs) throwIO $ mkFailureResponse burl req (clientResponseToResponse res' lbs)

View File

@ -1,4 +1,4 @@
cabal-version: >=1.10 cabal-version: 2.2
name: servant-machines name: servant-machines
version: 0.15.1 version: 0.15.1
@ -23,7 +23,7 @@ extra-source-files:
source-repository head source-repository head
type: git type: git
location: http://github.com/haskell-servant/servant-machines.git location: http://github.com/haskell-servant/servant.git
library library
exposed-modules: Servant.Machines exposed-modules: Servant.Machines
@ -31,8 +31,8 @@ library
base >=4.9 && <5 base >=4.9 && <5
, bytestring >=0.10.8.1 && <0.12 , bytestring >=0.10.8.1 && <0.12
, machines >=0.6.4 && <0.8 , machines >=0.6.4 && <0.8
, mtl >=2.2.2 && <2.3 , mtl ^>=2.2.2 || ^>=2.3.1
, servant >=0.15 && <0.19 , servant >=0.15 && <0.20
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -Wall ghc-options: -Wall
@ -51,8 +51,8 @@ test-suite example
, servant , servant
, machines , machines
, servant-machines , servant-machines
, servant-server >=0.15 && <0.19 , servant-server >=0.15 && <0.20
, servant-client >=0.15 && <0.19 , servant-client >=0.15 && <0.20
, wai >=3.2.1.2 && <3.3 , wai >=3.2.1.2 && <3.3
, warp >=3.2.25 && <3.4 , warp >=3.2.25 && <3.4
, http-client , http-client

View File

@ -1,4 +1,4 @@
cabal-version: >=1.10 cabal-version: 2.2
name: servant-pipes name: servant-pipes
version: 0.15.3 version: 0.15.3
@ -23,7 +23,7 @@ extra-source-files:
source-repository head source-repository head
type: git type: git
location: http://github.com/haskell-servant/servant-pipes.git location: http://github.com/haskell-servant/servant.git
library library
exposed-modules: Servant.Pipes exposed-modules: Servant.Pipes
@ -32,9 +32,9 @@ library
, bytestring >=0.10.8.1 && <0.12 , bytestring >=0.10.8.1 && <0.12
, pipes >=4.3.9 && <4.4 , pipes >=4.3.9 && <4.4
, pipes-safe >=2.3.1 && <2.4 , pipes-safe >=2.3.1 && <2.4
, mtl >=2.2.2 && <2.3 , mtl ^>=2.2.2 || ^>=2.3.1
, monad-control >=1.0.2.3 && <1.1 , monad-control >=1.0.2.3 && <1.1
, servant >=0.15 && <0.19 , servant >=0.15 && <0.20
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -Wall ghc-options: -Wall
@ -51,12 +51,12 @@ test-suite example
, bytestring , bytestring
, http-media , http-media
, servant , servant
, pipes , pipes
, pipes-safe , pipes-safe
, servant-pipes , servant-pipes
, pipes-bytestring >=2.1.6 && <2.2 , pipes-bytestring >=2.1.6 && <2.2
, servant-server >=0.15 && <0.19 , servant-server >=0.15 && <0.20
, servant-client >=0.15 && <0.19 , servant-client >=0.15 && <0.20
, wai >=3.2.1.2 && <3.3 , wai >=3.2.1.2 && <3.3
, warp >=3.2.25 && <3.4 , warp >=3.2.25 && <3.4
, http-client , http-client

View File

@ -1,6 +1,36 @@
[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-server/CHANGELOG.md) [The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-server/CHANGELOG.md)
[Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md) [Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)
Package versions follow the [Package Versioning Policy](https://pvp.haskell.org/): in A.B.C, bumps to either A or B represent major versions.
0.19.2
------
Compatibility with GHC 9.4, see [PR #1592](https://github.com/haskell-servant/servant/pull/1592).
0.19.1
------
- Add `MonadFail` instance for `Handler` wrt [#1545](https://github.com/haskell-servant/servant/issues/1545)
- Support GHC 9.2 [#1525](https://github.com/haskell-servant/servant/issues/1525)
- Add capture hints in `Router` type for debug and display purposes [PR #1556] (https://github.com/haskell-servant/servant/pull/1556)
0.19
----
### Significant changes
- Drop support for GHC < 8.6.
- Support GHC 9.0 (GHC 9.2 should work as well, but isn't fully tested yet).
- Support Aeson 2 ([#1475](https://github.com/haskell-servant/servant/pull/1475)),
which fixes a [DOS vulnerability](https://github.com/haskell/aeson/issues/864)
related to hash collisions.
- Add `NamedRoutes` combinator, making support for records first-class in Servant
([#1388](https://github.com/haskell-servant/servant/pull/1388)).
- Add custom type errors for partially applied combinators
([#1289](https://github.com/haskell-servant/servant/pull/1289),
[#1486](https://github.com/haskell-servant/servant/pull/1486)).
0.18.3 0.18.3
------ ------

View File

@ -18,7 +18,6 @@ import Network.Wai.Handler.Warp
import Servant import Servant
import Servant.Server.Generic () import Servant.Server.Generic ()
import Servant.API.Generic
-- * Example -- * Example

View File

@ -1,6 +1,6 @@
cabal-version: >=1.10 cabal-version: 2.2
name: servant-server name: servant-server
version: 0.18.3 version: 0.19.2
synopsis: A family of combinators for defining webservices APIs and serving them synopsis: A family of combinators for defining webservices APIs and serving them
category: Servant, Web category: Servant, Web
@ -23,7 +23,7 @@ author: Servant Contributors
maintainer: haskell-servant-maintainers@googlegroups.com maintainer: haskell-servant-maintainers@googlegroups.com
copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors
build-type: Simple build-type: Simple
tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1 tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.4 || ==9.4.3
extra-source-files: extra-source-files:
CHANGELOG.md CHANGELOG.md
@ -60,25 +60,25 @@ library
-- Bundled with GHC: Lower bound to not force re-installs -- Bundled with GHC: Lower bound to not force re-installs
-- text and mtl are bundled starting with GHC-8.4 -- text and mtl are bundled starting with GHC-8.4
build-depends: build-depends:
base >= 4.9 && < 4.16 base >= 4.9 && < 4.18
, bytestring >= 0.10.8.1 && < 0.12 , bytestring >= 0.10.8.1 && < 0.12
, constraints >= 0.2 && < 0.14 , constraints >= 0.2 && < 0.14
, containers >= 0.5.7.1 && < 0.7 , containers >= 0.5.7.1 && < 0.7
, mtl >= 2.2.2 && < 2.3 , mtl ^>= 2.2.2 || ^>= 2.3.1
, text >= 1.2.3.0 && < 1.3 , text >= 1.2.3.0 && < 2.1
, transformers >= 0.5.2.0 && < 0.6 , transformers >= 0.5.2.0 && < 0.7
, filepath >= 1.4.1.1 && < 1.5 , filepath >= 1.4.1.1 && < 1.5
-- Servant dependencies -- Servant dependencies
-- strict dependency as we re-export 'servant' things. -- strict dependency as we re-export 'servant' things.
build-depends: build-depends:
servant >= 0.18.3 && < 0.18.4 servant >= 0.19 && < 0.20
, http-api-data >= 0.4.1 && < 0.4.4 , http-api-data >= 0.4.1 && < 0.5.1
-- Other dependencies: Lower bound around what is in the latest Stackage LTS. -- Other dependencies: Lower bound around what is in the latest Stackage LTS.
-- Here can be exceptions if we really need features from the newer versions. -- Here can be exceptions if we really need features from the newer versions.
build-depends: build-depends:
base-compat >= 0.10.5 && < 0.12 base-compat >= 0.10.5 && < 0.13
, base64-bytestring >= 1.0.0.1 && < 1.3 , base64-bytestring >= 1.0.0.1 && < 1.3
, exceptions >= 0.10.0 && < 0.11 , exceptions >= 0.10.0 && < 0.11
, http-media >= 0.7.1.3 && < 0.9 , http-media >= 0.7.1.3 && < 0.9
@ -88,10 +88,10 @@ library
, network >= 2.8 && < 3.2 , network >= 2.8 && < 3.2
, sop-core >= 0.4.0.0 && < 0.6 , sop-core >= 0.4.0.0 && < 0.6
, string-conversions >= 0.4.0.1 && < 0.5 , string-conversions >= 0.4.0.1 && < 0.5
, resourcet >= 1.2.2 && < 1.3 , resourcet >= 1.2.2 && < 1.4
, tagged >= 0.8.6 && < 0.9 , tagged >= 0.8.6 && < 0.9
, transformers-base >= 0.4.5.2 && < 0.5 , transformers-base >= 0.4.5.2 && < 0.5
, wai >= 3.2.1.2 && < 3.3 , wai >= 3.2.2.1 && < 3.3
, wai-app-static >= 3.1.6.2 && < 3.2 , wai-app-static >= 3.1.6.2 && < 3.2
, word8 >= 0.1.3 && < 0.2 , word8 >= 0.1.3 && < 0.2
@ -114,7 +114,7 @@ executable greet
, text , text
build-depends: build-depends:
aeson >= 1.4.1.0 && < 1.6 aeson >= 1.4.1.0 && < 3
, warp >= 3.2.25 && < 3.4 , warp >= 3.2.25 && < 3.4
test-suite spec test-suite spec
@ -157,9 +157,9 @@ test-suite spec
-- Additional dependencies -- Additional dependencies
build-depends: build-depends:
aeson >= 1.4.1.0 && < 1.6 aeson >= 1.4.1.0 && < 3
, directory >= 1.3.0.0 && < 1.4 , directory >= 1.3.0.0 && < 1.4
, hspec >= 2.6.0 && < 2.9 , hspec >= 2.6.0 && < 2.10
, hspec-wai >= 0.10.1 && < 0.12 , hspec-wai >= 0.10.1 && < 0.12
, QuickCheck >= 2.12.6.1 && < 2.15 , QuickCheck >= 2.12.6.1 && < 2.15
, should-not-typecheck >= 2.1.0 && < 2.2 , should-not-typecheck >= 2.1.0 && < 2.2
@ -167,4 +167,4 @@ test-suite spec
, wai-extra >= 3.0.24.3 && < 3.2 , wai-extra >= 3.0.24.3 && < 3.2
build-tool-depends: build-tool-depends:
hspec-discover:hspec-discover >= 2.6.0 && <2.9 hspec-discover:hspec-discover >= 2.6.0 && <2.10

View File

@ -235,7 +235,7 @@ hoistServer p = hoistServerWithContext p (Proxy :: Proxy '[])
-- > │ └─ e/ -- > │ └─ e/
-- > │ └─• -- > │ └─•
-- > ├─ b/ -- > ├─ b/
-- > │ └─ <capture>/ -- > │ └─ <x::Int>/
-- > │ ├─• -- > │ ├─•
-- > │ ┆ -- > │ ┆
-- > │ └─• -- > │ └─•
@ -252,7 +252,8 @@ hoistServer p = hoistServerWithContext p (Proxy :: Proxy '[])
-- --
-- [@─•@] Leaves reflect endpoints. -- [@─•@] Leaves reflect endpoints.
-- --
-- [@\<capture\>/@] This is a delayed capture of a path component. -- [@\<x::Int\>/@] This is a delayed capture of a single
-- path component named @x@, of expected type @Int@.
-- --
-- [@\<raw\>@] This is a part of the API we do not know anything about. -- [@\<raw\>@] This is a part of the API we do not know anything about.
-- --

View File

@ -1,5 +1,6 @@
{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
@ -44,7 +45,7 @@ type family AuthServerData a :: *
-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE -- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE
newtype AuthHandler r usr = AuthHandler newtype AuthHandler r usr = AuthHandler
{ unAuthHandler :: r -> Handler usr } { unAuthHandler :: r -> Handler usr }
deriving (Generic, Typeable) deriving (Functor, Generic, Typeable)
-- | NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE -- | NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE
mkAuthHandler :: (r -> Handler usr) -> AuthHandler r usr mkAuthHandler :: (r -> Handler usr) -> AuthHandler r usr

View File

@ -1,5 +1,6 @@
{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
@ -34,14 +35,15 @@ module Servant.Server.Internal
import Control.Monad import Control.Monad
(join, when) (join, when)
import Control.Monad.Trans import Control.Monad.Trans
(liftIO) (liftIO, lift)
import Control.Monad.Trans.Resource import Control.Monad.Trans.Resource
(runResourceT) (runResourceT, ReleaseKey)
import Data.Acquire
import qualified Data.ByteString as B import qualified Data.ByteString as B
import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.Builder as BB
import qualified Data.ByteString.Char8 as BC8 import qualified Data.ByteString.Char8 as BC8
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy as BL
import Data.Constraint (Dict(..)) import Data.Constraint (Constraint, Dict(..))
import Data.Either import Data.Either
(partitionEithers) (partitionEithers)
import Data.Maybe import Data.Maybe
@ -56,7 +58,7 @@ import qualified Data.Text as T
import Data.Typeable import Data.Typeable
import GHC.Generics import GHC.Generics
import GHC.TypeLits import GHC.TypeLits
(KnownNat, KnownSymbol, natVal, symbolVal) (KnownNat, KnownSymbol, TypeError, symbolVal)
import qualified Network.HTTP.Media as NHM import qualified Network.HTTP.Media as NHM
import Network.HTTP.Types hiding import Network.HTTP.Types hiding
(Header, ResponseHeaders) (Header, ResponseHeaders)
@ -76,7 +78,7 @@ import Servant.API
QueryParam', QueryParams, Raw, ReflectMethod (reflectMethod), QueryParam', QueryParams, Raw, ReflectMethod (reflectMethod),
RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO, RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO,
Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb, Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb,
WithNamedContext, NamedRoutes) WithNamedContext, WithResource, NamedRoutes)
import Servant.API.Generic (GenericMode(..), ToServant, ToServantApi, GServantProduct, toServant, fromServant) import Servant.API.Generic (GenericMode(..), ToServant, ToServantApi, GServantProduct, toServant, fromServant)
import Servant.API.ContentTypes import Servant.API.ContentTypes
(AcceptHeader (..), AllCTRender (..), AllCTUnrender (..), (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),
@ -87,10 +89,15 @@ import Servant.API.Modifiers
unfoldRequestArgument) unfoldRequestArgument)
import Servant.API.ResponseHeaders import Servant.API.ResponseHeaders
(GetHeaders, Headers, getHeaders, getResponse) (GetHeaders, Headers, getHeaders, getResponse)
import Servant.API.Status
(statusFromNat)
import qualified Servant.Types.SourceT as S import qualified Servant.Types.SourceT as S
import Servant.API.TypeErrors
import Web.HttpApiData import Web.HttpApiData
(FromHttpApiData, parseHeader, parseQueryParam, parseUrlPiece, (FromHttpApiData, parseHeader, parseQueryParam, parseUrlPiece,
parseUrlPieces) parseUrlPieces)
import Data.Kind
(Type)
import Servant.Server.Internal.BasicAuth import Servant.Server.Internal.BasicAuth
import Servant.Server.Internal.Context import Servant.Server.Internal.Context
@ -109,6 +116,10 @@ import Servant.API.TypeLevel
(AtLeastOneFragment, FragmentUnique) (AtLeastOneFragment, FragmentUnique)
class HasServer api context where class HasServer api context where
-- | The type of a server for this API, given a monad to run effects in.
--
-- Note that the result kind is @*@, so it is /not/ a monad transformer, unlike
-- what the @T@ in the name might suggest.
type ServerT api (m :: * -> *) :: * type ServerT api (m :: * -> *) :: *
route :: route ::
@ -170,7 +181,7 @@ instance (HasServer a context, HasServer b context) => HasServer (a :<|> b) cont
-- > server = getBook -- > server = getBook
-- > where getBook :: Text -> Handler Book -- > where getBook :: Text -> Handler Book
-- > getBook isbn = ... -- > getBook isbn = ...
instance (KnownSymbol capture, FromHttpApiData a instance (KnownSymbol capture, FromHttpApiData a, Typeable a
, HasServer api context, SBoolI (FoldLenient mods) , HasServer api context, SBoolI (FoldLenient mods)
, HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
) )
@ -182,7 +193,7 @@ instance (KnownSymbol capture, FromHttpApiData a
hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
route Proxy context d = route Proxy context d =
CaptureRouter $ CaptureRouter [hint] $
route (Proxy :: Proxy api) route (Proxy :: Proxy api)
context context
(addCapture d $ \ txt -> withRequest $ \ request -> (addCapture d $ \ txt -> withRequest $ \ request ->
@ -194,6 +205,7 @@ instance (KnownSymbol capture, FromHttpApiData a
where where
rep = typeRep (Proxy :: Proxy Capture') rep = typeRep (Proxy :: Proxy Capture')
formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context) formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
hint = CaptureHint (T.pack $ symbolVal $ Proxy @capture) (typeRep (Proxy :: Proxy a))
-- | If you use 'CaptureAll' in one of the endpoints for your API, -- | If you use 'CaptureAll' in one of the endpoints for your API,
-- this automatically requires your server-side handler to be a -- this automatically requires your server-side handler to be a
@ -212,7 +224,7 @@ instance (KnownSymbol capture, FromHttpApiData a
-- > server = getSourceFile -- > server = getSourceFile
-- > where getSourceFile :: [Text] -> Handler Book -- > where getSourceFile :: [Text] -> Handler Book
-- > getSourceFile pathSegments = ... -- > getSourceFile pathSegments = ...
instance (KnownSymbol capture, FromHttpApiData a instance (KnownSymbol capture, FromHttpApiData a, Typeable a
, HasServer api context , HasServer api context
, HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
) )
@ -224,7 +236,7 @@ instance (KnownSymbol capture, FromHttpApiData a
hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
route Proxy context d = route Proxy context d =
CaptureAllRouter $ CaptureAllRouter [hint] $
route (Proxy :: Proxy api) route (Proxy :: Proxy api)
context context
(addCapture d $ \ txts -> withRequest $ \ request -> (addCapture d $ \ txts -> withRequest $ \ request ->
@ -235,6 +247,43 @@ instance (KnownSymbol capture, FromHttpApiData a
where where
rep = typeRep (Proxy :: Proxy CaptureAll) rep = typeRep (Proxy :: Proxy CaptureAll)
formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context) formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
hint = CaptureHint (T.pack $ symbolVal $ Proxy @capture) (typeRep (Proxy :: Proxy [a]))
-- | If you use 'WithResource' in one of the endpoints for your API Servant
-- will provide the handler for this endpoint an argument of the specified type.
-- The lifespan of this resource will be automatically managed by Servant. This
-- resource will be created before the handler starts and it will be destoyed
-- after it ends. A new resource is created for each request to the endpoint.
-- The creation and destruction are done using a 'Data.Acquire.Acquire'
-- provided via server 'Context'.
--
-- Example
--
-- > type MyApi = WithResource Handle :> "writeToFile" :> Post '[JSON] NoContent
-- >
-- > server :: Server MyApi
-- > server = writeToFile
-- > where writeToFile :: (ReleaseKey, Handle) -> Handler NoContent
-- > writeToFile (_, h) = hPutStrLn h "message"
--
-- In addition to the resource, the handler will also receive a 'ReleaseKey'
-- which can be used to deallocate the resource before the end of the request
-- if desired.
instance (HasServer api ctx, HasContextEntry ctx (Acquire a))
=> HasServer (WithResource a :> api) ctx where
type ServerT (WithResource a :> api) m = (ReleaseKey, a) -> ServerT api m
hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy @api) pc nt . s
route Proxy context d = route (Proxy @api) context (d `addParameterCheck` allocateResource)
where
allocateResource :: DelayedIO (ReleaseKey, a)
allocateResource = DelayedIO $ lift $ allocateAcquire (getContextEntry context)
allowedMethodHead :: Method -> Request -> Bool allowedMethodHead :: Method -> Request -> Bool
allowedMethodHead method request = method == methodGet && requestMethod request == methodHead allowedMethodHead method request = method == methodGet && requestMethod request == methodHead
@ -298,7 +347,7 @@ instance {-# OVERLAPPABLE #-}
route Proxy _ = methodRouter ([],) method (Proxy :: Proxy ctypes) status route Proxy _ = methodRouter ([],) method (Proxy :: Proxy ctypes) status
where method = reflectMethod (Proxy :: Proxy method) where method = reflectMethod (Proxy :: Proxy method)
status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) status = statusFromNat (Proxy :: Proxy status)
instance {-# OVERLAPPING #-} instance {-# OVERLAPPING #-}
( AllCTRender ctypes a, ReflectMethod method, KnownNat status ( AllCTRender ctypes a, ReflectMethod method, KnownNat status
@ -310,7 +359,7 @@ instance {-# OVERLAPPING #-}
route Proxy _ = methodRouter (\x -> (getHeaders x, getResponse x)) method (Proxy :: Proxy ctypes) status route Proxy _ = methodRouter (\x -> (getHeaders x, getResponse x)) method (Proxy :: Proxy ctypes) status
where method = reflectMethod (Proxy :: Proxy method) where method = reflectMethod (Proxy :: Proxy method)
status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) status = statusFromNat (Proxy :: Proxy status)
instance (ReflectMethod method) => instance (ReflectMethod method) =>
HasServer (NoContentVerb method) context where HasServer (NoContentVerb method) context where
@ -331,7 +380,7 @@ instance {-# OVERLAPPABLE #-}
route Proxy _ = streamRouter ([],) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype) route Proxy _ = streamRouter ([],) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)
where method = reflectMethod (Proxy :: Proxy method) where method = reflectMethod (Proxy :: Proxy method)
status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) status = statusFromNat (Proxy :: Proxy status)
instance {-# OVERLAPPING #-} instance {-# OVERLAPPING #-}
@ -345,7 +394,7 @@ instance {-# OVERLAPPING #-}
route Proxy _ = streamRouter (\x -> (getHeaders x, getResponse x)) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype) route Proxy _ = streamRouter (\x -> (getHeaders x, getResponse x)) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)
where method = reflectMethod (Proxy :: Proxy method) where method = reflectMethod (Proxy :: Proxy method)
status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) status = statusFromNat (Proxy :: Proxy status)
streamRouter :: forall ctype a c chunk env framing. (MimeRender ctype chunk, FramingRender framing, ToSourceIO chunk a) => streamRouter :: forall ctype a c chunk env framing. (MimeRender ctype chunk, FramingRender framing, ToSourceIO chunk a) =>
@ -812,38 +861,19 @@ instance (HasContextEntry context (NamedContext name subContext), HasServer subA
hoistServerWithContext _ _ nt s = hoistServerWithContext (Proxy :: Proxy subApi) (Proxy :: Proxy subContext) nt s hoistServerWithContext _ _ nt s = hoistServerWithContext (Proxy :: Proxy subApi) (Proxy :: Proxy subContext) nt s
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
-- TypeError helpers -- Custom type errors
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
-- | This instance catches mistakes when there are non-saturated -- Erroring instance for 'HasServer' when a combinator is not fully applied
-- type applications on LHS of ':>'. instance TypeError (PartialApplication
-- #if __GLASGOW_HASKELL__ >= 904
-- >>> serve (Proxy :: Proxy (Capture "foo" :> Get '[JSON] Int)) (error "...") @(Type -> [Type] -> Constraint)
-- ... #endif
-- ...Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'. HasServer arr) => HasServer ((arr :: a -> b) :> sub) context
-- ...Maybe you haven't applied enough arguments to
-- ...Capture' '[] "foo"
-- ...
--
-- >>> undefined :: Server (Capture "foo" :> Get '[JSON] Int)
-- ...
-- ...Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'.
-- ...Maybe you haven't applied enough arguments to
-- ...Capture' '[] "foo"
-- ...
--
instance TypeError (HasServerArrowKindError arr) => HasServer ((arr :: k -> l) :> api) context
where where
type ServerT (arr :> api) m = TypeError (HasServerArrowKindError arr) type ServerT (arr :> sub) _ = TypeError (PartialApplication (HasServer :: * -> [*] -> Constraint) arr)
-- it doesn't really matter what sub route we peak route = error "unreachable"
route _ _ _ = error "servant-server panic: impossible happened in HasServer (arr :> api)" hoistServerWithContext _ _ _ _ = error "unreachable"
hoistServerWithContext _ _ _ = id
-- Cannot have TypeError here, otherwise use of this symbol will error :)
type HasServerArrowKindError arr =
'Text "Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'."
':$$: 'Text "Maybe you haven't applied enough arguments to"
':$$: 'ShowType arr
-- | This instance prevents from accidentally using '->' instead of ':>' -- | This instance prevents from accidentally using '->' instead of ':>'
-- --
@ -878,6 +908,19 @@ type HasServerArrowTypeError a b =
':$$: 'Text "and" ':$$: 'Text "and"
':$$: 'ShowType b ':$$: 'ShowType b
-- Erroring instances for 'HasServer' for unknown API combinators
-- XXX: This omits the @context@ parameter, e.g.:
--
-- "There is no instance for HasServer (Bool :> …)". Do we care ?
instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub
#if __GLASGOW_HASKELL__ >= 904
@(Type -> [Type] -> Constraint)
#endif
HasServer ty) => HasServer (ty :> sub) context
instance {-# OVERLAPPABLE #-} TypeError (NoInstanceFor (HasServer api context)) => HasServer api context
-- | Ignore @'Fragment'@ in server handlers. -- | Ignore @'Fragment'@ in server handlers.
-- See <https://ietf.org/rfc/rfc2616.html#section-15.1.3> for more details. -- See <https://ietf.org/rfc/rfc2616.html#section-15.1.3> for more details.
-- --

View File

@ -13,17 +13,19 @@ import Control.Monad.Base
import Control.Monad.Catch import Control.Monad.Catch
(MonadCatch, MonadMask, MonadThrow) (MonadCatch, MonadMask, MonadThrow)
import Control.Monad.Error.Class import Control.Monad.Error.Class
(MonadError) (MonadError, throwError)
import Control.Monad.IO.Class import Control.Monad.IO.Class
(MonadIO) (MonadIO)
import Control.Monad.Trans.Control import Control.Monad.Trans.Control
(MonadBaseControl (..)) (MonadBaseControl (..))
import Control.Monad.Trans.Except import Control.Monad.Trans.Except
(ExceptT, runExceptT) (ExceptT, runExceptT)
import Data.String
(fromString)
import GHC.Generics import GHC.Generics
(Generic) (Generic)
import Servant.Server.Internal.ServerError import Servant.Server.Internal.ServerError
(ServerError) (ServerError, errBody, err500)
newtype Handler a = Handler { runHandler' :: ExceptT ServerError IO a } newtype Handler a = Handler { runHandler' :: ExceptT ServerError IO a }
deriving deriving
@ -32,6 +34,9 @@ newtype Handler a = Handler { runHandler' :: ExceptT ServerError IO a }
, MonadThrow, MonadCatch, MonadMask , MonadThrow, MonadCatch, MonadMask
) )
instance MonadFail Handler where
fail str = throwError err500 { errBody = fromString str }
instance MonadBase IO Handler where instance MonadBase IO Handler where
liftBase = Handler . liftBase liftBase = Handler . liftBase

View File

@ -9,12 +9,16 @@ import Prelude.Compat
import Data.Function import Data.Function
(on) (on)
import Data.List
(nub)
import Data.Map import Data.Map
(Map) (Map)
import qualified Data.Map as M import qualified Data.Map as M
import Data.Text import Data.Text
(Text) (Text)
import qualified Data.Text as T import qualified Data.Text as T
import Data.Typeable
(TypeRep)
import Network.Wai import Network.Wai
(Response, pathInfo) (Response, pathInfo)
import Servant.Server.Internal.ErrorFormatter import Servant.Server.Internal.ErrorFormatter
@ -24,6 +28,21 @@ import Servant.Server.Internal.ServerError
type Router env = Router' env RoutingApplication type Router env = Router' env RoutingApplication
-- | Holds information about pieces of url that are captured as variables.
data CaptureHint = CaptureHint
{ captureName :: Text
-- ^ Holds the name of the captured variable
, captureType :: TypeRep
-- ^ Holds the type of the captured variable
}
deriving (Show, Eq)
toCaptureTag :: CaptureHint -> Text
toCaptureTag hint = captureName hint <> "::" <> (T.pack . show) (captureType hint)
toCaptureTags :: [CaptureHint] -> Text
toCaptureTags hints = "<" <> T.intercalate "|" (map toCaptureTag hints) <> ">"
-- | Internal representation of a router. -- | Internal representation of a router.
-- --
-- The first argument describes an environment type that is -- The first argument describes an environment type that is
@ -36,12 +55,23 @@ data Router' env a =
-- ^ the map contains routers for subpaths (first path component used -- ^ the map contains routers for subpaths (first path component used
-- for lookup and removed afterwards), the list contains handlers -- for lookup and removed afterwards), the list contains handlers
-- for the empty path, to be tried in order -- for the empty path, to be tried in order
| CaptureRouter (Router' (Text, env) a) | CaptureRouter [CaptureHint] (Router' (Text, env) a)
-- ^ first path component is passed to the child router in its -- ^ first path component is passed to the child router in its
-- environment and removed afterwards -- environment and removed afterwards.
| CaptureAllRouter (Router' ([Text], env) a) -- The first argument is a list of hints for all variables that can be
-- captured by the router. The fact that it is a list is counter-intuitive,
-- because the 'Capture' combinator only allows to capture a single varible,
-- with a single name and a single type. However, the 'choice' smart
-- constructor may merge two 'Capture' combinators with different hints, thus
-- forcing the type to be '[CaptureHint]'.
-- Because 'CaptureRouter' is built from a 'Capture' combinator, the list of
-- hints should always be non-empty.
| CaptureAllRouter [CaptureHint] (Router' ([Text], env) a)
-- ^ all path components are passed to the child router in its -- ^ all path components are passed to the child router in its
-- environment and are removed afterwards -- environment and are removed afterwards
-- The first argument is a hint for the list of variables that can be
-- captured by the router. Note that the 'captureType' field of the hint
-- should always be '[a]' for some 'a'.
| RawRouter (env -> a) | RawRouter (env -> a)
-- ^ to be used for routes we do not know anything about -- ^ to be used for routes we do not know anything about
| Choice (Router' env a) (Router' env a) | Choice (Router' env a) (Router' env a)
@ -69,8 +99,8 @@ leafRouter l = StaticRouter M.empty [l]
choice :: Router' env a -> Router' env a -> Router' env a choice :: Router' env a -> Router' env a -> Router' env a
choice (StaticRouter table1 ls1) (StaticRouter table2 ls2) = choice (StaticRouter table1 ls1) (StaticRouter table2 ls2) =
StaticRouter (M.unionWith choice table1 table2) (ls1 ++ ls2) StaticRouter (M.unionWith choice table1 table2) (ls1 ++ ls2)
choice (CaptureRouter router1) (CaptureRouter router2) = choice (CaptureRouter hints1 router1) (CaptureRouter hints2 router2) =
CaptureRouter (choice router1 router2) CaptureRouter (nub $ hints1 ++ hints2) (choice router1 router2)
choice router1 (Choice router2 router3) = Choice (choice router1 router2) router3 choice router1 (Choice router2 router3) = Choice (choice router1 router2) router3
choice router1 router2 = Choice router1 router2 choice router1 router2 = Choice router1 router2
@ -84,7 +114,11 @@ choice router1 router2 = Choice router1 router2
-- --
data RouterStructure = data RouterStructure =
StaticRouterStructure (Map Text RouterStructure) Int StaticRouterStructure (Map Text RouterStructure) Int
| CaptureRouterStructure RouterStructure | CaptureRouterStructure [CaptureHint] RouterStructure
-- ^ The first argument holds information about variables
-- that are captured by the router. There may be several hints
-- if several routers have been aggregated by the 'choice'
-- smart constructor.
| RawRouterStructure | RawRouterStructure
| ChoiceStructure RouterStructure RouterStructure | ChoiceStructure RouterStructure RouterStructure
deriving (Eq, Show) deriving (Eq, Show)
@ -98,11 +132,11 @@ data RouterStructure =
routerStructure :: Router' env a -> RouterStructure routerStructure :: Router' env a -> RouterStructure
routerStructure (StaticRouter m ls) = routerStructure (StaticRouter m ls) =
StaticRouterStructure (fmap routerStructure m) (length ls) StaticRouterStructure (fmap routerStructure m) (length ls)
routerStructure (CaptureRouter router) = routerStructure (CaptureRouter hints router) =
CaptureRouterStructure $ CaptureRouterStructure hints $
routerStructure router routerStructure router
routerStructure (CaptureAllRouter router) = routerStructure (CaptureAllRouter hints router) =
CaptureRouterStructure $ CaptureRouterStructure hints $
routerStructure router routerStructure router
routerStructure (RawRouter _) = routerStructure (RawRouter _) =
RawRouterStructure RawRouterStructure
@ -114,8 +148,8 @@ routerStructure (Choice r1 r2) =
-- | Compare the structure of two routers. -- | Compare the structure of two routers.
-- --
sameStructure :: Router' env a -> Router' env b -> Bool sameStructure :: Router' env a -> Router' env b -> Bool
sameStructure r1 r2 = sameStructure router1 router2 =
routerStructure r1 == routerStructure r2 routerStructure router1 == routerStructure router2
-- | Provide a textual representation of the -- | Provide a textual representation of the
-- structure of a router. -- structure of a router.
@ -126,7 +160,8 @@ routerLayout router =
where where
mkRouterLayout :: Bool -> RouterStructure -> [Text] mkRouterLayout :: Bool -> RouterStructure -> [Text]
mkRouterLayout c (StaticRouterStructure m n) = mkSubTrees c (M.toList m) n mkRouterLayout c (StaticRouterStructure m n) = mkSubTrees c (M.toList m) n
mkRouterLayout c (CaptureRouterStructure r) = mkSubTree c "<capture>" (mkRouterLayout False r) mkRouterLayout c (CaptureRouterStructure hints r) =
mkSubTree c (toCaptureTags hints) (mkRouterLayout False r)
mkRouterLayout c RawRouterStructure = mkRouterLayout c RawRouterStructure =
if c then ["├─ <raw>"] else ["└─ <raw>"] if c then ["├─ <raw>"] else ["└─ <raw>"]
mkRouterLayout c (ChoiceStructure r1 r2) = mkRouterLayout c (ChoiceStructure r1 r2) =
@ -169,7 +204,7 @@ runRouterEnv fmt router env request respond =
-> let request' = request { pathInfo = rest } -> let request' = request { pathInfo = rest }
in runRouterEnv fmt router' env request' respond in runRouterEnv fmt router' env request' respond
_ -> respond $ Fail $ fmt request _ -> respond $ Fail $ fmt request
CaptureRouter router' -> CaptureRouter _ router' ->
case pathInfo request of case pathInfo request of
[] -> respond $ Fail $ fmt request [] -> respond $ Fail $ fmt request
-- This case is to handle trailing slashes. -- This case is to handle trailing slashes.
@ -177,7 +212,7 @@ runRouterEnv fmt router env request respond =
first : rest first : rest
-> let request' = request { pathInfo = rest } -> let request' = request { pathInfo = rest }
in runRouterEnv fmt router' (first, env) request' respond in runRouterEnv fmt router' (first, env) request' respond
CaptureAllRouter router' -> CaptureAllRouter _ router' ->
let segments = pathInfo request let segments = pathInfo request
request' = request { pathInfo = [] } request' = request { pathInfo = [] }
in runRouterEnv fmt router' (segments, env) request' respond in runRouterEnv fmt router' (segments, env) request' respond

View File

@ -9,7 +9,9 @@ import Control.Monad
import Data.Proxy import Data.Proxy
(Proxy (..)) (Proxy (..))
import Data.Text import Data.Text
(unpack) (Text, unpack)
import Data.Typeable
(typeRep)
import Network.HTTP.Types import Network.HTTP.Types
(Status (..)) (Status (..))
import Network.Wai import Network.Wai
@ -27,6 +29,7 @@ spec :: Spec
spec = describe "Servant.Server.Internal.Router" $ do spec = describe "Servant.Server.Internal.Router" $ do
routerSpec routerSpec
distributivitySpec distributivitySpec
serverLayoutSpec
routerSpec :: Spec routerSpec :: Spec
routerSpec = do routerSpec = do
@ -51,7 +54,7 @@ routerSpec = do
toApp = toApplication . runRouter (const err404) toApp = toApplication . runRouter (const err404)
cap :: Router () cap :: Router ()
cap = CaptureRouter $ cap = CaptureRouter [hint] $
let delayed = addCapture (emptyDelayed $ Route pure) (const $ delayedFail err400) let delayed = addCapture (emptyDelayed $ Route pure) (const $ delayedFail err400)
in leafRouter in leafRouter
$ \env req res -> $ \env req res ->
@ -59,6 +62,9 @@ routerSpec = do
. const . const
$ Route success $ Route success
hint :: CaptureHint
hint = CaptureHint "anything" $ typeRep (Proxy :: Proxy ())
router :: Router () router :: Router ()
router = leafRouter (\_ _ res -> res $ Route success) router = leafRouter (\_ _ res -> res $ Route success)
`Choice` cap `Choice` cap
@ -98,12 +104,30 @@ distributivitySpec =
it "properly handles mixing static paths at different levels" $ do it "properly handles mixing static paths at different levels" $ do
level `shouldHaveSameStructureAs` levelRef level `shouldHaveSameStructureAs` levelRef
serverLayoutSpec :: Spec
serverLayoutSpec =
describe "serverLayout" $ do
it "correctly represents the example API" $ do
exampleLayout `shouldHaveLayout` expectedExampleLayout
it "aggregates capture hints when different" $ do
captureDifferentTypes `shouldHaveLayout` expectedCaptureDifferentTypes
it "nubs capture hints when equal" $ do
captureSameType `shouldHaveLayout` expectedCaptureSameType
it "properly displays CaptureAll hints" $ do
captureAllLayout `shouldHaveLayout` expectedCaptureAllLayout
shouldHaveSameStructureAs :: shouldHaveSameStructureAs ::
(HasServer api1 '[], HasServer api2 '[]) => Proxy api1 -> Proxy api2 -> Expectation (HasServer api1 '[], HasServer api2 '[]) => Proxy api1 -> Proxy api2 -> Expectation
shouldHaveSameStructureAs p1 p2 = shouldHaveSameStructureAs p1 p2 =
unless (sameStructure (makeTrivialRouter p1) (makeTrivialRouter p2)) $ unless (sameStructure (makeTrivialRouter p1) (makeTrivialRouter p2)) $
expectationFailure ("expected:\n" ++ unpack (layout p2) ++ "\nbut got:\n" ++ unpack (layout p1)) expectationFailure ("expected:\n" ++ unpack (layout p2) ++ "\nbut got:\n" ++ unpack (layout p1))
shouldHaveLayout ::
(HasServer api '[]) => Proxy api -> Text -> Expectation
shouldHaveLayout p l =
unless (routerLayout (makeTrivialRouter p) == l) $
expectationFailure ("expected:\n" ++ unpack l ++ "\nbut got:\n" ++ unpack (layout p))
makeTrivialRouter :: (HasServer layout '[]) => Proxy layout -> Router () makeTrivialRouter :: (HasServer layout '[]) => Proxy layout -> Router ()
makeTrivialRouter p = makeTrivialRouter p =
route p EmptyContext (emptyDelayed (FailFatal err501)) route p EmptyContext (emptyDelayed (FailFatal err501))
@ -144,12 +168,12 @@ staticRef = Proxy
-- structure: -- structure:
type Dynamic = type Dynamic =
"a" :> Capture "foo" Int :> "b" :> End "a" :> Capture "foo" Int :> "b" :> End
:<|> "a" :> Capture "bar" Bool :> "c" :> End :<|> "a" :> Capture "foo" Int :> "c" :> End
:<|> "a" :> Capture "baz" Char :> "d" :> End :<|> "a" :> Capture "foo" Int :> "d" :> End
type DynamicRef = type DynamicRef =
"a" :> Capture "anything" () :> "a" :> Capture "foo" Int :>
("b" :> End :<|> "c" :> End :<|> "d" :> End) ("b" :> End :<|> "c" :> End :<|> "d" :> End)
dynamic :: Proxy Dynamic dynamic :: Proxy Dynamic
@ -339,3 +363,100 @@ level = Proxy
levelRef :: Proxy LevelRef levelRef :: Proxy LevelRef
levelRef = Proxy levelRef = Proxy
-- The example API for the 'layout' function.
-- Should get factorized by the 'choice' smart constructor.
type ExampleLayout =
"a" :> "d" :> Get '[JSON] NoContent
:<|> "b" :> Capture "x" Int :> Get '[JSON] Bool
:<|> "c" :> Put '[JSON] Bool
:<|> "a" :> "e" :> Get '[JSON] Int
:<|> "b" :> Capture "x" Int :> Put '[JSON] Bool
:<|> Raw
exampleLayout :: Proxy ExampleLayout
exampleLayout = Proxy
-- The expected representation of the example API layout
--
expectedExampleLayout :: Text
expectedExampleLayout =
"/\n\
\ a/\n\
\ d/\n\
\ \n\
\ e/\n\
\ \n\
\ b/\n\
\ <x::Int>/\n\
\ \n\
\ \n\
\ \n\
\ c/\n\
\ \n\
\\n\
\ <raw>\n"
-- A capture API with all capture types being the same
--
type CaptureSameType =
"a" :> Capture "foo" Int :> "b" :> End
:<|> "a" :> Capture "foo" Int :> "c" :> End
:<|> "a" :> Capture "foo" Int :> "d" :> End
captureSameType :: Proxy CaptureSameType
captureSameType = Proxy
-- The expected representation of the CaptureSameType API layout.
--
expectedCaptureSameType :: Text
expectedCaptureSameType =
"/\n\
\ a/\n\
\ <foo::Int>/\n\
\ b/\n\
\ \n\
\ c/\n\
\ \n\
\ d/\n\
\ \n"
-- A capture API capturing different types
--
type CaptureDifferentTypes =
"a" :> Capture "foo" Int :> "b" :> End
:<|> "a" :> Capture "bar" Bool :> "c" :> End
:<|> "a" :> Capture "baz" Char :> "d" :> End
captureDifferentTypes :: Proxy CaptureDifferentTypes
captureDifferentTypes = Proxy
-- The expected representation of the CaptureDifferentTypes API layout.
--
expectedCaptureDifferentTypes :: Text
expectedCaptureDifferentTypes =
"/\n\
\ a/\n\
\ <foo::Int|bar::Bool|baz::Char>/\n\
\ b/\n\
\ \n\
\ c/\n\
\ \n\
\ d/\n\
\ \n"
-- An API with a CaptureAll part
type CaptureAllLayout = "a" :> CaptureAll "foos" Int :> End
captureAllLayout :: Proxy CaptureAllLayout
captureAllLayout = Proxy
-- The expected representation of the CaptureAllLayout API.
--
expectedCaptureAllLayout :: Text
expectedCaptureAllLayout =
"/\n\
\ a/\n\
\ <foos::[Int]>/\n\
\ \n"

View File

@ -21,6 +21,8 @@ import Control.Monad.Error.Class
(MonadError (..)) (MonadError (..))
import Data.Aeson import Data.Aeson
(FromJSON, ToJSON, decode', encode) (FromJSON, ToJSON, decode', encode)
import Data.Acquire
(Acquire, mkAcquire)
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64 as Base64 import qualified Data.ByteString.Base64 as Base64
import Data.Char import Data.Char
@ -81,8 +83,11 @@ import Servant.Server.Internal.Context
-- This declaration simply checks that all instances are in place. -- This declaration simply checks that all instances are in place.
_ = serveWithContext comprehensiveAPI comprehensiveApiContext _ = serveWithContext comprehensiveAPI comprehensiveApiContext
comprehensiveApiContext :: Context '[NamedContext "foo" '[]] comprehensiveApiContext :: Context '[NamedContext "foo" '[], Acquire Int]
comprehensiveApiContext = NamedContext EmptyContext :. EmptyContext comprehensiveApiContext =
NamedContext EmptyContext :.
mkAcquire (pure 10) (\_ -> pure ()) :.
EmptyContext
-- * Specs -- * Specs

View File

@ -0,0 +1,143 @@
1.1.9
-------
* Support `servant-0.18`
1.1.8
-------
* Support `servant-0.17`
1.1.7.1
-------
* Support `swagger2-2.4`
1.1.7
-----
* Support servant-0.15
- support for 'Stream' and 'StreamBody' combinators
- orphan 'ToSchema (SourceT m a)' instance
* Fix BodyTypes to work with generalized ReqBody'
[#88](https://github.com/haskell-servant/servant-swagger/pull/88)
1.1.6
-----
* Fixes:
* `validateEveryToJSON` now prints validation errors
* Notes:
* GHC-8.6 compatible release
1.1.5
-----
* Notes:
* `servant-0.13` compatible release
* Drops compatibility with previous `servant` versions.
1.1.4
-----
* Notes:
* `servant-0.12` compatible release
1.1.3.1
---
* Notes:
* GHC-8.2 compatible release
1.1.3
---
* Notes:
* `servant-0.11` compatible release
1.1.2.1
---
* Notes:
* `servant-0.10` compatible release
1.1.2
---
* Minor fixes:
* Support for aeson-1, insert-ordered-containers-0.2
* CaptureAll instance
1.1.1
---
* Minor fixes:
* Fix `unused-imports` and `unused-foralls` warnings;
* Fix tests to match `swagger2-2.1.1` (add `example` property for `UTCTime` schema).
1.1
---
* Breaking changes:
* Requires `swagger2 >= 2.1`
* Requires `servant >= 0.5`
* Notes:
* GHC-8.0 compatible release
1.0.3
---
* Fixes:
* Improve compile-time performance of `BodyTypes` even further (see [18e0d95](https://github.com/haskell-servant/servant-swagger/commit/18e0d95ef6fe9076dd9621cb515d8d1a189f71d3))!
1.0.2
---
* Minor changes:
* Add GHC 7.8 support (see [#26](https://github.com/haskell-servant/servant-swagger/pull/26)).
* Fixes:
* Improve compile-time performance of `BodyTypes` (see [#25](https://github.com/haskell-servant/servant-swagger/issues/25)).
1.0.1
---
* Fixes:
* Stop using `Data.Swagger.Internal`;
* Documentation fixes (links to examples).
1.0
---
* Major changes (see [#24](https://github.com/haskell-servant/servant-swagger/pull/24)):
* Switch to `swagger2-2.*`;
* Add automatic `ToJSON`/`ToSchema` validation tests;
* Add great documentation;
* Export some type-level functions for servant API.
* Minor changes:
* Rework Todo API example;
* Stop exporting `ToResponseHeader`, `AllAccept` and `AllToResponseHeader` (see [bd50db4](https://github.com/haskell-servant/servant-swagger/commit/bd50db48ca6a106e4366560ded70932d409de1e2));
* Change maintainer, update authors/copyrights (see [1a62681](https://github.com/haskell-servant/servant-swagger/commit/1a6268101dc826a92c42e832e402e251c0d32147));
* Include changelog and example files into `extra-source-files`.
0.1.2
---
* Fixes:
* Fix default spec for `ReqBody` param to be required (see [#22](https://github.com/haskell-servant/servant-swagger/issues/22));
* Set version bounds for `swagger2`.
0.1.1
---
* Fixes:
* Fix `subOperations` to filter endpoints also by method (see [#18](https://github.com/haskell-servant/servant-swagger/issues/18));
* Fix response schema in `ToSwagger` instance for `Header` (see [b59e557](https://github.com/haskell-servant/servant-swagger/commit/b59e557a05bc2669332c52b397879e7598747b82)).
0.1
---
* Major changes
* Use `swagger2` for data model (see [#9](https://github.com/dmjio/servant-swagger/pull/9)); this changes almost everything.

Some files were not shown because too many files have changed in this diff Show More